Added timestamps to kademlia replacement queues.

1 files changed, 14 insertions, 24 deletions

diff --git a/src/Network/DHT/Routing.hs b/src/Network/DHT/Routing.hs
index 2521f7b9..7f0e1c94 100644
--- a/src/Network/DHT/Routing.hs
+++ b/src/Network/DHT/Routing.hs
@@ -172,10 +172,10 @@ bucketQ = seqQ
 --   table tree. Size of the bucket should be choosen such that it's
 --   very unlikely that all nodes in bucket fail within an hour of
 --   each other.
---
-data Bucket ni = Bucket { bktNodes :: !(PSQ ni Timestamp) -- current routing nodes
-                        , bktQ     :: !(BucketQueue ni)   -- replacements pending time-outs
-                        } deriving Generic
+data Bucket ni = Bucket
+    { bktNodes :: !(PSQ ni Timestamp)           -- current routing nodes
+    , bktQ     :: !(BucketQueue (Timestamp,ni)) -- replacements pending time-outs
+    } deriving Generic
 
 deriving instance Show ni => Show (Bucket ni)
 
@@ -249,7 +249,7 @@ updateBucketForInbound curTime info bucket
            , bucket { -- Update timestamps so that we don't redundantly ping.
                       bktNodes = updateStamps curTime stales $ bktNodes bucket
                       -- Update queue with the pending NodeInfo in case of ping fail.
-                    , bktQ     = runIdentity $ pushBack bucketQ info $ bktQ bucket } )
+                    , bktQ     = runIdentity $ pushBack bucketQ (curTime,info) $ bktQ bucket } )
   -- When the bucket is full of good nodes, the new node is simply discarded.
   -- We must return 'A.empty' here to ensure that bucket splitting happens
   -- inside 'modifyBucket'.
@@ -270,7 +270,7 @@ updateBucketForInbound curTime info bucket
     map_ns f = bucket { bktNodes = f (bktNodes bucket) }
     -- map_q f = bucket { bktQ = runIdentity \$ f (bktQ bucket) }
 
-updateBucketForPingResult curTime bad_node got_response bucket
+updateBucketForPingResult bad_node got_response bucket
     = pure ( replacements
            , Bucket (foldr replace
                            (bktNodes bucket)
@@ -286,17 +286,8 @@ updateBucketForPingResult curTime bad_node got_response bucket
                                          return (bad_node, info)
                  | otherwise        = []
 
-    replace (bad_node, info) =
-                 PSQ.insert info curTime
-                 -- XXX: curTime is the time somebody pinged out, not the time
-                 -- of which the popped node was originally queued.  That's not
-                 -- quite right.
-                 --
-                 -- It's the best we can do atm since the overflow BucketQueue
-                 -- does not include timestamps.
-                 --
-                 -- This means that initial time-outs for replacement nodes are up to
-                 -- twice as long as for the originals.
+    replace (bad_node, (tm, info)) =
+                 PSQ.insert info tm
                  . PSQ.delete bad_node
 
 
@@ -330,7 +321,7 @@ split :: -- ( Eq ip , Ord (NodeId) , FiniteBits (NodeId)) =>
 split testNodeIdBit i b = (Bucket ns qs, Bucket ms rs)
   where
     (ns,ms) = (PSQ.fromList *** PSQ.fromList) . partition (spanBit . key) . PSQ.toList $ bktNodes b
-    (qs,rs) = runIdentity $ partitionQ bucketQ spanBit $ bktQ b
+    (qs,rs) = runIdentity $ partitionQ bucketQ (spanBit . snd) $ bktQ b
 
     spanBit :: ni -> Bool
     spanBit entry = testNodeIdBit entry i
@@ -659,21 +650,20 @@ updateForInbound testIdBit nodeId tm ni tbl =
 
 -- | Update the routing table with the results of a ping.
 --
--- Each (a,b) in the returned list indicates that the node /a/ was deleted from the
--- routing table and the  node /b/ has taken its place.
+-- Each (a,(tm,b)) in the returned list indicates that the node /a/ was deleted from the
+-- routing table and the  node /b/, with timestamp /tm/, has taken its place.
 updateForPingResult :: Ord ni =>
     (nid -> Word -> Bool)
     -> (ni -> nid)
-    -> Timestamp
     -> ni           -- ^ The pinged node.
     -> Bool         -- ^ True if we got a reply, False if it timed out.
     -> Table ni nid -- ^ The routing table.
-    -> ( [(ni,ni)], Table ni nid )
-updateForPingResult testIdBit nodeId tm ni got_reply tbl =
+    -> ( [(ni,(Timestamp, ni))], Table ni nid )
+updateForPingResult testIdBit nodeId ni got_reply tbl =
     fromMaybe ([],tbl)
                    $ modifyBucket testIdBit (\ni -> testIdBit $ nodeId ni)
                                             (nodeId ni)
-                                            (updateBucketForPingResult tm ni got_reply)
+                                            (updateBucketForPingResult ni got_reply)
                                             tbl