git-annex/Assistant/Threads/Merger.hs
Joey Hess ff6b36c706
assistant prompt pushing of manual commits to remotes
assistant: When annex.autocommit is set, notice commits that the user makes
manually, and push them out to remotes promptly.

Sponsored-by: Boyd Stephen Smith Jr. on Patreon
2022-03-31 13:02:16 -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 = error
{- 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