Improved debug prints.

3 files changed, 31 insertions, 17 deletions

diff --git a/dht/src/DebugTag.hs b/dht/src/DebugTag.hs
index efa6415f..83f9b1f8 100644
--- a/dht/src/DebugTag.hs
+++ b/dht/src/DebugTag.hs
@@ -5,6 +5,7 @@ import Data.Typeable
 -- | Debug Tags, add more as needed, but ensure XAnnounce is always first, XMisc last
 data DebugTag
   = XAnnounce
+  | XAnnounceResponse
   | XBitTorrent
   | XDHT
   | XLan
diff --git a/dht/src/Network/Tox/Onion/Handlers.hs b/dht/src/Network/Tox/Onion/Handlers.hs
index 45795312..8db1c534 100644
--- a/dht/src/Network/Tox/Onion/Handlers.hs
+++ b/dht/src/Network/Tox/Onion/Handlers.hs
@@ -272,6 +272,15 @@ announceSerializer getTimeout = MethodSerializer
 -- aggressively reannounce itself and search for friends as if it was just
 -- started.
 
+showResponse :: Bool -> NodeInfo -> AnnounceRequest -> AnnounceResponse -> String
+showResponse is_async them req r = unlines $ map (mappend $ show them ++ " --> ") $
+    [ "AnnounceResponse" ++ if is_async then " -- async" else ""
+    , "  { announceSeeking = " ++ show (announceSeeking req)
+    , "  , is_stored     = " ++ show (is_stored r)
+    , "  , announceNodes = "
+    ] ++ case announceNodes r of
+        SendNodes ns -> map (mappend "      " . show) ns
+    ++ [ "  }" ]
 
 sendOnion :: (OnionDestination r -> STM (OnionDestination r, Int))
             -> Client r
@@ -283,7 +292,8 @@ sendOnion getTimeout client req oaddr unwrap =
     -- Four tries and then we tap out.
     flip fix 4 $ \loop n -> do
         mb <- QR.sendQuery client (announceSerializer getTimeout) req oaddr
-        forM_ mb $ \r -> dput XAnnounce $ show (onionNodeInfo oaddr) ++ " sent response: " ++ show r
+        forM_ mb $ \mr -> forM_ mr $ \r ->
+            dput XAnnounceResponse $ showResponse False (onionNodeInfo oaddr) req r
         let re = if n>0 then loop $! n - 1 else return Canceled
         case mb of
             Success x -> maybe re (return . Success . unwrap (onionNodeInfo oaddr)) x
@@ -300,7 +310,8 @@ asyncOnion :: (OnionDestination r -> STM (OnionDestination r, Int))
 asyncOnion getTimeout client req oaddr unwrap withResult = do
     -- TODO: Restore "Four tries and then we tap out" behavior.
     qid <- QR.asyncQuery client (announceSerializer getTimeout) req oaddr $ \k mb -> do
-            forM_ mb $ \r -> dput XAnnounce $ show (onionNodeInfo oaddr) ++ " async sent response: " ++ show r
+            forM_ mb $ \mr -> forM_ mr $ \r ->
+                dput XAnnounceResponse $ showResponse True (onionNodeInfo oaddr) req r
             withResult k $ case mb of
                 Success x -> maybe (TimedOut)
                                    (Success . unwrap (onionNodeInfo oaddr))
diff --git a/dht/src/Network/Tox/Relay.hs b/dht/src/Network/Tox/Relay.hs
index dd150917..96838688 100644
--- a/dht/src/Network/Tox/Relay.hs
+++ b/dht/src/Network/Tox/Relay.hs
@@ -80,12 +80,12 @@ relaySession :: TransportCrypto
                 -> Int
                 -> Handle
                 -> IO ()
