Minor refactor.

2 files changed, 46 insertions, 29 deletions

diff --git a/dht/Presence/Nesting.hs b/dht/Presence/Nesting.hs
index cf47c9fc..403d63cf 100644
--- a/dht/Presence/Nesting.hs
+++ b/dht/Presence/Nesting.hs
@@ -24,6 +24,13 @@ doNestingXML :: Monad m => NestingXML o m r -> ConduitM Event o m r
 doNestingXML m =
     evalStateC (XMLState 0 StrictNil) (trackNesting .| m)
 
+startNestingXML :: Monad m => NestingXML o m r -> ConduitM Event o m (r, XMLState)
+startNestingXML m =
+    runStateC (XMLState 0 StrictNil) (trackNesting .| m)
+
+finishNestingXML :: Monad m => XMLState -> NestingXML o m r -> ConduitM Event o m r
+finishNestingXML = evalStateC
+
 nesting :: Monad m => NestingXML o m Int
 nesting = lift $ (return . nestingLevel) =<< get
 
diff --git a/dht/Presence/XMPPServer.hs b/dht/Presence/XMPPServer.hs
index 65d882bd..0aef1ed6 100644
--- a/dht/Presence/XMPPServer.hs
+++ b/dht/Presence/XMPPServer.hs
@@ -476,23 +476,16 @@ C->Unrecognized </iq>
 
 -- Sends all stanzas to announce channel except ping, for which it sends a pong
 -- to the output channel.
