diff options
author | Joe Crayne <joe@jerkface.net> | 2020-01-03 18:22:16 -0500 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2020-01-07 13:24:59 -0500 |
commit | 15ab3290ad04280764968ba4760474a8c0cbfa52 (patch) | |
tree | 8df7bdfe38005f5478243427bb2b692d32843283 /dht/src | |
parent | b411ab66ceee7386e4829e2337c735a08fb3d54d (diff) |
Modify kademlia search to distinguish a Canceled from timed-out query.
Diffstat (limited to 'dht/src')
-rw-r--r-- | dht/src/Network/BitTorrent/MainlineDHT.hs | 26 | ||||
-rw-r--r-- | dht/src/Network/Tox.hs | 2 | ||||
-rw-r--r-- | dht/src/Network/Tox/DHT/Handlers.hs | 12 | ||||
-rw-r--r-- | dht/src/Network/Tox/Onion/Handlers.hs | 19 | ||||
-rw-r--r-- | dht/src/Network/Tox/TCP.hs | 8 |
5 files changed, 38 insertions, 29 deletions
diff --git a/dht/src/Network/BitTorrent/MainlineDHT.hs b/dht/src/Network/BitTorrent/MainlineDHT.hs index fc69fedd..8532b492 100644 --- a/dht/src/Network/BitTorrent/MainlineDHT.hs +++ b/dht/src/Network/BitTorrent/MainlineDHT.hs | |||
@@ -70,7 +70,7 @@ import Network.Kademlia.Search (Search (..)) | |||
70 | import Network.BitTorrent.DHT.Token as Token | 70 | import Network.BitTorrent.DHT.Token as Token |
71 | import qualified Network.Kademlia.Routing as R | 71 | import qualified Network.Kademlia.Routing as R |
72 | ;import Network.Kademlia.Routing (getTimestamp) | 72 | ;import Network.Kademlia.Routing (getTimestamp) |
73 | import Network.QueryResponse | 73 | import Network.QueryResponse as QR |
74 | import Network.Socket | 74 | import Network.Socket |
75 | import System.IO.Error | 75 | import System.IO.Error |
76 | import System.IO.Unsafe (unsafeInterleaveIO) | 76 | import System.IO.Unsafe (unsafeInterleaveIO) |
@@ -569,7 +569,7 @@ newClient swarms addr = do | |||
569 | -- We defer initializing the refreshSearch and refreshPing until we | 569 | -- We defer initializing the refreshSearch and refreshPing until we |
570 | -- have a client to send queries with. | 570 | -- have a client to send queries with. |
571 | let nullPing = const $ return False | 571 | let nullPing = const $ return False |
572 | nullSearch = mainlineSearch $ \_ _ -> return Nothing | 572 | nullSearch = mainlineSearch $ \_ _ -> return Canceled |
573 | tbl4 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info R.defaultBucketCount | 573 | tbl4 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info R.defaultBucketCount |
574 | refresher4 <- newBucketRefresher tbl4 nullSearch nullPing | 574 | refresher4 <- newBucketRefresher tbl4 nullSearch nullPing |
575 | tbl6 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info6 R.defaultBucketCount | 575 | tbl6 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info6 R.defaultBucketCount |
@@ -1045,14 +1045,14 @@ mainlineSend :: ( BEncode xqry | |||
1045 | -> MainlineClient | 1045 | -> MainlineClient |
1046 | -> qry | 1046 | -> qry |
1047 | -> NodeInfo | 1047 | -> NodeInfo |
1048 | -> IO (Maybe rsp) | 1048 | -> IO (QR.Result rsp) |
1049 | mainlineSend meth unwrap msg client nid addr = do | 1049 | mainlineSend meth unwrap msg client nid addr = do |
1050 | reply <- sendQuery client serializer (msg nid) addr | 1050 | reply <- sendQuery client serializer (msg nid) addr |
1051 | return $ case reply of | 1051 | return $ case reply of |
1052 | Success (Right x) -> Just x | 1052 | Success (Right x) -> Success x |
1053 | Success (Left e) -> Nothing -- TODO: Do something with parse errors. | 1053 | Success (Left e) -> Canceled -- TODO: Do something with parse errors. |
1054 | Canceled -> Nothing | 1054 | Canceled -> Canceled |
1055 | TimedOut -> Nothing | 1055 | TimedOut -> TimedOut |
1056 | where | 1056 | where |
1057 | serializer = MethodSerializer | 1057 | serializer = MethodSerializer |
1058 | { methodTimeout = \ni -> return (ni, 5000000) | 1058 | { methodTimeout = \ni -> return (ni, 5000000) |
@@ -1066,23 +1066,23 @@ mainlineSend meth unwrap msg client nid addr = do | |||
1066 | 1066 | ||
1067 | ping :: MainlineClient -> NodeInfo -> IO Bool | 1067 | ping :: MainlineClient -> NodeInfo -> IO Bool |
1068 | ping client addr = | 1068 | ping client addr = |
1069 | fromMaybe False | 1069 | fromMaybe False . resultToMaybe |
1070 | <$> mainlineSend (Method "ping") (\Pong -> True) (const Ping) client () addr | 1070 | <$> mainlineSend (Method "ping") (\Pong -> True) (const Ping) client () addr |
1071 | 1071 | ||
1072 | -- searchQuery :: ni -> IO (Maybe [ni], [r], tok)) | 1072 | -- searchQuery :: ni -> IO (Maybe [ni], [r], tok)) |
1073 | getNodes :: MainlineClient -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ())) | 1073 | getNodes :: MainlineClient -> NodeId -> NodeInfo -> IO (QR.Result ([NodeInfo],[NodeInfo],Maybe ())) |
1074 | getNodes = mainlineSend (Method "find_node") unwrapNodes $ flip FindNode (Just Want_Both) | 1074 | getNodes = mainlineSend (Method "find_node") unwrapNodes $ flip FindNode (Just Want_Both) |
1075 | 1075 | ||
1076 | unwrapNodes :: NodeFound -> ([NodeInfo], [NodeInfo], Maybe ()) | 1076 | unwrapNodes :: NodeFound -> ([NodeInfo], [NodeInfo], Maybe ()) |
1077 | unwrapNodes (NodeFound ns4 ns6) = (ns4++ns6, ns4++ns6, Just ()) | 1077 | unwrapNodes (NodeFound ns4 ns6) = (ns4++ns6, ns4++ns6, Just ()) |
1078 | 1078 | ||
1079 | getPeers :: MainlineClient -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[PeerAddr],Maybe Token)) | 1079 | getPeers :: MainlineClient -> NodeId -> NodeInfo -> IO (QR.Result ([NodeInfo],[PeerAddr],Maybe Token)) |
1080 | getPeers = mainlineSend (Method "get_peers") unwrapPeers $ flip GetPeers (Just Want_Both) . coerce | 1080 | getPeers = mainlineSend (Method "get_peers") unwrapPeers $ flip GetPeers (Just Want_Both) . coerce |
1081 | 1081 | ||
1082 | unwrapPeers :: GotPeers -> ([NodeInfo], [PeerAddr], Maybe Token) | 1082 | unwrapPeers :: GotPeers -> ([NodeInfo], [PeerAddr], Maybe Token) |
1083 | unwrapPeers (GotPeers ps (NodeFound ns4 ns6) tok) = (ns4++ns6, ps, Just tok) | 1083 | unwrapPeers (GotPeers ps (NodeFound ns4 ns6) tok) = (ns4++ns6, ps, Just tok) |
1084 | 1084 | ||
1085 | mainlineSearch :: (NodeId -> NodeInfo -> IO (Maybe ([NodeInfo], [r], Maybe tok))) | 1085 | mainlineSearch :: (NodeId -> NodeInfo -> IO (QR.Result ([NodeInfo], [r], Maybe tok))) |
1086 | -> Search NodeId (IP, PortNumber) tok NodeInfo r | 1086 | -> Search NodeId (IP, PortNumber) tok NodeInfo r |
1087 | mainlineSearch qry = Search | 1087 | mainlineSearch qry = Search |
1088 | { searchSpace = mainlineSpace | 1088 | { searchSpace = mainlineSpace |
@@ -1140,5 +1140,5 @@ resolve want hostAndPort = do | |||
1140 | 1140 | ||
1141 | 1141 | ||
1142 | announce :: MainlineClient -> Announce -> NodeInfo -> IO (Maybe Announced) | 1142 | announce :: MainlineClient -> Announce -> NodeInfo -> IO (Maybe Announced) |
1143 | announce client msg addr = do | 1143 | announce client msg addr = |
1144 | mainlineSend (Method "announce_peer") id (\() -> msg) client () addr | 1144 | resultToMaybe <$> mainlineSend (Method "announce_peer") id (\() -> msg) client () addr |
diff --git a/dht/src/Network/Tox.hs b/dht/src/Network/Tox.hs index f17bad2c..f9f35ea4 100644 --- a/dht/src/Network/Tox.hs +++ b/dht/src/Network/Tox.hs | |||
@@ -349,7 +349,7 @@ newToxOverTransport keydb addr onNewSession (crypto,roster) udp tcp = do | |||
349 | -- TODO: Refactor so that these threads are forked when 'forkTox' is invoked. | 349 | -- TODO: Refactor so that these threads are forked when 'forkTox' is invoked. |
350 | -- This function should only initialize state. | 350 | -- This function should only initialize state. |
351 | orouter' <- forkRouteBuilder orouter | 351 | orouter' <- forkRouteBuilder orouter |
352 | $ \nid ni -> fmap (\(_,ns,_)->ns) | 352 | $ \nid ni -> fmap (\(_,ns,_)->ns) . resultToMaybe |
353 | <$> DHT.getNodes dhtclient (DHT.nodesOfInterest $ mkrouting dhtclient) nid (Multi.UDP ==> ni) | 353 | <$> DHT.getNodes dhtclient (DHT.nodesOfInterest $ mkrouting dhtclient) nid (Multi.UDP ==> ni) |
354 | 354 | ||
355 | toks <- do | 355 | toks <- do |
diff --git a/dht/src/Network/Tox/DHT/Handlers.hs b/dht/src/Network/Tox/DHT/Handlers.hs index dc4ca5fa..d132da88 100644 --- a/dht/src/Network/Tox/DHT/Handlers.hs +++ b/dht/src/Network/Tox/DHT/Handlers.hs | |||
@@ -198,7 +198,7 @@ newRouting addr crypto update4 update6 = do | |||
198 | nullSearch = Search | 198 | nullSearch = Search |
199 | { searchSpace = toxSpace | 199 | { searchSpace = toxSpace |
200 | , searchNodeAddress = nodeIP &&& nodePort | 200 | , searchNodeAddress = nodeIP &&& nodePort |
201 | , searchQuery = \_ _ -> return Nothing | 201 | , searchQuery = \_ _ -> return Canceled |
202 | , searchAlpha = 1 | 202 | , searchAlpha = 1 |
203 | , searchK = 2 | 203 | , searchK = 2 |
204 | } | 204 | } |
@@ -410,7 +410,8 @@ unsendNodes _ = Nothing | |||
410 | unwrapNodes :: SendNodes -> ( [NodeInfo], [NodeInfo], Maybe () ) | 410 | unwrapNodes :: SendNodes -> ( [NodeInfo], [NodeInfo], Maybe () ) |
411 | unwrapNodes (SendNodes ns) = (map udpNodeInfo ns,map udpNodeInfo ns,Just ()) | 411 | unwrapNodes (SendNodes ns) = (map udpNodeInfo ns,map udpNodeInfo ns,Just ()) |
412 | 412 | ||
413 | getNodes :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> NodeId -> Multi.NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ())) | 413 | getNodes :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> NodeId -> Multi.NodeInfo |
414 | -> IO (QR.Result ([NodeInfo],[NodeInfo],Maybe ())) | ||
414 | getNodes client cbvar nid addr = do | 415 | getNodes client cbvar nid addr = do |
415 | -- dput XMisc $ show addr ++ " <-- getnodes " ++ show nid | 416 | -- dput XMisc $ show addr ++ " <-- getnodes " ++ show nid |
416 | reply <- QR.sendQuery client (serializer GetNodesType DHTGetNodes unsendNodes) (GetNodes nid) addr | 417 | reply <- QR.sendQuery client (serializer GetNodesType DHTGetNodes unsendNodes) (GetNodes nid) addr |
@@ -423,9 +424,12 @@ getNodes client cbvar nid addr = do | |||
423 | forM_ mcbs $ \cbs -> do | 424 | forM_ mcbs $ \cbs -> do |
424 | forM_ cbs $ \cb -> do | 425 | forM_ cbs $ \cb -> do |
425 | rumoredAddress cb now addr (udpNodeInfo n) | 426 | rumoredAddress cb now addr (udpNodeInfo n) |
426 | return $ fmap unwrapNodes $ join $ resultToMaybe reply | 427 | return $ case reply of |
428 | Success x -> maybe Canceled (Success . unwrapNodes) x | ||
429 | _ -> fmap (error "Network.Tox.DHT.Handlers.getNodes: the impossible happened!") reply | ||
427 | 430 | ||
428 | getNodesUDP :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ())) | 431 | getNodesUDP :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> NodeId -> NodeInfo |
432 | -> IO (QR.Result ([NodeInfo],[NodeInfo],Maybe ())) | ||
429 | getNodesUDP client cbvar nid addr = getNodes client cbvar nid (Multi.UDP ==> addr) | 433 | getNodesUDP client cbvar nid addr = getNodes client cbvar nid (Multi.UDP ==> addr) |
430 | 434 | ||
431 | updateRouting :: Client -> Routing | 435 | updateRouting :: Client -> Routing |
diff --git a/dht/src/Network/Tox/Onion/Handlers.hs b/dht/src/Network/Tox/Onion/Handlers.hs index fa7bc83c..015c758c 100644 --- a/dht/src/Network/Tox/Onion/Handlers.hs +++ b/dht/src/Network/Tox/Onion/Handlers.hs | |||
@@ -277,15 +277,17 @@ sendOnion :: (OnionDestination r -> STM (OnionDestination r, Int)) | |||
277 | -> AnnounceRequest | 277 | -> AnnounceRequest |
278 | -> OnionDestination r | 278 | -> OnionDestination r |
279 | -> (NodeInfo -> AnnounceResponse -> t) | 279 | -> (NodeInfo -> AnnounceResponse -> t) |
280 | -> IO (Maybe t) | 280 | -> IO (QR.Result t) |
281 | sendOnion getTimeout client req oaddr unwrap = | 281 | sendOnion getTimeout client req oaddr unwrap = |
282 | -- Four tries and then we tap out. | 282 | -- Four tries and then we tap out. |
283 | flip fix 4 $ \loop n -> do | 283 | flip fix 4 $ \loop n -> do |
284 | mb <- QR.sendQuery client (announceSerializer getTimeout) req oaddr | 284 | mb <- QR.sendQuery client (announceSerializer getTimeout) req oaddr |
285 | forM_ mb $ \r -> dput XAnnounce $ show (onionNodeInfo oaddr) ++ " sent response: " ++ show r | 285 | forM_ mb $ \r -> dput XAnnounce $ show (onionNodeInfo oaddr) ++ " sent response: " ++ show r |
286 | maybe (if n>0 then loop $! n - 1 else return Nothing) | 286 | let re = if n>0 then loop $! n - 1 else return Canceled |
287 | (return . Just . unwrap (onionNodeInfo oaddr)) | 287 | case mb of |
288 | $ join $ resultToMaybe mb | 288 | Success x -> maybe re (return . Success . unwrap (onionNodeInfo oaddr)) x |
289 | Canceled -> return Canceled | ||
290 | TimedOut -> re | ||
289 | 291 | ||
290 | 292 | ||
291 | -- | Lookup the secret counterpart for a given alias key. | 293 | -- | Lookup the secret counterpart for a given alias key. |
@@ -294,7 +296,7 @@ getRendezvous :: (OnionDestination r -> STM (OnionDestination r, Int)) | |||
294 | -> Client r | 296 | -> Client r |
295 | -> NodeId | 297 | -> NodeId |
296 | -> NodeInfo | 298 | -> NodeInfo |
297 | -> IO (Maybe ([NodeInfo],[Rendezvous],Maybe Nonce32)) | 299 | -> IO (Result ([NodeInfo],[Rendezvous],Maybe Nonce32)) |
298 | getRendezvous getTimeout crypto client nid ni = do | 300 | getRendezvous getTimeout crypto client nid ni = do |
299 | asel <- atomically $ selectAlias crypto nid | 301 | asel <- atomically $ selectAlias crypto nid |
300 | let oaddr = OnionDestination asel ni Nothing | 302 | let oaddr = OnionDestination asel ni Nothing |
@@ -319,5 +321,6 @@ putRendezvous getTimeout crypto client pubkey nonce32 ni = do | |||
319 | rendezvousKey = key2id rkey | 321 | rendezvousKey = key2id rkey |
320 | asel <- atomically $ selectAlias crypto longTermKey | 322 | asel <- atomically $ selectAlias crypto longTermKey |
321 | let oaddr = OnionDestination asel ni Nothing | 323 | let oaddr = OnionDestination asel ni Nothing |
322 | sendOnion getTimeout client (AnnounceRequest nonce32 longTermKey rendezvousKey) oaddr | 324 | fmap resultToMaybe |
325 | $ sendOnion getTimeout client (AnnounceRequest nonce32 longTermKey rendezvousKey) oaddr | ||
323 | $ \ni resp -> (Rendezvous rkey ni, resp) | 326 | $ \ni resp -> (Rendezvous rkey ni, resp) |
diff --git a/dht/src/Network/Tox/TCP.hs b/dht/src/Network/Tox/TCP.hs index 385da35b..932b4ab3 100644 --- a/dht/src/Network/Tox/TCP.hs +++ b/dht/src/Network/Tox/TCP.hs | |||
@@ -221,12 +221,14 @@ getTCPNodes tcp seeking dst = do | |||
221 | -} | 221 | -} |
222 | 222 | ||
223 | getUDPNodes :: TCPClient err Nonce8 -> NodeId -> UDP.NodeInfo -> IO (Maybe ([UDP.NodeInfo], [UDP.NodeInfo], Maybe ())) | 223 | getUDPNodes :: TCPClient err Nonce8 -> NodeId -> UDP.NodeInfo -> IO (Maybe ([UDP.NodeInfo], [UDP.NodeInfo], Maybe ())) |
224 | getUDPNodes tcp seeking dst = fmap fst <$> getUDPNodes' tcp seeking dst | 224 | getUDPNodes tcp seeking dst = fmap fst . resultToMaybe <$> getUDPNodes' tcp seeking dst |
225 | 225 | ||
226 | getUDPNodes' :: TCPClient err Nonce8 -> NodeId -> UDP.NodeInfo -> IO (Maybe (([UDP.NodeInfo], [UDP.NodeInfo], Maybe ()), NodeInfo)) | 226 | getUDPNodes' :: TCPClient err Nonce8 -> NodeId -> UDP.NodeInfo -> IO (QR.Result (([UDP.NodeInfo], [UDP.NodeInfo], Maybe ()), NodeInfo)) |
227 | getUDPNodes' tcp seeking dst0 = do | 227 | getUDPNodes' tcp seeking dst0 = do |
228 | mgateway <- atomically $ tcpGetGateway tcp dst0 | 228 | mgateway <- atomically $ tcpGetGateway tcp dst0 |
229 | fmap (join . fmap resultToMaybe) $ forM mgateway $ \gateway -> do | 229 | case mgateway of |
230 | Nothing -> return Canceled | ||
231 | Just gateway -> do | ||
230 | (b,c,n24) <- atomically $ do | 232 | (b,c,n24) <- atomically $ do |
231 | b <- transportNewKey (tcpCrypto tcp) | 233 | b <- transportNewKey (tcpCrypto tcp) |
232 | c <- transportNewKey (tcpCrypto tcp) | 234 | c <- transportNewKey (tcpCrypto tcp) |