Removed tput hack.

1 files changed, 32 insertions, 21 deletions

diff --git a/dht/examples/dhtd.hs b/dht/examples/dhtd.hs
index 984afeed..c36508ef 100644
--- a/dht/examples/dhtd.hs
+++ b/dht/examples/dhtd.hs
@@ -687,20 +687,22 @@ clientSession s@Session{..} sock cnum h = do
                         cf <- readTVar $ contactFriendRequest c
                         cp <- readTVar $ contactPolicy c
                         let summarizeNodeId | nosummary = id
-                                            | otherwise = take 6
+                                            | otherwise = take 20
                             summarizeAddr | nosummary = id
                                           | otherwise = reverse . take 20 . reverse
                         return $ [ maybe "/" showPolicy cp
-                                 , maybe "" (summarizeNodeId . show . Tox.key2id . Tox.dhtpk . snd) ck
-                                 , maybe "" (summarizeAddr . show . snd) ca
+                                 , maybe (maybe "" (summarizeNodeId . show . Tox.key2id . Tox.dhtpk . snd) ck)
+                                         (summarizeAddr . show . snd)
+                                         ca
                                  , maybe "" (show . T.decodeUtf8 . Tox.friendRequestText . snd) cf
                                  ]
             return $ do
                 forM_ (HashMap.toList css) $ \(me,xss) -> do
                     let cs = map (\(toxid,xs) -> show toxid : xs)
                                  $ HashMap.toList xss
-                    hPutClientChunk h $ unlines [ show me, map (const '-') (show me) ]
-                    hPutClientChunk h $ showColumns $ ["ToxID","","NodeID","Address","FR text"]
+                    hPutClientChunk h $ let header = show me ++ if nosummary then "" else " (pass -v for more)"
+                                        in unlines [ header, map (const '-') header ]
+                    hPutClientChunk h $ showColumns $ ["ToxID","","Address","FR text"]
                                                       : cs
                 hPutClient h ""
 
@@ -1315,14 +1317,15 @@ newXmmpSink session@(Tox.NCrypto { ncOutgoingQueue = outGoingQVar }) = C.awaitFo
 -}
 
 
-onNewToxSession :: XMPPServer
+onNewToxSession :: (IO () -> STM ())
+                     -> XMPPServer
                      -> TVar (Map.Map Uniq24 AggregateSession)
                      -> InviteCache IO
                      -> ContactInfo extra
                      -> SockAddr
                      -> Tox.Session
                      -> IO ()
-onNewToxSession sv ssvar invc ContactInfo{accounts} addrTox netcrypto = do
+onNewToxSession runio sv ssvar invc ContactInfo{accounts} addrTox netcrypto = do
     let them s = Tox.longTermKey $ runIdentity cookie -- remote tox key
          where Tox.Cookie _ cookie = Tox.handshakeCookie (sReceivedHandshake s)
 
@@ -1331,9 +1334,10 @@ onNewToxSession sv ssvar invc ContactInfo{accounts} addrTox netcrypto = do
         onStatusChange :: (Tox.Session -> Tcp.ConnectionEvent XML.Event -> STM ())
                           -> AggregateSession -> Tox.Session -> Status Tox.ToxProgress -> STM ()
         onStatusChange announce c s Established = onConnect announce c s
-        onStatusChange announce _ s _           = onEOF announce s
+        onStatusChange announce _ s status      = onEOF announce s status
 
-        onEOF announce s = do
+        onEOF announce s status = do
+            runio $ dput XMan $ "EOF(" ++ take 16 (showKey256 $ them s) ++ "): " ++ show status
             HashMap.lookup (Tox.key2id $ me s) <$> readTVar accounts
                 >>= mapM_ (setTerminated $ them s)
             announce s Tcp.EOF
@@ -1391,8 +1395,8 @@ getToxContacts a = case cast a of
 aggSessionKey :: Tox.ToxContact -> IO Uniq24
 aggSessionKey (Tox.ToxContact me them) = xor24 <$> hash24 (Tox.id2key me) <*> hash24 (Tox.id2key them)
 
-selectManager :: Maybe (t -> ToxManager clientAddress) -> Manager Tcp.TCPStatus T.Text -> T.Text -> Manager Pending T.Text
-selectManager mtman tcp profile = case stripSuffix ".tox" profile of
+selectManager :: Announcer -> Maybe (t -> ToxManager clientAddress) -> Manager Tcp.TCPStatus T.Text -> T.Text -> Manager Pending T.Text
+selectManager announcer mtman tcp profile = case stripSuffix ".tox" profile of
     Just k | Just tman <- mtman
                -> let -- The following error call is safe because the toxConnections field
                       -- does not make use of the PresenceState passed to tman.
