From 19619f352db3fbe91da266f60208f41aeb52ce77 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Sun, 28 Oct 2018 19:03:22 -0400 Subject: Use remote-address (not local bind address) as connection key for clients. Also: MVar for synchronous XMPP stanza logging. --- Presence/XMPPServer.hs | 50 +++++++++++++++++++++++++++++++------------------- 1 file changed, 31 insertions(+), 19 deletions(-) diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs index 02c33635..24cfd055 100644 --- a/Presence/XMPPServer.hs +++ b/Presence/XMPPServer.hs @@ -65,7 +65,7 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Fix (fix) import Control.Monad #ifdef THREAD_DEBUG -import Control.Concurrent.Lifted.Instrument (forkIO,myThreadId,labelThread,ThreadId) +import Control.Concurrent.Lifted.Instrument (forkIO,myThreadId,labelThread,ThreadId,MVar,putMVar,takeMVar,newMVar) #else import Control.Concurrent.Lifted (forkIO,myThreadId,ThreadId) import GHC.Conc (labelThread) @@ -1258,8 +1258,9 @@ forkConnection :: Server PeerAddress ConnectionData releaseKey XML.Event -> Source IO XML.Event -> Sink (Flush XML.Event) IO () -> TChan Stanza + -> MVar () -> IO (TChan Stanza) -forkConnection sv xmpp saddr cdta pingflag src snk stanzas = do +forkConnection sv xmpp saddr cdta pingflag src snk stanzas pp_mvar = do let auxAddr = cdAddr cdta clientOrServer@(namespace,tellmyname,telltheirname,_) = case auxAddr of Right _ -> ("jabber:client", xmppTellMyNameToClient xmpp (ClientAddress $ peerAddress saddr) @@ -1285,8 +1286,9 @@ forkConnection sv xmpp saddr cdta pingflag src snk stanzas = 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) + , Text.unpack (Text.drop 7 namespace) -- "client" or "server" , "." , case cdProfile cdta of _ | Right _ <- cdAddr cdta -> show saddr @@ -1341,11 +1343,13 @@ forkConnection sv xmpp saddr cdta pingflag src snk stanzas = do fix $ \loop -> do what <- atomically $ foldr1 orElse [readTChan output >>= \stanza -> return $ do + wantStanzas <- getVerbose XJabber let notping f - | (verbosity==1) = case stanzaType stanza of Pong -> return () - _ -> f - | (verbosity>=2) = f - | otherwise = return () + | not wantStanzas = return () + | (verbosity==1) = case stanzaType stanza of Pong -> return () + _ -> f + | (verbosity>=2) = f + | otherwise = return () -- isempty <- atomically $ isEmptyTChan (stanzaChan stanza) -- kwlog $ "queuing: "++show (isempty, stanzaId stanza) notping $ do @@ -1355,7 +1359,9 @@ forkConnection sv xmpp saddr cdta pingflag src snk stanzas = do Right _ -> "C" Left _ -> "P" wlog "" + liftIO $ takeMVar pp_mvar stanzaToConduit dup $$ prettyPrint typ + liftIO $ putMVar pp_mvar () -- wlog $ "hacks: "++show (stanzaId stanza) case stanzaType stanza of InternalEnableHack hack -> do @@ -1441,6 +1447,7 @@ peerKey bind_addr sock = do -- to distinguish fake address connection keys. return p rname <- atomically $ newTVar Nothing + -- dput XMan $ "peerKey " ++ show (PeerAddress $ raddr `withPort` peerport,laddr) return $ ( PeerAddress $ raddr `withPort` peerport , ConnectionData { cdAddr = Left (Local laddr) , cdType = XMPP @@ -1449,16 +1456,17 @@ peerKey bind_addr sock = do clientKey :: SocketLike sock => sock -> IO (PeerAddress,ConnectionData) clientKey sock = do - laddr <- getSocketName sock - raddr <- getPeerName sock - when (Just 0 == sockAddrPort laddr) $ do + laddr <- getSocketName sock -- [::1]:5222 bind address, same for all clients + raddr <- getPeerName sock -- [::1]:????? unique key + when (Just 0 == sockAddrPort raddr) $ do dput XMan $ unwords [ "BUG: XMPP Client" , show (laddr,raddr) , "is using port zero. This could interfere" , "with Tox peer sessions." ] rname <- atomically $ newTVar Nothing - return $ ( PeerAddress laddr - , ConnectionData { cdAddr = Right (Remote raddr) + -- dput XMan $ "clientKey " ++ show (PeerAddress laddr,raddr) + return $ ( PeerAddress raddr -- Actually a ClientAddress, but _xmpp_sv conkey type is PeerAddress. + , ConnectionData { cdAddr = Right (Remote raddr) -- FIXME: This is a bad way to detect client/peer. , cdType = XMPP , cdProfile = "." , cdRemoteName = rname } ) @@ -1705,13 +1713,14 @@ monitor sv params xmpp = do chan <- return $ serverEvent sv stanzas <- atomically newTChan quitVar <- atomically newEmptyTMVar + pp_mvar <- newMVar () -- Lock for synchronous pretty-printing of stanzas in log. fix $ \loop -> do action <- atomically $ foldr1 orElse [ readTChan chan >>= \((addr,u),e) -> return $ do case e of Connection pingflag xsrc xsnk -> do wlog $ tomsg addr "Connection" - outs <- forkConnection sv xmpp addr u pingflag xsrc xsnk stanzas + outs <- forkConnection sv xmpp addr u pingflag xsrc xsnk stanzas pp_mvar -- /addr/ may be a peer or a client. So we'll strip off -- the PeerAddress constructor before exposing it. xmppNewConnection xmpp (peerAddress addr) u outs @@ -1848,11 +1857,13 @@ monitor sv params xmpp = do 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 | (verbosity==1) = case stanzaType stanza of Pong -> return () - _ -> f - | (verbosity>=2) = f - | otherwise = return () + 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 @@ -1860,8 +1871,9 @@ monitor sv params xmpp = do ClientOrigin {} -> "C" PeerOrigin {} -> "P" wlog "" + liftIO $ takeMVar pp_mvar stanzaToConduit dup $$ prettyPrint typ - + liftIO $ putMVar pp_mvar () ] action loop @@ -1875,7 +1887,7 @@ data ConnectionType = XMPP | Tox data ConnectionData = ConnectionData { cdAddr :: Either (Local SockAddr) -- Peer connection local address - (Remote SockAddr) -- Client connection remote address + (Remote SockAddr) -- unused, todo:remove. (was client connection remote address). , cdType :: ConnectionType , cdProfile :: Text -- Currently ignored for clients. Instead, see -- 'clientProfile' field of 'ClientState'. -- cgit v1.2.3