pass output channel to xmppInbound handler

1 files changed, 21 insertions, 7 deletions

diff --git a/xmppServer.hs b/xmppServer.hs
index aa99c061..85e0cb5c 100644
--- a/xmppServer.hs
+++ b/xmppServer.hs
@@ -91,8 +91,9 @@ prettyPrint prefix xs =
 xmppInbound :: ConnectionKey -> FlagCommand 
                 -> Source IO XML.Event
                 -> TChan Stanza
+                -> TChan Stanza
                 -> Sink XML.Event IO ()
-xmppInbound k pingflag src stanzas = doNestingXML $ do
+xmppInbound k pingflag src stanzas output = doNestingXML $ do
     withXML $ \begindoc -> do
     when (begindoc==EventBeginDocument) $ do
     whenJust nextElement $ \xml -> do
@@ -167,6 +168,18 @@ peerPing mid to from =
        , EventEndElement "{urn:xmpp:ping}ping"
        , EventEndElement "{jabber:server}iq" ]
 
+peerPong mid to from =
+       [ EventBeginElement "{jabber:server}iq"
+         $(case mid of
+               Just c -> (("id",[ContentText c]):)
+               _      -> id)
+               [ attr "type" "result"
+               , attr "to"   to
+               , attr "from" from
+               ]
+       , EventEndElement "{jabber:server}iq"
+       ]
+
 
 forkConnection :: ConnectionKey
                 -> FlagCommand
@@ -176,11 +189,6 @@ forkConnection :: ConnectionKey
                 ->  IO (TChan Stanza)
 forkConnection k pingflag src snk stanzas = do
     rdone <- atomically newEmptyTMVar
-    forkIO $ do
-        -- src $$ awaitForever (lift . putStrLn . takeWhile (/=' ') . show)
-        src $$ xmppInbound k pingflag src stanzas
-        atomically $ putTMVar rdone ()
-        wlog $ "end reader fork: " ++ show k
     slots <- atomically $ Slotted.new isEventBeginElement isEventEndElement
     needsFlush <- atomically $ newTVar False
     let _ = slots :: Slotted.UpdateStream XMPPState XML.Event
@@ -235,6 +243,11 @@ forkConnection k pingflag src snk stanzas = do
                 ]
             what
         wlog $ "end pre-queue fork: " ++ show k
+    forkIO $ do
+        -- src $$ awaitForever (lift . putStrLn . takeWhile (/=' ') . show)
+        src $$ xmppInbound k pingflag src stanzas output
+        atomically $ putTMVar rdone ()
+        wlog $ "end reader fork: " ++ show k
     return output
 
 monitor sv params = do
@@ -245,9 +258,10 @@ monitor sv params = do
       [ readTChan chan >>= \(k,e) -> return $ do 
         case e of
             Connection pingflag conread conwrite -> do
+                 wlog $ tomsg k "Connection"
                  let (xsrc,xsnk) = xmlStream conread conwrite
                  forkConnection k pingflag xsrc xsnk stanzas
-                 wlog $ tomsg k "Connection"
+                 return ()
             EOF        -> wlog $ tomsg k "EOF"
             HalfConnection In -> do
                 wlog $ tomsg k "ReadOnly"