WIP: server2server pings

2 files changed, 66 insertions, 0 deletions

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