-xmppInbound :: ConnectionData
+xmppInbound :: Maybe Text -- ^ "to" attribute sent from remote
+                -> Maybe Text -- ^ "from" attribute sent from remote
+                -> ConnectionData
                 -> (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 (namespace,tellmyname,tellyourname,mkorigin) pingflag stanzas output donevar = doNestingXML $ do
-    withXML $ \begindoc -> do
-    when (begindoc==EventBeginDocument) $ do
-    whenJust nextElement $ \xml -> do
-    withJust (elementAttrs "stream" xml) $ \stream_attrs -> do
-    -- liftIO $ dput XMisc $ "STREAM ATTRS "++show stream_attrs
-    let stream_name   = lookupAttrib "to"   stream_attrs
-        stream_remote = lookupAttrib "from" stream_attrs
-     -- xmpp_version = lookupAttrib "version" stream_attrs
-    liftIO $ atomically $ writeTVar (cdRemoteName cdta) stream_remote
+                -> NestingXML o IO ()
+xmppInbound stream_name stream_remote cdta (namespace,tellmyname,tellyourname,mkorigin) pingflag stanzas output donevar =
     fix $ \loop -> do
     -- liftIO . wlog $ "waiting for stanza."
     (chan,clsrs) <- liftIO . atomically $
@@ -920,7 +913,17 @@ forkConnection :: Server PeerAddress ConnectionData releaseKey XML.Event
                 -> MVar ()
                 -> IO (TChan Stanza)
 forkConnection sv xmpp saddr cdta pingflag src snk stanzas pp_mvar = do
-    let auxAddr = cdAddr cdta
+    -- client.PeerAddress {peerAddress = [::1]:5222}
+    let lbl n = concat [ n
+                       , Text.unpack (Text.drop 7 namespace) -- "client" or "server"
+                       , "."
+                       , case cdProfile cdta of
+                            _ | Right _ <- cdAddr cdta -> show saddr
+                            "."                        -> show saddr
+                            mytoxname                  -> show saddr {- TODO: remote tox peer name? -} ]
+
+        auxAddr = cdAddr cdta
+
         clientOrServer@(namespace,tellmyname,telltheirname,_) = case auxAddr of
             Right _    -> ("jabber:client", xmppTellMyNameToClient xmpp (ClientAddress $ peerAddress saddr)
                                           , xmppTellClientHisName xmpp (ClientAddress $ peerAddress saddr)
@@ -928,8 +931,28 @@ forkConnection sv xmpp saddr cdta pingflag src snk stanzas pp_mvar = do
             Left laddr -> ("jabber:server", xmppTellMyNameToPeer xmpp laddr
                                           , xmppTellPeerHisName xmpp saddr
                                           , PeerOrigin saddr)
-    me <- tellmyname
+
+    output <- atomically newTChan
     rdone <- atomically newEmptyTMVar
+    forkLabeled (lbl "xmpp-reader.") $ do
+        -- src $$ awaitForever (lift . putStrLn . takeWhile (/=' ') . show)
+        runConduit $ (.|) src $
+            -- :: ConduitM Event o IO ()
+            doNestingXML $ do
+                withXML $ \begindoc -> do
+                when (begindoc==EventBeginDocument) $ do
+                whenJust nextElement $ \xml -> do
+                withJust (elementAttrs "stream" xml) $ \stream_attrs -> do
+                -- liftIO $ dput XMisc $ "STREAM ATTRS "++show stream_attrs
+                let stream_name   = lookupAttrib "to"   stream_attrs
+                    stream_remote = lookupAttrib "from" stream_attrs
+                 -- xmpp_version = lookupAttrib "version" stream_attrs
+                liftIO $ atomically $ writeTVar (cdRemoteName cdta) stream_remote
+                xmppInbound stream_name stream_remote cdta clientOrServer pingflag stanzas output rdone
+        atomically $ putTMVar rdone ()
+        wlog $ "end reader fork: " ++ lbl ""
+
+    me <- tellmyname
     let isStarter (Left _) = True
         isStarter (Right e) | isEventBeginElement e = True
         isStarter _ = False
@@ -940,19 +963,12 @@ forkConnection sv xmpp saddr cdta pingflag src snk stanzas pp_mvar = do
     needsFlush <- atomically $ newTVar False
     lastStanza <- atomically $ newTVar Nothing
     nesting <- atomically $ newTVar 0
+
     let _ = slots :: Slotted.UpdateStream XMPPState (Either (StanzaWrap XML.Event) XML.Event)
-    let greet_src = do
+        greet_src = do
             CL.sourceList (greet' namespace me) .| CL.map Chunk
             yield Flush
         slot_src = slotsToSource slots nesting lastStanza needsFlush rdone
-    -- client.PeerAddress {peerAddress = [::1]:5222}
-    let lbl n = concat [ n
-                       , Text.unpack (Text.drop 7 namespace) -- "client" or "server"
-                       , "."
-                       , case cdProfile cdta of
-                            _ | Right _ <- cdAddr cdta -> show saddr
-                            "."                        -> show saddr
-                            mytoxname                  -> show saddr {- TODO: remote tox peer name? -} ]
 
     forkLabeled (lbl "xmpp-post.") $ do
                 -- This thread handles messages after they are pulled out of
@@ -988,7 +1004,6 @@ forkConnection sv xmpp saddr cdta pingflag src snk stanzas pp_mvar = do
                 mapM_ fail $ filter notError (maybeToList last ++ es')
                 wlog $ "end xmpp-post fork: " ++ (lbl "")
 
-    output <- atomically newTChan
     hacks <- atomically $ newTVar Map.empty
     msgids <- atomically $ newTVar []
     forkLabeled (lbl "xmpp-pre.") $ do
@@ -1072,11 +1087,6 @@ forkConnection sv xmpp saddr cdta pingflag src snk stanzas pp_mvar = do
                 ]
             what
         wlog $ "end xmpp-pre fork: " ++ show (lbl "")
-    forkLabeled (lbl "xmpp-reader.") $ do
-        -- src $$ awaitForever (lift . putStrLn . takeWhile (/=' ') . show)
-        runConduit $ src .| xmppInbound cdta clientOrServer pingflag stanzas output rdone
-        atomically $ putTMVar rdone ()
-        wlog $ "end reader fork: " ++ lbl ""
     return output
 
 {-