1 files 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'.