From 2b77920dcd98f63d7f45ec58de1337efbb294280 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Tue, 28 Feb 2023 23:26:08 +0000 Subject: [PATCH] teminal: option to log errors and service messages to file, closes #1516 (#1957) * teminal: option to log errors and service messages to file, closes #1516 * rename function --- src/Simplex/Chat.hs | 4 ++-- src/Simplex/Chat/Controller.hs | 23 ++++++++++++++++++++++- src/Simplex/Chat/Core.hs | 11 ++++++----- src/Simplex/Chat/Mobile.hs | 3 ++- src/Simplex/Chat/Options.hs | 21 +++++++++++++++++++-- src/Simplex/Chat/Terminal/Output.hs | 17 ++++++++++++----- tests/ChatClient.hs | 10 ++++++---- 7 files changed, 69 insertions(+), 20 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 131aaedf8..1649c4f4f 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -138,7 +138,7 @@ createChatDatabase filePrefix key yesToMigrations = do pure ChatDatabase {chatStore, agentStore} newChatController :: ChatDatabase -> Maybe User -> ChatConfig -> ChatOpts -> Maybe (Notification -> IO ()) -> IO ChatController -newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agentConfig = aCfg, defaultServers, inlineFiles} ChatOpts {coreOptions = CoreChatOpts {smpServers, networkConfig, logLevel, logConnections, logServerHosts, tbqSize}, optFilesFolder, allowInstantFiles} sendToast = do +newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agentConfig = aCfg, defaultServers, inlineFiles} ChatOpts {coreOptions = CoreChatOpts {smpServers, networkConfig, logLevel, logConnections, logServerHosts, logFile, tbqSize}, optFilesFolder, allowInstantFiles} sendToast = do let inlineFiles' = if allowInstantFiles then inlineFiles else inlineFiles {sendChunks = 0, receiveInstant = False} config = cfg {logLevel, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, defaultServers = configServers, inlineFiles = inlineFiles'} sendNotification = fromMaybe (const $ pure ()) sendToast @@ -163,7 +163,7 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen cleanupManagerAsync <- newTVarIO Nothing timedItemThreads <- atomically TM.empty showLiveItems <- newTVarIO False - pure ChatController {activeTo, firstTime, currentUser, smpAgent, agentAsync, chatStore, chatStoreChanged, idsDrg, inputQ, outputQ, notifyQ, chatLock, sndFiles, rcvFiles, currentCalls, config, sendNotification, incognitoMode, filesFolder, expireCIThreads, expireCIFlags, cleanupManagerAsync, timedItemThreads, showLiveItems} + pure ChatController {activeTo, firstTime, currentUser, smpAgent, agentAsync, chatStore, chatStoreChanged, idsDrg, inputQ, outputQ, notifyQ, chatLock, sndFiles, rcvFiles, currentCalls, config, sendNotification, incognitoMode, filesFolder, expireCIThreads, expireCIFlags, cleanupManagerAsync, timedItemThreads, showLiveItems, logFilePath = logFile} where configServers :: DefaultAgentServers configServers = diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index fb9f10564..c6a560d52 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -4,6 +4,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StrictData #-} @@ -165,7 +166,8 @@ data ChatController = ChatController expireCIFlags :: TMap UserId Bool, cleanupManagerAsync :: TVar (Maybe (Async ())), timedItemThreads :: TMap (ChatRef, ChatItemId) (TVar (Maybe (Weak ThreadId))), - showLiveItems :: TVar Bool + showLiveItems :: TVar Bool, + logFilePath :: Maybe FilePath } data HelpSection = HSMain | HSFiles | HSGroups | HSMyAddress | HSMarkdown | HSMessages | HSSettings @@ -487,6 +489,25 @@ data ChatResponse | CRChatError {user_ :: Maybe User, chatError :: ChatError} deriving (Show, Generic) +logResponseToFile :: ChatResponse -> Bool +logResponseToFile = \case + CRContactsDisconnected {} -> True + CRContactsSubscribed {} -> True + CRContactSubError {} -> True + CRMemberSubError {} -> True + CRSndFileSubError {} -> True + CRRcvFileSubError {} -> True + CRHostConnected {} -> True + CRHostDisconnected {} -> True + CRConnectionDisabled {} -> True + CRAgentRcvQueueDeleted {} -> True + CRAgentConnDeleted {} -> True + CRAgentUserDeleted {} -> True + CRChatCmdError {} -> True + CRChatError {} -> True + CRMessageError {} -> True + _ -> False + instance ToJSON ChatResponse where toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "CR" toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "CR" diff --git a/src/Simplex/Chat/Core.hs b/src/Simplex/Chat/Core.hs index 83bed16bf..aa242a089 100644 --- a/src/Simplex/Chat/Core.hs +++ b/src/Simplex/Chat/Core.hs @@ -14,11 +14,12 @@ import Simplex.Chat.Types import UnliftIO.Async simplexChatCore :: ChatConfig -> ChatOpts -> Maybe (Notification -> IO ()) -> (User -> ChatController -> IO ()) -> IO () -simplexChatCore cfg@ChatConfig {yesToMigrations} opts@ChatOpts {coreOptions = CoreChatOpts {dbFilePrefix, dbKey, logAgent}} sendToast chat - | logAgent = do - setLogLevel LogInfo -- LogError - withGlobalLogging logCfg initRun - | otherwise = initRun +simplexChatCore cfg@ChatConfig {yesToMigrations} opts@ChatOpts {coreOptions = CoreChatOpts {dbFilePrefix, dbKey, logAgent}} sendToast chat = + case logAgent of + Just level -> do + setLogLevel level + withGlobalLogging logCfg initRun + _ -> initRun where initRun = do db@ChatDatabase {chatStore} <- createChatDatabase dbFilePrefix dbKey yesToMigrations diff --git a/src/Simplex/Chat/Mobile.hs b/src/Simplex/Chat/Mobile.hs index 6820d3c1f..172a0c179 100644 --- a/src/Simplex/Chat/Mobile.hs +++ b/src/Simplex/Chat/Mobile.hs @@ -134,7 +134,8 @@ mobileChatOpts dbFilePrefix dbKey = logLevel = CLLImportant, logConnections = False, logServerHosts = True, - logAgent = False, + logAgent = Nothing, + logFile = Nothing, tbqSize = 1024 }, chatCmd = "", diff --git a/src/Simplex/Chat/Options.hs b/src/Simplex/Chat/Options.hs index 63ff7e1b2..8631e7a27 100644 --- a/src/Simplex/Chat/Options.hs +++ b/src/Simplex/Chat/Options.hs @@ -16,6 +16,7 @@ module Simplex.Chat.Options ) where +import Control.Logger.Simple (LogLevel (..)) import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B import Numeric.Natural (Natural) @@ -46,10 +47,19 @@ data CoreChatOpts = CoreChatOpts logLevel :: ChatLogLevel, logConnections :: Bool, logServerHosts :: Bool, - logAgent :: Bool, + logAgent :: Maybe LogLevel, + logFile :: Maybe FilePath, tbqSize :: Natural } +agentLogLevel :: ChatLogLevel -> LogLevel +agentLogLevel = \case + CLLDebug -> LogDebug + CLLInfo -> LogInfo + CLLWarning -> LogWarn + CLLError -> LogError + CLLImportant -> LogInfo + coreChatOptsP :: FilePath -> FilePath -> Parser CoreChatOpts coreChatOptsP appDir defaultDbFileName = do dbFilePrefix <- @@ -125,6 +135,12 @@ coreChatOptsP appDir defaultDbFileName = do ( long "log-agent" <> help "Enable logs from SMP agent (also with `-l debug`)" ) + logFile <- + optional $ + strOption + ( long "log-file" + <> help "Log to specified file / device" + ) tbqSize <- option auto @@ -144,7 +160,8 @@ coreChatOptsP appDir defaultDbFileName = do logLevel, logConnections = logConnections || logLevel <= CLLInfo, logServerHosts = logServerHosts || logLevel <= CLLInfo, - logAgent = logAgent || logLevel == CLLDebug, + logAgent = if logAgent || logLevel == CLLDebug then Just $ agentLogLevel logLevel else Nothing, + logFile, tbqSize } where diff --git a/src/Simplex/Chat/Terminal/Output.hs b/src/Simplex/Chat/Terminal/Output.hs index faf7a974f..f82f7335f 100644 --- a/src/Simplex/Chat/Terminal/Output.hs +++ b/src/Simplex/Chat/Terminal/Output.hs @@ -19,6 +19,7 @@ import Simplex.Chat.Messages hiding (NewChatItem (..)) import Simplex.Chat.Styled import Simplex.Chat.View import System.Console.ANSI.Types +import System.IO (IOMode (..), hPutStrLn, withFile) import System.Mem.Weak (Weak) import System.Terminal import System.Terminal.Internal (LocalTerminal, Terminal, VirtualTerminal) @@ -91,17 +92,19 @@ withTermLock ChatTerminal {termLock} action = do atomically $ putTMVar termLock () runTerminalOutput :: ChatTerminal -> ChatController -> IO () -runTerminalOutput ct cc@ChatController {outputQ, showLiveItems} = do +runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} = do forever $ do (_, r) <- atomically $ readTBQueue outputQ case r of CRNewChatItem _ ci -> markChatItemRead ci CRChatItemUpdated _ ci -> markChatItemRead ci _ -> pure () + let printResp = case logFilePath of + Just path -> if logResponseToFile r then logResponse path else printToTerminal ct + _ -> printToTerminal ct liveItems <- readTVarIO showLiveItems - printRespToTerminal ct cc liveItems r + responseString cc liveItems r >>= printResp where - markChatItemRead :: AChatItem -> IO () markChatItemRead (AChatItem _ _ chat item@ChatItem {meta = CIMeta {itemStatus}}) = case (muted chat item, itemStatus) of (False, CISRcvNew) -> do @@ -109,12 +112,16 @@ runTerminalOutput ct cc@ChatController {outputQ, showLiveItems} = do chatRef = chatInfoToRef chat void $ runReaderT (runExceptT $ processChatCommand (APIChatRead chatRef (Just (itemId, itemId)))) cc _ -> pure () + logResponse path s = withFile path AppendMode $ \h -> mapM_ (hPutStrLn h . unStyle) s printRespToTerminal :: ChatTerminal -> ChatController -> Bool -> ChatResponse -> IO () -printRespToTerminal ct cc liveItems r = do +printRespToTerminal ct cc liveItems r = responseString cc liveItems r >>= printToTerminal ct + +responseString :: ChatController -> Bool -> ChatResponse -> IO [StyledString] +responseString cc liveItems r = do user <- readTVarIO $ currentUser cc ts <- getCurrentTime - printToTerminal ct $ responseToView user (config cc) liveItems ts r + pure $ responseToView user (config cc) liveItems ts r printToTerminal :: ChatTerminal -> [StyledString] -> IO () printToTerminal ct s = diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index cdbf91ee2..b914dd2e3 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -59,8 +59,9 @@ testOpts = logLevel = CLLImportant, logConnections = False, logServerHosts = False, - logAgent = False, - tbqSize = 64 + logAgent = Nothing, + logFile = Nothing, + tbqSize = 16 }, chatCmd = "", chatCmdDelay = 3, @@ -91,7 +92,7 @@ data TestCC = TestCC } aCfg :: AgentConfig -aCfg = agentConfig defaultChatConfig +aCfg = (agentConfig defaultChatConfig) {tbqSize = 16} testAgentCfg :: AgentConfig testAgentCfg = aCfg {reconnectInterval = (reconnectInterval aCfg) {initialInterval = 50000}} @@ -100,7 +101,8 @@ testCfg :: ChatConfig testCfg = defaultChatConfig { agentConfig = testAgentCfg, - testView = True + testView = True, + tbqSize = 16 } testAgentCfgV1 :: AgentConfig