full-on git-annex assistant syncing now works over XMPP!

I decided to use the fallback push mode from the beginning for XMPP, since
while it uses some ugly branches, it avoids the possibility of a normal
push failing, and needing to pull and re-push. Due to the overhead of XMPP,
and the difficulty of building such a chain of actions due to the async
implementation, this seemed reasonable.

It seems to work great!

3 files changed, 49 insertions, 38 deletions

diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs
index 201e6e534..8d7ead31d 100644
--- a/Assistant/Sync.hs
+++ b/Assistant/Sync.hs
@@ -84,10 +84,6 @@ reconnectRemotes notifypushes rs = void $ do
  - fallback mode, where our push is guarenteed to succeed if the remote is
  - reachable. If the fallback fails, the push is queued to be retried
  - later.
- -
- - The fallback mode pushes to branches on the remote that have our uuid in
- - them. While ugly, those branches are reserved for pushing by us, and
- - so our pushes will succeed.
  -}
 pushToRemotes :: UTCTime -> Bool -> [Remote] -> Assistant Bool
 pushToRemotes now notifypushes remotes = do
@@ -132,7 +128,7 @@ pushToRemotes now notifypushes remotes = do
 	fallback branch g u rs = do
 		debug ["fallback pushing to", show rs]
 		(succeeded, failed) <- liftIO $
-			inParallel (pushfallback g u branch) rs
+			inParallel (\r -> pushFallback u branch r g) rs
 		updatemap succeeded failed
 		when (notifypushes && (not $ null succeeded)) $
 			sendNetMessage $ NotifyPush $
@@ -140,20 +136,26 @@ pushToRemotes now notifypushes remotes = do
 		return $ null failed
 		
 	push g branch remote = Command.Sync.pushBranch remote branch g
-	pushfallback g u branch remote = Git.Command.runBool "push"
+
+{- This fallback push mode pushes to branches on the remote that have our
+ - uuid in them. While ugly, those branches are reserved for pushing by us,
+ - and so our pushes will never conflict with other pushes. -}
+pushFallback :: UUID -> Git.Ref -> Remote -> Git.Repo -> IO Bool
+pushFallback u branch remote = Git.Command.runBool "push" params
+  where
+	params = 
 		[ Param $ Remote.name remote
 		, Param $ refspec Annex.Branch.name
 		, Param $ refspec branch
-		] g
-	  where
-		{- Push to refs/synced/uuid/branch; this
-		 - avoids cluttering up the branch display. -}
-		refspec b = concat
-			[ s
-			, ":"
-			, "refs/synced/" ++ fromUUID u ++ "/" ++ s
-			]
-		  where s = show $ Git.Ref.base b
+		]
+	{- Push to refs/synced/uuid/branch; this
+	 - avoids cluttering up the branch display. -}
+	refspec b = concat
+		[ s
+		, ":"
+		, "refs/synced/" ++ fromUUID u ++ "/" ++ s
+		]
+	  where s = show $ Git.Ref.base b
 
 {- Manually pull from remotes and merge their branches. -}
 manualPull :: Maybe Git.Ref -> [Remote] -> Assistant ([Bool], Bool)
diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs
index d31712770..e473b5305 100644
--- a/Assistant/XMPP.hs
+++ b/Assistant/XMPP.hs
@@ -167,8 +167,8 @@ decodeMessage m = decode =<< gitAnnexTagInfo m
 			fmap (ReceivePackDone . decodeExitCode) . readish .
 				T.unpack . tagValue
 		]
