factor out Annex.AutoMerge from Command.Sync

Annex/AutoMerge.hs

@@ -0,0 +1,179 @@
+{- git-annex automatic merge conflict resolution
+ -
+ - Copyright 2012-2014 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Annex.AutoMerge (autoMergeFrom) where
+
+import Common.Annex
+import qualified Annex.Queue
+import Annex.Direct
+import Annex.CatFile
+import Annex.Link
+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 Config
+import Annex.ReplaceFile
+import Git.FileMode
+import Annex.VariantFile
+
+import qualified Data.Set as S
+
+{- Merges from a branch into the current branch, with automatic merge
+ - conflict resolution. -}
+autoMergeFrom :: Git.Ref -> Annex Bool
+autoMergeFrom 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

Assistant/Threads/Merger.hs

@@ -17,7 +17,7 @@ import Utility.DirWatcher.Types
 import qualified Annex.Branch
 import qualified Git
 import qualified Git.Branch
-import qualified Command.Sync
+import Annex.AutoMerge
 import Annex.TaggedPush
 import Remote (remoteFromUUID)
 
@@ -83,7 +83,7 @@ onChange file
 				[ "merging", Git.fromRef changedbranch
 				, "into", Git.fromRef current
 				]
-			void $ liftAnnex  $ Command.Sync.mergeFrom changedbranch
+			void $ liftAnnex  $ autoMergeFrom changedbranch
 	mergecurrent _ = noop
 
 	handleDesynced = case fromTaggedBranch changedbranch of

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