From 8183644b29224b1f2a33b9428729744052373fb5 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Mon, 13 Jan 2020 01:14:40 -0500 Subject: Minor refactor. --- dht/Presence/Nesting.hs | 7 +++++ dht/Presence/XMPPServer.hs | 68 ++++++++++++++++++++++++++-------------------- 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 -- 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 {- -- cgit v1.2.3