summaryrefslogtreecommitdiff
path: root/src/Network
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network')
-rw-r--r--src/Network/DHT/Routing.hs264
-rw-r--r--src/Network/DatagramServer/Types.hs16
2 files changed, 151 insertions, 129 deletions
diff --git a/src/Network/DHT/Routing.hs b/src/Network/DHT/Routing.hs
index 5c6abe5d..34d8385f 100644
--- a/src/Network/DHT/Routing.hs
+++ b/src/Network/DHT/Routing.hs
@@ -23,6 +23,7 @@
23{-# LANGUAGE StandaloneDeriving, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances #-} 23{-# LANGUAGE StandaloneDeriving, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances #-}
24{-# OPTIONS_GHC -fno-warn-orphans #-} 24{-# OPTIONS_GHC -fno-warn-orphans #-}
25module Network.DHT.Routing 25module Network.DHT.Routing
26 {-
26 ( -- * Table 27 ( -- * Table
27 Table 28 Table
28 , Info(..) 29 , Info(..)
@@ -61,7 +62,7 @@ module Network.DHT.Routing
61 62
62 -- * Routing 63 -- * Routing
63 , Timestamp 64 , Timestamp
64 ) where 65 ) -} where
65 66
66import Control.Applicative as A 67import Control.Applicative as A
67import Control.Arrow 68import Control.Arrow
@@ -85,11 +86,6 @@ import Data.Bits
85 86
86import Network.Address 87import Network.Address
87 88
88
89{-----------------------------------------------------------------------
90-- Routing monad
91-----------------------------------------------------------------------}
92
93-- | Last time the node was responding to our queries. 89-- | Last time the node was responding to our queries.
94-- 90--
95-- Not all nodes that we learn about are equal. Some are \"good\" and 91-- Not all nodes that we learn about are equal. Some are \"good\" and
@@ -107,10 +103,11 @@ import Network.Address
107-- 103--
108type Timestamp = POSIXTime 104type Timestamp = POSIXTime
109 105
106
107
110{----------------------------------------------------------------------- 108{-----------------------------------------------------------------------
111 Bucket 109 Bucket
112-----------------------------------------------------------------------} 110-----------------------------------------------------------------------}
113-- TODO: add replacement cache to the bucket
114-- 111--
115-- When a k-bucket is full and a new node is discovered for that 112-- When a k-bucket is full and a new node is discovered for that
116-- k-bucket, the least recently seen node in the k-bucket is 113-- k-bucket, the least recently seen node in the k-bucket is
@@ -120,16 +117,12 @@ type Timestamp = POSIXTime
120-- other words: new nodes are used only when older nodes disappear. 117-- other words: new nodes are used only when older nodes disappear.
121 118
122-- | Timestamp - last time this node is pinged. 119-- | Timestamp - last time this node is pinged.
123type NodeEntry dht ip u = Binding (NodeInfo dht ip u) Timestamp 120type NodeEntry ni = Binding ni Timestamp
124
125-- TODO instance Pretty where
126 121
127-- | Number of nodes in a bucket.
128type BucketSize = Int
129 122
130-- | Maximum number of 'NodeInfo's stored in a bucket. Most clients 123-- | Maximum number of 'NodeInfo's stored in a bucket. Most clients
131-- use this value. 124-- use this value.
132defaultBucketSize :: BucketSize 125defaultBucketSize :: Int
133defaultBucketSize = 8 126defaultBucketSize = 8
134 127
135data QueueMethods m elem fifo = QueueMethods 128data QueueMethods m elem fifo = QueueMethods
@@ -151,7 +144,7 @@ fromQ embed project QueueMethods{..} =
151 } 144 }
152-} 145-}
153 146
154seqQ :: QueueMethods Identity (NodeInfo dht ip u) (Seq.Seq (NodeInfo dht ip u)) 147seqQ :: QueueMethods Identity ni (Seq.Seq ni)
155seqQ = QueueMethods 148seqQ = QueueMethods
156 { pushBack = \e fifo -> pure (fifo Seq.|> e) 149 { pushBack = \e fifo -> pure (fifo Seq.|> e)
157 , popFront = \fifo -> case Seq.viewl fifo of 150 , popFront = \fifo -> case Seq.viewl fifo of
@@ -160,11 +153,12 @@ seqQ = QueueMethods
160 , emptyQueue = pure Seq.empty 153 , emptyQueue = pure Seq.empty
161 } 154 }
162 155
163type BucketQueue dht ip u = Seq.Seq (NodeInfo dht ip u) 156type BucketQueue ni = Seq.Seq ni
164 157
165bucketQ :: QueueMethods Identity (NodeInfo dht ip u) (BucketQueue dht ip u) 158bucketQ :: QueueMethods Identity ni (BucketQueue ni)
166bucketQ = seqQ 159bucketQ = seqQ
167 160
161
168-- | Bucket is also limited in its length — thus it's called k-bucket. 162-- | Bucket is also limited in its length — thus it's called k-bucket.
169-- When bucket becomes full, we should split it in two lists by 163-- When bucket becomes full, we should split it in two lists by
170-- current span bit. Span bit is defined by depth in the routing 164-- current span bit. Span bit is defined by depth in the routing
@@ -172,17 +166,21 @@ bucketQ = seqQ
172-- very unlikely that all nodes in bucket fail within an hour of 166-- very unlikely that all nodes in bucket fail within an hour of
173-- each other. 167-- each other.
174-- 168--
175data Bucket dht ip u = Bucket { bktNodes :: !(PSQ (NodeInfo dht ip u) Timestamp) 169data Bucket ni = Bucket { bktNodes :: !(PSQ ni Timestamp)
176 , bktQ :: !(BucketQueue dht ip u) 170 , bktQ :: !(BucketQueue ni)
177 } deriving Generic 171 } deriving Generic
172
173deriving instance Show ni => Show (Bucket ni)
174
178 175
179deriving instance (Show ip, Show u, Show (NodeId dht)) => Show (Bucket dht ip u)
180 176
177#if 0
181 178
182getGenericNode :: ( Serialize (NodeId dht) 179{-
180getGenericNode :: ( Serialize (NodeId)
183 , Serialize ip 181 , Serialize ip
184 , Serialize u 182 , Serialize u
185 ) => Get (NodeInfo dht ip u) 183 ) => Get (NodeInfo)
186getGenericNode = do 184getGenericNode = do
187 nid <- get 185 nid <- get
188 naddr <- get 186 naddr <- get
@@ -193,19 +191,21 @@ getGenericNode = do
193 , nodeAnnotation = u 191 , nodeAnnotation = u
194 } 192 }
195 193
196putGenericNode :: ( Serialize (NodeId dht) 194putGenericNode :: ( Serialize (NodeId)
197 , Serialize ip 195 , Serialize ip
198 , Serialize u 196 , Serialize u
199 ) => NodeInfo dht ip u -> Put 197 ) => NodeInfo -> Put
200putGenericNode (NodeInfo nid naddr u) = do 198putGenericNode (NodeInfo nid naddr u) = do
201 put nid 199 put nid
202 put naddr 200 put naddr
203 put u 201 put u
204 202
205instance (Eq ip, Ord (NodeId dht), Serialize (NodeId dht), Serialize ip, Serialize u) => Serialize (Bucket dht ip u) where 203instance (Eq ip, Ord (NodeId), Serialize (NodeId), Serialize ip, Serialize u) => Serialize (Bucket) where
206 get = Bucket . psqFromPairList <$> getListOf ( (,) <$> getGenericNode <*> get ) <*> pure (runIdentity $ emptyQueue bucketQ) 204 get = Bucket . psqFromPairList <$> getListOf ( (,) <$> getGenericNode <*> get ) <*> pure (runIdentity $ emptyQueue bucketQ)
207 put = putListOf (\(ni,stamp) -> putGenericNode ni >> put stamp) . psqToPairList . bktNodes 205 put = putListOf (\(ni,stamp) -> putGenericNode ni >> put stamp) . psqToPairList . bktNodes
206-}
208 207
208#endif
209 209
210psqFromPairList :: (Ord p, Ord k) => [(k, p)] -> OrdPSQ k p () 210psqFromPairList :: (Ord p, Ord k) => [(k, p)] -> OrdPSQ k p ()
211psqFromPairList xs = PSQ.fromList $ map (\(a,b) -> a :-> b) xs 211psqFromPairList xs = PSQ.fromList $ map (\(a,b) -> a :-> b) xs
@@ -220,8 +220,8 @@ delta = 15 * 60
220-- | Should maintain a set of stable long running nodes. 220-- | Should maintain a set of stable long running nodes.
221-- 221--
222-- Note: pings are triggerd only when a bucket is full. 222-- Note: pings are triggerd only when a bucket is full.
223insertBucket :: (Eq ip, Alternative f, Ord (NodeId dht)) => Timestamp -> Event dht ip u -> Bucket dht ip u 223insertBucket :: (Alternative f, Ord ni) => -- (Eq ip, Alternative f, Ord (NodeId)) =>
224 -> f ([CheckPing dht ip u], Bucket dht ip u) 224 Timestamp -> Event ni -> Bucket ni -> f ([CheckPing ni], Bucket ni)
225insertBucket curTime (TryInsert info) bucket 225insertBucket curTime (TryInsert info) bucket
226 -- just update timestamp if a node is already in bucket 226 -- just update timestamp if a node is already in bucket
227 | already_have 227 | already_have
@@ -272,11 +272,9 @@ insertBucket curTime (PingResult bad_node got_response) bucket
272 pure $ PSQ.insert info curTime nodes' 272 pure $ PSQ.insert info curTime nodes'
273 | otherwise = id 273 | otherwise = id
274 274
275updateStamps :: ( Eq ip
276 , Ord (NodeId dht)
277 ) => Timestamp -> [NodeInfo dht ip u] -> PSQ (NodeInfo dht ip u) Timestamp -> PSQ (NodeInfo dht ip u) Timestamp
278updateStamps curTime stales nodes = foldl' (\q n -> PSQ.insert n curTime q) nodes stales
279 275
276updateStamps :: Ord ni => Timestamp -> [ni] -> PSQ ni Timestamp -> PSQ ni Timestamp
277updateStamps curTime stales nodes = foldl' (\q n -> PSQ.insert n curTime q) nodes stales
280 278
281type BitIx = Word 279type BitIx = Word
282 280
@@ -296,42 +294,37 @@ partitionQ imp test q0 = do
296 select f = if test e then \(a,b) -> flip (,) b <$> f a 294 select f = if test e then \(a,b) -> flip (,) b <$> f a
297 else \(a,b) -> (,) a <$> f b 295 else \(a,b) -> (,) a <$> f b
298 296
299split :: forall dht ip u. 297
300 ( Eq ip 298
301 , Ord (NodeId dht) 299split :: -- ( Eq ip , Ord (NodeId) , FiniteBits (NodeId)) =>
302 , FiniteBits (NodeId dht) 300 forall ni. Ord ni =>
303 ) => BitIx -> Bucket dht ip u -> (Bucket dht ip u, Bucket dht ip u) 301 (ni -> Word -> Bool)
304split i b = (Bucket ns qs, Bucket ms rs) 302 -> BitIx -> Bucket ni -> (Bucket ni, Bucket ni)
303split testNodeIdBit i b = (Bucket ns qs, Bucket ms rs)
305 where 304 where
306 (ns,ms) = (PSQ.fromList *** PSQ.fromList) . partition (spanBit . key) . PSQ.toList $ bktNodes b 305 (ns,ms) = (PSQ.fromList *** PSQ.fromList) . partition (spanBit . key) . PSQ.toList $ bktNodes b
307 (qs,rs) = runIdentity $ partitionQ bucketQ spanBit $ bktQ b 306 (qs,rs) = runIdentity $ partitionQ bucketQ spanBit $ bktQ b
308 {- 307
309 spanBit :: forall (dht :: * -> *) addr u. 308 spanBit :: ni -> Bool
310 FiniteBits (Network.DatagramServer.Types.NodeId dht) => 309 spanBit entry = testNodeIdBit entry i
311 NodeInfo dht addr u -> Bool 310
312 -}
313 spanBit :: NodeInfo dht addr u -> Bool
314 spanBit entry = testIdBit (nodeId entry) i
315 311
316{----------------------------------------------------------------------- 312{-----------------------------------------------------------------------
317-- Table 313-- Table
318-----------------------------------------------------------------------} 314-----------------------------------------------------------------------}
319 315
320-- | Number of buckets in a routing table. 316defaultBucketCount :: Int
321type BucketCount = Int
322
323defaultBucketCount :: BucketCount
324defaultBucketCount = 20 317defaultBucketCount = 20
325 318
326data Info dht ip u = Info 319data Info ni nid = Info
327 { myBuckets :: Table dht ip u 320 { myBuckets :: Table ni nid
328 , myNodeId :: NodeId dht 321 , myNodeId :: nid
329 , myAddress :: SockAddr 322 , myAddress :: SockAddr
330 } 323 }
331 deriving Generic 324 deriving Generic
332 325
333deriving instance (Eq ip, Eq u, Eq (NodeId dht)) => Eq (Info dht ip u) 326deriving instance (Eq ni, Eq nid) => Eq (Info ni nid)
334deriving instance (Show ip, Show u, Show (NodeId dht)) => Show (Info dht ip u) 327deriving instance (Show ni, Show nid) => Show (Info ni nid)
335 328
336-- instance (Eq ip, Serialize ip) => Serialize (Info ip) 329-- instance (Eq ip, Serialize ip) => Serialize (Info ip)
337 330
@@ -351,33 +344,41 @@ deriving instance (Show ip, Show u, Show (NodeId dht)) => Show (Info dht ip u)
351-- is always split into two new buckets covering the ranges @0..2 ^ 344-- is always split into two new buckets covering the ranges @0..2 ^
352-- 159@ and @2 ^ 159..2 ^ 160@. 345-- 159@ and @2 ^ 159..2 ^ 160@.
353-- 346--
354data Table dht ip u 347data Table ni nid
355 -- most nearest bucket 348 -- most nearest bucket
356 = Tip (NodeId dht) BucketCount (Bucket dht ip u) 349 = Tip nid Int (Bucket ni)
357 350
358 -- left biased tree branch 351 -- left biased tree branch
359 | Zero (Table dht ip u) (Bucket dht ip u) 352 | Zero (Table ni nid) (Bucket ni)
360 353
361 -- right biased tree branch 354 -- right biased tree branch
362 | One (Bucket dht ip u) (Table dht ip u) 355 | One (Bucket ni) (Table ni nid)
363 deriving Generic 356 deriving Generic
364 357
365instance (Eq ip, Eq (NodeId dht)) => Eq (Table dht ip u) where 358instance (Eq ni, Eq nid) => Eq (Table ni nid) where
366 (==) = (==) `on` Network.DHT.Routing.toList 359 (==) = (==) `on` Network.DHT.Routing.toList
367 360
361#if 0
362
368instance Serialize NominalDiffTime where 363instance Serialize NominalDiffTime where
369 put = putWord32be . fromIntegral . fromEnum 364 put = putWord32be . fromIntegral . fromEnum
370 get = (toEnum . fromIntegral) <$> getWord32be 365 get = (toEnum . fromIntegral) <$> getWord32be
371 366
372deriving instance (Show ip, Show u, Show (NodeId dht)) => Show (Table dht ip u) 367#endif
368
369deriving instance (Show ni, Show nid) => Show (Table ni nid)
370
371#if 0
373 372
374-- | Normally, routing table should be saved between invocations of 373-- | Normally, routing table should be saved between invocations of
375-- the client software. Note that you don't need to store /this/ 374-- the client software. Note that you don't need to store /this/
376-- 'NodeId' since it is already included in routing table. 375-- 'NodeId' since it is already included in routing table.
377instance (Eq ip, Serialize ip, Ord (NodeId dht), Serialize (NodeId dht), Serialize u) => Serialize (Table dht ip u) 376instance (Eq ip, Serialize ip, Ord (NodeId), Serialize (NodeId), Serialize u) => Serialize (Table)
377
378#endif
378 379
379-- | Shape of the table. 380-- | Shape of the table.
380instance Pretty (Table dht ip u) where 381instance Pretty (Table ni nid) where
381 pPrint t 382 pPrint t
382 | bucketCount < 6 = hcat $ punctuate ", " $ L.map PP.int ss 383 | bucketCount < 6 = hcat $ punctuate ", " $ L.map PP.int ss
383 | otherwise = brackets $ 384 | otherwise = brackets $
@@ -388,26 +389,28 @@ instance Pretty (Table dht ip u) where
388 ss = shape t 389 ss = shape t
389 390
390-- | Empty table with specified /spine/ node id. 391-- | Empty table with specified /spine/ node id.
391nullTable :: Eq ip => NodeId dht -> BucketCount -> Table dht ip u 392nullTable :: nid -> Int -> Table ni nid
392nullTable nid n = Tip nid (bucketCount (pred n)) (Bucket PSQ.empty (runIdentity $ emptyQueue bucketQ)) 393nullTable nid n = Tip nid (bucketCount (pred n)) (Bucket PSQ.empty (runIdentity $ emptyQueue bucketQ))
393 where 394 where
394 bucketCount x = max 0 (min 159 x) 395 bucketCount x = max 0 (min 159 x)
395 396
397#if 0
398
396-- | Test if table is empty. In this case DHT should start 399-- | Test if table is empty. In this case DHT should start
397-- bootstrapping process until table becomes 'full'. 400-- bootstrapping process until table becomes 'full'.
398null :: Table dht ip u -> Bool 401null :: Table -> Bool
399null (Tip _ _ b) = PSQ.null $ bktNodes b 402null (Tip _ _ b) = PSQ.null $ bktNodes b
400null _ = False 403null _ = False
401 404
402-- | Test if table have maximum number of nodes. No more nodes can be 405-- | Test if table have maximum number of nodes. No more nodes can be
403-- 'insert'ed, except old ones becomes bad. 406-- 'insert'ed, except old ones becomes bad.
404full :: Table dht ip u -> Bool 407full :: Table -> Bool
405full (Tip _ n _) = n == 0 408full (Tip _ n _) = n == 0
406full (Zero t b) = PSQ.size (bktNodes b) == defaultBucketSize && full t 409full (Zero t b) = PSQ.size (bktNodes b) == defaultBucketSize && full t
407full (One b t) = PSQ.size (bktNodes b) == defaultBucketSize && full t 410full (One b t) = PSQ.size (bktNodes b) == defaultBucketSize && full t
408 411
409-- | Get the /spine/ node id. 412-- | Get the /spine/ node id.
410thisId :: Table dht ip u -> NodeId dht 413thisId :: Table -> NodeId
411thisId (Tip nid _ _) = nid 414thisId (Tip nid _ _) = nid
412thisId (Zero table _) = thisId table 415thisId (Zero table _) = thisId table
413thisId (One _ table) = thisId table 416thisId (One _ table) = thisId table
@@ -415,21 +418,25 @@ thisId (One _ table) = thisId table
415-- | Number of nodes in a bucket or a table. 418-- | Number of nodes in a bucket or a table.
416type NodeCount = Int 419type NodeCount = Int
417 420
421#endif
422
418-- | Internally, routing table is similar to list of buckets or a 423-- | Internally, routing table is similar to list of buckets or a
419-- /matrix/ of nodes. This function returns the shape of the matrix. 424-- /matrix/ of nodes. This function returns the shape of the matrix.
420shape :: Table dht ip u -> [BucketSize] 425shape :: Table ni nid -> [Int]
421shape = map (PSQ.size . bktNodes) . toBucketList 426shape = map (PSQ.size . bktNodes) . toBucketList
422 427
428#if 0
429
423-- | Get number of nodes in the table. 430-- | Get number of nodes in the table.
424size :: Table dht ip u -> NodeCount 431size :: Table -> NodeCount
425size = L.sum . shape 432size = L.sum . shape
426 433
427-- | Get number of buckets in the table. 434-- | Get number of buckets in the table.
428depth :: Table dht ip u -> BucketCount 435depth :: Table -> BucketCount
429depth = L.length . shape 436depth = L.length . shape
430 437
431lookupBucket :: ( FiniteBits (NodeId dht) 438lookupBucket :: ( FiniteBits (NodeId)
432 ) => NodeId dht -> Table dht ip u -> [Bucket dht ip u] 439 ) => NodeId -> Table -> [Bucket]
433lookupBucket nid = go 0 [] 440lookupBucket nid = go 0 []
434 where 441 where
435 go i bs (Zero table bucket) 442 go i bs (Zero table bucket)
@@ -440,18 +447,19 @@ lookupBucket nid = go 0 []
440 | otherwise = bucket : toBucketList table ++ bs 447 | otherwise = bucket : toBucketList table ++ bs
441 go _ bs (Tip _ _ bucket) = bucket : bs 448 go _ bs (Tip _ _ bucket) = bucket : bs
442 449
443compatibleNodeId :: forall dht ip u. 450#endif
444 ( Serialize (NodeId dht) 451
445 , FiniteBits (NodeId dht) 452compatibleNodeId :: forall ni nid.
446 ) => Table dht ip u -> IO (NodeId dht) 453 ( Serialize nid, FiniteBits nid) =>
454 Table ni nid -> IO nid
447compatibleNodeId tbl = genBucketSample prefix br 455compatibleNodeId tbl = genBucketSample prefix br
448 where 456 where
449 br = bucketRange (L.length (shape tbl) - 1) True 457 br = bucketRange (L.length (shape tbl) - 1) True
450 nodeIdSize = finiteBitSize (undefined :: NodeId dht) `div` 8 458 nodeIdSize = finiteBitSize (undefined :: nid) `div` 8
451 bs = BS.pack $ take nodeIdSize $ tablePrefix tbl ++ repeat 0 459 bs = BS.pack $ take nodeIdSize $ tablePrefix tbl ++ repeat 0
452 prefix = either error id $ S.decode bs 460 prefix = either error id $ S.decode bs
453 461
454tablePrefix :: Table dht ip u -> [Word8] 462tablePrefix :: Table ni nid -> [Word8]
455tablePrefix = map (packByte . take 8 . (++repeat False)) 463tablePrefix = map (packByte . take 8 . (++repeat False))
456 . chunksOf 8 464 . chunksOf 8
457 . tableBits 465 . tableBits
@@ -460,7 +468,7 @@ tablePrefix = map (packByte . take 8 . (++repeat False))
460 bitmask ix True = bit ix 468 bitmask ix True = bit ix
461 bitmask _ _ = 0 469 bitmask _ _ = 0
462 470
463tableBits :: Table dht ip u -> [Bool] 471tableBits :: Table ni nid -> [Bool]
464tableBits (One _ tbl) = True : tableBits tbl 472tableBits (One _ tbl) = True : tableBits tbl
465tableBits (Zero tbl _) = False : tableBits tbl 473tableBits (Zero tbl _) = False : tableBits tbl
466tableBits (Tip _ _ _) = [] 474tableBits (Tip _ _ _) = []
@@ -474,6 +482,9 @@ chunksOf i ls = map (take i) (build (splitter ls)) where
474build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] 482build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a]
475build g = g (:) [] 483build g = g (:) []
476 484
485#if 0
486
487
477-- | Count of closest nodes in find_node request. 488-- | Count of closest nodes in find_node request.
478type K = Int 489type K = Int
479 490
@@ -482,17 +493,17 @@ defaultK :: K
482defaultK = 8 493defaultK = 8
483 494
484class TableKey dht k where 495class TableKey dht k where
485 toNodeId :: k -> NodeId dht 496 toNodeId :: k -> NodeId
486 497
487instance TableKey dht (NodeId dht) where 498instance TableKey dht (NodeId) where
488 toNodeId = id 499 toNodeId = id
489 500
490-- | Get a list of /K/ closest nodes using XOR metric. Used in 501-- | Get a list of /K/ closest nodes using XOR metric. Used in
491-- 'find_node' and 'get_peers' queries. 502-- 'find_node' and 'get_peers' queries.
492kclosest :: ( Eq ip 503kclosest :: ( Eq ip
493 , Ord (NodeId dht) 504 , Ord (NodeId)
494 , FiniteBits (NodeId dht) 505 , FiniteBits (NodeId)
495 ) => TableKey dht a => K -> a -> Table dht ip u -> [NodeInfo dht ip u] 506 ) => TableKey dht a => K -> a -> Table -> [NodeInfo]
496kclosest k (toNodeId -> nid) tbl = take k $ rank nodeId nid (L.concat bucket) 507kclosest k (toNodeId -> nid) tbl = take k $ rank nodeId nid (L.concat bucket)
497 ++ rank nodeId nid (L.concat everyone) 508 ++ rank nodeId nid (L.concat everyone)
498 where 509 where
@@ -502,19 +513,22 @@ kclosest k (toNodeId -> nid) tbl = take k $ rank nodeId nid (L.concat bucket)
502 . lookupBucket nid 513 . lookupBucket nid
503 $ tbl 514 $ tbl
504 515
516#endif
517
505{----------------------------------------------------------------------- 518{-----------------------------------------------------------------------
506-- Routing 519-- Routing
507-----------------------------------------------------------------------} 520-----------------------------------------------------------------------}
508 521
509splitTip :: ( Eq ip 522splitTip :: -- ( Eq ip , Ord (NodeId) , FiniteBits (NodeId)) =>
510 , Ord (NodeId dht) 523 Ord ni =>
511 , FiniteBits (NodeId dht) 524 (nid -> Word -> Bool)
512 ) => NodeId dht -> BucketCount -> BitIx -> Bucket dht ip u -> Table dht ip u 525 -> (ni -> Word -> Bool)
513splitTip nid n i bucket 526 -> nid -> Int -> BitIx -> Bucket ni -> Table ni nid
527splitTip testIdBit testNodeBit nid n i bucket
514 | testIdBit nid i = (One zeros (Tip nid (pred n) ones)) 528 | testIdBit nid i = (One zeros (Tip nid (pred n) ones))
515 | otherwise = (Zero (Tip nid (pred n) zeros) ones) 529 | otherwise = (Zero (Tip nid (pred n) zeros) ones)
516 where 530 where
517 (ones, zeros) = split i bucket 531 (ones, zeros) = split testNodeBit i bucket
518 532
519-- | Used in each query. 533-- | Used in each query.
520-- 534--
@@ -522,15 +536,14 @@ splitTip nid n i bucket
522-- k nodes in them. Which subtrees I mean is illustrated in Fig 1. of Kademlia 536-- k nodes in them. Which subtrees I mean is illustrated in Fig 1. of Kademlia
523-- paper. The rule requiring additional splits is in section 2.4. 537-- paper. The rule requiring additional splits is in section 2.4.
524modifyBucket 538modifyBucket
525 :: forall xs dht ip u. 539 :: -- ( Eq ip , Ord (NodeId) , FiniteBits (NodeId)) =>
526 ( Eq ip 540 forall ni nid xs. Ord ni =>
527 , Ord (NodeId dht) 541 (nid -> Word -> Bool)
528 , FiniteBits (NodeId dht) 542 -> (ni -> Word -> Bool)
529 ) => 543 -> nid -> (Bucket ni -> Maybe (xs, Bucket ni)) -> Table ni nid -> Maybe (xs,Table ni nid)
530 NodeId dht -> (Bucket dht ip u -> Maybe (xs, Bucket dht ip u)) -> Table dht ip u -> Maybe (xs,Table dht ip u) 544modifyBucket testIdBit testNodeBit nodeId f = go (0 :: BitIx)
531modifyBucket nodeId f = go (0 :: BitIx)
532 where 545 where
533 go :: BitIx -> Table dht ip u -> Maybe (xs, Table dht ip u) 546 go :: BitIx -> Table ni nid -> Maybe (xs, Table ni nid)
534 go !i (Zero table bucket) 547 go !i (Zero table bucket)
535 | testIdBit nodeId i = second (Zero table) <$> f bucket 548 | testIdBit nodeId i = second (Zero table) <$> f bucket
536 | otherwise = second (`Zero` bucket) <$> go (succ i) table 549 | otherwise = second (`Zero` bucket) <$> go (succ i) table
@@ -540,56 +553,65 @@ modifyBucket nodeId f = go (0 :: BitIx)
540 go !i (Tip nid n bucket) 553 go !i (Tip nid n bucket)
541 | n == 0 = second (Tip nid n) <$> f bucket 554 | n == 0 = second (Tip nid n) <$> f bucket
542 | otherwise = second (Tip nid n) <$> f bucket 555 | otherwise = second (Tip nid n) <$> f bucket
543 <|> go i (splitTip nid n i bucket) 556 <|> go i (splitTip testIdBit testNodeBit nid n i bucket)
557
544 558
545-- | Triggering event for atomic table update 559-- | Triggering event for atomic table update
546data Event dht ip u = TryInsert { foreignNode :: NodeInfo dht ip u } 560data Event ni = TryInsert { foreignNode :: ni }
547 | PingResult { foreignNode :: NodeInfo dht ip u 561 | PingResult { foreignNode :: ni , ponged :: Bool }
548 , ponged :: Bool 562
549 } 563#if 0
550deriving instance Eq (NodeId dht) => Eq (Event dht ip u) 564deriving instance Eq (NodeId) => Eq (Event)
551deriving instance ( Show ip 565deriving instance ( Show ip
552 , Show (NodeId dht) 566 , Show (NodeId)
553 , Show u 567 , Show u
554 ) => Show (Event dht ip u) 568 ) => Show (Event)
569
570#endif
571
572eventId :: (ni -> nid) -> Event ni -> nid
573eventId nodeId (TryInsert ni) = nodeId ni
574eventId nodeId (PingResult ni _) = nodeId ni
555 575
556eventId :: Event dht ip u -> NodeId dht
557eventId (TryInsert NodeInfo{..}) = nodeId
558eventId (PingResult NodeInfo{..} _) = nodeId
559 576
560-- | Actions requested by atomic table update 577-- | Actions requested by atomic table update
561data CheckPing dht ip u = CheckPing [NodeInfo dht ip u] 578data CheckPing ni = CheckPing [ni]
579
580#if 0
562 581
563deriving instance Eq (NodeId dht) => Eq (CheckPing dht ip u) 582deriving instance Eq (NodeId) => Eq (CheckPing)
564deriving instance ( Show ip 583deriving instance ( Show ip
565 , Show (NodeId dht) 584 , Show (NodeId)
566 , Show u 585 , Show u
567 ) => Show (CheckPing dht ip u) 586 ) => Show (CheckPing)
568 587
588#endif
569 589
570-- | Atomic 'Table' update 590-- | Atomic 'Table' update
571insert :: ( Eq ip 591insert :: -- ( Eq ip , Applicative m , Ord (NodeId) , FiniteBits (NodeId)) =>
572 , Applicative m 592 (Applicative m, Ord ni) =>
573 , Ord (NodeId dht) 593 (nid -> Word -> Bool)
574 , FiniteBits (NodeId dht) 594 -> (ni -> nid)
575 ) => Timestamp -> Event dht ip u -> Table dht ip u -> m ([CheckPing dht ip u], Table dht ip u) 595 -> Timestamp -> Event ni -> Table ni nid -> m ([CheckPing ni], Table ni nid)
576insert tm event tbl = pure $ fromMaybe ([],tbl) $ modifyBucket (eventId event) (insertBucket tm event) tbl 596insert testIdBit nodeId tm event tbl = pure $ fromMaybe ([],tbl) $ modifyBucket testIdBit (\ni -> testIdBit $ nodeId ni) (eventId nodeId event) (insertBucket tm event) tbl
597
577 598
578 599
579{----------------------------------------------------------------------- 600{-----------------------------------------------------------------------
580-- Conversion 601-- Conversion
581-----------------------------------------------------------------------} 602-----------------------------------------------------------------------}
582 603
583type TableEntry dht ip u = (NodeInfo dht ip u, Timestamp) 604type TableEntry ni = (ni, Timestamp)
584 605
585tableEntry :: NodeEntry dht ip u -> TableEntry dht ip u 606tableEntry :: NodeEntry ni -> TableEntry ni
586tableEntry (a :-> b) = (a, b) 607tableEntry (a :-> b) = (a, b)
587 608
588-- | Non-empty list of buckets. 609-- | Non-empty list of buckets.
589toBucketList :: Table dht ip u -> [Bucket dht ip u] 610toBucketList :: Table ni nid -> [Bucket ni]
590toBucketList (Tip _ _ b) = [b] 611toBucketList (Tip _ _ b) = [b]
591toBucketList (Zero t b) = b : toBucketList t 612toBucketList (Zero t b) = b : toBucketList t
592toBucketList (One b t) = b : toBucketList t 613toBucketList (One b t) = b : toBucketList t
593 614
594toList :: Eq ip => Table dht ip u -> [[TableEntry dht ip u]] 615toList :: Table ni nid -> [[TableEntry ni]]
595toList = L.map (L.map tableEntry . PSQ.toList . bktNodes) . toBucketList 616toList = L.map (L.map tableEntry . PSQ.toList . bktNodes) . toBucketList
617
diff --git a/src/Network/DatagramServer/Types.hs b/src/Network/DatagramServer/Types.hs
index 6aa7aeaa..68aa9212 100644
--- a/src/Network/DatagramServer/Types.hs
+++ b/src/Network/DatagramServer/Types.hs
@@ -326,25 +326,25 @@ genNodeId = either error id . S.decode <$> getEntropy nodeIdSize
326-- is for the current deepest bucket in our routing table: 326-- is for the current deepest bucket in our routing table:
327-- 327--
328-- > sample <- genBucketSample nid (bucketRange index is_last) 328-- > sample <- genBucketSample nid (bucketRange index is_last)
329genBucketSample :: ( FiniteBits (NodeId dht) 329genBucketSample :: ( FiniteBits nid
330 , Serialize (NodeId dht) 330 , Serialize nid
331 ) => NodeId dht -> (Int,Word8,Word8) -> IO (NodeId dht) 331 ) => nid -> (Int,Word8,Word8) -> IO nid
332genBucketSample n qmb = genBucketSample' getEntropy n qmb 332genBucketSample n qmb = genBucketSample' getEntropy n qmb
333 333
334-- | Generalizion of 'genBucketSample' that accepts a byte generator 334-- | Generalizion of 'genBucketSample' that accepts a byte generator
335-- function to use instead of the system entropy. 335-- function to use instead of the system entropy.
336genBucketSample' :: forall m dht. 336genBucketSample' :: forall m dht nid.
337 ( Applicative m 337 ( Applicative m
338 , FiniteBits (NodeId dht) 338 , FiniteBits nid
339 , Serialize (NodeId dht) 339 , Serialize nid
340 ) => 340 ) =>
341 (Int -> m ByteString) -> NodeId dht -> (Int,Word8,Word8) -> m (NodeId dht) 341 (Int -> m ByteString) -> nid -> (Int,Word8,Word8) -> m nid
342genBucketSample' gen self (q,m,b) 342genBucketSample' gen self (q,m,b)
343 | q <= 0 = either error id . S.decode <$> gen nodeIdSize 343 | q <= 0 = either error id . S.decode <$> gen nodeIdSize
344 | q >= nodeIdSize = pure self 344 | q >= nodeIdSize = pure self
345 | otherwise = either error id . S.decode . build <$> gen (nodeIdSize - q + 1) 345 | otherwise = either error id . S.decode . build <$> gen (nodeIdSize - q + 1)
346 where 346 where
347 nodeIdSize = finiteBitSize (undefined :: NodeId dht) `div` 8 347 nodeIdSize = finiteBitSize (undefined :: nid) `div` 8
348 build tl = BS.init hd <> BS.cons (h .|. t) (BS.tail tl) 348 build tl = BS.init hd <> BS.cons (h .|. t) (BS.tail tl)
349 where 349 where
350 hd = BS.take q $ S.encode self 350 hd = BS.take q $ S.encode self