Merge branch 'master' into assistant
This commit is contained in:
commit
8baff14054
14 changed files with 307 additions and 7 deletions
105
Command/Sync.hs
105
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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue