factor out Annex.AutoMerge from Command.Sync

1 files changed, 3 insertions, 162 deletions

diff --git a/Command/Sync.hs b/Command/Sync.hs
index 838e40f48..bd0e57904 100644
--- a/Command/Sync.hs
+++ b/Command/Sync.hs
@@ -12,26 +12,18 @@ import Common.Annex
 import Command
 import qualified Annex
 import qualified Annex.Branch
-import qualified Annex.Queue
 import qualified Remote
 import qualified Types.Remote as Remote
 import Annex.Direct
-import Annex.CatFile
-import Annex.Link
 import Annex.Hook
 import qualified Git.Command
 import qualified Git.LsFiles as LsFiles
-import qualified Git.UpdateIndex as UpdateIndex
-import qualified Git.Merge
 import qualified Git.Branch
 import qualified Git.Ref
 import qualified Git
-import Git.Types (BlobType(..))
 import qualified Types.Remote
 import qualified Remote.Git
 import Config
-import Annex.ReplaceFile
-import Git.FileMode
 import Annex.Wanted
 import Annex.Content
 import Command.Get (getKeyFile')
@@ -39,9 +31,8 @@ import qualified Command.Move
 import Logs.Location
 import Annex.Drop
 import Annex.UUID
-import Annex.VariantFile
+import Annex.AutoMerge
 
-import qualified Data.Set as S
 import Control.Concurrent.MVar
 
 def :: [Command]
@@ -178,7 +169,7 @@ mergeLocal (Just branch) = go =<< needmerge
 	go False = stop
 	go True = do
 		showStart "merge" $ Git.Ref.describe syncbranch
-		next $ next $ mergeFrom syncbranch
+		next $ next $ autoMergeFrom syncbranch
 
 pushLocal :: Maybe Git.Ref -> CommandStart
 pushLocal Nothing = stop
@@ -225,7 +216,7 @@ mergeRemote remote b = case b of
 		and <$> mapM merge (branchlist branch)
 	Just _ -> and <$> (mapM merge =<< tomerge (branchlist b))
   where
-	merge = mergeFrom . remoteBranch remote
+	merge = autoMergeFrom . remoteBranch remote
 	tomerge = filterM (changed remote)
 	branchlist Nothing = []
 	branchlist (Just branch) = [branch, syncBranch branch]
@@ -306,156 +297,6 @@ mergeAnnex = do
 	void Annex.Branch.forceUpdate
 	stop
 
-{- Merges from a branch into the current branch. -}
-mergeFrom :: Git.Ref -> Annex Bool
-mergeFrom branch = do
-	showOutput
-	ifM isDirect
-		( maybe go godirect =<< inRepo Git.Branch.current
-		, go
-		)
-  where
-	go = inRepo (Git.Merge.mergeNonInteractive branch) <||> resolveMerge branch
-	godirect currbranch = do
-		old <- inRepo $ Git.Ref.sha currbranch
-		d <- fromRepo gitAnnexMergeDir
-		r <- inRepo (mergeDirect d branch) <||> resolveMerge branch
-		new <- inRepo $ Git.Ref.sha currbranch
-		case (old, new) of
-			(Just oldsha, Just newsha) ->
-				mergeDirectCleanup d oldsha newsha
-			_ -> noop
-		return r
-
-{- Resolves a conflicted merge. It's important that any conflicts be
- - resolved in a way that itself avoids later merge conflicts, since
- - multiple repositories may be doing this concurrently.
- -
- - Only annexed files are resolved; other files are left for the user to
- - handle.
- -
- - This uses the Keys pointed to by the files to construct new
- - filenames. So when both sides modified file foo, 
- - it will be deleted, and replaced with files foo.variant-A and
- - foo.variant-B.
- -
- - On the other hand, when one side deleted foo, and the other modified it,
- - it will be deleted, and the modified version stored as file
- - foo.variant-A (or B).
- -
- - It's also possible that one side has foo as an annexed file, and
- - the other as a directory or non-annexed file. The annexed file
- - is renamed to resolve the merge, and the other object is preserved as-is.
- -
- - In indirect mode, the merge is resolved in the work tree and files
- - staged, to clean up from a conflicted merge that was run in the work
- - tree. In direct mode, the work tree is not touched here; files are 
- - staged to the index, and written to the gitAnnexMergeDir, and later
- - mergeDirectCleanup handles updating the work tree.
- -}
-resolveMerge :: Git.Ref -> Annex Bool
-resolveMerge branch = do
-	top <- fromRepo Git.repoPath
-	(fs, cleanup) <- inRepo (LsFiles.unmerged [top])
-	mergedfs <- catMaybes <$> mapM (resolveMerge' branch) fs
-	let merged = not (null mergedfs)
-	void $ liftIO cleanup
-
-	unlessM isDirect $ do
-		(deleted, cleanup2) <- inRepo (LsFiles.deleted [top])
-		unless (null deleted) $
-			Annex.Queue.addCommand "rm" [Params "--quiet -f --"] deleted
-		void $ liftIO cleanup2
-
-	when merged $ do
-		unlessM isDirect $
-			cleanConflictCruft mergedfs top
-		Annex.Queue.flush
-		void $ inRepo $ Git.Command.runBool
-			[ Param "commit"
-			, Param "-m"
-			, Param "git-annex automatic merge conflict fix"
-			]
-		showLongNote "Merge conflict was automatically resolved; you may want to examine the result."
-	return merged
-
-resolveMerge' :: Git.Ref -> LsFiles.Unmerged -> Annex (Maybe FilePath)
-resolveMerge' branch u
-	| mergeable LsFiles.valUs && mergeable LsFiles.valThem = do
-		kus <- getKey LsFiles.valUs
-		kthem <- getKey LsFiles.valThem
-		case (kus, kthem) of
-			-- Both sides of conflict are annexed files
-			(Just keyUs, Just keyThem) -> do
-				unstageoldfile
-				if keyUs == keyThem
-					then makelink keyUs
-					else do
-						makelink keyUs
-						makelink keyThem
-				return $ Just file
-			-- Our side is annexed, other side is not.
-			(Just keyUs, Nothing) -> do
-				unstageoldfile
-				whenM isDirect $
-					stagefromdirectmergedir file
-				makelink keyUs
-				return $ Just file
-			-- Our side is not annexed, other side is.
-			(Nothing, Just keyThem) -> do
-				unstageoldfile
-				makelink keyThem
-				return $ Just file
-			-- Neither side is annexed; cannot resolve.
-			(Nothing, Nothing) -> return Nothing
-	| otherwise = return Nothing
-  where
-	file = LsFiles.unmergedFile u
-	mergeable select = select (LsFiles.unmergedBlobType u)
-		`elem` [Just SymlinkBlob, Nothing]
-	makelink key = do
-		let dest = variantFile file key
-		l <- inRepo $ gitAnnexLink dest key
-		ifM isDirect
-			( do
-				d <- fromRepo gitAnnexMergeDir
-				replaceFile (d </> dest) $ makeAnnexLink l
-			, replaceFile dest $ makeAnnexLink l
-			)
-		stageSymlink dest =<< hashSymlink l
-	getKey select = case select (LsFiles.unmergedSha u) of
-		Nothing -> return Nothing
-		Just sha -> catKey sha symLinkMode
-
-	-- removing the conflicted file from cache clears the conflict
-	unstageoldfile = Annex.Queue.addCommand "rm" [Params "--quiet -f --cached --"] [file]
-
-	{- stage an item from the direct mode merge directory, which may
-	 - be a directory with arbitrary contents -}
-	stagefromdirectmergedir item = Annex.Queue.addUpdateIndex
-		=<< fromRepo (UpdateIndex.lsSubTree branch item)
-
-{- git-merge moves conflicting files away to files
- - named something like f~HEAD or f~branch, but the
- - exact name chosen can vary. Once the conflict is resolved,
- - this cruft can be deleted. To avoid deleting legitimate
- - files that look like this, only delete files that are
- - A) not staged in git and B) look like git-annex symlinks.
- -}
-cleanConflictCruft :: [FilePath] -> FilePath -> Annex ()
-cleanConflictCruft resolvedfs top = do
-	(fs, cleanup) <- inRepo $ LsFiles.notInRepo False [top]
-	mapM_ clean fs
-	void $ liftIO cleanup
-  where
-	clean f
-		| matchesresolved f = whenM (isJust <$> isAnnexLink f) $
-			liftIO $ nukeFile f
-		| otherwise = noop
-	s = S.fromList resolvedfs
-	matchesresolved f = S.member (base f) s
-	base f = reverse $ drop 1 $ dropWhile (/= '~') $ reverse f
-
 changed :: Remote -> Git.Ref -> Annex Bool
 changed remote b = do
 	let r = remoteBranch remote b