diff options
author | joe <joe@jerkface.net> | 2017-07-13 18:42:20 -0400 |
---|---|---|
committer | joe <joe@jerkface.net> | 2017-07-13 18:42:20 -0400 |
commit | adc30fe62736d1f4f539a971db681b0a5c552871 (patch) | |
tree | 411c9235f55bfe1b192b73c2a6cb7524a7e3a152 | |
parent | 36562749e2204da4500742c7f62676c19f0ce999 (diff) |
Removed type argument clutter from Routing table.
-rw-r--r-- | src/Network/DHT/Routing.hs | 264 | ||||
-rw-r--r-- | src/Network/DatagramServer/Types.hs | 16 |
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 #-} |
25 | module Network.DHT.Routing | 25 | module 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 | ||
66 | import Control.Applicative as A | 67 | import Control.Applicative as A |
67 | import Control.Arrow | 68 | import Control.Arrow |
@@ -85,11 +86,6 @@ import Data.Bits | |||
85 | 86 | ||
86 | import Network.Address | 87 | import 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 | -- |
108 | type Timestamp = POSIXTime | 104 | type 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. |
123 | type NodeEntry dht ip u = Binding (NodeInfo dht ip u) Timestamp | 120 | type NodeEntry ni = Binding ni Timestamp |
124 | |||
125 | -- TODO instance Pretty where | ||
126 | 121 | ||
127 | -- | Number of nodes in a bucket. | ||
128 | type 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. |
132 | defaultBucketSize :: BucketSize | 125 | defaultBucketSize :: Int |
133 | defaultBucketSize = 8 | 126 | defaultBucketSize = 8 |
134 | 127 | ||
135 | data QueueMethods m elem fifo = QueueMethods | 128 | data QueueMethods m elem fifo = QueueMethods |
@@ -151,7 +144,7 @@ fromQ embed project QueueMethods{..} = | |||
151 | } | 144 | } |
152 | -} | 145 | -} |
153 | 146 | ||
154 | seqQ :: QueueMethods Identity (NodeInfo dht ip u) (Seq.Seq (NodeInfo dht ip u)) | 147 | seqQ :: QueueMethods Identity ni (Seq.Seq ni) |
155 | seqQ = QueueMethods | 148 | seqQ = 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 | ||
163 | type BucketQueue dht ip u = Seq.Seq (NodeInfo dht ip u) | 156 | type BucketQueue ni = Seq.Seq ni |
164 | 157 | ||
165 | bucketQ :: QueueMethods Identity (NodeInfo dht ip u) (BucketQueue dht ip u) | 158 | bucketQ :: QueueMethods Identity ni (BucketQueue ni) |
166 | bucketQ = seqQ | 159 | bucketQ = 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 | -- |
175 | data Bucket dht ip u = Bucket { bktNodes :: !(PSQ (NodeInfo dht ip u) Timestamp) | 169 | data Bucket ni = Bucket { bktNodes :: !(PSQ ni Timestamp) |
176 | , bktQ :: !(BucketQueue dht ip u) | 170 | , bktQ :: !(BucketQueue ni) |
177 | } deriving Generic | 171 | } deriving Generic |
172 | |||
173 | deriving instance Show ni => Show (Bucket ni) | ||
174 | |||
178 | 175 | ||
179 | deriving instance (Show ip, Show u, Show (NodeId dht)) => Show (Bucket dht ip u) | ||
180 | 176 | ||
177 | #if 0 | ||
181 | 178 | ||
182 | getGenericNode :: ( Serialize (NodeId dht) | 179 | {- |
180 | getGenericNode :: ( Serialize (NodeId) | ||
183 | , Serialize ip | 181 | , Serialize ip |
184 | , Serialize u | 182 | , Serialize u |
185 | ) => Get (NodeInfo dht ip u) | 183 | ) => Get (NodeInfo) |
186 | getGenericNode = do | 184 | getGenericNode = 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 | ||
196 | putGenericNode :: ( Serialize (NodeId dht) | 194 | putGenericNode :: ( Serialize (NodeId) |
197 | , Serialize ip | 195 | , Serialize ip |
198 | , Serialize u | 196 | , Serialize u |
199 | ) => NodeInfo dht ip u -> Put | 197 | ) => NodeInfo -> Put |
200 | putGenericNode (NodeInfo nid naddr u) = do | 198 | putGenericNode (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 | ||
205 | instance (Eq ip, Ord (NodeId dht), Serialize (NodeId dht), Serialize ip, Serialize u) => Serialize (Bucket dht ip u) where | 203 | instance (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 | ||
210 | psqFromPairList :: (Ord p, Ord k) => [(k, p)] -> OrdPSQ k p () | 210 | psqFromPairList :: (Ord p, Ord k) => [(k, p)] -> OrdPSQ k p () |
211 | psqFromPairList xs = PSQ.fromList $ map (\(a,b) -> a :-> b) xs | 211 | psqFromPairList 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. |
223 | insertBucket :: (Eq ip, Alternative f, Ord (NodeId dht)) => Timestamp -> Event dht ip u -> Bucket dht ip u | 223 | insertBucket :: (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) |
225 | insertBucket curTime (TryInsert info) bucket | 225 | insertBucket 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 | ||
275 | updateStamps :: ( Eq ip | ||
276 | , Ord (NodeId dht) | ||
277 | ) => Timestamp -> [NodeInfo dht ip u] -> PSQ (NodeInfo dht ip u) Timestamp -> PSQ (NodeInfo dht ip u) Timestamp | ||
278 | updateStamps curTime stales nodes = foldl' (\q n -> PSQ.insert n curTime q) nodes stales | ||
279 | 275 | ||
276 | updateStamps :: Ord ni => Timestamp -> [ni] -> PSQ ni Timestamp -> PSQ ni Timestamp | ||
277 | updateStamps curTime stales nodes = foldl' (\q n -> PSQ.insert n curTime q) nodes stales | ||
280 | 278 | ||
281 | type BitIx = Word | 279 | type 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 | ||
299 | split :: forall dht ip u. | 297 | |
300 | ( Eq ip | 298 | |
301 | , Ord (NodeId dht) | 299 | split :: -- ( 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) |
304 | split i b = (Bucket ns qs, Bucket ms rs) | 302 | -> BitIx -> Bucket ni -> (Bucket ni, Bucket ni) |
303 | split 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. | 316 | defaultBucketCount :: Int |
321 | type BucketCount = Int | ||
322 | |||
323 | defaultBucketCount :: BucketCount | ||
324 | defaultBucketCount = 20 | 317 | defaultBucketCount = 20 |
325 | 318 | ||
326 | data Info dht ip u = Info | 319 | data 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 | ||
333 | deriving instance (Eq ip, Eq u, Eq (NodeId dht)) => Eq (Info dht ip u) | 326 | deriving instance (Eq ni, Eq nid) => Eq (Info ni nid) |
334 | deriving instance (Show ip, Show u, Show (NodeId dht)) => Show (Info dht ip u) | 327 | deriving 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 | -- |
354 | data Table dht ip u | 347 | data 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 | ||
365 | instance (Eq ip, Eq (NodeId dht)) => Eq (Table dht ip u) where | 358 | instance (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 | |||
368 | instance Serialize NominalDiffTime where | 363 | instance 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 | ||
372 | deriving instance (Show ip, Show u, Show (NodeId dht)) => Show (Table dht ip u) | 367 | #endif |
368 | |||
369 | deriving 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. |
377 | instance (Eq ip, Serialize ip, Ord (NodeId dht), Serialize (NodeId dht), Serialize u) => Serialize (Table dht ip u) | 376 | instance (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. |
380 | instance Pretty (Table dht ip u) where | 381 | instance 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. |
391 | nullTable :: Eq ip => NodeId dht -> BucketCount -> Table dht ip u | 392 | nullTable :: nid -> Int -> Table ni nid |
392 | nullTable nid n = Tip nid (bucketCount (pred n)) (Bucket PSQ.empty (runIdentity $ emptyQueue bucketQ)) | 393 | nullTable 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'. |
398 | null :: Table dht ip u -> Bool | 401 | null :: Table -> Bool |
399 | null (Tip _ _ b) = PSQ.null $ bktNodes b | 402 | null (Tip _ _ b) = PSQ.null $ bktNodes b |
400 | null _ = False | 403 | null _ = 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. |
404 | full :: Table dht ip u -> Bool | 407 | full :: Table -> Bool |
405 | full (Tip _ n _) = n == 0 | 408 | full (Tip _ n _) = n == 0 |
406 | full (Zero t b) = PSQ.size (bktNodes b) == defaultBucketSize && full t | 409 | full (Zero t b) = PSQ.size (bktNodes b) == defaultBucketSize && full t |
407 | full (One b t) = PSQ.size (bktNodes b) == defaultBucketSize && full t | 410 | full (One b t) = PSQ.size (bktNodes b) == defaultBucketSize && full t |
408 | 411 | ||
409 | -- | Get the /spine/ node id. | 412 | -- | Get the /spine/ node id. |
410 | thisId :: Table dht ip u -> NodeId dht | 413 | thisId :: Table -> NodeId |
411 | thisId (Tip nid _ _) = nid | 414 | thisId (Tip nid _ _) = nid |
412 | thisId (Zero table _) = thisId table | 415 | thisId (Zero table _) = thisId table |
413 | thisId (One _ table) = thisId table | 416 | thisId (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. |
416 | type NodeCount = Int | 419 | type 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. |
420 | shape :: Table dht ip u -> [BucketSize] | 425 | shape :: Table ni nid -> [Int] |
421 | shape = map (PSQ.size . bktNodes) . toBucketList | 426 | shape = 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. |
424 | size :: Table dht ip u -> NodeCount | 431 | size :: Table -> NodeCount |
425 | size = L.sum . shape | 432 | size = L.sum . shape |
426 | 433 | ||
427 | -- | Get number of buckets in the table. | 434 | -- | Get number of buckets in the table. |
428 | depth :: Table dht ip u -> BucketCount | 435 | depth :: Table -> BucketCount |
429 | depth = L.length . shape | 436 | depth = L.length . shape |
430 | 437 | ||
431 | lookupBucket :: ( FiniteBits (NodeId dht) | 438 | lookupBucket :: ( FiniteBits (NodeId) |
432 | ) => NodeId dht -> Table dht ip u -> [Bucket dht ip u] | 439 | ) => NodeId -> Table -> [Bucket] |
433 | lookupBucket nid = go 0 [] | 440 | lookupBucket 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 | ||
443 | compatibleNodeId :: forall dht ip u. | 450 | #endif |
444 | ( Serialize (NodeId dht) | 451 | |
445 | , FiniteBits (NodeId dht) | 452 | compatibleNodeId :: forall ni nid. |
446 | ) => Table dht ip u -> IO (NodeId dht) | 453 | ( Serialize nid, FiniteBits nid) => |
454 | Table ni nid -> IO nid | ||
447 | compatibleNodeId tbl = genBucketSample prefix br | 455 | compatibleNodeId 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 | ||
454 | tablePrefix :: Table dht ip u -> [Word8] | 462 | tablePrefix :: Table ni nid -> [Word8] |
455 | tablePrefix = map (packByte . take 8 . (++repeat False)) | 463 | tablePrefix = 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 | ||
463 | tableBits :: Table dht ip u -> [Bool] | 471 | tableBits :: Table ni nid -> [Bool] |
464 | tableBits (One _ tbl) = True : tableBits tbl | 472 | tableBits (One _ tbl) = True : tableBits tbl |
465 | tableBits (Zero tbl _) = False : tableBits tbl | 473 | tableBits (Zero tbl _) = False : tableBits tbl |
466 | tableBits (Tip _ _ _) = [] | 474 | tableBits (Tip _ _ _) = [] |
@@ -474,6 +482,9 @@ chunksOf i ls = map (take i) (build (splitter ls)) where | |||
474 | build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] | 482 | build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] |
475 | build g = g (:) [] | 483 | build 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. |
478 | type K = Int | 489 | type K = Int |
479 | 490 | ||
@@ -482,17 +493,17 @@ defaultK :: K | |||
482 | defaultK = 8 | 493 | defaultK = 8 |
483 | 494 | ||
484 | class TableKey dht k where | 495 | class TableKey dht k where |
485 | toNodeId :: k -> NodeId dht | 496 | toNodeId :: k -> NodeId |
486 | 497 | ||
487 | instance TableKey dht (NodeId dht) where | 498 | instance 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. |
492 | kclosest :: ( Eq ip | 503 | kclosest :: ( 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] |
496 | kclosest k (toNodeId -> nid) tbl = take k $ rank nodeId nid (L.concat bucket) | 507 | kclosest 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 | ||
509 | splitTip :: ( Eq ip | 522 | splitTip :: -- ( 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) |
513 | splitTip nid n i bucket | 526 | -> nid -> Int -> BitIx -> Bucket ni -> Table ni nid |
527 | splitTip 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. |
524 | modifyBucket | 538 | modifyBucket |
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) | 544 | modifyBucket testIdBit testNodeBit nodeId f = go (0 :: BitIx) |
531 | modifyBucket 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 |
546 | data Event dht ip u = TryInsert { foreignNode :: NodeInfo dht ip u } | 560 | data 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 |
550 | deriving instance Eq (NodeId dht) => Eq (Event dht ip u) | 564 | deriving instance Eq (NodeId) => Eq (Event) |
551 | deriving instance ( Show ip | 565 | deriving 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 | |||
572 | eventId :: (ni -> nid) -> Event ni -> nid | ||
573 | eventId nodeId (TryInsert ni) = nodeId ni | ||
574 | eventId nodeId (PingResult ni _) = nodeId ni | ||
555 | 575 | ||
556 | eventId :: Event dht ip u -> NodeId dht | ||
557 | eventId (TryInsert NodeInfo{..}) = nodeId | ||
558 | eventId (PingResult NodeInfo{..} _) = nodeId | ||
559 | 576 | ||
560 | -- | Actions requested by atomic table update | 577 | -- | Actions requested by atomic table update |
561 | data CheckPing dht ip u = CheckPing [NodeInfo dht ip u] | 578 | data CheckPing ni = CheckPing [ni] |
579 | |||
580 | #if 0 | ||
562 | 581 | ||
563 | deriving instance Eq (NodeId dht) => Eq (CheckPing dht ip u) | 582 | deriving instance Eq (NodeId) => Eq (CheckPing) |
564 | deriving instance ( Show ip | 583 | deriving 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 |
571 | insert :: ( Eq ip | 591 | insert :: -- ( 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) |
576 | insert tm event tbl = pure $ fromMaybe ([],tbl) $ modifyBucket (eventId event) (insertBucket tm event) tbl | 596 | insert 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 | ||
583 | type TableEntry dht ip u = (NodeInfo dht ip u, Timestamp) | 604 | type TableEntry ni = (ni, Timestamp) |
584 | 605 | ||
585 | tableEntry :: NodeEntry dht ip u -> TableEntry dht ip u | 606 | tableEntry :: NodeEntry ni -> TableEntry ni |
586 | tableEntry (a :-> b) = (a, b) | 607 | tableEntry (a :-> b) = (a, b) |
587 | 608 | ||
588 | -- | Non-empty list of buckets. | 609 | -- | Non-empty list of buckets. |
589 | toBucketList :: Table dht ip u -> [Bucket dht ip u] | 610 | toBucketList :: Table ni nid -> [Bucket ni] |
590 | toBucketList (Tip _ _ b) = [b] | 611 | toBucketList (Tip _ _ b) = [b] |
591 | toBucketList (Zero t b) = b : toBucketList t | 612 | toBucketList (Zero t b) = b : toBucketList t |
592 | toBucketList (One b t) = b : toBucketList t | 613 | toBucketList (One b t) = b : toBucketList t |
593 | 614 | ||
594 | toList :: Eq ip => Table dht ip u -> [[TableEntry dht ip u]] | 615 | toList :: Table ni nid -> [[TableEntry ni]] |
595 | toList = L.map (L.map tableEntry . PSQ.toList . bktNodes) . toBucketList | 616 | toList = 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) |
329 | genBucketSample :: ( FiniteBits (NodeId dht) | 329 | genBucketSample :: ( 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 |
332 | genBucketSample n qmb = genBucketSample' getEntropy n qmb | 332 | genBucketSample 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. |
336 | genBucketSample' :: forall m dht. | 336 | genBucketSample' :: 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 |
342 | genBucketSample' gen self (q,m,b) | 342 | genBucketSample' 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 |