summaryrefslogtreecommitdiff
path: root/src/Network
diff options
context:
space:
mode:
authorjoe <joe@jerkface.net>2017-06-08 03:07:13 -0400
committerjoe <joe@jerkface.net>2017-06-08 03:07:13 -0400
commit8c33deac14ca92ef67afc7fbcd3f67bc19317f88 (patch)
treee7636f38ae91ff0ef7c84091ccc65048cc45fea5 /src/Network
parentd6fac9a8df0ce872ede54d6a71ca6d6c750eadc9 (diff)
WIP: Adapting DHT to Tox network (part 6).
Diffstat (limited to 'src/Network')
-rw-r--r--src/Network/BitTorrent/Address.hs242
-rw-r--r--src/Network/BitTorrent/DHT/Message.hs4
-rw-r--r--src/Network/BitTorrent/DHT/Query.hs3
-rw-r--r--src/Network/BitTorrent/DHT/Routing.hs268
-rw-r--r--src/Network/BitTorrent/DHT/Search.hs22
-rw-r--r--src/Network/BitTorrent/DHT/Session.hs42
-rw-r--r--src/Network/DHT/Mainline.hs94
-rw-r--r--src/Network/RPC.hs236
8 files changed, 509 insertions, 402 deletions
diff --git a/src/Network/BitTorrent/Address.hs b/src/Network/BitTorrent/Address.hs
index 560ac1ef..f364abbe 100644
--- a/src/Network/BitTorrent/Address.hs
+++ b/src/Network/BitTorrent/Address.hs
@@ -13,6 +13,7 @@
13{-# LANGUAGE FlexibleInstances #-} 13{-# LANGUAGE FlexibleInstances #-}
14{-# LANGUAGE FlexibleContexts #-} 14{-# LANGUAGE FlexibleContexts #-}
15{-# LANGUAGE RecordWildCards #-} 15{-# LANGUAGE RecordWildCards #-}
16{-# LANGUAGE ScopedTypeVariables #-}
16{-# LANGUAGE StandaloneDeriving #-} 17{-# LANGUAGE StandaloneDeriving #-}
17{-# LANGUAGE ViewPatterns #-} 18{-# LANGUAGE ViewPatterns #-}
18{-# LANGUAGE GeneralizedNewtypeDeriving #-} 19{-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -60,13 +61,10 @@ module Network.BitTorrent.Address
60 -- * Node 61 -- * Node
61 -- ** Id 62 -- ** Id
62 , NodeId 63 , NodeId
63 , nodeIdSize
64 , testIdBit 64 , testIdBit
65 , genNodeId 65 , genNodeId
66 , bucketRange 66 , bucketRange
67 , genBucketSample 67 , genBucketSample
68 , bep42
69 , bep42s
70 68
71 -- ** Info 69 -- ** Info
72 , NodeAddr (..) 70 , NodeAddr (..)
@@ -129,47 +127,15 @@ import System.Locale (defaultTimeLocale)
129#endif 127#endif
130import System.Entropy 128import System.Entropy
131import Data.Digest.CRC32C 129import Data.Digest.CRC32C
132import qualified Network.RPC as RPC 130import Network.RPC as RPC
133import Network.KRPC.Message (KMessageOf) 131import Network.KRPC.Message (KMessageOf)
134import Network.DHT.Mainline 132-- import Network.DHT.Mainline
135 133
136-- import Paths_bittorrent (version) 134-- import Paths_bittorrent (version)
137 135
138{-----------------------------------------------------------------------
139-- Address
140-----------------------------------------------------------------------}
141
142instance Pretty UTCTime where 136instance Pretty UTCTime where
143 pPrint = PP.text . show 137 pPrint = PP.text . show
144 138
145class (Eq a, Serialize a, Typeable a, Hashable a, Pretty a)
146 => Address a where
147 toSockAddr :: a -> SockAddr
148 fromSockAddr :: SockAddr -> Maybe a
149
150fromAddr :: (Address a, Address b) => a -> Maybe b
151fromAddr = fromSockAddr . toSockAddr
152
153-- | Note that port is zeroed.
154instance Address IPv4 where
155 toSockAddr = SockAddrInet 0 . toHostAddress
156 fromSockAddr (SockAddrInet _ h) = Just (fromHostAddress h)
157 fromSockAddr _ = Nothing
158
159-- | Note that port is zeroed.
160instance Address IPv6 where
161 toSockAddr h = SockAddrInet6 0 0 (toHostAddress6 h) 0
162 fromSockAddr (SockAddrInet6 _ _ h _) = Just (fromHostAddress6 h)
163 fromSockAddr _ = Nothing
164
165-- | Note that port is zeroed.
166instance Address IP where
167 toSockAddr (IPv4 h) = toSockAddr h
168 toSockAddr (IPv6 h) = toSockAddr h
169 fromSockAddr sa =
170 IPv4 <$> fromSockAddr sa
171 <|> IPv6 <$> fromSockAddr sa
172
173setPort :: PortNumber -> SockAddr -> SockAddr 139setPort :: PortNumber -> SockAddr -> SockAddr
174setPort port (SockAddrInet _ h ) = SockAddrInet port h 140setPort port (SockAddrInet _ h ) = SockAddrInet port h
175setPort port (SockAddrInet6 _ f h s) = SockAddrInet6 port f h s 141setPort port (SockAddrInet6 _ f h s) = SockAddrInet6 port f h s
@@ -388,21 +354,6 @@ instance BEncode PortNumber where
388 = pure $ fromIntegral n 354 = pure $ fromIntegral n
389 | otherwise = decodingError $ "PortNumber: " ++ show n 355 | otherwise = decodingError $ "PortNumber: " ++ show n
390#endif 356#endif
391
392instance Serialize PortNumber where
393 get = fromIntegral <$> getWord16be
394 {-# INLINE get #-}
395 put = putWord16be . fromIntegral
396 {-# INLINE put #-}
397
398instance Hashable PortNumber where
399 hashWithSalt s = hashWithSalt s . fromEnum
400 {-# INLINE hashWithSalt #-}
401
402instance Pretty PortNumber where
403 pPrint = PP.int . fromEnum
404 {-# INLINE pPrint #-}
405
406{----------------------------------------------------------------------- 357{-----------------------------------------------------------------------
407-- IP addr 358-- IP addr
408-----------------------------------------------------------------------} 359-----------------------------------------------------------------------}
@@ -457,51 +408,6 @@ instance BEncode IPv6 where
457 {-# INLINE fromBEncode #-} 408 {-# INLINE fromBEncode #-}
458#endif 409#endif
459 410
460-- | When 'get'ing an IP it must be 'isolate'd to the appropriate
461-- number of bytes since we have no other way of telling which
462-- address type we are trying to parse
463instance Serialize IP where
464 put (IPv4 ip) = put ip
465 put (IPv6 ip) = put ip
466
467 get = do
468 n <- remaining
469 case n of
470 4 -> IPv4 <$> get
471 16 -> IPv6 <$> get
472 _ -> fail (show n ++ " is the wrong number of remaining bytes to parse IP")
473
474instance Serialize IPv4 where
475 put = putWord32host . toHostAddress
476 get = fromHostAddress <$> getWord32host
477
478instance Serialize IPv6 where
479 put ip = put $ toHostAddress6 ip
480 get = fromHostAddress6 <$> get
481
482instance Pretty IPv4 where
483 pPrint = PP.text . show
484 {-# INLINE pPrint #-}
485
486instance Pretty IPv6 where
487 pPrint = PP.text . show
488 {-# INLINE pPrint #-}
489
490instance Pretty IP where
491 pPrint = PP.text . show
492 {-# INLINE pPrint #-}
493
494instance Hashable IPv4 where
495 hashWithSalt = hashUsing toHostAddress
496 {-# INLINE hashWithSalt #-}
497
498instance Hashable IPv6 where
499 hashWithSalt s a = hashWithSalt s (toHostAddress6 a)
500
501instance Hashable IP where
502 hashWithSalt s (IPv4 h) = hashWithSalt s h
503 hashWithSalt s (IPv6 h) = hashWithSalt s h
504
505{----------------------------------------------------------------------- 411{-----------------------------------------------------------------------
506-- Peer addr 412-- Peer addr
507-----------------------------------------------------------------------} 413-----------------------------------------------------------------------}
@@ -666,13 +572,6 @@ testIdBit :: FiniteBits bs => bs -> Word -> Bool
666testIdBit bs i = testBit bs (fromIntegral (finiteBitSize bs - fromIntegral i)) 572testIdBit bs i = testBit bs (fromIntegral (finiteBitSize bs - fromIntegral i))
667{-# INLINE testIdBit #-} 573{-# INLINE testIdBit #-}
668 574
669-- TODO WARN is the 'system' random suitable for this?
670-- | Generate random NodeID used for the entire session.
671-- Distribution of ID's should be as uniform as possible.
672--
673genNodeId :: IO NodeId
674genNodeId = NodeId . either error id . S.decode <$> getEntropy nodeIdSize
675
676------------------------------------------------------------------------ 575------------------------------------------------------------------------
677 576
678-- | Accepts a depth/index of a bucket and whether or not it is the last one, 577-- | Accepts a depth/index of a bucket and whether or not it is the last one,
@@ -693,54 +592,8 @@ bucketRange depth is_last = (q,m,b)
693 m = 2^(7-r) - 1 592 m = 2^(7-r) - 1
694 b = if is_last then 0 else 2^(7-r) 593 b = if is_last then 0 else 2^(7-r)
695 594
696-- | Generate a random 'NodeId' within a range suitable for a bucket. To
697-- obtain a sample for bucket number /index/ where /is_last/ indicates if this
698-- is for the current deepest bucket in our routing table:
699--
700-- > sample <- genBucketSample nid (bucketRange index is_last)
701genBucketSample :: NodeId -> (Int,Word8,Word8) -> IO NodeId
702genBucketSample n qmb = genBucketSample' getEntropy n qmb
703
704-- | Generalizion of 'genBucketSample' that accepts a byte generator
705-- function to use instead of the system entropy.
706genBucketSample' :: Applicative m =>
707 (Int -> m ByteString) -> NodeId -> (Int,Word8,Word8) -> m NodeId
708genBucketSample' gen (NodeId self) (q,m,b)
709 | q <= 0 = NodeId . either error id . S.decode <$> gen nodeIdSize
710 | q >= nodeIdSize = pure (NodeId self)
711 | otherwise = NodeId . either error id . S.decode . build <$> gen (nodeIdSize - q + 1)
712 where
713 build tl = BS.init hd <> BS.cons (h .|. t) (BS.tail tl)
714 where
715 hd = BS.take q $ S.encode self
716 h = xor b (complement m .&. BS.last hd)
717 t = m .&. BS.head tl
718
719------------------------------------------------------------------------ 595------------------------------------------------------------------------
720 596
721data NodeAddr a = NodeAddr
722 { nodeHost :: !a
723 , nodePort :: {-# UNPACK #-} !PortNumber
724 } deriving (Eq, Ord, Typeable, Functor, Foldable, Traversable)
725
726instance Show a => Show (NodeAddr a) where
727 showsPrec i NodeAddr {..}
728 = showsPrec i nodeHost <> showString ":" <> showsPrec i nodePort
729
730instance Read (NodeAddr IPv4) where
731 readsPrec i x = [ (fromPeerAddr a, s) | (a, s) <- readsPrec i x ]
732
733-- | @127.0.0.1:6882@
734instance Default (NodeAddr IPv4) where
735 def = "127.0.0.1:6882"
736
737-- | KRPC compatible encoding.
738instance Serialize a => Serialize (NodeAddr a) where
739 get = NodeAddr <$> get <*> get
740 {-# INLINE get #-}
741 put NodeAddr {..} = put nodeHost >> put nodePort
742 {-# INLINE put #-}
743
744#ifdef VERSION_bencoding 597#ifdef VERSION_bencoding
745-- | Torrent file compatible encoding. 598-- | Torrent file compatible encoding.
746instance BEncode a => BEncode (NodeAddr a) where 599instance BEncode a => BEncode (NodeAddr a) where
@@ -750,20 +603,6 @@ instance BEncode a => BEncode (NodeAddr a) where
750 {-# INLINE fromBEncode #-} 603 {-# INLINE fromBEncode #-}
751#endif 604#endif
752 605
753instance Hashable a => Hashable (NodeAddr a) where
754 hashWithSalt s NodeAddr {..} = hashWithSalt s (nodeHost, nodePort)
755 {-# INLINE hashWithSalt #-}
756
757instance Pretty ip => Pretty (NodeAddr ip) where
758 pPrint NodeAddr {..} = pPrint nodeHost <> ":" <> pPrint nodePort
759
760-- | Example:
761--
762-- @nodePort \"127.0.0.1:6881\" == 6881@
763--
764instance IsString (NodeAddr IPv4) where
765 fromString = fromPeerAddr . fromString
766
767fromPeerAddr :: PeerAddr a -> NodeAddr a 606fromPeerAddr :: PeerAddr a -> NodeAddr a
768fromPeerAddr PeerAddr {..} = NodeAddr 607fromPeerAddr PeerAddr {..} = NodeAddr
769 { nodeHost = peerHost 608 { nodeHost = peerHost
@@ -772,45 +611,10 @@ fromPeerAddr PeerAddr {..} = NodeAddr
772 611
773------------------------------------------------------------------------ 612------------------------------------------------------------------------
774 613
775data NodeInfo dht addr u = NodeInfo
776 { nodeId :: !(RPC.NodeId dht)
777 , nodeAddr :: !(NodeAddr addr)
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)
784
785mapAddress :: (addr -> b) -> NodeInfo dht addr u -> NodeInfo dht b u
786mapAddress f ni = ni { nodeAddr = fmap f (nodeAddr ni) }
787
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
796 compare = comparing nodeId
797
798-- | KRPC 'compact list' compatible encoding: contact information for
799-- nodes is encoded as a 26-byte string. Also known as "Compact node
800-- info" the 20-byte Node ID in network byte order has the compact
801-- IP-address/port info concatenated to the end.
802instance Serialize a => Serialize (NodeInfo KMessageOf a ()) where
803 get = (\a b -> NodeInfo a b ()) <$> get <*> get
804 put NodeInfo {..} = put nodeId >> put nodeAddr
805
806instance Pretty ip => Pretty (NodeInfo KMessageOf ip ()) where
807 pPrint NodeInfo {..} = pPrint nodeId <> "@(" <> pPrint nodeAddr <> ")"
808
809instance Pretty ip => Pretty [NodeInfo KMessageOf ip ()] where
810 pPrint = PP.vcat . PP.punctuate "," . L.map pPrint
811
812-- | Order by closeness: nearest nodes first. 614-- | Order by closeness: nearest nodes first.
813rank :: (x -> NodeId) -> NodeId -> [x] -> [x] 615rank :: ( Ord (NodeId dht)
616 , Bits (NodeId dht)
617 ) => (x -> NodeId dht) -> NodeId dht -> [x] -> [x]
814rank f nid = L.sortBy (comparing (RPC.distance nid . f)) 618rank f nid = L.sortBy (comparing (RPC.distance nid . f))
815 619
816{----------------------------------------------------------------------- 620{-----------------------------------------------------------------------
@@ -1219,40 +1023,6 @@ fingerprint pid = either (const def) id $ runGet getCI (getPeerId pid)
1219 return $ Version (catMaybes $ L.map decodeShadowVerNr str) [] 1023 return $ Version (catMaybes $ L.map decodeShadowVerNr str) []
1220 1024
1221 1025
1222-- | Yields all 8 DHT neighborhoods available to you given a particular ip
1223-- address.
1224bep42s :: Address a => a -> NodeId -> [NodeId]
1225bep42s addr (NodeId r) = mapMaybe (bep42 addr) rs
1226 where
1227 rs = L.map (NodeId . change3bits r) [0..7]
1228
1229-- change3bits :: ByteString -> Word8 -> ByteString
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
1234
1235-- | Modifies a purely random 'NodeId' to one that is related to a given
1236-- routable address in accordance with BEP 42.
1237bep42 :: Address a => a -> NodeId -> Maybe NodeId
1238bep42 addr (NodeId r)
1239 | Just ip <- fmap S.encode (fromAddr addr :: Maybe IPv4)
1240 <|> fmap S.encode (fromAddr addr :: Maybe IPv6)
1241 = genBucketSample' retr (NodeId $ crc $ applyMask ip) (3,0x07,0)
1242 | otherwise
1243 = Nothing
1244 where
1245 ip4mask = "\x03\x0f\x3f\xff" :: ByteString
1246 ip6mask = "\x01\x03\x07\x0f\x1f\x3f\x7f\xff" :: ByteString
1247 nbhood_select = (fromIntegral r :: Word8) .&. 7
1248 retr n = pure $ BS.drop (nodeIdSize - n) $ S.encode r
1249 crc = flip shiftL (finiteBitSize (NodeId undefined) - 32) . fromIntegral . crc32c . BS.pack
1250 applyMask ip = case BS.zipWith (.&.) msk ip of
1251 (b:bs) -> (b .|. shiftL nbhood_select 5) : bs
1252 bs -> bs
1253 where msk | BS.length ip == 4 = ip4mask
1254 | otherwise = ip6mask
1255
1256 1026
1257-- | Given a string specifying a port (numeric or service name) 1027-- | Given a string specifying a port (numeric or service name)
1258-- and a flag indicating whether you want to support IPv6, this 1028-- and a flag indicating whether you want to support IPv6, this
diff --git a/src/Network/BitTorrent/DHT/Message.hs b/src/Network/BitTorrent/DHT/Message.hs
index c3df683a..c99c72bb 100644
--- a/src/Network/BitTorrent/DHT/Message.hs
+++ b/src/Network/BitTorrent/DHT/Message.hs
@@ -113,8 +113,10 @@ import Data.Maybe
113 113
114import Data.Torrent (InfoHash) 114import Data.Torrent (InfoHash)
115import Network.BitTorrent.DHT.Token 115import Network.BitTorrent.DHT.Token
116#ifdef VERSION_bencoding
116import Network.KRPC () 117import Network.KRPC ()
117import Network.DHT.Mainline () 118import Network.DHT.Mainline ()
119#endif
118import Network.RPC hiding (Query,Response) 120import Network.RPC hiding (Query,Response)
119 121
120{----------------------------------------------------------------------- 122{-----------------------------------------------------------------------
@@ -237,7 +239,7 @@ instance KRPC (Query Ping) (Response Ping) where
237#ifdef VERSION_bencoding 239#ifdef VERSION_bencoding
238newtype FindNode ip = FindNode (NodeId KMessageOf) 240newtype FindNode ip = FindNode (NodeId KMessageOf)
239#else 241#else
240data FindNode ip = FindNode NodeId Tox.Nonce8 -- Tox: Get Nodes 242data FindNode ip = FindNode (NodeId Tox.Message) Tox.Nonce8 -- Tox: Get Nodes
241#endif 243#endif
242 deriving (Show, Eq, Typeable) 244 deriving (Show, Eq, Typeable)
243 245
diff --git a/src/Network/BitTorrent/DHT/Query.hs b/src/Network/BitTorrent/DHT/Query.hs
index 4b386cdc..56ea262a 100644
--- a/src/Network/BitTorrent/DHT/Query.hs
+++ b/src/Network/BitTorrent/DHT/Query.hs
@@ -14,6 +14,7 @@
14{-# LANGUAGE ScopedTypeVariables #-} 14{-# LANGUAGE ScopedTypeVariables #-}
15{-# LANGUAGE TemplateHaskell #-} 15{-# LANGUAGE TemplateHaskell #-}
16{-# LANGUAGE TupleSections #-} 16{-# LANGUAGE TupleSections #-}
17{-# LANGUAGE PartialTypeSignatures #-}
17{-# LANGUAGE GADTs #-} 18{-# LANGUAGE GADTs #-}
18module Network.BitTorrent.DHT.Query 19module Network.BitTorrent.DHT.Query
19 ( -- * Handler 20 ( -- * Handler
@@ -322,7 +323,7 @@ insertNode info witnessed_ip0 = do
322 let logMsg = "Routing table: " <> pPrint t 323 let logMsg = "Routing table: " <> pPrint t
323 $(logDebugS) "insertNode" (T.pack (render logMsg)) 324 $(logDebugS) "insertNode" (T.pack (render logMsg))
324 let arrival0 = TryInsert info 325 let arrival0 = TryInsert info
325 arrival4 = TryInsert (mapAddress fromAddr info) :: Event (Maybe IPv4) 326 arrival4 = TryInsert (mapAddress fromAddr info) :: Event _ (Maybe IPv4) _
326 $(logDebugS) "insertNode" $ T.pack (show arrival4) 327 $(logDebugS) "insertNode" $ T.pack (show arrival4)
327 maxbuckets <- asks (optBucketCount . options) 328 maxbuckets <- asks (optBucketCount . options)
328 fallbackid <- asks tentativeNodeId 329 fallbackid <- asks tentativeNodeId
diff --git a/src/Network/BitTorrent/DHT/Routing.hs b/src/Network/BitTorrent/DHT/Routing.hs
index 6cf7f122..42728a53 100644
--- a/src/Network/BitTorrent/DHT/Routing.hs
+++ b/src/Network/BitTorrent/DHT/Routing.hs
@@ -13,12 +13,14 @@
13-- For more info see: 13-- For more info see:
14-- <http://www.bittorrent.org/beps/bep_0005.html#routing-table> 14-- <http://www.bittorrent.org/beps/bep_0005.html#routing-table>
15-- 15--
16{-# LANGUAGE CPP #-}
16{-# LANGUAGE RecordWildCards #-} 17{-# LANGUAGE RecordWildCards #-}
17{-# LANGUAGE BangPatterns #-} 18{-# LANGUAGE BangPatterns #-}
18{-# LANGUAGE ViewPatterns #-} 19{-# LANGUAGE ViewPatterns #-}
19{-# LANGUAGE TypeOperators #-} 20{-# LANGUAGE TypeOperators #-}
20{-# LANGUAGE DeriveGeneric #-} 21{-# LANGUAGE DeriveGeneric #-}
21{-# LANGUAGE ScopedTypeVariables #-} 22{-# LANGUAGE ScopedTypeVariables #-}
23{-# LANGUAGE StandaloneDeriving, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances #-}
22{-# OPTIONS_GHC -fno-warn-orphans #-} 24{-# OPTIONS_GHC -fno-warn-orphans #-}
23module Network.BitTorrent.DHT.Routing 25module Network.BitTorrent.DHT.Routing
24 ( -- * Table 26 ( -- * Table
@@ -59,8 +61,6 @@ module Network.BitTorrent.DHT.Routing
59 61
60 -- * Routing 62 -- * Routing
61 , Timestamp 63 , Timestamp
62 , Routing
63 , runRouting
64 ) where 64 ) where
65 65
66import Control.Applicative as A 66import Control.Applicative as A
@@ -83,10 +83,16 @@ 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)
87import Data.Torrent 86import Data.Torrent
88import Network.BitTorrent.Address 87import Network.BitTorrent.Address
89import Network.DHT.Mainline 88#ifdef VERSION_bencoding
89import Network.DHT.Mainline ()
90import Network.KRPC.Message (KMessageOf)
91#else
92import Data.Tox as Tox
93type KMessageOf = Tox.Message
94#endif
95
90 96
91{----------------------------------------------------------------------- 97{-----------------------------------------------------------------------
92-- Routing monad 98-- Routing monad
@@ -109,66 +115,6 @@ import Network.DHT.Mainline
109-- 115--
110type Timestamp = POSIXTime 116type Timestamp = POSIXTime
111 117
112-- | Some routing operations might need to perform additional IO.
113data Routing ip result
114 = Full
115 | Done result
116 | GetTime ( Timestamp -> Routing ip result)
117 | NeedPing (NodeAddr ip) ( Bool -> Routing ip result)
118 | Refresh NodeId (Routing ip result)
119
120instance Functor (Routing ip) where
121 fmap _ Full = Full
122 fmap f (Done r) = Done ( f r)
123 fmap f (GetTime g) = GetTime (fmap f . g)
124 fmap f (NeedPing addr g) = NeedPing addr (fmap f . g)
125 fmap f (Refresh nid g) = Refresh nid (fmap f g)
126
127instance Monad (Routing ip) where
128 return = Done
129
130 Full >>= _ = Full
131 Done r >>= m = m r
132 GetTime f >>= m = GetTime $ \ t -> f t >>= m
133 NeedPing a f >>= m = NeedPing a $ \ p -> f p >>= m
134 Refresh n f >>= m = Refresh n $ f >>= m
135
136instance Applicative (Routing ip) where
137 pure = return
138 (<*>) = ap
139
140instance Alternative (Routing ip) where
141 empty = Full
142
143 Full <|> m = m
144 Done a <|> _ = Done a
145 GetTime f <|> m = GetTime $ \ t -> f t <|> m
146 NeedPing a f <|> m = NeedPing a $ \ p -> f p <|> m
147 Refresh n f <|> m = Refresh n (f <|> m)
148
149-- | Run routing table operation.
150runRouting :: Monad m
151 => (NodeAddr ip -> m Bool) -- ^ ping the specific node;
152 -> (NodeId -> m ()) -- ^ refresh nodes;
153 -> m Timestamp -- ^ get current time;
154 -> Routing ip f -- ^ operation to run;
155 -> m (Maybe f) -- ^ operation result;
156runRouting ping_node find_nodes timestamper = go
157 where
158 go Full = return (Nothing)
159 go (Done r) = return (Just r)
160 go (GetTime f) = do
161 t <- timestamper
162 go (f t)
163
164 go (NeedPing addr f) = do
165 pong <- ping_node addr
166 go (f pong)
167
168 go (Refresh nid f) = do
169 find_nodes nid
170 go f
171
172{----------------------------------------------------------------------- 118{-----------------------------------------------------------------------
173 Bucket 119 Bucket
174-----------------------------------------------------------------------} 120-----------------------------------------------------------------------}
@@ -182,7 +128,7 @@ runRouting ping_node find_nodes timestamper = go
182-- other words: new nodes are used only when older nodes disappear. 128-- other words: new nodes are used only when older nodes disappear.
183 129
184-- | Timestamp - last time this node is pinged. 130-- | Timestamp - last time this node is pinged.
185type NodeEntry ip = Binding (NodeInfo KMessageOf ip ()) Timestamp 131type NodeEntry dht ip u = Binding (NodeInfo dht ip u) Timestamp
186 132
187-- TODO instance Pretty where 133-- TODO instance Pretty where
188 134
@@ -213,7 +159,7 @@ fromQ embed project QueueMethods{..} =
213 } 159 }
214-} 160-}
215 161
216seqQ :: QueueMethods Identity (NodeInfo KMessageOf ip ()) (Seq.Seq (NodeInfo KMessageOf ip ())) 162seqQ :: QueueMethods Identity (NodeInfo dht ip u) (Seq.Seq (NodeInfo dht ip u))
217seqQ = QueueMethods 163seqQ = QueueMethods
218 { pushBack = \e fifo -> pure (fifo Seq.|> e) 164 { pushBack = \e fifo -> pure (fifo Seq.|> e)
219 , popFront = \fifo -> case Seq.viewl fifo of 165 , popFront = \fifo -> case Seq.viewl fifo of
@@ -222,9 +168,9 @@ seqQ = QueueMethods
222 , emptyQueue = pure Seq.empty 168 , emptyQueue = pure Seq.empty
223 } 169 }
224 170
225type BucketQueue ip = Seq.Seq (NodeInfo KMessageOf ip ()) 171type BucketQueue dht ip u = Seq.Seq (NodeInfo dht ip u)
226 172
227bucketQ :: QueueMethods Identity (NodeInfo KMessageOf ip ()) (BucketQueue ip) 173bucketQ :: QueueMethods Identity (NodeInfo dht ip u) (BucketQueue dht ip u)
228bucketQ = seqQ 174bucketQ = seqQ
229 175
230-- | Bucket is also limited in its length — thus it's called k-bucket. 176-- | Bucket is also limited in its length — thus it's called k-bucket.
@@ -234,16 +180,45 @@ bucketQ = seqQ
234-- very unlikely that all nodes in bucket fail within an hour of 180-- very unlikely that all nodes in bucket fail within an hour of
235-- each other. 181-- each other.
236-- 182--
237data Bucket ip = Bucket { bktNodes :: !(PSQ (NodeInfo KMessageOf ip ()) Timestamp) 183data Bucket dht ip u = Bucket { bktNodes :: !(PSQ (NodeInfo dht ip u) Timestamp)
238 , bktQ :: !(BucketQueue ip) 184 , bktQ :: !(BucketQueue dht ip u)
239 } deriving (Show,Generic) 185 } deriving Generic
240 186
241instance (Eq ip, Serialize ip) => Serialize (Bucket ip) where 187deriving instance (Show ip, Show u, Show (NodeId dht)) => Show (Bucket dht ip u)
242 get = Bucket . psqFromPairList <$> get <*> pure (runIdentity $ emptyQueue bucketQ) 188
243 put = put . psqToPairList . bktNodes 189
244 190getGenericNode :: ( Serialize (NodeId dht)
191 , Serialize ip
192 , Serialize u
193 ) => Get (NodeInfo dht ip u)
194getGenericNode = do
195 nid <- get
196 naddr <- get
197 u <- get
198 return NodeInfo
199 { nodeId = nid
200 , nodeAddr = naddr
201 , nodeAnnotation = u
202 }
203
204putGenericNode :: ( Serialize (NodeId dht)
205 , Serialize ip
206 , Serialize u
207 ) => NodeInfo dht ip u -> Put
208putGenericNode (NodeInfo nid naddr u) = do
209 put nid
210 put naddr
211 put u
212
213instance (Eq ip, Ord (NodeId dht), Serialize (NodeId dht), Serialize ip, Serialize u) => Serialize (Bucket dht ip u) where
214 get = Bucket . psqFromPairList <$> getListOf ( (,) <$> getGenericNode <*> get ) <*> pure (runIdentity $ emptyQueue bucketQ)
215 put = putListOf (\(ni,stamp) -> putGenericNode ni >> put stamp) . psqToPairList . bktNodes
216
217
218psqFromPairList :: (Ord p, Ord k) => [(k, p)] -> OrdPSQ k p ()
245psqFromPairList xs = PSQ.fromList $ map (\(a,b) -> a :-> b) xs 219psqFromPairList xs = PSQ.fromList $ map (\(a,b) -> a :-> b) xs
246 220
221psqToPairList :: OrdPSQ t t1 () -> [(t, t1)]
247psqToPairList psq = map (\(a :-> b) -> (a,b)) $ PSQ.toList psq 222psqToPairList psq = map (\(a :-> b) -> (a,b)) $ PSQ.toList psq
248 223
249-- | Update interval, in seconds. 224-- | Update interval, in seconds.
@@ -253,8 +228,8 @@ delta = 15 * 60
253-- | Should maintain a set of stable long running nodes. 228-- | Should maintain a set of stable long running nodes.
254-- 229--
255-- Note: pings are triggerd only when a bucket is full. 230-- Note: pings are triggerd only when a bucket is full.
256insertBucket :: (Eq ip, Alternative f) => Timestamp -> Event ip -> Bucket ip 231insertBucket :: (Eq ip, Alternative f, Ord (NodeId dht)) => Timestamp -> Event dht ip u -> Bucket dht ip u
257 -> f ([CheckPing ip], Bucket ip) 232 -> f ([CheckPing dht ip u], Bucket dht ip u)
258insertBucket curTime (TryInsert info) bucket 233insertBucket curTime (TryInsert info) bucket
259 -- just update timestamp if a node is already in bucket 234 -- just update timestamp if a node is already in bucket
260 | already_have 235 | already_have
@@ -305,7 +280,9 @@ insertBucket curTime (PingResult bad_node got_response) bucket
305 pure $ PSQ.insert info curTime nodes' 280 pure $ PSQ.insert info curTime nodes'
306 | otherwise = id 281 | otherwise = id
307 282
308updateStamps :: Eq ip => Timestamp -> [NodeInfo KMessageOf ip ()] -> PSQ (NodeInfo KMessageOf ip ()) Timestamp -> PSQ (NodeInfo KMessageOf ip ()) Timestamp 283updateStamps :: ( Eq ip
284 , Ord (NodeId dht)
285 ) => Timestamp -> [NodeInfo dht ip u] -> PSQ (NodeInfo dht ip u) Timestamp -> PSQ (NodeInfo dht ip u) Timestamp
309updateStamps curTime stales nodes = foldl' (\q n -> PSQ.insert n curTime q) nodes stales 286updateStamps curTime stales nodes = foldl' (\q n -> PSQ.insert n curTime q) nodes stales
310 287
311 288
@@ -327,7 +304,11 @@ partitionQ imp test q0 = do
327 select f = if test e then \(a,b) -> flip (,) b <$> f a 304 select f = if test e then \(a,b) -> flip (,) b <$> f a
328 else \(a,b) -> (,) a <$> f b 305 else \(a,b) -> (,) a <$> f b
329 306
330split :: Eq ip => BitIx -> Bucket ip -> (Bucket ip, Bucket ip) 307split :: forall dht ip u.
308 ( Eq ip
309 , Ord (NodeId dht)
310 , FiniteBits (NodeId dht)
311 ) => BitIx -> Bucket dht ip u -> (Bucket dht ip u, Bucket dht ip u)
331split i b = (Bucket ns qs, Bucket ms rs) 312split i b = (Bucket ns qs, Bucket ms rs)
332 where 313 where
333 (ns,ms) = (PSQ.fromList *** PSQ.fromList) . partition (spanBit . key) . PSQ.toList $ bktNodes b 314 (ns,ms) = (PSQ.fromList *** PSQ.fromList) . partition (spanBit . key) . PSQ.toList $ bktNodes b
@@ -337,7 +318,7 @@ split i b = (Bucket ns qs, Bucket ms rs)
337 FiniteBits (Network.RPC.NodeId dht) => 318 FiniteBits (Network.RPC.NodeId dht) =>
338 NodeInfo dht addr u -> Bool 319 NodeInfo dht addr u -> Bool
339 -} 320 -}
340 spanBit :: NodeInfo KMessageOf addr () -> Bool 321 spanBit :: NodeInfo dht addr u -> Bool
341 spanBit entry = testIdBit (nodeId entry) i 322 spanBit entry = testIdBit (nodeId entry) i
342 323
343{----------------------------------------------------------------------- 324{-----------------------------------------------------------------------
@@ -350,12 +331,15 @@ type BucketCount = Int
350defaultBucketCount :: BucketCount 331defaultBucketCount :: BucketCount
351defaultBucketCount = 20 332defaultBucketCount = 20
352 333
353data Info ip = Info 334data Info dht ip u = Info
354 { myBuckets :: Table ip 335 { myBuckets :: Table dht ip u
355 , myNodeId :: NodeId 336 , myNodeId :: NodeId dht
356 , myAddress :: SockAddr 337 , myAddress :: SockAddr
357 } 338 }
358 deriving (Eq, Show, Generic) 339 deriving Generic
340
341deriving instance (Eq ip, Eq u, Eq (NodeId dht)) => Eq (Info dht ip u)
342deriving instance (Show ip, Show u, Show (NodeId dht)) => Show (Info dht ip u)
359 343
360-- instance (Eq ip, Serialize ip) => Serialize (Info ip) 344-- instance (Eq ip, Serialize ip) => Serialize (Info ip)
361 345
@@ -375,31 +359,33 @@ data Info ip = Info
375-- is always split into two new buckets covering the ranges @0..2 ^ 359-- is always split into two new buckets covering the ranges @0..2 ^
376-- 159@ and @2 ^ 159..2 ^ 160@. 360-- 159@ and @2 ^ 159..2 ^ 160@.
377-- 361--
378data Table ip 362data Table dht ip u
379 -- most nearest bucket 363 -- most nearest bucket
380 = Tip NodeId BucketCount (Bucket ip) 364 = Tip (NodeId dht) BucketCount (Bucket dht ip u)
381 365
382 -- left biased tree branch 366 -- left biased tree branch
383 | Zero (Table ip) (Bucket ip) 367 | Zero (Table dht ip u) (Bucket dht ip u)
384 368
385 -- right biased tree branch 369 -- right biased tree branch
386 | One (Bucket ip) (Table ip) 370 | One (Bucket dht ip u) (Table dht ip u)
387 deriving (Show, Generic) 371 deriving Generic
388 372
389instance Eq ip => Eq (Table ip) where 373instance (Eq ip, Eq (NodeId dht)) => Eq (Table dht ip u) where
390 (==) = (==) `on` Network.BitTorrent.DHT.Routing.toList 374 (==) = (==) `on` Network.BitTorrent.DHT.Routing.toList
391 375
392instance Serialize NominalDiffTime where 376instance Serialize NominalDiffTime where
393 put = putWord32be . fromIntegral . fromEnum 377 put = putWord32be . fromIntegral . fromEnum
394 get = (toEnum . fromIntegral) <$> getWord32be 378 get = (toEnum . fromIntegral) <$> getWord32be
395 379
380deriving instance (Show ip, Show u, Show (NodeId dht)) => Show (Table dht ip u)
381
396-- | Normally, routing table should be saved between invocations of 382-- | Normally, routing table should be saved between invocations of
397-- the client software. Note that you don't need to store /this/ 383-- the client software. Note that you don't need to store /this/
398-- 'NodeId' since it is already included in routing table. 384-- 'NodeId' since it is already included in routing table.
399instance (Eq ip, Serialize ip) => Serialize (Table ip) 385instance (Eq ip, Serialize ip, Ord (NodeId dht), Serialize (NodeId dht), Serialize u) => Serialize (Table dht ip u)
400 386
401-- | Shape of the table. 387-- | Shape of the table.
402instance Pretty (Table ip) where 388instance Pretty (Table dht ip u) where
403 pPrint t 389 pPrint t
404 | bucketCount < 6 = hcat $ punctuate ", " $ L.map PP.int ss 390 | bucketCount < 6 = hcat $ punctuate ", " $ L.map PP.int ss
405 | otherwise = brackets $ 391 | otherwise = brackets $
@@ -410,26 +396,26 @@ instance Pretty (Table ip) where
410 ss = shape t 396 ss = shape t
411 397
412-- | Empty table with specified /spine/ node id. 398-- | Empty table with specified /spine/ node id.
413nullTable :: Eq ip => NodeId -> BucketCount -> Table ip 399nullTable :: Eq ip => NodeId dht -> BucketCount -> Table dht ip u
414nullTable nid n = Tip nid (bucketCount (pred n)) (Bucket PSQ.empty (runIdentity $ emptyQueue bucketQ)) 400nullTable nid n = Tip nid (bucketCount (pred n)) (Bucket PSQ.empty (runIdentity $ emptyQueue bucketQ))
415 where 401 where
416 bucketCount x = max 0 (min 159 x) 402 bucketCount x = max 0 (min 159 x)
417 403
418-- | Test if table is empty. In this case DHT should start 404-- | Test if table is empty. In this case DHT should start
419-- bootstrapping process until table becomes 'full'. 405-- bootstrapping process until table becomes 'full'.
420null :: Table ip -> Bool 406null :: Table dht ip u -> Bool
421null (Tip _ _ b) = PSQ.null $ bktNodes b 407null (Tip _ _ b) = PSQ.null $ bktNodes b
422null _ = False 408null _ = False
423 409
424-- | Test if table have maximum number of nodes. No more nodes can be 410-- | Test if table have maximum number of nodes. No more nodes can be
425-- 'insert'ed, except old ones becomes bad. 411-- 'insert'ed, except old ones becomes bad.
426full :: Table ip -> Bool 412full :: Table dht ip u -> Bool
427full (Tip _ n _) = n == 0 413full (Tip _ n _) = n == 0
428full (Zero t b) = PSQ.size (bktNodes b) == defaultBucketSize && full t 414full (Zero t b) = PSQ.size (bktNodes b) == defaultBucketSize && full t
429full (One b t) = PSQ.size (bktNodes b) == defaultBucketSize && full t 415full (One b t) = PSQ.size (bktNodes b) == defaultBucketSize && full t
430 416
431-- | Get the /spine/ node id. 417-- | Get the /spine/ node id.
432thisId :: Table ip -> NodeId 418thisId :: Table dht ip u -> NodeId dht
433thisId (Tip nid _ _) = nid 419thisId (Tip nid _ _) = nid
434thisId (Zero table _) = thisId table 420thisId (Zero table _) = thisId table
435thisId (One _ table) = thisId table 421thisId (One _ table) = thisId table
@@ -439,18 +425,19 @@ type NodeCount = Int
439 425
440-- | Internally, routing table is similar to list of buckets or a 426-- | Internally, routing table is similar to list of buckets or a
441-- /matrix/ of nodes. This function returns the shape of the matrix. 427-- /matrix/ of nodes. This function returns the shape of the matrix.
442shape :: Table ip -> [BucketSize] 428shape :: Table dht ip u -> [BucketSize]
443shape = map (PSQ.size . bktNodes) . toBucketList 429shape = map (PSQ.size . bktNodes) . toBucketList
444 430
445-- | Get number of nodes in the table. 431-- | Get number of nodes in the table.
446size :: Table ip -> NodeCount 432size :: Table dht ip u -> NodeCount
447size = L.sum . shape 433size = L.sum . shape
448 434
449-- | Get number of buckets in the table. 435-- | Get number of buckets in the table.
450depth :: Table ip -> BucketCount 436depth :: Table dht ip u -> BucketCount
451depth = L.length . shape 437depth = L.length . shape
452 438
453lookupBucket :: NodeId -> Table ip -> [Bucket ip] 439lookupBucket :: ( FiniteBits (NodeId dht)
440 ) => NodeId dht -> Table dht ip u -> [Bucket dht ip u]
454lookupBucket nid = go 0 [] 441lookupBucket nid = go 0 []
455 where 442 where
456 go i bs (Zero table bucket) 443 go i bs (Zero table bucket)
@@ -461,14 +448,18 @@ lookupBucket nid = go 0 []
461 | otherwise = bucket : toBucketList table ++ bs 448 | otherwise = bucket : toBucketList table ++ bs
462 go _ bs (Tip _ _ bucket) = bucket : bs 449 go _ bs (Tip _ _ bucket) = bucket : bs
463 450
464compatibleNodeId :: Table ip -> IO NodeId 451compatibleNodeId :: forall dht ip u.
452 ( Serialize (NodeId dht)
453 , FiniteBits (NodeId dht)
454 ) => Table dht ip u -> IO (NodeId dht)
465compatibleNodeId tbl = genBucketSample prefix br 455compatibleNodeId tbl = genBucketSample prefix br
466 where 456 where
467 br = bucketRange (L.length (shape tbl) - 1) True 457 br = bucketRange (L.length (shape tbl) - 1) True
458 nodeIdSize = finiteBitSize (undefined :: NodeId dht) `div` 8
468 bs = BS.pack $ take nodeIdSize $ tablePrefix tbl ++ repeat 0 459 bs = BS.pack $ take nodeIdSize $ tablePrefix tbl ++ repeat 0
469 prefix = either error id $ S.decode bs 460 prefix = either error id $ S.decode bs
470 461
471tablePrefix :: Table ip -> [Word8] 462tablePrefix :: Table dht ip u -> [Word8]
472tablePrefix = map (packByte . take 8 . (++repeat False)) 463tablePrefix = map (packByte . take 8 . (++repeat False))
473 . chunksOf 8 464 . chunksOf 8
474 . tableBits 465 . tableBits
@@ -477,7 +468,7 @@ tablePrefix = map (packByte . take 8 . (++repeat False))
477 bitmask ix True = bit ix 468 bitmask ix True = bit ix
478 bitmask _ _ = 0 469 bitmask _ _ = 0
479 470
480tableBits :: Table ip -> [Bool] 471tableBits :: Table dht ip u -> [Bool]
481tableBits (One _ tbl) = True : tableBits tbl 472tableBits (One _ tbl) = True : tableBits tbl
482tableBits (Zero tbl _) = False : tableBits tbl 473tableBits (Zero tbl _) = False : tableBits tbl
483tableBits (Tip _ _ _) = [] 474tableBits (Tip _ _ _) = []
@@ -498,20 +489,23 @@ type K = Int
498defaultK :: K 489defaultK :: K
499defaultK = 8 490defaultK = 8
500 491
501class TableKey k where 492class TableKey dht k where
502 toNodeId :: k -> NodeId 493 toNodeId :: k -> NodeId dht
503 494
504instance TableKey NodeId where 495instance TableKey dht (NodeId dht) where
505 toNodeId = id 496 toNodeId = id
506 497
507instance TableKey InfoHash where 498instance TableKey KMessageOf InfoHash where
508 toNodeId = either (error msg) id . S.decode . S.encode 499 toNodeId = either (error msg) id . S.decode . S.encode
509 where -- TODO unsafe coerse? 500 where -- TODO unsafe coerse?
510 msg = "tableKey: impossible" 501 msg = "tableKey: impossible"
511 502
512-- | Get a list of /K/ closest nodes using XOR metric. Used in 503-- | Get a list of /K/ closest nodes using XOR metric. Used in
513-- 'find_node' and 'get_peers' queries. 504-- 'find_node' and 'get_peers' queries.
514kclosest :: Eq ip => TableKey a => K -> a -> Table ip -> [NodeInfo KMessageOf ip ()] 505kclosest :: ( Eq ip
506 , Ord (NodeId dht)
507 , FiniteBits (NodeId dht)
508 ) => TableKey dht a => K -> a -> Table dht ip u -> [NodeInfo dht ip u]
515kclosest k (toNodeId -> nid) tbl = take k $ rank nodeId nid (L.concat bucket) 509kclosest k (toNodeId -> nid) tbl = take k $ rank nodeId nid (L.concat bucket)
516 ++ rank nodeId nid (L.concat everyone) 510 ++ rank nodeId nid (L.concat everyone)
517 where 511 where
@@ -525,7 +519,10 @@ kclosest k (toNodeId -> nid) tbl = take k $ rank nodeId nid (L.concat bucket)
525-- Routing 519-- Routing
526-----------------------------------------------------------------------} 520-----------------------------------------------------------------------}
527 521
528splitTip :: Eq ip => NodeId -> BucketCount -> BitIx -> Bucket ip -> Table ip 522splitTip :: ( Eq ip
523 , Ord (NodeId dht)
524 , FiniteBits (NodeId dht)
525 ) => NodeId dht -> BucketCount -> BitIx -> Bucket dht ip u -> Table dht ip u
529splitTip nid n i bucket 526splitTip nid n i bucket
530 | testIdBit nid i = (One zeros (Tip nid (pred n) ones)) 527 | testIdBit nid i = (One zeros (Tip nid (pred n) ones))
531 | otherwise = (Zero (Tip nid (pred n) zeros) ones) 528 | otherwise = (Zero (Tip nid (pred n) zeros) ones)
@@ -538,11 +535,15 @@ splitTip nid n i bucket
538-- k nodes in them. Which subtrees I mean is illustrated in Fig 1. of Kademlia 535-- k nodes in them. Which subtrees I mean is illustrated in Fig 1. of Kademlia
539-- paper. The rule requiring additional splits is in section 2.4. 536-- paper. The rule requiring additional splits is in section 2.4.
540modifyBucket 537modifyBucket
541 :: forall ip xs. (Eq ip) => 538 :: forall xs dht ip u.
542 NodeId -> (Bucket ip -> Maybe (xs, Bucket ip)) -> Table ip -> Maybe (xs,Table ip) 539 ( Eq ip
540 , Ord (NodeId dht)
541 , FiniteBits (NodeId dht)
542 ) =>
543 NodeId dht -> (Bucket dht ip u -> Maybe (xs, Bucket dht ip u)) -> Table dht ip u -> Maybe (xs,Table dht ip u)
543modifyBucket nodeId f = go (0 :: BitIx) 544modifyBucket nodeId f = go (0 :: BitIx)
544 where 545 where
545 go :: BitIx -> Table ip -> Maybe (xs, Table ip) 546 go :: BitIx -> Table dht ip u -> Maybe (xs, Table dht ip u)
546 go !i (Zero table bucket) 547 go !i (Zero table bucket)
547 | testIdBit nodeId i = second (Zero table) <$> f bucket 548 | testIdBit nodeId i = second (Zero table) <$> f bucket
548 | otherwise = second (`Zero` bucket) <$> go (succ i) table 549 | otherwise = second (`Zero` bucket) <$> go (succ i) table
@@ -555,23 +556,36 @@ modifyBucket nodeId f = go (0 :: BitIx)
555 <|> go i (splitTip nid n i bucket) 556 <|> go i (splitTip nid n i bucket)
556 557
557-- | Triggering event for atomic table update 558-- | Triggering event for atomic table update
558data Event ip = TryInsert { foreignNode :: NodeInfo KMessageOf ip () } 559data Event dht ip u = TryInsert { foreignNode :: NodeInfo dht ip u }
559 | PingResult { foreignNode :: NodeInfo KMessageOf ip () 560 | PingResult { foreignNode :: NodeInfo dht ip u
560 , ponged :: Bool 561 , ponged :: Bool
561 } 562 }
562 deriving (Eq,Show) -- Ord 563deriving instance Eq (NodeId dht) => Eq (Event dht ip u)
563 564deriving instance ( Show ip
564eventId :: Event ip -> NodeId 565 , Show (NodeId dht)
566 , Show u
567 ) => Show (Event dht ip u)
568
569eventId :: Event dht ip u -> NodeId dht
565eventId (TryInsert NodeInfo{..}) = nodeId 570eventId (TryInsert NodeInfo{..}) = nodeId
566eventId (PingResult NodeInfo{..} _) = nodeId 571eventId (PingResult NodeInfo{..} _) = nodeId
567 572
568-- | Actions requested by atomic table update 573-- | Actions requested by atomic table update
569data CheckPing ip = CheckPing [NodeInfo KMessageOf ip ()] 574data CheckPing dht ip u = CheckPing [NodeInfo dht ip u]
570 deriving (Eq,Show) -- Ord 575
576deriving instance Eq (NodeId dht) => Eq (CheckPing dht ip u)
577deriving instance ( Show ip
578 , Show (NodeId dht)
579 , Show u
580 ) => Show (CheckPing dht ip u)
571 581
572 582
573-- | Atomic 'Table' update 583-- | Atomic 'Table' update
574insert :: (Eq ip, Applicative m) => Timestamp -> Event ip -> Table ip -> m ([CheckPing ip], Table ip) 584insert :: ( Eq ip
585 , Applicative m
586 , Ord (NodeId dht)
587 , FiniteBits (NodeId dht)
588 ) => Timestamp -> Event dht ip u -> Table dht ip u -> m ([CheckPing dht ip u], Table dht ip u)
575insert tm event tbl = pure $ fromMaybe ([],tbl) $ modifyBucket (eventId event) (insertBucket tm event) tbl 589insert tm event tbl = pure $ fromMaybe ([],tbl) $ modifyBucket (eventId event) (insertBucket tm event) tbl
576 590
577 591
@@ -579,16 +593,16 @@ insert tm event tbl = pure $ fromMaybe ([],tbl) $ modifyBucket (eventId event) (
579-- Conversion 593-- Conversion
580-----------------------------------------------------------------------} 594-----------------------------------------------------------------------}
581 595
582type TableEntry ip = (NodeInfo KMessageOf ip (), Timestamp) 596type TableEntry dht ip u = (NodeInfo dht ip u, Timestamp)
583 597
584tableEntry :: NodeEntry ip -> TableEntry ip 598tableEntry :: NodeEntry dht ip u -> TableEntry dht ip u
585tableEntry (a :-> b) = (a, b) 599tableEntry (a :-> b) = (a, b)
586 600
587-- | Non-empty list of buckets. 601-- | Non-empty list of buckets.
588toBucketList :: Table ip -> [Bucket ip] 602toBucketList :: Table dht ip u -> [Bucket dht ip u]
589toBucketList (Tip _ _ b) = [b] 603toBucketList (Tip _ _ b) = [b]
590toBucketList (Zero t b) = b : toBucketList t 604toBucketList (Zero t b) = b : toBucketList t
591toBucketList (One b t) = b : toBucketList t 605toBucketList (One b t) = b : toBucketList t
592 606
593toList :: Eq ip => Table ip -> [[TableEntry ip]] 607toList :: Eq ip => Table dht ip u -> [[TableEntry dht ip u]]
594toList = L.map (L.map tableEntry . PSQ.toList . bktNodes) . toBucketList 608toList = L.map (L.map tableEntry . PSQ.toList . bktNodes) . toBucketList
diff --git a/src/Network/BitTorrent/DHT/Search.hs b/src/Network/BitTorrent/DHT/Search.hs
index 854f26c7..844b4575 100644
--- a/src/Network/BitTorrent/DHT/Search.hs
+++ b/src/Network/BitTorrent/DHT/Search.hs
@@ -1,3 +1,4 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE PatternSynonyms #-} 2{-# LANGUAGE PatternSynonyms #-}
2{-# LANGUAGE RecordWildCards #-} 3{-# LANGUAGE RecordWildCards #-}
3{-# LANGUAGE ScopedTypeVariables #-} 4{-# LANGUAGE ScopedTypeVariables #-}
@@ -24,21 +25,28 @@ import qualified Data.Wrapper.PSQ as PSQ
24 ;import Data.Wrapper.PSQ (pattern (:->), Binding, PSQ) 25 ;import Data.Wrapper.PSQ (pattern (:->), Binding, PSQ)
25import Network.BitTorrent.Address hiding (NodeId) 26import Network.BitTorrent.Address hiding (NodeId)
26import Network.RPC 27import Network.RPC
27import Network.KRPC.Message (KMessageOf) 28#ifdef VERSION_bencoding
28import Network.DHT.Mainline () 29import Network.DHT.Mainline ()
30import Network.KRPC.Message (KMessageOf)
31type Ann = ()
32#else
33import Data.Tox as Tox
34type KMessageOf = Tox.Message
35type Ann = Bool
36#endif
29 37
30data IterativeSearch ip r = IterativeSearch 38data IterativeSearch ip r = IterativeSearch
31 { searchTarget :: NodeId KMessageOf 39 { searchTarget :: NodeId KMessageOf
32 , searchQuery :: NodeInfo KMessageOf ip () -> IO ([NodeInfo KMessageOf ip ()], [r]) 40 , searchQuery :: NodeInfo KMessageOf ip Ann -> IO ([NodeInfo KMessageOf ip Ann], [r])
33 , searchPendingCount :: TVar Int 41 , searchPendingCount :: TVar Int
34 , searchQueued :: TVar (MinMaxPSQ (NodeInfo KMessageOf ip ()) (NodeDistance (NodeId KMessageOf))) 42 , searchQueued :: TVar (MinMaxPSQ (NodeInfo KMessageOf ip Ann) (NodeDistance (NodeId KMessageOf)))
35 , searchInformant :: TVar (MinMaxPSQ (NodeInfo KMessageOf ip ()) (NodeDistance (NodeId KMessageOf))) 43 , searchInformant :: TVar (MinMaxPSQ (NodeInfo KMessageOf ip Ann) (NodeDistance (NodeId KMessageOf)))
36 , searchVisited :: TVar (Set (NodeAddr ip)) 44 , searchVisited :: TVar (Set (NodeAddr ip))
37 , searchResults :: TVar (Set r) 45 , searchResults :: TVar (Set r)
38 } 46 }
39 47
40newSearch :: Eq ip => (NodeInfo KMessageOf ip () -> IO ([NodeInfo KMessageOf ip ()], [r])) 48newSearch :: Eq ip => (NodeInfo KMessageOf ip Ann -> IO ([NodeInfo KMessageOf ip Ann], [r]))
41 -> NodeId KMessageOf -> [NodeInfo KMessageOf ip ()] -> IO (IterativeSearch ip r) 49 -> NodeId KMessageOf -> [NodeInfo KMessageOf ip Ann] -> IO (IterativeSearch ip r)
42newSearch qry target ns = atomically $ do 50newSearch qry target ns = atomically $ do
43 c <- newTVar 0 51 c <- newTVar 0
44 q <- newTVar $ MM.fromList $ map (\n -> n :-> distance target (nodeId n)) ns 52 q <- newTVar $ MM.fromList $ map (\n -> n :-> distance target (nodeId n)) ns
@@ -55,7 +63,7 @@ searchK = 8
55 63
56sendQuery :: forall a ip. (Ord a, Ord ip) => 64sendQuery :: forall a ip. (Ord a, Ord ip) =>
57 IterativeSearch ip a 65 IterativeSearch ip a
58 -> Binding (NodeInfo KMessageOf ip ()) (NodeDistance (NodeId KMessageOf)) 66 -> Binding (NodeInfo KMessageOf ip Ann) (NodeDistance (NodeId KMessageOf))
59 -> IO () 67 -> IO ()
60sendQuery IterativeSearch{..} (ni :-> d) = do 68sendQuery IterativeSearch{..} (ni :-> d) = do
61 (ns,rs) <- handle (\(SomeException e) -> return ([],[])) 69 (ns,rs) <- handle (\(SomeException e) -> return ([],[]))
diff --git a/src/Network/BitTorrent/DHT/Session.hs b/src/Network/BitTorrent/DHT/Session.hs
index aa6ee396..bec2dabc 100644
--- a/src/Network/BitTorrent/DHT/Session.hs
+++ b/src/Network/BitTorrent/DHT/Session.hs
@@ -106,9 +106,11 @@ import Data.Serialize as S
106import Data.Torrent as Torrent 106import Data.Torrent as Torrent
107import Network.KRPC as KRPC hiding (Options, def) 107import Network.KRPC as KRPC hiding (Options, def)
108import qualified Network.KRPC as KRPC (def) 108import qualified Network.KRPC as KRPC (def)
109import Network.KRPC.Message (KMessageOf)
110#ifdef VERSION_bencoding 109#ifdef VERSION_bencoding
111import Data.BEncode (BValue) 110import Data.BEncode (BValue)
111import Network.KRPC.Message (KMessageOf)
112#else
113import Data.Tox as Tox
112#endif 114#endif
113import Network.BitTorrent.Address 115import Network.BitTorrent.Address
114import Network.BitTorrent.DHT.ContactInfo (PeerStore) 116import Network.BitTorrent.DHT.ContactInfo (PeerStore)
@@ -257,11 +259,19 @@ data Node ip = Node
257 259
258 -- | Pseudo-unique self-assigned session identifier. This value is 260 -- | Pseudo-unique self-assigned session identifier. This value is
259 -- constant during DHT session and (optionally) between sessions. 261 -- constant during DHT session and (optionally) between sessions.
260 , tentativeNodeId :: !NodeId 262#ifdef VERSION_bencoding
263 , tentativeNodeId :: !(NodeId KMessageOf)
264#else
265 , tentativeNodeId :: !(NodeId Tox.Message)
266#endif
261 267
262 , resources :: !InternalState 268 , resources :: !InternalState
263 , manager :: !(Manager (DHT ip )) -- ^ RPC manager; 269 , manager :: !(Manager (DHT ip )) -- ^ RPC manager;
264 , routingInfo :: !(TVar (Maybe (R.Info ip))) -- ^ search table; 270#ifdef VERSION_bencoding
271 , routingInfo :: !(TVar (Maybe (R.Info KMessageOf ip ()))) -- ^ search table;
272#else
273 , routingInfo :: !(TVar (Maybe (R.Info Tox.Message ip Bool))) -- ^ search table;
274#endif
265 , contactInfo :: !(TVar (PeerStore ip )) -- ^ published by other nodes; 275 , contactInfo :: !(TVar (PeerStore ip )) -- ^ published by other nodes;
266 , announceInfo :: !(TVar AnnounceSet ) -- ^ to publish by this node; 276 , announceInfo :: !(TVar AnnounceSet ) -- ^ to publish by this node;
267 , sessionTokens :: !(TVar SessionTokens ) -- ^ query session IDs. 277 , sessionTokens :: !(TVar SessionTokens ) -- ^ query session IDs.
@@ -319,7 +329,7 @@ instance MonadLogger (DHT ip) where
319#ifdef VERSION_bencoding 329#ifdef VERSION_bencoding
320type NodeHandler ip = Handler (DHT ip) KMessageOf BValue 330type NodeHandler ip = Handler (DHT ip) KMessageOf BValue
321#else 331#else
322type NodeHandler ip = Handler (DHT ip) KMessageOf ByteString 332type NodeHandler ip = Handler (DHT ip) Tox.Message ByteString
323#endif 333#endif
324 334
325-- | Run DHT session. You /must/ properly close session using 335-- | Run DHT session. You /must/ properly close session using
@@ -330,7 +340,11 @@ newNode :: Address ip
330 -> Options -- ^ various dht options; 340 -> Options -- ^ various dht options;
331 -> NodeAddr ip -- ^ node address to bind; 341 -> NodeAddr ip -- ^ node address to bind;
332 -> LogFun -- ^ 342 -> LogFun -- ^
333 -> Maybe NodeId -- ^ use this NodeId, if not given a new one is generated. 343#ifdef VERSION_bencoding
344 -> Maybe (NodeId KMessageOf) -- ^ use this NodeId, if not given a new one is generated.
345#else
346 -> Maybe (NodeId Tox.Message) -- ^ use this NodeId, if not given a new one is generated.
347#endif
334 -> IO (Node ip) -- ^ a new DHT node running at given address. 348 -> IO (Node ip) -- ^ a new DHT node running at given address.
335newNode hs opts naddr logger mbid = do 349newNode hs opts naddr logger mbid = do
336 s <- createInternalState 350 s <- createInternalState
@@ -406,7 +420,11 @@ routableAddress = do
406 return $ myAddress <$> info 420 return $ myAddress <$> info
407 421
408-- | The current NodeId that the given remote node should know us by. 422-- | The current NodeId that the given remote node should know us by.
409myNodeIdAccordingTo :: NodeAddr ip -> DHT ip NodeId 423#ifdef VERSION_bencoding
424myNodeIdAccordingTo :: NodeAddr ip -> DHT ip (NodeId KMessageOf)
425#else
426myNodeIdAccordingTo :: NodeAddr ip -> DHT ip (NodeId Tox.Message)
427#endif
410myNodeIdAccordingTo _ = do 428myNodeIdAccordingTo _ = do
411 info <- asks routingInfo >>= liftIO . atomically . readTVar 429 info <- asks routingInfo >>= liftIO . atomically . readTVar
412 maybe (asks tentativeNodeId) 430 maybe (asks tentativeNodeId)
@@ -415,7 +433,11 @@ myNodeIdAccordingTo _ = do
415 433
416-- | Get current routing table. Normally you don't need to use this 434-- | Get current routing table. Normally you don't need to use this
417-- function, but it can be usefull for debugging and profiling purposes. 435-- function, but it can be usefull for debugging and profiling purposes.
418getTable :: Eq ip => DHT ip (Table ip) 436#ifdef VERSION_bencoding
437getTable :: Eq ip => DHT ip (Table KMessageOf ip ())
438#else
439getTable :: Eq ip => DHT ip (Table Tox.Message ip Bool)
440#endif
419getTable = do 441getTable = do
420 Node { tentativeNodeId = myId 442 Node { tentativeNodeId = myId
421 , routingInfo = var 443 , routingInfo = var
@@ -452,7 +474,11 @@ allPeers ih = do
452-- 474--
453-- This operation used for 'find_nodes' query. 475-- This operation used for 'find_nodes' query.
454-- 476--
455getClosest :: Eq ip => TableKey k => k -> DHT ip [NodeInfo KMessageOf ip ()] 477#ifdef VERSION_bencoding
478getClosest :: Eq ip => TableKey KMessageOf k => k -> DHT ip [NodeInfo KMessageOf ip ()]
479#else
480getClosest :: Eq ip => TableKey Tox.Message k => k -> DHT ip [NodeInfo Tox.Message ip Bool]
481#endif
456getClosest node = do 482getClosest node = do
457 k <- asks (optK . options) 483 k <- asks (optK . options)
458 kclosest k node <$> getTable 484 kclosest k node <$> getTable
diff --git a/src/Network/DHT/Mainline.hs b/src/Network/DHT/Mainline.hs
index d7aed430..2b7db3c7 100644
--- a/src/Network/DHT/Mainline.hs
+++ b/src/Network/DHT/Mainline.hs
@@ -1,15 +1,23 @@
1{-# LANGUAGE LambdaCase #-} 1{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE MultiParamTypeClasses #-} 2{-# LANGUAGE MultiParamTypeClasses #-}
3{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE DeriveDataTypeable #-} 4{-# LANGUAGE DeriveDataTypeable #-}
4{-# LANGUAGE TypeFamilies #-} 5{-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE GeneralizedNewtypeDeriving #-} 6{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6module Network.DHT.Mainline where 7module Network.DHT.Mainline where
7 8
9import Data.Digest.CRC32C
10import Control.Applicative
11import Data.Maybe
12import Data.Monoid
13import Data.Word
14import Data.IP
8import Data.BEncode as BE 15import Data.BEncode as BE
9import Data.Bits 16import Data.Bits
10import Data.ByteString (ByteString) 17import Data.ByteString (ByteString)
11import Data.ByteString.Base16 as Base16 18import Data.ByteString.Base16 as Base16
12import qualified Data.ByteString.Char8 as Char8 19import qualified Data.ByteString.Char8 as Char8
20import qualified Data.ByteString as BS
13import qualified Data.ByteString.Lazy as L 21import qualified Data.ByteString.Lazy as L
14import Data.Default 22import Data.Default
15import Data.LargeWord 23import Data.LargeWord
@@ -17,28 +25,16 @@ import Data.Serialize as S
17import Data.String 25import Data.String
18import Data.Typeable 26import Data.Typeable
19import Network.KRPC.Message as KRPC 27import Network.KRPC.Message as KRPC
20import qualified Network.RPC as RPC (NodeId) 28import Network.RPC as RPC
21 ;import Network.RPC as RPC hiding (NodeId)
22import Text.PrettyPrint as PP hiding ((<>)) 29import Text.PrettyPrint as PP hiding ((<>))
23import Text.PrettyPrint.HughesPJClass hiding (($$), (<>)) 30import Text.PrettyPrint.HughesPJClass hiding (($$), (<>))
24 31
25-- | Each node has a globally unique identifier known as the \"node 32nodeIdSize = finiteBitSize (undefined :: NodeId KMessageOf) `div` 8
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 33
33instance BEncode NodeId where 34instance BEncode (NodeId KMessageOf) where
34 toBEncode (NodeId w) = toBEncode $ S.encode w 35 toBEncode (NodeId w) = toBEncode $ S.encode w
35 fromBEncode bval = fromBEncode bval >>= S.decode 36 fromBEncode bval = fromBEncode bval >>= S.decode
36 37
37-- | NodeId size in bytes.
38nodeIdSize :: Int
39nodeIdSize = 20
40
41
42-- instance BEncode NodeId where TODO 38-- instance BEncode NodeId where TODO
43 39
44-- TODO: put this somewhere appropriate 40-- TODO: put this somewhere appropriate
@@ -46,14 +42,14 @@ instance (Serialize a, Serialize b) => Serialize (LargeKey a b) where
46 put (LargeKey lo hi) = put hi >> put lo 42 put (LargeKey lo hi) = put hi >> put lo
47 get = flip LargeKey <$> get <*> get 43 get = flip LargeKey <$> get <*> get
48 44
49instance Serialize NodeId where 45instance Serialize (NodeId KMessageOf) where
50 get = NodeId <$> get 46 get = NodeId <$> get
51 {-# INLINE get #-} 47 {-# INLINE get #-}
52 put (NodeId bs) = put bs 48 put (NodeId bs) = put bs
53 {-# INLINE put #-} 49 {-# INLINE put #-}
54 50
55-- | ASCII encoded. 51-- | ASCII encoded.
56instance IsString NodeId where 52instance IsString (NodeId KMessageOf) where
57 fromString str 53 fromString str
58 | length str == nodeIdSize = NodeId (either error id $ S.decode (fromString str :: ByteString)) 54 | 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)) 55 | length str == 2 * nodeIdSize = NodeId (either error id $ S.decode (fst $ Base16.decode $ fromString str))
@@ -61,16 +57,74 @@ instance IsString NodeId where
61 {-# INLINE fromString #-} 57 {-# INLINE fromString #-}
62 58
63-- | Meaningless node id, for testing purposes only. 59-- | Meaningless node id, for testing purposes only.
64instance Default NodeId where 60instance Default (NodeId KMessageOf) where
65 def = NodeId 0 61 def = NodeId 0
66 62
67-- | base16 encoded. 63-- | base16 encoded.
68instance Pretty NodeId where 64instance Pretty (NodeId KMessageOf) where
69 pPrint (NodeId nid) = PP.text $ Char8.unpack $ Base16.encode $ S.encode nid 65 pPrint (NodeId nid) = PP.text $ Char8.unpack $ Base16.encode $ S.encode nid
70 66
67-- | KRPC 'compact list' compatible encoding: contact information for
68-- nodes is encoded as a 26-byte string. Also known as "Compact node
69-- info" the 20-byte Node ID in network byte order has the compact
70-- IP-address/port info concatenated to the end.
71instance Serialize a => Serialize (NodeInfo KMessageOf a ()) where
72 get = (\a b -> NodeInfo a b ()) <$> get <*> get
73 put NodeInfo {..} = put nodeId >> put nodeAddr
74
75instance Pretty ip => Pretty (NodeInfo KMessageOf ip ()) where
76 pPrint NodeInfo {..} = pPrint nodeId <> "@(" <> pPrint nodeAddr <> ")"
77
78instance Pretty ip => Pretty [NodeInfo KMessageOf ip ()] where
79 pPrint = PP.vcat . PP.punctuate "," . map pPrint
80
81
82-- | Yields all 8 DHT neighborhoods available to you given a particular ip
83-- address.
84bep42s :: Address a => a -> NodeId KMessageOf -> [NodeId KMessageOf]
85bep42s addr (NodeId r) = mapMaybe (bep42 addr) rs
86 where
87 rs = map (NodeId . change3bits r) [0..7]
88
89-- change3bits :: ByteString -> Word8 -> ByteString
90-- change3bits bs n = BS.snoc (BS.init bs) (BS.last bs .&. 0xF8 .|. n)
91
92change3bits :: (Num b, Bits b) => b -> b -> b
93change3bits bs n = (bs .&. complement 7) .|. n
94
95-- | Modifies a purely random 'NodeId' to one that is related to a given
96-- routable address in accordance with BEP 42.
97bep42 :: Address a => a -> NodeId KMessageOf -> Maybe (NodeId KMessageOf)
98bep42 addr (NodeId r)
99 | Just ip <- fmap S.encode (fromAddr addr :: Maybe IPv4)
100 <|> fmap S.encode (fromAddr addr :: Maybe IPv6)
101 = genBucketSample' retr (NodeId $ crc $ applyMask ip) (3,0x07,0)
102 | otherwise
103 = Nothing
104 where
105 ip4mask = "\x03\x0f\x3f\xff" :: ByteString
106 ip6mask = "\x01\x03\x07\x0f\x1f\x3f\x7f\xff" :: ByteString
107 nbhood_select = (fromIntegral r :: Word8) .&. 7
108 retr n = pure $ BS.drop (nodeIdSize - n) $ S.encode r
109 crc = flip shiftL (finiteBitSize (NodeId undefined) - 32) . fromIntegral . crc32c . BS.pack
110 applyMask ip = case BS.zipWith (.&.) msk ip of
111 (b:bs) -> (b .|. shiftL nbhood_select 5) : bs
112 bs -> bs
113 where msk | BS.length ip == 4 = ip4mask
114 | otherwise = ip6mask
115
116
117
71instance Envelope KMessageOf where 118instance Envelope KMessageOf where
72 type TransactionID KMessageOf = KRPC.TransactionId 119 type TransactionID KMessageOf = KRPC.TransactionId
73 type NodeId KMessageOf = Network.DHT.Mainline.NodeId 120
121 -- | Each node has a globally unique identifier known as the \"node
122 -- ID.\"
123 --
124 -- Normally, /this/ node id should be saved between invocations
125 -- of the client software.
126 newtype NodeId KMessageOf = NodeId Word160
127 deriving (Show, Eq, Ord, Typeable, Bits, FiniteBits)
74 128
75 envelopePayload (Q q) = queryArgs q 129 envelopePayload (Q q) = queryArgs q
76 envelopePayload (R r) = respVals r 130 envelopePayload (R r) = respVals r
diff --git a/src/Network/RPC.hs b/src/Network/RPC.hs
index 7fb0e571..2333766a 100644
--- a/src/Network/RPC.hs
+++ b/src/Network/RPC.hs
@@ -1,29 +1,80 @@
1{-# LANGUAGE ConstraintKinds #-} 1{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE DeriveDataTypeable #-} 2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE DeriveFunctor #-}
4{-# LANGUAGE DeriveFoldable #-}
5{-# LANGUAGE DeriveTraversable #-}
6{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleContexts #-} 7{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FunctionalDependencies #-} 8{-# LANGUAGE FunctionalDependencies #-}
5{-# LANGUAGE MultiParamTypeClasses #-} 9{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE RankNTypes #-} 10{-# LANGUAGE RankNTypes #-}
7{-# LANGUAGE ScopedTypeVariables #-} 11{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE TypeFamilies #-} 12{-# LANGUAGE TypeFamilies #-}
13{-# LANGUAGE StandaloneDeriving #-}
9module Network.RPC where 14module Network.RPC where
10 15
16import Control.Applicative
17import qualified Text.ParserCombinators.ReadP as RP
18import Data.Digest.CRC32C
19import Data.Word
20import Data.Monoid
21import Data.Hashable
22import Data.String
11import Data.Bits 23import Data.Bits
12import Data.ByteString (ByteString) 24import Data.ByteString (ByteString)
13import Data.Kind (Constraint) 25import Data.Kind (Constraint)
14import Data.Data 26import Data.Data
27import Data.Default
28import Data.List.Split
29import Data.Ord
30import Data.IP
15import Network.Socket 31import Network.Socket
32import Text.PrettyPrint as PP hiding ((<>))
16import Text.PrettyPrint.HughesPJClass hiding (($$), (<>)) 33import Text.PrettyPrint.HughesPJClass hiding (($$), (<>))
34import Text.Read (readMaybe)
17import Data.Serialize as S 35import Data.Serialize as S
18import qualified Data.ByteString.Char8 as Char8 36import qualified Data.ByteString.Char8 as Char8
37import qualified Data.ByteString as BS
19import Data.ByteString.Base16 as Base16 38import Data.ByteString.Base16 as Base16
39import System.Entropy
40
41class (Eq a, Serialize a, Typeable a, Hashable a, Pretty a)
42 => Address a where
43 toSockAddr :: a -> SockAddr
44 fromSockAddr :: SockAddr -> Maybe a
45
46fromAddr :: (Address a, Address b) => a -> Maybe b
47fromAddr = fromSockAddr . toSockAddr
48
49-- | Note that port is zeroed.
50instance Address IPv4 where
51 toSockAddr = SockAddrInet 0 . toHostAddress
52 fromSockAddr (SockAddrInet _ h) = Just (fromHostAddress h)
53 fromSockAddr _ = Nothing
54
55-- | Note that port is zeroed.
56instance Address IPv6 where
57 toSockAddr h = SockAddrInet6 0 0 (toHostAddress6 h) 0
58 fromSockAddr (SockAddrInet6 _ _ h _) = Just (fromHostAddress6 h)
59 fromSockAddr _ = Nothing
60
61-- | Note that port is zeroed.
62instance Address IP where
63 toSockAddr (IPv4 h) = toSockAddr h
64 toSockAddr (IPv6 h) = toSockAddr h
65 fromSockAddr sa =
66 IPv4 <$> fromSockAddr sa
67 <|> IPv6 <$> fromSockAddr sa
68
69
70
20 71
21data MessageClass = Error | Query | Response 72data MessageClass = Error | Query | Response
22 deriving (Eq,Ord,Enum,Bounded,Data,Show,Read) 73 deriving (Eq,Ord,Enum,Bounded,Data,Show,Read)
23 74
24class Envelope envelope where 75class Envelope envelope where
25 type TransactionID envelope 76 type TransactionID envelope
26 type NodeId envelope 77 data NodeId envelope
27 78
28 envelopePayload :: envelope a -> a 79 envelopePayload :: envelope a -> a
29 envelopeTransaction :: envelope a -> TransactionID envelope 80 envelopeTransaction :: envelope a -> TransactionID envelope
@@ -58,6 +109,187 @@ instance Serialize nodeid => Pretty (NodeDistance nodeid) where
58 pPrint n = text $ show n 109 pPrint n = text $ show n
59 110
60 111
112-- | When 'get'ing an IP it must be 'isolate'd to the appropriate
113-- number of bytes since we have no other way of telling which
114-- address type we are trying to parse
115instance Serialize IP where
116 put (IPv4 ip) = put ip
117 put (IPv6 ip) = put ip
118
119 get = do
120 n <- remaining
121 case n of
122 4 -> IPv4 <$> get
123 16 -> IPv6 <$> get
124 _ -> fail (show n ++ " is the wrong number of remaining bytes to parse IP")
125
126instance Serialize IPv4 where
127 put = putWord32host . toHostAddress
128 get = fromHostAddress <$> getWord32host
129
130instance Serialize IPv6 where
131 put ip = put $ toHostAddress6 ip
132 get = fromHostAddress6 <$> get
133
134instance Pretty IPv4 where
135 pPrint = PP.text . show
136 {-# INLINE pPrint #-}
137
138instance Pretty IPv6 where
139 pPrint = PP.text . show
140 {-# INLINE pPrint #-}
141
142instance Pretty IP where
143 pPrint = PP.text . show
144 {-# INLINE pPrint #-}
145
146instance Hashable IPv4 where
147 hashWithSalt = hashUsing toHostAddress
148 {-# INLINE hashWithSalt #-}
149
150instance Hashable IPv6 where
151 hashWithSalt s a = hashWithSalt s (toHostAddress6 a)
152
153instance Hashable IP where
154 hashWithSalt s (IPv4 h) = hashWithSalt s h
155 hashWithSalt s (IPv6 h) = hashWithSalt s h
156
157
158
159
160
161data NodeAddr a = NodeAddr
162 { nodeHost :: !a
163 , nodePort :: {-# UNPACK #-} !PortNumber
164 } deriving (Eq, Ord, Typeable, Functor, Foldable, Traversable)
165
166instance Show a => Show (NodeAddr a) where
167 showsPrec i NodeAddr {..}
168 = showsPrec i nodeHost <> showString ":" <> showsPrec i nodePort
169
170instance Read (NodeAddr IPv4) where
171 readsPrec i = RP.readP_to_S $ do
172 ipv4 <- RP.readS_to_P (readsPrec i)
173 _ <- RP.char ':'
174 port <- toEnum <$> RP.readS_to_P (readsPrec i)
175 return $ NodeAddr ipv4 port
176
177-- | @127.0.0.1:6882@
178instance Default (NodeAddr IPv4) where
179 def = "127.0.0.1:6882"
180
181-- | KRPC compatible encoding.
182instance Serialize a => Serialize (NodeAddr a) where
183 get = NodeAddr <$> get <*> get
184 {-# INLINE get #-}
185 put NodeAddr {..} = put nodeHost >> put nodePort
186 {-# INLINE put #-}
187
188-- | Example:
189--
190-- @nodePort \"127.0.0.1:6881\" == 6881@
191--
192instance IsString (NodeAddr IPv4) where
193 fromString str
194 | [hostAddrStr, portStr] <- splitWhen (== ':') str
195 , Just hostAddr <- readMaybe hostAddrStr
196 , Just portNum <- toEnum <$> readMaybe portStr
197 = NodeAddr hostAddr portNum
198 | otherwise = error $ "fromString: unable to parse (NodeAddr IPv4): " ++ str
199
200instance Hashable PortNumber where
201 hashWithSalt s = hashWithSalt s . fromEnum
202 {-# INLINE hashWithSalt #-}
203
204instance Pretty PortNumber where
205 pPrint = PP.int . fromEnum
206 {-# INLINE pPrint #-}
207
208
209instance Hashable a => Hashable (NodeAddr a) where
210 hashWithSalt s NodeAddr {..} = hashWithSalt s (nodeHost, nodePort)
211 {-# INLINE hashWithSalt #-}
212
213instance Pretty ip => Pretty (NodeAddr ip) where
214 pPrint NodeAddr {..} = pPrint nodeHost <> ":" <> pPrint nodePort
215
216
217instance Serialize PortNumber where
218 get = fromIntegral <$> getWord16be
219 {-# INLINE get #-}
220 put = putWord16be . fromIntegral
221 {-# INLINE put #-}
222
223
224
225
226data NodeInfo dht addr u = NodeInfo
227 { nodeId :: !(NodeId dht)
228 , nodeAddr :: !(NodeAddr addr)
229 , nodeAnnotation :: u
230 } deriving (Functor, Foldable, Traversable)
231
232deriving instance ( Show (NodeId dht)
233 , Show addr
234 , Show u ) => Show (NodeInfo dht addr u)
235
236mapAddress :: (addr -> b) -> NodeInfo dht addr u -> NodeInfo dht b u
237mapAddress f ni = ni { nodeAddr = fmap f (nodeAddr ni) }
238
239traverseAddress :: Applicative f => (addr -> f b) -> NodeInfo dht addr u -> f (NodeInfo dht b u)
240traverseAddress f ni = fmap (\addr -> ni { nodeAddr = addr }) $ traverse f (nodeAddr ni)
241
242-- Warning: Eq and Ord only look at the nodeId field.
243instance Eq (NodeId dht) => Eq (NodeInfo dht a u) where
244 a == b = (nodeId a == nodeId b)
245
246instance Ord (NodeId dht) => Ord (NodeInfo dht a u) where
247 compare = comparing nodeId
248
249
250-- TODO WARN is the 'system' random suitable for this?
251-- | Generate random NodeID used for the entire session.
252-- Distribution of ID's should be as uniform as possible.
253--
254genNodeId :: forall dht.
255 ( Serialize (NodeId dht)
256 , FiniteBits (NodeId dht)
257 ) => IO (NodeId dht)
258genNodeId = either error id . S.decode <$> getEntropy nodeIdSize
259 where
260 nodeIdSize = finiteBitSize (undefined :: NodeId dht) `div` 8
261
262-- | Generate a random 'NodeId' within a range suitable for a bucket. To
263-- obtain a sample for bucket number /index/ where /is_last/ indicates if this
264-- is for the current deepest bucket in our routing table:
265--
266-- > sample <- genBucketSample nid (bucketRange index is_last)
267genBucketSample :: ( FiniteBits (NodeId dht)
268 , Serialize (NodeId dht)
269 ) => NodeId dht -> (Int,Word8,Word8) -> IO (NodeId dht)
270genBucketSample n qmb = genBucketSample' getEntropy n qmb
271
272-- | Generalizion of 'genBucketSample' that accepts a byte generator
273-- function to use instead of the system entropy.
274genBucketSample' :: forall m dht.
275 ( Applicative m
276 , FiniteBits (NodeId dht)
277 , Serialize (NodeId dht)
278 ) =>
279 (Int -> m ByteString) -> NodeId dht -> (Int,Word8,Word8) -> m (NodeId dht)
280genBucketSample' gen self (q,m,b)
281 | q <= 0 = either error id . S.decode <$> gen nodeIdSize
282 | q >= nodeIdSize = pure self
283 | otherwise = either error id . S.decode . build <$> gen (nodeIdSize - q + 1)
284 where
285 nodeIdSize = finiteBitSize (undefined :: NodeId dht) `div` 8
286 build tl = BS.init hd <> BS.cons (h .|. t) (BS.tail tl)
287 where
288 hd = BS.take q $ S.encode self
289 h = xor b (complement m .&. BS.last hd)
290 t = m .&. BS.head tl
291
292
61class Envelope envelope => WireFormat raw envelope where 293class Envelope envelope => WireFormat raw envelope where
62 type SerializableTo raw :: * -> Constraint 294 type SerializableTo raw :: * -> Constraint
63 type CipherContext raw envelope 295 type CipherContext raw envelope
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 14:18:26 +0000