diff options
author | 2012-06-27 16:14:33 -0400 | |
---|---|---|
committer | 2012-06-27 16:14:33 -0400 | |
commit | 8baff14054e65ecbe801eb66786a55fa5245cb30 (patch) | |
tree | 6b94664f942ecbbda6def84cbe2b75bba10ce8f2 /Command | |
parent | 3ede3a809725a1ce612730218aa52349f785b0de (diff) | |
parent | 6677a99cb42e40baedfc98b1602171ec0c14f86b (diff) |
Merge branch 'master' into assistant
Diffstat (limited to 'Command')
-rw-r--r-- | Command/Sync.hs | 105 |
1 files changed, 103 insertions, 2 deletions
diff --git a/Command/Sync.hs b/Command/Sync.hs index 912ce944c..b2bf24d55 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)) @@ -168,10 +175,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 |