More TCP work.

1 files changed, 27 insertions, 8 deletions

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index d014a611..96cfbe0e 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -264,7 +264,7 @@ forkSearch ::
     -> TVar (Maybe (IO ()))
     -> STM ()
 forkSearch method nid DHTQuery{qsearch,qshowTok,qshowR} dhtSearches dhtBuckets  tid kvar = do
-    ns <- R.kclosest (searchSpace qsearch) searchK nid <$> readTVar dhtBuckets
+    ns <- R.kclosest (searchSpace qsearch) (searchK qsearch) nid <$> readTVar dhtBuckets
     st <- newSearch qsearch nid ns
     results <- newTVar Set.empty
     let storeResult r = modifyTVar' results (Set.insert (qshowR r))
@@ -674,7 +674,8 @@ clientSession s@Session{..} sock cnum h = do
                 hPutClient h $ "Showing " ++ show tag ++ " messages."
 
 
-        ("onion", s) -> cmd0 $ do
+        ("onion", s) | "" <- strp $ map toLower s
+                      -> cmd0 $ do
             now <- getPOSIXTime
             join $ atomically $ do
             rm <- IntMap.fromList . catMaybes . map (\(i,m) -> fmap (i,) m) <$> getAssocs (routeMap onionRouter)
@@ -690,10 +691,14 @@ clientSession s@Session{..} sock cnum h = do
             tcp_spill <- readTVar (TCP.probeSpill $ tcpProber onionRouter)
             tcp_cache <- readTVar (TCP.probeCache $ tcpProber onionRouter)
             tcp_queue <- readTVar (TCP.probeQueue $ tcpProber onionRouter)
+            tcpmode <- readTVar (tcpMode onionRouter)
             let showRecord :: Int -> Int -> [String]
                 showRecord n wanted_ver
-                    | Just RouteRecord{responseCount,timeoutCount,routeVersion,routeBirthTime} <- IntMap.lookup n rm
-                                = [ show n, show responseCount, show timeoutCount, show (now-routeBirthTime)
+                    | Just RouteRecord{responseCount,timeoutCount,routeVersion,routeBirthTime
+                                      ,storedRoute=Tox.OnionRoute{routeRelayPort}} <- IntMap.lookup n rm
+                                = [ show n, show responseCount, show timeoutCount
+                                  , maybe "" show routeRelayPort
+                                  , show (now - routeBirthTime)
                                   , if routeVersion >= wanted_ver
                                      then show routeVersion
                                      else show routeVersion ++ "(pending)" ]
@@ -701,11 +706,23 @@ clientSession s@Session{..} sock cnum h = do
                 r = map (uncurry showRecord) rs
             return $ do
                 hPutClientChunk h $ unlines [ "trampolines(UDP): " ++ show (IntMap.size ts,tcnt,icnt)
+                                                                   ++ if tcpmode then "" else " *"
                                             , "trampolines(TCP): " ++ show (IntMap.size tts,ttcnt,ticnt)
+                                                                   ++ if tcpmode then " *" else ""
                                             , "pending: " ++ show (W64.size pqs)
                                             , "TCP spill,cache,queue: "
                                                 ++ show (PSQ.size tcp_spill, PSQ.size tcp_cache, PSQ.size tcp_queue)]
-                hPutClient h $ showColumns $ ["","responses","timeouts", "age", "version"]:r
+                hPutClient h $ showColumns $ ["","responses","timeouts", "tcp", "age", "version"]:r
+
+        ("onion", s) | "udp" <- strp $ map toLower s
+                     -> cmd0 $ do
+            atomically $ writeTVar (tcpMode onionRouter) False
+            hPutClient h "Onion routes: UDP."
+
+        ("onion", s) | "tcp" <- strp $ map toLower s
+                     -> cmd0 $ do
+            atomically $ writeTVar (tcpMode onionRouter) True
+            hPutClient h "Onion routes: TCP."
 
         ("g", s) | Just DHT{..} <- Map.lookup netname dhts
                     -> cmd0 $ do
@@ -884,7 +901,7 @@ clientSession s@Session{..} sock cnum h = do
                                             akey
                                             (AnnounceMethod qsearch asend
                                                             (\nid -> R.kclosest (searchSpace qsearch)
-                                                                                searchK
+                                                                                (searchK qsearch)
                                                                                 nid
                                                                      <$> readTVar dhtBuckets)
                                                             (announceTarget dta)
@@ -910,7 +927,7 @@ clientSession s@Session{..} sock cnum h = do
                                             akey
                                             (SearchMethod qsearch (asend pub)
                                                             (\nid -> R.kclosest (searchSpace qsearch)
-                                                                                searchK
+                                                                                (searchK qsearch)
                                                                                 nid
                                                                      <$> readTVar dhtBuckets)
                                                             (announceTarget dta)
@@ -1514,7 +1531,9 @@ initTox opts ssvar keysdb mbxmpp invc = case porttox opts of
                     , dhtQuery = Map.singleton "node" DHTQuery
                                     { qsearch = TCP.nodeSearch tcpprober tcpclient
                                     , qhandler = \ni nid -> do
-                                        ns <- R.kclosest (searchSpace $ TCP.nodeSearch tcpprober tcpclient) searchK nid
+                                        ns <- R.kclosest (searchSpace $ TCP.nodeSearch tcpprober tcpclient)
+                                                         (searchK $ TCP.nodeSearch tcpprober tcpclient)
+                                                         nid
                                                 <$> atomically (readTVar $ refreshBuckets tcpRefresher)
                                         return (ns,ns,Just ())
                                     , qshowR = show -- TCP.NodeInfo