1 files changed, 30 insertions, 25 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 45b89b3d..140c91af 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -130,12 +130,10 @@ copyToChannel f chan closer_stack = awaitForever copy
         yield x
 
 
-prettyPrint prefix xs = 
-    liftIO $ 
-        CL.sourceList xs
-        $= XML.renderBytes (XML.def { XML.rsPretty=True })
+prettyPrint prefix = 
+        XML.renderBytes (XML.def { XML.rsPretty=True })
         =$= CB.lines 
-        $$ CL.mapM_ (wlogb . (prefix <>))
+        =$ CL.mapM_ (wlogb . (prefix <>))
 
 grockStanzaIQGet :: Monad m => XML.Event -> NestingXML o m (Maybe StanzaType)
 grockStanzaIQGet stanza = do
@@ -316,22 +314,10 @@ forkConnection k pingflag src snk stanzas = do
         fix $ \loop -> do
             what <- atomically $ foldr1 orElse
                 [readTChan output >>= \stanza -> return $ do
-                    let xchan = stanzaChan stanza
-                        xfin = stanzaClosers stanza
-                    fix $ \inner -> do
-                        what <- atomically $ foldr1 orElse
-                            [readTChan xchan >>= \xml -> return $ do
-                                atomically $ Slotted.push slots Nothing xml
-                                inner
-                            ,do mb <- readTVar xfin
-                                cempty <- isEmptyTChan xchan
-                                if isNothing mb
-                                    then if cempty then return loop else retry
-                                    else retry -- todo: send closers
-                            ,do isEmptyTChan xchan >>= check
-                                readTMVar rdone
-                                return (return ())]
-                        what
+                    stanzaToConduit stanza
+                        $$ awaitForever
+                            $ liftIO . atomically . Slotted.push slots Nothing
+                    loop
                 ,do pingflag >>= check
                     return $ do
                     let to = addrToText (callBackAddress k)
@@ -342,7 +328,7 @@ forkConnection k pingflag src snk stanzas = do
                     mapM_ (atomically . Slotted.push slots (Just $ PingSlot))
                           ping
                     wlog ""
-                    prettyPrint "P<-PING " ping
+                    CL.sourceList ping $$ prettyPrint "P<-Ping "
                     loop
                 ,readTMVar rdone >> return (return ())
                 ]
@@ -380,6 +366,27 @@ peerKey (sock,addr) = do
 
 clientKey (sock,addr) = return $ ClientKey addr
 
+stanzaToConduit :: MonadIO m => Stanza -> ConduitM i Event m ()
+stanzaToConduit stanza = do
+    let xchan = stanzaChan stanza
+        xfin = stanzaClosers stanza
+        rdone = stanzaInterrupt stanza
+        loop = return ()
+    fix $ \inner -> do
+        what <- liftIO . atomically $ foldr1 orElse
+            [readTChan xchan >>= \xml -> return $ do
+                yield xml -- atomically $ Slotted.push slots Nothing xml
+                inner
+            ,do mb <- readTVar xfin
+                cempty <- isEmptyTChan xchan
+                if isNothing mb
+                    then if cempty then return loop else retry
+                    else retry -- todo: send closers
+            ,do isEmptyTChan xchan >>= check
+                readTMVar rdone
+                return (return ())]
+        what
+
 monitor sv params = do
     chan <- return $ serverEvent sv
     stanzas <- atomically newTChan
@@ -402,11 +409,9 @@ monitor sv params = do
             RequiresPing -> return () -- wlog $ tomsg k "RequiresPing"
             _ -> return ()
       , readTChan stanzas >>= \stanza -> return $ do
-        -- xs <- readUntilNothing (stanzaChan stanza)
-        xs <- chanContents (stanzaChan stanza)
         let typ = Strict8.pack $ "P->"++(show (stanzaType stanza))++" "
         wlog ""
-        prettyPrint typ xs
+        stanzaToConduit stanza $$ prettyPrint typ
       ]
     action
     loop