diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index eefb1f77a4..64ba0cf974 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/apps/simplex-directory-service/src/Directory/Service.hs @@ -31,7 +31,7 @@ import Directory.Search import Directory.Store import Simplex.Chat.Bot import Simplex.Chat.Bot.KnownContacts -import Simplex.Chat.Controller +import Simplex.Chat.Controller hiding (logError, logInfo) import Simplex.Chat.Core import Simplex.Chat.Messages import Simplex.Chat.Options @@ -586,7 +586,8 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi sendChatCmdStr cc cmdStr >>= \r -> do ts <- getCurrentTime tz <- getCurrentTimeZone - sendReply $ serializeChatResponse (Nothing, Just user) ts tz Nothing r + ll <- readTVarIO $ appLogLevel cc + sendReply $ serializeChatResponse (Nothing, Just user) ll ts tz Nothing r DCCommandError tag -> sendReply $ "Command error: " <> show tag | otherwise = sendReply "You are not allowed to use this command" where diff --git a/cabal.project b/cabal.project index 1a6942e4b5..5452473e05 100644 --- a/cabal.project +++ b/cabal.project @@ -12,7 +12,7 @@ constraints: zip +disable-bzip2 +disable-zstd source-repository-package type: git location: https://github.com/simplex-chat/simplexmq.git - tag: 1116aeeea1869e0de38e9faccea76b329b549804 + tag: 71489fe6fca70f32f18137186bab2b77304f11b0 source-repository-package type: git diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index 06875457b0..43a297b8c3 100644 --- a/scripts/nix/sha256map.nix +++ b/scripts/nix/sha256map.nix @@ -1,5 +1,5 @@ { - "https://github.com/simplex-chat/simplexmq.git"."1116aeeea1869e0de38e9faccea76b329b549804" = "07ynn7f70hfsdrirmhb9zd257bx90d29l5gjyhh50wd12gaqdm0w"; + "https://github.com/simplex-chat/simplexmq.git"."71489fe6fca70f32f18137186bab2b77304f11b0" = "18inrqiab269w7dw1isjrijgnycv0dz0bp1y9sq5z9fykvwg5rlh"; "https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38"; "https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d"; "https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl"; diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index acdfe116ff..5335955ec0 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -17,7 +17,7 @@ module Simplex.Chat where import Control.Applicative (optional, (<|>)) import Control.Concurrent.STM (retry) -import Control.Logger.Simple +import Control.Logger.Simple (LogConfig (..)) import Control.Monad import Control.Monad.Except import Control.Monad.IO.Unlift @@ -155,7 +155,6 @@ defaultChatConfig = autoAcceptFileSize = 0, showReactions = False, showReceipts = False, - logLevel = CLLImportant, subscriptionEvents = False, hostEvents = False, testView = False, @@ -218,7 +217,7 @@ newChatController ChatOpts {coreOptions = CoreChatOpts {smpServers, xftpServers, networkConfig, logLevel, logConnections, logServerHosts, logFile, tbqSize, highlyAvailable}, deviceName, optFilesFolder, optTempDirectory, showReactions, allowInstantFiles, autoAcceptFileSize} backgroundMode = do let inlineFiles' = if allowInstantFiles || autoAcceptFileSize > 0 then inlineFiles else inlineFiles {sendChunks = 0, receiveInstant = False} - config = cfg {logLevel, showReactions, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, defaultServers = configServers, inlineFiles = inlineFiles', autoAcceptFileSize, highlyAvailable} + config = cfg {showReactions, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, defaultServers = configServers, inlineFiles = inlineFiles', autoAcceptFileSize, highlyAvailable} firstTime = dbNew chatStore currentUser <- newTVarIO user currentRemoteHost <- newTVarIO Nothing @@ -241,6 +240,7 @@ newChatController remoteHostSessions <- atomically TM.empty remoteHostsFolder <- newTVarIO Nothing remoteCtrlSession <- newTVarIO Nothing + appLogLevel <- newTVarIO logLevel filesFolder <- newTVarIO optFilesFolder chatStoreChanged <- newTVarIO False expireCIThreads <- newTVarIO M.empty @@ -279,6 +279,7 @@ newChatController remoteHostsFolder, remoteCtrlSession, config, + appLogLevel, filesFolder, expireCIThreads, expireCIFlags, @@ -436,18 +437,19 @@ restoreCalls = do calls <- asks currentCalls atomically $ writeTVar calls callsMap -stopChatController :: ChatController -> IO () +stopChatController :: ChatController -> CM' () stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles, expireCIFlags, remoteHostSessions, remoteCtrlSession} = do readTVarIO remoteHostSessions >>= mapM_ (cancelRemoteHost False . snd) - atomically (stateTVar remoteCtrlSession (,Nothing)) >>= mapM_ (cancelRemoteCtrl False . snd) - disconnectAgentClient smpAgent - readTVarIO s >>= mapM_ (\(a1, a2) -> uninterruptibleCancel a1 >> mapM_ uninterruptibleCancel a2) - closeFiles sndFiles - closeFiles rcvFiles - atomically $ do - keys <- M.keys <$> readTVar expireCIFlags - forM_ keys $ \k -> TM.insert k False expireCIFlags - writeTVar s Nothing + liftIO $ do + atomically (stateTVar remoteCtrlSession (,Nothing)) >>= mapM_ (cancelRemoteCtrl False . snd) + disconnectAgentClient smpAgent + readTVarIO s >>= mapM_ (\(a1, a2) -> uninterruptibleCancel a1 >> mapM_ uninterruptibleCancel a2) + closeFiles sndFiles + closeFiles rcvFiles + atomically $ do + keys <- M.keys <$> readTVar expireCIFlags + forM_ keys $ \k -> TM.insert k False expireCIFlags + writeTVar s Nothing where closeFiles :: TVar (Map Int64 Handle) -> IO () closeFiles files = do @@ -601,7 +603,7 @@ processChatCommand' vr = \case Just _ -> pure CRChatRunning _ -> checkStoreNotChanged . lift $ startChatController mainApp $> CRChatStarted APIStopChat -> do - ask >>= liftIO . stopChatController + ask >>= lift . stopChatController pure CRChatStopped APIActivateChat restoreChat -> withUser $ \_ -> do lift $ when restoreChat restoreCalls @@ -2199,6 +2201,10 @@ processChatCommand' vr = \case chatMigrations <- map upMigration <$> withStore' (Migrations.getCurrent . DB.conn) agentMigrations <- withAgent getAgentMigrations pure $ CRVersionInfo {versionInfo, chatMigrations, agentMigrations} + SetAppLogLevel ll -> do + chatWriteVar appLogLevel ll + lift $ withAgent' (`setAgentLogLevel` toLogLevel ll) + ok_ DebugLocks -> lift $ do chatLockName <- atomically . tryReadTMVar =<< asks chatLock chatEntityLocks <- getLocks =<< asks entityLocks @@ -3629,6 +3635,7 @@ processAgentMessageNoConn = \case UP srv conns -> serverEvent srv conns NSConnected CRContactsSubscribed SUSPENDED -> toView CRChatSuspended DEL_USER agentUserId -> toView $ CRAgentUserDeleted agentUserId + LOG ll s -> toView $ CRAgentLog ll s where hostEvent :: ChatResponse -> CM () hostEvent = whenM (asks $ hostEvents . config) . toView @@ -7377,6 +7384,7 @@ chatCommandP = "/_download " *> (APIDownloadStandaloneFile <$> A.decimal <* A.space <*> strP_ <*> cryptoFileP), ("/quit" <|> "/q" <|> "/exit") $> QuitChat, ("/version" <|> "/v") $> ShowVersion, + "/log " *> (SetAppLogLevel <$> strP), "/debug locks" $> DebugLocks, "/debug event " *> (DebugEvent <$> jsonP), "/get stats" $> GetAgentStats, diff --git a/src/Simplex/Chat/Bot.hs b/src/Simplex/Chat/Bot.hs index c5c5ff7eed..860b4f1df2 100644 --- a/src/Simplex/Chat/Bot.hs +++ b/src/Simplex/Chat/Bot.hs @@ -85,9 +85,9 @@ textMsgContent :: String -> MsgContent textMsgContent = MCText . T.pack printLog :: ChatController -> ChatLogLevel -> String -> IO () -printLog cc level s - | logLevel (config cc) <= level = putStrLn s - | otherwise = pure () +printLog cc level s = do + ll <- readTVarIO $ appLogLevel cc + when (ll <= level) $ putStrLn s contactInfo :: Contact -> String contactInfo Contact {contactId, localDisplayName} = T.unpack localDisplayName <> " (" <> show contactId <> ")" diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 267298f188..e8ccb066c3 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -19,6 +19,8 @@ module Simplex.Chat.Controller where import Control.Concurrent (ThreadId) import Control.Concurrent.Async (Async) import Control.Exception +import qualified Control.Logger.Simple as Logger +import Control.Monad (when) import Control.Monad.Except import Control.Monad.IO.Unlift import Control.Monad.Reader @@ -139,7 +141,6 @@ data ChatConfig = ChatConfig showReceipts :: Bool, subscriptionEvents :: Bool, hostEvents :: Bool, - logLevel :: ChatLogLevel, testView :: Bool, initialCleanupManagerDelay :: Int64, cleanupManagerInterval :: NominalDiffTime, @@ -221,6 +222,7 @@ data ChatController = ChatController remoteHostsFolder :: TVar (Maybe FilePath), -- folder for remote hosts data remoteCtrlSession :: TVar (Maybe (SessionSeq, RemoteCtrlSession)), -- Supervisor process for hosted controllers config :: ChatConfig, + appLogLevel :: TVar ChatLogLevel, filesFolder :: TVar (Maybe FilePath), -- path to files folder for mobile apps, expireCIThreads :: TMap UserId (Maybe (Async ())), expireCIFlags :: TMap UserId Bool, @@ -493,6 +495,7 @@ data ChatCommand | APIStandaloneFileInfo FileDescriptionURI | QuitChat | ShowVersion + | SetAppLogLevel ChatLogLevel | DebugLocks | DebugEvent ChatResponse | GetAgentStats @@ -757,6 +760,8 @@ data ChatResponse | CRChatCmdError {user_ :: Maybe User, chatError :: ChatError} | CRChatError {user_ :: Maybe User, chatError :: ChatError} | CRChatErrors {user_ :: Maybe User, chatErrors :: [ChatError]} + | CRAgentLog {agentLogLevel :: AgentLogLevel, errorMessage :: Text} + | CRChatLog {chatLogLevel :: ChatLogLevel, errorMessage :: Text} | CRArchiveImported {archiveErrors :: [ArchiveError]} | CRAppSettings {appSettings :: AppSettings} | CRTimedAction {action :: String, durationMilliseconds :: Int64} @@ -1053,6 +1058,30 @@ tmeToPref currentTTL tme = uncurry TimedMessagesPreference $ case tme of data ChatLogLevel = CLLDebug | CLLInfo | CLLWarning | CLLError | CLLImportant deriving (Eq, Ord, Show) +instance StrEncoding ChatLogLevel where + strEncode = \case + CLLDebug -> "debug" + CLLInfo -> "info" + CLLWarning -> "warn" + CLLError -> "error" + CLLImportant -> "important" + strP = + A.takeTill (== ' ') + >>= \case + "debug" -> pure CLLDebug + "info" -> pure CLLInfo + "warn" -> pure CLLWarning + "error" -> pure CLLError + "important" -> pure CLLImportant + _ -> fail "Invalid log level" + +instance ToJSON ChatLogLevel where + toJSON = strToJSON + toEncoding = strToJEncoding + +instance FromJSON ChatLogLevel where + parseJSON = strParseJSON "ChatLogLevel" + data CoreVersionInfo = CoreVersionInfo { version :: String, simplexmqVersion :: String, @@ -1397,6 +1426,34 @@ withAgent action = withAgent' :: (AgentClient -> IO a) -> CM' a withAgent' action = asks smpAgent >>= liftIO . action +logDebug :: Text -> CM () +logDebug = lift . logDebug' +{-# INLINE logDebug #-} + +logDebug' :: Text -> CM' () +logDebug' s = logToView CLLDebug s >> Logger.logDebug s + +logInfo :: Text -> CM () +logInfo s = lift (logToView CLLInfo s) >> Logger.logInfo s + +logWarn :: Text -> CM () +logWarn s = lift (logToView CLLWarning s) >> Logger.logWarn s + +logError :: Text -> CM () +logError = lift . logError' +{-# INLINE logError #-} + +logError' :: Text -> CM' () +logError' s = logToView CLLError s >> Logger.logError s + +logImportant :: Text -> CM () +logImportant s = lift (logToView CLLImportant s) >> Logger.logError s + +logToView :: ChatLogLevel -> Text -> CM' () +logToView ll' s = do + ll <- chatReadVar' appLogLevel + when (ll' >= ll) $ toView' $ CRChatLog ll s + $(JQ.deriveJSON (enumJSON $ dropPrefix "HS") ''HelpSection) $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CLQ") ''ChatListQuery) diff --git a/src/Simplex/Chat/Core.hs b/src/Simplex/Chat/Core.hs index a8580746d1..a175237432 100644 --- a/src/Simplex/Chat/Core.hs +++ b/src/Simplex/Chat/Core.hs @@ -11,6 +11,7 @@ module Simplex.Chat.Core ) where +import Control.Concurrent.STM import Control.Logger.Simple import Control.Monad import Control.Monad.Reader @@ -110,7 +111,8 @@ createActiveUser cc = do r -> do ts <- getCurrentTime tz <- getCurrentTimeZone - putStrLn $ serializeChatResponse (Nothing, Nothing) ts tz Nothing r + ll <- readTVarIO $ appLogLevel cc + putStrLn $ serializeChatResponse (Nothing, Nothing) ll ts tz Nothing r loop getWithPrompt :: String -> IO String diff --git a/src/Simplex/Chat/Mobile.hs b/src/Simplex/Chat/Mobile.hs index 5883c6042c..498a5552e2 100644 --- a/src/Simplex/Chat/Mobile.hs +++ b/src/Simplex/Chat/Mobile.hs @@ -193,7 +193,7 @@ mobileChatOpts dbFilePrefix = smpServers = [], xftpServers = [], networkConfig = defaultNetworkConfig, - logLevel = CLLImportant, + logLevel = CLLError, logConnections = False, logServerHosts = True, logAgent = Nothing, @@ -220,7 +220,6 @@ defaultMobileConfig :: ChatConfig defaultMobileConfig = defaultChatConfig { confirmMigrations = MCYesUp, - logLevel = CLLError, coreApi = True, deviceNameForRemote = "Mobile" } diff --git a/src/Simplex/Chat/Options.hs b/src/Simplex/Chat/Options.hs index 871e3358ec..0370100993 100644 --- a/src/Simplex/Chat/Options.hs +++ b/src/Simplex/Chat/Options.hs @@ -14,6 +14,7 @@ module Simplex.Chat.Options getChatOpts, protocolServersP, fullNetworkConfig, + toLogLevel, ) where @@ -68,13 +69,13 @@ data CoreChatOpts = CoreChatOpts data ChatCmdLog = CCLAll | CCLMessages | CCLNone deriving (Eq) -agentLogLevel :: ChatLogLevel -> LogLevel -agentLogLevel = \case +toLogLevel :: ChatLogLevel -> LogLevel +toLogLevel = \case CLLDebug -> LogDebug CLLInfo -> LogInfo CLLWarning -> LogWarn CLLError -> LogError - CLLImportant -> LogInfo + CLLImportant -> LogError coreChatOptsP :: FilePath -> FilePath -> Parser CoreChatOpts coreChatOptsP appDir defaultDbFileName = do @@ -194,11 +195,11 @@ coreChatOptsP appDir defaultDbFileName = do dbKey, smpServers, xftpServers, - networkConfig = fullNetworkConfig socksProxy (useTcpTimeout socksProxy t) (logTLSErrors || logLevel == CLLDebug), + networkConfig = fullNetworkConfig socksProxy (useTcpTimeout socksProxy t) (logTLSErrors || logLevel <= CLLDebug), logLevel, logConnections = logConnections || logLevel <= CLLInfo, logServerHosts = logServerHosts || logLevel <= CLLInfo, - logAgent = if logAgent || logLevel == CLLDebug then Just $ agentLogLevel logLevel else Nothing, + logAgent = if logAgent || logLevel <= CLLDebug then Just $ toLogLevel logLevel else Nothing, logFile, tbqSize, highlyAvailable @@ -342,13 +343,7 @@ protocolServersP :: ProtocolTypeI p => A.Parser [ProtoServerWithAuth p] protocolServersP = strP `A.sepBy1` A.char ' ' parseLogLevel :: ReadM ChatLogLevel -parseLogLevel = eitherReader $ \case - "debug" -> Right CLLDebug - "info" -> Right CLLInfo - "warn" -> Right CLLWarning - "error" -> Right CLLError - "important" -> Right CLLImportant - _ -> Left "Invalid log level" +parseLogLevel = eitherReader $ strDecode . B.pack parseChatCmdLog :: ReadM ChatCmdLog parseChatCmdLog = eitherReader $ \case diff --git a/src/Simplex/Chat/Remote.hs b/src/Simplex/Chat/Remote.hs index e8d13402ef..c5ac6be1fb 100644 --- a/src/Simplex/Chat/Remote.hs +++ b/src/Simplex/Chat/Remote.hs @@ -13,7 +13,6 @@ module Simplex.Chat.Remote where import Control.Applicative ((<|>)) -import Control.Logger.Simple import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class @@ -249,7 +248,7 @@ startRemoteHostSession rhKey = do closeRemoteHost :: RHKey -> CM () closeRemoteHost rhKey = do - logNote $ "Closing remote host session for " <> tshow rhKey + logInfo $ "Closing remote host session for " <> tshow rhKey cancelRemoteHostSession Nothing rhKey cancelRemoteHostSession :: Maybe (SessionSeq, RemoteHostStopReason) -> RHKey -> CM () @@ -266,7 +265,7 @@ cancelRemoteHostSession handlerInfo_ rhKey = do modifyTVar' crh $ \cur -> if (RHId <$> cur) == Just rhKey then Nothing else cur -- only wipe the closing RH pure $ Just rhs forM_ deregistered $ \session -> do - liftIO $ cancelRemoteHost handlingError session `catchAny` (logError . tshow) + lift (cancelRemoteHost handlingError session) `catchAny` (logError . tshow) forM_ (snd <$> handlerInfo_) $ \rhStopReason -> toView CRRemoteHostStopped {remoteHostId_, rhsState = rhsSessionState session, rhStopReason} where @@ -275,25 +274,26 @@ cancelRemoteHostSession handlerInfo_ rhKey = do RHNew -> Nothing RHId rhId -> Just rhId -cancelRemoteHost :: Bool -> RemoteHostSession -> IO () +cancelRemoteHost :: Bool -> RemoteHostSession -> CM' () cancelRemoteHost handlingError = \case RHSessionStarting -> pure () RHSessionConnecting _inv rhs -> cancelPendingSession rhs RHSessionPendingConfirmation _sessCode tls rhs -> do cancelPendingSession rhs - closeConnection tls + closeConn tls RHSessionConfirmed tls rhs -> do cancelPendingSession rhs - closeConnection tls + closeConn tls RHSessionConnected {rchClient, tls, rhClient = RemoteHostClient {httpClient}, pollAction} -> do uninterruptibleCancel pollAction - cancelHostClient rchClient `catchAny` (logError . tshow) - closeConnection tls `catchAny` (logError . tshow) - unless handlingError $ closeHTTP2Client httpClient `catchAny` (logError . tshow) + liftIO (cancelHostClient rchClient) `catchAny` (logError' . tshow) + closeConn tls + unless handlingError $ liftIO (closeHTTP2Client httpClient) `catchAny` (logError' . tshow) where + closeConn tls = liftIO (closeConnection tls) `catchAny` (logError' . tshow) cancelPendingSession RHPendingSession {rchClient, rhsWaitSession} = do - unless handlingError $ uninterruptibleCancel rhsWaitSession `catchAny` (logError . tshow) - cancelHostClient rchClient `catchAny` (logError . tshow) + unless handlingError $ uninterruptibleCancel rhsWaitSession `catchAny` (logError' . tshow) + liftIO (cancelHostClient rchClient) `catchAny` (logError' . tshow) -- | Generate a random 16-char filepath without / in it by using base64url encoding. randomStorePath :: IO FilePath @@ -495,7 +495,7 @@ parseCtrlAppInfo ctrlAppInfo = do handleRemoteCommand :: (ByteString -> CM' ChatResponse) -> RemoteCrypto -> TBQueue ChatResponse -> HTTP2Request -> CM' () handleRemoteCommand execChatCommand encryption remoteOutputQ HTTP2Request {request, reqBody, sendResponse} = do - logDebug "handleRemoteCommand" + logDebug' "handleRemoteCommand" liftIO (tryRemoteError' parseRequest) >>= \case Right (getNext, rc) -> do chatReadVar' currentUser >>= \case @@ -511,7 +511,7 @@ handleRemoteCommand execChatCommand encryption remoteOutputQ HTTP2Request {reque processCommand :: User -> GetChunk -> RemoteCommand -> CM () processCommand user getNext = \case RCSend {command} -> lift $ handleSend execChatCommand command >>= reply - RCRecv {wait = time} -> lift $ liftIO (handleRecv time remoteOutputQ) >>= reply + RCRecv {wait = time} -> lift $ handleRecv time remoteOutputQ >>= reply RCStoreFile {fileName, fileSize, fileDigest} -> lift $ handleStoreFile encryption fileName fileSize fileDigest getNext >>= reply RCGetFile {file} -> handleGetFile encryption user file replyWith reply :: RemoteResponse -> CM' () @@ -547,14 +547,14 @@ tryRemoteError' = tryAllErrors' (RPEException . tshow) handleSend :: (ByteString -> CM' ChatResponse) -> Text -> CM' RemoteResponse handleSend execChatCommand command = do - logDebug $ "Send: " <> tshow command + logDebug' $ "Send: " <> tshow command -- execChatCommand checks for remote-allowed commands -- convert errors thrown in execChatCommand into error responses to prevent aborting the protocol wrapper RRChatResponse <$> execChatCommand (encodeUtf8 command) -handleRecv :: Int -> TBQueue ChatResponse -> IO RemoteResponse +handleRecv :: Int -> TBQueue ChatResponse -> CM' RemoteResponse handleRecv time events = do - logDebug $ "Recv: " <> tshow time + logDebug' $ "Recv: " <> tshow time RRChatEvent <$> (timeout time . atomically $ readTBQueue events) -- TODO this command could remember stored files and return IDs to allow removing files that are not needed. diff --git a/src/Simplex/Chat/Terminal/Main.hs b/src/Simplex/Chat/Terminal/Main.hs index 2b26bb1d66..516a405e81 100644 --- a/src/Simplex/Chat/Terminal/Main.hs +++ b/src/Simplex/Chat/Terminal/Main.hs @@ -48,7 +48,8 @@ simplexChatCLI cfg server_ = do ts <- getCurrentTime tz <- getCurrentTimeZone rh <- readTVarIO $ currentRemoteHost cc - putStrLn $ serializeChatResponse (rh, Just user) ts tz rh r + ll <- readTVarIO $ appLogLevel cc + putStrLn $ serializeChatResponse (rh, Just user) ll ts tz rh r welcome :: ChatOpts -> IO () welcome ChatOpts {coreOptions = CoreChatOpts {dbFilePrefix, networkConfig}} = diff --git a/src/Simplex/Chat/Terminal/Output.hs b/src/Simplex/Chat/Terminal/Output.hs index be8aa12cfe..f1bfad9580 100644 --- a/src/Simplex/Chat/Terminal/Output.hs +++ b/src/Simplex/Chat/Terminal/Output.hs @@ -10,7 +10,6 @@ module Simplex.Chat.Terminal.Output where import Control.Concurrent (ThreadId) -import Control.Logger.Simple import Control.Monad import Control.Monad.Catch (MonadMask) import Control.Monad.Except @@ -168,9 +167,10 @@ runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} Cha _ -> pure () logResponse path s = withFile path AppendMode $ \h -> mapM_ (hPutStrLn h . unStyle) s getRemoteUser rhId = - runReaderT (execChatCommand (Just rhId) "/user") cc >>= \case - CRActiveUser {user} -> updateRemoteUser ct user rhId - cr -> logError $ "Unexpected reply while getting remote user: " <> tshow cr + flip runReaderT cc $ + execChatCommand (Just rhId) "/user" >>= \case + CRActiveUser {user} -> liftIO $ updateRemoteUser ct user rhId + cr -> logError' $ "Unexpected reply while getting remote user: " <> tshow cr removeRemoteUser rhId = atomically $ TM.delete rhId (currentRemoteUsers ct) responseNotification :: ChatTerminal -> ChatController -> ChatResponse -> IO () @@ -275,7 +275,8 @@ responseString ct cc liveItems outputRH r = do cu <- getCurrentUser ct cc ts <- getCurrentTime tz <- getCurrentTimeZone - pure $ responseToView cu (config cc) liveItems ts tz outputRH r + ll <- readTVarIO $ appLogLevel cc + pure $ responseToView cu (config cc) ll liveItems ts tz outputRH r updateRemoteUser :: ChatTerminal -> User -> RemoteHostId -> IO () updateRemoteUser ct user rhId = atomically $ TM.insert rhId user (currentRemoteUsers ct) diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 4b3240fe46..147cd4f002 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -79,11 +79,11 @@ data WCallCommand $(JQ.deriveToJSON (taggedObjectJSON $ dropPrefix "WCCall") ''WCallCommand) -serializeChatResponse :: (Maybe RemoteHostId, Maybe User) -> CurrentTime -> TimeZone -> Maybe RemoteHostId -> ChatResponse -> String -serializeChatResponse user_ ts tz remoteHost_ = unlines . map unStyle . responseToView user_ defaultChatConfig False ts tz remoteHost_ +serializeChatResponse :: (Maybe RemoteHostId, Maybe User) -> ChatLogLevel -> CurrentTime -> TimeZone -> Maybe RemoteHostId -> ChatResponse -> String +serializeChatResponse user_ logLevel ts tz remoteHost_ = unlines . map unStyle . responseToView user_ defaultChatConfig logLevel False ts tz remoteHost_ -responseToView :: (Maybe RemoteHostId, Maybe User) -> ChatConfig -> Bool -> CurrentTime -> TimeZone -> Maybe RemoteHostId -> ChatResponse -> [StyledString] -responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showReceipts, testView} liveItems ts tz outputRH = \case +responseToView :: (Maybe RemoteHostId, Maybe User) -> ChatConfig -> ChatLogLevel -> Bool -> CurrentTime -> TimeZone -> Maybe RemoteHostId -> ChatResponse -> [StyledString] +responseToView hu@(currentRH, user_) ChatConfig {showReactions, showReceipts, testView} logLevel liveItems ts tz outputRH = \case CRActiveUser User {profile, uiThemes} -> viewUserProfile (fromLocalProfile profile) <> viewUITheme uiThemes CRUsersList users -> viewUsersList users CRChatStarted -> ["chat started"] @@ -391,6 +391,8 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe CRChatCmdError u e -> ttyUserPrefix' u $ viewChatError logLevel testView e CRChatError u e -> ttyUser' u $ viewChatError logLevel testView e CRChatErrors u errs -> ttyUser' u $ concatMap (viewChatError logLevel testView) errs + CRAgentLog {} -> [] + CRChatLog {} -> [] CRArchiveImported archiveErrs -> if null archiveErrs then ["ok"] else ["archive import errors: " <> plain (show archiveErrs)] CRAppSettings as -> ["app settings: " <> plain (LB.unpack $ J.encode as)] CRTimedAction _ _ -> [] @@ -1969,8 +1971,8 @@ viewChatError logLevel testView = \case CEFileImageType _ -> ["image type must be jpg, send as a file using " <> highlight' "/f"] CEFileImageSize _ -> ["max image size: " <> sShow maxImageSize <> " bytes, resize it or send as a file using " <> highlight' "/f"] CEFileNotReceived fileId -> ["file " <> sShow fileId <> " not received"] - CEXFTPRcvFile fileId aFileId e -> ["error receiving XFTP file " <> sShow fileId <> ", agent file id " <> sShow aFileId <> ": " <> sShow e | logLevel == CLLError] - CEXFTPSndFile fileId aFileId e -> ["error sending XFTP file " <> sShow fileId <> ", agent file id " <> sShow aFileId <> ": " <> sShow e | logLevel == CLLError] + CEXFTPRcvFile fileId aFileId e -> ["error receiving XFTP file " <> sShow fileId <> ", agent file id " <> sShow aFileId <> ": " <> sShow e | logLevel <= CLLError] + CEXFTPSndFile fileId aFileId e -> ["error sending XFTP file " <> sShow fileId <> ", agent file id " <> sShow aFileId <> ": " <> sShow e | logLevel <= CLLError] CEFallbackToSMPProhibited fileId -> ["recipient tried to accept file " <> sShow fileId <> " via old protocol, prohibited"] CEInlineFileProhibited _ -> ["A small file sent without acceptance - you can enable receiving such files with -f option."] CEInvalidQuote -> ["cannot reply to this message"] @@ -2032,7 +2034,7 @@ viewChatError logLevel testView = \case <> "error: connection authorization failed - this could happen if connection was deleted,\ \ secured with different credentials, or due to a bug - please re-create the connection" ] - AGENT A_DUPLICATE -> [withConnEntity <> "error: AGENT A_DUPLICATE" | logLevel == CLLDebug] + AGENT A_DUPLICATE -> [withConnEntity <> "error: AGENT A_DUPLICATE" | logLevel <= CLLDebug] AGENT A_PROHIBITED -> [withConnEntity <> "error: AGENT A_PROHIBITED" | logLevel <= CLLWarning] CONN NOT_FOUND -> [withConnEntity <> "error: CONN NOT_FOUND" | logLevel <= CLLWarning] CRITICAL restart e -> [plain $ "critical error: " <> e] <> ["please restart the app" | restart]