summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Data/Torrent.hs1
-rw-r--r--src/Network/Address.hs190
-rw-r--r--src/Network/BitTorrent/DHT/Search.hs1
-rw-r--r--src/Network/DatagramServer/Types.hs412
4 files changed, 173 insertions, 431 deletions
diff --git a/src/Data/Torrent.hs b/src/Data/Torrent.hs
index 004369ce..55b34f98 100644
--- a/src/Data/Torrent.hs
+++ b/src/Data/Torrent.hs
@@ -196,7 +196,6 @@ import System.Posix.Types
196 196
197import Network.Address 197import Network.Address
198import Network.DHT.Routing 198import Network.DHT.Routing
199import Network.DatagramServer.Mainline
200 199
201 200
202{----------------------------------------------------------------------- 201{-----------------------------------------------------------------------
diff --git a/src/Network/Address.hs b/src/Network/Address.hs
index 9ecd89a3..8715a82d 100644
--- a/src/Network/Address.hs
+++ b/src/Network/Address.hs
@@ -59,18 +59,13 @@ module Network.Address
59 , peerSocket 59 , peerSocket
60 60
61 -- * Node 61 -- * Node
62 , NodeAddr (..)
63
62 -- ** Id 64 -- ** Id
63 , NodeId
64 , testIdBit 65 , testIdBit
65 , genNodeId
66 , bucketRange 66 , bucketRange
67 , genBucketSample 67 , genBucketSample
68 68 , genBucketSample'
69 -- ** Info
70 , NodeAddr (..)
71 , NodeInfo (..)
72 , mapAddress
73 , traverseAddress
74 69
75 -- * Fingerprint 70 -- * Fingerprint
76 -- $fingerprint 71 -- $fingerprint
@@ -126,7 +121,6 @@ import Text.PrettyPrint.HughesPJClass hiding ((<>),($$))
126import System.Locale (defaultTimeLocale) 121import System.Locale (defaultTimeLocale)
127#endif 122#endif
128import System.Entropy 123import System.Entropy
129import Network.DatagramServer.Types as RPC
130 124
131-- import Paths_bittorrent (version) 125-- import Paths_bittorrent (version)
132 126
@@ -147,9 +141,82 @@ sockAddrPort (SockAddrInet6 p _ _ _) = Just p
147sockAddrPort _ = Nothing 141sockAddrPort _ = Nothing
148{-# INLINE sockAddrPort #-} 142{-# INLINE sockAddrPort #-}
149 143
150instance Address a => Address (NodeAddr a) where 144class (Eq a, Serialize a, Typeable a, Hashable a, Pretty a)
151 toSockAddr NodeAddr {..} = setPort nodePort $ toSockAddr nodeHost 145 => Address a where
152 fromSockAddr sa = NodeAddr <$> fromSockAddr sa <*> sockAddrPort sa 146 toSockAddr :: a -> SockAddr
147 fromSockAddr :: SockAddr -> Maybe a
148
149fromAddr :: (Address a, Address b) => a -> Maybe b
150fromAddr = fromSockAddr . toSockAddr
151
152-- | Note that port is zeroed.
153instance Address IPv4 where
154 toSockAddr = SockAddrInet 0 . toHostAddress
155 fromSockAddr (SockAddrInet _ h) = Just (fromHostAddress h)
156 fromSockAddr _ = Nothing
157
158-- | Note that port is zeroed.
159instance Address IPv6 where
160 toSockAddr h = SockAddrInet6 0 0 (toHostAddress6 h) 0
161 fromSockAddr (SockAddrInet6 _ _ h _) = Just (fromHostAddress6 h)
162 fromSockAddr _ = Nothing
163
164-- | Note that port is zeroed.
165instance Address IP where
166 toSockAddr (IPv4 h) = toSockAddr h
167 toSockAddr (IPv6 h) = toSockAddr h
168 fromSockAddr sa =
169 IPv4 <$> fromSockAddr sa
170 <|> IPv6 <$> fromSockAddr sa
171
172data NodeAddr a = NodeAddr
173 { nodeHost :: !a
174 , nodePort :: {-# UNPACK #-} !PortNumber
175 } deriving (Eq, Ord, Typeable, Functor, Foldable, Traversable)
176
177instance Show a => Show (NodeAddr a) where
178 showsPrec i NodeAddr {..}
179 = showsPrec i nodeHost <> showString ":" <> showsPrec i nodePort
180
181instance Read (NodeAddr IPv4) where
182 readsPrec i = RP.readP_to_S $ do
183 ipv4 <- RP.readS_to_P (readsPrec i)
184 _ <- RP.char ':'
185 port <- toEnum <$> RP.readS_to_P (readsPrec i)
186 return $ NodeAddr ipv4 port
187
188-- | @127.0.0.1:6882@
189instance Default (NodeAddr IPv4) where
190 def = "127.0.0.1:6882"
191
192-- | KRPC compatible encoding.
193instance Serialize a => Serialize (NodeAddr a) where
194 get = NodeAddr <$> get <*> get
195 {-# INLINE get #-}
196 put NodeAddr {..} = put nodeHost >> put nodePort
197 {-# INLINE put #-}
198
199-- | Example:
200--
201-- @nodePort \"127.0.0.1:6881\" == 6881@
202--
203instance IsString (NodeAddr IPv4) where
204 fromString str
205 | [hostAddrStr, portStr] <- splitWhen (== ':') str
206 , Just hostAddr <- readMaybe hostAddrStr
207 , Just portNum <- toEnum <$> readMaybe portStr
208 = NodeAddr hostAddr portNum
209 | otherwise = error $ "fromString: unable to parse (NodeAddr IPv4): " ++ str
210
211
212instance Hashable a => Hashable (NodeAddr a) where
213 hashWithSalt s NodeAddr {..} = hashWithSalt s (nodeHost, nodePort)
214 {-# INLINE hashWithSalt #-}
215
216instance Pretty ip => Pretty (NodeAddr ip) where
217 pPrint NodeAddr {..} = pPrint nodeHost <> ":" <> pPrint nodePort
218
219
153 220
154instance Address PeerAddr where 221instance Address PeerAddr where
155 toSockAddr PeerAddr {..} = setPort peerPort $ toSockAddr peerHost 222 toSockAddr PeerAddr {..} = setPort peerPort $ toSockAddr peerHost
@@ -552,6 +619,37 @@ testIdBit :: FiniteBits bs => bs -> Word -> Bool
552testIdBit bs i = testBit bs (fromIntegral (finiteBitSize bs - 1 - fromIntegral i)) 619testIdBit bs i = testBit bs (fromIntegral (finiteBitSize bs - 1 - fromIntegral i))
553{-# INLINE testIdBit #-} 620{-# INLINE testIdBit #-}
554 621
622-- | Generate a random 'NodeId' within a range suitable for a bucket. To
623-- obtain a sample for bucket number /index/ where /is_last/ indicates if this
624-- is for the current deepest bucket in our routing table:
625--
626-- > sample <- genBucketSample nid (bucketRange index is_last)
627genBucketSample :: ( FiniteBits nid
628 , Serialize nid
629 ) => nid -> (Int,Word8,Word8) -> IO nid
630genBucketSample n qmb = genBucketSample' getEntropy n qmb
631
632-- | Generalizion of 'genBucketSample' that accepts a byte generator
633-- function to use instead of the system entropy.
634genBucketSample' :: forall m dht nid.
635 ( Applicative m
636 , FiniteBits nid
637 , Serialize nid
638 ) =>
639 (Int -> m ByteString) -> nid -> (Int,Word8,Word8) -> m nid
640genBucketSample' gen self (q,m,b)
641 | q <= 0 = either error id . S.decode <$> gen nodeIdSize
642 | q >= nodeIdSize = pure self
643 | otherwise = either error id . S.decode . build <$> gen (nodeIdSize - q + 1)
644 where
645 nodeIdSize = finiteBitSize (undefined :: nid) `div` 8
646 build tl = BS.init hd <> BS.cons (h .|. t) (BS.tail tl)
647 where
648 hd = BS.take q $ S.encode self
649 h = xor b (complement m .&. BS.last hd)
650 t = m .&. BS.head tl
651
652
555------------------------------------------------------------------------ 653------------------------------------------------------------------------
556 654
557-- | Accepts a depth/index of a bucket and whether or not it is the last one, 655-- | Accepts a depth/index of a bucket and whether or not it is the last one,
@@ -583,11 +681,69 @@ instance BEncode a => BEncode (NodeAddr a) where
583 {-# INLINE fromBEncode #-} 681 {-# INLINE fromBEncode #-}
584#endif 682#endif
585 683
586fromPeerAddr :: PeerAddr -> NodeAddr IP 684
587fromPeerAddr PeerAddr {..} = NodeAddr 685instance Hashable PortNumber where
588 { nodeHost = peerHost 686 hashWithSalt s = hashWithSalt s . fromEnum
589 , nodePort = peerPort 687 {-# INLINE hashWithSalt #-}
590 } 688
689instance Pretty PortNumber where
690 pPrint = PP.int . fromEnum
691 {-# INLINE pPrint #-}
692
693instance Serialize PortNumber where
694 get = fromIntegral <$> getWord16be
695 {-# INLINE get #-}
696 put = putWord16be . fromIntegral
697 {-# INLINE put #-}
698
699instance Pretty IPv4 where
700 pPrint = PP.text . show
701 {-# INLINE pPrint #-}
702
703instance Pretty IPv6 where
704 pPrint = PP.text . show
705 {-# INLINE pPrint #-}
706
707instance Pretty IP where
708 pPrint = PP.text . show
709 {-# INLINE pPrint #-}
710
711
712-- | When 'get'ing an IP it must be 'isolate'd to the appropriate
713-- number of bytes since we have no other way of telling which
714-- address type we are trying to parse
715instance Serialize IP where
716 put (IPv4 ip) = put ip
717 put (IPv6 ip) = put ip
718
719 get = do
720 n <- remaining
721 case n of
722 4 -> IPv4 <$> get
723 16 -> IPv6 <$> get
724 _ -> fail (show n ++ " is the wrong number of remaining bytes to parse IP")
725
726instance Serialize IPv4 where
727 put = putWord32host . toHostAddress
728 get = fromHostAddress <$> getWord32host
729
730instance Serialize IPv6 where
731 put ip = put $ toHostAddress6 ip
732 get = fromHostAddress6 <$> get
733
734
735instance Hashable IPv4 where
736 hashWithSalt = hashUsing toHostAddress
737 {-# INLINE hashWithSalt #-}
738
739instance Hashable IPv6 where
740 hashWithSalt s a = hashWithSalt s (toHostAddress6 a)
741
742instance Hashable IP where
743 hashWithSalt s (IPv4 h) = hashWithSalt s h
744 hashWithSalt s (IPv6 h) = hashWithSalt s h
745
746
591 747
592------------------------------------------------------------------------ 748------------------------------------------------------------------------
593 749
diff --git a/src/Network/BitTorrent/DHT/Search.hs b/src/Network/BitTorrent/DHT/Search.hs
index 12fc29f6..54547211 100644
--- a/src/Network/BitTorrent/DHT/Search.hs
+++ b/src/Network/BitTorrent/DHT/Search.hs
@@ -26,7 +26,6 @@ import qualified Data.MinMaxPSQ as MM
26import qualified Data.Wrapper.PSQ as PSQ 26import qualified Data.Wrapper.PSQ as PSQ
27 ;import Data.Wrapper.PSQ (pattern (:->), Binding, PSQ, PSQKey) 27 ;import Data.Wrapper.PSQ (pattern (:->), Binding, PSQ, PSQKey)
28import Network.Address hiding (NodeId) 28import Network.Address hiding (NodeId)
29import Network.DatagramServer.Types
30import Network.DHT.Routing as R 29import Network.DHT.Routing as R
31#ifdef THREAD_DEBUG 30#ifdef THREAD_DEBUG
32import Control.Concurrent.Lifted.Instrument 31import Control.Concurrent.Lifted.Instrument
diff --git a/src/Network/DatagramServer/Types.hs b/src/Network/DatagramServer/Types.hs
deleted file mode 100644
index 68aa9212..00000000
--- a/src/Network/DatagramServer/Types.hs
+++ /dev/null
@@ -1,412 +0,0 @@
1{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE DeriveFunctor #-}
4{-# LANGUAGE DeriveFoldable #-}
5{-# LANGUAGE DeriveTraversable #-}
6{-# LANGUAGE DefaultSignatures #-}
7{-# LANGUAGE FlexibleInstances #-}
8{-# LANGUAGE FlexibleContexts #-}
9{-# LANGUAGE FunctionalDependencies #-}
10{-# LANGUAGE MultiParamTypeClasses #-}
11{-# LANGUAGE RankNTypes #-}
12{-# LANGUAGE ScopedTypeVariables #-}
13{-# LANGUAGE TupleSections #-}
14{-# LANGUAGE TypeFamilies #-}
15{-# LANGUAGE StandaloneDeriving #-}
16module Network.DatagramServer.Types
17 ( module Network.DatagramServer.Types
18 , module Network.DatagramServer.Error
19 ) where
20
21import Control.Applicative
22import qualified Text.ParserCombinators.ReadP as RP
23import Data.Word
24import Data.Monoid
25import Data.Hashable
26import Data.String
27import Data.Bits
28import Data.ByteString (ByteString)
29import Data.Kind (Constraint)
30import Data.Data
31import Data.Default
32import Data.List.Split
33import Data.Ord
34import Data.IP
35import Network.Socket
36import Text.PrettyPrint as PP hiding ((<>))
37import Text.PrettyPrint.HughesPJClass hiding (($$), (<>))
38import Text.Read (readMaybe, readEither)
39import Data.Serialize as S
40import qualified Data.ByteString.Char8 as Char8
41import qualified Data.ByteString as BS
42import Data.ByteString.Base16 as Base16
43import System.Entropy
44import Network.DatagramServer.Error
45import Data.LargeWord
46import Data.Char
47
48
49class (Eq a, Serialize a, Typeable a, Hashable a, Pretty a)
50 => Address a where
51 toSockAddr :: a -> SockAddr
52 fromSockAddr :: SockAddr -> Maybe a
53
54fromAddr :: (Address a, Address b) => a -> Maybe b
55fromAddr = fromSockAddr . toSockAddr
56
57-- | Note that port is zeroed.
58instance Address IPv4 where
59 toSockAddr = SockAddrInet 0 . toHostAddress
60 fromSockAddr (SockAddrInet _ h) = Just (fromHostAddress h)
61 fromSockAddr _ = Nothing
62
63-- | Note that port is zeroed.
64instance Address IPv6 where
65 toSockAddr h = SockAddrInet6 0 0 (toHostAddress6 h) 0
66 fromSockAddr (SockAddrInet6 _ _ h _) = Just (fromHostAddress6 h)
67 fromSockAddr _ = Nothing
68
69-- | Note that port is zeroed.
70instance Address IP where
71 toSockAddr (IPv4 h) = toSockAddr h
72 toSockAddr (IPv6 h) = toSockAddr h
73 fromSockAddr sa =
74 IPv4 <$> fromSockAddr sa
75 <|> IPv6 <$> fromSockAddr sa
76
77
78
79
80
81newtype ReflectedIP = ReflectedIP SockAddr
82 deriving (Eq, Ord, Show)
83
84-- The MessageClass/MessageClassG duality is merely a way to help GHC derive
85-- instances without having to cope with the QueryMethod and TransactionID type
86-- functions
87type MessageClass msg = MessageClassG (QueryMethod msg) (TransactionID msg)
88data MessageClassG meth tid = Query meth
89 | Response (Maybe ReflectedIP)
90 | Error (KError tid)
91 deriving (Eq,Ord,Show) -- ,Read, Data: not implemented by SockAddr
92
93
94class Envelope envelope where
95 data TransactionID envelope
96 type QueryMethod envelope
97 data NodeId envelope
98 data QueryExtra envelope
99 data ResponseExtra envelope
100 data PacketDestination envelope
101
102 envelopePayload :: envelope a -> a
103 envelopeTransaction :: envelope a -> TransactionID envelope
104 envelopeClass :: envelope a -> MessageClass envelope
105
106 -- | > replyAddress qry addr
107 --
108 -- [ qry ] received query message
109 --
110 -- [ addr ] SockAddr of query origin
111 --
112 -- Returns: Destination address for reply.
113 makeAddress :: Either (NodeId envelope) (envelope a) -> SockAddr -> PacketDestination envelope
114
115 -- | > buildReply self addr qry response
116 --
117 -- [ self ] this node's id.
118 --
119 -- [ addr ] SockAddr of query origin.
120 --
121 -- [ qry ] received query message.
122 --
123 -- [ response ] response payload.
124 --
125 -- Returns: response message envelope
126 buildReply :: NodeId envelope -> SockAddr -> envelope a -> b -> envelope b
127
128 -- This is a abstract constructor and a design wart. Since it returns into
129 -- the IO monad, it allows for outside state to be used in creating
130 -- envelopes.
131 buildQuery :: NodeId envelope -> SockAddr -> QueryMethod envelope -> TransactionID envelope -> a -> IO (envelope a)
132
133 uniqueTransactionId :: Int -> IO (TransactionID envelope)
134
135 fromRoutableNode :: QueryExtra envelope -> Bool
136 fromRoutableNode _ = True
137
138-- | In Kademlia, the distance metric is XOR and the result is
139-- interpreted as an unsigned integer.
140newtype NodeDistance nodeid = NodeDistance nodeid
141 deriving (Eq, Ord)
142
143-- | distance(A,B) = |A xor B| Smaller values are closer.
144distance :: Bits nid => nid -> nid -> NodeDistance nid
145distance a b = NodeDistance $ xor a b
146
147instance Serialize nodeid => Show (NodeDistance nodeid) where
148 show (NodeDistance w) = Char8.unpack $ Base16.encode $ S.encode w
149
150instance Serialize nodeid => Pretty (NodeDistance nodeid) where
151 pPrint n = text $ show n
152
153
154-- | When 'get'ing an IP it must be 'isolate'd to the appropriate
155-- number of bytes since we have no other way of telling which
156-- address type we are trying to parse
157instance Serialize IP where
158 put (IPv4 ip) = put ip
159 put (IPv6 ip) = put ip
160
161 get = do
162 n <- remaining
163 case n of
164 4 -> IPv4 <$> get
165 16 -> IPv6 <$> get
166 _ -> fail (show n ++ " is the wrong number of remaining bytes to parse IP")
167
168instance Serialize IPv4 where
169 put = putWord32host . toHostAddress
170 get = fromHostAddress <$> getWord32host
171
172instance Serialize IPv6 where
173 put ip = put $ toHostAddress6 ip
174 get = fromHostAddress6 <$> get
175
176instance Pretty IPv4 where
177 pPrint = PP.text . show
178 {-# INLINE pPrint #-}
179
180instance Pretty IPv6 where
181 pPrint = PP.text . show
182 {-# INLINE pPrint #-}
183
184instance Pretty IP where
185 pPrint = PP.text . show
186 {-# INLINE pPrint #-}
187
188instance Hashable IPv4 where
189 hashWithSalt = hashUsing toHostAddress
190 {-# INLINE hashWithSalt #-}
191
192instance Hashable IPv6 where
193 hashWithSalt s a = hashWithSalt s (toHostAddress6 a)
194
195instance Hashable IP where
196 hashWithSalt s (IPv4 h) = hashWithSalt s h
197 hashWithSalt s (IPv6 h) = hashWithSalt s h
198
199
200
201
202
203data NodeAddr a = NodeAddr
204 { nodeHost :: !a
205 , nodePort :: {-# UNPACK #-} !PortNumber
206 } deriving (Eq, Ord, Typeable, Functor, Foldable, Traversable)
207
208instance Show a => Show (NodeAddr a) where
209 showsPrec i NodeAddr {..}
210 = showsPrec i nodeHost <> showString ":" <> showsPrec i nodePort
211
212instance Read (NodeAddr IPv4) where
213 readsPrec i = RP.readP_to_S $ do
214 ipv4 <- RP.readS_to_P (readsPrec i)
215 _ <- RP.char ':'
216 port <- toEnum <$> RP.readS_to_P (readsPrec i)
217 return $ NodeAddr ipv4 port
218
219-- | @127.0.0.1:6882@
220instance Default (NodeAddr IPv4) where
221 def = "127.0.0.1:6882"
222
223-- | KRPC compatible encoding.
224instance Serialize a => Serialize (NodeAddr a) where
225 get = NodeAddr <$> get <*> get
226 {-# INLINE get #-}
227 put NodeAddr {..} = put nodeHost >> put nodePort
228 {-# INLINE put #-}
229
230-- | Example:
231--
232-- @nodePort \"127.0.0.1:6881\" == 6881@
233--
234instance IsString (NodeAddr IPv4) where
235 fromString str
236 | [hostAddrStr, portStr] <- splitWhen (== ':') str
237 , Just hostAddr <- readMaybe hostAddrStr
238 , Just portNum <- toEnum <$> readMaybe portStr
239 = NodeAddr hostAddr portNum
240 | otherwise = error $ "fromString: unable to parse (NodeAddr IPv4): " ++ str
241
242instance Hashable PortNumber where
243 hashWithSalt s = hashWithSalt s . fromEnum
244 {-# INLINE hashWithSalt #-}
245
246instance Pretty PortNumber where
247 pPrint = PP.int . fromEnum
248 {-# INLINE pPrint #-}
249
250
251instance Hashable a => Hashable (NodeAddr a) where
252 hashWithSalt s NodeAddr {..} = hashWithSalt s (nodeHost, nodePort)
253 {-# INLINE hashWithSalt #-}
254
255instance Pretty ip => Pretty (NodeAddr ip) where
256 pPrint NodeAddr {..} = pPrint nodeHost <> ":" <> pPrint nodePort
257
258
259instance Serialize PortNumber where
260 get = fromIntegral <$> getWord16be
261 {-# INLINE get #-}
262 put = putWord16be . fromIntegral
263 {-# INLINE put #-}
264
265
266
267
268data NodeInfo dht addr u = NodeInfo
269 { nodeId :: !(NodeId dht)
270 , nodeAddr :: !(NodeAddr addr)
271 , nodeAnnotation :: u
272 } deriving (Functor, Foldable, Traversable)
273
274deriving instance ( Show (NodeId dht)
275 , Show addr
276 , Show u ) => Show (NodeInfo dht addr u)
277
278hexdigit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'f') || ( 'A' <= c && c <= 'F')
279
280instance ( FiniteBits (NodeId dht)
281 , Read (NodeId dht)
282 , Read (NodeAddr addr)
283 , Default u
284 ) => Read (NodeInfo dht addr u) where
285 readsPrec i = RP.readP_to_S $ do
286 RP.skipSpaces
287 let n = finiteBitSize (undefined :: NodeId dht) `div` 4
288 hexhash <- sequence $ replicate n (RP.satisfy hexdigit)
289 RP.char '@' RP.+++ RP.satisfy isSpace
290 addrstr <- RP.between (RP.char '(') (RP.char ')') (RP.munch (/=')'))
291 RP.+++ RP.munch (not . isSpace)
292 addr <- either fail return $ readEither addrstr
293 nid <- either fail return $ readEither hexhash
294 return $ NodeInfo nid addr def
295
296
297
298mapAddress :: (addr -> b) -> NodeInfo dht addr u -> NodeInfo dht b u
299mapAddress f ni = ni { nodeAddr = fmap f (nodeAddr ni) }
300
301traverseAddress :: Applicative f => (addr -> f b) -> NodeInfo dht addr u -> f (NodeInfo dht b u)
302traverseAddress f ni = fmap (\addr -> ni { nodeAddr = addr }) $ traverse f (nodeAddr ni)
303
304-- Warning: Eq and Ord only look at the nodeId field.
305instance Eq (NodeId dht) => Eq (NodeInfo dht a u) where
306 a == b = (nodeId a == nodeId b)
307
308instance Ord (NodeId dht) => Ord (NodeInfo dht a u) where
309 compare = comparing nodeId
310
311
312-- TODO WARN is the 'system' random suitable for this?
313-- | Generate random NodeID used for the entire session.
314-- Distribution of ID's should be as uniform as possible.
315--
316genNodeId :: forall dht.
317 ( Serialize (NodeId dht)
318 , FiniteBits (NodeId dht)
319 ) => IO (NodeId dht)
320genNodeId = either error id . S.decode <$> getEntropy nodeIdSize
321 where
322 nodeIdSize = finiteBitSize (undefined :: NodeId dht) `div` 8
323
324-- | Generate a random 'NodeId' within a range suitable for a bucket. To
325-- obtain a sample for bucket number /index/ where /is_last/ indicates if this
326-- is for the current deepest bucket in our routing table:
327--
328-- > sample <- genBucketSample nid (bucketRange index is_last)
329genBucketSample :: ( FiniteBits nid
330 , Serialize nid
331 ) => nid -> (Int,Word8,Word8) -> IO nid
332genBucketSample n qmb = genBucketSample' getEntropy n qmb
333
334-- | Generalizion of 'genBucketSample' that accepts a byte generator
335-- function to use instead of the system entropy.
336genBucketSample' :: forall m dht nid.
337 ( Applicative m
338 , FiniteBits nid
339 , Serialize nid
340 ) =>
341 (Int -> m ByteString) -> nid -> (Int,Word8,Word8) -> m nid
342genBucketSample' gen self (q,m,b)
343 | q <= 0 = either error id . S.decode <$> gen nodeIdSize
344 | q >= nodeIdSize = pure self
345 | otherwise = either error id . S.decode . build <$> gen (nodeIdSize - q + 1)
346 where
347 nodeIdSize = finiteBitSize (undefined :: nid) `div` 8
348 build tl = BS.init hd <> BS.cons (h .|. t) (BS.tail tl)
349 where
350 hd = BS.take q $ S.encode self
351 h = xor b (complement m .&. BS.last hd)
352 t = m .&. BS.head tl
353
354class (Envelope envelope, Address (PacketDestination envelope)) => WireFormat raw envelope where
355 type SerializableTo raw :: * -> Constraint
356 type CipherContext raw envelope
357
358 parsePacket :: Proxy envelope -> ByteString -> Either String raw
359
360 default parsePacket :: raw ~ ByteString => Proxy envelope -> ByteString -> Either String ByteString
361 parsePacket _ = Right
362
363 buildError :: KError (TransactionID envelope) -> Maybe (envelope raw)
364 buildError _ = Nothing
365
366 decodeHeaders :: CipherContext raw envelope -> raw -> Either String (envelope raw)
367 decodePayload :: SerializableTo raw a => envelope raw -> Either String (envelope a)
368
369 encodeHeaders :: CipherContext raw envelope -> envelope raw -> PacketDestination envelope -> ByteString
370 encodePayload :: SerializableTo raw a => envelope a -> envelope raw
371
372 initializeServerState :: Proxy (envelope raw) -> Maybe (NodeId envelope) -> IO (NodeId envelope, CipherContext raw envelope)
373
374
375encodeHexDoc :: Serialize x => x -> Doc
376encodeHexDoc nid = PP.text $ Char8.unpack $ Base16.encode $ S.encode nid
377
378decodeHex :: Serialize x => String -> [(x,String)]
379decodeHex s = either (const []) (pure . (, Char8.unpack ybs)) $ S.decode xbs
380 where
381 (xbs,ybs) = Base16.decode $ Char8.pack s
382
383-- FIXME Orphan Serialize intance for large words
384instance (Serialize a, Serialize b) => Serialize (LargeKey a b) where
385 put (LargeKey lo hi) = put hi >> put lo
386 get = flip LargeKey <$> get <*> get
387
388instance (Pretty ip, Pretty (NodeId dht)) => Pretty (NodeInfo dht ip u) where
389 pPrint NodeInfo {..} = pPrint nodeId <> "@(" <> pPrint nodeAddr <> ")"
390
391instance (Pretty ip, Pretty (NodeId dht)) => Pretty [NodeInfo dht ip u] where
392 pPrint = PP.vcat . PP.punctuate "," . map pPrint
393
394
395
396putSockAddr (SockAddrInet port addr)
397 = put (0x34 :: Word8) >> put port >> put addr
398putSockAddr (SockAddrInet6 port flow addr scope)
399 = put (0x36 :: Word8) >> put port >> put addr >> put scope >> put flow
400putSockAddr (SockAddrUnix path)
401 = put (0x75 :: Word8) >> put path
402putSockAddr (SockAddrCan num)
403 = put (0x63 :: Word8) >> put num
404
405getSockAddr = do
406 c <- get
407 case c :: Word8 of
408 0x34 -> SockAddrInet <$> get <*> get
409 0x36 -> (\p a s f -> SockAddrInet6 p f a s) <$> get <*> get <*> get <*> get
410 0x75 -> SockAddrUnix <$> get
411 0x63 -> SockAddrCan <$> get
412 _ -> fail "getSockAddr"