diff options
| -rw-r--r-- | Annex/AutoMerge.hs | 179 | ||||
| -rw-r--r-- | Assistant/Threads/Merger.hs | 4 | ||||
| -rw-r--r-- | Command/Sync.hs | 165 |
3 files changed, 184 insertions, 164 deletions
diff --git a/Annex/AutoMerge.hs b/Annex/AutoMerge.hs new file mode 100644 index 000000000..c4045008b --- /dev/null +++ b/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 diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs index 8c406990a..74f67aab7 100644 --- a/Assistant/Threads/Merger.hs +++ b/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 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 |