diff --git a/Command/Sync.hs b/Command/Sync.hs index 1da6b0b812..06e1fd5c92 100644 --- a/Command/Sync.hs +++ b/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 diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs index 540503a28a..321913334b 100644 --- a/Git/LsFiles.hs +++ b/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 - , unmergedSha :: Sha - } + , unmergedBlobType :: Conflicting BlobType + , 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 - - in the list for each unmerged version (typically two). -} + - unresolved merge conflicts. + - + - 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 - parse s - | null file || length ws < 2 = Nothing - | otherwise = do - blobtype <- readBlobType (ws !! 0) - sha <- extractSha (ws !! 1) - return $ Unmerged file blobtype sha - where - (metadata, file) = separate (== '\t') s - ws = words metadata + files = map File l + list = pipeNullSplit $ Params "ls-files --unmerged -z --" : files + +data InternalUnmerged = InternalUnmerged + { isus :: Bool + , ifile :: FilePath + , iblobtype :: Maybe BlobType + , isha :: Maybe Sha + } deriving (Show) + +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 + } diff --git a/Git/Types.hs b/Git/Types.hs index e8cdbb442d..0c37427c7d 100644 --- a/Git/Types.hs +++ b/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 diff --git a/debian/changelog b/debian/changelog index c1ebac8398..46afb6e4d5 100644 --- a/debian/changelog +++ b/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 Mon, 25 Jun 2012 11:38:12 -0400 diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn index 39fad04882..c52a5f3bf9 100644 --- a/doc/git-annex.mdwn +++ b/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