diff options
author | Sam Truzjan <pxqr.sta@gmail.com> | 2013-12-18 22:00:45 +0400 |
---|---|---|
committer | Sam Truzjan <pxqr.sta@gmail.com> | 2013-12-18 22:00:45 +0400 |
commit | 4b5b7b56445fe2521e89146b2761de6b7534e59d (patch) | |
tree | 2cab54daaf84e87ba3c9e2db67309c560c6a6f76 /src/Data/Kademlia/Routing/Table.hs | |
parent | 8bff89d4dd6354288c8b01395bcf6103c6edfe19 (diff) |
Add the new purified routing table
Diffstat (limited to 'src/Data/Kademlia/Routing/Table.hs')
-rw-r--r-- | src/Data/Kademlia/Routing/Table.hs | 182 |
1 files changed, 0 insertions, 182 deletions
diff --git a/src/Data/Kademlia/Routing/Table.hs b/src/Data/Kademlia/Routing/Table.hs deleted file mode 100644 index b3b2a655..00000000 --- a/src/Data/Kademlia/Routing/Table.hs +++ /dev/null | |||
@@ -1,182 +0,0 @@ | |||
1 | -- | | ||
2 | -- Copyright : (c) Sam Truzjan 2013 | ||
3 | -- License : BSD3 | ||
4 | -- Maintainer : pxqr.sta@gmail.com | ||
5 | -- Stability : experimental | ||
6 | -- Portability : portable | ||
7 | -- | ||
8 | {-# LANGUAGE RecordWildCards #-} | ||
9 | module Data.Kademlia.Routing.Table | ||
10 | ( Table(nodeID) | ||
11 | ) where | ||
12 | |||
13 | import Control.Applicative hiding (empty) | ||
14 | import Data.Bits | ||
15 | import Data.List as L hiding (insert) | ||
16 | import Data.Maybe | ||
17 | |||
18 | {----------------------------------------------------------------------- | ||
19 | Bucket | ||
20 | -----------------------------------------------------------------------} | ||
21 | |||
22 | type Size = Int | ||
23 | |||
24 | -- | Bucket is kept sorted by time last seen — least-recently seen | ||
25 | -- node at the head, most-recently seen at the tail. Reason: when we | ||
26 | -- insert a node into the bucket we first filter nodes with smaller | ||
27 | -- lifetime since they more likely leave network and we more likely | ||
28 | -- don't reach list end. This should reduce list traversal, we don't | ||
29 | -- need to reverse list in insertion routines. | ||
30 | -- | ||
31 | -- Bucket is also limited in its length — thus it's called k-bucket. | ||
32 | -- When bucket becomes full we should split it in two lists by | ||
33 | -- current span bit. Span bit is defined by depth in the routing | ||
34 | -- table tree. Size of the bucket should be choosen such that it's | ||
35 | -- very unlikely that all nodes in bucket fail within an hour of | ||
36 | -- each other. | ||
37 | -- | ||
38 | data Bucket = Empty | ||
39 | | Cons {-# UNPACK #-} !NodeAddr {-# UNPACK #-} !TimeStamp !Bucket | ||
40 | |||
41 | -- | Gives /current/ size of bucket. | ||
42 | -- | ||
43 | -- forall bucket. size bucket <= maxSize bucket | ||
44 | -- | ||
45 | size :: Bucket k v -> Size | ||
46 | size = L.length . kvs | ||
47 | |||
48 | isFull :: Bucket k v -> Bool | ||
49 | isFull Bucket {..} = L.length kvs == maxSize | ||
50 | |||
51 | member :: Eq k => k -> Bucket k v -> Bool | ||
52 | member k = elem k . map fst . kvs | ||
53 | |||
54 | empty :: Size -> Bucket k v | ||
55 | empty s = Bucket (max 0 s) [] | ||
56 | |||
57 | singleton :: Size -> k -> v -> Bucket k v | ||
58 | singleton s k v = Bucket (max 1 s) [(k, v)] | ||
59 | |||
60 | |||
61 | -- | Increase size of a given bucket. | ||
62 | enlarge :: Size -> Bucket k v -> Bucket k v | ||
63 | enlarge additional b = b { maxSize = maxSize b + additional } | ||
64 | |||
65 | split :: Bits k => Int -> Bucket k v -> (Bucket k v, Bucket k v) | ||
66 | split index Bucket {..} = | ||
67 | let (far, near) = partition spanBit kvs | ||
68 | in (Bucket maxSize near, Bucket maxSize far) | ||
69 | where | ||
70 | spanBit = (`testBit` index) . fst | ||
71 | |||
72 | |||
73 | -- move elem to the end in one traversal | ||
74 | moveToEnd :: Eq k => (k, v) -> Bucket k v -> Bucket k v | ||
75 | moveToEnd kv@(k, _) b = b { kvs = go (kvs b) } | ||
76 | where | ||
77 | go [] = [] | ||
78 | go (x : xs) | ||
79 | | fst x == k = xs ++ [kv] | ||
80 | | otherwise = x : go xs | ||
81 | |||
82 | insertToEnd :: (k, v) -> Bucket k v -> Bucket k v | ||
83 | insertToEnd kv b = b { kvs = kvs b ++ [kv] } | ||
84 | |||
85 | -- | * If the info already exists in bucket then move it to the end. | ||
86 | -- | ||
87 | -- * If bucket is not full then insert the info to the end. | ||
88 | -- | ||
89 | -- * If bucket is full then ping the least recently seen node. | ||
90 | -- Here we have a choice: | ||
91 | -- | ||
92 | -- If node respond then move it the end and discard node | ||
93 | -- we want to insert. | ||
94 | -- | ||
95 | -- If not remove it from the bucket and add the | ||
96 | -- (we want to insert) node to the end. | ||
97 | -- | ||
98 | insert :: Applicative f => Eq k | ||
99 | => (v -> f Bool) -- ^ Ping RPC | ||
100 | -> (k, v) -> Bucket k v -> f (Bucket k v) | ||
101 | |||
102 | insert ping new bucket@(Bucket {..}) | ||
103 | | fst new `member` bucket = pure (new `moveToEnd` bucket) | ||
104 | | size bucket < maxSize = pure (new `insertToEnd` bucket) | ||
105 | | least : rest <- kvs = | ||
106 | let select alive = if alive then least else new | ||
107 | mk most = Bucket maxSize (rest ++ [most]) | ||
108 | in mk . select <$> ping (snd least) | ||
109 | where | ||
110 | -- | otherwise = pure bucket | ||
111 | -- WARN: or maybe error "insertBucket: max size should not be 0" ? | ||
112 | |||
113 | lookup :: k -> Bucket k v -> Maybe v | ||
114 | lookup = undefined | ||
115 | |||
116 | closest :: Int -> k -> Bucket k v -> [(k, v)] | ||
117 | closest = undefined | ||
118 | |||
119 | -- | Most clients use this value for maximum bucket size. | ||
120 | defaultBucketSize :: Int | ||
121 | defaultBucketSize = 20 | ||
122 | |||
123 | {----------------------------------------------------------------------- | ||
124 | Tree | ||
125 | -----------------------------------------------------------------------} | ||
126 | |||
127 | -- | Routing tree should contain key -> value pairs in this way: | ||
128 | -- | ||
129 | -- * More keys that near to our node key, and less keys that far | ||
130 | -- from our node key. | ||
131 | -- | ||
132 | -- * Tree might be saturated. If this happen we can only update | ||
133 | -- buckets, but we can't add new buckets. | ||
134 | -- | ||
135 | -- Instead of using ordinary binary tree and keep track is it | ||
136 | -- following restrictions above (that's somewhat non-trivial) we | ||
137 | -- store distance -> value keys. This lead to simple data structure | ||
138 | -- that actually isomorphic to non-empty list. So we first map our | ||
139 | -- keys to distances using our node ID and store them in tree. When | ||
140 | -- we need to extract a pair we map distances to keys back, again | ||
141 | -- using our node ID. This normalization happen in routing table. | ||
142 | -- | ||
143 | data Tree k v | ||
144 | = Tip (Bucket k v) | ||
145 | | Bin (Tree k v) (Bucket k v) | ||
146 | |||
147 | empty :: Int -> Tree k v | ||
148 | empty = Tip . Bucket.empty | ||
149 | |||
150 | insert :: Applicative f => Bits k | ||
151 | => (v -> f Bool) -> (k, v) -> Tree k v -> f (Tree k v) | ||
152 | insert ping (k, v) = go 0 | ||
153 | where | ||
154 | go n (Tip bucket) | ||
155 | | isFull bucket, (near, far) <- split n bucket | ||
156 | = pure (Tip near `Bin` far) | ||
157 | | otherwise = Tip <$> Bucket.insert ping (k, v) bucket | ||
158 | |||
159 | go n (Bin near far) | ||
160 | | k `testBit` n = Bin <$> pure near <*> Bucket.insert ping (k, v) far | ||
161 | | otherwise = Bin <$> go (succ n) near <*> pure far | ||
162 | |||
163 | {----------------------------------------------------------------------- | ||
164 | Table | ||
165 | -----------------------------------------------------------------------} | ||
166 | |||
167 | data Table k v = Table { | ||
168 | routeTree :: Tree k v | ||
169 | |||
170 | -- | Set degree of parallelism in node lookup calls. | ||
171 | , alpha :: Int | ||
172 | , nodeID :: k | ||
173 | } | ||
174 | |||
175 | --insert :: NodeID -> Table -> Table | ||
176 | --insert x t = undefined | ||
177 | |||
178 | --closest :: InfoHash -> Table -> [NodeID] | ||
179 | --closest = undefined | ||
180 | |||
181 | -- TODO table serialization: usually we need to save table between | ||
182 | -- target program executions for bootstrapping | ||