4 files changed, 55 insertions, 26 deletions

diff --git a/dht-client.cabal b/dht-client.cabal
index d6d6600e..14c691b0 100644
--- a/dht-client.cabal
+++ b/dht-client.cabal
@@ -146,6 +146,7 @@ library
                     ToxToXMPP
                     ToxManager
                     XMPPToTox
+                    DebugUtil
 
   build-depends:      base
                     , containers
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index e4b10b8d..3f2a6a63 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -69,6 +69,7 @@ import Announcer
 import Announcer.Tox
 import ToxManager
 import Crypto.Tox -- (zeros32,SecretKey,PublicKey, generateSecretKey, toPublic, encodeSecret, decodeSecret, userKeys)
+import DebugUtil
 import Network.UPNP as UPNP
 import Network.Address hiding (NodeId, NodeInfo(..))
 import Network.QueryResponse
@@ -124,17 +125,6 @@ import qualified Data.CyclicBuffer as CB
 import DPut
 
 
-showReport :: [(String,String)] -> String
-showReport kvs = showColumns $ map (\(x,y)->[x,y]) kvs
-
-showColumns :: [[String]] -> String
-showColumns rows = do
-    let cols = transpose rows
-        ws = map (maximum . map (succ . length)) cols
-    fs <- rows
-    _ <- take 1 fs -- Guard against empty rows so that 'last' is safe.
-    "  " ++ concat (zipWith (printf "%-*s") (init ws) (init fs)) ++ last fs ++ "\n"
-
 pshow :: Show a => a -> B.ByteString
 pshow = B.pack . show
 
@@ -471,19 +461,9 @@ clientSession s@Session{..} sock cnum h = do
                         >>= hPutClient h
 #ifdef THREAD_DEBUG
         ("threads", s) -> cmd0 $ do
-                    threads <- threadsInformation
-                    tm <- getCurrentTime
-                    let (ss,ts) = partition (("search" `isPrefixOf`) . lbl . snd)
-                                            threads
-                        want_ss = ["-v"] `isInfixOf` words s
-                    r <- forM (if want_ss then threads else ts) $ \(tid,PerThread{..}) -> do
-                        stat <- threadStatus tid
-                        let showStat (ThreadBlocked reason) = show reason
-                            showStat stat                   = show stat
-                        return [show lbl,show (diffUTCTime tm startTime),showStat stat]
-                    hPutClient h $ unlines [ showColumns r
-                                           , (if want_ss then "  There are " else "  and ")
-                                             ++ show (length ss) ++ " search threads." ]
+                    let want_ss = ["-v"] `isInfixOf` words s
+                    r <- threadReport want_ss
+                    hPutClient h r
 #endif
         ("mem", s) -> cmd0 $ do
                     case s of
diff --git a/examples/testTox.hs b/examples/testTox.hs
index 45bc661e..53ed25dc 100644
--- a/examples/testTox.hs
+++ b/examples/testTox.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE NamedFieldPuns #-}
+import Control.Concurrent (threadDelay)
 import Control.Concurrent.STM.TChan
 import Control.Concurrent.STM.TMChan
 import Control.Concurrent.STM.TVar
@@ -6,6 +7,8 @@ import Control.Concurrent.Supply
 import Control.Monad.STM
 import Crypto.Tox
 import qualified Data.IntMap.Strict          as IntMap
+import DebugUtil
+import DPut
 import Network.QueryResponse
 import Network.Socket
 import Network.Tox
@@ -14,7 +17,6 @@ import qualified Network.Tox.Crypto.Handlers as CH
 import Network.Tox.Crypto.Transport
 import Network.Tox.DHT.Handlers              as DHT
 import Network.Tox.Onion.Transport           (UDPTransport)
-import DPut
 
 
 makeToxNode :: UDPTransport -> Maybe SecretKey -> IO (Tox extra)
@@ -71,10 +73,15 @@ main = do
     (a_quit,_,_) <- forkTox a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf False
     (b_quit,_,_) <- forkTox b_OM7znaPMYkTbm'9GcZJAdnDATXmZxZ9fnaSTP3qNCZk False
 
+    threadReport False >>= putStrLn
 
     DHT.ping (toxDHT a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf) b
 
     putStrLn "Type Enter to quit..."
     getLine
 
-    return ()
+    a_quit
+    b_quit
+
+    threadDelay 500000
+    threadReport False >>= putStrLn
diff --git a/src/DebugUtil.hs b/src/DebugUtil.hs
new file mode 100644
index 00000000..e7a10397
--- /dev/null
+++ b/src/DebugUtil.hs
@@ -0,0 +1,41 @@
+{-# LANGUAGE CPP #-}
+module DebugUtil where
+
+import Control.Monad
+import Data.Time.Clock
+import Data.List
+import Text.Printf
+import GHC.Conc (threadStatus,ThreadStatus(..))
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument
+#else
+import Control.Concurrent.Lifted
+import GHC.Conc                  (labelThread)
+#endif
+
+showReport :: [(String,String)] -> String
+showReport kvs = showColumns $ map (\(x,y)->[x,y]) kvs
+
+showColumns :: [[String]] -> String
+showColumns rows = do
+    let cols = transpose rows
+        ws = map (maximum . map (succ . length)) cols
+    fs <- rows
+    _ <- take 1 fs -- Guard against empty rows so that 'last' is safe.
+    "  " ++ concat (zipWith (printf "%-*s") (init ws) (init fs)) ++ last fs ++ "\n"
+
+
+threadReport :: Bool -> IO String
+threadReport want_ss = do
+    threads <- threadsInformation
+    tm <- getCurrentTime
+    let (ss,ts) = partition (("search" `isPrefixOf`) . lbl . snd)
+                            threads
+    r <- forM (if want_ss then threads else ts) $ \(tid,PerThread{..}) -> do
+        stat <- threadStatus tid
+        let showStat (ThreadBlocked reason) = show reason
+            showStat stat                   = show stat
+        return [show lbl,show (diffUTCTime tm startTime),showStat stat]
+    return $ unlines [ showColumns r
+                     , (if want_ss then "  There are " else "  and ")
+                        ++ show (length ss) ++ " search threads." ]