Merge branch 'automerge'

Command/Sync.hs

@@ -15,15 +15,22 @@ import Command
 import qualified Remote
 import qualified Annex
 import qualified Annex.Branch
+import qualified Annex.Queue
+import Annex.Content
+import Annex.CatFile
 import qualified Git.Command
+import qualified Git.LsFiles as LsFiles
 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 qualified Data.Map as M
+import qualified Data.ByteString.Lazy as L
+import Data.Hash.MD5
 
 def :: [Command]
 def = [command "sync" (paramOptional (paramRepeating paramRemote))
@@ -155,10 +162,104 @@ mergeAnnex = do
 	Annex.Branch.forceUpdate
 	stop
 
-mergeFrom :: Git.Ref -> CommandCleanup
+mergeFrom :: Git.Ref -> Annex Bool
 mergeFrom branch = do
 	showOutput
-	inRepo $ Git.Merge.mergeNonInteractive branch
+	ok <- inRepo $ Git.Merge.mergeNonInteractive branch
+	if ok
+		then return ok
+		else resolveMerge
+
+{- 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.KEYA and foo.KEYB.
+ -
+ - 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.KEYA (or KEYB).
+ -}
+resolveMerge :: Annex Bool
+resolveMerge = do
+	top <- fromRepo Git.repoPath
+	merged <- all id <$> (mapM resolveMerge' =<< inRepo (LsFiles.unmerged [top]))
+	when merged $ do
+		Annex.Queue.flush
+		void $ inRepo $ Git.Command.runBool "commit"
+			[Param "-m", Param "git-annex automatic merge conflict fix"]
+	return merged
+
+resolveMerge' :: LsFiles.Unmerged -> Annex Bool
+resolveMerge' u
+	| issymlink LsFiles.valUs && issymlink LsFiles.valThem =
+		withKey LsFiles.valUs $ \keyUs ->
+		withKey LsFiles.valThem $ \keyThem -> go keyUs keyThem
+	| otherwise = return False
+	where
+		go keyUs keyThem
+			| keyUs == keyThem = do
+				makelink keyUs
+				return True
+			| otherwise = do
+				liftIO $ nukeFile file
+				Annex.Queue.addCommand "rm" [Params "--quiet -f --"] [file]
+				makelink keyUs
+				makelink keyThem
+				return True
+		file = LsFiles.unmergedFile u
+		issymlink select = any (select (LsFiles.unmergedBlobType u) ==)
+			[Just SymlinkBlob, Nothing]
+		makelink (Just key) = do
+			let dest = mergeFile file key
+			l <- calcGitLink dest key
+			liftIO $ do
+				nukeFile dest
+				createSymbolicLink l dest
+			Annex.Queue.addCommand "add" [Param "--force", Param "--"] [dest]
+		makelink _ = noop
+		withKey select a = do
+			let msha = select $ LsFiles.unmergedSha u
+			case msha of
+				Nothing -> a Nothing
+				Just sha -> do
+					key <- fileKey . takeFileName
+						. encodeW8 . L.unpack 
+						<$> catObject sha
+					maybe (return False) (a . Just) key
+
+{- The filename to use when resolving a conflicted merge of a file,
+ - that points to a key.
+ -
+ - Something derived from the key needs to be included in the filename,
+ - but rather than exposing the whole key to the user, a very weak hash
+ - is used. There is a very real, although still unlikely, chance of
+ - conflicts using this hash.
+ -
+ - In the event that there is a conflict with the filename generated
+ - for some other key, that conflict will itself be handled by the
+ - conflicted merge resolution code. That case is detected, and the full
+ - key is used in the filename.
+ -}
+mergeFile :: FilePath -> Key -> FilePath
+mergeFile file key
+	| doubleconflict = go $ show key
+	| otherwise = go $ shortHash $ show key
+	where
+		varmarker = ".variant-"
+		doubleconflict = vermarker `isSuffixOf` (dropExtension file)
+		go v = takeDirectory file
+			</> dropExtension (takeFileName file)
+			++ varmarker ++ v
+			++ takeExtension file
+		
+shortHash :: String -> String
+shortHash = take 4 . md5s . encodeFilePath
 
 changed :: Remote -> Git.Ref -> Annex Bool
 changed remote b = do

Git/LsFiles.hs

@@ -13,6 +13,9 @@ module Git.LsFiles (
 	changedUnstaged,
 	typeChanged,
 	typeChangedStaged,
+	Conflicting(..),
+	Unmerged(..),
+	unmerged,
 ) where
 
 import Common
@@ -78,25 +81,75 @@ typeChanged' ps l repo = do
 		prefix = [Params "diff --name-only --diff-filter=T -z"]
 		suffix = Param "--" : map File l
 
+{- A item in conflict has two possible values.
+ - Either can be Nothing, when that side deleted the file. -}
+data Conflicting v = Conflicting
+	{ valUs :: Maybe v
+	, valThem :: Maybe v
+	} deriving (Show)
+
 data Unmerged = Unmerged
 	{ unmergedFile :: FilePath
-	, unmergedBlobType :: BlobType
+	, unmergedBlobType :: Conflicting BlobType
-	, unmergedSha :: Sha
+	, unmergedSha :: Conflicting Sha
-	}
+	} deriving (Show)
 
 {- Returns a list of the files in the specified locations that have
- - unresolved merge conflicts. Each unmerged file will have duplicates
+ - unresolved merge conflicts.
- - in the list for each unmerged version (typically two). -}
+ -
+ - ls-files outputs multiple lines per conflicting file, each with its own
+ - stage number:
+ -   1 = old version, can be ignored
+ -   2 = us
+ -   3 = them
+ - If a line is omitted, that side deleted the file.
+ -}
 unmerged :: [FilePath] -> Repo -> IO [Unmerged]
