diff options
Diffstat (limited to 'Command/Sync.hs')
| -rw-r--r-- | Command/Sync.hs | 165 |
1 files changed, 3 insertions, 162 deletions
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 |