tag xmpp pushes with jid

This fixes the issue mentioned in the last commit.

Turns out just collecting UUID of clients behind a XMPP remote is
insufficient (although I should probably still do it for other reasons),
because a single remote repo might be connected via both XMPP and local
pairing. So a way is needed to know when a push was received from any
client using a given XMPP remote over XMPP, as opposed to via ssh.

Annex/TaggedPush.hs

@@ -1,4 +1,4 @@
-{- git-annex uuid-tagged pushes
+{- git-annex tagged pushes
  -
  - Copyright 2012 Joey Hess <joey@kitenet.net>
  -
@@ -13,9 +13,11 @@ import qualified Annex.Branch
 import qualified Git
 import qualified Git.Ref
 import qualified Git.Command
+import Utility.Base64
 
 {- Converts a git branch into a branch that is tagged with a UUID, typically
- - the UUID of the repo that will be pushing it.
+ - the UUID of the repo that will be pushing it, and possibly with other
+ - information.
  -
  - Pushing to branches on the remote that have out uuid in them is ugly,
  - but it reserves those branches for pushing by us, and so our pushes will
@@ -23,25 +25,33 @@ import qualified Git.Command
  -
  - To avoid cluttering up the branch display, the branch is put under
  - refs/synced/, rather than the usual refs/remotes/
+ -
+ - Both UUIDs and Base64 encoded data are always legal to be used in git
+ - refs, per git-check-ref-format.
  -}
-toTaggedBranch :: UUID -> Git.Branch -> Git.Branch
-toTaggedBranch u b = Git.Ref $ concat
-	[ s
-	, ":"
-	, "refs/synced/" ++ fromUUID u ++ "/" ++ s
+toTaggedBranch :: UUID -> Maybe String -> Git.Branch -> Git.Branch
+toTaggedBranch u info b = Git.Ref $ join "/" $ catMaybes
+	[ Just "refs/synced"
+	, Just $ fromUUID u
+	, toB64 <$> info
+	, Just $ show $ Git.Ref.base b
 	]
-  where
-	s = show $ Git.Ref.base b
 
-branchTaggedBy :: Git.Branch -> Maybe UUID
-branchTaggedBy b = case split "/" $ show b of
-	("refs":"synced":u:_base) -> Just $ toUUID u
+fromTaggedBranch :: Git.Branch -> Maybe (UUID, Maybe String)
+fromTaggedBranch b = case split "/" $ show b of
+	("refs":"synced":u:info:_base) ->
+		Just (toUUID u, fromB64Maybe info)
+	("refs":"synced":u:_base) ->
+		Just (toUUID u, Nothing)
 	_ -> Nothing
+  where
 
-taggedPush :: UUID -> Git.Ref -> Remote -> Git.Repo -> IO Bool
-taggedPush u branch remote = Git.Command.runBool
+taggedPush :: UUID -> Maybe String -> Git.Ref -> Remote -> Git.Repo -> IO Bool
+taggedPush u info branch remote = Git.Command.runBool
         [ Param "push"
         , Param $ Remote.name remote
-        , Param $ show $ toTaggedBranch u Annex.Branch.name
-        , Param $ show $ toTaggedBranch u branch
+        , Param $ refspec Annex.Branch.name
+        , Param $ refspec branch
         ]
+  where
+	refspec b = show b ++ ":" ++ show (toTaggedBranch u info b)

Assistant/Sync.hs

@@ -48,11 +48,9 @@ reconnectRemotes _ [] = noop
 reconnectRemotes notifypushes rs = void $ do
 	modifyDaemonStatus_ $ \s -> s
 		{ desynced = S.union (S.fromList $ map Remote.uuid xmppremotes) (desynced s) }
-	alertWhile (syncAlert normalremotes) $ do
-		(ok, diverged) <- sync
-			=<< liftAnnex (inRepo Git.Branch.current)
-		addScanRemotes diverged rs
-		return ok
+	if null normalremotes
+		then go
+		else alertWhile (syncAlert normalremotes) go
   where
 	gitremotes = filter (notspecialremote . Remote.repo) rs
 	(xmppremotes, normalremotes) = partition isXMPPRemote gitremotes
@@ -69,6 +67,11 @@ reconnectRemotes notifypushes rs = void $ do
 	sync Nothing = do
 		diverged <- snd <$> manualPull Nothing gitremotes
 		return (True, diverged)
+	go = do
+		(ok, diverged) <- sync
+			=<< liftAnnex (inRepo Git.Branch.current)
+		addScanRemotes diverged rs
+		return ok
 
 {- Updates the local sync branch, then pushes it to all remotes, in
  - parallel, along with the git-annex branch. This is the same
@@ -137,7 +140,7 @@ pushToRemotes now notifypushes remotes = do
 	fallback branch g u rs = do
 		debug ["fallback pushing to", show rs]
 		(succeeded, failed) <- liftIO $
-			inParallel (\r -> taggedPush u branch r g) rs
+			inParallel (\r -> taggedPush u Nothing branch r g) rs
 		updatemap succeeded failed
 		when (notifypushes && (not $ null succeeded)) $
 			sendNetMessage $ NotifyPush $

Assistant/Threads/Merger.hs

@@ -22,6 +22,7 @@ import Annex.TaggedPush
 import Remote (remoteFromUUID)
 
 import qualified Data.Set as S
+import qualified Data.Text as T
 
 {- This thread watches for changes to .git/refs/, and handles incoming
  - pushes. -}
@@ -89,21 +90,21 @@ onAdd file
 			void $ liftAnnex  $ Command.Sync.mergeFrom changedbranch
 	mergecurrent _ = noop
 
-	handleDesynced = case branchTaggedBy changedbranch of
+	handleDesynced = case fromTaggedBranch changedbranch of
 		Nothing -> return False
-		Just u -> do
-			s <- desynced <$> getDaemonStatus				
-			if S.member u s
-				then do
-					modifyDaemonStatus_ $ \st -> st
-						{ desynced = S.delete u s }
-					mr <- liftAnnex $ remoteFromUUID u
-					case mr of
-						Just r -> do
+		Just (u, info) -> do
+			mr <- liftAnnex $ remoteFromUUID u
+			case mr of
+				Nothing -> return False
+				Just r -> do
+					s <- desynced <$> getDaemonStatus
+					if S.member u s || Just (T.unpack $ getXMPPClientID r) == info
+						then do
+							modifyDaemonStatus_ $ \st -> st
+								{ desynced = S.delete u s }
 							addScanRemotes True [r]
 							return True
-						Nothing -> return False
-				else return False
+						else return False
 
 equivBranches :: Git.Ref -> Git.Ref -> Bool
 equivBranches x y = base x == base y

Assistant/Threads/XMPPClient.hs

@@ -38,18 +38,20 @@ xmppClientThread urlrenderer = namedThread "XMPPClient" $
 	restartableClient . xmppClient urlrenderer =<< getAssistant id
 
 {- Runs the client, handing restart events. -}
-restartableClient :: IO () -> Assistant ()
-restartableClient a = forever $ do
-	tid <- liftIO $ forkIO a
-	waitNetMessagerRestart
-	liftIO $ killThread tid
+restartableClient :: (XMPPCreds -> IO ()) -> Assistant ()
+restartableClient a = forever $ go =<< liftAnnex getXMPPCreds
+  where
+	go Nothing = waitNetMessagerRestart
+	go (Just creds) = do
+		modifyDaemonStatus_ $ \s -> s
+			{ xmppClientID = Just $ xmppJID creds }
+		tid <- liftIO $ forkIO $ a creds
+		waitNetMessagerRestart
+		liftIO $ killThread tid
 
-xmppClient :: UrlRenderer -> AssistantData -> IO ()
-xmppClient urlrenderer d = do
-	v <- liftAssistant $ liftAnnex getXMPPCreds
-	case v of
-		Nothing -> noop -- will be restarted once creds get configured
-		Just c -> retry (runclient c) =<< getCurrentTime
+xmppClient :: UrlRenderer -> AssistantData -> XMPPCreds -> IO ()
+xmppClient urlrenderer d creds =
+	retry (runclient creds) =<< getCurrentTime
   where
 	liftAssistant = runAssistant d
 	inAssistant = liftIO . liftAssistant

Assistant/Types/DaemonStatus.hs

@@ -15,6 +15,7 @@ import Assistant.Pairing
 import Utility.NotificationBroadcaster
 import Logs.Transfer
 import Assistant.Types.ThreadName
+import Assistant.Types.NetMessager
 
 import Control.Concurrent.STM
 import Control.Concurrent.Async
@@ -57,6 +58,8 @@ data DaemonStatus = DaemonStatus
 	, alertNotifier :: NotificationBroadcaster
 	-- Broadcasts notifications when the syncRemotes change
 	, syncRemotesNotifier :: NotificationBroadcaster
+	-- When the XMPP client is in use, this will contain its JI.
+	, xmppClientID :: Maybe ClientID
 	}
 
 type TransferMap = M.Map Transfer TransferInfo
@@ -83,3 +86,4 @@ newDaemonStatus = DaemonStatus
 	<*> newNotificationBroadcaster
 	<*> newNotificationBroadcaster
 	<*> newNotificationBroadcaster
+	<*> pure Nothing

Assistant/XMPP/Git.hs

@@ -264,7 +264,8 @@ handlePushInitiation (Pushing cid PushRequest) =
 			<*> getUUID
 		liftIO $ Command.Sync.updateBranch (Command.Sync.syncBranch branch) g
 		debug ["pushing to", show rs]
-		forM_ rs $ \r -> xmppPush cid $ taggedPush u branch r
+		selfjid <- ((T.unpack <$>) . xmppClientID) <$> getDaemonStatus
+		forM_ rs $ \r -> xmppPush cid $ taggedPush u selfjid branch r
 handlePushInitiation (Pushing cid StartingPush) =
 	whenXMPPRemote cid $
 		void $ xmppReceivePack cid

Utility/Base64.hs

@@ -5,14 +5,20 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-module Utility.Base64 (toB64, fromB64) where
+module Utility.Base64 (toB64, fromB64Maybe, fromB64) where
 
 import Codec.Binary.Base64
 import Data.Bits.Utils
+import Control.Applicative
+import Data.Maybe
 
 toB64 :: String -> String		
 toB64 = encode . s2w8
 
+fromB64Maybe :: String -> Maybe String
+fromB64Maybe s = w82s <$> decode s
+
 fromB64 :: String -> String
-fromB64 s = maybe bad w82s $ decode s
-  where bad = error "bad base64 encoded data"
+fromB64 = fromMaybe bad . fromB64Maybe
+  where
+	bad = error "bad base64 encoded data"