factor out Annex.AutoMerge from Command.Sync
This commit is contained in:
Joey Hess
parent
33aae51175
commit
99295f2c1d
3 changed files with 184 additions and 164 deletions
179
Annex/AutoMerge.hs
Normal file
179
Annex/AutoMerge.hs
Normal file
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
165
Command/Sync.hs
165
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
|
||||
|
|
|
|||
Loading…
Reference in a new issue