diff options
Diffstat (limited to 'dht/src/Network/BitTorrent/MainlineDHT.hs')
-rw-r--r-- | dht/src/Network/BitTorrent/MainlineDHT.hs | 54 |
1 files changed, 8 insertions, 46 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. |