From 82c6426b785bc7fca45e2f5a44e1e8d29e40d7f1 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Sat, 3 Nov 2012 21:38:27 -0400
Subject: avoid repeated pairing alerts

---
 Assistant/Threads/XMPPClient.hs |  2 +-
 Assistant/XMPP.hs               | 28 +++++++++++++++++++++-------
 2 files changed, 22 insertions(+), 8 deletions(-)

(limited to 'Assistant')

diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs
index d988b2f83..63040001b 100644
--- a/Assistant/Threads/XMPPClient.hs
+++ b/Assistant/Threads/XMPPClient.hs
@@ -138,7 +138,7 @@ relayNetMessage fulljid = convert <$> waitNetMessage
 	convert QueryPresence = putStanza $ presenceQuery
 	convert (PairingNotification stage t u) = case parseJID t of
 		Nothing -> noop
-		Just tojid -> putStanza $
+		Just tojid -> mapM_ putStanza $
 			pairingNotification stage u tojid fulljid
 
 {- Runs the client, handing restart events. -}
diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs
index 59113a0b0..d18087976 100644
--- a/Assistant/XMPP.hs
+++ b/Assistant/XMPP.hs
@@ -96,15 +96,29 @@ isPresenceQuery p = case filter isGitAnnexTag (presencePayloads p) of
 	((Element _name attrs _nodes):_) -> any (isAttr queryAttr) attrs
 
 {- A notification about a stage of pairing, sent as directed presence
- - to all clients of a jid. -}
-pairingNotification :: PairStage -> UUID -> JID -> JID -> Presence
-pairingNotification pairstage u tojid fromjid = (gitAnnexPresence elt)
-	{ presenceTo = Just $ JID (jidNode tojid) (jidDomain tojid) Nothing
-	, presenceFrom = Just fromjid
-	}
+ - to all clients of a jid. 
+ -
+ - For PairReq, the directed presence is followed by a second presence
+ - without the pair notification. This is done because XMPP servers
+ - resend the last directed presence periodically, which can make
+ - the pair request alert be re-displayed annoyingly. For PairAck and
+ - PairDone, that resending is a desirable feature, as it helps ensure
+ - clients see them.
+ -}
+pairingNotification :: PairStage -> UUID -> JID -> JID -> [Presence]
+pairingNotification pairstage u tojid fromjid
+	| pairstage == PairReq = [send, clear]
+	| otherwise = [send]
 	where
-		elt = Element gitAnnexTagName
+		send = directed $ gitAnnexPresence $ Element gitAnnexTagName
 			[(pairAttr, [ContentText content])] []
+		clear = directed $ gitAnnexPresence gitAnnexSignature
+
+		directed p = p
+			{ presenceTo = Just $ JID (jidNode tojid) (jidDomain tojid) Nothing
+			, presenceFrom = Just fromjid
+			}	
+
 		content = T.unwords
 			[ T.pack $ show pairstage
 			, T.pack $ fromUUID u
-- 
cgit v1.2.3