Factored applyStanza/forwardStanza out of xmppInbound.

1 files changed, 42 insertions, 30 deletions

diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index a102ed5a..e3dfd32e 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -42,7 +42,6 @@ module XMPPServer
     , flushPassThrough
     , greet'
     , (<&>)
-    , grokStanza
     ) where
 
 import ConnectionKey
@@ -463,15 +462,16 @@ C->Unrecognized </iq>
 -}
 
 
+-- Sends all stanzas to announce channel except ping, for which it sends a pong
+-- to the output channel.
 xmppInbound :: ConnectionData
-                -> XMPPServerParameters -- ^ XXX: unused
                 -> (Text, IO Text, IO Text, TChan Stanza -> StanzaOrigin)
                 -> FlagCommand  -- ^ action to check whether the connection needs a ping (XXX: unused)
                 -> TChan Stanza -- ^ channel to announce incoming stanzas on
                 -> TChan Stanza -- ^ channel used to send stanzas
                 -> TMVar ()     -- ^ mvar that is filled when the connection quits
                 -> ConduitM Event o IO ()
-xmppInbound cdta xmpp (namespace,tellmyname,tellyourname,mkorigin) pingflag stanzas output donevar = doNestingXML $ do
+xmppInbound cdta (namespace,tellmyname,tellyourname,mkorigin) pingflag stanzas output donevar = doNestingXML $ do
     withXML $ \begindoc -> do
     when (begindoc==EventBeginDocument) $ do
     whenJust nextElement $ \xml -> do
@@ -971,7 +971,7 @@ forkConnection sv xmpp saddr cdta pingflag src snk stanzas pp_mvar = do
     forkIO $ do
         myThreadId >>= flip labelThread (lbl "xmpp-reader.")
         -- src $$ awaitForever (lift . putStrLn . takeWhile (/=' ') . show)
-        runConduit $ src .| xmppInbound cdta xmpp clientOrServer pingflag stanzas output rdone
+        runConduit $ src .| xmppInbound cdta clientOrServer pingflag stanzas output rdone
         atomically $ putTMVar rdone ()
         wlog $ "end reader fork: " ++ lbl ""
     return output
@@ -1209,7 +1209,41 @@ monitor sv params xmpp = do
         -}
         dup <- cloneStanza stanza
 
-        forkIO $ do
+        forkIO $ do applyStanza sv quitVar xmpp stanza
+                    forwardStanza quitVar xmpp stanza
+
+        -- We need to clone in the case the stanza is passed on as for Message.
+        wantStanzas <- getVerbose XJabber
+        verbosity <- xmppVerbosity xmpp
+        let notping f | not wantStanzas = return ()
+                      | (verbosity==1)  = case stanzaType stanza of Pong -> return ()
+                                                                    _    -> f
+                      | (verbosity>=2)  = f
+                      | otherwise       = return ()
+        notping $ do
+        let typ = Strict8.pack $ c ++ "->"++(concat . take 1 . words $ show (stanzaType stanza))++" "
+            c = case stanzaOrigin stanza of
+                    LocalPeer       -> "*"
+                    ClientOrigin {} -> "C"
+                    PeerOrigin {}   -> "P"
+        wlog ""
+        liftIO $ takeMVar pp_mvar
+        runConduit $ stanzaToConduit dup .| prettyPrint typ
+        liftIO $ putMVar pp_mvar ()
+      ]
+    action
+    loop
+ where
+    tomsg k str =  printf "%12s %s" str (show k)
+        where
+            _ = str :: String
+
+applyStanza :: Server PeerAddress ConnectionData releaseKey Event
+                     -> TMVar ()
+                     -> XMPPServerParameters
+                     -> StanzaWrap (LockedChan Event)
+                     -> IO ()
+applyStanza sv quitVar xmpp stanza = do
             case stanzaOrigin stanza of
                 ClientOrigin k replyto ->
                     case stanzaType stanza of
@@ -1288,6 +1322,9 @@ monitor sv params xmpp = do
                             xmppPeerInformSubscription xmpp fail k stanza
                         _ -> return ()
                 _ -> return ()
+
+forwardStanza :: TMVar () -> XMPPServerParameters -> StanzaWrap (LockedChan Event) -> IO ()
+forwardStanza quitVar xmpp stanza = do
             let deliver replyto = do
                     -- TODO: Issuing RecipientUnavailable for all errors is a presence leak
                     --          and protocol violation
@@ -1312,31 +1349,6 @@ monitor sv params xmpp = do
                     ClientOrigin _ replyto -> deliver replyto
                     PeerOrigin   _ replyto -> deliver replyto
                 _ -> return ()
-        -- We need to clone in the case the stanza is passed on as for Message.
-        wantStanzas <- getVerbose XJabber
-        verbosity <- xmppVerbosity xmpp
-        let notping f | not wantStanzas = return ()
-                      | (verbosity==1)  = case stanzaType stanza of Pong -> return ()
-                                                                    _    -> f
-                      | (verbosity>=2)  = f
-                      | otherwise       = return ()
-        notping $ do
-        let typ = Strict8.pack $ c ++ "->"++(concat . take 1 . words $ show (stanzaType stanza))++" "
-            c = case stanzaOrigin stanza of
-                    LocalPeer       -> "*"
-                    ClientOrigin {} -> "C"
-                    PeerOrigin {}   -> "P"
-        wlog ""
-        liftIO $ takeMVar pp_mvar
-        runConduit $ stanzaToConduit dup .| prettyPrint typ
-        liftIO $ putMVar pp_mvar ()
-      ]
-    action
-    loop
- where
-    tomsg k str =  printf "%12s %s" str (show k)
-        where
-            _ = str :: String
 
 data ConnectionType = XMPP | Tox
     deriving (Eq,Ord,Enum,Show,Read)