summaryrefslogtreecommitdiff
path: root/dht/src/Network/BitTorrent/MainlineDHT.hs
diff options
context:
space:
mode:
Diffstat (limited to 'dht/src/Network/BitTorrent/MainlineDHT.hs')
-rw-r--r--dht/src/Network/BitTorrent/MainlineDHT.hs54
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)
1044mainlineSend meth unwrap msg client nid addr = do 1044mainlineSend 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
1051mainlineAsync :: (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 ()
1060mainlineAsync 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
1068mainlineSerializeer :: (BEncode a2, BEncode a1) =>
1069 Method
1070 -> (a2 -> b)
1071 -> MainlineClient
1072 -> MethodSerializer
1073 TransactionId NodeInfo (Message BValue) Method a1 (Either Error b)
1074mainlineSerializeer 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 =
1090getNodes :: MainlineClient -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ())) 1067getNodes :: MainlineClient -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ()))
1091getNodes = mainlineSend (Method "find_node") unwrapNodes $ flip FindNode (Just Want_Both) 1068getNodes = mainlineSend (Method "find_node") unwrapNodes $ flip FindNode (Just Want_Both)
1092 1069
1093asyncGetNodes :: Client String Method TransactionId NodeInfo (Message BValue)
1094 -> NodeId
1095 -> NodeInfo
1096 -> (Maybe ([NodeInfo], [NodeInfo], Maybe ()) -> IO ())
1097 -> IO ()
1098asyncGetNodes = mainlineAsync (Method "find_node") unwrapNodes $ flip FindNode (Just Want_Both)
1099
1100unwrapNodes :: NodeFound -> ([NodeInfo], [NodeInfo], Maybe ()) 1070unwrapNodes :: NodeFound -> ([NodeInfo], [NodeInfo], Maybe ())
1101unwrapNodes (NodeFound ns4 ns6) = (ns4++ns6, ns4++ns6, Just ()) 1071unwrapNodes (NodeFound ns4 ns6) = (ns4++ns6, ns4++ns6, Just ())
1102 1072
1103getPeers :: MainlineClient -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[PeerAddr],Maybe Token)) 1073getPeers :: MainlineClient -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[PeerAddr],Maybe Token))
1104getPeers = mainlineSend (Method "get_peers") unwrapPeers $ flip GetPeers (Just Want_Both) . coerce 1074getPeers = mainlineSend (Method "get_peers") unwrapPeers $ flip GetPeers (Just Want_Both) . coerce
1105 1075
1106asyncGetPeers :: Client String Method TransactionId NodeInfo (Message BValue)
1107 -> NodeId
1108 -> NodeInfo
1109 -> (Maybe ([NodeInfo], [PeerAddr], Maybe Token) -> IO ())
1110 -> IO ()
1111asyncGetPeers = mainlineAsync (Method "get_peers") unwrapPeers $ flip GetPeers (Just Want_Both) . coerce
1112
1113unwrapPeers :: GotPeers -> ([NodeInfo], [PeerAddr], Maybe Token) 1076unwrapPeers :: GotPeers -> ([NodeInfo], [PeerAddr], Maybe Token)
1114unwrapPeers (GotPeers ps (NodeFound ns4 ns6) tok) = (ns4++ns6, ps, Just tok) 1077unwrapPeers (GotPeers ps (NodeFound ns4 ns6) tok) = (ns4++ns6, ps, Just tok)
1115 1078
1116mainlineSearch :: Either (NodeId -> NodeInfo -> IO (Maybe ([NodeInfo], [r], Maybe tok))) 1079mainlineSearch :: (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
1119mainlineSearch qry = Search 1081mainlineSearch 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
1127nodeSearch :: MainlineClient -> Search NodeId (IP, PortNumber) () NodeInfo NodeInfo 1089nodeSearch :: MainlineClient -> Search NodeId (IP, PortNumber) () NodeInfo NodeInfo
1128nodeSearch client = mainlineSearch (Right $ asyncGetNodes client) 1090nodeSearch client = mainlineSearch (getNodes client)
1129 1091
1130peerSearch :: MainlineClient -> Search NodeId (IP, PortNumber) Token NodeInfo PeerAddr 1092peerSearch :: MainlineClient -> Search NodeId (IP, PortNumber) Token NodeInfo PeerAddr
1131peerSearch client = mainlineSearch (Right $ asyncGetPeers client) 1093peerSearch 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.