Bootstrapping rework in progress.

5 files changed, 240 insertions, 157 deletions

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index d1db1938..7d3661e6 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -61,7 +61,7 @@ import Network.Address hiding (NodeId, NodeInfo(..))
 import Network.QueryResponse
 import Network.StreamServer
 import Network.Kademlia
-import Network.Kademlia.Bootstrap (bootstrap)
+import Network.Kademlia.Bootstrap
 import Network.Kademlia.Search
 import qualified Network.BitTorrent.MainlineDHT as Mainline
 import qualified Network.Tox as Tox
@@ -1323,7 +1323,12 @@ main = do
             case Map.lookup "node" qrys of
                 Just DHTQuery { qsearch = srch } -> do
                     case eqT of
-                        Just witness -> bootstrap (isNodesSearch witness srch) bkts ping btSaved fallbackNodes
+                        Just witness -> let strapper = BucketRefresher
+                                                { refreshSearch = isNodesSearch witness srch
+                                                , refreshBuckets = bkts
+                                                , refreshPing = ping
+                                                }
+                                         in bootstrap strapper btSaved fallbackNodes
                         _            -> error $ "Missing node-search for "++netname++"."
                     saveNodes netname dht
                 Nothing -> return ()
diff --git a/src/Network/BitTorrent/MainlineDHT.hs b/src/Network/BitTorrent/MainlineDHT.hs
index c7ef560c..268cacfb 100644
--- a/src/Network/BitTorrent/MainlineDHT.hs
+++ b/src/Network/BitTorrent/MainlineDHT.hs
@@ -6,6 +6,7 @@
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase                 #-}
+{-# LANGUAGE NamedFieldPuns             #-}
 {-# LANGUAGE PatternSynonyms            #-}
 {-# LANGUAGE StandaloneDeriving         #-}
 {-# LANGUAGE TupleSections              #-}
@@ -502,14 +503,24 @@ newSwarmsDatabase = do
 
 data Routing = Routing
     { tentativeId :: NodeInfo
-    , sched4      :: !( TVar (Int.PSQ POSIXTime) )
-    , routing4    :: !( TVar (R.BucketList NodeInfo) )
     , committee4  :: TriadCommittee NodeId SockAddr
-    , sched6      :: !( TVar (Int.PSQ POSIXTime) )
-    , routing6    :: !( TVar (R.BucketList NodeInfo) )
     , committee6  :: TriadCommittee NodeId SockAddr
+    , refresher4  :: BucketRefresher NodeId NodeInfo
+    , refresher6  :: BucketRefresher NodeId NodeInfo
     }
 
+sched4 :: Routing -> TVar (Int.PSQ POSIXTime)
+sched4 Routing { refresher4 = BucketRefresher { refreshQueue } } = refreshQueue
+
+sched6 :: Routing -> TVar (Int.PSQ POSIXTime)
+sched6 Routing { refresher6 = BucketRefresher { refreshQueue } } = refreshQueue
+
+routing4 :: Routing -> TVar (R.BucketList NodeInfo)
+routing4 Routing { refresher4 = BucketRefresher { refreshBuckets } } = refreshBuckets
+
+routing6 :: Routing -> TVar (R.BucketList NodeInfo)
+routing6 Routing { refresher6 = BucketRefresher { refreshBuckets } } = refreshBuckets
+
 traced :: Show tid => TableMethods t tid -> TableMethods t tid
 traced (TableMethods ins del lkup)
             = TableMethods (\tid mvar t -> trace ("insert "++show tid) $ ins tid mvar t)
@@ -537,7 +548,7 @@ newClient swarms addr = do
             <$> global6
     addr4 <- atomically $ newTChan
     addr6 <- atomically $ newTChan
-    routing <- atomically $ do
+    mkrouting <- atomically $ do
         let nobkts = R.defaultBucketCount :: Int
         tbl4 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info nobkts
         tbl6 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info6 nobkts
@@ -558,9 +569,22 @@ newClient swarms addr = do
         committee6 <- newTriadCommittee $ updateIPVote tbl6 addr6
         sched4 <- newTVar Int.empty
         sched6 <- newTVar Int.empty
-        return $ Routing tentative_info sched4 tbl4 committee4 sched6 tbl6 committee6
+        return $ \client ->
+            let refresher sched bkts = BucketRefresher
+                    { refreshInterval = 15 * 60
+                    , refreshQueue    = sched
+                    , refreshSearch   = nodeSearch client
+                    , refreshBuckets  = bkts
+                    , refreshPing     = ping client
+                    }
+                refresher4 = refresher sched4 tbl4
+                refresher6 = refresher sched6 tbl6
+            in Routing tentative_info committee4 committee6 refresher4 refresher6
     map_var <- atomically $ newTVar (0, mempty)
-    let net = onInbound (updateRouting outgoingClient routing)
+
+    let routing = mkrouting outgoingClient
+
+        net = onInbound (updateRouting outgoingClient routing)
               $ layerTransport parsePacket encodePacket
               $ udp
 
@@ -625,14 +649,9 @@ newClient swarms addr = do
         -- TODO: trigger bootstrap ipv6
         again
 
-    refresh_thread4 <- forkPollForRefresh
-                            (15*60)
-                            (sched4 routing)
-                            (refreshBucket (nodeSearch client) (routing4 routing))
-    refresh_thread6 <- forkPollForRefresh
-                            (15*60)
-                            (sched6 routing)
-                            (refreshBucket (nodeSearch client) (routing6 routing))
+
+    refresh_thread4 <- forkPollForRefresh $ refresher4 routing
+    refresh_thread6 <- forkPollForRefresh $ refresher6 routing
 
     return (client, routing)
 
@@ -676,14 +695,17 @@ defaultHandler meth = MethodHandler decodePayload errorPayload returnError
     returnError :: NodeInfo -> BValue -> IO Error
     returnError _ _ = return $ Error MethodUnknown ("Unknown method " <> meth)
 
-mainlineKademlia :: MainlineClient -> TriadCommittee NodeId SockAddr -> TVar (R.BucketList NodeInfo) -> TVar (Int.PSQ POSIXTime) -> Kademlia NodeId NodeInfo
-mainlineKademlia client committee var sched
+mainlineKademlia :: MainlineClient
+                    -> TriadCommittee NodeId SockAddr
+                    -> BucketRefresher NodeId NodeInfo
+                    -> Kademlia NodeId NodeInfo
+mainlineKademlia client committee refresher
     = Kademlia quietInsertions
                mainlineSpace
-               (vanillaIO var $ ping client)
+               (vanillaIO (refreshBuckets refresher) $ ping client)
                    { tblTransition = \tr -> do
                         io1 <- transitionCommittee committee tr
-                        io2 <- touchBucket mainlineSpace (15*60) var sched tr
+                        io2 <- touchBucket refresher tr
                         return $ do
                             io1 >> io2
                             {-  noisy (timestamp updates are currently reported as transitions to Accepted)
@@ -712,11 +734,11 @@ transitionCommittee committee _ = return $ return ()
 updateRouting :: MainlineClient -> Routing -> NodeInfo -> Message BValue -> IO ()
 updateRouting client routing naddr msg = do
     case prefer4or6 naddr Nothing of
-        Want_IP4 -> go (routing4 routing) (committee4 routing) (sched4 routing)
-        Want_IP6 -> go (routing6 routing) (committee6 routing) (sched6 routing)
+        Want_IP4 -> go (committee4 routing) (refresher4 routing)
+        Want_IP6 -> go (committee6 routing) (refresher6 routing)
  where
-    go tbl committee sched = do
-        self <- atomically $ R.thisNode <$> readTVar tbl
+    go committee refresher = do
+        self <- atomically $ R.thisNode <$> readTVar (refreshBuckets refresher)
         when (nodeIP self /= nodeIP naddr) $ do
             case msg of
                 R { rspReflectedIP = Just sockaddr }
@@ -724,7 +746,7 @@ updateRouting client routing naddr msg = do
                         -- hPutStrLn stderr $ "External: "++show (nodeId naddr,sockaddr)
                         atomically $ addVote committee (nodeId naddr) sockaddr
                 _   -> return ()
-            insertNode (mainlineKademlia client committee tbl sched) naddr
+            insertNode (mainlineKademlia client committee refresher) naddr
 
 data Ping = Ping deriving Show
 
diff --git a/src/Network/Kademlia/Bootstrap.hs b/src/Network/Kademlia/Bootstrap.hs
index 283e054a..42bff665 100644
--- a/src/Network/Kademlia/Bootstrap.hs
+++ b/src/Network/Kademlia/Bootstrap.hs
@@ -1,11 +1,14 @@
 {-# LANGUAGE CPP                   #-}
+{-# LANGUAGE ConstraintKinds       #-}
 {-# LANGUAGE DeriveFunctor         #-}
 {-# LANGUAGE DeriveTraversable     #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE GADTs                 #-}
 {-# LANGUAGE KindSignatures        #-}
+{-# LANGUAGE NamedFieldPuns        #-}
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE PatternSynonyms       #-}
+{-# LANGUAGE RankNTypes            #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
 module Network.Kademlia.Bootstrap where
 
@@ -42,34 +45,90 @@ import Network.Kademlia.Search
 import Control.Concurrent.Tasks
 import Network.Kademlia
 
-
--- | > pollForRefresh interval queue refresh
+-- From BEP 05:
+--
+-- Each bucket should maintain a "last changed" property to indicate how
+-- "fresh" the contents are.
+--
+-- Note: We will use a "time to next refresh" property instead and store it in
+-- a priority search queue.
+--
+-- When...
+--
+-- >>> data BucketTouchEvent = RoutingStatus :--> RoutingStatus
+-- >>> bucketEvents =
+-- >>>  [ Applicant :--> Stranger -- a node in a bucket is pinged and it responds,
+-- >>>
+-- >>>  , Stranger  :--> Accepted -- or a node is added to a bucket,
+-- >>>
+-- >>>  , Accepted  :--> Stranger -- or a node in a bucket is replaced
+-- >>>  , Applicant :--> Accepted -- with another node,
+-- >>>  ]
+--
+-- the bucket's last changed property should be updated. Buckets
+-- that have not been changed in 15 minutes should be "refreshed." This is done
+-- by picking a random ID in the range of the bucket and performing a
+-- find_nodes search on it.
+--
+-- The only other possible BucketTouchEvents are as follows:
 --
--- Fork a refresh loop.  Kill the returned thread to terminate it.  The
--- arguments are: a staleness threshold (if a bucket goes this long without
--- being touched, a refresh will be triggered), a TVar with the time-to-refresh
--- schedule for each bucket, and a refresh action to be forked when a bucket
--- excedes the staleness threshold.
+-- >>> not_handled =
+-- >>>   , Stranger :--> Applicant -- A ping is pending, it's result is covered:
+-- >>>                             --     (Applicant :--> Stranger)
+-- >>>                             --     (Applicant :--> Accepted)
+-- >>>   , Accepted :--> Applicant -- Never happens
+-- >>>   ]
 --
--- TO "touch" a bucket and prevent it from being refreshed, reschedule it's
--- refresh time to some time into the future by modifying the 'Int.PSQ' in the
--- TVar.
-forkPollForRefresh :: POSIXTime -> TVar (Int.PSQ POSIXTime) -> (Int -> IO a) -> IO ThreadId
-forkPollForRefresh interval psq refresh = do
-    fork $ do
+
+type SensibleNodeId nid ni =
+                 ( Show nid
+                 , Ord nid
+                 , Ord ni
+                 , Hashable nid
+                 , Hashable ni )
+
+data BucketRefresher nid ni = forall tok addr. Ord addr =>  BucketRefresher
+    { -- | A staleness threshold (if a bucket goes this long without being
+      -- touched, a refresh will be triggered).
+      refreshInterval :: POSIXTime
+      -- | A TVar with the time-to-refresh schedule for each bucket.
+      --
+      -- To "touch" a bucket and prevent it from being refreshed, reschedule
+      -- it's refresh time to some time into the future by modifying the
+      -- 'Int.PSQ' in the TVar.  (See 'touchBucket').
+    , refreshQueue    :: TVar (Int.PSQ POSIXTime)
+      -- | This is the kademlia node search specification.
+    , refreshSearch   :: Search nid addr tok ni ni
+      -- | The current kademlia routing table buckets.
+    , refreshBuckets  :: TVar (R.BucketList ni)
+      -- | Action to ping a node.  This is used only during initial bootstrap
+      -- to get some nodes in our table.  A 'True' result is interpreted as a a
+      -- pong, where 'False' is a non-response.
+    , refreshPing     :: ni -> IO Bool
+    }
+
+-- | Fork a refresh loop.  Kill the returned thread to terminate it.
+forkPollForRefresh :: SensibleNodeId nid ni => BucketRefresher nid ni -> IO ThreadId
+forkPollForRefresh BucketRefresher{ refreshInterval
+                                  , refreshQueue
+                                  , refreshBuckets
+                                  , refreshSearch   } = fork $ do
       myThreadId >>= flip labelThread "pollForRefresh"
       fix $ \again -> do
         join $ atomically $ do
-            nextup <- Int.findMin <$> readTVar psq
+            nextup <- Int.findMin <$> readTVar refreshQueue
             maybe retry (return . go again) nextup
  where
+    refresh :: Int -> IO Int
+    refresh = refreshBucket refreshSearch refreshBuckets
+
     go again ( bktnum :-> refresh_time ) = do
         now <- getPOSIXTime
         case fromEnum (refresh_time - now) of
             x | x <= 0 -> do -- Refresh time!
                              -- Move it to the back of the refresh queue.
-                             atomically $ modifyTVar' psq
-                                        $ Int.insert bktnum (now + interval)
+                             atomically $ modifyTVar' refreshQueue
+                                        $ Int.insert bktnum (now + refreshInterval)
                              -- Now fork the refresh operation.
                              -- TODO: We should probably propogate the kill signal to this thread.
                              fork $ do myThreadId >>= flip labelThread ("refresh."++show bktnum)
@@ -79,15 +138,37 @@ forkPollForRefresh interval psq refresh = do
             seconds    -> threadDelay ( seconds * 1000000 )
         again
 
-refreshBucket :: forall nid tok ni addr.
-                 ( Show nid
-                 , Serialize nid
-                 , Ord nid
-                 , Ord ni
-                 , Ord addr
-                 , Hashable nid
-                 , Hashable ni ) =>
-                 Search nid addr tok ni ni -> TVar (BucketList ni) -> Int -> IO Int
+
+-- | This is a helper to 'refreshBucket' which does some book keeping to decide
+-- whether or not a bucket is sufficiently refreshed or not.  It will return
+-- false when we can terminate a node search.
+checkBucketFull :: Ord ni => KademliaSpace nid ni   -- ^ Obtain a node id from a node.
+                            -> TVar (BucketList ni) -- ^ The current routing table.
+                            -> TVar (Set.Set ni)    -- ^ In-range nodes found so far.
+                            -> TVar Bool            -- ^ The result will also be written here.
+                            -> Int                  -- ^ The bucket number of interest.
+                            -> ni                   -- ^ A newly found node.
+                            -> STM Bool
+checkBucketFull space var resultCounter fin n found_node = do
+    let fullcount = R.defaultBucketSize
+        saveit True = writeTVar fin True >> return True
+        saveit _    = return False
+    tbl <- readTVar var
+    let counts = R.shape tbl
+        nid = kademliaLocation space found_node
+    -- Update the result set with every found node that is in the
+    -- bucket of interest.
+    when (n == R.bucketNumber space nid tbl)
+         $ modifyTVar' resultCounter (Set.insert found_node)
+    resultCount <- readTVar resultCounter
+    saveit $ case drop (n - 1) counts of
+        (cnt:_) | cnt < fullcount            -> True  -- bucket not full, keep going
+        _ | Set.size resultCount < fullcount -> True  -- we haven't got many results, keep going
+        _                                    -> False -- okay, good enough, let's quit.
+
+
+refreshBucket :: (Hashable a, Hashable t, Ord t, Ord addr, Ord a, Show t) =>
+                 Search t addr tok a a -> TVar (BucketList a) -> Int -> IO Int
 refreshBucket sch var n = do
     tbl <- atomically (readTVar var)
     let count = bktCount tbl
@@ -100,27 +181,13 @@ refreshBucket sch var n = do
                         (bucketRange n (n + 1 < count))
     fin <- atomically $ newTVar False
     resultCounter <- atomically $ newTVar Set.empty
-    let fullcount = R.defaultBucketSize
-        saveit True = writeTVar fin True >> return True
-        saveit _    = return False
-        checkBucketFull :: ni -> STM Bool
-        checkBucketFull found_node = do
-            tbl <- readTVar var
-            let counts = R.shape tbl
-            when (n == R.bucketNumber (searchSpace sch) (kademliaLocation (searchSpace sch) found_node) tbl)
-                 $ modifyTVar' resultCounter (Set.insert found_node)
-            resultCount <- readTVar resultCounter
-            saveit $ case drop (n - 1) counts of
-                (cnt:_) | cnt < fullcount            -> True
-                _ | Set.size resultCount < fullcount -> True
-                _                                    -> False
 
     hPutStrLn stderr $ "Start refresh " ++ show (n,sample)
 
     -- Set 15 minute timeout in order to avoid overlapping refreshes.
     s <- search sch tbl sample $ if n+1 == R.defaultBucketCount
                                     then const $ return True -- Never short-circuit the last bucket.
-                                    else checkBucketFull
+                                    else checkBucketFull (searchSpace sch) var resultCounter fin n
     _ <- timeout (15*60*1000000) $ do
             atomically $ searchIsFinished s >>= check
     atomically $ searchCancel s
@@ -131,20 +198,11 @@ refreshBucket sch var n = do
         return $ if b then 1 else c
     return rcount
 
-
-bootstrap ::
-    ( Show nid
-    , Serialize nid
-    -- , FiniteBits nid
-    , Hashable ni
-    , Hashable nid
-    , Ord ni
-    , Ord addr
-    , Ord nid
-    , Traversable t1
-    , Traversable t
-    ) => Search nid addr tok ni ni -> TVar (BucketList ni) -> (ni -> IO Bool) -> t ni -> t1 ni -> IO ()
-bootstrap sch var ping ns ns0 = do
+bootstrap :: (Ord ni, Ord nid, Hashable nid, Hashable ni, Foldable t, Foldable t1, Show nid) =>
+             BucketRefresher nid ni -> t1 ni -> t ni -> IO ()
+bootstrap BucketRefresher { refreshSearch  = sch
+                          , refreshBuckets = var
+                          , refreshPing    = ping } ns ns0 = do
     gotPing <- atomically $ newTVar False
 
     -- First, ping the given nodes so that they are added to
@@ -193,6 +251,9 @@ bootstrap sch var ping ns ns0 = do
                 cnt <- refreshBucket sch var num
                 again cnt
 
+-- | Reschedule a bucket's refresh-time.  It should be called whenever a bucket
+-- changes.  This will typically be invoked from 'tblTransition'.
+--
 -- XXX: This will be redundantly triggered twice upon every node replacement
 -- because we do not currently distinguish between standalone
 -- insertion/deletion events and an insertion/deletion pair constituting
@@ -201,55 +262,21 @@ bootstrap sch var ping ns ns0 = do
 -- It might also be better to pass the timestamp of the transition here and
 -- keep the refresh queue in better sync with the routing table by updating it
 -- within the STM monad.
-touchBucket :: KademliaSpace nid ni
-            -> POSIXTime
-            -> TVar (BucketList ni)
-            -> TVar (Int.PSQ POSIXTime)
-            -> RoutingTransition ni
+touchBucket :: BucketRefresher nid ni
+            -> RoutingTransition ni     -- ^ What happened to the bucket?
             -> STM (IO ())
-touchBucket space interval bkts psq tr
+touchBucket BucketRefresher{ refreshSearch
+                           , refreshInterval
+                           , refreshBuckets
+                           , refreshQueue
+                           }
+            tr
     | (transitionedTo tr == Applicant)
                 = return $ return ()
     | otherwise = return $ do
          now <- getPOSIXTime
          atomically $ do
-            let nid = kademliaLocation space (transitioningNode tr)
-            num <- R.bucketNumber space nid <$> readTVar bkts
-            modifyTVar' psq $ Int.insert num (now + interval)
-
--- TODO: Bootstrap/Refresh
---
--- From BEP 05:
---
--- Each bucket should maintain a "last changed" property to indicate how
--- "fresh" the contents are.
---
--- Note: We will use a "time to next refresh" property instead and store it in
--- a priority search queue.
---
--- When...
---
--- >>> data BucketTouchEvent = RoutingStatus :--> RoutingStatus
--- >>> bucketEvents =
--- >>>  [ Applicant :--> Stranger -- a node in a bucket is pinged and it responds,
--- >>>
--- >>>  , Stranger  :--> Accepted -- or a node is added to a bucket,
--- >>>
--- >>>  , Accepted  :--> Stranger -- or a node in a bucket is replaced
--- >>>  , Applicant :--> Accepted -- with another node,
--- >>>  ]
---
--- the bucket's last changed property should be updated. Buckets
--- that have not been changed in 15 minutes should be "refreshed." This is done
--- by picking a random ID in the range of the bucket and performing a
--- find_nodes search on it.
---
--- The only other possible BucketTouchEvents are as follows:
---
--- >>> not_handled =
--- >>>   , Stranger :--> Applicant -- A ping is pending, it's result is covered:
--- >>>                             --     (Applicant :--> Stranger)
--- >>>                             --     (Applicant :--> Accepted)
--- >>>   , Accepted :--> Applicant -- Never happens
--- >>>   ]
---
+            let space = searchSpace refreshSearch
+                nid = kademliaLocation space (transitioningNode tr)
+            num <- R.bucketNumber space nid <$> readTVar refreshBuckets
+            modifyTVar' refreshQueue $ Int.insert num (now + refreshInterval)
diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs
index 35eaebb5..15b00780 100644
--- a/src/Network/Tox.hs
+++ b/src/Network/Tox.hs
@@ -167,11 +167,15 @@ w64Key (DHT.TransactionId (Nonce8 w) _) = w
 nonceKey :: DHT.TransactionId -> Nonce8
 nonceKey (DHT.TransactionId n _) = n
 
-myAddr :: DHT.Routing -> Maybe NodeInfo -> IO NodeInfo
-myAddr routing maddr = atomically $ do
+-- | Return my own address.
+myAddr :: TVar (R.BucketList NodeInfo) -- ^ IPv4 buckets
+       -> TVar (R.BucketList NodeInfo) -- ^ IPv6 buckets
+       -> Maybe NodeInfo             -- ^ Interested remote address
+       -> IO NodeInfo
+myAddr routing4 routing6 maddr = atomically $ do
     let var = case flip DHT.prefer4or6 Nothing <$> maddr of
-                Just Want_IP6 -> DHT.routing6 routing
-                _             -> DHT.routing4 routing
+                Just Want_IP6 -> routing4
+                _             -> routing6
     a <- readTVar var
     return $ R.thisNode a
 
@@ -179,7 +183,7 @@ newClient :: (DRG g, Show addr, Show meth) =>
               g -> Transport String addr x
                 -> (Client String meth DHT.TransactionId addr x -> x -> MessageClass String meth DHT.TransactionId addr x)
                 -> (Maybe addr -> IO addr)
-                -> (meth -> Maybe (MethodHandler String DHT.TransactionId addr x))
+                -> (Client String meth DHT.TransactionId addr x -> meth -> Maybe (MethodHandler String DHT.TransactionId addr x))
                 -> (forall d. TransactionMethods d DHT.TransactionId addr x -> TransactionMethods d DHT.TransactionId addr x)
                 -> (Client String meth DHT.TransactionId addr x -> Transport String addr x -> Transport String addr x)
                 -> IO (Client String meth DHT.TransactionId addr x)
@@ -207,7 +211,7 @@ newClient drg net classify selfAddr handlers modifytbl modifynet = do
         mkclient (tbl,var) handlers =
             let client = Client
                     { clientNet           = addHandler (reportParseError eprinter) (handleMessage client) $ modifynet client net
-                    , clientDispatcher    = dispatch tbl var handlers client
+                    , clientDispatcher    = dispatch tbl var (handlers client) client
                     , clientErrorReporter = eprinter { reportTimeout = reportTimeout ignoreErrors }
                     , clientPending       = var
                     , clientAddress       = selfAddr
@@ -308,13 +312,15 @@ newTox keydb addr mbSessionsState suppliedDHTKey = do
     drg <- drgNew
     let lookupClose _ = return Nothing
 
-    routing <- DHT.newRouting addr crypto updateIP updateIP
+    mkrouting <- DHT.newRouting addr crypto updateIP updateIP
     let ignoreErrors _ = return () -- Set this to (hPutStrLn stderr) to debug onion route building.
     orouter <- newOnionRouter ignoreErrors
     (dhtcrypt,onioncrypt,dtacrypt,cryptonet) <- toxTransport crypto orouter lookupClose udp
     let dhtnet0 = layerTransportM (DHT.decrypt crypto) (DHT.encrypt crypto) dhtcrypt
-    dhtclient <- newClient drg dhtnet0 DHT.classify (myAddr routing) (DHT.handlers crypto routing) id
-                    $ \client net -> onInbound (DHT.updateRouting client routing orouter) net
+        tbl4 = DHT.routing4 $ mkrouting (error "missing client")
+        tbl6 = DHT.routing6 $ mkrouting (error "missing client")
+    dhtclient <- newClient drg dhtnet0 DHT.classify (myAddr tbl4 tbl6) (DHT.handlers crypto . mkrouting) id
+                    $ \client net -> onInbound (DHT.updateRouting client (mkrouting client) orouter) net
 
     orouter <- forkRouteBuilder orouter $ \nid ni -> fmap (\(_,ns,_)->ns) <$> DHT.getNodes dhtclient nid ni
 
@@ -324,8 +330,8 @@ newTox keydb addr mbSessionsState suppliedDHTKey = do
     oniondrg <- drgNew
     let onionnet = layerTransportM (Onion.decrypt crypto) (Onion.encrypt crypto) onioncrypt
     onionclient <- newClient oniondrg onionnet (const Onion.classify)
-                    (getOnionAlias crypto $ R.thisNode <$> readTVar (DHT.routing4 routing))
-                    (Onion.handlers onionnet routing toks keydb)
+                    (getOnionAlias crypto $ R.thisNode <$> readTVar (DHT.routing4 $ mkrouting dhtclient))
+                    (const $ Onion.handlers onionnet (mkrouting dhtclient) toks keydb)
                     (hookQueries orouter DHT.transactionKey)
                     (const id)
 
@@ -337,7 +343,7 @@ newTox keydb addr mbSessionsState suppliedDHTKey = do
         , toxCrypto = addHandler (hPutStrLn stderr) (cryptoNetHandler sessionsState) cryptonet
         , toxCryptoSessions = sessionsState
         , toxCryptoKeys = crypto
-        , toxRouting = routing
+        , toxRouting = mkrouting dhtclient
         , toxTokens = toks
         , toxAnnouncedKeys = keydb
         , toxOnionRoutes = orouter
diff --git a/src/Network/Tox/DHT/Handlers.hs b/src/Network/Tox/DHT/Handlers.hs
index 494e319b..d3d36525 100644
--- a/src/Network/Tox/DHT/Handlers.hs
+++ b/src/Network/Tox/DHT/Handlers.hs
@@ -1,7 +1,8 @@
+{-# LANGUAGE CPP                        #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE NamedFieldPuns             #-}
 {-# LANGUAGE PatternSynonyms            #-}
 {-# LANGUAGE TupleSections              #-}
-{-# LANGUAGE CPP                        #-}
 module Network.Tox.DHT.Handlers where
 
 import Network.Tox.DHT.Transport as DHTTransport
@@ -11,7 +12,7 @@ import Crypto.Tox
 import Network.Kademlia.Search
 import qualified Data.Wrapper.PSQInt as Int
 import Network.Kademlia
-import Network.Kademlia.Bootstrap    (touchBucket)
+import Network.Kademlia.Bootstrap
 import Network.Address               (WantIP (..), ipFamily, testIdBit,fromSockAddr, sockAddrPort)
 import qualified Network.Kademlia.Routing as R
 import Control.TriadCommittee
@@ -111,18 +112,28 @@ classify client msg = fromMaybe (IsUnknown "unknown")
 
 data Routing = Routing
     { tentativeId :: NodeInfo
-    , sched4      :: !( TVar (Int.PSQ POSIXTime) )
-    , routing4    :: !( TVar (R.BucketList NodeInfo) )
     , committee4  :: TriadCommittee NodeId SockAddr
-    , sched6      :: !( TVar (Int.PSQ POSIXTime) )
-    , routing6    :: !( TVar (R.BucketList NodeInfo) )
     , committee6  :: TriadCommittee NodeId SockAddr
+    , refresher4  :: BucketRefresher NodeId NodeInfo
+    , refresher6  :: BucketRefresher NodeId NodeInfo
     }
 
+sched4 :: Routing -> TVar (Int.PSQ POSIXTime)
+sched4 Routing { refresher4 = BucketRefresher { refreshQueue } } = refreshQueue
+
+sched6 :: Routing -> TVar (Int.PSQ POSIXTime)
+sched6 Routing { refresher6 = BucketRefresher { refreshQueue } } = refreshQueue
+
+routing4 :: Routing -> TVar (R.BucketList NodeInfo)
+routing4 Routing { refresher4 = BucketRefresher { refreshBuckets } } = refreshBuckets
+
+routing6 :: Routing -> TVar (R.BucketList NodeInfo)
+routing6 Routing { refresher6 = BucketRefresher { refreshBuckets } } = refreshBuckets
+
 newRouting :: SockAddr -> TransportCrypto
                        -> (TVar (R.BucketList NodeInfo) -> SockAddr -> STM ()) -- ^ invoked on IPv4 change
                        -> (TVar (R.BucketList NodeInfo) -> SockAddr -> STM ()) -- ^ invoked on IPv6 change
-                       -> IO Routing
+                       -> IO (Client -> Routing)
 newRouting addr crypto update4 update6 = do
     let tentative_ip4 = fromMaybe (IPv4 $ toEnum 0) (IPv4 <$> fromSockAddr addr)
         tentative_ip6 = fromMaybe (IPv6 $ toEnum 0) (IPv6 <$> fromSockAddr addr)
@@ -146,7 +157,17 @@ newRouting addr crypto update4 update6 = do
         committee6 <- newTriadCommittee (update6 tbl6) -- updateIPVote tbl6 addr6
         sched4 <- newTVar Int.empty
         sched6 <- newTVar Int.empty
-        return $ Routing tentative_info sched4 tbl4 committee4 sched6 tbl6 committee6
+        return $ \client ->
+            let refresher sched bkts = BucketRefresher
+                    { refreshInterval = 15 * 60
+                    , refreshQueue    = sched
+                    , refreshSearch   = nodeSearch client
+                    , refreshBuckets  = bkts
+                    , refreshPing     = ping client
+                    }
+                refresher4 = refresher sched4 tbl6
+                refresher6 = refresher sched6 tbl6
+            in Routing tentative_info committee4 committee6 refresher4 refresher6
 
 
 -- TODO: This should cover more cases
@@ -322,26 +343,28 @@ updateRouting client routing orouter naddr msg
     | PacketKind 0x21 <- msgType msg = return () -- ignore lan discovery
     | otherwise                      = do
     case prefer4or6 naddr Nothing of
-        Want_IP4 -> updateTable client naddr orouter (routing4 routing) (committee4 routing) (sched4 routing)
-        Want_IP6 -> updateTable client naddr orouter (routing6 routing) (committee6 routing) (sched6 routing)
+        Want_IP4 -> updateTable client naddr orouter (committee4 routing) (refresher4 routing)
+        Want_IP6 -> updateTable client naddr orouter (committee6 routing) (refresher4 routing)
         Want_Both -> error $ "BUG:unreachable at " ++ __FILE__ ++ ":" ++ show __LINE__
 
-updateTable :: Client -> NodeInfo -> OnionRouter -> TVar (R.BucketList NodeInfo) -> TriadCommittee NodeId SockAddr -> TVar (Int.PSQ POSIXTime) -> IO ()
-updateTable client naddr orouter tbl committee sched = do
-        self <- atomically $ R.thisNode <$> readTVar tbl
+updateTable :: Client -> NodeInfo -> OnionRouter -> TriadCommittee NodeId SockAddr -> BucketRefresher NodeId NodeInfo -> IO ()
+updateTable client naddr orouter committee refresher = do
+        self <- atomically $ R.thisNode <$> readTVar (refreshBuckets refresher)
         when (nodeIP self /= nodeIP naddr) $ do
             -- TODO: IP address vote?
-            insertNode (toxKademlia client committee orouter tbl sched) naddr
+            insertNode (toxKademlia client committee orouter refresher) naddr
 
-toxKademlia :: Client -> TriadCommittee NodeId SockAddr -> OnionRouter -> TVar (R.BucketList NodeInfo) -> TVar (Int.PSQ POSIXTime) -> Kademlia NodeId NodeInfo
-toxKademlia client committee orouter var sched
+toxKademlia :: Client -> TriadCommittee NodeId SockAddr -> OnionRouter
+                -> BucketRefresher NodeId NodeInfo
+                -> Kademlia NodeId NodeInfo
+toxKademlia client committee orouter refresher
     = Kademlia quietInsertions
                toxSpace
-               (vanillaIO var $ ping client)
+               (vanillaIO (refreshBuckets refresher) $ ping client)
                    { tblTransition = \tr -> do
                         io1 <- transitionCommittee committee tr
-                        io2 <- touchBucket toxSpace (15*60) var sched tr
-                        hookBucketList toxSpace var orouter tr
+                        io2 <- touchBucket refresher tr -- toxSpace (15*60) var sched tr
+                        hookBucketList toxSpace (refreshBuckets refresher) orouter tr
                         return $ do
                             io1 >> io2
                             {-