git-annex/Assistant/Threads/Merger.hs
Joey Hess cd544e548b
filter out control characters in error messages
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
2023-04-10 13:50:51 -04:00

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