diff options
Diffstat (limited to 'Command/Sync.hs')
| -rw-r--r-- | Command/Sync.hs | 90 |
1 files changed, 56 insertions, 34 deletions
diff --git a/Command/Sync.hs b/Command/Sync.hs index 0c12fa090..b362d7c1e 100644 --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -8,6 +8,8 @@ module Command.Sync ( cmd, + CurrBranch, + getCurrBranch, prepMerge, mergeLocal, mergeRemote, @@ -43,6 +45,7 @@ import Annex.Drop import Annex.UUID import Logs.UUID import Annex.AutoMerge +import Annex.AdjustedBranch import Annex.Ssh import Annex.BloomFilter import Utility.Bloom @@ -95,20 +98,7 @@ seek :: SyncOptions -> CommandSeek seek o = allowConcurrentOutput $ do prepMerge - -- There may not be a branch checked out until after the commit, - -- or perhaps after it gets merged from the remote, or perhaps - -- never. - -- So only look it up once it's needed, and 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 - ) + getbranch <- getCurrBranch let withbranch a = a =<< getbranch remotes <- syncRemotes (syncWith o) @@ -140,6 +130,35 @@ seek o = allowConcurrentOutput $ do -- Pushes to remotes can run concurrently. mapM_ (commandAction . withbranch . pushRemote o) gitremotes +type CurrBranch = (Maybe Git.Branch, Maybe Adjustment) + +{- There may not be a branch checked out until after the commit, + - or perhaps after it gets merged from the remote, or perhaps + - never. + - + - So only look it up once it's needed, and once there is a + - branch, cache it. + - + - When on an adjusted branch, gets the original branch, and the adjustment. + -} +getCurrBranch :: Annex (Annex CurrBranch) +getCurrBranch = do + mvar <- liftIO newEmptyMVar + return $ ifM (liftIO $ isEmptyMVar mvar) + ( do + currbranch <- inRepo Git.Branch.current + case currbranch of + Nothing -> return (Nothing, Nothing) + Just b -> do + let v = case adjustedToOriginal b of + Nothing -> (Just b, Nothing) + Just (adj, origbranch) -> + (Just origbranch, Just adj) + liftIO $ putMVar mvar v + return v + , liftIO $ readMVar mvar + ) + {- Merging may delete the current directory, so go to the top - of the repo. This also means that sync always acts on all files in the - repository, not just on a subdirectory. -} @@ -216,9 +235,9 @@ commitStaged commitmode commitmessage = do void $ inRepo $ Git.Branch.commit commitmode False commitmessage branch parents return True -mergeLocal :: Maybe Git.Ref -> CommandStart -mergeLocal Nothing = stop -mergeLocal (Just branch) = go =<< needmerge +mergeLocal :: CurrBranch -> CommandStart +mergeLocal (Nothing, _) = stop +mergeLocal (Just branch, madj) = go =<< needmerge where syncbranch = syncBranch branch needmerge = ifM isBareRepo @@ -231,16 +250,18 @@ mergeLocal (Just branch) = go =<< needmerge go False = stop go True = do showStart "merge" $ Git.Ref.describe syncbranch - next $ next $ autoMergeFrom syncbranch (Just branch) Git.Branch.ManualCommit + next $ next $ case madj of + Nothing -> autoMergeFrom syncbranch (Just branch) Git.Branch.ManualCommit + Just adj -> updateAdjustedBranch adj branch syncbranch -pushLocal :: Maybe Git.Ref -> CommandStart +pushLocal :: CurrBranch -> CommandStart pushLocal b = do updateSyncBranch b stop -updateSyncBranch :: Maybe Git.Ref -> Annex () -updateSyncBranch Nothing = noop -updateSyncBranch (Just branch) = do +updateSyncBranch :: CurrBranch -> Annex () +updateSyncBranch (Nothing, _) = noop +updateSyncBranch (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 @@ -249,7 +270,7 @@ updateSyncBranch (Just branch) = do whenM isDirect $ inRepo $ updateBranch $ fromDirectBranch branch -updateBranch :: Git.Ref -> Git.Repo -> IO () +updateBranch :: Git.Branch -> Git.Repo -> IO () updateBranch syncbranch g = unlessM go $ error $ "failed to update " ++ Git.fromRef syncbranch where @@ -259,7 +280,7 @@ updateBranch syncbranch g = , Param $ Git.fromRef $ Git.Ref.base syncbranch ] g -pullRemote :: SyncOptions -> Remote -> Maybe Git.Ref -> CommandStart +pullRemote :: SyncOptions -> Remote -> CurrBranch -> CommandStart pullRemote o remote branch = stopUnless (pure $ pullOption o) $ do showStart "pull" (Remote.name remote) next $ do @@ -276,26 +297,27 @@ pullRemote o remote branch = stopUnless (pure $ pullOption o) $ 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 -> CurrBranch -> CommandCleanup mergeRemote remote b = ifM isBareRepo ( return True , case b of - Nothing -> do + (Nothing, _) -> do branch <- inRepo Git.Branch.currentUnsafe - and <$> mapM (merge Nothing) (branchlist branch) - Just thisbranch -> do - inRepo $ updateBranch $ syncBranch thisbranch - and <$> (mapM (merge (Just thisbranch)) =<< tomerge (branchlist b)) + and <$> mapM (merge Nothing Nothing) (branchlist branch) + (Just currbranch, madj) -> do + inRepo $ updateBranch $ syncBranch currbranch + and <$> (mapM (merge (Just currbranch) madj) =<< tomerge (branchlist (Just currbranch))) ) where - merge thisbranch br = autoMergeFrom (remoteBranch remote br) thisbranch Git.Branch.ManualCommit + merge (Just origbranch) (Just adj) br = updateAdjustedBranch adj origbranch br + merge currbranch _ br = autoMergeFrom (remoteBranch remote br) currbranch Git.Branch.ManualCommit tomerge = filterM (changed remote) branchlist Nothing = [] branchlist (Just branch) = [branch, syncBranch branch] -pushRemote :: SyncOptions -> Remote -> Maybe Git.Ref -> CommandStart -pushRemote _o _remote Nothing = stop -pushRemote o remote (Just branch) = stopUnless (pure (pushOption o) <&&> needpush) $ do +pushRemote :: SyncOptions -> Remote -> CurrBranch -> CommandStart +pushRemote _o _remote (Nothing, _) = stop +pushRemote o remote (Just branch, _) = stopUnless (pure (pushOption o) <&&> needpush) $ do showStart "push" (Remote.name remote) next $ next $ do showOutput |