mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2024-12-17 17:20:21 +01:00
Compare commits
2 Commits
| Author | SHA1 | Date | |
|---|---|---|---|
| c3671b04c5 | |||
| 0e9cc8b3a8 |
@@ -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: {
|
||||||
|
|||||||
@@ -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
|
||||||
|
}
|
||||||
|
|||||||
@@ -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
@@ -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,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
@@ -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,
|
||||||
|
|||||||
@@ -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 <> ")"
|
||||||
|
|||||||
@@ -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)
|
||||||
|
|||||||
@@ -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
|
||||||
|
|||||||
@@ -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"
|
||||||
}
|
}
|
||||||
|
|||||||
@@ -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
@@ -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.
|
||||||
|
|||||||
@@ -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}} =
|
||||||
|
|||||||
@@ -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)
|
||||||
|
|||||||
@@ -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]
|
||||||
|
|||||||
Reference in New Issue
Block a user