From d4c209fb9543019461bcf612da67708aeabcdce2 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Sat, 25 Jan 2020 01:02:33 -0500 Subject: Ported dhtd to reworked QueryResponse design. --- dht/src/Network/BitTorrent/MainlineDHT.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'dht/src/Network/BitTorrent/MainlineDHT.hs') diff --git a/dht/src/Network/BitTorrent/MainlineDHT.hs b/dht/src/Network/BitTorrent/MainlineDHT.hs index 705d7291..e0715d4a 100644 --- a/dht/src/Network/BitTorrent/MainlineDHT.hs +++ b/dht/src/Network/BitTorrent/MainlineDHT.hs @@ -431,11 +431,11 @@ showPacket f addr flow bs = L8.unpack $ L8.unlines es -- Add detailed printouts for every packet. addVerbosity :: Transport err SockAddr ByteString -> Transport err SockAddr ByteString addVerbosity tr = - tr { awaitMessage = \kont -> awaitMessage tr $ \m -> do + tr { awaitMessage = do + (m,io) <- awaitMessage tr case m of - Arrival addr msg -> dput XBitTorrent (showPacket id addr " --> " msg) - _ -> return () - kont m + Arrival addr msg -> return (m, io >> dput XBitTorrent (showPacket id addr " --> " msg)) + _ -> return (m, io) , sendMessage = \addr msg -> do dput XBitTorrent (showPacket id addr " <-- " msg) sendMessage tr addr msg @@ -603,7 +603,7 @@ newClient swarms addr udp = do -- recursive since 'updateRouting' does not invoke 'awaitMessage' which -- which was modified by 'onInbound'. However, I'm going to avoid the -- mutual reference just to be safe. - outgoingClient = client { clientNet = net { awaitMessage = pure . ($ Terminated) } } + outgoingClient = client { clientNet = net { awaitMessage = pure (Terminated, return ()) } } dispatch = DispatchMethods { classifyInbound = classify -- :: x -> MessageClass err meth tid addr x -- cgit v1.2.3