From 6be7ff71f850e90f61c8f3b80b2b513b34891c57 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Sat, 11 Jan 2020 21:24:17 -0500 Subject: Removed tput hack. --- dht/examples/dhtd.hs | 53 ++++++++++++++++++++++++++++------------------- dput-hslogger/src/DPut.hs | 8 ------- 2 files changed, 32 insertions(+), 29 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 diff --git a/dput-hslogger/src/DPut.hs b/dput-hslogger/src/DPut.hs index 38e532d0..7a0015b6 100644 --- a/dput-hslogger/src/DPut.hs +++ b/dput-hslogger/src/DPut.hs @@ -33,14 +33,6 @@ dputB tag msg = liftIO $ debugM (appName <.> show tag) (T.unpack . T.decodeUtf8 verbosityMap :: IORef (Map.Map TypeRep Dynamic) verbosityMap = unsafePerformIO $ newIORef (Map.empty) --- | Trace version of 'dput' works in arbitrary monad, using unsafePerformIO. -tput :: (Applicative m, IsDebugTag tag) => tag -> String -> m () -tput tag msg = - let mp = unsafePerformIO $ readIORef verbosityMap - in if maybe True (fromMaybe True . Map.lookup tag . flip fromDyn Map.empty) (Map.lookup (typeOf tag) mp) - then trace msg (pure ()) - else pure () - -- | like 'trace' but parameterized with 'DebugTag' dtrace :: forall a tag. IsDebugTag tag => tag -> String -> a -> a dtrace tag msg result = let mp = unsafePerformIO $ readIORef verbosityMap -- cgit v1.2.3