-unmerged l repo = catMaybes . map parse <$> list repo
+unmerged l repo = reduceUnmerged [] . catMaybes . map parseUnmerged <$> list repo
 	where
-		list = pipeNullSplit $ Params "ls-files --unmerged -z --" : map File l
+		files = map File l
-		parse s
+		list = pipeNullSplit $ Params "ls-files --unmerged -z --" : files
-			| null file || length ws < 2 = Nothing
+
-			| otherwise = do
+data InternalUnmerged = InternalUnmerged
-				blobtype <- readBlobType (ws !! 0)
+	{ isus :: Bool
-				sha <- extractSha (ws !! 1)
+	, ifile :: FilePath
-				return $ Unmerged file blobtype sha
+	, iblobtype :: Maybe BlobType
-			where
+	, isha :: Maybe Sha
-				(metadata, file) = separate (== '\t') s
+	} deriving (Show)
-				ws = words metadata
+
+parseUnmerged :: String -> Maybe InternalUnmerged
+parseUnmerged s
+	| null file || length ws < 3 = Nothing
+	| otherwise = do
+		stage <- readish (ws !! 2) :: Maybe Int
+		unless (stage == 2 || stage == 3) $
+			fail undefined -- skip stage 1
+		blobtype <- readBlobType (ws !! 0)
+		sha <- extractSha (ws !! 1)
+		return $ InternalUnmerged (stage == 2) file (Just blobtype) (Just sha)
+	where
+		(metadata, file) = separate (== '\t') s
+		ws = words metadata
+
+reduceUnmerged :: [Unmerged] -> [InternalUnmerged] -> [Unmerged]
+reduceUnmerged c [] = c
+reduceUnmerged c (i:is) = reduceUnmerged (new:c) rest
+	where
+		(rest, sibi) = findsib i is
+		(blobtypeA, blobtypeB, shaA, shaB)
+			| isus i    = (iblobtype i, iblobtype sibi, isha i, isha sibi)
+			| otherwise = (iblobtype sibi, iblobtype i, isha sibi, isha i)
+		new = Unmerged
+			{ unmergedFile = ifile i
+			, unmergedBlobType = Conflicting blobtypeA blobtypeB
+			, unmergedSha = Conflicting shaA shaB
+			}
+		findsib templatei [] = ([], deleted templatei)
+		findsib templatei (l:ls)
+			| ifile l == ifile templatei = (ls, l)
+			| otherwise = (l:ls, deleted templatei)
+		deleted templatei = templatei
+			{ isus = not (isus templatei)
+			, iblobtype = Nothing
+			, isha = Nothing
+			}

Git/Types.hs

@@ -51,6 +51,7 @@ type Tag = Ref
 
 {- Types of objects that can be stored in git. -}
 data ObjectType = BlobObject | CommitObject | TreeObject
+	deriving (Eq)
 
 instance Show ObjectType where
 	show BlobObject = "blob"
@@ -65,6 +66,7 @@ readObjectType _ = Nothing
 
 {- Types of blobs. -}
 data BlobType = FileBlob | ExecutableBlob | SymlinkBlob
+	deriving (Eq)
 
 {- Git uses magic numbers to denote the type of a blob. -}
 instance Show BlobType where

debian/changelog

@@ -9,6 +9,7 @@ git-annex (3.20120625) UNRELEASED; urgency=low
   * Accept arbitrarily encoded repository filepaths etc when reading
     git config output. This fixes support for remotes with unusual characters
     in their names.
+  * sync: Automatically resolves merge conflicts.
 
  -- Joey Hess <joeyh@debian.org>  Mon, 25 Jun 2012 11:38:12 -0400
 

doc/git-annex.mdwn

@@ -135,6 +135,11 @@ subdirectories).
   commands to do each of those steps by hand, or if you don't want to
   worry about the details, you can use sync.
 
+  Merge conflicts are automatically resolved by sync. When two conflicting
+  versions of a file have been committed, both will be added to the tree,
+  under different filenames. For example, file "foo" would be replaced
+  with "foo.somekey" and "foo.otherkey".
+
   Note that syncing with a remote will not update the remote's working
   tree with changes made to the local repository. However, those changes
   are pushed to the remote, so can be merged into its working tree