set negative XMPP presence priority

This should help prevent git-annex clients receiving messages that
were intended for normal clients they're sharing the account with.

Changed XMPP protocol use to always send chat messages directed at the
specific client, as the negative priority blocks less directed messages.

2 files changed, 21 insertions, 5 deletions

diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs
index ee1db0666..12ec9d550 100644
--- a/Assistant/Threads/XMPPClient.hs
+++ b/Assistant/Threads/XMPPClient.hs
@@ -137,7 +137,13 @@ decodeStanza selfjid s@(ReceivedMessage m)
 	| otherwise = [fromMaybe (Unknown s) (GotNetMessage <$> decodeMessage m)]
 decodeStanza _ s = [Unknown s]
 
-{- Waits for a NetMessager message to be sent, and relays it to XMPP. -}
+{- Waits for a NetMessager message to be sent, and relays it to XMPP.
+ -
+ - Chat messages must be directed to specific clients, not a base
+ - account JID, due to git-annex clients using a negative presence priority.
+ - PairingNotification messages are always directed at specific
+ - clients, but Pushing messages are sometimes not, and need to be exploded.
+ -}
 relayNetMessage :: JID -> Assistant (XMPP ())
 relayNetMessage selfjid = convert =<< waitNetMessage
   where
@@ -146,8 +152,13 @@ relayNetMessage selfjid = convert =<< waitNetMessage
 	convert (PairingNotification stage c u) = withclient c $ \tojid -> do
 		changeBuddyPairing tojid True
 		return $ putStanza $ pairingNotification stage u tojid selfjid
-	convert (Pushing c pushstage) = withclient c $ \tojid -> 
-		return $ putStanza $ pushMessage pushstage tojid selfjid
+	convert (Pushing c pushstage) = withclient c $ \tojid -> do
+		if tojid == baseJID tojid
+			then do
+				bud <- getBuddy (genBuddyKey tojid) <<~ buddyList
+				return $ forM_ (maybe [] (S.toList . buddyAssistants) bud) $ \(Client jid) ->
+					putStanza $ pushMessage pushstage jid selfjid
+			else return $ putStanza $ pushMessage pushstage tojid selfjid
 
 	withclient c a = case parseJID c of
 		Nothing -> return noop
diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs
index e473b5305..2c0004403 100644
--- a/Assistant/XMPP.hs
+++ b/Assistant/XMPP.hs
@@ -52,8 +52,9 @@ instance GitAnnexTaggable Message where
 	extractGitAnnexTag = headMaybe . filter isGitAnnexTag . messagePayloads
 
 instance GitAnnexTaggable Presence where
-	-- always mark extended away
-	insertGitAnnexTag p elt = p { presencePayloads = extendedAway : elt : presencePayloads p }
+	-- always mark extended away and set presence priority to negative
+	insertGitAnnexTag p elt = p
+		{ presencePayloads = extendedAway : negativePriority : elt : presencePayloads p }
 	extractGitAnnexTag = headMaybe . filter isGitAnnexTag . presencePayloads
 
 data GitAnnexTagInfo = GitAnnexTagInfo
@@ -208,6 +209,10 @@ silentMessage = (emptyMessage MessageChat)
 extendedAway :: Element
 extendedAway = Element "show" [] [NodeContent $ ContentText "xa"]
 
+{- Add to a presence to give it a negative priority. -}
+negativePriority :: Element
+negativePriority = Element "priority" [] [NodeContent $ ContentText "-1"]
+
 pushAttr :: Name
 pushAttr = "push"