Compare commits

...

2 Commits

Author SHA1 Message Date
Evgeny Poberezkin c3671b04c5 ios: set log level 2024-05-18 15:25:39 +01:00
Evgeny Poberezkin 0e9cc8b3a8 core: set log level, log events 2024-05-18 14:27:59 +01:00
17 changed files with 174 additions and 66 deletions
+4
View File
@@ -1286,6 +1286,10 @@ func apiGetVersion() throws -> CoreVersionInfo {
throw r throw r
} }
func apiSetAppLogLevel(_ ll: ChatLogLevel) async throws {
try await sendCommandOkResp(.setAppLogLevel(appLogLevel: ll))
}
private func currentUserId(_ funcName: String) throws -> Int64 { private func currentUserId(_ funcName: String) throws -> Int64 {
if let userId = ChatModel.shared.currentUser?.userId { if let userId = ChatModel.shared.currentUser?.userId {
return userId return userId
@@ -12,6 +12,7 @@ import SimpleXChat
struct DeveloperView: View { struct DeveloperView: View {
@AppStorage(DEFAULT_DEVELOPER_TOOLS) private var developerTools = false @AppStorage(DEFAULT_DEVELOPER_TOOLS) private var developerTools = false
@AppStorage(GROUP_DEFAULT_CONFIRM_DB_UPGRADES, store: groupDefaults) private var confirmDatabaseUpgrades = false @AppStorage(GROUP_DEFAULT_CONFIRM_DB_UPGRADES, store: groupDefaults) private var confirmDatabaseUpgrades = false
@State private var appLogLevel = appLogLevelGroupDefault.get()
@Environment(\.colorScheme) var colorScheme @Environment(\.colorScheme) var colorScheme
var body: some View { var body: some View {
@@ -37,6 +38,24 @@ struct DeveloperView: View {
settingsRow("chevron.left.forwardslash.chevron.right") { settingsRow("chevron.left.forwardslash.chevron.right") {
Toggle("Show developer options", isOn: $developerTools) Toggle("Show developer options", isOn: $developerTools)
} }
settingsRow("text.justify") {
Picker("Log level", selection: $appLogLevel) {
ForEach(ChatLogLevel.allCases, id: \.self) { ll in
Text(ll.rawValue)
}
}
.frame(height: 36)
.onChange(of: appLogLevel) { ll in
Task {
do {
try await apiSetAppLogLevel(ll)
appLogLevelGroupDefault.set(ll)
} catch let e {
logger.error("apiSetAppLogLevel error: \(responseError(e))")
}
}
}
}
} header: { } header: {
Text("") Text("")
} footer: { } footer: {
+11
View File
@@ -140,6 +140,7 @@ public enum ChatCommand {
case apiStandaloneFileInfo(url: String) case apiStandaloneFileInfo(url: String)
// misc // misc
case showVersion case showVersion
case setAppLogLevel(appLogLevel: ChatLogLevel)
case string(String) case string(String)
public var cmdString: String { public var cmdString: String {
@@ -297,6 +298,7 @@ public enum ChatCommand {
case let .apiDownloadStandaloneFile(userId, link, file): return "/_download \(userId) \(link) \(file.filePath)" case let .apiDownloadStandaloneFile(userId, link, file): return "/_download \(userId) \(link) \(file.filePath)"
case let .apiStandaloneFileInfo(link): return "/_download info \(link)" case let .apiStandaloneFileInfo(link): return "/_download info \(link)"
case .showVersion: return "/version" case .showVersion: return "/version"
case let .setAppLogLevel(ll): return "/log \(ll.rawValue)"
case let .string(str): return str case let .string(str): return str
} }
} }
@@ -429,6 +431,7 @@ public enum ChatCommand {
case .apiDownloadStandaloneFile: return "apiDownloadStandaloneFile" case .apiDownloadStandaloneFile: return "apiDownloadStandaloneFile"
case .apiStandaloneFileInfo: return "apiStandaloneFileInfo" case .apiStandaloneFileInfo: return "apiStandaloneFileInfo"
case .showVersion: return "showVersion" case .showVersion: return "showVersion"
case .setAppLogLevel: return "setAppLogLevel"
case .string: return "console command" case .string: return "console command"
} }
} }
@@ -2167,3 +2170,11 @@ public enum UserNetworkType: String, Codable {
} }
} }
} }
public enum ChatLogLevel: String, Codable, CaseIterable {
case debug
case info
case warn
case error
case important
}
+8
View File
@@ -44,6 +44,7 @@ public let GROUP_DEFAULT_INITIAL_RANDOM_DB_PASSPHRASE = "initialRandomDBPassphra
public let GROUP_DEFAULT_CONFIRM_DB_UPGRADES = "confirmDBUpgrades" public let GROUP_DEFAULT_CONFIRM_DB_UPGRADES = "confirmDBUpgrades"
public let GROUP_DEFAULT_CALL_KIT_ENABLED = "callKitEnabled" public let GROUP_DEFAULT_CALL_KIT_ENABLED = "callKitEnabled"
public let GROUP_DEFAULT_PQ_EXPERIMENTAL_ENABLED = "pqExperimentalEnabled" // no longer used public let GROUP_DEFAULT_PQ_EXPERIMENTAL_ENABLED = "pqExperimentalEnabled" // no longer used
public let GROUP_DEFAULT_APP_LOG_LEVEL = "appLogLevel"
public let APP_GROUP_NAME = "group.chat.simplex.app" public let APP_GROUP_NAME = "group.chat.simplex.app"
@@ -76,6 +77,7 @@ public func registerGroupDefaults() {
GROUP_DEFAULT_CONFIRM_DB_UPGRADES: false, GROUP_DEFAULT_CONFIRM_DB_UPGRADES: false,
GROUP_DEFAULT_CALL_KIT_ENABLED: true, GROUP_DEFAULT_CALL_KIT_ENABLED: true,
GROUP_DEFAULT_PQ_EXPERIMENTAL_ENABLED: false, GROUP_DEFAULT_PQ_EXPERIMENTAL_ENABLED: false,
GROUP_DEFAULT_APP_LOG_LEVEL: ChatLogLevel.important.rawValue,
]) ])
} }
@@ -215,6 +217,12 @@ public let confirmDBUpgradesGroupDefault = BoolDefault(defaults: groupDefaults,
public let callKitEnabledGroupDefault = BoolDefault(defaults: groupDefaults, forKey: GROUP_DEFAULT_CALL_KIT_ENABLED) public let callKitEnabledGroupDefault = BoolDefault(defaults: groupDefaults, forKey: GROUP_DEFAULT_CALL_KIT_ENABLED)
public let appLogLevelGroupDefault = EnumDefault<ChatLogLevel>(
defaults: groupDefaults,
forKey: GROUP_DEFAULT_APP_LOG_LEVEL,
withDefault: .important
)
public class DateDefault { public class DateDefault {
var defaults: UserDefaults var defaults: UserDefaults
var key: String var key: String
@@ -31,7 +31,7 @@ import Directory.Search
import Directory.Store import Directory.Store
import Simplex.Chat.Bot import Simplex.Chat.Bot
import Simplex.Chat.Bot.KnownContacts import Simplex.Chat.Bot.KnownContacts
import Simplex.Chat.Controller import Simplex.Chat.Controller hiding (logError, logInfo)
import Simplex.Chat.Core import Simplex.Chat.Core
import Simplex.Chat.Messages import Simplex.Chat.Messages
import Simplex.Chat.Options import Simplex.Chat.Options
@@ -586,7 +586,8 @@ directoryService st DirectoryOpts {superUsers, serviceName, searchResults, testi
sendChatCmdStr cc cmdStr >>= \r -> do sendChatCmdStr cc cmdStr >>= \r -> do
ts <- getCurrentTime ts <- getCurrentTime
tz <- getCurrentTimeZone 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 DCCommandError tag -> sendReply $ "Command error: " <> show tag
| otherwise = sendReply "You are not allowed to use this command" | otherwise = sendReply "You are not allowed to use this command"
where where
+1 -1
View File
@@ -12,7 +12,7 @@ constraints: zip +disable-bzip2 +disable-zstd
source-repository-package source-repository-package
type: git type: git
location: https://github.com/simplex-chat/simplexmq.git location: https://github.com/simplex-chat/simplexmq.git
tag: 1116aeeea1869e0de38e9faccea76b329b549804 tag: 71489fe6fca70f32f18137186bab2b77304f11b0
source-repository-package source-repository-package
type: git type: git
+1 -1
View File
@@ -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/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38";
"https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d"; "https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d";
"https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl"; "https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl";
+13 -5
View File
@@ -17,7 +17,7 @@ module Simplex.Chat where
import Control.Applicative (optional, (<|>)) import Control.Applicative (optional, (<|>))
import Control.Concurrent.STM (retry) import Control.Concurrent.STM (retry)
import Control.Logger.Simple import Control.Logger.Simple (LogConfig (..))
import Control.Monad import Control.Monad
import Control.Monad.Except import Control.Monad.Except
import Control.Monad.IO.Unlift import Control.Monad.IO.Unlift
@@ -155,7 +155,6 @@ defaultChatConfig =
autoAcceptFileSize = 0, autoAcceptFileSize = 0,
showReactions = False, showReactions = False,
showReceipts = False, showReceipts = False,
logLevel = CLLImportant,
subscriptionEvents = False, subscriptionEvents = False,
hostEvents = False, hostEvents = False,
testView = 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} ChatOpts {coreOptions = CoreChatOpts {smpServers, xftpServers, networkConfig, logLevel, logConnections, logServerHosts, logFile, tbqSize, highlyAvailable}, deviceName, optFilesFolder, optTempDirectory, showReactions, allowInstantFiles, autoAcceptFileSize}
backgroundMode = do backgroundMode = do
let inlineFiles' = if allowInstantFiles || autoAcceptFileSize > 0 then inlineFiles else inlineFiles {sendChunks = 0, receiveInstant = False} 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 firstTime = dbNew chatStore
currentUser <- newTVarIO user currentUser <- newTVarIO user
currentRemoteHost <- newTVarIO Nothing currentRemoteHost <- newTVarIO Nothing
@@ -241,6 +240,7 @@ newChatController
remoteHostSessions <- atomically TM.empty remoteHostSessions <- atomically TM.empty
remoteHostsFolder <- newTVarIO Nothing remoteHostsFolder <- newTVarIO Nothing
remoteCtrlSession <- newTVarIO Nothing remoteCtrlSession <- newTVarIO Nothing
appLogLevel <- newTVarIO logLevel
filesFolder <- newTVarIO optFilesFolder filesFolder <- newTVarIO optFilesFolder
chatStoreChanged <- newTVarIO False chatStoreChanged <- newTVarIO False
expireCIThreads <- newTVarIO M.empty expireCIThreads <- newTVarIO M.empty
@@ -279,6 +279,7 @@ newChatController
remoteHostsFolder, remoteHostsFolder,
remoteCtrlSession, remoteCtrlSession,
config, config,
appLogLevel,
filesFolder, filesFolder,
expireCIThreads, expireCIThreads,
expireCIFlags, expireCIFlags,
@@ -436,9 +437,10 @@ restoreCalls = do
calls <- asks currentCalls calls <- asks currentCalls
atomically $ writeTVar calls callsMap atomically $ writeTVar calls callsMap
stopChatController :: ChatController -> IO () stopChatController :: ChatController -> CM' ()
stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles, expireCIFlags, remoteHostSessions, remoteCtrlSession} = do stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles, expireCIFlags, remoteHostSessions, remoteCtrlSession} = do
readTVarIO remoteHostSessions >>= mapM_ (cancelRemoteHost False . snd) readTVarIO remoteHostSessions >>= mapM_ (cancelRemoteHost False . snd)
liftIO $ do
atomically (stateTVar remoteCtrlSession (,Nothing)) >>= mapM_ (cancelRemoteCtrl False . snd) atomically (stateTVar remoteCtrlSession (,Nothing)) >>= mapM_ (cancelRemoteCtrl False . snd)
disconnectAgentClient smpAgent disconnectAgentClient smpAgent
readTVarIO s >>= mapM_ (\(a1, a2) -> uninterruptibleCancel a1 >> mapM_ uninterruptibleCancel a2) readTVarIO s >>= mapM_ (\(a1, a2) -> uninterruptibleCancel a1 >> mapM_ uninterruptibleCancel a2)
@@ -601,7 +603,7 @@ processChatCommand' vr = \case
Just _ -> pure CRChatRunning Just _ -> pure CRChatRunning
_ -> checkStoreNotChanged . lift $ startChatController mainApp $> CRChatStarted _ -> checkStoreNotChanged . lift $ startChatController mainApp $> CRChatStarted
APIStopChat -> do APIStopChat -> do
ask >>= liftIO . stopChatController ask >>= lift . stopChatController
pure CRChatStopped pure CRChatStopped
APIActivateChat restoreChat -> withUser $ \_ -> do APIActivateChat restoreChat -> withUser $ \_ -> do
lift $ when restoreChat restoreCalls lift $ when restoreChat restoreCalls
@@ -2199,6 +2201,10 @@ processChatCommand' vr = \case
chatMigrations <- map upMigration <$> withStore' (Migrations.getCurrent . DB.conn) chatMigrations <- map upMigration <$> withStore' (Migrations.getCurrent . DB.conn)
agentMigrations <- withAgent getAgentMigrations agentMigrations <- withAgent getAgentMigrations
pure $ CRVersionInfo {versionInfo, chatMigrations, agentMigrations} pure $ CRVersionInfo {versionInfo, chatMigrations, agentMigrations}
SetAppLogLevel ll -> do
chatWriteVar appLogLevel ll
lift $ withAgent' (`setAgentLogLevel` toLogLevel ll)
ok_
DebugLocks -> lift $ do DebugLocks -> lift $ do
chatLockName <- atomically . tryReadTMVar =<< asks chatLock chatLockName <- atomically . tryReadTMVar =<< asks chatLock
chatEntityLocks <- getLocks =<< asks entityLocks chatEntityLocks <- getLocks =<< asks entityLocks
@@ -3629,6 +3635,7 @@ processAgentMessageNoConn = \case
UP srv conns -> serverEvent srv conns NSConnected CRContactsSubscribed UP srv conns -> serverEvent srv conns NSConnected CRContactsSubscribed
SUSPENDED -> toView CRChatSuspended SUSPENDED -> toView CRChatSuspended
DEL_USER agentUserId -> toView $ CRAgentUserDeleted agentUserId DEL_USER agentUserId -> toView $ CRAgentUserDeleted agentUserId
LOG ll s -> toView $ CRAgentLog ll s
where where
hostEvent :: ChatResponse -> CM () hostEvent :: ChatResponse -> CM ()
hostEvent = whenM (asks $ hostEvents . config) . toView hostEvent = whenM (asks $ hostEvents . config) . toView
@@ -7377,6 +7384,7 @@ chatCommandP =
"/_download " *> (APIDownloadStandaloneFile <$> A.decimal <* A.space <*> strP_ <*> cryptoFileP), "/_download " *> (APIDownloadStandaloneFile <$> A.decimal <* A.space <*> strP_ <*> cryptoFileP),
("/quit" <|> "/q" <|> "/exit") $> QuitChat, ("/quit" <|> "/q" <|> "/exit") $> QuitChat,
("/version" <|> "/v") $> ShowVersion, ("/version" <|> "/v") $> ShowVersion,
"/log " *> (SetAppLogLevel <$> strP),
"/debug locks" $> DebugLocks, "/debug locks" $> DebugLocks,
"/debug event " *> (DebugEvent <$> jsonP), "/debug event " *> (DebugEvent <$> jsonP),
"/get stats" $> GetAgentStats, "/get stats" $> GetAgentStats,
+3 -3
View File
@@ -85,9 +85,9 @@ textMsgContent :: String -> MsgContent
textMsgContent = MCText . T.pack textMsgContent = MCText . T.pack
printLog :: ChatController -> ChatLogLevel -> String -> IO () printLog :: ChatController -> ChatLogLevel -> String -> IO ()
printLog cc level s printLog cc level s = do
| logLevel (config cc) <= level = putStrLn s ll <- readTVarIO $ appLogLevel cc
| otherwise = pure () when (ll <= level) $ putStrLn s
contactInfo :: Contact -> String contactInfo :: Contact -> String
contactInfo Contact {contactId, localDisplayName} = T.unpack localDisplayName <> " (" <> show contactId <> ")" contactInfo Contact {contactId, localDisplayName} = T.unpack localDisplayName <> " (" <> show contactId <> ")"
+58 -1
View File
@@ -19,6 +19,8 @@ module Simplex.Chat.Controller where
import Control.Concurrent (ThreadId) import Control.Concurrent (ThreadId)
import Control.Concurrent.Async (Async) import Control.Concurrent.Async (Async)
import Control.Exception import Control.Exception
import qualified Control.Logger.Simple as Logger
import Control.Monad (when)
import Control.Monad.Except import Control.Monad.Except
import Control.Monad.IO.Unlift import Control.Monad.IO.Unlift
import Control.Monad.Reader import Control.Monad.Reader
@@ -139,7 +141,6 @@ data ChatConfig = ChatConfig
showReceipts :: Bool, showReceipts :: Bool,
subscriptionEvents :: Bool, subscriptionEvents :: Bool,
hostEvents :: Bool, hostEvents :: Bool,
logLevel :: ChatLogLevel,
testView :: Bool, testView :: Bool,
initialCleanupManagerDelay :: Int64, initialCleanupManagerDelay :: Int64,
cleanupManagerInterval :: NominalDiffTime, cleanupManagerInterval :: NominalDiffTime,
@@ -221,6 +222,7 @@ data ChatController = ChatController
remoteHostsFolder :: TVar (Maybe FilePath), -- folder for remote hosts data remoteHostsFolder :: TVar (Maybe FilePath), -- folder for remote hosts data
remoteCtrlSession :: TVar (Maybe (SessionSeq, RemoteCtrlSession)), -- Supervisor process for hosted controllers remoteCtrlSession :: TVar (Maybe (SessionSeq, RemoteCtrlSession)), -- Supervisor process for hosted controllers
config :: ChatConfig, config :: ChatConfig,
appLogLevel :: TVar ChatLogLevel,
filesFolder :: TVar (Maybe FilePath), -- path to files folder for mobile apps, filesFolder :: TVar (Maybe FilePath), -- path to files folder for mobile apps,
expireCIThreads :: TMap UserId (Maybe (Async ())), expireCIThreads :: TMap UserId (Maybe (Async ())),
expireCIFlags :: TMap UserId Bool, expireCIFlags :: TMap UserId Bool,
@@ -493,6 +495,7 @@ data ChatCommand
| APIStandaloneFileInfo FileDescriptionURI | APIStandaloneFileInfo FileDescriptionURI
| QuitChat | QuitChat
| ShowVersion | ShowVersion
| SetAppLogLevel ChatLogLevel
| DebugLocks | DebugLocks
| DebugEvent ChatResponse | DebugEvent ChatResponse
| GetAgentStats | GetAgentStats
@@ -757,6 +760,8 @@ data ChatResponse
| CRChatCmdError {user_ :: Maybe User, chatError :: ChatError} | CRChatCmdError {user_ :: Maybe User, chatError :: ChatError}
| CRChatError {user_ :: Maybe User, chatError :: ChatError} | CRChatError {user_ :: Maybe User, chatError :: ChatError}
| CRChatErrors {user_ :: Maybe User, chatErrors :: [ChatError]} | CRChatErrors {user_ :: Maybe User, chatErrors :: [ChatError]}
| CRAgentLog {agentLogLevel :: AgentLogLevel, errorMessage :: Text}
| CRChatLog {chatLogLevel :: ChatLogLevel, errorMessage :: Text}
| CRArchiveImported {archiveErrors :: [ArchiveError]} | CRArchiveImported {archiveErrors :: [ArchiveError]}
| CRAppSettings {appSettings :: AppSettings} | CRAppSettings {appSettings :: AppSettings}
| CRTimedAction {action :: String, durationMilliseconds :: Int64} | CRTimedAction {action :: String, durationMilliseconds :: Int64}
@@ -1053,6 +1058,30 @@ tmeToPref currentTTL tme = uncurry TimedMessagesPreference $ case tme of
data ChatLogLevel = CLLDebug | CLLInfo | CLLWarning | CLLError | CLLImportant data ChatLogLevel = CLLDebug | CLLInfo | CLLWarning | CLLError | CLLImportant
deriving (Eq, Ord, Show) 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 data CoreVersionInfo = CoreVersionInfo
{ version :: String, { version :: String,
simplexmqVersion :: String, simplexmqVersion :: String,
@@ -1397,6 +1426,34 @@ withAgent action =
withAgent' :: (AgentClient -> IO a) -> CM' a withAgent' :: (AgentClient -> IO a) -> CM' a
withAgent' action = asks smpAgent >>= liftIO . action 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 (enumJSON $ dropPrefix "HS") ''HelpSection)
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CLQ") ''ChatListQuery) $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CLQ") ''ChatListQuery)
+3 -1
View File
@@ -11,6 +11,7 @@ module Simplex.Chat.Core
) )
where where
import Control.Concurrent.STM
import Control.Logger.Simple import Control.Logger.Simple
import Control.Monad import Control.Monad
import Control.Monad.Reader import Control.Monad.Reader
@@ -110,7 +111,8 @@ createActiveUser cc = do
r -> do r -> do
ts <- getCurrentTime ts <- getCurrentTime
tz <- getCurrentTimeZone tz <- getCurrentTimeZone
putStrLn $ serializeChatResponse (Nothing, Nothing) ts tz Nothing r ll <- readTVarIO $ appLogLevel cc
putStrLn $ serializeChatResponse (Nothing, Nothing) ll ts tz Nothing r
loop loop
getWithPrompt :: String -> IO String getWithPrompt :: String -> IO String
+1 -2
View File
@@ -193,7 +193,7 @@ mobileChatOpts dbFilePrefix =
smpServers = [], smpServers = [],
xftpServers = [], xftpServers = [],
networkConfig = defaultNetworkConfig, networkConfig = defaultNetworkConfig,
logLevel = CLLImportant, logLevel = CLLError,
logConnections = False, logConnections = False,
logServerHosts = True, logServerHosts = True,
logAgent = Nothing, logAgent = Nothing,
@@ -220,7 +220,6 @@ defaultMobileConfig :: ChatConfig
defaultMobileConfig = defaultMobileConfig =
defaultChatConfig defaultChatConfig
{ confirmMigrations = MCYesUp, { confirmMigrations = MCYesUp,
logLevel = CLLError,
coreApi = True, coreApi = True,
deviceNameForRemote = "Mobile" deviceNameForRemote = "Mobile"
} }
+7 -12
View File
@@ -14,6 +14,7 @@ module Simplex.Chat.Options
getChatOpts, getChatOpts,
protocolServersP, protocolServersP,
fullNetworkConfig, fullNetworkConfig,
toLogLevel,
) )
where where
@@ -68,13 +69,13 @@ data CoreChatOpts = CoreChatOpts
data ChatCmdLog = CCLAll | CCLMessages | CCLNone data ChatCmdLog = CCLAll | CCLMessages | CCLNone
deriving (Eq) deriving (Eq)
agentLogLevel :: ChatLogLevel -> LogLevel toLogLevel :: ChatLogLevel -> LogLevel
agentLogLevel = \case toLogLevel = \case
CLLDebug -> LogDebug CLLDebug -> LogDebug
CLLInfo -> LogInfo CLLInfo -> LogInfo
CLLWarning -> LogWarn CLLWarning -> LogWarn
CLLError -> LogError CLLError -> LogError
CLLImportant -> LogInfo CLLImportant -> LogError
coreChatOptsP :: FilePath -> FilePath -> Parser CoreChatOpts coreChatOptsP :: FilePath -> FilePath -> Parser CoreChatOpts
coreChatOptsP appDir defaultDbFileName = do coreChatOptsP appDir defaultDbFileName = do
@@ -194,11 +195,11 @@ coreChatOptsP appDir defaultDbFileName = do
dbKey, dbKey,
smpServers, smpServers,
xftpServers, xftpServers,
networkConfig = fullNetworkConfig socksProxy (useTcpTimeout socksProxy t) (logTLSErrors || logLevel == CLLDebug), networkConfig = fullNetworkConfig socksProxy (useTcpTimeout socksProxy t) (logTLSErrors || logLevel <= CLLDebug),
logLevel, logLevel,
logConnections = logConnections || logLevel <= CLLInfo, logConnections = logConnections || logLevel <= CLLInfo,
logServerHosts = logServerHosts || 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, logFile,
tbqSize, tbqSize,
highlyAvailable highlyAvailable
@@ -342,13 +343,7 @@ protocolServersP :: ProtocolTypeI p => A.Parser [ProtoServerWithAuth p]
protocolServersP = strP `A.sepBy1` A.char ' ' protocolServersP = strP `A.sepBy1` A.char ' '
parseLogLevel :: ReadM ChatLogLevel parseLogLevel :: ReadM ChatLogLevel
parseLogLevel = eitherReader $ \case parseLogLevel = eitherReader $ strDecode . B.pack
"debug" -> Right CLLDebug
"info" -> Right CLLInfo
"warn" -> Right CLLWarning
"error" -> Right CLLError
"important" -> Right CLLImportant
_ -> Left "Invalid log level"
parseChatCmdLog :: ReadM ChatCmdLog parseChatCmdLog :: ReadM ChatCmdLog
parseChatCmdLog = eitherReader $ \case parseChatCmdLog = eitherReader $ \case
+16 -16
View File
@@ -13,7 +13,6 @@
module Simplex.Chat.Remote where module Simplex.Chat.Remote where
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
import Control.Logger.Simple
import Control.Monad import Control.Monad
import Control.Monad.Except import Control.Monad.Except
import Control.Monad.IO.Class import Control.Monad.IO.Class
@@ -249,7 +248,7 @@ startRemoteHostSession rhKey = do
closeRemoteHost :: RHKey -> CM () closeRemoteHost :: RHKey -> CM ()
closeRemoteHost rhKey = do closeRemoteHost rhKey = do
logNote $ "Closing remote host session for " <> tshow rhKey logInfo $ "Closing remote host session for " <> tshow rhKey
cancelRemoteHostSession Nothing rhKey cancelRemoteHostSession Nothing rhKey
cancelRemoteHostSession :: Maybe (SessionSeq, RemoteHostStopReason) -> RHKey -> CM () 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 modifyTVar' crh $ \cur -> if (RHId <$> cur) == Just rhKey then Nothing else cur -- only wipe the closing RH
pure $ Just rhs pure $ Just rhs
forM_ deregistered $ \session -> do forM_ deregistered $ \session -> do
liftIO $ cancelRemoteHost handlingError session `catchAny` (logError . tshow) lift (cancelRemoteHost handlingError session) `catchAny` (logError . tshow)
forM_ (snd <$> handlerInfo_) $ \rhStopReason -> forM_ (snd <$> handlerInfo_) $ \rhStopReason ->
toView CRRemoteHostStopped {remoteHostId_, rhsState = rhsSessionState session, rhStopReason} toView CRRemoteHostStopped {remoteHostId_, rhsState = rhsSessionState session, rhStopReason}
where where
@@ -275,25 +274,26 @@ cancelRemoteHostSession handlerInfo_ rhKey = do
RHNew -> Nothing RHNew -> Nothing
RHId rhId -> Just rhId RHId rhId -> Just rhId
cancelRemoteHost :: Bool -> RemoteHostSession -> IO () cancelRemoteHost :: Bool -> RemoteHostSession -> CM' ()
cancelRemoteHost handlingError = \case cancelRemoteHost handlingError = \case
RHSessionStarting -> pure () RHSessionStarting -> pure ()
RHSessionConnecting _inv rhs -> cancelPendingSession rhs RHSessionConnecting _inv rhs -> cancelPendingSession rhs
RHSessionPendingConfirmation _sessCode tls rhs -> do RHSessionPendingConfirmation _sessCode tls rhs -> do
cancelPendingSession rhs cancelPendingSession rhs
closeConnection tls closeConn tls
RHSessionConfirmed tls rhs -> do RHSessionConfirmed tls rhs -> do
cancelPendingSession rhs cancelPendingSession rhs
closeConnection tls closeConn tls
RHSessionConnected {rchClient, tls, rhClient = RemoteHostClient {httpClient}, pollAction} -> do RHSessionConnected {rchClient, tls, rhClient = RemoteHostClient {httpClient}, pollAction} -> do
uninterruptibleCancel pollAction uninterruptibleCancel pollAction
cancelHostClient rchClient `catchAny` (logError . tshow) liftIO (cancelHostClient rchClient) `catchAny` (logError' . tshow)
closeConnection tls `catchAny` (logError . tshow) closeConn tls
unless handlingError $ closeHTTP2Client httpClient `catchAny` (logError . tshow) unless handlingError $ liftIO (closeHTTP2Client httpClient) `catchAny` (logError' . tshow)
where where
closeConn tls = liftIO (closeConnection tls) `catchAny` (logError' . tshow)
cancelPendingSession RHPendingSession {rchClient, rhsWaitSession} = do cancelPendingSession RHPendingSession {rchClient, rhsWaitSession} = do
unless handlingError $ uninterruptibleCancel rhsWaitSession `catchAny` (logError . tshow) unless handlingError $ uninterruptibleCancel rhsWaitSession `catchAny` (logError' . tshow)
cancelHostClient rchClient `catchAny` (logError . tshow) liftIO (cancelHostClient rchClient) `catchAny` (logError' . tshow)
-- | Generate a random 16-char filepath without / in it by using base64url encoding. -- | Generate a random 16-char filepath without / in it by using base64url encoding.
randomStorePath :: IO FilePath randomStorePath :: IO FilePath
@@ -495,7 +495,7 @@ parseCtrlAppInfo ctrlAppInfo = do
handleRemoteCommand :: (ByteString -> CM' ChatResponse) -> RemoteCrypto -> TBQueue ChatResponse -> HTTP2Request -> CM' () handleRemoteCommand :: (ByteString -> CM' ChatResponse) -> RemoteCrypto -> TBQueue ChatResponse -> HTTP2Request -> CM' ()
handleRemoteCommand execChatCommand encryption remoteOutputQ HTTP2Request {request, reqBody, sendResponse} = do handleRemoteCommand execChatCommand encryption remoteOutputQ HTTP2Request {request, reqBody, sendResponse} = do
logDebug "handleRemoteCommand" logDebug' "handleRemoteCommand"
liftIO (tryRemoteError' parseRequest) >>= \case liftIO (tryRemoteError' parseRequest) >>= \case
Right (getNext, rc) -> do Right (getNext, rc) -> do
chatReadVar' currentUser >>= \case chatReadVar' currentUser >>= \case
@@ -511,7 +511,7 @@ handleRemoteCommand execChatCommand encryption remoteOutputQ HTTP2Request {reque
processCommand :: User -> GetChunk -> RemoteCommand -> CM () processCommand :: User -> GetChunk -> RemoteCommand -> CM ()
processCommand user getNext = \case processCommand user getNext = \case
RCSend {command} -> lift $ handleSend execChatCommand command >>= reply 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 RCStoreFile {fileName, fileSize, fileDigest} -> lift $ handleStoreFile encryption fileName fileSize fileDigest getNext >>= reply
RCGetFile {file} -> handleGetFile encryption user file replyWith RCGetFile {file} -> handleGetFile encryption user file replyWith
reply :: RemoteResponse -> CM' () reply :: RemoteResponse -> CM' ()
@@ -547,14 +547,14 @@ tryRemoteError' = tryAllErrors' (RPEException . tshow)
handleSend :: (ByteString -> CM' ChatResponse) -> Text -> CM' RemoteResponse handleSend :: (ByteString -> CM' ChatResponse) -> Text -> CM' RemoteResponse
handleSend execChatCommand command = do handleSend execChatCommand command = do
logDebug $ "Send: " <> tshow command logDebug' $ "Send: " <> tshow command
-- execChatCommand checks for remote-allowed commands -- execChatCommand checks for remote-allowed commands
-- convert errors thrown in execChatCommand into error responses to prevent aborting the protocol wrapper -- convert errors thrown in execChatCommand into error responses to prevent aborting the protocol wrapper
RRChatResponse <$> execChatCommand (encodeUtf8 command) RRChatResponse <$> execChatCommand (encodeUtf8 command)
handleRecv :: Int -> TBQueue ChatResponse -> IO RemoteResponse handleRecv :: Int -> TBQueue ChatResponse -> CM' RemoteResponse
handleRecv time events = do handleRecv time events = do
logDebug $ "Recv: " <> tshow time logDebug' $ "Recv: " <> tshow time
RRChatEvent <$> (timeout time . atomically $ readTBQueue events) RRChatEvent <$> (timeout time . atomically $ readTBQueue events)
-- TODO this command could remember stored files and return IDs to allow removing files that are not needed. -- TODO this command could remember stored files and return IDs to allow removing files that are not needed.
+2 -1
View File
@@ -48,7 +48,8 @@ simplexChatCLI cfg server_ = do
ts <- getCurrentTime ts <- getCurrentTime
tz <- getCurrentTimeZone tz <- getCurrentTimeZone
rh <- readTVarIO $ currentRemoteHost cc 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 -> IO ()
welcome ChatOpts {coreOptions = CoreChatOpts {dbFilePrefix, networkConfig}} = welcome ChatOpts {coreOptions = CoreChatOpts {dbFilePrefix, networkConfig}} =
+6 -5
View File
@@ -10,7 +10,6 @@
module Simplex.Chat.Terminal.Output where module Simplex.Chat.Terminal.Output where
import Control.Concurrent (ThreadId) import Control.Concurrent (ThreadId)
import Control.Logger.Simple
import Control.Monad import Control.Monad
import Control.Monad.Catch (MonadMask) import Control.Monad.Catch (MonadMask)
import Control.Monad.Except import Control.Monad.Except
@@ -168,9 +167,10 @@ runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} Cha
_ -> pure () _ -> pure ()
logResponse path s = withFile path AppendMode $ \h -> mapM_ (hPutStrLn h . unStyle) s logResponse path s = withFile path AppendMode $ \h -> mapM_ (hPutStrLn h . unStyle) s
getRemoteUser rhId = getRemoteUser rhId =
runReaderT (execChatCommand (Just rhId) "/user") cc >>= \case flip runReaderT cc $
CRActiveUser {user} -> updateRemoteUser ct user rhId execChatCommand (Just rhId) "/user" >>= \case
cr -> logError $ "Unexpected reply while getting remote user: " <> tshow cr 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) removeRemoteUser rhId = atomically $ TM.delete rhId (currentRemoteUsers ct)
responseNotification :: ChatTerminal -> ChatController -> ChatResponse -> IO () responseNotification :: ChatTerminal -> ChatController -> ChatResponse -> IO ()
@@ -275,7 +275,8 @@ responseString ct cc liveItems outputRH r = do
cu <- getCurrentUser ct cc cu <- getCurrentUser ct cc
ts <- getCurrentTime ts <- getCurrentTime
tz <- getCurrentTimeZone 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 :: ChatTerminal -> User -> RemoteHostId -> IO ()
updateRemoteUser ct user rhId = atomically $ TM.insert rhId user (currentRemoteUsers ct) updateRemoteUser ct user rhId = atomically $ TM.insert rhId user (currentRemoteUsers ct)
+9 -7
View File
@@ -79,11 +79,11 @@ data WCallCommand
$(JQ.deriveToJSON (taggedObjectJSON $ dropPrefix "WCCall") ''WCallCommand) $(JQ.deriveToJSON (taggedObjectJSON $ dropPrefix "WCCall") ''WCallCommand)
serializeChatResponse :: (Maybe RemoteHostId, Maybe User) -> CurrentTime -> TimeZone -> Maybe RemoteHostId -> ChatResponse -> String serializeChatResponse :: (Maybe RemoteHostId, Maybe User) -> ChatLogLevel -> CurrentTime -> TimeZone -> Maybe RemoteHostId -> ChatResponse -> String
serializeChatResponse user_ ts tz remoteHost_ = unlines . map unStyle . responseToView user_ defaultChatConfig False ts tz remoteHost_ 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 :: (Maybe RemoteHostId, Maybe User) -> ChatConfig -> ChatLogLevel -> Bool -> CurrentTime -> TimeZone -> Maybe RemoteHostId -> ChatResponse -> [StyledString]
responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showReceipts, testView} liveItems ts tz outputRH = \case responseToView hu@(currentRH, user_) ChatConfig {showReactions, showReceipts, testView} logLevel liveItems ts tz outputRH = \case
CRActiveUser User {profile, uiThemes} -> viewUserProfile (fromLocalProfile profile) <> viewUITheme uiThemes CRActiveUser User {profile, uiThemes} -> viewUserProfile (fromLocalProfile profile) <> viewUITheme uiThemes
CRUsersList users -> viewUsersList users CRUsersList users -> viewUsersList users
CRChatStarted -> ["chat started"] CRChatStarted -> ["chat started"]
@@ -391,6 +391,8 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
CRChatCmdError u e -> ttyUserPrefix' u $ viewChatError logLevel testView e CRChatCmdError u e -> ttyUserPrefix' u $ viewChatError logLevel testView e
CRChatError u e -> ttyUser' u $ viewChatError logLevel testView e CRChatError u e -> ttyUser' u $ viewChatError logLevel testView e
CRChatErrors u errs -> ttyUser' u $ concatMap (viewChatError logLevel testView) errs 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)] CRArchiveImported archiveErrs -> if null archiveErrs then ["ok"] else ["archive import errors: " <> plain (show archiveErrs)]
CRAppSettings as -> ["app settings: " <> plain (LB.unpack $ J.encode as)] CRAppSettings as -> ["app settings: " <> plain (LB.unpack $ J.encode as)]
CRTimedAction _ _ -> [] CRTimedAction _ _ -> []
@@ -1969,8 +1971,8 @@ viewChatError logLevel testView = \case
CEFileImageType _ -> ["image type must be jpg, send as a file using " <> highlight' "/f"] 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"] CEFileImageSize _ -> ["max image size: " <> sShow maxImageSize <> " bytes, resize it or send as a file using " <> highlight' "/f"]
CEFileNotReceived fileId -> ["file " <> sShow fileId <> " not received"] 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] 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] 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"] 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."] CEInlineFileProhibited _ -> ["A small file sent without acceptance - you can enable receiving such files with -f option."]
CEInvalidQuote -> ["cannot reply to this message"] 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,\ <> "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" \ 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] AGENT A_PROHIBITED -> [withConnEntity <> "error: AGENT A_PROHIBITED" | logLevel <= CLLWarning]
CONN NOT_FOUND -> [withConnEntity <> "error: CONN NOT_FOUND" | logLevel <= CLLWarning] CONN NOT_FOUND -> [withConnEntity <> "error: CONN NOT_FOUND" | logLevel <= CLLWarning]
CRITICAL restart e -> [plain $ "critical error: " <> e] <> ["please restart the app" | restart] CRITICAL restart e -> [plain $ "critical error: " <> e] <> ["please restart the app" | restart]