git-annex/Assistant/Threads/Merger.hs
Joey Hess 4a92eac23e
assistant: Merge changes from refs/remotes/foo/master into master.
Previously, only sync branches were merged. This makes regular git push
into a repository watched by the assistant auto-merge.

While this does hardcode an assumption about what the remote tracking
branch is named, which some unusual git configurations won't match,
git-annex sync already made the same assumption.

Also, changed behavior when a tracking branch like
refs/remotes/synced/not/master is received. When on the master branch,
that used to get merged into it, but it's the tracking branch for
not/master, so should only be merged in when on the not/master branch.

This commit was sponsored by Ewen McNeill.
2017-06-07 16:17:46 -04:00

107 lines
3.1 KiB
Haskell

{- git-annex assistant git merge thread
-
- Copyright 2012-2017 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Threads.Merger where
import Assistant.Common
import Assistant.TransferQueue
import Assistant.BranchChange
import Utility.DirWatcher
import Utility.DirWatcher.Types
import qualified Annex.Branch
import qualified Git
import qualified Git.Branch
import qualified Git.Ref
import qualified Command.Sync
{- This thread watches for changes to .git/refs/, and handles incoming
- pushes. -}
mergeThread :: NamedThread
mergeThread = namedThread "Merger" $ do
g <- liftAnnex gitRepo
let dir = Git.localGitDir g </> "refs"
liftIO $ createDirectoryIfMissing True 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 dir (const False) True hooks id
debug ["watching", 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
when diverged $
queueDeferredDownloads "retrying deferred download" Later
| otherwise = mergecurrent
where
changedbranch = fileToBranch file
mergecurrent =
mergecurrent' =<< liftAnnex (join Command.Sync.getCurrBranch)
mergecurrent' currbranch@(Just b, _)
| changedbranch `isRelatedTo` b =
whenM (liftAnnex $ inRepo $ Git.Branch.changed b changedbranch) $ do
debug
[ "merging", Git.fromRef changedbranch
, "into", Git.fromRef b
]
void $ liftAnnex $ Command.Sync.merge
currbranch Command.Sync.mergeConfig
def
Git.Branch.AutomaticCommit
changedbranch
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 $ "refs" </> base
where
base = Prelude.last $ split "/refs/" f