summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Network/BitTorrent/DHT/Query.hs10
-rw-r--r--src/Network/DHT/Routing.hs4
-rw-r--r--src/Network/DatagramServer.hs16
3 files changed, 15 insertions, 15 deletions
diff --git a/src/Network/BitTorrent/DHT/Query.hs b/src/Network/BitTorrent/DHT/Query.hs
index ae072db0..9162abdc 100644
--- a/src/Network/BitTorrent/DHT/Query.hs
+++ b/src/Network/BitTorrent/DHT/Query.hs
@@ -259,7 +259,7 @@ isearch f ih = do
259 tid <- myThreadId 259 tid <- myThreadId
260 labelThread tid ("search."++show ih) 260 labelThread tid ("search."++show ih)
261 Search.search s 261 Search.search s
262 -- atomically $ readTVar (Search.searchResults s) 262 -- atomically \$ readTVar (Search.searchResults s)
263 return (a, s) 263 return (a, s)
264 264
265 265
@@ -298,11 +298,11 @@ refreshNodes nid = do
298 $(logDebugS) "routing.refresh_bucket" (T.pack (render (pPrint nid))) 298 $(logDebugS) "routing.refresh_bucket" (T.pack (render (pPrint nid)))
299 nodes <- getClosest nid 299 nodes <- getClosest nid
300 do 300 do
301 -- forM (L.take 1 nodes) $ \ addr -> do 301 -- forM (L.take 1 nodes) \$ \ addr -> do
302 -- NodeFound ns <- FindNode nid <@> addr 302 -- NodeFound ns <- FindNode nid <@> addr
303 -- Expected type: ConduitM [NodeAddr ip] [NodeInfo KMessageOf ip ()] (DHT ip) () 303 -- Expected type: ConduitM [NodeAddr ip] [NodeInfo KMessageOf ip ()] (DHT ip) ()
304 -- Actual type: ConduitM [NodeInfo KMessageOf ip ()] [NodeInfo KMessageOf ip ()] (DHT ip) () 304 -- Actual type: ConduitM [NodeInfo KMessageOf ip ()] [NodeInfo KMessageOf ip ()] (DHT ip) ()
305 -- nss <- sourceList [[addr]] $= search nid (findNodeQ nid) $$ C.consume 305 -- nss <- sourceList [[addr]] \$= search nid (findNodeQ nid) $$ C.consume
306 nss <- sourceList [nodes] $= search nid (findNodeQ nid) $$ C.consume 306 nss <- sourceList [nodes] $= search nid (findNodeQ nid) $$ C.consume
307 $(logWarnS) "refreshNodes" $ "received " <> T.pack (show (L.length (L.concat nss))) <> " nodes." 307 $(logWarnS) "refreshNodes" $ "received " <> T.pack (show (L.length (L.concat nss))) <> " nodes."
308 _ <- queryParallel $ flip L.map (L.concat nss) $ \n -> do 308 _ <- queryParallel $ flip L.map (L.concat nss) $ \n -> do
@@ -310,7 +310,7 @@ refreshNodes nid = do
310 pingQ (nodeAddr n) 310 pingQ (nodeAddr n)
311 -- pingQ takes care of inserting the node. 311 -- pingQ takes care of inserting the node.
312 return () 312 return ()
313 return () -- $ L.concat nss 313 return () -- \$ L.concat nss
314 314
315-- | This operation do not block but acquire exclusive access to 315-- | This operation do not block but acquire exclusive access to
316-- routing table. 316-- routing table.
@@ -398,7 +398,7 @@ queryNode' addr q = do
398 let read_only = False -- TODO: check for NAT issues. (BEP 43) 398 let read_only = False -- TODO: check for NAT issues. (BEP 43)
399 let KRPC.Method name = KRPC.method :: KRPC.Method (Query a) (Response b) 399 let KRPC.Method name = KRPC.method :: KRPC.Method (Query a) (Response b)
400 (Response remoteId r, witnessed_ip) <- query' name (toSockAddr addr) (Query nid read_only q) 400 (Response remoteId r, witnessed_ip) <- query' name (toSockAddr addr) (Query nid read_only q)
401 -- $(logDebugS) "queryNode" $ "Witnessed address: " <> T.pack (show witnessed_ip) 401 -- \$(logDebugS) "queryNode" $ "Witnessed address: " <> T.pack (show witnessed_ip)
402 -- <> " by " <> T.pack (show (toSockAddr addr)) 402 -- <> " by " <> T.pack (show (toSockAddr addr))
403 _ <- insertNode (NodeInfo remoteId addr ()) witnessed_ip 403 _ <- insertNode (NodeInfo remoteId addr ()) witnessed_ip
404 return (remoteId, r, witnessed_ip) 404 return (remoteId, r, witnessed_ip)
diff --git a/src/Network/DHT/Routing.hs b/src/Network/DHT/Routing.hs
index 1d1aa44b..5c6abe5d 100644
--- a/src/Network/DHT/Routing.hs
+++ b/src/Network/DHT/Routing.hs
@@ -253,12 +253,12 @@ insertBucket curTime (TryInsert info) bucket
253 guard (t < curTime - delta) 253 guard (t < curTime - delta)
254 return n 254 return n
255 -- All stale: 255 -- All stale:
256 -- map key $ PSQ.atMost (curTime - delta) $ bktNodes bucket 256 -- map key \$ PSQ.atMost (curTime - delta) $ bktNodes bucket
257 257
258 already_have = maybe False (const True) $ PSQ.lookup info (bktNodes bucket) 258 already_have = maybe False (const True) $ PSQ.lookup info (bktNodes bucket)
259 259
260 map_ns f = bucket { bktNodes = f (bktNodes bucket) } 260 map_ns f = bucket { bktNodes = f (bktNodes bucket) }
261 -- map_q f = bucket { bktQ = runIdentity $ f (bktQ bucket) } 261 -- map_q f = bucket { bktQ = runIdentity \$ f (bktQ bucket) }
262 262
263insertBucket curTime (PingResult bad_node got_response) bucket 263insertBucket curTime (PingResult bad_node got_response) bucket
264 = pure ([], Bucket (upd $ bktNodes bucket) popped) 264 = pure ([], Bucket (upd $ bktNodes bucket) popped)
diff --git a/src/Network/DatagramServer.hs b/src/Network/DatagramServer.hs
index 5c77fb86..cd74f589 100644
--- a/src/Network/DatagramServer.hs
+++ b/src/Network/DatagramServer.hs
@@ -526,13 +526,13 @@ handleQuery meth raw q addr = void $ fork $ do
526 let res' = either buildError Just res 526 let res' = either buildError Just res
527 ctx = error "TODO TOX ToxCipherContext 2 or () for Mainline" 527 ctx = error "TODO TOX ToxCipherContext 2 or () for Mainline"
528 resbs = fmap (encodeHeaders ctx) res' :: Maybe BS.ByteString 528 resbs = fmap (encodeHeaders ctx) res' :: Maybe BS.ByteString
529-- TODO: Generalize this debug print. 529 -- TODO: Generalize this debug print.
530-- resbe = either toBEncode toBEncode res 530 -- resbe = either toBEncode toBEncode res
531-- $(logOther "q") $ T.unlines 531 -- .(logOther "q") \$ T.unlines
532-- [ either (const "<unicode-fail>") id $ T.decodeUtf8' (BL.toStrict $ showBEncode raw) 532 -- [ either (const "<unicode-fail>") id \$ T.decodeUtf8' (BL.toStrict $ showBEncode raw)
533-- , "==>" 533 -- , "==>"
534-- , either (const "<unicode-fail>") id $ T.decodeUtf8' (BL.toStrict $ showBEncode resbe) 534 -- , either (const "<unicode-fail>") id \$ T.decodeUtf8' (BL.toStrict $ showBEncode resbe)
535-- ] 535 -- ]
536 maybe (return ()) (sendMessage sock addr) resbs 536 maybe (return ()) (sendMessage sock addr) resbs
537 537
538handleResponse :: ( MonadKRPC h m raw msg 538handleResponse :: ( MonadKRPC h m raw msg
@@ -568,7 +568,7 @@ listener p = do
568 handle exceptions $ BS.recvFrom sock (optMaxMsgSize options) 568 handle exceptions $ BS.recvFrom sock (optMaxMsgSize options)
569 case parsePacket (msgProxy p) bs >>= \r -> (,) r <$> decodeHeaders ctx r of 569 case parsePacket (msgProxy p) bs >>= \r -> (,) r <$> decodeHeaders ctx r of
570 Left e -> -- XXX: Send parse failure message? 570 Left e -> -- XXX: Send parse failure message?
571 -- liftIO $ sendMessage sock addr $ encodeHeaders ctx (unknownMessage e) 571 -- liftIO \$ sendMessage sock addr $ encodeHeaders ctx (unknownMessage e)
572 return () -- Without transaction id, error message isn't very useful. 572 return () -- Without transaction id, error message isn't very useful.
573 Right (raw,m) -> 573 Right (raw,m) ->
574 case envelopeClass m of 574 case envelopeClass m of