diff options
| -rw-r--r-- | Assistant/Threads/XMPPClient.hs | 18 | ||||
| -rw-r--r-- | Assistant/XMPP.hs | 52 | ||||
| -rw-r--r-- | doc/design/assistant/xmpp.mdwn | 6 |
3 files changed, 41 insertions, 35 deletions
diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs index 974cc83a0..d988b2f83 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/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 diff --git a/doc/design/assistant/xmpp.mdwn b/doc/design/assistant/xmpp.mdwn index 6cfcbf56c..9410b3e7c 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: + + <git-annex xmlns='git-annex' pairing="PairReq uuid" /> ### security |