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.

5 files changed, 41 insertions, 30 deletions

diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs
index f8dcd6748..901694920 100644
--- a/Assistant/Sync.hs
+++ 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 $
diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs
index d88cf00bd..4a482583f 100644
--- a/Assistant/Threads/Merger.hs
+++ b/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
diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs
index ebface796..688d0121b 100644
--- a/Assistant/Threads/XMPPClient.hs
+++ b/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
diff --git a/Assistant/Types/DaemonStatus.hs b/Assistant/Types/DaemonStatus.hs
index 7da85daa0..a22223476 100644
--- a/Assistant/Types/DaemonStatus.hs
+++ b/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
diff --git a/Assistant/XMPP/Git.hs b/Assistant/XMPP/Git.hs
index b5c8e382c..bdb68eea1 100644
--- a/Assistant/XMPP/Git.hs
+++ b/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