git-annex/Assistant/Threads/Merger.hs

{- git-annex assistant git merge thread
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Assistant.Threads.Merger where

import Common.Annex
import Assistant.ThreadedMonad
import Utility.DirWatcher
import Utility.Types.DirWatcher
import qualified Annex.Branch
import qualified Git
import qualified Git.Command
import qualified Git.Merge
import qualified Git.Branch
import qualified Command.Sync
import qualified Remote

{- This thread watches for changes to .git/refs/heads/synced/*,
 - which indicate incoming pushes. It merges those pushes into the
 - currently checked out branch. -}
mergeThread :: ThreadState -> IO ()
mergeThread st = do
	g <- runThreadState st $ fromRepo id
	let dir = Git.localGitDir g </> "refs" </> "heads" </> "synced"
	createDirectoryIfMissing True dir
	let hook a = Just $ runHandler g a
	-- XXX: For reasons currently unknown, using the ThreadState
	-- inside the watch hooks leads to a MVar deadlock.
	-- Luckily, we don't currently need to do that.
	let hooks = mkWatchHooks
		{ addHook = hook onAdd
		, errHook = hook onErr
		}
	watchDir dir (const False) hooks id

type Handler = Git.Repo -> FilePath -> Maybe FileStatus -> IO ()

{- Runs an action handler.
 -
 - Exceptions are ignored, otherwise a whole thread could be crashed.
 -}
runHandler :: Git.Repo -> Handler -> FilePath -> Maybe FileStatus -> IO ()
runHandler g handler file filestatus = void $ do
        either print (const noop) =<< tryIO go
        where
                go = handler g file filestatus

{- Called when there's an error with inotify. -}
onErr :: Handler
onErr _ msg _ = error msg

{- Called when a new branch ref is written.
 -
 - This relies on git's atomic method of updating branch ref files,
 - which is to first write the new file to .lock, and then rename it
 - over the old file. So, ignore .lock files, and the rename ensures
 - the watcher sees a new file being added on each update.
 -
 - 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.
 -}
onAdd :: Handler
onAdd g file _
	| ".lock" `isSuffixOf` file = noop
	| otherwise = do
		let changedbranch = Git.Ref $
			"refs" </> "heads" </> takeFileName file
		current <- Git.Branch.current g
		when (Just changedbranch == current) $
			void $ mergeBranch changedbranch g

mergeBranch :: Git.Ref -> Git.Repo -> IO Bool
mergeBranch = Git.Merge.mergeNonInteractive . Command.Sync.syncBranch

{- Manually pull from remotes and merge their branches. Called by the pusher
 - when a push fails, which can happen due to a remote not having pushed
 - changes to us. That could be because it doesn't have us as a remote, or
 - because the assistant is not running there, or other reasons. -}
manualPull :: Git.Ref -> [Remote] -> Annex ()
manualPull currentbranch remotes = do
	forM_ remotes $ \r ->
		inRepo $ Git.Command.runBool "fetch" [Param $ Remote.name r]
	Annex.Branch.forceUpdate
	forM_ remotes $ \r ->
		Command.Sync.mergeRemote r currentbranch