summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Annex/AdjustedBranch.hs5
-rw-r--r--Assistant/Sync.hs25
-rw-r--r--Assistant/Threads/Committer.hs2
-rw-r--r--Assistant/Threads/XMPPClient.hs4
-rw-r--r--Command/Merge.hs5
-rw-r--r--Command/Sync.hs90
-rw-r--r--Git/Ref.hs7
7 files changed, 79 insertions, 59 deletions
diff --git a/Annex/AdjustedBranch.hs b/Annex/AdjustedBranch.hs
index 4c009c9ea..1579a1f2f 100644
--- a/Annex/AdjustedBranch.hs
+++ b/Annex/AdjustedBranch.hs
@@ -67,9 +67,6 @@ adjustedToOriginal b
bs = fromRef b
prefixlen = length adjustedBranchPrefix
-getAdjustment :: Annex (Maybe (Adjustment, OrigBranch))
-getAdjustment = maybe Nothing adjustedToOriginal <$> inRepo Git.Branch.current
-
originalBranch :: Annex (Maybe OrigBranch)
originalBranch = fmap getorig <$> inRepo Git.Branch.current
where
@@ -123,6 +120,6 @@ commitAdjustedTree treesha parent = go =<< catCommit parent
{- Update the currently checked out adjusted branch, merging the provided
- branch into it. -}
-updateAdjustedBranch :: Adjustment -> OrigBranch -> Branch -> Annex ()
+updateAdjustedBranch :: Adjustment -> OrigBranch -> Branch -> Annex Bool
updateAdjustedBranch mergebranch = do
error "updateAdjustedBranch"
diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs
index 7a9ea6a86..ebdead00d 100644
--- a/Assistant/Sync.hs
+++ b/Assistant/Sync.hs
@@ -19,7 +19,6 @@ import Assistant.RemoteControl
import qualified Command.Sync
import Utility.Parallel
import qualified Git
-import qualified Git.Branch
import qualified Git.Command
import qualified Git.Ref
import qualified Remote
@@ -79,16 +78,16 @@ reconnectRemotes notifypushes rs = void $ do
| Git.repoIsLocal r = True
| Git.repoIsLocalUnknown r = True
| otherwise = False
- sync (Just branch) = do
- (failedpull, diverged) <- manualPull (Just branch) gitremotes
+ sync currentbranch@(Just _, _) = do
+ (failedpull, diverged) <- manualPull currentbranch gitremotes
now <- liftIO getCurrentTime
failedpush <- pushToRemotes' now notifypushes gitremotes
return (nub $ failedpull ++ failedpush, diverged)
{- No local branch exists yet, but we can try pulling. -}
- sync Nothing = manualPull Nothing gitremotes
+ sync (Nothing, _) = manualPull (Nothing, Nothing) gitremotes
go = do
(failed, diverged) <- sync
- =<< liftAnnex (inRepo Git.Branch.current)
+ =<< liftAnnex (join Command.Sync.getCurrBranch)
addScanRemotes diverged $
filter (not . remoteAnnexIgnore . Remote.gitconfig)
nonxmppremotes
@@ -133,7 +132,7 @@ pushToRemotes' now notifypushes remotes = do
Annex.Branch.commit "update"
(,,)
<$> gitRepo
- <*> inRepo Git.Branch.current
+ <*> join Command.Sync.getCurrBranch
<*> getUUID
let (xmppremotes, normalremotes) = partition Remote.isXMPPRemote remotes
ret <- go True branch g u normalremotes
@@ -145,9 +144,9 @@ pushToRemotes' now notifypushes remotes = do
Pushing (getXMPPClientID r) (CanPush u shas)
return ret
where
- go _ Nothing _ _ _ = return [] -- no branch, so nothing to do
+ go _ (Nothing, _) _ _ _ = return [] -- no branch, so nothing to do
go _ _ _ _ [] = return [] -- no remotes, so nothing to do
- go shouldretry (Just branch) g u rs = do
+ go shouldretry currbranch@(Just branch, _) g u rs = do
debug ["pushing to", show rs]
(succeeded, failed) <- parallelPush g rs (push branch)
updatemap succeeded []
@@ -158,7 +157,7 @@ pushToRemotes' now notifypushes remotes = do
map Remote.uuid succeeded
return failed
else if shouldretry
- then retry branch g u failed
+ then retry currbranch g u failed
else fallback branch g u failed
updatemap succeeded failed = changeFailedPushMap $ \m ->
@@ -166,10 +165,10 @@ pushToRemotes' now notifypushes remotes = do
M.difference m (makemap succeeded)
makemap l = M.fromList $ zip l (repeat now)
- retry branch g u rs = do
+ retry currbranch g u rs = do
debug ["trying manual pull to resolve failed pushes"]
- void $ manualPull (Just branch) rs
- go False (Just branch) g u rs
+ void $ manualPull currbranch rs
+ go False currbranch g u rs
fallback branch g u rs = do
debug ["fallback pushing to", show rs]
@@ -227,7 +226,7 @@ syncAction rs a
- XMPP remotes. However, those pushes will run asynchronously, so their
- results are not included in the return data.
-}
-manualPull :: Maybe Git.Ref -> [Remote] -> Assistant ([Remote], Bool)
+manualPull :: Command.Sync.CurrBranch -> [Remote] -> Assistant ([Remote], Bool)
manualPull currentbranch remotes = do
g <- liftAnnex gitRepo
let (xmppremotes, normalremotes) = partition Remote.isXMPPRemote remotes
diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs
index be4a0a255..070699cb2 100644
--- a/Assistant/Threads/Committer.hs
+++ b/Assistant/Threads/Committer.hs
@@ -227,7 +227,7 @@ commitStaged msg = do
Right _ -> do
ok <- Command.Sync.commitStaged Git.Branch.AutomaticCommit msg
when ok $
- Command.Sync.updateSyncBranch =<< inRepo Git.Branch.current
+ Command.Sync.updateSyncBranch =<< join Command.Sync.getCurrBranch
return ok
{- OSX needs a short delay after a file is added before locking it down,
diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs
index da29c4ae4..2b68ecbe1 100644
--- a/Assistant/Threads/XMPPClient.hs
+++ b/Assistant/Threads/XMPPClient.hs
@@ -25,6 +25,7 @@ import Assistant.Pairing
import Assistant.XMPP.Git
import Annex.UUID
import Logs.UUID
+import qualified Command.Sync
import Network.Protocol.XMPP
import Control.Concurrent
@@ -33,7 +34,6 @@ import Control.Concurrent.STM (atomically)
import qualified Data.Text as T
import qualified Data.Set as S
import qualified Data.Map as M
-import qualified Git.Branch
import Data.Time.Clock
import Control.Concurrent.Async
@@ -306,7 +306,7 @@ pull [] = noop
pull us = do
rs <- filter matching . syncGitRemotes <$> getDaemonStatus
debug $ "push notification for" : map (fromUUID . Remote.uuid ) rs
- pullone rs =<< liftAnnex (inRepo Git.Branch.current)
+ pullone rs =<< liftAnnex (join Command.Sync.getCurrBranch)
where
matching r = Remote.uuid r `S.member` s
s = S.fromList us
diff --git a/Command/Merge.hs b/Command/Merge.hs
index 6ea8a68b1..908f3c1aa 100644
--- a/Command/Merge.hs
+++ b/Command/Merge.hs
@@ -9,8 +9,7 @@ module Command.Merge where
import Command
import qualified Annex.Branch
-import qualified Git.Branch
-import Command.Sync (prepMerge, mergeLocal)
+import Command.Sync (prepMerge, mergeLocal, getCurrBranch)
cmd :: Command
cmd = command "merge" SectionMaintenance
@@ -34,4 +33,4 @@ mergeBranch = do
mergeSynced :: CommandStart
mergeSynced = do
prepMerge
- mergeLocal =<< inRepo Git.Branch.current
+ mergeLocal =<< join getCurrBranch
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
diff --git a/Git/Ref.hs b/Git/Ref.hs
index 6bc47d5ed..7f21b0ab8 100644
--- a/Git/Ref.hs
+++ b/Git/Ref.hs
@@ -31,11 +31,14 @@ base = Ref . remove "refs/heads/" . remove "refs/remotes/" . fromRef
| prefix `isPrefixOf` s = drop (length prefix) s
| otherwise = s
+{- Gets the basename of any qualified ref. -}
+basename :: Ref -> Ref
+basename = Ref . reverse . takeWhile (/= '/') . reverse . fromRef
+
{- Given a directory and any ref, takes the basename of the ref and puts
- it under the directory. -}
under :: String -> Ref -> Ref
-under dir r = Ref $ dir ++ "/" ++
- (reverse $ takeWhile (/= '/') $ reverse $ fromRef r)
+under dir r = Ref $ dir ++ "/" ++ fromRef (basename r)
{- Given a directory such as "refs/remotes/origin", and a ref such as
- refs/heads/master, yields a version of that ref under the directory,
generated by cgit v1.2.3 (git 2.39.1) at 2025-01-22 18:30:02 +0000