summaryrefslogtreecommitdiff
path: root/src/Network
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network')
-rw-r--r--src/Network/BitTorrent/Address.hs128
-rw-r--r--src/Network/BitTorrent/DHT.hs7
-rw-r--r--src/Network/BitTorrent/DHT/Message.hs20
-rw-r--r--src/Network/BitTorrent/DHT/Query.hs63
-rw-r--r--src/Network/BitTorrent/DHT/Routing.hs36
-rw-r--r--src/Network/BitTorrent/DHT/Search.hs29
-rw-r--r--src/Network/BitTorrent/DHT/Session.hs2
-rw-r--r--src/Network/DHT/Mainline.hs72
-rw-r--r--src/Network/KRPC/Manager.hs44
-rw-r--r--src/Network/RPC.hs24
10 files changed, 247 insertions, 178 deletions
diff --git a/src/Network/BitTorrent/Address.hs b/src/Network/BitTorrent/Address.hs
index 2132f8f9..560ac1ef 100644
--- a/src/Network/BitTorrent/Address.hs
+++ b/src/Network/BitTorrent/Address.hs
@@ -11,6 +11,7 @@
11-- 11--
12{-# LANGUAGE CPP #-} 12{-# LANGUAGE CPP #-}
13{-# LANGUAGE FlexibleInstances #-} 13{-# LANGUAGE FlexibleInstances #-}
14{-# LANGUAGE FlexibleContexts #-}
14{-# LANGUAGE RecordWildCards #-} 15{-# LANGUAGE RecordWildCards #-}
15{-# LANGUAGE StandaloneDeriving #-} 16{-# LANGUAGE StandaloneDeriving #-}
16{-# LANGUAGE ViewPatterns #-} 17{-# LANGUAGE ViewPatterns #-}
@@ -59,11 +60,8 @@ module Network.BitTorrent.Address
59 -- * Node 60 -- * Node
60 -- ** Id 61 -- ** Id
61 , NodeId 62 , NodeId
62 , asNodeId
63 , nodeIdSize 63 , nodeIdSize
64 , testIdBit 64 , testIdBit
65 , NodeDistance
66 , distance
67 , genNodeId 65 , genNodeId
68 , bucketRange 66 , bucketRange
69 , genBucketSample 67 , genBucketSample
@@ -73,6 +71,8 @@ module Network.BitTorrent.Address
73 -- ** Info 71 -- ** Info
74 , NodeAddr (..) 72 , NodeAddr (..)
75 , NodeInfo (..) 73 , NodeInfo (..)
74 , mapAddress
75 , traverseAddress
76 , rank 76 , rank
77 77
78 -- * Fingerprint 78 -- * Fingerprint
@@ -98,7 +98,6 @@ import Data.BEncode.BDict (BKey)
98import Data.Bits 98import Data.Bits
99import qualified Data.ByteString as BS 99import qualified Data.ByteString as BS
100import qualified Data.ByteString.Internal as BS 100import qualified Data.ByteString.Internal as BS
101import Data.ByteString.Base16 as Base16
102import Data.ByteString.Char8 as BC 101import Data.ByteString.Char8 as BC
103import Data.ByteString.Char8 as BS8 102import Data.ByteString.Char8 as BS8
104import qualified Data.ByteString.Lazy as BL 103import qualified Data.ByteString.Lazy as BL
@@ -130,6 +129,9 @@ import System.Locale (defaultTimeLocale)
130#endif 129#endif
131import System.Entropy 130import System.Entropy
132import Data.Digest.CRC32C 131import Data.Digest.CRC32C
132import qualified Network.RPC as RPC
133import Network.KRPC.Message (KMessageOf)
134import Network.DHT.Mainline
133 135
134-- import Paths_bittorrent (version) 136-- import Paths_bittorrent (version)
135 137
@@ -646,48 +648,10 @@ peerSocket socketType pa = do
646-- in the DHT to get the location of peers to download from using 648-- in the DHT to get the location of peers to download from using
647-- the BitTorrent protocol. 649-- the BitTorrent protocol.
648 650
649-- TODO more compact representation ('ShortByteString's?) 651-- asNodeId :: ByteString -> NodeId
652-- asNodeId bs = NodeId $ BS.take nodeIdSize bs
650 653
651-- | Each node has a globally unique identifier known as the \"node 654{-
652-- ID.\"
653--
654-- Normally, /this/ node id should be saved between invocations
655-- of the client software.
656newtype NodeId = NodeId ByteString
657 deriving (Show, Eq, Ord, Typeable
658#ifdef VERSION_bencoding
659 , BEncode
660#endif
661 )
662
663
664nodeIdSize :: Int
665nodeIdSize = 20
666
667asNodeId :: ByteString -> NodeId
668asNodeId bs = NodeId $ BS.take nodeIdSize bs
669
670-- | Meaningless node id, for testing purposes only.
671instance Default NodeId where
672 def = NodeId (BS.replicate nodeIdSize 0)
673
674instance Serialize NodeId where
675 get = NodeId <$> getByteString nodeIdSize
676 {-# INLINE get #-}
677 put (NodeId bs) = putByteString bs
678 {-# INLINE put #-}
679
680-- | ASCII encoded.
681instance IsString NodeId where
682 fromString str
683 | L.length str == nodeIdSize = NodeId (fromString str)
684 | L.length str == 2 * nodeIdSize = NodeId (fst $ Base16.decode $ fromString str)
685 | otherwise = error "fromString: invalid NodeId length"
686 {-# INLINE fromString #-}
687
688-- | base16 encoded.
689instance Pretty NodeId where
690 pPrint (NodeId nid) = PP.text $ BC.unpack $ Base16.encode nid
691 655
692-- | Test if the nth bit is set. 656-- | Test if the nth bit is set.
693testIdBit :: NodeId -> Word -> Bool 657testIdBit :: NodeId -> Word -> Bool
@@ -696,6 +660,10 @@ testIdBit (NodeId bs) i
696 , (q, r) <- quotRem (fromIntegral i) 8 660 , (q, r) <- quotRem (fromIntegral i) 8
697 = testBit (BS.index bs q) (7 - r) 661 = testBit (BS.index bs q) (7 - r)
698 | otherwise = False 662 | otherwise = False
663-}
664
665testIdBit :: FiniteBits bs => bs -> Word -> Bool
666testIdBit bs i = testBit bs (fromIntegral (finiteBitSize bs - fromIntegral i))
699{-# INLINE testIdBit #-} 667{-# INLINE testIdBit #-}
700 668
701-- TODO WARN is the 'system' random suitable for this? 669-- TODO WARN is the 'system' random suitable for this?
@@ -703,25 +671,10 @@ testIdBit (NodeId bs) i
703-- Distribution of ID's should be as uniform as possible. 671-- Distribution of ID's should be as uniform as possible.
704-- 672--
705genNodeId :: IO NodeId 673genNodeId :: IO NodeId
706genNodeId = NodeId <$> getEntropy nodeIdSize 674genNodeId = NodeId . either error id . S.decode <$> getEntropy nodeIdSize
707 675
708------------------------------------------------------------------------ 676------------------------------------------------------------------------
709 677
710-- | In Kademlia, the distance metric is XOR and the result is
711-- interpreted as an unsigned integer.
712newtype NodeDistance = NodeDistance BS.ByteString
713 deriving (Eq, Ord)
714
715instance Pretty NodeDistance where
716 pPrint (NodeDistance bs) = text $ BC.unpack (Base16.encode bs)
717
718instance Show NodeDistance where
719 show (NodeDistance bs) = BC.unpack (Base16.encode bs)
720
721-- | distance(A,B) = |A xor B| Smaller values are closer.
722distance :: NodeId -> NodeId -> NodeDistance
723distance (NodeId a) (NodeId b) = NodeDistance (BS.pack (BS.zipWith xor a b))
724
725-- | Accepts a depth/index of a bucket and whether or not it is the last one, 678-- | Accepts a depth/index of a bucket and whether or not it is the last one,
726-- yields: 679-- yields:
727-- 680--
@@ -753,13 +706,13 @@ genBucketSample n qmb = genBucketSample' getEntropy n qmb
753genBucketSample' :: Applicative m => 706genBucketSample' :: Applicative m =>
754 (Int -> m ByteString) -> NodeId -> (Int,Word8,Word8) -> m NodeId 707 (Int -> m ByteString) -> NodeId -> (Int,Word8,Word8) -> m NodeId
755genBucketSample' gen (NodeId self) (q,m,b) 708genBucketSample' gen (NodeId self) (q,m,b)
756 | q <= 0 = NodeId <$> gen nodeIdSize 709 | q <= 0 = NodeId . either error id . S.decode <$> gen nodeIdSize
757 | q >= nodeIdSize = pure (NodeId self) 710 | q >= nodeIdSize = pure (NodeId self)
758 | otherwise = NodeId . build <$> gen (nodeIdSize - q + 1) 711 | otherwise = NodeId . either error id . S.decode . build <$> gen (nodeIdSize - q + 1)
759 where 712 where
760 build tl = BS.init hd <> BS.cons (h .|. t) (BS.tail tl) 713 build tl = BS.init hd <> BS.cons (h .|. t) (BS.tail tl)
761 where 714 where
762 hd = BS.take q self 715 hd = BS.take q $ S.encode self
763 h = xor b (complement m .&. BS.last hd) 716 h = xor b (complement m .&. BS.last hd)
764 t = m .&. BS.head tl 717 t = m .&. BS.head tl
765 718
@@ -819,32 +772,46 @@ fromPeerAddr PeerAddr {..} = NodeAddr
819 772
820------------------------------------------------------------------------ 773------------------------------------------------------------------------
821 774
822data NodeInfo a = NodeInfo 775data NodeInfo dht addr u = NodeInfo
823 { nodeId :: !NodeId 776 { nodeId :: !(RPC.NodeId dht)
824 , nodeAddr :: !(NodeAddr a) 777 , nodeAddr :: !(NodeAddr addr)
825 } deriving (Show, Eq, Functor, Foldable, Traversable) 778 , nodeAnnotation :: u
779 } deriving (Functor, Foldable, Traversable)
780
781deriving instance ( Show (RPC.NodeId dht)
782 , Show addr
783 , Show u ) => Show (NodeInfo dht addr u)
826 784
785mapAddress :: (addr -> b) -> NodeInfo dht addr u -> NodeInfo dht b u
786mapAddress f ni = ni { nodeAddr = fmap f (nodeAddr ni) }
827 787
828instance Eq a => Ord (NodeInfo a) where 788traverseAddress :: Applicative f => (addr -> f b) -> NodeInfo dht addr u -> f (NodeInfo dht b u)
789traverseAddress f ni = fmap (\addr -> ni { nodeAddr = addr }) $ traverse f (nodeAddr ni)
790
791-- Warning: Eq and Ord only look at the nodeId field.
792instance Eq (RPC.NodeId dht) => Eq (NodeInfo dht a u) where
793 a == b = (nodeId a == nodeId b)
794
795instance Ord (RPC.NodeId dht) => Ord (NodeInfo dht a u) where
829 compare = comparing nodeId 796 compare = comparing nodeId
830 797
831-- | KRPC 'compact list' compatible encoding: contact information for 798-- | KRPC 'compact list' compatible encoding: contact information for
832-- nodes is encoded as a 26-byte string. Also known as "Compact node 799-- nodes is encoded as a 26-byte string. Also known as "Compact node
833-- info" the 20-byte Node ID in network byte order has the compact 800-- info" the 20-byte Node ID in network byte order has the compact
834-- IP-address/port info concatenated to the end. 801-- IP-address/port info concatenated to the end.
835instance Serialize a => Serialize (NodeInfo a) where 802instance Serialize a => Serialize (NodeInfo KMessageOf a ()) where
836 get = NodeInfo <$> get <*> get 803 get = (\a b -> NodeInfo a b ()) <$> get <*> get
837 put NodeInfo {..} = put nodeId >> put nodeAddr 804 put NodeInfo {..} = put nodeId >> put nodeAddr
838 805
839instance Pretty ip => Pretty (NodeInfo ip) where 806instance Pretty ip => Pretty (NodeInfo KMessageOf ip ()) where
840 pPrint NodeInfo {..} = pPrint nodeId <> "@(" <> pPrint nodeAddr <> ")" 807 pPrint NodeInfo {..} = pPrint nodeId <> "@(" <> pPrint nodeAddr <> ")"
841 808
842instance Pretty ip => Pretty [NodeInfo ip] where 809instance Pretty ip => Pretty [NodeInfo KMessageOf ip ()] where
843 pPrint = PP.vcat . PP.punctuate "," . L.map pPrint 810 pPrint = PP.vcat . PP.punctuate "," . L.map pPrint
844 811
845-- | Order by closeness: nearest nodes first. 812-- | Order by closeness: nearest nodes first.
846rank :: (x -> NodeId) -> NodeId -> [x] -> [x] 813rank :: (x -> NodeId) -> NodeId -> [x] -> [x]
847rank f nid = L.sortBy (comparing (distance nid . f)) 814rank f nid = L.sortBy (comparing (RPC.distance nid . f))
848 815
849{----------------------------------------------------------------------- 816{-----------------------------------------------------------------------
850-- Fingerprint 817-- Fingerprint
@@ -1259,8 +1226,11 @@ bep42s addr (NodeId r) = mapMaybe (bep42 addr) rs
1259 where 1226 where
1260 rs = L.map (NodeId . change3bits r) [0..7] 1227 rs = L.map (NodeId . change3bits r) [0..7]
1261 1228
1262change3bits :: ByteString -> Word8 -> ByteString 1229-- change3bits :: ByteString -> Word8 -> ByteString
1263change3bits bs n = BS.snoc (BS.init bs) (BS.last bs .&. 0xF8 .|. n) 1230-- change3bits bs n = BS.snoc (BS.init bs) (BS.last bs .&. 0xF8 .|. n)
1231
1232change3bits :: (Num b, Bits b) => b -> b -> b
1233change3bits bs n = (bs .&. complement 7) .|. n
1264 1234
1265-- | Modifies a purely random 'NodeId' to one that is related to a given 1235-- | Modifies a purely random 'NodeId' to one that is related to a given
1266-- routable address in accordance with BEP 42. 1236-- routable address in accordance with BEP 42.
@@ -1274,9 +1244,9 @@ bep42 addr (NodeId r)
1274 where 1244 where
1275 ip4mask = "\x03\x0f\x3f\xff" :: ByteString 1245 ip4mask = "\x03\x0f\x3f\xff" :: ByteString
1276 ip6mask = "\x01\x03\x07\x0f\x1f\x3f\x7f\xff" :: ByteString 1246 ip6mask = "\x01\x03\x07\x0f\x1f\x3f\x7f\xff" :: ByteString
1277 nbhood_select = BS.last r .&. 7 1247 nbhood_select = (fromIntegral r :: Word8) .&. 7
1278 retr n = pure $ BS.drop (BS.length r - n) r 1248 retr n = pure $ BS.drop (nodeIdSize - n) $ S.encode r
1279 crc = S.encode . crc32c . BS.pack 1249 crc = flip shiftL (finiteBitSize (NodeId undefined) - 32) . fromIntegral . crc32c . BS.pack
1280 applyMask ip = case BS.zipWith (.&.) msk ip of 1250 applyMask ip = case BS.zipWith (.&.) msk ip of
1281 (b:bs) -> (b .|. shiftL nbhood_select 5) : bs 1251 (b:bs) -> (b .|. shiftL nbhood_select 5) : bs
1282 bs -> bs 1252 bs -> bs
diff --git a/src/Network/BitTorrent/DHT.hs b/src/Network/BitTorrent/DHT.hs
index aaa1cf33..ab948a2d 100644
--- a/src/Network/BitTorrent/DHT.hs
+++ b/src/Network/BitTorrent/DHT.hs
@@ -17,6 +17,7 @@
17{-# LANGUAGE FlexibleInstances #-} 17{-# LANGUAGE FlexibleInstances #-}
18{-# LANGUAGE TemplateHaskell #-} 18{-# LANGUAGE TemplateHaskell #-}
19{-# LANGUAGE TypeOperators #-} 19{-# LANGUAGE TypeOperators #-}
20{-# LANGUAGE ScopedTypeVariables #-}
20module Network.BitTorrent.DHT 21module Network.BitTorrent.DHT
21 ( -- * Distributed Hash Table 22 ( -- * Distributed Hash Table
22 DHT 23 DHT
@@ -70,6 +71,7 @@ import Network.BitTorrent.DHT.Session
70import Network.BitTorrent.DHT.Routing as T hiding (null) 71import Network.BitTorrent.DHT.Routing as T hiding (null)
71import qualified Data.Text as Text 72import qualified Data.Text as Text
72import Data.Monoid 73import Data.Monoid
74import Network.KRPC.Message (KMessageOf)
73 75
74 76
75{----------------------------------------------------------------------- 77{-----------------------------------------------------------------------
@@ -166,7 +168,7 @@ resolveHostName NodeAddr {..} = do
166-- 168--
167-- This operation do block, use 169-- This operation do block, use
168-- 'Control.Concurrent.Async.Lifted.async' if needed. 170-- 'Control.Concurrent.Async.Lifted.async' if needed.
169bootstrap :: Address ip => Maybe BS.ByteString -> [NodeAddr ip] -> DHT ip () 171bootstrap :: forall ip. Address ip => Maybe BS.ByteString -> [NodeAddr ip] -> DHT ip ()
170bootstrap mbs startNodes = do 172bootstrap mbs startNodes = do
171 restored <- 173 restored <-
172 case decode <$> mbs of 174 case decode <$> mbs of
@@ -178,7 +180,8 @@ bootstrap mbs startNodes = do
178 $(logInfoS) "bootstrap" "Start node bootstrapping" 180 $(logInfoS) "bootstrap" "Start node bootstrapping"
179 let searchAll aliveNodes = do 181 let searchAll aliveNodes = do
180 nid <- myNodeIdAccordingTo (error "FIXME") 182 nid <- myNodeIdAccordingTo (error "FIXME")
181 C.sourceList [aliveNodes] $= search nid (findNodeQ nid) $$ C.consume 183 nss <- C.sourceList [aliveNodes] $= search nid (findNodeQ nid) $$ C.consume
184 return ( nss :: [[NodeInfo KMessageOf ip ()]] )
182 input_nodes <- (restored ++) . T.toList <$> getTable 185 input_nodes <- (restored ++) . T.toList <$> getTable
183 -- Step 1: Use iterative searches to flesh out the table.. 186 -- Step 1: Use iterative searches to flesh out the table..
184 do let knowns = map (map $ nodeAddr . fst) input_nodes 187 do let knowns = map (map $ nodeAddr . fst) input_nodes
diff --git a/src/Network/BitTorrent/DHT/Message.hs b/src/Network/BitTorrent/DHT/Message.hs
index 0e2bfdd9..c3df683a 100644
--- a/src/Network/BitTorrent/DHT/Message.hs
+++ b/src/Network/BitTorrent/DHT/Message.hs
@@ -93,15 +93,14 @@ import Data.Bool
93#ifdef VERSION_bencoding 93#ifdef VERSION_bencoding
94import Data.BEncode as BE 94import Data.BEncode as BE
95import Data.BEncode.BDict as BDict 95import Data.BEncode.BDict as BDict
96import Network.BitTorrent.Address
97#else 96#else
98import qualified Data.Tox as Tox 97import qualified Data.Tox as Tox
99import Data.Tox (NodeId) 98import Data.Tox (NodeId)
100import Data.Word 99import Data.Word
101import Control.Monad 100import Control.Monad
102import Network.KRPC.Method 101import Network.KRPC.Method
103import Network.BitTorrent.Address hiding (NodeId)
104#endif 102#endif
103import Network.BitTorrent.Address hiding (NodeId)
105import Data.ByteString (ByteString) 104import Data.ByteString (ByteString)
106import Data.List as L 105import Data.List as L
107import Data.Monoid 106import Data.Monoid
@@ -109,11 +108,14 @@ import Data.Serialize as S
109import Data.Typeable 108import Data.Typeable
110import Network 109import Network
111import Network.KRPC 110import Network.KRPC
111import Network.KRPC.Message (KMessageOf)
112import Data.Maybe 112import Data.Maybe
113 113
114import Data.Torrent (InfoHash) 114import Data.Torrent (InfoHash)
115import Network.BitTorrent.DHT.Token 115import Network.BitTorrent.DHT.Token
116import Network.KRPC () 116import Network.KRPC ()
117import Network.DHT.Mainline ()
118import Network.RPC hiding (Query,Response)
117 119
118{----------------------------------------------------------------------- 120{-----------------------------------------------------------------------
119-- envelopes 121-- envelopes
@@ -134,7 +136,7 @@ read_only_key = "ro"
134-- | All queries have an \"id\" key and value containing the node ID 136-- | All queries have an \"id\" key and value containing the node ID
135-- of the querying node. 137-- of the querying node.
136data Query a = Query 138data Query a = Query
137 { queringNodeId :: NodeId -- ^ node id of /quering/ node; 139 { queringNodeId :: NodeId KMessageOf -- ^ node id of /quering/ node;
138 , queryIsReadOnly :: Bool -- ^ node is read-only as per BEP 43 140 , queryIsReadOnly :: Bool -- ^ node is read-only as per BEP 43
139 , queryParams :: a -- ^ query parameters. 141 , queryParams :: a -- ^ query parameters.
140 } deriving (Show, Eq, Typeable) 142 } deriving (Show, Eq, Typeable)
@@ -161,7 +163,7 @@ data Query a = Query a
161-- | All responses have an \"id\" key and value containing the node ID 163-- | All responses have an \"id\" key and value containing the node ID
162-- of the responding node. 164-- of the responding node.
163data Response a = Response 165data Response a = Response
164 { queredNodeId :: NodeId -- ^ node id of /quered/ node; 166 { queredNodeId :: NodeId KMessageOf -- ^ node id of /quered/ node;
165 , responseVals :: a -- ^ query result. 167 , responseVals :: a -- ^ query result.
166 } deriving (Show, Eq, Typeable) 168 } deriving (Show, Eq, Typeable)
167 169
@@ -233,7 +235,7 @@ instance KRPC (Query Ping) (Response Ping) where
233-- | Find node is used to find the contact information for a node 235-- | Find node is used to find the contact information for a node
234-- given its ID. 236-- given its ID.
235#ifdef VERSION_bencoding 237#ifdef VERSION_bencoding
236newtype FindNode ip = FindNode NodeId 238newtype FindNode ip = FindNode (NodeId KMessageOf)
237#else 239#else
238data FindNode ip = FindNode NodeId Tox.Nonce8 -- Tox: Get Nodes 240data FindNode ip = FindNode NodeId Tox.Nonce8 -- Tox: Get Nodes
239#endif 241#endif
@@ -262,7 +264,7 @@ instance Serialize (Query (FindNode ip)) where
262-- nodes in its own routing table. 264-- nodes in its own routing table.
263-- 265--
264#ifdef VERSION_bencoding 266#ifdef VERSION_bencoding
265newtype NodeFound ip = NodeFound [NodeInfo ip] 267newtype NodeFound ip = NodeFound [NodeInfo KMessageOf ip ()]
266#else 268#else
267data NodeFound ip = NodeFound [Tox.NodeFormat] Tox.Nonce8 269data NodeFound ip = NodeFound [Tox.NodeFormat] Tox.Nonce8
268#endif 270#endif
@@ -273,9 +275,9 @@ nodes_key :: BKey
273nodes_key = "nodes" 275nodes_key = "nodes"
274 276
275-- Convert IPv4 address. Useful for using variadic IP type. 277-- Convert IPv4 address. Useful for using variadic IP type.
276from4 :: forall s. Address s => NodeInfo IPv4 -> Either String (NodeInfo s) 278from4 :: forall dht u s. Address s => NodeInfo dht IPv4 u -> Either String (NodeInfo dht s u)
277from4 n = maybe (Left "Error converting IPv4") Right 279from4 n = maybe (Left "Error converting IPv4") Right
278 $ traverse (fromAddr :: IPv4 -> Maybe s) n 280 $ traverseAddress (fromAddr :: IPv4 -> Maybe s) n
279 281
280#ifdef VERSION_bencoding 282#ifdef VERSION_bencoding
281binary :: Serialize a => BKey -> BE.Get [a] 283binary :: Serialize a => BKey -> BE.Get [a]
@@ -334,7 +336,7 @@ instance Typeable ip => BEncode (GetPeers ip) where
334 toBEncode (GetPeers ih) = toDict $ info_hash_key .=! ih .: endDict 336 toBEncode (GetPeers ih) = toDict $ info_hash_key .=! ih .: endDict
335 fromBEncode = fromDict $ GetPeers <$>! info_hash_key 337 fromBEncode = fromDict $ GetPeers <$>! info_hash_key
336 338
337type PeerList ip = Either [NodeInfo ip] [PeerAddr ip] 339type PeerList ip = Either [NodeInfo KMessageOf ip ()] [PeerAddr ip]
338 340
339data GotPeers ip = GotPeers 341data GotPeers ip = GotPeers
340 { -- | If the queried node has no peers for the infohash, returned 342 { -- | If the queried node has no peers for the infohash, returned
diff --git a/src/Network/BitTorrent/DHT/Query.hs b/src/Network/BitTorrent/DHT/Query.hs
index 820db8ba..4b386cdc 100644
--- a/src/Network/BitTorrent/DHT/Query.hs
+++ b/src/Network/BitTorrent/DHT/Query.hs
@@ -80,7 +80,7 @@ import Text.PrettyPrint.HughesPJClass hiding ((<>),($$))
80import Data.Time 80import Data.Time
81import Data.Time.Clock.POSIX 81import Data.Time.Clock.POSIX
82 82
83import Network.KRPC hiding (Options, def) 83import Network.KRPC as KRPC hiding (Options, def)
84import Network.KRPC.Message (ReflectedIP(..)) 84import Network.KRPC.Message (ReflectedIP(..))
85import Network.KRPC.Manager (QueryFailure(..)) 85import Network.KRPC.Manager (QueryFailure(..))
86import Data.Torrent 86import Data.Torrent
@@ -90,14 +90,15 @@ import Network.BitTorrent.DHT.Session
90import Control.Concurrent.STM 90import Control.Concurrent.STM
91import qualified Network.BitTorrent.DHT.Search as Search 91import qualified Network.BitTorrent.DHT.Search as Search
92#ifdef VERSION_bencoding 92#ifdef VERSION_bencoding
93import Network.BitTorrent.Address
94import Data.BEncode (BValue) 93import Data.BEncode (BValue)
95import Network.DHT.Mainline 94import Network.DHT.Mainline hiding (NodeId)
95import Network.KRPC.Message (KMessageOf)
96#else 96#else
97import Network.BitTorrent.Address hiding (NodeId)
98import Data.ByteString (ByteString) 97import Data.ByteString (ByteString)
99import Data.Tox 98import Data.Tox
100#endif 99#endif
100import Network.BitTorrent.Address hiding (NodeId)
101import Network.RPC as RPC hiding (Query,Response)
101 102
102{----------------------------------------------------------------------- 103{-----------------------------------------------------------------------
103-- Handlers 104-- Handlers
@@ -106,18 +107,17 @@ import Data.Tox
106nodeHandler :: ( Address ip 107nodeHandler :: ( Address ip
107 , KRPC (Query a) (Response b) 108 , KRPC (Query a) (Response b)
108#ifdef VERSION_bencoding 109#ifdef VERSION_bencoding
109 , Envelope (Query a) (Response b) ~ BValue ) 110 , KRPC.Envelope (Query a) (Response b) ~ BValue )
110#else 111#else
111 , Envelope (Query a) (Response b) ~ ByteString ) 112 , KPRC.Envelope (Query a) (Response b) ~ ByteString )
112#endif 113#endif
113 => (NodeAddr ip -> a -> DHT ip b) -> NodeHandler ip 114 => (NodeAddr ip -> a -> DHT ip b) -> NodeHandler ip
114#ifdef VERSION_bencoding
115nodeHandler action = handler $ \ sockAddr qry -> do 115nodeHandler action = handler $ \ sockAddr qry -> do
116#ifdef VERSION_bencoding
116 let remoteId = queringNodeId qry 117 let remoteId = queringNodeId qry
117 read_only = queryIsReadOnly qry 118 read_only = queryIsReadOnly qry
118 q = queryParams qry 119 q = queryParams qry
119#else 120#else
120nodeHandler action = handler (error "TODO TOX Messaging") $ \ sockAddr qry -> do
121 let remoteId = msgClient qry 121 let remoteId = msgClient qry
122 read_only = False 122 read_only = False
123 q = msgPayload qry 123 q = msgPayload qry
@@ -125,7 +125,7 @@ nodeHandler action = handler (error "TODO TOX Messaging") $ \ sockAddr qry -> do
125 case fromSockAddr sockAddr of 125 case fromSockAddr sockAddr of
126 Nothing -> throwIO BadAddress 126 Nothing -> throwIO BadAddress
127 Just naddr -> do 127 Just naddr -> do
128 let ni = NodeInfo remoteId naddr 128 let ni = NodeInfo remoteId naddr ()
129 -- Do not route read-only nodes. (bep 43) 129 -- Do not route read-only nodes. (bep 43)
130 if read_only 130 if read_only
131 then $(logWarnS) "nodeHandler" $ "READ-ONLY " <> T.pack (show $ pPrint ni) 131 then $(logWarnS) "nodeHandler" $ "READ-ONLY " <> T.pack (show $ pPrint ni)
@@ -136,8 +136,11 @@ nodeHandler action = handler (error "TODO TOX Messaging") $ \ sockAddr qry -> do
136 136
137-- | Default 'Ping' handler. 137-- | Default 'Ping' handler.
138pingH :: Address ip => NodeHandler ip 138pingH :: Address ip => NodeHandler ip
139pingH = nodeHandler $ \ _ Ping -> do 139#ifdef VERSION_bencoding
140 return Ping 140pingH = nodeHandler $ \ _ Ping -> return Ping
141#else
142pingH = nodeHandler $ \ _ p@PingPayload{} -> return p { isPong = True }
143#endif
141 144
142-- | Default 'FindNode' handler. 145-- | Default 'FindNode' handler.
143findNodeH :: Address ip => NodeHandler ip 146findNodeH :: Address ip => NodeHandler ip
@@ -177,19 +180,23 @@ defaultHandlers = [pingH, findNodeH]
177-- Basic queries 180-- Basic queries
178-----------------------------------------------------------------------} 181-----------------------------------------------------------------------}
179 182
180type Iteration ip o = NodeInfo ip -> DHT ip (Either [NodeInfo ip] [o ip]) 183type Iteration ip o = NodeInfo KMessageOf ip () -> DHT ip (Either [NodeInfo KMessageOf ip ()] [o ip])
181 184
182-- | The most basic query. May be used to check if the given node is 185-- | The most basic query. May be used to check if the given node is
183-- alive or get its 'NodeId'. 186-- alive or get its 'NodeId'.
184pingQ :: Address ip => NodeAddr ip -> DHT ip (NodeInfo ip, Maybe ReflectedIP) 187pingQ :: Address ip => NodeAddr ip -> DHT ip (NodeInfo KMessageOf ip (), Maybe ReflectedIP)
185pingQ addr = do 188pingQ addr = do
189#ifdef VERSION_bencoding
186 (nid, Ping, mip) <- queryNode' addr Ping 190 (nid, Ping, mip) <- queryNode' addr Ping
187 return (NodeInfo nid addr, mip) 191#else
192 (nid, PingPayload{}, mip) <- queryNode' addr PingPayload {isPong=False, pingId=pid}
193#endif
194 return (NodeInfo nid addr (), mip)
188 195
189-- TODO [robustness] match range of returned node ids with the 196-- TODO [robustness] match range of returned node ids with the
190-- expected range and either filter bad nodes or discard response at 197-- expected range and either filter bad nodes or discard response at
191-- all throwing an exception 198-- all throwing an exception
192findNodeQ :: Address ip => TableKey key => key -> Iteration ip NodeInfo 199-- findNodeQ :: Address ip => TableKey key => key -> IterationI ip NodeInfo
193findNodeQ key NodeInfo {..} = do 200findNodeQ key NodeInfo {..} = do
194 NodeFound closest <- FindNode (toNodeId key) <@> nodeAddr 201 NodeFound closest <- FindNode (toNodeId key) <@> nodeAddr
195 $(logInfoS) "findNodeQ" $ "NodeFound\n" 202 $(logInfoS) "findNodeQ" $ "NodeFound\n"
@@ -223,7 +230,7 @@ announceQ ih p NodeInfo {..} = do
223-----------------------------------------------------------------------} 230-----------------------------------------------------------------------}
224 231
225 232
226ioGetPeers :: Address ip => InfoHash -> DHT ip (NodeInfo ip -> IO ([NodeInfo ip], [PeerAddr ip])) 233ioGetPeers :: Address ip => InfoHash -> DHT ip (NodeInfo KMessageOf ip () -> IO ([NodeInfo KMessageOf ip ()], [PeerAddr ip]))
227ioGetPeers ih = do 234ioGetPeers ih = do
228 session <- ask 235 session <- ask
229 return $ \ni -> runDHT session $ do 236 return $ \ni -> runDHT session $ do
@@ -232,7 +239,7 @@ ioGetPeers ih = do
232 Right e -> return $ either (,[]) ([],) e 239 Right e -> return $ either (,[]) ([],) e
233 Left e -> let _ = e :: QueryFailure in return ([],[]) 240 Left e -> let _ = e :: QueryFailure in return ([],[])
234 241
235ioFindNode :: Address ip => InfoHash -> DHT ip (NodeInfo ip -> IO ([NodeInfo ip], [NodeInfo ip])) 242ioFindNode :: Address ip => InfoHash -> DHT ip (NodeInfo KMessageOf ip () -> IO ([NodeInfo KMessageOf ip ()], [NodeInfo KMessageOf ip ()]))
236ioFindNode ih = do 243ioFindNode ih = do
237 session <- ask 244 session <- ask
238 return $ \ni -> runDHT session $ do 245 return $ \ni -> runDHT session $ do
@@ -240,7 +247,7 @@ ioFindNode ih = do
240 return $ L.partition (\n -> nodeId n /= toNodeId ih) ns 247 return $ L.partition (\n -> nodeId n /= toNodeId ih) ns
241 248
242isearch :: (Ord r, Ord ip) => 249isearch :: (Ord r, Ord ip) =>
243 (InfoHash -> DHT ip (NodeInfo ip -> IO ([NodeInfo ip], [r]))) 250 (InfoHash -> DHT ip (NodeInfo KMessageOf ip () -> IO ([NodeInfo KMessageOf ip ()], [r])))
244 -> InfoHash 251 -> InfoHash
245 -> DHT ip (ThreadId, Search.IterativeSearch ip r) 252 -> DHT ip (ThreadId, Search.IterativeSearch ip r)
246isearch f ih = do 253isearch f ih = do
@@ -255,10 +262,10 @@ isearch f ih = do
255 return (a, s) 262 return (a, s)
256 263
257 264
258type Search ip o = Conduit [NodeInfo ip] (DHT ip) [o ip] 265type Search ip o = Conduit [NodeInfo KMessageOf ip ()] (DHT ip) [o KMessageOf ip ()]
259 266
260-- TODO: use reorder and filter (Traversal option) leftovers 267-- TODO: use reorder and filter (Traversal option) leftovers
261search :: k -> Iteration ip o -> Search ip o 268-- search :: k -> IterationI ip o -> Search ip o
262search _ action = do 269search _ action = do
263 awaitForever $ \ batch -> unless (L.null batch) $ do 270 awaitForever $ \ batch -> unless (L.null batch) $ do
264 $(logWarnS) "search" "start query" 271 $(logWarnS) "search" "start query"
@@ -285,15 +292,15 @@ probeNode addr = do
285 292
286 293
287-- FIXME do not use getClosest sinse we should /refresh/ them 294-- FIXME do not use getClosest sinse we should /refresh/ them
288refreshNodes :: Address ip => NodeId -> DHT ip () -- [NodeInfo ip] 295refreshNodes :: Address ip => NodeId KMessageOf -> DHT ip () -- [NodeInfo KMessageOf ip ()]
289refreshNodes nid = do 296refreshNodes nid = do
290 $(logDebugS) "routing.refresh_bucket" (T.pack (render (pPrint nid))) 297 $(logDebugS) "routing.refresh_bucket" (T.pack (render (pPrint nid)))
291 nodes <- getClosest nid 298 nodes <- getClosest nid
292 do 299 do
293 -- forM (L.take 1 nodes) $ \ addr -> do 300 -- forM (L.take 1 nodes) $ \ addr -> do
294 -- NodeFound ns <- FindNode nid <@> addr 301 -- NodeFound ns <- FindNode nid <@> addr
295 -- Expected type: ConduitM [NodeAddr ip] [NodeInfo ip] (DHT ip) () 302 -- Expected type: ConduitM [NodeAddr ip] [NodeInfo KMessageOf ip ()] (DHT ip) ()
296 -- Actual type: ConduitM [NodeInfo ip] [NodeInfo ip] (DHT ip) () 303 -- Actual type: ConduitM [NodeInfo KMessageOf ip ()] [NodeInfo KMessageOf ip ()] (DHT ip) ()
297 -- nss <- sourceList [[addr]] $= search nid (findNodeQ nid) $$ C.consume 304 -- nss <- sourceList [[addr]] $= search nid (findNodeQ nid) $$ C.consume
298 nss <- sourceList [nodes] $= search nid (findNodeQ nid) $$ C.consume 305 nss <- sourceList [nodes] $= search nid (findNodeQ nid) $$ C.consume
299 $(logWarnS) "refreshNodes" $ "received " <> T.pack (show (L.length (L.concat nss))) <> " nodes." 306 $(logWarnS) "refreshNodes" $ "received " <> T.pack (show (L.length (L.concat nss))) <> " nodes."
@@ -306,7 +313,7 @@ refreshNodes nid = do
306 313
307-- | This operation do not block but acquire exclusive access to 314-- | This operation do not block but acquire exclusive access to
308-- routing table. 315-- routing table.
309insertNode :: forall ip. Address ip => NodeInfo ip -> Maybe ReflectedIP -> DHT ip () 316insertNode :: forall ip. Address ip => NodeInfo KMessageOf ip () -> Maybe ReflectedIP -> DHT ip ()
310insertNode info witnessed_ip0 = do 317insertNode info witnessed_ip0 = do
311 var <- asks routingInfo 318 var <- asks routingInfo
312 tm <- getTimestamp 319 tm <- getTimestamp
@@ -315,7 +322,7 @@ insertNode info witnessed_ip0 = do
315 let logMsg = "Routing table: " <> pPrint t 322 let logMsg = "Routing table: " <> pPrint t
316 $(logDebugS) "insertNode" (T.pack (render logMsg)) 323 $(logDebugS) "insertNode" (T.pack (render logMsg))
317 let arrival0 = TryInsert info 324 let arrival0 = TryInsert info
318 arrival4 = TryInsert (fmap fromAddr info) :: Event (Maybe IPv4) 325 arrival4 = TryInsert (mapAddress fromAddr info) :: Event (Maybe IPv4)
319 $(logDebugS) "insertNode" $ T.pack (show arrival4) 326 $(logDebugS) "insertNode" $ T.pack (show arrival4)
320 maxbuckets <- asks (optBucketCount . options) 327 maxbuckets <- asks (optBucketCount . options)
321 fallbackid <- asks tentativeNodeId 328 fallbackid <- asks tentativeNodeId
@@ -380,18 +387,18 @@ insertNode info witnessed_ip0 = do
380 387
381-- | Throws exception if node is not responding. 388-- | Throws exception if node is not responding.
382queryNode :: forall a b ip. Address ip => KRPC (Query a) (Response b) 389queryNode :: forall a b ip. Address ip => KRPC (Query a) (Response b)
383 => NodeAddr ip -> a -> DHT ip (NodeId, b) 390 => NodeAddr ip -> a -> DHT ip (NodeId KMessageOf, b)
384queryNode addr q = fmap (\(n,b,_) -> (n,b)) $ queryNode' addr q 391queryNode addr q = fmap (\(n,b,_) -> (n,b)) $ queryNode' addr q
385 392
386queryNode' :: forall a b ip. Address ip => KRPC (Query a) (Response b) 393queryNode' :: forall a b ip. Address ip => KRPC (Query a) (Response b)
387 => NodeAddr ip -> a -> DHT ip (NodeId, b, Maybe ReflectedIP) 394 => NodeAddr ip -> a -> DHT ip (NodeId KMessageOf, b, Maybe ReflectedIP)
388queryNode' addr q = do 395queryNode' addr q = do
389 nid <- myNodeIdAccordingTo addr 396 nid <- myNodeIdAccordingTo addr
390 let read_only = False -- TODO: check for NAT issues. (BEP 43) 397 let read_only = False -- TODO: check for NAT issues. (BEP 43)
391 (Response remoteId r, witnessed_ip) <- query' (toSockAddr addr) (Query nid read_only q) 398 (Response remoteId r, witnessed_ip) <- query' (toSockAddr addr) (Query nid read_only q)
392 -- $(logDebugS) "queryNode" $ "Witnessed address: " <> T.pack (show witnessed_ip) 399 -- $(logDebugS) "queryNode" $ "Witnessed address: " <> T.pack (show witnessed_ip)
393 -- <> " by " <> T.pack (show (toSockAddr addr)) 400 -- <> " by " <> T.pack (show (toSockAddr addr))
394 _ <- insertNode (NodeInfo remoteId addr) witnessed_ip 401 _ <- insertNode (NodeInfo remoteId addr ()) witnessed_ip
395 return (remoteId, r, witnessed_ip) 402 return (remoteId, r, witnessed_ip)
396 403
397-- | Infix version of 'queryNode' function. 404-- | Infix version of 'queryNode' function.
diff --git a/src/Network/BitTorrent/DHT/Routing.hs b/src/Network/BitTorrent/DHT/Routing.hs
index cf4a4de3..6cf7f122 100644
--- a/src/Network/BitTorrent/DHT/Routing.hs
+++ b/src/Network/BitTorrent/DHT/Routing.hs
@@ -83,8 +83,10 @@ import Text.PrettyPrint.HughesPJClass (pPrint,Pretty)
83import qualified Data.ByteString as BS 83import qualified Data.ByteString as BS
84import Data.Bits 84import Data.Bits
85 85
86import Network.KRPC.Message (KMessageOf)
86import Data.Torrent 87import Data.Torrent
87import Network.BitTorrent.Address 88import Network.BitTorrent.Address
89import Network.DHT.Mainline
88 90
89{----------------------------------------------------------------------- 91{-----------------------------------------------------------------------
90-- Routing monad 92-- Routing monad
@@ -180,7 +182,7 @@ runRouting ping_node find_nodes timestamper = go
180-- other words: new nodes are used only when older nodes disappear. 182-- other words: new nodes are used only when older nodes disappear.
181 183
182-- | Timestamp - last time this node is pinged. 184-- | Timestamp - last time this node is pinged.
183type NodeEntry ip = Binding (NodeInfo ip) Timestamp 185type NodeEntry ip = Binding (NodeInfo KMessageOf ip ()) Timestamp
184 186
185-- TODO instance Pretty where 187-- TODO instance Pretty where
186 188
@@ -211,7 +213,7 @@ fromQ embed project QueueMethods{..} =
211 } 213 }
212-} 214-}
213 215
214seqQ :: QueueMethods Identity (NodeInfo ip) (Seq.Seq (NodeInfo ip)) 216seqQ :: QueueMethods Identity (NodeInfo KMessageOf ip ()) (Seq.Seq (NodeInfo KMessageOf ip ()))
215seqQ = QueueMethods 217seqQ = QueueMethods
216 { pushBack = \e fifo -> pure (fifo Seq.|> e) 218 { pushBack = \e fifo -> pure (fifo Seq.|> e)
217 , popFront = \fifo -> case Seq.viewl fifo of 219 , popFront = \fifo -> case Seq.viewl fifo of
@@ -220,9 +222,9 @@ seqQ = QueueMethods
220 , emptyQueue = pure Seq.empty 222 , emptyQueue = pure Seq.empty
221 } 223 }
222 224
223type BucketQueue ip = Seq.Seq (NodeInfo ip) 225type BucketQueue ip = Seq.Seq (NodeInfo KMessageOf ip ())
224 226
225bucketQ :: QueueMethods Identity (NodeInfo ip) (BucketQueue ip) 227bucketQ :: QueueMethods Identity (NodeInfo KMessageOf ip ()) (BucketQueue ip)
226bucketQ = seqQ 228bucketQ = seqQ
227 229
228-- | Bucket is also limited in its length — thus it's called k-bucket. 230-- | Bucket is also limited in its length — thus it's called k-bucket.
@@ -232,7 +234,7 @@ bucketQ = seqQ
232-- very unlikely that all nodes in bucket fail within an hour of 234-- very unlikely that all nodes in bucket fail within an hour of
233-- each other. 235-- each other.
234-- 236--
235data Bucket ip = Bucket { bktNodes :: !(PSQ (NodeInfo ip) Timestamp) 237data Bucket ip = Bucket { bktNodes :: !(PSQ (NodeInfo KMessageOf ip ()) Timestamp)
236 , bktQ :: !(BucketQueue ip) 238 , bktQ :: !(BucketQueue ip)
237 } deriving (Show,Generic) 239 } deriving (Show,Generic)
238 240
@@ -303,7 +305,7 @@ insertBucket curTime (PingResult bad_node got_response) bucket
303 pure $ PSQ.insert info curTime nodes' 305 pure $ PSQ.insert info curTime nodes'
304 | otherwise = id 306 | otherwise = id
305 307
306updateStamps :: Eq ip => Timestamp -> [NodeInfo ip] -> PSQ (NodeInfo ip) Timestamp -> PSQ (NodeInfo ip) Timestamp 308updateStamps :: Eq ip => Timestamp -> [NodeInfo KMessageOf ip ()] -> PSQ (NodeInfo KMessageOf ip ()) Timestamp -> PSQ (NodeInfo KMessageOf ip ()) Timestamp
307updateStamps curTime stales nodes = foldl' (\q n -> PSQ.insert n curTime q) nodes stales 309updateStamps curTime stales nodes = foldl' (\q n -> PSQ.insert n curTime q) nodes stales
308 310
309 311
@@ -330,6 +332,12 @@ split i b = (Bucket ns qs, Bucket ms rs)
330 where 332 where
331 (ns,ms) = (PSQ.fromList *** PSQ.fromList) . partition (spanBit . key) . PSQ.toList $ bktNodes b 333 (ns,ms) = (PSQ.fromList *** PSQ.fromList) . partition (spanBit . key) . PSQ.toList $ bktNodes b
332 (qs,rs) = runIdentity $ partitionQ bucketQ spanBit $ bktQ b 334 (qs,rs) = runIdentity $ partitionQ bucketQ spanBit $ bktQ b
335 {-
336 spanBit :: forall (dht :: * -> *) addr u.
337 FiniteBits (Network.RPC.NodeId dht) =>
338 NodeInfo dht addr u -> Bool
339 -}
340 spanBit :: NodeInfo KMessageOf addr () -> Bool
333 spanBit entry = testIdBit (nodeId entry) i 341 spanBit entry = testIdBit (nodeId entry) i
334 342
335{----------------------------------------------------------------------- 343{-----------------------------------------------------------------------
@@ -458,7 +466,7 @@ compatibleNodeId tbl = genBucketSample prefix br
458 where 466 where
459 br = bucketRange (L.length (shape tbl) - 1) True 467 br = bucketRange (L.length (shape tbl) - 1) True
460 bs = BS.pack $ take nodeIdSize $ tablePrefix tbl ++ repeat 0 468 bs = BS.pack $ take nodeIdSize $ tablePrefix tbl ++ repeat 0
461 prefix = asNodeId bs 469 prefix = either error id $ S.decode bs
462 470
463tablePrefix :: Table ip -> [Word8] 471tablePrefix :: Table ip -> [Word8]
464tablePrefix = map (packByte . take 8 . (++repeat False)) 472tablePrefix = map (packByte . take 8 . (++repeat False))
@@ -503,7 +511,7 @@ instance TableKey InfoHash where
503 511
504-- | Get a list of /K/ closest nodes using XOR metric. Used in 512-- | Get a list of /K/ closest nodes using XOR metric. Used in
505-- 'find_node' and 'get_peers' queries. 513-- 'find_node' and 'get_peers' queries.
506kclosest :: Eq ip => TableKey a => K -> a -> Table ip -> [NodeInfo ip] 514kclosest :: Eq ip => TableKey a => K -> a -> Table ip -> [NodeInfo KMessageOf ip ()]
507kclosest k (toNodeId -> nid) tbl = take k $ rank nodeId nid (L.concat bucket) 515kclosest k (toNodeId -> nid) tbl = take k $ rank nodeId nid (L.concat bucket)
508 ++ rank nodeId nid (L.concat everyone) 516 ++ rank nodeId nid (L.concat everyone)
509 where 517 where
@@ -547,19 +555,19 @@ modifyBucket nodeId f = go (0 :: BitIx)
547 <|> go i (splitTip nid n i bucket) 555 <|> go i (splitTip nid n i bucket)
548 556
549-- | Triggering event for atomic table update 557-- | Triggering event for atomic table update
550data Event ip = TryInsert { foreignNode :: NodeInfo ip } 558data Event ip = TryInsert { foreignNode :: NodeInfo KMessageOf ip () }
551 | PingResult { foreignNode :: NodeInfo ip 559 | PingResult { foreignNode :: NodeInfo KMessageOf ip ()
552 , ponged :: Bool 560 , ponged :: Bool
553 } 561 }
554 deriving (Eq,Ord,Show) 562 deriving (Eq,Show) -- Ord
555 563
556eventId :: Event ip -> NodeId 564eventId :: Event ip -> NodeId
557eventId (TryInsert NodeInfo{..}) = nodeId 565eventId (TryInsert NodeInfo{..}) = nodeId
558eventId (PingResult NodeInfo{..} _) = nodeId 566eventId (PingResult NodeInfo{..} _) = nodeId
559 567
560-- | Actions requested by atomic table update 568-- | Actions requested by atomic table update
561data CheckPing ip = CheckPing [NodeInfo ip] 569data CheckPing ip = CheckPing [NodeInfo KMessageOf ip ()]
562 deriving (Eq,Ord,Show) 570 deriving (Eq,Show) -- Ord
563 571
564 572
565-- | Atomic 'Table' update 573-- | Atomic 'Table' update
@@ -571,7 +579,7 @@ insert tm event tbl = pure $ fromMaybe ([],tbl) $ modifyBucket (eventId event) (
571-- Conversion 579-- Conversion
572-----------------------------------------------------------------------} 580-----------------------------------------------------------------------}
573 581
574type TableEntry ip = (NodeInfo ip, Timestamp) 582type TableEntry ip = (NodeInfo KMessageOf ip (), Timestamp)
575 583
576tableEntry :: NodeEntry ip -> TableEntry ip 584tableEntry :: NodeEntry ip -> TableEntry ip
577tableEntry (a :-> b) = (a, b) 585tableEntry (a :-> b) = (a, b)
diff --git a/src/Network/BitTorrent/DHT/Search.hs b/src/Network/BitTorrent/DHT/Search.hs
index 79cc9489..854f26c7 100644
--- a/src/Network/BitTorrent/DHT/Search.hs
+++ b/src/Network/BitTorrent/DHT/Search.hs
@@ -1,5 +1,6 @@
1{-# LANGUAGE PatternSynonyms #-} 1{-# LANGUAGE PatternSynonyms #-}
2{-# LANGUAGE RecordWildCards #-} 2{-# LANGUAGE RecordWildCards #-}
3{-# LANGUAGE ScopedTypeVariables #-}
3module Network.BitTorrent.DHT.Search where 4module Network.BitTorrent.DHT.Search where
4 5
5import Control.Concurrent 6import Control.Concurrent
@@ -21,20 +22,23 @@ import qualified Data.MinMaxPSQ as MM
21 ;import Data.MinMaxPSQ (MinMaxPSQ) 22 ;import Data.MinMaxPSQ (MinMaxPSQ)
22import qualified Data.Wrapper.PSQ as PSQ 23import qualified Data.Wrapper.PSQ as PSQ
23 ;import Data.Wrapper.PSQ (pattern (:->), Binding, PSQ) 24 ;import Data.Wrapper.PSQ (pattern (:->), Binding, PSQ)
24import Network.BitTorrent.Address 25import Network.BitTorrent.Address hiding (NodeId)
26import Network.RPC
27import Network.KRPC.Message (KMessageOf)
28import Network.DHT.Mainline ()
25 29
26data IterativeSearch ip r = IterativeSearch 30data IterativeSearch ip r = IterativeSearch
27 { searchTarget :: NodeId 31 { searchTarget :: NodeId KMessageOf
28 , searchQuery :: NodeInfo ip -> IO ([NodeInfo ip], [r]) 32 , searchQuery :: NodeInfo KMessageOf ip () -> IO ([NodeInfo KMessageOf ip ()], [r])
29 , searchPendingCount :: TVar Int 33 , searchPendingCount :: TVar Int
30 , searchQueued :: TVar (MinMaxPSQ (NodeInfo ip) NodeDistance) 34 , searchQueued :: TVar (MinMaxPSQ (NodeInfo KMessageOf ip ()) (NodeDistance (NodeId KMessageOf)))
31 , searchInformant :: TVar (MinMaxPSQ (NodeInfo ip) NodeDistance) 35 , searchInformant :: TVar (MinMaxPSQ (NodeInfo KMessageOf ip ()) (NodeDistance (NodeId KMessageOf)))
32 , searchVisited :: TVar (Set (NodeAddr ip)) 36 , searchVisited :: TVar (Set (NodeAddr ip))
33 , searchResults :: TVar (Set r) 37 , searchResults :: TVar (Set r)
34 } 38 }
35 39
36newSearch :: Eq ip => (NodeInfo ip -> IO ([NodeInfo ip], [r])) 40newSearch :: Eq ip => (NodeInfo KMessageOf ip () -> IO ([NodeInfo KMessageOf ip ()], [r]))
37 -> NodeId -> [NodeInfo ip] -> IO (IterativeSearch ip r) 41 -> NodeId KMessageOf -> [NodeInfo KMessageOf ip ()] -> IO (IterativeSearch ip r)
38newSearch qry target ns = atomically $ do 42newSearch qry target ns = atomically $ do
39 c <- newTVar 0 43 c <- newTVar 0
40 q <- newTVar $ MM.fromList $ map (\n -> n :-> distance target (nodeId n)) ns 44 q <- newTVar $ MM.fromList $ map (\n -> n :-> distance target (nodeId n)) ns
@@ -49,9 +53,9 @@ searchAlpha = 3
49searchK :: Int 53searchK :: Int
50searchK = 8 54searchK = 8
51 55
52sendQuery :: (Ord a, Ord t) => 56sendQuery :: forall a ip. (Ord a, Ord ip) =>
53 IterativeSearch t a 57 IterativeSearch ip a
54 -> Binding (NodeInfo t) NodeDistance 58 -> Binding (NodeInfo KMessageOf ip ()) (NodeDistance (NodeId KMessageOf))
55 -> IO () 59 -> IO ()
56sendQuery IterativeSearch{..} (ni :-> d) = do 60sendQuery IterativeSearch{..} (ni :-> d) = do
57 (ns,rs) <- handle (\(SomeException e) -> return ([],[])) 61 (ns,rs) <- handle (\(SomeException e) -> return ([],[]))
@@ -60,7 +64,10 @@ sendQuery IterativeSearch{..} (ni :-> d) = do
60 modifyTVar searchPendingCount pred 64 modifyTVar searchPendingCount pred
61 vs <- readTVar searchVisited 65 vs <- readTVar searchVisited
62 -- We only queue a node if it is not yet visited 66 -- We only queue a node if it is not yet visited
63 let insertFoundNode n q 67 let insertFoundNode :: NodeInfo KMessageOf ip u
68 -> MinMaxPSQ (NodeInfo KMessageOf ip u) (NodeDistance (NodeId KMessageOf))
69 -> MinMaxPSQ (NodeInfo KMessageOf ip u) (NodeDistance (NodeId KMessageOf))
70 insertFoundNode n q
64 | nodeAddr n `Set.member` vs = q 71 | nodeAddr n `Set.member` vs = q
65 | otherwise = MM.insertTake searchK n (distance searchTarget $ nodeId n) q 72 | otherwise = MM.insertTake searchK n (distance searchTarget $ nodeId n) q
66 modifyTVar searchQueued $ \q -> foldr insertFoundNode q ns 73 modifyTVar searchQueued $ \q -> foldr insertFoundNode q ns
diff --git a/src/Network/BitTorrent/DHT/Session.hs b/src/Network/BitTorrent/DHT/Session.hs
index 20dba595..aa6ee396 100644
--- a/src/Network/BitTorrent/DHT/Session.hs
+++ b/src/Network/BitTorrent/DHT/Session.hs
@@ -452,7 +452,7 @@ allPeers ih = do
452-- 452--
453-- This operation used for 'find_nodes' query. 453-- This operation used for 'find_nodes' query.
454-- 454--
455getClosest :: Eq ip => TableKey k => k -> DHT ip [NodeInfo ip] 455getClosest :: Eq ip => TableKey k => k -> DHT ip [NodeInfo KMessageOf ip ()]
456getClosest node = do 456getClosest node = do
457 k <- asks (optK . options) 457 k <- asks (optK . options)
458 kclosest k node <$> getTable 458 kclosest k node <$> getTable
diff --git a/src/Network/DHT/Mainline.hs b/src/Network/DHT/Mainline.hs
index 540b74f9..d7aed430 100644
--- a/src/Network/DHT/Mainline.hs
+++ b/src/Network/DHT/Mainline.hs
@@ -1,18 +1,76 @@
1{-# LANGUAGE LambdaCase #-} 1{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE MultiParamTypeClasses #-} 2{-# LANGUAGE MultiParamTypeClasses #-}
3{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE TypeFamilies #-} 4{-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4module Network.DHT.Mainline where 6module Network.DHT.Mainline where
5 7
6import Network.Socket 8import Data.BEncode as BE
7import Network.RPC 9import Data.Bits
8import Network.KRPC.Message as KRPC 10import Data.ByteString (ByteString)
9import Data.BEncode as BE 11import Data.ByteString.Base16 as Base16
10import qualified Data.ByteString.Lazy as L 12import qualified Data.ByteString.Char8 as Char8
11import Network.BitTorrent.Address as BT (NodeId) 13import qualified Data.ByteString.Lazy as L
14import Data.Default
15import Data.LargeWord
16import Data.Serialize as S
17import Data.String
18import Data.Typeable
19import Network.KRPC.Message as KRPC
20import qualified Network.RPC as RPC (NodeId)
21 ;import Network.RPC as RPC hiding (NodeId)
22import Text.PrettyPrint as PP hiding ((<>))
23import Text.PrettyPrint.HughesPJClass hiding (($$), (<>))
24
25-- | Each node has a globally unique identifier known as the \"node
26-- ID.\"
27--
28-- Normally, /this/ node id should be saved between invocations
29-- of the client software.
30newtype NodeId = NodeId Word160
31 deriving (Show, Eq, Ord, Typeable, Bits, FiniteBits)
32
33instance BEncode NodeId where
34 toBEncode (NodeId w) = toBEncode $ S.encode w
35 fromBEncode bval = fromBEncode bval >>= S.decode
36
37-- | NodeId size in bytes.
38nodeIdSize :: Int
39nodeIdSize = 20
40
41
42-- instance BEncode NodeId where TODO
43
44-- TODO: put this somewhere appropriate
45instance (Serialize a, Serialize b) => Serialize (LargeKey a b) where
46 put (LargeKey lo hi) = put hi >> put lo
47 get = flip LargeKey <$> get <*> get
48
49instance Serialize NodeId where
50 get = NodeId <$> get
51 {-# INLINE get #-}
52 put (NodeId bs) = put bs
53 {-# INLINE put #-}
54
55-- | ASCII encoded.
56instance IsString NodeId where
57 fromString str
58 | length str == nodeIdSize = NodeId (either error id $ S.decode (fromString str :: ByteString))
59 | length str == 2 * nodeIdSize = NodeId (either error id $ S.decode (fst $ Base16.decode $ fromString str))
60 | otherwise = error "fromString: invalid NodeId length"
61 {-# INLINE fromString #-}
62
63-- | Meaningless node id, for testing purposes only.
64instance Default NodeId where
65 def = NodeId 0
66
67-- | base16 encoded.
68instance Pretty NodeId where
69 pPrint (NodeId nid) = PP.text $ Char8.unpack $ Base16.encode $ S.encode nid
12 70
13instance Envelope KMessageOf where 71instance Envelope KMessageOf where
14 type TransactionID KMessageOf = KRPC.TransactionId 72 type TransactionID KMessageOf = KRPC.TransactionId
15 type NodeId KMessageOf = BT.NodeId 73 type NodeId KMessageOf = Network.DHT.Mainline.NodeId
16 74
17 envelopePayload (Q q) = queryArgs q 75 envelopePayload (Q q) = queryArgs q
18 envelopePayload (R r) = respVals r 76 envelopePayload (R r) = respVals r
diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs
index f31a3cd6..efd59f32 100644
--- a/src/Network/KRPC/Manager.hs
+++ b/src/Network/KRPC/Manager.hs
@@ -84,7 +84,9 @@ import Network.Socket hiding (listen)
84import Network.Socket.ByteString as BS 84import Network.Socket.ByteString as BS
85import System.IO.Error 85import System.IO.Error
86import System.Timeout 86import System.Timeout
87#ifdef VERSION_bencoding
87import Network.DHT.Mainline 88import Network.DHT.Mainline
89#endif
88 90
89 91
90{----------------------------------------------------------------------- 92{-----------------------------------------------------------------------
@@ -268,15 +270,9 @@ data QueryFailure
268 270
269instance Exception QueryFailure 271instance Exception QueryFailure
270 272
271#ifdef VERSION_bencoding
272sendMessage :: MonadIO m => BEncode a => Socket -> SockAddr -> a -> m ()
273sendMessage sock addr a = do
274 liftIO $ sendManyTo sock (BL.toChunks (BE.encode a)) addr
275#else
276sendMessage :: MonadIO m => Socket -> SockAddr -> BC.ByteString -> m () 273sendMessage :: MonadIO m => Socket -> SockAddr -> BC.ByteString -> m ()
277sendMessage sock addr a = do 274sendMessage sock addr a = do
278 liftIO $ sendManyTo sock [a] addr 275 liftIO $ sendManyTo sock [a] addr
279#endif
280 276
281genTransactionId :: TransactionCounter -> IO TransactionId 277genTransactionId :: TransactionCounter -> IO TransactionId
282genTransactionId ref = do 278genTransactionId ref = do
@@ -309,13 +305,8 @@ unregisterQuery cid ref = do
309 305
310 306
311-- (sendmsg EINVAL) 307-- (sendmsg EINVAL)
312#ifdef VERSION_bencoding 308sendQuery :: Socket -> SockAddr -> BC.ByteString -> IO ()
313sendQuery :: BEncode a => Socket -> SockAddr -> a -> IO ()
314sendQuery sock addr q = handle sockError $ sendMessage sock addr q 309sendQuery sock addr q = handle sockError $ sendMessage sock addr q
315#else
316sendQuery :: Serialize a => Socket -> SockAddr -> a -> IO ()
317sendQuery sock addr q = handle sockError $ sendMessage sock addr (S.encode q)
318#endif
319 where 310 where
320 sockError :: IOError -> IO () 311 sockError :: IOError -> IO ()
321 sockError _ = throwIO SendFailed 312 sockError _ = throwIO SendFailed
@@ -351,12 +342,17 @@ queryK addr params kont = do
351 ares <- registerQuery (tid, addr) pendingCalls 342 ares <- registerQuery (tid, addr) pendingCalls
352 343
353#ifdef VERSION_bencoding 344#ifdef VERSION_bencoding
354 let q = KQuery (toBEncode params) (methodName queryMethod) tid 345 let q = Q (KQuery (toBEncode params) (methodName queryMethod) tid)
346 qb = encodePayload q :: KMessage
347 qbs = encodeHeaders () qb :: BC.ByteString
355#else 348#else
356 let q = Tox.Message (methodName queryMethod) cli tid params 349 let q = Tox.Message (methodName queryMethod) cli tid params
357 cli = error "TODO TOX client node id" 350 cli = error "TODO TOX client node id"
351 ctx = error "TODO TOX ToxCipherContext"
352 qb = encodePayload q :: Tox.Message BC.ByteString
353 qbs = encodeHeaders ctx qb :: BC.ByteString
358#endif 354#endif
359 sendQuery sock addr q 355 sendQuery sock addr qbs
360 `onException` unregisterQuery (tid, addr) pendingCalls 356 `onException` unregisterQuery (tid, addr) pendingCalls
361 357
362 timeout (optQueryTimeout options * 10 ^ (6 :: Int)) $ do 358 timeout (optQueryTimeout options * 10 ^ (6 :: Int)) $ do
@@ -463,14 +459,7 @@ runHandler h addr m = Lifted.catches wrapper failbacks
463 459
464 Right a -> do -- KQueryArgs 460 Right a -> do -- KQueryArgs
465 $(logDebugS) "handler.success" signature 461 $(logDebugS) "handler.success" signature
466#ifdef VERSION_bencoding
467 return $ Right a 462 return $ Right a
468#else
469 let cli = error "TODO TOX client node id"
470 messageid = error "TODO TOX message response id"
471 -- TODO: ReflectedIP addr ??
472 return $ Right $ Tox.Message messageid cli (queryId m) a
473#endif
474 463
475 failbacks = 464 failbacks =
476 [ E.Handler $ \ (e :: HandlerFailure) -> do 465 [ E.Handler $ \ (e :: HandlerFailure) -> do
@@ -528,16 +517,18 @@ handleQuery raw q addr = void $ fork $ do
528 Manager {..} <- getManager 517 Manager {..} <- getManager
529 res <- dispatchHandler q addr 518 res <- dispatchHandler q addr
530#ifdef VERSION_bencoding 519#ifdef VERSION_bencoding
531 let resbe = either toBEncode toBEncode res 520 let res' = either E id res
521 resbe = either toBEncode toBEncode res
532 $(logOther "q") $ T.unlines 522 $(logOther "q") $ T.unlines
533 [ either (const "<unicode-fail>") id $ T.decodeUtf8' (BL.toStrict $ showBEncode raw) 523 [ either (const "<unicode-fail>") id $ T.decodeUtf8' (BL.toStrict $ showBEncode raw)
534 , "==>" 524 , "==>"
535 , either (const "<unicode-fail>") id $ T.decodeUtf8' (BL.toStrict $ showBEncode resbe) 525 , either (const "<unicode-fail>") id $ T.decodeUtf8' (BL.toStrict $ showBEncode resbe)
536 ] 526 ]
537 sendMessage sock addr resbe 527 sendMessage sock addr $ encodeHeaders () res'
538#else 528#else
539 -- Errors not sent for Tox. 529 -- Errors not sent for Tox.
540 either (const $ return ()) (sendMessage sock addr . S.encode) res 530 let ctx = error "TODO TOX ToxCipherContext 2"
531 either (const $ return ()) (sendMessage sock addr . encodeHeaders ctx) res
541#endif 532#endif
542 533
543handleResponse :: MonadKRPC h m => KQueryArgs -> KResult -> SockAddr -> m () 534handleResponse :: MonadKRPC h m => KQueryArgs -> KResult -> SockAddr -> m ()
@@ -570,16 +561,17 @@ listener :: MonadKRPC h m => m ()
570listener = do 561listener = do
571 Manager {..} <- getManager 562 Manager {..} <- getManager
572 fix $ \again -> do 563 fix $ \again -> do
564 let ctx = error "TODO TOX ToxCipherContext 3"
573 (bs, addr) <- liftIO $ do 565 (bs, addr) <- liftIO $ do
574 handle exceptions $ BS.recvFrom sock (optMaxMsgSize options) 566 handle exceptions $ BS.recvFrom sock (optMaxMsgSize options)
575#ifdef VERSION_bencoding 567#ifdef VERSION_bencoding
576 case BE.parse bs >>= \r -> (,) r <$> BE.decode bs of 568 case BE.parse bs >>= \r -> (,) r <$> BE.decode bs of
577#else 569#else
578 case return bs >>= \r -> (,) r <$> decode bs of 570 case return bs >>= \r -> (,) r <$> decodeHeaders ctx bs of
579#endif 571#endif
580 -- TODO ignore unknown messages at all? 572 -- TODO ignore unknown messages at all?
581#ifdef VERSION_bencoding 573#ifdef VERSION_bencoding
582 Left e -> liftIO $ sendMessage sock addr $ unknownMessage e 574 Left e -> liftIO $ sendMessage sock addr $ encodeHeaders () (E (unknownMessage e) :: KMessage)
583#else 575#else
584 Left _ -> return () -- TODO TOX send unknownMessage error 576 Left _ -> return () -- TODO TOX send unknownMessage error
585#endif 577#endif
diff --git a/src/Network/RPC.hs b/src/Network/RPC.hs
index 727422fd..7fb0e571 100644
--- a/src/Network/RPC.hs
+++ b/src/Network/RPC.hs
@@ -1,16 +1,22 @@
1{-# LANGUAGE ConstraintKinds #-} 1{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FunctionalDependencies #-} 4{-# LANGUAGE FunctionalDependencies #-}
3{-# LANGUAGE MultiParamTypeClasses #-} 5{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE RankNTypes #-} 6{-# LANGUAGE RankNTypes #-}
5{-# LANGUAGE ScopedTypeVariables #-} 7{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE TypeFamilies #-} 8{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE DeriveDataTypeable #-}
8module Network.RPC where 9module Network.RPC where
9 10
11import Data.Bits
10import Data.ByteString (ByteString) 12import Data.ByteString (ByteString)
11import Data.Kind (Constraint) 13import Data.Kind (Constraint)
12import Data.Data 14import Data.Data
13import Network.Socket 15import Network.Socket
16import Text.PrettyPrint.HughesPJClass hiding (($$), (<>))
17import Data.Serialize as S
18import qualified Data.ByteString.Char8 as Char8
19import Data.ByteString.Base16 as Base16
14 20
15data MessageClass = Error | Query | Response 21data MessageClass = Error | Query | Response
16 deriving (Eq,Ord,Enum,Bounded,Data,Show,Read) 22 deriving (Eq,Ord,Enum,Bounded,Data,Show,Read)
@@ -36,6 +42,22 @@ class Envelope envelope where
36 -- Returns: response message envelope 42 -- Returns: response message envelope
37 buildReply :: NodeId envelope -> SockAddr -> envelope a -> b -> envelope b 43 buildReply :: NodeId envelope -> SockAddr -> envelope a -> b -> envelope b
38 44
45-- | In Kademlia, the distance metric is XOR and the result is
46-- interpreted as an unsigned integer.
47newtype NodeDistance nodeid = NodeDistance nodeid
48 deriving (Eq, Ord)
49
50-- | distance(A,B) = |A xor B| Smaller values are closer.
51distance :: Bits nid => nid -> nid -> NodeDistance nid
52distance a b = NodeDistance $ xor a b
53
54instance Serialize nodeid => Show (NodeDistance nodeid) where
55 show (NodeDistance w) = Char8.unpack $ Base16.encode $ S.encode w
56
57instance Serialize nodeid => Pretty (NodeDistance nodeid) where
58 pPrint n = text $ show n
59
60
39class Envelope envelope => WireFormat raw envelope where 61class Envelope envelope => WireFormat raw envelope where
40 type SerializableTo raw :: * -> Constraint 62 type SerializableTo raw :: * -> Constraint
41 type CipherContext raw envelope 63 type CipherContext raw envelope
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 18:11:37 +0000