-relaySession crypto clients cons sendOnion _ conid h = do
+relaySession crypto clients cons sendOnion _ thistcp h = do
     -- atomically $ modifyTVar' cons $ IntMap.insert conid h
 
     -- mhello <- fmap (>>= \h -> decryptPayload (computeSharedSecret me (helloFrom h) (helloNonce h)) h) $ hGetSized h
 
-    dput XRelay $ "Relay client session conid=" ++ show conid
+    dput XRelay $ "Relay client session tcp=" ++ show thistcp
     (hGetSized h >>=) $ mapM_ $ \helloE -> do
 
     let me = transportSecret crypto
@@ -103,13 +103,12 @@ relaySession crypto clients cons sendOnion _ conid h = do
             w24 <- transportNewNonce crypto
             return (skey, Welcome w24 $ pure dta)
 
-        {-
-        dput XRelay $ unlines [ "Relay to send welcome to client. conid=" ++ show conid
-                              , show welcome
-                              ]
-        -}
         B.hPut h $ encode $ encryptPayload (noncef $ welcomeNonce welcome) welcome
-        dput XRelay $ "Relay welcomes (conid=" ++ show conid ++ ") " ++ showKey256 them
+        dput XRelay $ unlines
+            [ "Relay welcomes (tcp=" ++ show thistcp ++ ") " ++ showKey256 them
+            -- , "   hello=" ++ show hello
+            -- , " welcome=" ++ show welcome
+            ]
 
         noncef' <- let them' = sessionPublicKey (runIdentity $ helloData hello)
                    in lookupNonceFunction crypto me' them'
@@ -143,22 +142,25 @@ relaySession crypto clients cons sendOnion _ conid h = do
                 atomically $ modifyTVar' cons $ Map.insert (helloFrom hello) (sendPacket,session)
                 return (sendPacket,session)
 
-            handlePacket cons conid (helloFrom hello) crypto sendOnion sendPacket session pkt0
+            handlePacket cons thistcp (helloFrom hello) crypto sendOnion sendPacket session pkt0
 
-            atomically $ modifyTVar' clients $ IntMap.insert conid $
+            atomically $ modifyTVar' clients $ IntMap.insert thistcp $
                 \p -> do
-                    dput XOnion $ "Sending onion reply to TCP client conid="++show conid
+                    dput XOnion $ unlines
+                        [ "Sending onion reply to TCP client tcp="++show thistcp
+                        , " pkt0=" ++ show pkt0
+                        ]
                     sendPacket p
 
             flip fix (incrementNonce24 base)  $ \loop n24 -> do
                 m <- readPacket n24
                 forM_ m $ \p -> do
-                    handlePacket cons conid (helloFrom hello) crypto sendOnion sendPacket session p
+                    handlePacket cons thistcp (helloFrom hello) crypto sendOnion sendPacket session p
                     loop (incrementNonce24 n24)
          `finally` do
-            atomically $ modifyTVar' clients $ IntMap.delete conid
+            atomically $ modifyTVar' clients $ IntMap.delete thistcp
             disconnect cons (helloFrom hello)
-            dput XRelay $ "Relay client session closed. conid=" ++ show conid
+            dput XRelay $ "Relay client session closed. tcp=" ++ show thistcp
 
 handlePacket :: TVar (Map PublicKey (RelayPacket -> IO (), TVar RelaySession)) -- ^ All sessions.
                       -> Int -- ^ TCP client number.
@@ -211,7 +213,7 @@ handlePacket cons thistcp thisKey crypto sendOnion sendToClient session = \case
     RelayPing x -> sendToClient $ RelayPong x -- TODO x==0 is invalid.  Do we care?
 
     OOBSend them bs -> do
-        dput XRelay $ "OOB send to " ++ showKey256 them
+        dput XRelay $ "OOB send from " ++ showKey256 thisKey ++ " to " ++ showKey256 them
         m <- atomically $ Map.lookup them <$> readTVar cons
         forM_ m $ \(sendToThem,_) -> sendToThem $ OOBRecv thisKey bs