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