-	pushdecoder a m i = Pushing
-		<$> (formatJID <$> messageFrom m)
+	pushdecoder a m' i = Pushing
+		<$> (formatJID <$> messageFrom m')
 		<*> a i
 
 decodeExitCode :: Int -> ExitCode
diff --git a/Assistant/XMPP/Git.hs b/Assistant/XMPP/Git.hs
index 86c9c9a9b..6aa280ec7 100644
--- a/Assistant/XMPP/Git.hs
+++ b/Assistant/XMPP/Git.hs
@@ -16,12 +16,12 @@ import Assistant.DaemonStatus
 import Assistant.Alert
 import Assistant.MakeRemote
 import Assistant.Sync
+import qualified Command.Sync
+import qualified Annex.Branch
 import Annex.UUID
 import Config
 import Git
-import qualified Git.Command
 import qualified Git.Branch
-import qualified Annex.Branch
 import Locations.UserConfig
 import qualified Types.Remote as Remote
 import Utility.FileMode
@@ -53,9 +53,9 @@ makeXMPPGitRemote buddyname jid u = do
 	syncNewRemote remote
 	return True
 
-{- Pushes the named refs to the remote, over XMPP, communicating with a
- - specific client that either requested the push, or responded to our
- - message.
+{- Pushes over XMPP, communicating with a specific client.
+ - Runs an arbitrary IO action to push, which should run git-push with
+ - an xmpp:: url.
  -
  - To handle xmpp:: urls, git push will run git-remote-xmpp, which is
  - injected into its PATH, and in turn runs git-annex xmppgit. The
@@ -72,8 +72,8 @@ makeXMPPGitRemote buddyname jid u = do
  -
  - We listen at the other end of the pipe and relay to and from XMPP.
  -}
-xmppPush :: ClientID -> Remote -> [Ref] -> Assistant Bool
-xmppPush cid remote refs = runPush (SendPushRunning cid) handleDeferred $ do
+xmppPush :: ClientID -> (Git.Repo -> IO Bool) -> Assistant Bool
+xmppPush cid gitpush = runPush (SendPushRunning cid) handleDeferred $ do
 	sendNetMessage $ Pushing cid StartingPush
 
 	(Fd inf, writepush) <- liftIO createPipe
@@ -104,9 +104,7 @@ xmppPush cid remote refs = runPush (SendPushRunning cid) handleDeferred $ do
 	{- This can take a long time to run, so avoid running it in the
 	 - Annex monad. Also, override environment. -}
 	g <- liftAnnex gitRepo
-	let params = Param (Remote.name remote) : map (Param . show) refs
-	r <- liftIO $ Git.Command.runBool "push" params $
-		g { gitEnv = Just $ M.toList myenv }
+	r <- liftIO $ gitpush $ g { gitEnv = Just $ M.toList myenv }
 
 	liftIO $ do
 		mapM_ killThread [t1, t2]
@@ -233,16 +231,27 @@ whenXMPPRemote :: ClientID -> Assistant () -> Assistant ()
 whenXMPPRemote cid = unlessM (null <$> xmppRemotes cid)
 
 handlePushMessage :: NetMessage -> Assistant ()
-handlePushMessage (Pushing cid CanPush) = whenXMPPRemote cid $ 
-	sendNetMessage $ Pushing cid PushRequest
-handlePushMessage (Pushing cid PushRequest) = do
-	rs <- xmppRemotes cid
-	current <- liftAnnex $ inRepo Git.Branch.current
-	--let refs = catMaybes [current, Just Annex.Branch.fullname] -- TODO
-	let refs = [Ref "master:refs/remotes/xmpp/newmaster"]
-	forM_ rs $ \r -> xmppPush cid r refs
-handlePushMessage (Pushing cid StartingPush) = whenXMPPRemote cid $
-	void $ xmppReceivePack cid
+handlePushMessage (Pushing cid CanPush) =
+	whenXMPPRemote cid $ 
+		sendNetMessage $ Pushing cid PushRequest
+
+handlePushMessage (Pushing cid PushRequest) =
+	go =<< liftAnnex (inRepo Git.Branch.current)
+  where
+	go Nothing = noop
+	go (Just branch) = do
+		rs <- xmppRemotes cid
+		liftAnnex $ Annex.Branch.commit "update"
+		(g, u) <- liftAnnex $ (,)
+			<$> gitRepo
+			<*> getUUID
+		liftIO $ Command.Sync.updateBranch (Command.Sync.syncBranch branch) g
+		debug ["pushing to", show rs]
+		forM_ rs $ \r -> xmppPush cid $ pushFallback u branch r
+
+handlePushMessage (Pushing cid StartingPush) =
+	whenXMPPRemote cid $
+		void $ xmppReceivePack cid
 handlePushMessage _ = noop
 
 handleDeferred :: NetMessage -> Assistant ()