diff options
Diffstat (limited to 'dht')
-rw-r--r-- | dht/src/Network/BitTorrent/MainlineDHT.hs | 54 | ||||
-rw-r--r-- | dht/src/Network/Tox/DHT/Handlers.hs | 69 | ||||
-rw-r--r-- | dht/src/Network/Tox/Onion/Handlers.hs | 44 |
3 files changed, 23 insertions, 144 deletions
diff --git a/dht/src/Network/BitTorrent/MainlineDHT.hs b/dht/src/Network/BitTorrent/MainlineDHT.hs index 7589f538..ed97ee31 100644 --- a/dht/src/Network/BitTorrent/MainlineDHT.hs +++ b/dht/src/Network/BitTorrent/MainlineDHT.hs | |||
@@ -564,7 +564,7 @@ newClient swarms addr = do | |||
564 | -- We defer initializing the refreshSearch and refreshPing until we | 564 | -- We defer initializing the refreshSearch and refreshPing until we |
565 | -- have a client to send queries with. | 565 | -- have a client to send queries with. |
566 | let nullPing = const $ return False | 566 | let nullPing = const $ return False |
567 | nullSearch = mainlineSearch $ Left $ \_ _ -> return Nothing | 567 | nullSearch = mainlineSearch $ \_ _ -> return Nothing |
568 | tbl4 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info R.defaultBucketCount | 568 | tbl4 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info R.defaultBucketCount |
569 | refresher4 <- newBucketRefresher tbl4 nullSearch nullPing | 569 | refresher4 <- newBucketRefresher tbl4 nullSearch nullPing |
570 | tbl6 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info6 R.defaultBucketCount | 570 | tbl6 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info6 R.defaultBucketCount |
@@ -1042,36 +1042,13 @@ mainlineSend :: ( BEncode a | |||
1042 | -> NodeInfo | 1042 | -> NodeInfo |
1043 | -> IO (Maybe b) | 1043 | -> IO (Maybe b) |
1044 | mainlineSend meth unwrap msg client nid addr = do | 1044 | mainlineSend meth unwrap msg client nid addr = do |
1045 | reply <- sendQuery client (mainlineSerializeer meth unwrap client) (msg nid) addr | 1045 | reply <- sendQuery client serializer (msg nid) addr |
1046 | -- sendQuery will return (Just (Left _)) on a parse error. We're going to | 1046 | -- sendQuery will return (Just (Left _)) on a parse error. We're going to |
1047 | -- blow it away with the join-either sequence. | 1047 | -- blow it away with the join-either sequence. |
1048 | -- TODO: Do something with parse errors. | 1048 | -- TODO: Do something with parse errors. |
1049 | return $ join $ either (const Nothing) Just <$> reply | 1049 | return $ join $ either (const Nothing) Just <$> reply |
1050 | 1050 | where | |
1051 | mainlineAsync :: (BEncode a1, BEncode a2) => | 1051 | serializer = MethodSerializer |
1052 | Method | ||
1053 | -> (a2 -> a3) | ||
1054 | -> (t -> a1) | ||
1055 | -> Client String Method TransactionId NodeInfo (Message BValue) | ||
1056 | -> t | ||
1057 | -> NodeInfo | ||
1058 | -> (Maybe a3 -> IO ()) | ||
1059 | -> IO () | ||
1060 | mainlineAsync meth unwrap msg client nid addr onresult = do | ||
1061 | asyncQuery client (mainlineSerializeer meth unwrap client) (msg nid) addr | ||
1062 | $ \reply -> | ||
1063 | -- sendQuery will return (Just (Left _)) on a parse error. We're going to | ||
1064 | -- blow it away with the join-either sequence. | ||
1065 | -- TODO: Do something with parse errors. | ||
1066 | onresult $ join $ either (const Nothing) Just <$> reply | ||
1067 | |||
1068 | mainlineSerializeer :: (BEncode a2, BEncode a1) => | ||
1069 | Method | ||
1070 | -> (a2 -> b) | ||
1071 | -> MainlineClient | ||
1072 | -> MethodSerializer | ||
1073 | TransactionId NodeInfo (Message BValue) Method a1 (Either Error b) | ||
1074 | mainlineSerializeer meth unwrap client = MethodSerializer | ||
1075 | { methodTimeout = \ni -> return (ni, 5000000) | 1052 | { methodTimeout = \ni -> return (ni, 5000000) |
1076 | , method = meth | 1053 | , method = meth |
1077 | , wrapQuery = encodeQueryPayload meth (isReadonlyClient client) | 1054 | , wrapQuery = encodeQueryPayload meth (isReadonlyClient client) |
@@ -1090,45 +1067,30 @@ ping client addr = | |||
1090 | getNodes :: MainlineClient -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ())) | 1067 | getNodes :: MainlineClient -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ())) |
1091 | getNodes = mainlineSend (Method "find_node") unwrapNodes $ flip FindNode (Just Want_Both) | 1068 | getNodes = mainlineSend (Method "find_node") unwrapNodes $ flip FindNode (Just Want_Both) |
1092 | 1069 | ||
1093 | asyncGetNodes :: Client String Method TransactionId NodeInfo (Message BValue) | ||
1094 | -> NodeId | ||
1095 | -> NodeInfo | ||
1096 | -> (Maybe ([NodeInfo], [NodeInfo], Maybe ()) -> IO ()) | ||
1097 | -> IO () | ||
1098 | asyncGetNodes = mainlineAsync (Method "find_node") unwrapNodes $ flip FindNode (Just Want_Both) | ||
1099 | |||
1100 | unwrapNodes :: NodeFound -> ([NodeInfo], [NodeInfo], Maybe ()) | 1070 | unwrapNodes :: NodeFound -> ([NodeInfo], [NodeInfo], Maybe ()) |
1101 | unwrapNodes (NodeFound ns4 ns6) = (ns4++ns6, ns4++ns6, Just ()) | 1071 | unwrapNodes (NodeFound ns4 ns6) = (ns4++ns6, ns4++ns6, Just ()) |
1102 | 1072 | ||
1103 | getPeers :: MainlineClient -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[PeerAddr],Maybe Token)) | 1073 | getPeers :: MainlineClient -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[PeerAddr],Maybe Token)) |
1104 | getPeers = mainlineSend (Method "get_peers") unwrapPeers $ flip GetPeers (Just Want_Both) . coerce | 1074 | getPeers = mainlineSend (Method "get_peers") unwrapPeers $ flip GetPeers (Just Want_Both) . coerce |
1105 | 1075 | ||
1106 | asyncGetPeers :: Client String Method TransactionId NodeInfo (Message BValue) | ||
1107 | -> NodeId | ||
1108 | -> NodeInfo | ||
1109 | -> (Maybe ([NodeInfo], [PeerAddr], Maybe Token) -> IO ()) | ||
1110 | -> IO () | ||
1111 | asyncGetPeers = mainlineAsync (Method "get_peers") unwrapPeers $ flip GetPeers (Just Want_Both) . coerce | ||
1112 | |||
1113 | unwrapPeers :: GotPeers -> ([NodeInfo], [PeerAddr], Maybe Token) | 1076 | unwrapPeers :: GotPeers -> ([NodeInfo], [PeerAddr], Maybe Token) |
1114 | unwrapPeers (GotPeers ps (NodeFound ns4 ns6) tok) = (ns4++ns6, ps, Just tok) | 1077 | unwrapPeers (GotPeers ps (NodeFound ns4 ns6) tok) = (ns4++ns6, ps, Just tok) |
1115 | 1078 | ||
1116 | mainlineSearch :: Either (NodeId -> NodeInfo -> IO (Maybe ([NodeInfo], [r], Maybe tok))) | 1079 | mainlineSearch :: (NodeId -> NodeInfo -> IO (Maybe ([NodeInfo], [r], Maybe tok))) |
1117 | (NodeId -> NodeInfo -> (Maybe ([NodeInfo], [r], Maybe tok) -> IO ()) -> IO ()) | ||
1118 | -> Search NodeId (IP, PortNumber) tok NodeInfo r | 1080 | -> Search NodeId (IP, PortNumber) tok NodeInfo r |
1119 | mainlineSearch qry = Search | 1081 | mainlineSearch qry = Search |
1120 | { searchSpace = mainlineSpace | 1082 | { searchSpace = mainlineSpace |
1121 | , searchNodeAddress = nodeIP &&& nodePort | 1083 | , searchNodeAddress = nodeIP &&& nodePort |
1122 | , searchQuery = qry | 1084 | , searchQuery = Left qry |
1123 | , searchAlpha = 8 | 1085 | , searchAlpha = 8 |
1124 | , searchK = 16 | 1086 | , searchK = 16 |
1125 | } | 1087 | } |
1126 | 1088 | ||
1127 | nodeSearch :: MainlineClient -> Search NodeId (IP, PortNumber) () NodeInfo NodeInfo | 1089 | nodeSearch :: MainlineClient -> Search NodeId (IP, PortNumber) () NodeInfo NodeInfo |
1128 | nodeSearch client = mainlineSearch (Right $ asyncGetNodes client) | 1090 | nodeSearch client = mainlineSearch (getNodes client) |
1129 | 1091 | ||
1130 | peerSearch :: MainlineClient -> Search NodeId (IP, PortNumber) Token NodeInfo PeerAddr | 1092 | peerSearch :: MainlineClient -> Search NodeId (IP, PortNumber) Token NodeInfo PeerAddr |
1131 | peerSearch client = mainlineSearch (Right $ asyncGetPeers client) | 1093 | peerSearch client = mainlineSearch (getPeers client) |
1132 | 1094 | ||
1133 | -- | List of bootstrap nodes maintained by different bittorrent | 1095 | -- | List of bootstrap nodes maintained by different bittorrent |
1134 | -- software authors. | 1096 | -- software authors. |
diff --git a/dht/src/Network/Tox/DHT/Handlers.hs b/dht/src/Network/Tox/DHT/Handlers.hs index e97cab96..e93f565b 100644 --- a/dht/src/Network/Tox/DHT/Handlers.hs +++ b/dht/src/Network/Tox/DHT/Handlers.hs | |||
@@ -400,61 +400,20 @@ unsendNodes _ = Nothing | |||
400 | unwrapNodes :: SendNodes -> ( [NodeInfo], [NodeInfo], Maybe () ) | 400 | unwrapNodes :: SendNodes -> ( [NodeInfo], [NodeInfo], Maybe () ) |
401 | unwrapNodes (SendNodes ns) = (ns,ns,Just ()) | 401 | unwrapNodes (SendNodes ns) = (ns,ns,Just ()) |
402 | 402 | ||
403 | data SendableQuery x a b = SendableQuery | ||
404 | { sendableSerializer :: MethodSerializer TransactionId NodeInfo Message PacketKind a (Maybe x) | ||
405 | , sendableQuery :: NodeId -> a | ||
406 | , sendableResult :: Maybe (Maybe x) -> IO b | ||
407 | } | ||
408 | |||
409 | sendQ :: SendableQuery x a b | ||
410 | -> QR.Client err PacketKind TransactionId NodeInfo Message | ||
411 | -> NodeId | ||
412 | -> NodeInfo | ||
413 | -> IO b | ||
414 | sendQ s client nid addr = do | ||
415 | reply <- QR.sendQuery client (sendableSerializer s) (sendableQuery s nid) addr | ||
416 | sendableResult s reply | ||
417 | |||
418 | asyncQ :: SendableQuery x a b | ||
419 | -> QR.Client err PacketKind TransactionId NodeInfo Message | ||
420 | -> NodeId | ||
421 | -> NodeInfo | ||
422 | -> (b -> IO ()) | ||
423 | -> IO () | ||
424 | asyncQ s client nid addr go = do | ||
425 | QR.asyncQuery client (sendableSerializer s) (sendableQuery s nid) addr | ||
426 | $ sendableResult s >=> go | ||
427 | |||
428 | getNodesSendable :: TVar (HashMap NodeId [NodeInfoCallback]) | ||
429 | -> NodeInfo | ||
430 | -> SendableQuery SendNodes GetNodes (Maybe ([NodeInfo], [NodeInfo], Maybe ())) | ||
431 | getNodesSendable cbvar addr = SendableQuery (serializer GetNodesType DHTGetNodes unsendNodes) | ||
432 | GetNodes | ||
433 | go | ||
434 | where | ||
435 | go reply = do | ||
436 | forM_ (join reply) $ \(SendNodes ns) -> | ||
437 | forM_ ns $ \n -> do | ||
438 | now <- getPOSIXTime | ||
439 | atomically $ do | ||
440 | mcbs <- HashMap.lookup (nodeId n) <$> readTVar cbvar | ||
441 | forM_ mcbs $ \cbs -> do | ||
442 | forM_ cbs $ \cb -> do | ||
443 | rumoredAddress cb now (nodeAddr addr) n | ||
444 | return $ fmap unwrapNodes $ join reply | ||
445 | |||
446 | getNodes :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ())) | 403 | getNodes :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ())) |
447 | getNodes client cbvar nid addr = | 404 | getNodes client cbvar nid addr = do |
448 | sendQ (getNodesSendable cbvar addr) client nid addr | 405 | -- dput XMisc $ show addr ++ " <-- getnodes " ++ show nid |
449 | 406 | reply <- QR.sendQuery client (serializer GetNodesType DHTGetNodes unsendNodes) (GetNodes nid) addr | |
450 | asyncGetNodes :: QR.Client err PacketKind TransactionId NodeInfo Message | 407 | -- dput XMisc $ show addr ++ " -sendnodes-> " ++ show reply |
451 | -> TVar (HashMap NodeId [NodeInfoCallback]) | 408 | forM_ (join reply) $ \(SendNodes ns) -> |
452 | -> NodeId | 409 | forM_ ns $ \n -> do |
453 | -> NodeInfo | 410 | now <- getPOSIXTime |
454 | -> (Maybe ([NodeInfo], [NodeInfo], Maybe ()) -> IO ()) | 411 | atomically $ do |
455 | -> IO () | 412 | mcbs <- HashMap.lookup (nodeId n) <$> readTVar cbvar |
456 | asyncGetNodes client cbvar nid addr go = | 413 | forM_ mcbs $ \cbs -> do |
457 | asyncQ (getNodesSendable cbvar addr) client nid addr go | 414 | forM_ cbs $ \cb -> do |
415 | rumoredAddress cb now (nodeAddr addr) n | ||
416 | return $ fmap unwrapNodes $ join reply | ||
458 | 417 | ||
459 | updateRouting :: Client -> Routing | 418 | updateRouting :: Client -> Routing |
460 | -> (TVar (R.BucketList NodeInfo) -> RoutingTransition NodeInfo -> STM ()) | 419 | -> (TVar (R.BucketList NodeInfo) -> RoutingTransition NodeInfo -> STM ()) |
@@ -566,7 +525,7 @@ nodeSearch :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> Search NodeI | |||
566 | nodeSearch client cbvar = Search | 525 | nodeSearch client cbvar = Search |
567 | { searchSpace = toxSpace | 526 | { searchSpace = toxSpace |
568 | , searchNodeAddress = nodeIP &&& nodePort | 527 | , searchNodeAddress = nodeIP &&& nodePort |
569 | , searchQuery = Right $ asyncGetNodes client cbvar | 528 | , searchQuery = Left $ getNodes client cbvar |
570 | , searchAlpha = 8 | 529 | , searchAlpha = 8 |
571 | , searchK = 16 | 530 | , searchK = 16 |
572 | 531 | ||
diff --git a/dht/src/Network/Tox/Onion/Handlers.hs b/dht/src/Network/Tox/Onion/Handlers.hs index 3ea7395f..b35631a3 100644 --- a/dht/src/Network/Tox/Onion/Handlers.hs +++ b/dht/src/Network/Tox/Onion/Handlers.hs | |||
@@ -219,7 +219,7 @@ toxidSearch :: (OnionDestination r -> STM (OnionDestination r, Int)) | |||
219 | toxidSearch getTimeout crypto client = Search | 219 | toxidSearch getTimeout crypto client = Search |
220 | { searchSpace = toxSpace | 220 | { searchSpace = toxSpace |
221 | , searchNodeAddress = nodeIP &&& nodePort | 221 | , searchNodeAddress = nodeIP &&& nodePort |
222 | , searchQuery = Right $ asyncGetRendezvous getTimeout crypto client | 222 | , searchQuery = Left $ getRendezvous getTimeout crypto client |
223 | , searchAlpha = 3 | 223 | , searchAlpha = 3 |
224 | , searchK = 6 | 224 | , searchK = 6 |
225 | } | 225 | } |
@@ -291,28 +291,6 @@ sendOnion getTimeout client req oaddr unwrap = | |||
291 | (return . Just . unwrap (onionNodeInfo oaddr)) | 291 | (return . Just . unwrap (onionNodeInfo oaddr)) |
292 | $ join mb | 292 | $ join mb |
293 | 293 | ||
294 | asyncOnion :: (OnionDestination r -> STM (OnionDestination r, Int)) | ||
295 | -> QR.Client | ||
296 | err | ||
297 | PacketKind | ||
298 | TransactionId | ||
299 | (OnionDestination r) | ||
300 | (OnionMessage Identity) | ||
301 | -> AnnounceRequest | ||
302 | -> OnionDestination r | ||
303 | -> (NodeInfo -> AnnounceResponse -> a) | ||
304 | -> (Maybe a -> IO ()) | ||
305 | -> IO () | ||
306 | asyncOnion getTimeout client req oaddr unwrap go = | ||
307 | -- Four tries and then we tap out. | ||
308 | flip fix 4 $ \loop n -> do | ||
309 | QR.asyncQuery client (announceSerializer getTimeout) req oaddr | ||
310 | $ \mb -> do | ||
311 | forM_ mb $ \r -> dput XAnnounce $ show (onionNodeInfo oaddr) ++ " sent response: " ++ show r | ||
312 | maybe (if n>0 then loop $! n - 1 else go Nothing) | ||
313 | (go . Just . unwrap (onionNodeInfo oaddr)) | ||
314 | $ join mb | ||
315 | |||
316 | 294 | ||
317 | -- | Lookup the secret counterpart for a given alias key. | 295 | -- | Lookup the secret counterpart for a given alias key. |
318 | getRendezvous :: (OnionDestination r -> STM (OnionDestination r, Int)) | 296 | getRendezvous :: (OnionDestination r -> STM (OnionDestination r, Int)) |
@@ -332,26 +310,6 @@ getRendezvous getTimeout crypto client nid ni = do | |||
332 | oaddr | 310 | oaddr |
333 | (unwrapAnnounceResponse rkey) | 311 | (unwrapAnnounceResponse rkey) |
334 | 312 | ||
335 | asyncGetRendezvous | ||
336 | :: (OnionDestination r -> STM (OnionDestination r, Int)) | ||
337 | -> TransportCrypto | ||
338 | -> Client r | ||
339 | -> NodeId | ||
340 | -> NodeInfo | ||
341 | -> (Maybe ([NodeInfo], [Rendezvous], Maybe Nonce32) -> IO ()) | ||
342 | -> IO () | ||
343 | asyncGetRendezvous getTimeout crypto client nid ni go = do | ||
344 | asel <- atomically $ selectAlias crypto nid | ||
345 | let oaddr = OnionDestination asel ni Nothing | ||
346 | rkey = case asel of | ||
347 | SearchingAlias -> Nothing | ||
348 | _ -> Just $ key2id $ rendezvousPublic crypto | ||
349 | asyncOnion getTimeout client | ||
350 | (AnnounceRequest zeros32 nid $ fromMaybe zeroID rkey) | ||
351 | oaddr | ||
352 | (unwrapAnnounceResponse rkey) | ||
353 | go | ||
354 | |||
355 | putRendezvous :: (OnionDestination r -> STM (OnionDestination r, Int)) | 313 | putRendezvous :: (OnionDestination r -> STM (OnionDestination r, Int)) |
356 | -> TransportCrypto | 314 | -> TransportCrypto |
357 | -> Client r | 315 | -> Client r |