diff options
Diffstat (limited to 'src/Network/BitTorrent/DHT/Routing.hs')
-rw-r--r-- | src/Network/BitTorrent/DHT/Routing.hs | 53 |
1 files changed, 17 insertions, 36 deletions
diff --git a/src/Network/BitTorrent/DHT/Routing.hs b/src/Network/BitTorrent/DHT/Routing.hs index 84e4d4ce..f9d64eea 100644 --- a/src/Network/BitTorrent/DHT/Routing.hs +++ b/src/Network/BitTorrent/DHT/Routing.hs | |||
@@ -144,7 +144,7 @@ instance Alternative (Routing ip) where | |||
144 | Refresh n f <|> m = Refresh n (f <|> m) | 144 | Refresh n f <|> m = Refresh n (f <|> m) |
145 | 145 | ||
146 | -- | Run routing table operation. | 146 | -- | Run routing table operation. |
147 | runRouting :: (Monad m, Eq ip) | 147 | runRouting :: Monad m |
148 | => (NodeAddr ip -> m Bool) -- ^ ping the specific node; | 148 | => (NodeAddr ip -> m Bool) -- ^ ping the specific node; |
149 | -> (NodeId -> m ()) -- ^ refresh nodes; | 149 | -> (NodeId -> m ()) -- ^ refresh nodes; |
150 | -> m Timestamp -- ^ get current time; | 150 | -> m Timestamp -- ^ get current time; |
@@ -166,18 +166,6 @@ runRouting ping_node find_nodes timestamper = go | |||
166 | find_nodes nid | 166 | find_nodes nid |
167 | go f | 167 | go f |
168 | 168 | ||
169 | getTime :: Routing ip Timestamp | ||
170 | getTime = GetTime return | ||
171 | {-# INLINE getTime #-} | ||
172 | |||
173 | needPing :: NodeAddr ip -> Routing ip Bool | ||
174 | needPing addr = NeedPing addr return | ||
175 | {-# INLINE needPing #-} | ||
176 | |||
177 | refresh :: NodeId -> Routing ip () | ||
178 | refresh nid = Refresh nid (Done ()) | ||
179 | {-# INLINE refresh #-} | ||
180 | |||
181 | {----------------------------------------------------------------------- | 169 | {----------------------------------------------------------------------- |
182 | Bucket | 170 | Bucket |
183 | -----------------------------------------------------------------------} | 171 | -----------------------------------------------------------------------} |
@@ -213,6 +201,7 @@ data QueueMethods m elem fifo = QueueMethods | |||
213 | , emptyQueue :: m fifo | 201 | , emptyQueue :: m fifo |
214 | } | 202 | } |
215 | 203 | ||
204 | {- | ||
216 | fromQ :: Functor m => | 205 | fromQ :: Functor m => |
217 | ( a -> b ) | 206 | ( a -> b ) |
218 | -> ( b -> a ) | 207 | -> ( b -> a ) |
@@ -223,6 +212,7 @@ fromQ embed project QueueMethods{..} = | |||
223 | , popFront = fmap (second embed) . popFront . project | 212 | , popFront = fmap (second embed) . popFront . project |
224 | , emptyQueue = fmap embed emptyQueue | 213 | , emptyQueue = fmap embed emptyQueue |
225 | } | 214 | } |
215 | -} | ||
226 | 216 | ||
227 | seqQ :: QueueMethods Identity (NodeInfo ip) (Seq.Seq (NodeInfo ip)) | 217 | seqQ :: QueueMethods Identity (NodeInfo ip) (Seq.Seq (NodeInfo ip)) |
228 | seqQ = QueueMethods | 218 | seqQ = QueueMethods |
@@ -256,17 +246,6 @@ instance (Serialize k, Serialize v, Ord k, Ord v) | |||
256 | get = PSQ.fromList <$> get | 246 | get = PSQ.fromList <$> get |
257 | put = put . PSQ.toList | 247 | put = put . PSQ.toList |
258 | 248 | ||
259 | -- | Get the most recently changed node entry, if any. | ||
260 | lastChanged :: Eq ip => Bucket ip -> Maybe (NodeEntry ip) | ||
261 | lastChanged bucket | ||
262 | | L.null timestamps = Nothing | ||
263 | | otherwise = Just (L.maximumBy (compare `on` prio) timestamps) | ||
264 | where | ||
265 | timestamps = PSQ.toList $ bktNodes bucket | ||
266 | |||
267 | leastRecently :: Eq ip => Bucket ip -> Maybe (NodeEntry ip, Bucket ip) | ||
268 | leastRecently b = fmap (\(e,ns) -> (e, b { bktNodes = ns })) $ minView $ bktNodes b | ||
269 | |||
270 | -- | Update interval, in seconds. | 249 | -- | Update interval, in seconds. |
271 | delta :: NominalDiffTime | 250 | delta :: NominalDiffTime |
272 | delta = 15 * 60 | 251 | delta = 15 * 60 |
@@ -303,29 +282,30 @@ insertBucket curTime (TryInsert info) bucket | |||
303 | map_q f = bucket { bktQ = runIdentity $ f (bktQ bucket) } | 282 | map_q f = bucket { bktQ = runIdentity $ f (bktQ bucket) } |
304 | 283 | ||
305 | insertBucket curTime (PingResult bad_node got_response) bucket | 284 | insertBucket curTime (PingResult bad_node got_response) bucket |
306 | = pure ([], Bucket (update $ bktNodes bucket) popped) | 285 | = pure ([], Bucket (upd $ bktNodes bucket) popped) |
307 | where | 286 | where |
308 | (top, popped) = runIdentity $ popFront bucketQ (bktQ bucket) | 287 | (top, popped) = runIdentity $ popFront bucketQ (bktQ bucket) |
309 | update | got_response = id | 288 | upd | got_response = id |
310 | | Just info <- top = PSQ.insert info curTime . PSQ.delete bad_node | 289 | | Just info <- top = PSQ.insert info curTime . PSQ.delete bad_node |
311 | | otherwise = id | 290 | | otherwise = id |
312 | 291 | ||
313 | type BitIx = Word | 292 | type BitIx = Word |
314 | 293 | ||
315 | partitionQ imp pred q = do | 294 | partitionQ :: Monad f => QueueMethods f elem b -> (elem -> Bool) -> b -> f (b, b) |
316 | pass <- emptyQueue imp | 295 | partitionQ imp test q0 = do |
317 | fail <- emptyQueue imp | 296 | pass0 <- emptyQueue imp |
297 | fail0 <- emptyQueue imp | ||
318 | let flipfix a b f = fix f a b | 298 | let flipfix a b f = fix f a b |
319 | flipfix q (pass,fail) $ \loop q qs -> do | 299 | flipfix q0 (pass0,fail0) $ \rec q qs -> do |
320 | (mb,q') <- popFront imp q | 300 | (mb,q') <- popFront imp q |
321 | case mb of | 301 | case mb of |
322 | Nothing -> return qs | 302 | Nothing -> return qs |
323 | Just e -> do qs' <- select (pushBack imp e) qs | 303 | Just e -> do qs' <- select (pushBack imp e) qs |
324 | loop q' qs' | 304 | rec q' qs' |
325 | where | 305 | where |
326 | select :: Functor f => (b -> f b) -> (b, b) -> f (b, b) | 306 | select :: Functor f => (b -> f b) -> (b, b) -> f (b, b) |
327 | select f = if pred e then \(a,b) -> flip (,) b <$> f a | 307 | select f = if test e then \(a,b) -> flip (,) b <$> f a |
328 | else \(a,b) -> (,) a <$> f b | 308 | else \(a,b) -> (,) a <$> f b |
329 | 309 | ||
330 | split :: Eq ip => BitIx -> Bucket ip -> (Bucket ip, Bucket ip) | 310 | split :: Eq ip => BitIx -> Bucket ip -> (Bucket ip, Bucket ip) |
331 | split i b = (Bucket ns qs, Bucket ms rs) | 311 | split i b = (Bucket ns qs, Bucket ms rs) |
@@ -529,7 +509,7 @@ splitTip nid n i bucket | |||
529 | -- k nodes in them. Which subtrees I mean is illustrated in Fig 1. of Kademlia | 509 | -- k nodes in them. Which subtrees I mean is illustrated in Fig 1. of Kademlia |
530 | -- paper. The rule requiring additional splits is in section 2.4. | 510 | -- paper. The rule requiring additional splits is in section 2.4. |
531 | modifyBucket | 511 | modifyBucket |
532 | :: forall f ip xs. (Alternative f, Eq ip, Monoid xs) => | 512 | :: forall f ip xs. (Alternative f, Eq ip) => |
533 | NodeId -> (Bucket ip -> f (xs, Bucket ip)) -> Table ip -> f (xs,Table ip) | 513 | NodeId -> (Bucket ip -> f (xs, Bucket ip)) -> Table ip -> f (xs,Table ip) |
534 | modifyBucket nodeId f = go (0 :: BitIx) | 514 | modifyBucket nodeId f = go (0 :: BitIx) |
535 | where | 515 | where |
@@ -552,6 +532,7 @@ data Event ip = TryInsert { foreignNode :: NodeInfo ip } | |||
552 | } | 532 | } |
553 | deriving (Eq,Ord,Show) | 533 | deriving (Eq,Ord,Show) |
554 | 534 | ||
535 | eventId :: Event ip -> NodeId | ||
555 | eventId (TryInsert NodeInfo{..}) = nodeId | 536 | eventId (TryInsert NodeInfo{..}) = nodeId |
556 | eventId (PingResult NodeInfo{..} _) = nodeId | 537 | eventId (PingResult NodeInfo{..} _) = nodeId |
557 | 538 | ||