cd544e548b
giveup changed to filter out control characters. (It is too low level to make it use StringContainingQuotedPath.) error still does not, but it should only be used for internal errors, where the message is not attacker-controlled. Changed a lot of existing error to giveup when it is not strictly an internal error. Of course, other exceptions can still be thrown, either by code in git-annex, or a library, that include some attacker-controlled value. This does not guard against those. Sponsored-by: Noam Kremen on Patreon
131 lines
3.8 KiB
Haskell
131 lines
3.8 KiB
Haskell
{- git-annex assistant git merge thread
|
|
-
|
|
- Copyright 2012-2021 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Assistant.Threads.Merger where
|
|
|
|
import Assistant.Common
|
|
import Assistant.TransferQueue
|
|
import Assistant.BranchChange
|
|
import Assistant.Sync
|
|
import Utility.DirWatcher
|
|
import Utility.DirWatcher.Types
|
|
import Utility.Directory.Create
|
|
import Annex.CurrentBranch
|
|
import Assistant.Commits
|
|
import qualified Annex
|
|
import qualified Annex.Branch
|
|
import qualified Git
|
|
import qualified Git.Branch
|
|
import qualified Git.Ref
|
|
import qualified Command.Sync
|
|
|
|
import qualified System.FilePath.ByteString as P
|
|
|
|
{- This thread watches for changes to .git/refs/, and handles incoming
|
|
- pushes. -}
|
|
mergeThread :: NamedThread
|
|
mergeThread = namedThread "Merger" $ do
|
|
g <- liftAnnex gitRepo
|
|
let gitd = Git.localGitDir g
|
|
let dir = gitd P.</> "refs"
|
|
liftIO $ createDirectoryUnder [gitd] dir
|
|
let hook a = Just <$> asIO2 (runHandler a)
|
|
changehook <- hook onChange
|
|
errhook <- hook onErr
|
|
let hooks = mkWatchHooks
|
|
{ addHook = changehook
|
|
, modifyHook = changehook
|
|
, errHook = errhook
|
|
}
|
|
void $ liftIO $ watchDir (fromRawFilePath dir) (const False) True hooks id
|
|
debug ["watching", fromRawFilePath dir]
|
|
|
|
type Handler = FilePath -> Assistant ()
|
|
|
|
{- Runs an action handler.
|
|
-
|
|
- Exceptions are ignored, otherwise a whole thread could be crashed.
|
|
-}
|
|
runHandler :: Handler -> FilePath -> Maybe FileStatus -> Assistant ()
|
|
runHandler handler file _filestatus =
|
|
either (liftIO . print) (const noop) =<< tryIO <~> handler file
|
|
|
|
{- Called when there's an error with inotify. -}
|
|
onErr :: Handler
|
|
onErr = giveup
|
|
|
|
{- Called when a new branch ref is written, or a branch ref is modified.
|
|
-
|
|
- At startup, synthetic add events fire, causing this to run, but that's
|
|
- ok; it ensures that any changes pushed since the last time the assistant
|
|
- ran are merged in.
|
|
-}
|
|
onChange :: Handler
|
|
onChange file
|
|
| ".lock" `isSuffixOf` file = noop
|
|
| isAnnexBranch file = do
|
|
branchChanged
|
|
diverged <- liftAnnex Annex.Branch.forceUpdate >>= return . \case
|
|
u@(Annex.Branch.UpdateMade {}) -> Annex.Branch.refsWereMerged u
|
|
(Annex.Branch.UpdateFailedPermissions {}) -> True
|
|
when diverged $ do
|
|
updateExportTreeFromLogAll
|
|
queueDeferredDownloads "retrying deferred download" Later
|
|
| otherwise = mergecurrent
|
|
where
|
|
changedbranch = fileToBranch file
|
|
|
|
mergecurrent =
|
|
mergecurrent' =<< liftAnnex getCurrentBranch
|
|
mergecurrent' currbranch@(Just b, _)
|
|
| changedbranch `isRelatedTo` b = do
|
|
whenM (liftAnnex $ inRepo $ Git.Branch.changed b changedbranch) $ do
|
|
debug
|
|
[ "merging", Git.fromRef changedbranch
|
|
, "into", Git.fromRef b
|
|
]
|
|
void $ liftAnnex $ do
|
|
cmode <- annexCommitMode <$> Annex.getGitConfig
|
|
-- Allow merging unrelated histories.
|
|
mc <- Command.Sync.mergeConfig True
|
|
Command.Sync.merge
|
|
currbranch
|
|
mc
|
|
def
|
|
cmode
|
|
changedbranch
|
|
recordCommit
|
|
| changedbranch == b =
|
|
-- Record commit so the pusher pushes it out.
|
|
-- This makes sure pushes happen when
|
|
-- annex.autocommit=false
|
|
recordCommit
|
|
mergecurrent' _ = noop
|
|
|
|
{- Is the first branch a synced branch or remote tracking branch related
|
|
- to the second branch, which should be merged into it? -}
|
|
isRelatedTo :: Git.Ref -> Git.Ref -> Bool
|
|
isRelatedTo x y
|
|
| basex /= takeDirectory basex ++ "/" ++ basey = False
|
|
| "/synced/" `isInfixOf` Git.fromRef x = True
|
|
| "refs/remotes/" `isPrefixOf` Git.fromRef x = True
|
|
| otherwise = False
|
|
where
|
|
basex = Git.fromRef $ Git.Ref.base x
|
|
basey = Git.fromRef $ Git.Ref.base y
|
|
|
|
isAnnexBranch :: FilePath -> Bool
|
|
isAnnexBranch f = n `isSuffixOf` f
|
|
where
|
|
n = '/' : Git.fromRef Annex.Branch.name
|
|
|
|
fileToBranch :: FilePath -> Git.Ref
|
|
fileToBranch f = Git.Ref $ encodeBS $ "refs" </> base
|
|
where
|
|
base = Prelude.last $ split "/refs/" f
|