Moved parse-error printing from addHandler to forkListener.

8 files changed, 26 insertions, 29 deletions

diff --git a/dht/examples/dhtd.hs b/dht/examples/dhtd.hs
index de315e35..0dcb4237 100644
--- a/dht/examples/dhtd.hs
+++ b/dht/examples/dhtd.hs
@@ -1803,7 +1803,7 @@ main = do
            fromMaybe bail $ msock <&> \(udp,sock) -> do
             addr <- getSocketName sock
             (bt,btR,btBootstrap4, btBootstrap6,quitBtClient) <- Mainline.newClient swarms addr udp
-            quitBt <- forkListener "bt" (clientNet bt)
+            quitBt <- forkListener "bt" (dput XBitTorrent . mappend "bt-parse: ") (clientNet bt)
             mainlineSearches <- atomically $ newTVar Map.empty
             peerPort <- atomically $ newTVar 6881 -- BitTorrent client TCP port.
             let mainlineDHT bkts wantip = DHT
diff --git a/dht/examples/tcpclient.hs b/dht/examples/tcpclient.hs
index d168b1fb..858a617d 100644
--- a/dht/examples/tcpclient.hs
+++ b/dht/examples/tcpclient.hs
@@ -16,7 +16,7 @@ main = do
     setVerbose XUnexpected
     crypto <- newCrypto
     (_,client) <- newClient crypto id (\cb p -> cb (Just (False,p)))
-    quitTCP <- forkListener "TCP-recv" (addHandler print (handleMessage client) $ clientNet client)
+    quitTCP <- forkListener "TCP-recv" (dput XTCP . (++) "tcp-parse: ") (addHandler print (handleMessage client) $ clientNet client)
     args <- getArgs
     let addr = read $ args !! 0
 
diff --git a/dht/src/DebugTag.hs b/dht/src/DebugTag.hs
index 37593e63..b5f862dc 100644
--- a/dht/src/DebugTag.hs
+++ b/dht/src/DebugTag.hs
@@ -8,6 +8,7 @@ data DebugTag
   | XAnnounceResponse
   | XBitTorrent
   | XDBus
+  | XDHT
   | XLan
   | XMan
   | XNetCrypto
diff --git a/dht/src/Network/BitTorrent/MainlineDHT.hs b/dht/src/Network/BitTorrent/MainlineDHT.hs
index a83cf740..705d7291 100644
--- a/dht/src/Network/BitTorrent/MainlineDHT.hs
+++ b/dht/src/Network/BitTorrent/MainlineDHT.hs
@@ -623,11 +623,8 @@ newClient swarms addr udp = do
         gen :: Word16 -> (TransactionId, Word16)
         gen cnt = (TransactionId $ S.encode cnt, cnt+1)
 
-        ignoreParseError :: String -> IO ()
-        ignoreParseError _ = return ()
-
         client = Client
-            { clientNet           = addHandler ignoreParseError (handleMessage client) net
+            { clientNet           = addHandler (handleMessage client) net
             , clientDispatcher    = dispatch
             , clientErrorReporter = ignoreErrors -- printErrors stderr
             , clientPending       = map_var
diff --git a/dht/src/Network/BitTorrent/Tracker/Transport.hs b/dht/src/Network/BitTorrent/Tracker/Transport.hs
index 5d225a7e..eacf7946 100644
--- a/dht/src/Network/BitTorrent/Tracker/Transport.hs
+++ b/dht/src/Network/BitTorrent/Tracker/Transport.hs
@@ -94,4 +94,4 @@ implementTracker err net c = do
                     , clientAddress       = const $ return localhost4
                     , clientResponseId    = return
                     }
-    return $ addHandler (\err -> return ()) (handleMessage client) net
+    return $ addHandler (handleMessage client) net
diff --git a/dht/src/Network/Tox.hs b/dht/src/Network/Tox.hs
index 6adfb9a9..084a9978 100644
--- a/dht/src/Network/Tox.hs
+++ b/dht/src/Network/Tox.hs
@@ -174,7 +174,6 @@ newClient drg net classify selfAddr handlers modifytbl modifynet = do
                 , lookupHandler   = handlers -- var
                 , tableMethods    = modifytbl tbl
                 }
-        eprinter = logErrors -- printErrors stderr
         mkclient :: (TransactionMethods
                          (g, pending) DHT.TransactionId addr x,
                        TVar (g, pending))
@@ -184,9 +183,9 @@ newClient drg net classify selfAddr handlers modifytbl modifynet = do
                       -> ClientA String meth DHT.TransactionId addr x x
         mkclient (tbl,var) handlers =
             let client = Client
