make sync aware of adjusted branches

So, it will pull and push the original branch, not the adjusted one.

And, for merging, it will use updateAdjustedBranch (not implemented yet).

Note that remaining uses of Git.Branch.current need to be checked too;
for things that should act on the original branch, and not the adjusted
branch.

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"

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
+	sync currentbranch@(Just _, _) = do
-		(failedpull, diverged) <- manualPull (Just branch) gitremotes
+		(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
+		void $ manualPull currbranch rs
-		go False (Just branch) g u 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

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,

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

Assistant/WebApp/Configurators/Local.hs

@@ -20,7 +20,7 @@ import qualified Annex
 import qualified Git
 import qualified Git.Config
 import qualified Git.Command
-import qualified Git.Branch
+import qualified Command.Sync
 import Config.Files
 import Utility.FreeDesktop
 import Utility.DiskFree
@@ -202,7 +202,7 @@ postNewRepositoryR = page "Add another repository" (Just Configuration) $ do
  - immediately pulling from it. Also spawns a sync to push to it as well. -}
 immediateSyncRemote :: Remote -> Assistant ()
 immediateSyncRemote r = do
-	currentbranch <- liftAnnex (inRepo Git.Branch.current)
+	currentbranch <- liftAnnex $ join Command.Sync.getCurrBranch
 	void $ manualPull currentbranch [r]
 	syncRemote r
 

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, getCurrBranch)
-import Command.Sync (prepMerge, mergeLocal)
 
 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

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,
+	getbranch <- getCurrBranch 
-	-- 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
-		)
 	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 :: CurrBranch -> CommandStart
-mergeLocal Nothing = stop
+mergeLocal (Nothing, _) = stop
-mergeLocal (Just branch) = go =<< needmerge
+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 :: CurrBranch -> Annex ()
-updateSyncBranch Nothing = noop
+updateSyncBranch (Nothing, _) = noop
-updateSyncBranch (Just branch) = do
+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)
+			and <$> mapM (merge Nothing Nothing) (branchlist branch)
-		Just thisbranch -> do
+		(Just currbranch, madj) -> do
-			inRepo $ updateBranch $ syncBranch thisbranch
+			inRepo $ updateBranch $ syncBranch currbranch
-			and <$> (mapM (merge (Just thisbranch)) =<< tomerge (branchlist b))
+			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 :: SyncOptions -> Remote -> CurrBranch -> CommandStart
-pushRemote _o _remote Nothing = stop
+pushRemote _o _remote (Nothing, _) = stop
-pushRemote o remote (Just branch) = stopUnless (pure (pushOption o) <&&> needpush) $ do
+pushRemote o remote (Just branch, _) = stopUnless (pure (pushOption o) <&&> needpush) $ do
 	showStart "push" (Remote.name remote)
 	next $ next $ do
 		showOutput

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 ++ "/" ++
+under dir r = Ref $ dir ++ "/" ++ fromRef (basename r)
-	(reverse $ takeWhile (/= '/') $ reverse $ fromRef 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,