diff options
Diffstat (limited to 'src')
-rw-r--r-- | src/Network/BitTorrent/MainlineDHT.hs | 52 | ||||
-rw-r--r-- | src/Network/BitTorrent/MainlineDHT/Symbols.hs | 24 |
2 files changed, 45 insertions, 31 deletions
diff --git a/src/Network/BitTorrent/MainlineDHT.hs b/src/Network/BitTorrent/MainlineDHT.hs index c9abf003..f4a5ade1 100644 --- a/src/Network/BitTorrent/MainlineDHT.hs +++ b/src/Network/BitTorrent/MainlineDHT.hs | |||
@@ -52,6 +52,7 @@ import Data.Typeable | |||
52 | import Data.Word | 52 | import Data.Word |
53 | import qualified Data.Wrapper.PSQInt as Int | 53 | import qualified Data.Wrapper.PSQInt as Int |
54 | import Debug.Trace | 54 | import Debug.Trace |
55 | import Network.BitTorrent.MainlineDHT.Symbols | ||
55 | import Network.Kademlia | 56 | import Network.Kademlia |
56 | import Network.Address (Address, fromAddr, fromSockAddr, | 57 | import Network.Address (Address, fromAddr, fromSockAddr, |
57 | setPort, sockAddrPort, testIdBit, | 58 | setPort, sockAddrPort, testIdBit, |
@@ -303,6 +304,7 @@ data Message a = Q { msgOrigin :: NodeId | |||
303 | , rspPayload :: Either Error a | 304 | , rspPayload :: Either Error a |
304 | , rspReflectedIP :: Maybe SockAddr } | 305 | , rspReflectedIP :: Maybe SockAddr } |
305 | 306 | ||
307 | showBE :: BValue -> String | ||
306 | showBE bval = L8.unpack (showBEncode bval) | 308 | showBE bval = L8.unpack (showBEncode bval) |
307 | 309 | ||
308 | instance BE.BEncode (Message BValue) where | 310 | instance BE.BEncode (Message BValue) where |
@@ -409,6 +411,7 @@ encodeAny tid key val aux = toDict $ | |||
409 | .: endDict | 411 | .: endDict |
410 | 412 | ||
411 | 413 | ||
414 | showPacket :: ([L8.ByteString] -> [L8.ByteString]) -> SockAddr -> L8.ByteString -> ByteString -> String | ||
412 | showPacket f addr flow bs = L8.unpack $ L8.unlines es | 415 | showPacket f addr flow bs = L8.unpack $ L8.unlines es |
413 | where | 416 | where |
414 | es = map (L8.append prefix) (f $ L8.lines pp) | 417 | es = map (L8.append prefix) (f $ L8.lines pp) |
@@ -418,6 +421,7 @@ showPacket f addr flow bs = L8.unpack $ L8.unlines es | |||
418 | pp = either L8.pack showBEncode $ BE.decode bs | 421 | pp = either L8.pack showBEncode $ BE.decode bs |
419 | 422 | ||
420 | -- Add detailed printouts for every packet. | 423 | -- Add detailed printouts for every packet. |
424 | addVerbosity :: Transport err SockAddr ByteString -> Transport err SockAddr ByteString | ||
421 | addVerbosity tr = | 425 | addVerbosity tr = |
422 | tr { awaitMessage = \kont -> awaitMessage tr $ \m -> do | 426 | tr { awaitMessage = \kont -> awaitMessage tr $ \m -> do |
423 | forM_ m $ mapM_ $ \(msg,addr) -> do | 427 | forM_ m $ mapM_ $ \(msg,addr) -> do |
@@ -429,7 +433,7 @@ addVerbosity tr = | |||
429 | } | 433 | } |
430 | 434 | ||
431 | 435 | ||
432 | 436 | showParseError :: ByteString -> SockAddr -> String -> String | |
433 | showParseError bs addr err = showPacket (L8.pack err :) addr " --> " bs | 437 | showParseError bs addr err = showPacket (L8.pack err :) addr " --> " bs |
434 | 438 | ||
435 | parsePacket :: ByteString -> SockAddr -> Either String (Message BValue, NodeInfo) | 439 | parsePacket :: ByteString -> SockAddr -> Either String (Message BValue, NodeInfo) |
@@ -918,36 +922,6 @@ mkAnnounce portnum info token = Announce | |||
918 | , impliedPort = False | 922 | , impliedPort = False |
919 | } | 923 | } |
920 | 924 | ||
921 | peer_ip_key = "ip" | ||
922 | peer_id_key = "peer id" | ||
923 | peer_port_key = "port" | ||
924 | msg_type_key = "msg_type" | ||
925 | piece_key = "piece" | ||
926 | total_size_key = "total_size" | ||
927 | node_id_key :: BKey | ||
928 | node_id_key = "id" | ||
929 | read_only_key :: BKey | ||
930 | read_only_key = "ro" | ||
931 | want_key :: BKey | ||
932 | want_key = "want" | ||
933 | target_key :: BKey | ||
934 | target_key = "target" | ||
935 | nodes_key :: BKey | ||
936 | nodes_key = "nodes" | ||
937 | nodes6_key :: BKey | ||
938 | nodes6_key = "nodes6" | ||
939 | info_hash_key :: BKey | ||
940 | info_hash_key = "info_hash" | ||
941 | peers_key :: BKey | ||
942 | peers_key = "values" | ||
943 | token_key :: BKey | ||
944 | token_key = "token" | ||
945 | name_key :: BKey | ||
946 | name_key = "name" | ||
947 | port_key :: BKey | ||
948 | port_key = "port" | ||
949 | implied_port_key :: BKey | ||
950 | implied_port_key = "implied_port" | ||
951 | 925 | ||
952 | instance BEncode Announce where | 926 | instance BEncode Announce where |
953 | toBEncode Announce {..} = toDict $ | 927 | toBEncode Announce {..} = toDict $ |
@@ -1004,8 +978,18 @@ announceH (SwarmsDatabase peers toks _) naddr announcement = do | |||
1004 | } | 978 | } |
1005 | return Announced | 979 | return Announced |
1006 | 980 | ||
981 | isReadonlyClient :: MainlineClient -> Bool | ||
1007 | isReadonlyClient client = False -- TODO | 982 | isReadonlyClient client = False -- TODO |
1008 | 983 | ||
984 | mainlineSend :: ( BEncode a | ||
985 | , BEncode a2 | ||
986 | ) => Method | ||
987 | -> (a2 -> b) | ||
988 | -> (t -> a) | ||
989 | -> MainlineClient | ||
990 | -> t | ||
991 | -> NodeInfo | ||
992 | -> IO (Maybe b) | ||
1009 | mainlineSend meth unwrap msg client nid addr = do | 993 | mainlineSend meth unwrap msg client nid addr = do |
1010 | reply <- sendQuery client serializer (msg nid) addr | 994 | reply <- sendQuery client serializer (msg nid) addr |
1011 | -- sendQuery will return (Just (Left _)) on a parse error. We're going to | 995 | -- sendQuery will return (Just (Left _)) on a parse error. We're going to |
@@ -1032,21 +1016,27 @@ ping client addr = | |||
1032 | getNodes :: MainlineClient -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],())) | 1016 | getNodes :: MainlineClient -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],())) |
1033 | getNodes = mainlineSend (Method "find_node") unwrapNodes $ flip FindNode (Just Want_Both) | 1017 | getNodes = mainlineSend (Method "find_node") unwrapNodes $ flip FindNode (Just Want_Both) |
1034 | 1018 | ||
1019 | unwrapNodes :: NodeFound -> ([NodeInfo], [NodeInfo], ()) | ||
1035 | unwrapNodes (NodeFound ns4 ns6) = (ns4++ns6, ns4++ns6,()) | 1020 | unwrapNodes (NodeFound ns4 ns6) = (ns4++ns6, ns4++ns6,()) |
1036 | 1021 | ||
1037 | getPeers :: MainlineClient -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[PeerAddr],Token)) | 1022 | getPeers :: MainlineClient -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[PeerAddr],Token)) |
1038 | getPeers = mainlineSend (Method "get_peers") unwrapPeers $ flip GetPeers (Just Want_Both) . coerce | 1023 | getPeers = mainlineSend (Method "get_peers") unwrapPeers $ flip GetPeers (Just Want_Both) . coerce |
1039 | 1024 | ||
1025 | unwrapPeers :: GotPeers -> ([NodeInfo], [PeerAddr], Token) | ||
1040 | unwrapPeers (GotPeers ps (NodeFound ns4 ns6) tok) = (ns4++ns6, ps, tok) | 1026 | unwrapPeers (GotPeers ps (NodeFound ns4 ns6) tok) = (ns4++ns6, ps, tok) |
1041 | 1027 | ||
1028 | mainlineSearch :: (NodeId -> NodeInfo -> IO (Maybe ([NodeInfo], [r], tok))) | ||
1029 | -> Search NodeId (IP, PortNumber) tok NodeInfo r | ||
1042 | mainlineSearch qry = Search | 1030 | mainlineSearch qry = Search |
1043 | { searchSpace = mainlineSpace | 1031 | { searchSpace = mainlineSpace |
1044 | , searchNodeAddress = nodeIP &&& nodePort | 1032 | , searchNodeAddress = nodeIP &&& nodePort |
1045 | , searchQuery = qry | 1033 | , searchQuery = qry |
1046 | } | 1034 | } |
1047 | 1035 | ||
1036 | nodeSearch :: MainlineClient -> Search NodeId (IP, PortNumber) () NodeInfo NodeInfo | ||
1048 | nodeSearch client = mainlineSearch (getNodes client) | 1037 | nodeSearch client = mainlineSearch (getNodes client) |
1049 | 1038 | ||
1039 | peerSearch :: MainlineClient -> Search NodeId (IP, PortNumber) Token NodeInfo PeerAddr | ||
1050 | peerSearch client = mainlineSearch (getPeers client) | 1040 | peerSearch client = mainlineSearch (getPeers client) |
1051 | 1041 | ||
1052 | -- | List of bootstrap nodes maintained by different bittorrent | 1042 | -- | List of bootstrap nodes maintained by different bittorrent |
diff --git a/src/Network/BitTorrent/MainlineDHT/Symbols.hs b/src/Network/BitTorrent/MainlineDHT/Symbols.hs new file mode 100644 index 00000000..05a64014 --- /dev/null +++ b/src/Network/BitTorrent/MainlineDHT/Symbols.hs | |||
@@ -0,0 +1,24 @@ | |||
1 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} | ||
2 | module Network.BitTorrent.MainlineDHT.Symbols where | ||
3 | |||
4 | import Data.BEncode.BDict | ||
5 | |||
6 | peer_ip_key = "ip" :: BKey | ||
7 | peer_id_key = "peer id" :: BKey | ||
8 | peer_port_key = "port" :: BKey | ||
9 | msg_type_key = "msg_type" :: BKey | ||
10 | piece_key = "piece" :: BKey | ||
11 | total_size_key = "total_size" :: BKey | ||
12 | node_id_key = "id" :: BKey | ||
13 | read_only_key = "ro" :: BKey | ||
14 | want_key = "want" :: BKey | ||
15 | target_key = "target" :: BKey | ||
16 | nodes_key = "nodes" :: BKey | ||
17 | nodes6_key = "nodes6" :: BKey | ||
18 | info_hash_key = "info_hash" :: BKey | ||
19 | peers_key = "values" :: BKey | ||
20 | token_key = "token" :: BKey | ||
21 | name_key = "name" :: BKey | ||
22 | port_key = "port" :: BKey | ||
23 | implied_port_key = "implied_port" :: BKey | ||
24 | |||