@@ -1436,7 +1440,8 @@ selectManager mtman tcp profile = case stripSuffix ".tox" profile of
                                             cs <- connections tox
                                             let ncs = length cs
                                                 nms = length $ mapMaybe valid cs
-                                            tput XMan $ "Manager{Tox} (all,valid)=" ++ show (ncs,nms)
+                                            runAction announcer "Tox.connections" $ do
+                                                dput XMan $ "Manager{Tox} (all,valid)=" ++ show (ncs,nms)
                                             return cs
                     , stringToKey = \s -> Just $ T.pack (s ++ ".tox")
                     , showProgress = \(ToxStatus stat) -> showProgress tox stat
@@ -1454,14 +1459,16 @@ selectManager mtman tcp profile = case stripSuffix ".tox" profile of
                     , status =  \k -> fmap XMPPStatus <$> status tcp k
                     , connections = do
                         cs <- connections tcp
-                        tput XMan $ "Manager{TCP} cons=" ++ show (length cs)
+                        runAction announcer "TCP.connections" $ do
+                            dput XMan $ "Manager{TCP} cons=" ++ show (length cs)
                         return cs
                     , stringToKey = stringToKey tcp
                     , showProgress = \(XMPPStatus stat) -> showProgress tcp stat
                     }
 
 
-initTox :: Options
+initTox :: (IO () -> STM ())
+           -> Options
            -> TVar (Map.Map Uniq24 AggregateSession)
            -> TVar Tox.AnnouncedKeys
            -> Maybe XMPPServer
@@ -1470,7 +1477,7 @@ initTox :: Options
                  , Map.Map String DHT
                  , IO [SockAddr]
                  , [SockAddr])
-initTox opts ssvar keysdb mbxmpp invc = case porttox opts of
+initTox runio opts ssvar keysdb mbxmpp invc = case porttox opts of
         [""] -> return (Nothing,return (), Map.empty, return [],[])
         toxport -> do
             dput XMisc $ "Supplied key: " ++ show (fmap (Tox.key2id . toPublic) (dhtkey opts))
@@ -1479,7 +1486,7 @@ initTox opts ssvar keysdb mbxmpp invc = case porttox opts of
                               toxport
                               (case mbxmpp of
                                 Nothing   -> \_ _ _ -> return ()
-                                Just xmpp -> onNewToxSession xmpp ssvar invc)
+                                Just xmpp -> onNewToxSession runio xmpp ssvar invc)
                               crypto
                               (enableTCPDHT opts)
             -- addrTox <- getBindAddress toxport (ip6tox opts)
@@ -1730,7 +1737,7 @@ initJabber opts ssvar announcer mbtox toxchat = case portxmpp opts of
             sv <- xmppServer Tcp.noCleanUp (Just sport)
             tcp <- xmppConnections sv -- :: IO ( Manager TCPStatus T.Text )
             let tman = toxman ssvar announcer <$> mbtox
-            state     <- newPresenceState cw tman sv (selectManager tman tcp)
+            state     <- newPresenceState cw tman sv (selectManager announcer tman tcp)
             chat <- atomically newMUC
             quitChatService <- forkLocalChat chat
             let chats = Map.fromList [ ("local", chat)
@@ -1866,9 +1873,10 @@ main = do
     keysdb <- Tox.newKeysDatabase
 
     ssvar <- atomically $ newTVar Map.empty :: IO ( TVar (Map.Map Uniq24 AggregateSession) )
+    ioChan <- atomically newTChan
     rec (mbtox,quitTox,toxdhts,toxips,(taddrs::[SockAddr]),msv,mconns,mstate) <- do
 
-        (mbtox,quitTox,toxdhts,toxips,(taddrs::[SockAddr])) <- initTox opts ssvar keysdb msv invc
+        (mbtox,quitTox,toxdhts,toxips,(taddrs::[SockAddr])) <- initTox (writeTChan ioChan) opts ssvar keysdb msv invc
 
         (msv,mconns,mstate,quitChat) <- initJabber opts ssvar announcer mbtox toxchat
 
@@ -1910,8 +1918,8 @@ main = do
                 , sessionsVar       = ssvar
                 }
         srv <- forkStreamServer (withSession session) [SockAddrUnix "dht.sock"]
-        return ( do atomically $ readTVar signalQuit >>= check
-                    quitListening srv
+        return ( do readTVar signalQuit >>= check
+                    return $ quitListening srv
                , readTVar signalQuit >>= check
                )
 
@@ -1950,7 +1958,10 @@ main = do
 
     -- Wait for DHT and XMPP threads to finish.
     -- Use ResourceT to clean-up XMPP server.
-    waitForSignal
+    fix $ \loop ->
+        join $ atomically $ orElse waitForSignal $ do
+            action <- readTChan ioChan
+            return $ action >> loop
 
     forM_ mstate $ \PresenceState{server=xmpp} -> do
         quitXmpp xmpp