diff options
| -rw-r--r-- | Assistant/Threads/XMPPClient.hs | 2 | ||||
| -rw-r--r-- | Assistant/XMPP.hs | 28 |
2 files changed, 22 insertions, 8 deletions
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 |