Reply to pings with pongs.

1 files changed, 50 insertions, 14 deletions

diff --git a/xmppServer.hs b/xmppServer.hs
index 85e0cb5c..f91c20ce 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -23,14 +23,14 @@ import Data.Conduit.Blaze (builderToByteStringFlush)
 import qualified Text.XML.Stream.Render as XML
 import qualified Text.XML.Stream.Parse as XML
 import Data.XML.Types as XML
-import Data.Maybe (catMaybes)
+import Data.Maybe (catMaybes,fromJust)
 import Data.Monoid ( (<>) )
 import Data.Text (Text)
 import qualified Data.Text as Text (pack)
 
 import qualified Control.Concurrent.STM.UpdateStream as Slotted
 import ControlMaybe
-import NestingXML
+import Nesting
 import EventUtil
 import Server
 
@@ -80,6 +80,17 @@ type WriteCommand = ByteString -> IO Bool
 
 data Stanza
     = UnrecognizedStanza { stanzaChan :: TChan (Maybe XML.Event) }
+    | PingStanza { stanzaId :: Maybe Text
+                 , stanzaChan :: TChan (Maybe XML.Event) }
+    | PongStanza { -- stanzaId :: Maybe Text
+                   stanzaChan :: TChan (Maybe XML.Event) }
+
+copyToChannel f chan = awaitForever copy
+ where
+    copy x = do 
+        liftIO . atomically $ writeTChan chan (f x)
+        yield x
+
 
 prettyPrint prefix xs = 
     liftIO $ 
@@ -88,6 +99,19 @@ prettyPrint prefix xs =
         =$= CB.lines 
         $$ CL.mapM_ (wlogb . (prefix <>))
 
+grockStanzaIQGet :: Monad m => XML.Event -> NestingXML o m (Maybe (TChan (Maybe Event) -> Stanza))
+grockStanzaIQGet stanza = do
+    let mid   = lookupAttrib "id" (tagAttrs stanza)
+        -- mfrom = lookupAttrib "from" (tagAttrs stanza)
+    mtag <- nextElement 
+    flip (maybe $ return Nothing)  mtag $ \tag -> do
+    case tagName tag of
+        "{urn:xmpp:ping}ping" -> do
+            return $ Just (PingStanza mid)
+        _ -> return Nothing
+
+ioWriteChan c v = liftIO . atomically $ writeTChan c v
+
 xmppInbound :: ConnectionKey -> FlagCommand 
                 -> Source IO XML.Event
                 -> TChan Stanza
@@ -99,18 +123,30 @@ xmppInbound k pingflag src stanzas output = doNestingXML $ do
     whenJust nextElement $ \xml -> do
     withJust (elementAttrs "stream" xml) $ \stream_attrs -> do
     fix $ \loop -> do
-        -- liftIO . wlog $ "waiting for stanza."
-        chan <- liftIO $ atomically newTChan
-        whenJust nextElement $ \stanza -> do
-            stanza_lvl <- nesting
-            liftIO . atomically $ writeTChan chan (Just stanza)
-
-            liftIO . atomically $ writeTChan stanzas $
-                UnrecognizedStanza chan
-            doUntilCloser stanza_lvl $ \xml -> do
-                liftIO . atomically $ writeTChan chan (Just xml)
-            liftIO . atomically $ writeTChan chan Nothing
-            loop
+    -- liftIO . wlog $ "waiting for stanza."
+    chan <- liftIO $ atomically newTChan
+    whenJust nextElement $ \stanza -> do
+        stanza_lvl <- nesting
+        ioWriteChan chan (Just stanza)
+        copyToChannel Just chan =$= do
+          dispatch <- 
+            case () of
+                _ | stanza `isServerIQOf` "get" -> grockStanzaIQGet stanza
+                _ -> return $ Just UnrecognizedStanza
+          flip (maybe $ return ()) dispatch $ \dispatch -> 
+            case dispatch chan of
+              d@(PingStanza {}) -> do
+                let to = "todo"
+                    from = "todo"
+                let pong = peerPong (stanzaId d) to from
+                pongChan <- liftIO $ atomically newTChan
+                ioWriteChan output (PongStanza pongChan)
+                mapM_ (ioWriteChan pongChan . Just) pong
+                ioWriteChan pongChan Nothing
+              disp -> ioWriteChan stanzas disp
+          awaitCloser stanza_lvl
+        ioWriteChan chan Nothing
+        loop
     
 
 chanContents :: TChan x -> IO [x]