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.

Assistant/Threads/XMPPClient.hs

@@ -119,18 +119,15 @@ decodeStanza fulljid s@(ReceivedPresence p)
 	| presenceFrom p == Just fulljid = [Ignorable p]
 	| not (null pushed) = impliedp $ GotNetMessage $ NotifyPush pushed
 	| isPresenceQuery p = impliedp $ GotNetMessage QueryPresence
-	| otherwise = [PresenceMessage p]
+	| otherwise = case decodePairingNotification p of
+		Nothing -> [PresenceMessage p]
+		Just pn -> impliedp $ GotNetMessage pn
   where
-	-- Some things are sent via presence, so imply a presence message,
+	-- Things sent via presence imply a presence message,
-	-- along with their real value.
+	-- along with their real meaning.
 	impliedp v = [PresenceMessage p, v]
 	pushed = concat $ catMaybes $ map decodePushNotification $
 		presencePayloads p
-decodeStanza _ s@(ReceivedIQ iq)
-	| iqType iq == IQError = [ProtocolError s]
-	| otherwise = case decodePairingNotification iq of
-		Nothing -> [Unknown s]
-		Just pn -> [GotNetMessage pn]
 decodeStanza _ s = [Unknown s]
 
 {- Waits for a NetMessager message to be sent, and relays it to XMPP. -}
@@ -141,9 +138,8 @@ relayNetMessage fulljid = convert <$> waitNetMessage
 	convert QueryPresence = putStanza $ presenceQuery
 	convert (PairingNotification stage t u) = case parseJID t of
 		Nothing -> noop
-		Just tojid -> do
+		Just tojid -> putStanza $
-			liftIO $ print $ pairingNotification stage u tojid fulljid
+			pairingNotification stage u tojid fulljid
-			putStanza $ pairingNotification stage u tojid fulljid
 
 {- Runs the client, handing restart events. -}
 restartableClient :: IO () -> Assistant ()

Assistant/WebApp/Configurators/Pairing.hs

@@ -89,13 +89,11 @@ getStartXMPPPairR bid = do
 		(Just []) -> redirect StartPairR
 		(Just clients@((Client exemplar):_)) -> do
 			let samejid = basejid ourjid == basejid exemplar
-			liftAssistant $ forM_ clients $ \(Client jid) ->
+			let account = formatJID $ basejid exemplar
-				unless (jid == ourjid) $ do
+			liftAssistant $ do
-					u <- liftAnnex getUUID
+				u <- liftAnnex getUUID
-					sendNetMessage $ PairingNotification
+				sendNetMessage $ PairingNotification PairReq account u
-						PairReq (formatJID jid) u
 			pairPage $ do
-				let account = formatJID $ basejid exemplar
 				let name = buddyName exemplar
 				$(widgetFile "configurators/pairing/xmpp/inprogress")
   where

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.
+{- A notification about a stage of pairing, sent as directed presence
- - The pairing info is sent using its id attribute; it also has a git-annex
+ - to all clients of a jid. -}
- - tag to identify it as from us. -}
+pairingNotification :: PairStage -> UUID -> JID -> JID -> Presence
-pairingNotification :: PairStage -> UUID -> JID -> JID -> IQ
+pairingNotification pairstage u tojid fromjid = (gitAnnexPresence elt)
-pairingNotification pairstage u tojid fromjid = (emptyIQ IQGet)
+	{ presenceTo = Just $ JID (jidNode tojid) (jidDomain tojid) Nothing
-	{ iqTo = Just tojid
+	, presenceFrom = Just fromjid
-	, iqFrom = Just fromjid
-	, iqID = Just $ T.unwords $ map T.pack
-		[ show pairstage
-		, fromUUID u
-		]
-	, iqPayload = Just gitAnnexSignature
 	}
+	where
+		elt = Element gitAnnexTagName
+			[(pairAttr, [ContentText content])] []
+		content = T.unwords
+			[ T.pack $ show pairstage
+			, T.pack $ fromUUID u
+			]
 
-decodePairingNotification :: IQ -> Maybe NetMessage
+decodePairingNotification :: Presence -> Maybe NetMessage
-decodePairingNotification iq@(IQ { iqPayload = Just elt })
+decodePairingNotification p = case filter isGitAnnexTag (presencePayloads p) of
-	| isGitAnnexTag elt = parseid =<< words . T.unpack <$> iqID iq
+	[] -> Nothing
-	| otherwise = 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
+	parse _ = Nothing
-decodePairingNotification _ = Nothing

doc/design/assistant/xmpp.mdwn

@@ -40,9 +40,9 @@ To indicate it's pushed changes to a git repo with a given UUID, a client uses:
 Multiple UUIDs can be listed when multiple clients were pushed. If the
 git repo does not have a git-annex UUID, an empty string is used.
 
-For pairing over XMPP, git-annex uses IQ messages, also containing a 
+For pairing, a directed presence message is sent, also using the git-annex tag:
-git-annex tag. The id attribute of the iq tag contains the pairing
+
-information.
+	<git-annex xmlns='git-annex' pairing="PairReq uuid" />
 
 ### security