diff options
author | Joey Hess <joey@kitenet.net> | 2012-11-03 16:00:38 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2012-11-03 16:01:09 -0400 |
commit | efa88a0f1589a82a91a06ed3a3cbd5f4106aabb4 (patch) | |
tree | 013133783caef5e5f693b2734024935fd494551b /Assistant/XMPP.hs | |
parent | 2798e659c701a3c6122930ece994411b3ec8b266 (diff) |
XMPP pairing notifications are now sent
Rest of pairing process still to do.
Diffstat (limited to 'Assistant/XMPP.hs')
-rw-r--r-- | Assistant/XMPP.hs | 52 |
1 files changed, 22 insertions, 30 deletions
diff --git a/Assistant/XMPP.hs b/Assistant/XMPP.hs index 834055fbc..04eea50f6 100644 --- a/Assistant/XMPP.hs +++ b/Assistant/XMPP.hs @@ -8,7 +8,7 @@ module Assistant.XMPP where import Assistant.Common -import Annex.UUID +import Assistant.Types.NetMessager import Assistant.Pairing import Network.Protocol.XMPP @@ -45,22 +45,9 @@ queryAttr = Name (T.pack "query") Nothing Nothing pushAttr :: Name pushAttr = Name (T.pack "push") Nothing Nothing -pairingAttr :: Name -pairingAttr = Name (T.pack "pairing") Nothing Nothing - isAttr :: Name -> (Name, [Content]) -> Bool isAttr attr (k, _) = k == attr -getAttr :: Name -> [(Name, [Content])] -> Maybe String -getAttr wantattr attrs = content <$> headMaybe (filter (isAttr wantattr) attrs) - where - content (_name, cs) = T.unpack $ T.concat $ map unpack cs - unpack (ContentText t) = t - unpack (ContentEntity t) = t - -uuidAttr :: Name -uuidAttr = Name (T.pack "uuid") Nothing Nothing - uuidSep :: T.Text uuidSep = T.pack "," @@ -98,20 +85,25 @@ isPresenceQuery p = case filter isGitAnnexTag (presencePayloads p) of [] -> False ((Element _name attrs _nodes):_) -> any (isAttr queryAttr) attrs -{- A notification about a stage of pairing. -} -pairingNotification :: PairStage -> Annex Presence -pairingNotification pairstage = do - u <- getUUID - return $ gitAnnexPresence $ Element gitAnnexTagName - [ (pairingAttr, [ContentText $ T.pack $ show pairstage]) - , (uuidAttr, [ContentText $ T.pack $ fromUUID u]) +{- A notification about a stage of pairing. Sent as an XMPP ping. + - The pairing info is sent using its id attribute. -} +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 + [ "git-annex" + , show pairstage + , fromUUID u ] - [] - -isPairingNotification :: Presence -> Maybe (PairStage, UUID) -isPairingNotification p = case filter isGitAnnexTag (presencePayloads p) of - [] -> Nothing - ((Element _name attrs _nodes):_) -> - (,) - <$> (readish =<< getAttr pairingAttr attrs) - <*> (toUUID <$> getAttr uuidAttr attrs) + } + +decodePairingNotification :: IQ -> Maybe NetMessage +decodePairingNotification iq = parseid =<< words . T.unpack <$> iqID iq + where + parseid ["git-annex", stage, u] = + PairingNotification + <$> readish stage + <*> (formatJID <$> iqFrom iq) + <*> pure (toUUID u) + parseid _ = Nothing |