switch to directed presence for pair requests

Testing between Google Talk and prosody, the directed IQ messages
were not received. Google Talk probably only relays them between
clients using the same account.

I first tried even more directed presence, with each client JID being sent
a separate presence, but that didn't work on Google Talk, particularly
it was ignored when one client sent it to another client using the same
account.

So, presence directed at the user@host of the client to pair with. Tested
working between Google Talk and prosody (in both directions), as well
as between two clients with the same account on Google Talk, and
two clients with the same account on prosody.

Only problem with this form of directed presence is that if I also use it
for git pushes, more clients than are interested in a push's data will
receive it. So I may need some better approach, or a hybrid between
directed IQ and directed presence.

1 files changed, 31 insertions, 21 deletions

diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs
index 75b64a788..59113a0b0 100644
--- a/Assistant/XMPP.hs
+++ b/Assistant/XMPP.hs
@@ -45,9 +45,19 @@ queryAttr = Name (T.pack "query") Nothing Nothing
 pushAttr :: Name
 pushAttr = Name (T.pack "push") Nothing Nothing
 
+pairAttr :: Name
+pairAttr = Name (T.pack "pair") Nothing Nothing
+
 isAttr :: Name -> (Name, [Content]) -> Bool
 isAttr attr (k, _) = k == attr
 
+getAttr :: Element -> Name -> Maybe T.Text
+getAttr (Element _name attrs _nodes) name =
+	T.concat . map unpack . snd <$> headMaybe (filter (isAttr name) attrs)
+  where
+	unpack (ContentText t) = t
+	unpack (ContentEntity t) = t
+
 uuidSep :: T.Text
 uuidSep = T.pack ","
 
@@ -85,29 +95,29 @@ isPresenceQuery p = case filter isGitAnnexTag (presencePayloads p) of
 	[] -> False
 	((Element _name attrs _nodes):_) -> any (isAttr queryAttr) attrs
 
-{- A notification about a stage of pairing. Sent as an XMPP IQ.
- - The pairing info is sent using its id attribute; it also has a git-annex
- - tag to identify it as from us. -}
-pairingNotification :: PairStage -> UUID -> JID -> JID -> IQ
-pairingNotification pairstage u tojid fromjid = (emptyIQ IQGet)
-	{ iqTo = Just tojid
-	, iqFrom = Just fromjid
-	, iqID = Just $ T.unwords $ map T.pack
-		[ show pairstage
-		, fromUUID u
-		]
-	, iqPayload = Just gitAnnexSignature
+{- 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
 	}
-
-decodePairingNotification :: IQ -> Maybe NetMessage
-decodePairingNotification iq@(IQ { iqPayload = Just elt })
-	| isGitAnnexTag elt = parseid =<< words . T.unpack <$> iqID iq
-	| otherwise = Nothing
+	where
+		elt = Element gitAnnexTagName
+			[(pairAttr, [ContentText content])] []
+		content = T.unwords
+			[ T.pack $ show pairstage
+			, T.pack $ fromUUID u
+			]
+
+decodePairingNotification :: Presence -> Maybe NetMessage
+decodePairingNotification p = case filter isGitAnnexTag (presencePayloads p) of
+	[] -> Nothing
+	(elt:_) -> parse =<< words . T.unpack <$> getAttr elt pairAttr
   where
-	parseid [stage, u] = 
+	parse [stage, u] = 
 		PairingNotification
 			<$> readish stage
-			<*> (formatJID <$> iqFrom iq)
+			<*> (formatJID <$> presenceFrom p)
 			<*> pure (toUUID u)
-	parseid _ = Nothing
-decodePairingNotification _ = Nothing
+	parse _ = Nothing