From 81489b13ee734bf5c618e1b826971725df8ed808 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Fri, 24 Jan 2020 21:43:44 -0500 Subject: Moved parse-error printing from addHandler to forkListener. --- dht/examples/dhtd.hs | 2 +- dht/examples/tcpclient.hs | 2 +- dht/src/DebugTag.hs | 1 + dht/src/Network/BitTorrent/MainlineDHT.hs | 5 +---- dht/src/Network/BitTorrent/Tracker/Transport.hs | 2 +- dht/src/Network/Tox.hs | 21 ++++++++++----------- dht/src/Network/Tox/Onion/Routes.hs | 2 +- server/src/Network/QueryResponse.hs | 20 ++++++++++---------- 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 -- cgit v1.2.3