summaryrefslogtreecommitdiff
path: root/src/Network/BitTorrent/DHT/Routing.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network/BitTorrent/DHT/Routing.hs')
-rw-r--r--src/Network/BitTorrent/DHT/Routing.hs53
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.
147runRouting :: (Monad m, Eq ip) 147runRouting :: 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
169getTime :: Routing ip Timestamp
170getTime = GetTime return
171{-# INLINE getTime #-}
172
173needPing :: NodeAddr ip -> Routing ip Bool
174needPing addr = NeedPing addr return
175{-# INLINE needPing #-}
176
177refresh :: NodeId -> Routing ip ()
178refresh 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{-
216fromQ :: Functor m => 205fromQ :: 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
227seqQ :: QueueMethods Identity (NodeInfo ip) (Seq.Seq (NodeInfo ip)) 217seqQ :: QueueMethods Identity (NodeInfo ip) (Seq.Seq (NodeInfo ip))
228seqQ = QueueMethods 218seqQ = 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.
260lastChanged :: Eq ip => Bucket ip -> Maybe (NodeEntry ip)
261lastChanged bucket
262 | L.null timestamps = Nothing
263 | otherwise = Just (L.maximumBy (compare `on` prio) timestamps)
264 where
265 timestamps = PSQ.toList $ bktNodes bucket
266
267leastRecently :: Eq ip => Bucket ip -> Maybe (NodeEntry ip, Bucket ip)
268leastRecently b = fmap (\(e,ns) -> (e, b { bktNodes = ns })) $ minView $ bktNodes b
269
270-- | Update interval, in seconds. 249-- | Update interval, in seconds.
271delta :: NominalDiffTime 250delta :: NominalDiffTime
272delta = 15 * 60 251delta = 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
305insertBucket curTime (PingResult bad_node got_response) bucket 284insertBucket 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
313type BitIx = Word 292type BitIx = Word
314 293
315partitionQ imp pred q = do 294partitionQ :: Monad f => QueueMethods f elem b -> (elem -> Bool) -> b -> f (b, b)
316 pass <- emptyQueue imp 295partitionQ 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
330split :: Eq ip => BitIx -> Bucket ip -> (Bucket ip, Bucket ip) 310split :: Eq ip => BitIx -> Bucket ip -> (Bucket ip, Bucket ip)
331split i b = (Bucket ns qs, Bucket ms rs) 311split 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.
531modifyBucket 511modifyBucket
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)
534modifyBucket nodeId f = go (0 :: BitIx) 514modifyBucket 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
535eventId :: Event ip -> NodeId
555eventId (TryInsert NodeInfo{..}) = nodeId 536eventId (TryInsert NodeInfo{..}) = nodeId
556eventId (PingResult NodeInfo{..} _) = nodeId 537eventId (PingResult NodeInfo{..} _) = nodeId
557 538