-                    { clientNet           = addHandler (reportParseError eprinter) (handleMessage client) $ modifynet client net
+                    { clientNet           = addHandler (handleMessage client) $ modifynet client net
                     , clientDispatcher    = dispatch tbl var (handlers client) client
-                    , clientErrorReporter = eprinter
+                    , clientErrorReporter = logErrors
                     , clientPending       = var
                     , clientAddress       = selfAddr
                     , clientResponseId    = genNonce24 var
@@ -412,8 +411,8 @@ newToxOverTransport keydb addr onNewSession (crypto,roster) udp tcp = do
         { toxDHT            = dhtclient
         , toxOnion          = onionclient
         , toxToRoute        = onInbound (updateContactInfo roster) dtacrypt
-        , toxCrypto         = addHandler (dput XMisc) (sessionHandler sessions) cryptonet
-        , toxHandshakes     = addHandler (dput XMisc) (handshakeH sparams) handshakes
+        , toxCrypto         = addHandler (sessionHandler sessions) cryptonet
+        , toxHandshakes     = addHandler (handshakeH sparams) handshakes
         , toxHandshakeCache = hscache
         , toxCryptoKeys     = crypto
         , toxRouting        = mkrouting dhtclient
@@ -467,13 +466,13 @@ forkTox :: Tox extra
             -> Bool -- tcp
             -> IO (IO (), [NodeInfo] -> [NodeInfo] -> IO (), [NodeInfo] -> [NodeInfo] -> IO ())
 forkTox tox with_avahi with_tcp = do
-    quitHs      <- forkListener "toxHandshakes" (toxHandshakes tox)
-    quitToRoute <- forkListener "toxToRoute" (toxToRoute tox)
-    quitOnion   <- forkListener "toxOnion" (clientNet $ toxOnion tox)
-    quitDHT     <- forkListener "toxDHT" (clientNet $ toxDHT tox)
-    quitNC      <- forkListener "toxCrypto" (toxCrypto tox)
+    quitHs      <- forkListener "toxHandshakes" (dput XMan . mappend "hs-parse: ") (toxHandshakes tox)
+    quitToRoute <- forkListener "toxToRoute" (dput XOnion . mappend "dta-parse: ") (toxToRoute tox)
+    quitOnion   <- forkListener "toxOnion" (dput XOnion . mappend "onion-parse: ") (clientNet $ toxOnion tox)
+    quitDHT     <- forkListener "toxDHT" (dput XDHT . mappend "dht-parse: ") (clientNet $ toxDHT tox)
+    quitNC      <- forkListener "toxCrypto" (dput XNetCrypto . mappend "nc-parse: ") (toxCrypto tox)
     quitTCP     <- if with_tcp
-                    then forkListener "relay-client" (clientNet $ tcpClient $ tcpKademliaClient $ toxOnionRoutes tox)
+                    then forkListener "relay-client" (dput XTCP . mappend "tcp-parse: ") (clientNet $ tcpClient $ tcpKademliaClient $ toxOnionRoutes tox)
                     else return $ return ()
     refresher4 <- forkPollForRefresh (DHT.refresher4 $ toxRouting tox)
     refresher6 <- forkPollForRefresh (DHT.refresher6 $ toxRouting tox)
diff --git a/dht/src/Network/Tox/Onion/Routes.hs b/dht/src/Network/Tox/Onion/Routes.hs
index 374b9648..46ded48d 100644
--- a/dht/src/Network/Tox/Onion/Routes.hs
+++ b/dht/src/Network/Tox/Onion/Routes.hs
@@ -249,7 +249,7 @@ newOnionRouter crypto perror tcp_enabled = do
                  , tcpKademliaClient = tcp
                     { TCP.tcpClient =
                         let c = TCP.tcpClient tcp
-                        in c { clientNet = addHandler perror (handleMessage c)
+                        in c { clientNet = addHandler (handleMessage c)
                                             $ onInbound (updateTCP or)
                                             $ clientNet c }
                     }
diff --git a/server/src/Network/QueryResponse.hs b/server/src/Network/QueryResponse.hs
index ea87abe4..69cc6f50 100644
--- a/server/src/Network/QueryResponse.hs
+++ b/server/src/Network/QueryResponse.hs
@@ -188,17 +188,16 @@ partitionTransport parse encodex tr =
 -- Note: If you add a handler to one of the branches before applying a
 -- 'mergeTransports' combinator, then this handler may not block or return
 -- Nothing.
-addHandler :: (err -> IO ()) -> (addr -> x -> IO (Maybe (x -> x))) -> TransportA err addr x y -> TransportA err addr x y
-addHandler onParseError f tr = tr
+addHandler :: (addr -> x -> IO (Maybe (x -> x))) -> TransportA err addr x y -> TransportA err addr x y
+addHandler f tr = tr
     { awaitMessage = \kont -> fix $ \eat -> awaitMessage tr $ \case
         Arrival addr x -> f addr x >>= maybe (join $ atomically eat) (kont . Arrival addr . ($ x))
-        ParseError e   -> onParseError e >> kont (ParseError e)
-        Terminated     -> kont Terminated
+        m              -> kont m
     }
 
 -- | Modify a 'Transport' to invoke an action upon every received packet.
 onInbound :: (addr -> x -> IO ()) -> Transport err addr x -> Transport err addr x
-onInbound f tr = addHandler (const $ return ()) (\addr x -> f addr x >> return (Just id)) tr
+onInbound f tr = addHandler (\addr x -> f addr x >> return (Just id)) tr
 
 -- * Using a query\/response client.
 
@@ -208,19 +207,20 @@ onInbound f tr = addHandler (const $ return ()) (\addr x -> f addr x >> return (
 --  Example usage:
 --
 --  > -- Start client.
---  > quitServer <- forkListener "listener" (clientNet client)
+--  > quitServer <- forkListener "listener" (\_ -> return()) (clientNet client)
 --  > -- Send a query q, recieve a response r.
 --  > r <- sendQuery client method q
 --  > -- Quit client.
 --  > quitServer
-forkListener :: String -> Transport err addr x -> IO (IO ())
-forkListener name client = do
+forkListener :: String -> (err -> IO ()) -> Transport err addr x -> IO (IO ())
+forkListener name onParseError client = do
     setActive client True
     thread_id <- forkIO $ do
         myThreadId >>= flip labelThread ("listener."++name)
         fix $ \loop -> join $ atomically $ awaitMessage client $ \case
-            Terminated -> return ()
-            _          -> loop
+            Terminated   -> return ()
+            ParseError e -> onParseError e >> loop
+            _            -> loop
         dput XMisc $ "Listener died: " ++ name
     return $ do
         setActive client False