diff options
Diffstat (limited to 'Command/Sync.hs')
| -rw-r--r-- | Command/Sync.hs | 272 |
1 files changed, 189 insertions, 83 deletions
diff --git a/Command/Sync.hs b/Command/Sync.hs index a6ae610f8..c41f46f8a 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -29,8 +29,11 @@ import qualified Remote.Git import Types.Key import Config import Annex.ReplaceFile +import Git.FileMode +import qualified Data.Set as S import Data.Hash.MD5 +import Control.Concurrent.MVar def :: [Command] def = [command "sync" (paramOptional (paramRepeating paramRemote)) @@ -39,24 +42,43 @@ def = [command "sync" (paramOptional (paramRepeating paramRemote)) -- syncing involves several operations, any of which can independently fail seek :: CommandSeek seek rs = do - branch <- fromMaybe nobranch <$> inRepo Git.Branch.current + prepMerge + + -- There may not be a branch checked out until after the commit, + -- or perhaps after it gets merged from the remote. + -- So only look it up once it's needed, and if once there is a + -- branch, cache it. + mvar <- liftIO newEmptyMVar + let getbranch = ifM (liftIO $ isEmptyMVar mvar) + ( do + branch <- inRepo Git.Branch.current + when (isJust branch) $ + liftIO $ putMVar mvar branch + return branch + , liftIO $ readMVar mvar + ) + let withbranch a = a =<< getbranch + remotes <- syncRemotes rs return $ concat [ [ commit ] - , [ mergeLocal branch ] - , [ pullRemote remote branch | remote <- remotes ] + , [ withbranch mergeLocal ] + , [ withbranch (pullRemote remote) | remote <- remotes ] , [ mergeAnnex ] - , [ pushLocal branch ] - , [ pushRemote remote branch | remote <- remotes ] + , [ withbranch pushLocal ] + , [ withbranch (pushRemote remote) | remote <- remotes ] ] - where - nobranch = error "no branch is checked out" + +{- Merging may delete the current directory, so go to the top + - of the repo. -} +prepMerge :: Annex () +prepMerge = liftIO . setCurrentDirectory =<< fromRepo Git.repoPath syncBranch :: Git.Ref -> Git.Ref -syncBranch = Git.Ref.under "refs/heads/synced/" +syncBranch = Git.Ref.under "refs/heads/synced" . fromDirectBranch remoteBranch :: Remote -> Git.Ref -> Git.Ref -remoteBranch remote = Git.Ref.under $ "refs/remotes/" ++ Remote.name remote +remoteBranch remote = Git.Ref.underBase $ "refs/remotes/" ++ Remote.name remote syncRemotes :: [String] -> Annex [Remote] syncRemotes rs = ifM (Annex.getState Annex.fast) ( nub <$> pickfast , wanted ) @@ -67,52 +89,62 @@ syncRemotes rs = ifM (Annex.getState Annex.fast) ( nub <$> pickfast , wanted ) | otherwise = listed listed = do l <- catMaybes <$> mapM (Remote.byName . Just) rs - let s = filter Remote.specialRemote l + let s = filter (not . Remote.syncableRemote) l unless (null s) $ error $ "cannot sync special remotes: " ++ unwords (map Types.Remote.name s) return l - available = filter (not . Remote.specialRemote) + available = filter Remote.syncableRemote . filter (remoteAnnexSync . Types.Remote.gitconfig) <$> Remote.remoteList good = filterM $ Remote.Git.repoAvail . Types.Remote.repo fastest = fromMaybe [] . headMaybe . Remote.byCost commit :: CommandStart -commit = next $ next $ do - ifM isDirect - ( do - void $ stageDirect - runcommit [] - , runcommit [Param "-a"] - ) +commit = next $ next $ ifM isDirect + ( do + void stageDirect + runcommit [] + , runcommit [Param "-a"] + ) where runcommit ps = do showStart "commit" "" showOutput Annex.Branch.commit "update" -- Commit will fail when the tree is clean, so ignore failure. - let params = (Param "commit") : ps ++ + let params = Param "commit" : ps ++ [Param "-m", Param "git-annex automatic sync"] _ <- inRepo $ tryIO . Git.Command.runQuiet params return True -mergeLocal :: Git.Ref -> CommandStart -mergeLocal branch = go =<< needmerge +mergeLocal :: Maybe Git.Ref -> CommandStart +mergeLocal Nothing = stop +mergeLocal (Just branch) = go =<< needmerge where syncbranch = syncBranch branch - needmerge = do - unlessM (inRepo $ Git.Ref.exists syncbranch) $ - inRepo $ updateBranch syncbranch - inRepo $ Git.Branch.changed branch syncbranch + needmerge = ifM isBareRepo + ( return False + , do + unlessM (inRepo $ Git.Ref.exists syncbranch) $ + inRepo $ updateBranch syncbranch + inRepo $ Git.Branch.changed branch syncbranch + ) go False = stop go True = do showStart "merge" $ Git.Ref.describe syncbranch next $ next $ mergeFrom syncbranch -pushLocal :: Git.Ref -> CommandStart -pushLocal branch = do +pushLocal :: Maybe Git.Ref -> CommandStart +pushLocal Nothing = stop +pushLocal (Just branch) = do + -- Update the sync branch to match the new state of the branch inRepo $ updateBranch $ syncBranch branch + -- In direct mode, we're operating on some special direct mode + -- branch, rather than the intended branch, so update the indended + -- branch. + whenM isDirect $ + inRepo $ updateBranch $ fromDirectBranch branch stop updateBranch :: Git.Ref -> Git.Repo -> IO () @@ -125,13 +157,13 @@ updateBranch syncbranch g = , Param $ show $ Git.Ref.base syncbranch ] g -pullRemote :: Remote -> Git.Ref -> CommandStart +pullRemote :: Remote -> Maybe Git.Ref -> CommandStart pullRemote remote branch = do showStart "pull" (Remote.name remote) next $ do showOutput stopUnless fetch $ - next $ mergeRemote remote (Just branch) + next $ mergeRemote remote branch where fetch = inRepo $ Git.Command.runBool [Param "fetch", Param $ Remote.name remote] @@ -141,20 +173,21 @@ pullRemote remote branch = do - were committed (or pushed changes, if this is a bare remote), - while the synced/master may have changes that some - other remote synced to this remote. So, merge them both. -} -mergeRemote :: Remote -> (Maybe Git.Ref) -> CommandCleanup +mergeRemote :: Remote -> Maybe Git.Ref -> CommandCleanup mergeRemote remote b = case b of Nothing -> do branch <- inRepo Git.Branch.currentUnsafe - all id <$> (mapM merge $ branchlist branch) - Just _ -> all id <$> (mapM merge =<< tomerge (branchlist b)) + and <$> mapM merge (branchlist branch) + Just _ -> and <$> (mapM merge =<< tomerge (branchlist b)) where merge = mergeFrom . remoteBranch remote tomerge branches = filterM (changed remote) branches branchlist Nothing = [] branchlist (Just branch) = [branch, syncBranch branch] -pushRemote :: Remote -> Git.Ref -> CommandStart -pushRemote remote branch = go =<< needpush +pushRemote :: Remote -> Maybe Git.Ref -> CommandStart +pushRemote _remote Nothing = stop +pushRemote remote (Just branch) = go =<< needpush where needpush = anyM (newer remote) [syncBranch branch, Annex.Branch.name] go False = stop @@ -162,31 +195,54 @@ pushRemote remote branch = go =<< needpush showStart "push" (Remote.name remote) next $ next $ do showOutput - inRepo $ pushBranch remote branch + ok <- inRepo $ pushBranch remote branch + unless ok $ do + warning $ unwords [ "Pushing to " ++ Remote.name remote ++ " failed." ] + showLongNote "(non-fast-forward problems can be solved by setting receive.denyNonFastforwards to false in the remote's git config)" + return ok -{- If the remote is a bare git repository, it's best to push the branch - - directly to it. On the other hand, if it's not bare, pushing to the - - checked out branch will fail, and this is why we use the syncBranch. +{- Pushes a regular branch like master to a remote. Also pushes the git-annex + - branch. + - + - If the remote is a bare git repository, it's best to push the regular + - branch directly to it, so that cloning/pulling will get it. + - On the other hand, if it's not bare, pushing to the checked out branch + - will fail, and this is why we push to its syncBranch. - - Git offers no way to tell if a remote is bare or not, so both methods - are tried. - - The direct push is likely to spew an ugly error message, so stderr is - - elided. Since progress is output to stderr too, the sync push is done - - first, and actually sends the data. Then the direct push is tried, - - with stderr discarded, to update the branch ref on the remote. + - elided. Since git progress display goes to stderr too, the sync push + - is done first, and actually sends the data. Then the direct push is + - tried, with stderr discarded, to update the branch ref on the remote. + - + - The sync push forces the update of the remote synced/git-annex branch. + - This is necessary if a transition has rewritten the git-annex branch. + - Normally any changes to the git-annex branch get pulled and merged before + - this push, so this forcing is unlikely to overwrite new data pushed + - in from another repository that is also syncing. + - + - But overwriting of data on synced/git-annex can happen, in a race. + - The only difference caused by using a forced push in that case is that + - the last repository to push wins the race, rather than the first to push. + - + - The sync push will fail to overwrite if receive.denyNonFastforwards is + - set on the remote. -} pushBranch :: Remote -> Git.Ref -> Git.Repo -> IO Bool -pushBranch remote branch g = tryIO directpush `after` syncpush +pushBranch remote branch g = tryIO (directpush g) `after` syncpush g where - syncpush = Git.Command.runBool (pushparams (refspec branch)) g - directpush = Git.Command.runQuiet (pushparams (show $ Git.Ref.base branch)) g - pushparams b = + syncpush = Git.Command.runBool $ pushparams + [ Git.Branch.forcePush $ refspec Annex.Branch.name + , refspec branch + ] + directpush = Git.Command.runQuiet $ pushparams + [show $ Git.Ref.base $ fromDirectBranch branch] + pushparams branches = [ Param "push" , Param $ Remote.name remote - , Param $ refspec Annex.Branch.name - , Param b - ] + ] ++ map Param branches refspec b = concat [ show $ Git.Ref.base b , ":" @@ -195,7 +251,7 @@ pushBranch remote branch g = tryIO directpush `after` syncpush mergeAnnex :: CommandStart mergeAnnex = do - void $ Annex.Branch.forceUpdate + void Annex.Branch.forceUpdate stop {- Merges from a branch into the current branch. -} @@ -218,7 +274,7 @@ mergeFrom branch = do mergeDirectCleanup d oldsha newsha _ -> noop return r - runmerge a = ifM (a) + runmerge a = ifM a ( return True , resolveMerge ) @@ -232,72 +288,122 @@ mergeFrom branch = do - - 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. + - 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.KEYA (or KEYB). + - 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. -} resolveMerge :: Annex Bool resolveMerge = do top <- fromRepo Git.repoPath (fs, cleanup) <- inRepo (LsFiles.unmerged [top]) - merged <- all id <$> mapM resolveMerge' fs + mergedfs <- catMaybes <$> mapM resolveMerge' fs + let merged = not (null mergedfs) void $ liftIO cleanup (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' :: LsFiles.Unmerged -> Annex Bool +resolveMerge' :: LsFiles.Unmerged -> Annex (Maybe FilePath) resolveMerge' u - | issymlink LsFiles.valUs && issymlink LsFiles.valThem = - withKey LsFiles.valUs $ \keyUs -> - withKey LsFiles.valThem $ \keyThem -> do + | issymlink LsFiles.valUs && issymlink 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 + removeoldfile keyUs + 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 ifM isDirect - ( maybe noop (\k -> removeDirect k file) keyUs - , liftIO $ nukeFile file + -- Move newly added non-annexed object + -- out of direct mode merge directory. + ( do + removeoldfile keyUs + makelink keyUs + d <- fromRepo gitAnnexMergeDir + liftIO $ rename (d </> file) file + -- cleaup tree after git merge + , do + unstageoldfile + makelink keyUs ) - Annex.Queue.addCommand "rm" [Params "--quiet -f --"] [file] - go keyUs keyThem - | otherwise = return False + return $ Just file + -- Our side is not annexed, other side is. + (Nothing, Just keyThem) -> do + makelink keyThem + unstageoldfile + return $ Just file + -- Neither side is annexed; cannot resolve. + (Nothing, Nothing) -> return Nothing + | otherwise = return Nothing where - go keyUs keyThem - | keyUs == keyThem = do - makelink keyUs - return True - | otherwise = do - makelink keyUs - makelink keyThem - return True file = LsFiles.unmergedFile u - issymlink select = any (select (LsFiles.unmergedBlobType u) ==) - [Just SymlinkBlob, Nothing] - makelink (Just key) = do + issymlink select = select (LsFiles.unmergedBlobType u) `elem` [Just SymlinkBlob, Nothing] + makelink key = do let dest = mergeFile file key l <- inRepo $ gitAnnexLink dest key replaceFile dest $ makeAnnexLink l stageSymlink dest =<< hashSymlink l - whenM (isDirect) $ + whenM isDirect $ toDirect key dest - makelink _ = noop - withKey select a = do - let msha = select $ LsFiles.unmergedSha u - case msha of - Nothing -> a Nothing - Just sha -> do - key <- catKey sha - maybe (return False) (a . Just) key + removeoldfile keyUs = do + ifM isDirect + ( removeDirect keyUs file + , liftIO $ nukeFile file + ) + Annex.Queue.addCommand "rm" [Params "--quiet -f --"] [file] + unstageoldfile = Annex.Queue.addCommand "rm" [Params "--quiet -f --cached --"] [file] + getKey select = case select (LsFiles.unmergedSha u) of + Nothing -> return Nothing + Just sha -> catKey sha symLinkMode + +{- 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 {- The filename to use when resolving a conflicted merge of a file, - that points to a key. |