From 17e84a809631d30a43215e13145b1555aba73e4c Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 3 Nov 2012 21:19:59 -0400 Subject: [PATCH] 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 | 18 ++++---- Assistant/WebApp/Configurators/Pairing.hs | 10 ++--- Assistant/XMPP.hs | 50 ++++++++++++++--------- doc/design/assistant/xmpp.mdwn | 6 +-- 4 files changed, 44 insertions(+), 40 deletions(-) diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs index 974cc83a04..d988b2f83c 100644 --- a/Assistant/Threads/XMPPClient.hs +++ b/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, - -- along with their real value. + -- Things sent via presence imply a presence message, + -- 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 - liftIO $ print $ pairingNotification stage u tojid fulljid - putStanza $ pairingNotification stage u tojid fulljid + Just tojid -> putStanza $ + pairingNotification stage u tojid fulljid {- Runs the client, handing restart events. -} restartableClient :: IO () -> Assistant () diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs index d88293d7e3..55eb59fe4d 100644 --- a/Assistant/WebApp/Configurators/Pairing.hs +++ b/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) -> - unless (jid == ourjid) $ do - u <- liftAnnex getUUID - sendNetMessage $ PairingNotification - PairReq (formatJID jid) u + let account = formatJID $ basejid exemplar + liftAssistant $ do + u <- liftAnnex getUUID + sendNetMessage $ PairingNotification PairReq account u pairPage $ do - let account = formatJID $ basejid exemplar let name = buddyName exemplar $(widgetFile "configurators/pairing/xmpp/inprogress") where diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs index 75b64a788b..59113a0b0b 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 } + where + elt = Element gitAnnexTagName + [(pairAttr, [ContentText content])] [] + content = T.unwords + [ T.pack $ show pairstage + , T.pack $ fromUUID u + ] -decodePairingNotification :: IQ -> Maybe NetMessage -decodePairingNotification iq@(IQ { iqPayload = Just elt }) - | isGitAnnexTag elt = parseid =<< words . T.unpack <$> iqID iq - | otherwise = Nothing +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 diff --git a/doc/design/assistant/xmpp.mdwn b/doc/design/assistant/xmpp.mdwn index 6cfcbf56cd..9410b3e7c6 100644 --- a/doc/design/assistant/xmpp.mdwn +++ b/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 -git-annex tag. The id attribute of the iq tag contains the pairing -information. +For pairing, a directed presence message is sent, also using the git-annex tag: + + ### security