8be5a7269a
Both Command.Sync and Annex.Ingest had their own versions of this. The one in Annex.Ingest used Git.Branch.currentUnsafe, but does not seem to need it. That is only checking to see if it's in an adjusted unlocked branch, and when in an adjusted branch, the branch does in fact exist, so the added check that Git.Branch.current does is fine. This commit was sponsored by Denis Dzyubenko on Patreon.
110 lines
3.2 KiB
Haskell
110 lines
3.2 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 Assistant.Sync
|
|
import Utility.DirWatcher
|
|
import Utility.DirWatcher.Types
|
|
import Annex.CurrentBranch
|
|
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 $ do
|
|
updateExportTreeFromLogAll
|
|
queueDeferredDownloads "retrying deferred download" Later
|
|
| otherwise = mergecurrent
|
|
where
|
|
changedbranch = fileToBranch file
|
|
|
|
mergecurrent =
|
|
mergecurrent' =<< liftAnnex getCurrentBranch
|
|
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
|