Code to enable detailed packet printouts (disabled via comment).

1 files changed, 21 insertions, 3 deletions

diff --git a/Mainline.hs b/Mainline.hs
index ab74eebf..deb75079 100644
--- a/Mainline.hs
+++ b/Mainline.hs
@@ -411,14 +411,31 @@ encodeAny tid key val aux = toDict $
         .: "y" .=! key
         .: endDict
 
-showParseError bs addr err = L8.unpack $ L8.unlines es
+
+showPacket f addr flow bs = L8.unpack $ L8.unlines es
  where
-    es = map (L8.append prefix) (L8.pack err : L8.lines pp)
+    es = map (L8.append prefix) (f $ L8.lines pp)
 
-    prefix = L8.pack (either show show $ either4or6 addr) <> " --> "
+    prefix = L8.pack (either show show $ either4or6 addr) <> flow
 
     pp = either L8.pack showBEncode $ BE.decode bs
 
+-- Add detailed printouts for every packet.
+addVerbosity tr =
+    tr { awaitMessage = do
+            m <- awaitMessage tr
+            forM_ m $ mapM_ $ \(msg,addr) -> do
+                hPutStrLn stderr (showPacket id addr " --> " msg)
+            return m
+       , sendMessage = \addr msg -> do
+            hPutStrLn stderr (showPacket id addr " <-- " msg)
+            sendMessage tr addr msg
+       }
+
+
+
+showParseError bs addr err = showPacket (L8.pack err :) addr " --> " bs
+
 parsePacket :: ByteString -> SockAddr -> Either String (Message BValue, NodeInfo)
 parsePacket bs addr = left (showParseError bs addr) $ do
     pkt <- BE.decode bs
@@ -540,6 +557,7 @@ newClient addr = do
     map_var <- atomically $ newTVar (0, mempty)
     let net = onInbound (updateRouting outgoingClient routing)
               $ layerTransport parsePacket encodePacket
+              -- $ addVerbosity
               $ udp
 
         -- Paranoid: It's safe to define /net/ and /client/ to be mutually