Modify s command to give bootstrapping info.

Also added the * wildcard to the x command to remove multiple searches.

1 files changed, 54 insertions, 11 deletions

diff --git a/dht/examples/dhtd.hs b/dht/examples/dhtd.hs
index 4f83beb2..ce04b020 100644
--- a/dht/examples/dhtd.hs
+++ b/dht/examples/dhtd.hs
@@ -75,7 +75,7 @@ import Network.Address hiding (NodeId, NodeInfo(..))
 import Network.QueryResponse
 import qualified Network.QueryResponse.TCP as TCP
 import Network.StreamServer
-import Network.Kademlia.Bootstrap (refreshBuckets,bootstrap)
+import Network.Kademlia.Bootstrap (refreshBuckets,bootstrap, BucketRefresher(..), BucketSearch(..) )
 import Network.Kademlia.CommonAPI
 import Network.Kademlia.Persistence
 import Network.Kademlia.Routing as R
@@ -91,6 +91,7 @@ import Network.BitTorrent.DHT.ContactInfo as Peers
 import qualified Data.MinMaxPSQ as MM
 import Data.Wrapper.PSQ as PSQ (pattern (:->))
 import qualified Data.Wrapper.PSQ as PSQ
+import Data.Wrapper.PSQInt as IPSQ (findMin)
 import Data.Ord
 import Data.Time.Clock.POSIX
 import qualified Network.Tox.DHT.Transport as Tox
@@ -236,6 +237,16 @@ showSearches :: ( Show nid
                 ) => Map.Map (String,nid) (DHTSearch nid ni) -> IO String
 showSearches searches = do
     tups <- forM (Map.toList searches) $ \((meth,nid),DHTSearch{..}) -> do
+        getSearchTuple meth nid searchState searchResults searchThread
+    return $ showSearchTuples tups
+
+showSearchTuples tups = do
+    let cnt'width = maximum $ map (\(_,cnt,_,_)->length cnt) tups
+        mth'width = maximum $ map (\(_,_,mth,_)->length mth) tups
+    (stat,cnt,meth,nid) <- tups
+    printf "  %c %-*s %-*s %s\n" stat cnt'width cnt mth'width meth nid
+
+getSearchTuple meth nid searchState searchResults searchThread = do
         (is'fin, cnt) <- atomically $
                 (,) <$> searchIsFinished searchState
                     <*> (Set.size <$> readTVar searchResults)
@@ -245,12 +256,32 @@ showSearches searches = do
                 ThreadFinished -> '-'
                 ThreadDied     -> '-'
                 _              -> '*'
-        return (stat,show cnt,meth,show nid)
-    let cnt'width = maximum $ map (\(_,cnt,_,_)->length cnt) tups
-        mth'width = maximum $ map (\(_,_,mth,_)->length mth) tups
-    return $ do -- List monad.
-        (stat,cnt,meth,nid) <- tups
-        printf "  %c %-*s %-*s %s\n" stat cnt'width cnt mth'width meth nid
+        return ( (stat,show cnt,meth,show nid) :: (Char,String,String,String) )
+
+showRefresherStatus BucketRefresher{..} = do
+    now <- getPOSIXTime
+    (st,hdr) <- atomically $ do
+        rq <- readTVar refreshQueue       -- Int.PSQ PosixTime
+        lt <- readTVar refreshLastTouch   -- POSIXTime
+        bm <- readTVar bootstrapMode      -- Bool
+        cd <- readTVar bootstrapCountdown -- Maybe Int
+        st <- readTVar refreshState       -- IntMap [BucketSearch nid ni]
+        return $ (,) st $ showReport
+            [ ("  bootstrap:", show bm)
+            , ("  countdown:", show cd)
+            , ("  touched:", show (now - lt))
+            , ("  next-up:", maybe "Nothing" (\(n,t,()) -> show n ++ " " ++ show (t - now)) $ IPSQ.findMin rq)
+            ]
+    let bgschs = concatMap (\(n,xs) -> map ((,) n) xs) $ IntMap.toList st
+    tups <- forM bgschs $ \(n,BucketSearch{..}) -> do
+        getSearchTuple ('#' : show n) bucketSample bucketState bucketResults bucketThread
+    return $ hdr ++ showSearchTuples tups
+
+
+showSearchState refresher searches = do
+    b <- showRefresherStatus refresher
+    u <- showSearches searches
+    return $ "Bucket Maintenance\n" ++ b ++ "User Searches\n" ++ u
 
 forkSearch ::
     ( Ord nid
@@ -742,9 +773,9 @@ clientSession s@Session{..} sock cnum h = do
             (rcnt,relays) <- currentRelays (tcpRelayPinger onionRouter)
             return $ do
                 hPutClientChunk h $ unlines
-                    [ "trampolines(UDP): " ++ show (IntMap.size uts,tcnt,icnt)
+                    [ "trampolines(UDP): " ++ show (IntMap.size uts) -- ,tcnt,icnt)
                                            ++ if tcpmode then "" else " *"
-                    , "trampolines(TCP): " ++ show (IntMap.size tts,ttcnt,ticnt)
+                    , "trampolines(TCP): " ++ show (IntMap.size tts) -- ,ttcnt,ticnt)
                                            ++ if tcpmode then " *" else ""
                     , "active TCP: " ++ show (MM.size tcps)
                     , "pending: " ++ show (W64.size pqs)
@@ -998,7 +1029,7 @@ clientSession s@Session{..} sock cnum h = do
                         let (method,xs) = break isSpace s
                             (nidstr,ys) = break isSpace $ dropWhile isSpace xs
                             presentSearches = hPutClient h
-                                              =<< showSearches
+                                              =<< showSearchState dhtBuckets
                                               =<< atomically (readTVar dhtSearches)
                             goTarget qry nid = do
                                 kvar <- atomically $ newTVar Nothing
@@ -1034,7 +1065,19 @@ clientSession s@Session{..} sock cnum h = do
                                         return $ do
                                             killThread searchThread
                                             hPutClient h "Removed search."
-                        either (hPutClient h . ("Bad search target: "++)) go $ dhtParseId nidstr
+                            removeAll = join $ atomically $ do
+                                schs <- readTVar dhtSearches
+                                let (scrapped,remainder) = Map.partitionWithKey (\(m,_) _ -> m == method) schs
+                                writeTVar dhtSearches remainder
+                                return $ do
+                                    ns <- forM (Map.toList scrapped) $
+                                        \((m,nid),DHTSearch{searchThread}) -> do
+                                            killThread searchThread
+                                            return $ show nid
+                                    hPutClient h $ unlines $ map (mappend "Removed " . mappend method . mappend " ") ns
+                        case nidstr of
+                            "*" -> removeAll
+                            _   -> either (hPutClient h . ("Bad search target: "++)) go $ dhtParseId nidstr
 
         ("save", _) | Just dht <- Map.lookup netname dhts
                     -> cmd0 $ do