From 5edf5d033dfe4147b9cdc14e963cc3d296836468 Mon Sep 17 00:00:00 2001 From: joe Date: Mon, 11 Nov 2013 16:02:42 -0500 Subject: WIP: server2server pings --- Presence/XMPP.hs | 64 +++++++++++++++++++++++++++++++++++++++++++++++++++ Presence/XMPPTypes.hs | 2 ++ 2 files changed, 66 insertions(+) diff --git a/Presence/XMPP.hs b/Presence/XMPP.hs index 2545e063..179ffd6b 100644 --- a/Presence/XMPP.hs +++ b/Presence/XMPP.hs @@ -265,6 +265,12 @@ isIQOf (EventBeginElement name attrs) testType = True isIQOf _ _ = False +isServerIQOf (EventBeginElement name attrs) testType + | name=="{jabber:server}iq" + && matchAttrib "type" testType attrs + = True +isServerIQOf _ _ = False + iq_service_unavailable host iq_id mjid req = [ EventBeginElement "{jabber:client}iq" [("type",[ContentText "error"]) @@ -879,6 +885,43 @@ peerRejectsSubscription session stanza = do withJust (name tojid) $ \user -> do liftIO $ processRejection session user fromjid +handlePeerIQGet :: (JabberPeerSession session, MonadIO m) => + session -> XML.Event -> NestingXML o m () +handlePeerIQGet session tag = do + withJust (lookupAttrib "id" (tagAttrs tag)) $ \stanza_id -> do + whenJust nextElement $ \child -> do + host <- liftIO $ do + names <- getNamesForPeer (peerAddress session) + return (S.decodeUtf8 . head $ names) + let unhandledGet req = do + liftIO $ debugStr ("iq-get: "++show (stanza_id,child)) + -- TODO: send service-unavailable to peer (See example 9 of XEP-0199) + -- Unsupported + -- Client equiv: liftIO . atomically . writeTChan cmdChan . Send $ iq_service_unavailable host stanza_id Nothing req + case tagName child of + -- "{http://jabber.org/protocol/disco#items}query" -> liftIO $ debugStr "iq-get-query-items" + "{urn:xmpp:ping}ping" -> liftIO $ do + {- + let mjid = lookupAttrib "from" (tagAttrs tag) + let pong = [ EventBeginElement "{jabber:server}iq" + $ (case mjid of + Just jid -> (attr "to" jid :) + _ -> id ) + [ attr "type" "result" + , attr "id" stanza_id + , attr "from" host + ] + , EventEndElement "{jabber:server}iq" + ] + -} + sendPeerMessage session (Pong (JID Nothing LocalHost Nothing) + (JID Nothing (peerAddress session) Nothing) + (Just (ContentText stanza_id))) + -- Client equiv: atomically . writeTChan cmdChan . Send $ pong + return () + + req -> unhandledGet req + fromPeer :: (MonadThrow m,MonadIO m, JabberPeerSession session) => session -> Sink XML.Event m () fromPeer session = doNestingXML $ do @@ -899,6 +942,7 @@ fromPeer session = doNestingXML $ do xs <- gatherElement stanza Seq.empty prettyPrint "P: " (toList xs) case () of + _ | stanza `isIQOf` iqTypeGet -> handlePeerIQGet session stanza _ | stanza `isPresenceOf` presenceTypeOnline -> handlePeerPresence session stanza True _ | stanza `isPresenceOf` presenceTypeOffline @@ -950,6 +994,8 @@ instance CommandCache CachedMessages where updateCache (Rejection from to) cache = cache { approvals= mmInsert (False,from) to $ approvals cache } updateCache (OutBoundMessage msg) cache = cache -- TODO + updateCache (Pong _ _ _) cache = cache -- pings are not cached + updateCache (Unsupported _ _ _ _) cache = cache -- error messages are not cached instance ThreadChannelCommand OutBoundMessage where isQuitCommand Disconnect = True @@ -1031,6 +1077,22 @@ toPeer sock cache chan fail = do sendOrFail (xmlifyMessageForPeer sock msg) (OutBoundMessage msg) + sendPong from to mid = + sendOrFail (xmlifyPong sock from to mid) + (Pong from to mid) + where + xmlifyPong sock from to mid = + return $ [ EventBeginElement "{jabber:server}iq" + $ (case mid of + Just c -> (("id",[c]):) + _ -> id ) + [ attr "type" "result" + , attr "to" (toStrict $ L.decodeUtf8 $ L.show to) + , attr "from" (toStrict $ L.decodeUtf8 $ L.show from) + ] + , EventEndElement "{jabber:server}iq" + ] + send greetPeer forM_ (Map.assocs . approvals $ cache) $ \(to,froms) -> do @@ -1067,6 +1129,8 @@ toPeer sock cache chan fail = do liftIO . debugL $ "sending rejection "<++>bshow (from,to) sendApproval False from to OutBoundMessage msg -> sendMessage msg + Pong from to mid -> sendPong from to mid + Unsupported _ _ _ _ -> todo Disconnect -> return () when (not . isQuitCommand $ event) loop return () diff --git a/Presence/XMPPTypes.hs b/Presence/XMPPTypes.hs index 06cfb563..8162ec5d 100644 --- a/Presence/XMPPTypes.hs +++ b/Presence/XMPPTypes.hs @@ -281,6 +281,8 @@ data OutBoundMessage = OutBoundPresence Presence | Approval JID JID | Rejection JID JID | OutBoundMessage Message + | Pong JID JID (Maybe Content) + | Unsupported JID JID (Maybe Content) XML.Name | Disconnect deriving Prelude.Show -- cgit v1.2.3