From fe6b5186e181d68c4b48aaef06471663023d0abe Mon Sep 17 00:00:00 2001 From: Evgeny Date: Mon, 25 May 2026 10:37:13 +0100 Subject: [PATCH] core: update simplexmq (receiving services) (#6212) * core: update simplexmq * update agent api * update simplexmq * core: add flag to User to use client services * update simplexmq * cli command to toggle service for a user * test, fix * query plans, core/bot api types * remove local package reference * increase server queue size in tests * show client service status in users list * update query plans * cli: fix redraw slowness (#6735) * cli: add pland to fix redraw slowness * updtae doc * cli: decouple key reading from processing via TQueue * schema and bot types --------- Co-authored-by: sh <37271604+shumvgolove@users.noreply.github.com> --- .../src/Broadcast/Options.hs | 2 +- .../src/Directory/Options.hs | 11 +- bots/api/TYPES.md | 7 +- bots/src/API/Docs/Commands.hs | 1 + bots/src/API/Docs/Events.hs | 1 + cabal.project | 2 +- .../types/typescript/src/types.ts | 10 +- .../src/simplex_chat/types/_types.py | 10 +- plans/cli-paste-slowness.md | 111 +++++++++++ scripts/nix/sha256map.nix | 2 +- simplex-chat.cabal | 2 + src/Simplex/Chat.hs | 174 +++++++++--------- src/Simplex/Chat/Controller.hs | 19 +- src/Simplex/Chat/Core.hs | 52 +++--- src/Simplex/Chat/Library/Commands.hs | 63 ++++--- src/Simplex/Chat/Library/Internal.hs | 5 +- src/Simplex/Chat/Library/Subscriber.hs | 40 ++-- src/Simplex/Chat/Mobile.hs | 8 +- src/Simplex/Chat/Options.hs | 11 +- src/Simplex/Chat/Remote.hs | 2 +- src/Simplex/Chat/Store/Postgres/Migrations.hs | 4 +- .../Migrations/M20260520_client_services.hs | 19 ++ .../Store/Postgres/Migrations/chat_schema.sql | 3 +- src/Simplex/Chat/Store/Profiles.hs | 26 ++- src/Simplex/Chat/Store/SQLite/Migrations.hs | 4 +- .../Migrations/M20260520_client_services.hs | 18 ++ .../SQLite/Migrations/agent_query_plans.txt | 101 +++++++++- .../SQLite/Migrations/chat_query_plans.txt | 30 +-- .../Store/SQLite/Migrations/chat_schema.sql | 3 +- src/Simplex/Chat/Store/Shared.hs | 8 +- src/Simplex/Chat/Terminal.hs | 10 +- src/Simplex/Chat/Terminal/Input.hs | 14 +- src/Simplex/Chat/Types.hs | 10 +- src/Simplex/Chat/View.hs | 31 +++- tests/Bots/DirectoryTests.hs | 1 + tests/ChatClient.hs | 26 ++- tests/ChatTests/Profiles.hs | 83 +++++++++ tests/ChatTests/Utils.hs | 7 +- tests/JSONFixtures.hs | 4 +- tests/MobileTests.hs | 4 +- 40 files changed, 681 insertions(+), 258 deletions(-) create mode 100644 plans/cli-paste-slowness.md create mode 100644 src/Simplex/Chat/Store/Postgres/Migrations/M20260520_client_services.hs create mode 100644 src/Simplex/Chat/Store/SQLite/Migrations/M20260520_client_services.hs diff --git a/apps/simplex-broadcast-bot/src/Broadcast/Options.hs b/apps/simplex-broadcast-bot/src/Broadcast/Options.hs index ff853f403d..268e4329cc 100644 --- a/apps/simplex-broadcast-bot/src/Broadcast/Options.hs +++ b/apps/simplex-broadcast-bot/src/Broadcast/Options.hs @@ -94,5 +94,5 @@ mkChatOpts BroadcastBotOpts {coreOptions, botDisplayName} = autoAcceptFileSize = 0, muteNotifications = True, markRead = False, - createBot = Just CreateBotOpts {botDisplayName, allowFiles = False} + createBot = Just CreateBotOpts {botDisplayName, allowFiles = False, clientService = False} } diff --git a/apps/simplex-directory-service/src/Directory/Options.hs b/apps/simplex-directory-service/src/Directory/Options.hs index f566ed5ded..5d51023781 100644 --- a/apps/simplex-directory-service/src/Directory/Options.hs +++ b/apps/simplex-directory-service/src/Directory/Options.hs @@ -39,6 +39,7 @@ data DirectoryOpts = DirectoryOpts directoryLog :: Maybe FilePath, migrateDirectoryLog :: Maybe MigrateLog, serviceName :: T.Text, + clientService :: Bool, runCLI :: Bool, searchResults :: Int, webFolder :: Maybe FilePath, @@ -151,6 +152,11 @@ directoryOpts appDir defaultDbName = do <> help "The display name of the directory service bot, without *'s and spaces (SimpleX Directory)" <> value "SimpleX Directory" ) + clientService <- + switch + ( long "client-service" + <> help "Use client service certificate" + ) runCLI <- switch ( long "run-cli" @@ -188,6 +194,7 @@ directoryOpts appDir defaultDbName = do directoryLog, migrateDirectoryLog, serviceName = T.pack serviceName, + clientService, runCLI, searchResults = 10, webFolder, @@ -207,7 +214,7 @@ getDirectoryOpts appDir defaultDbName = versionAndUpdate = versionStr <> "\n" <> updateStr mkChatOpts :: DirectoryOpts -> ChatOpts -mkChatOpts DirectoryOpts {coreOptions, serviceName} = +mkChatOpts DirectoryOpts {coreOptions, serviceName, clientService} = ChatOpts { coreOptions, chatCmd = "", @@ -221,7 +228,7 @@ mkChatOpts DirectoryOpts {coreOptions, serviceName} = autoAcceptFileSize = 0, muteNotifications = True, markRead = False, - createBot = Just CreateBotOpts {botDisplayName = serviceName, allowFiles = False} + createBot = Just CreateBotOpts {botDisplayName = serviceName, allowFiles = False, clientService} } parseMigrateLog :: ReadM MigrateLog diff --git a/bots/api/TYPES.md b/bots/api/TYPES.md index b4edb9bd22..1b843bc6e4 100644 --- a/bots/api/TYPES.md +++ b/bots/api/TYPES.md @@ -992,9 +992,6 @@ NoRcvFileUser: UserUnknown: - type: "userUnknown" -ActiveUserExists: -- type: "activeUserExists" - UserExists: - type: "userExists" - contactName: string @@ -2882,6 +2879,7 @@ SubscribeError: - profile: [Profile](#profile)? - pastTimestamp: bool - userChatRelay: bool +- clientService: bool --- @@ -4086,8 +4084,9 @@ Handshake: - sendRcptsSmallGroups: bool - autoAcceptMemberContacts: bool - userMemberProfileUpdatedAt: UTCTime? -- uiThemes: [UIThemeEntityOverrides](#uithemeentityoverrides)? - userChatRelay: bool +- clientService: bool +- uiThemes: [UIThemeEntityOverrides](#uithemeentityoverrides)? --- diff --git a/bots/src/API/Docs/Commands.hs b/bots/src/API/Docs/Commands.hs index 8894609758..756cf8c10e 100644 --- a/bots/src/API/Docs/Commands.hs +++ b/bots/src/API/Docs/Commands.hs @@ -271,6 +271,7 @@ cliCommands = "SetAddressSettings", "SetBotCommands", "SetChatTTL", + "SetClientService", "SetContactFeature", "SetContactTimedMessages", "SetGroupFeature", diff --git a/bots/src/API/Docs/Events.hs b/bots/src/API/Docs/Events.hs index c8446e9e67..f0c9352efd 100644 --- a/bots/src/API/Docs/Events.hs +++ b/bots/src/API/Docs/Events.hs @@ -188,6 +188,7 @@ undocumentedEvents = "CEvtCustomChatEvent", "CEvtGroupMemberRatchetSync", "CEvtGroupMemberSwitch", + "CEvtServiceSubStatus", "CEvtNewRemoteHost", "CEvtNoMemberContactCreating", "CEvtNtfMessage", diff --git a/cabal.project b/cabal.project index 7ee797e621..22eeebe714 100644 --- a/cabal.project +++ b/cabal.project @@ -21,7 +21,7 @@ constraints: zip +disable-bzip2 +disable-zstd source-repository-package type: git location: https://github.com/simplex-chat/simplexmq.git - tag: f03cec7a58ed13a39a52886888c74bcefdb64479 + tag: f0b7a4be7325cb787297a881076299c5ffbe26e7 source-repository-package type: git diff --git a/packages/simplex-chat-client/types/typescript/src/types.ts b/packages/simplex-chat-client/types/typescript/src/types.ts index 7e618e05c8..1b9e9f6f65 100644 --- a/packages/simplex-chat-client/types/typescript/src/types.ts +++ b/packages/simplex-chat-client/types/typescript/src/types.ts @@ -994,7 +994,6 @@ export type ChatErrorType = | ChatErrorType.NoSndFileUser | ChatErrorType.NoRcvFileUser | ChatErrorType.UserUnknown - | ChatErrorType.ActiveUserExists | ChatErrorType.UserExists | ChatErrorType.ChatRelayExists | ChatErrorType.DifferentActiveUser @@ -1072,7 +1071,6 @@ export namespace ChatErrorType { | "noSndFileUser" | "noRcvFileUser" | "userUnknown" - | "activeUserExists" | "userExists" | "chatRelayExists" | "differentActiveUser" @@ -1170,10 +1168,6 @@ export namespace ChatErrorType { type: "userUnknown" } - export interface ActiveUserExists extends Interface { - type: "activeUserExists" - } - export interface UserExists extends Interface { type: "userExists" contactName: string @@ -3181,6 +3175,7 @@ export interface NewUser { profile?: Profile pastTimestamp: boolean userChatRelay: boolean + clientService: boolean } export interface NoteFolder { @@ -4795,8 +4790,9 @@ export interface User { sendRcptsSmallGroups: boolean autoAcceptMemberContacts: boolean userMemberProfileUpdatedAt?: string // ISO-8601 timestamp - uiThemes?: UIThemeEntityOverrides userChatRelay: boolean + clientService: boolean + uiThemes?: UIThemeEntityOverrides } export interface UserChatRelay { diff --git a/packages/simplex-chat-python/src/simplex_chat/types/_types.py b/packages/simplex-chat-python/src/simplex_chat/types/_types.py index b2fc00a44c..c378ad56fd 100644 --- a/packages/simplex-chat-python/src/simplex_chat/types/_types.py +++ b/packages/simplex-chat-python/src/simplex_chat/types/_types.py @@ -712,9 +712,6 @@ class ChatErrorType_noRcvFileUser(TypedDict): class ChatErrorType_userUnknown(TypedDict): type: Literal["userUnknown"] -class ChatErrorType_activeUserExists(TypedDict): - type: Literal["activeUserExists"] - class ChatErrorType_userExists(TypedDict): type: Literal["userExists"] contactName: str @@ -987,7 +984,6 @@ ChatErrorType = ( | ChatErrorType_noSndFileUser | ChatErrorType_noRcvFileUser | ChatErrorType_userUnknown - | ChatErrorType_activeUserExists | ChatErrorType_userExists | ChatErrorType_chatRelayExists | ChatErrorType_differentActiveUser @@ -1059,7 +1055,7 @@ ChatErrorType = ( | ChatErrorType_exception ) -ChatErrorType_Tag = Literal["noActiveUser", "noConnectionUser", "noSndFileUser", "noRcvFileUser", "userUnknown", "activeUserExists", "userExists", "chatRelayExists", "differentActiveUser", "cantDeleteActiveUser", "cantDeleteLastUser", "cantHideLastUser", "hiddenUserAlwaysMuted", "emptyUserPassword", "userAlreadyHidden", "userNotHidden", "invalidDisplayName", "chatNotStarted", "chatNotStopped", "chatStoreChanged", "invalidConnReq", "unsupportedConnReq", "connReqMessageProhibited", "contactNotReady", "contactNotActive", "contactDisabled", "connectionDisabled", "groupUserRole", "groupMemberInitialRole", "contactIncognitoCantInvite", "groupIncognitoCantInvite", "groupContactRole", "groupDuplicateMember", "groupDuplicateMemberId", "groupNotJoined", "groupMemberNotActive", "cantBlockMemberForSelf", "groupMemberUserRemoved", "groupMemberNotFound", "groupCantResendInvitation", "groupInternal", "fileNotFound", "fileSize", "fileAlreadyReceiving", "fileCancelled", "fileCancel", "fileAlreadyExists", "fileWrite", "fileSend", "fileRcvChunk", "fileInternal", "fileImageType", "fileImageSize", "fileNotReceived", "fileNotApproved", "fallbackToSMPProhibited", "inlineFileProhibited", "invalidForward", "invalidChatItemUpdate", "invalidChatItemDelete", "hasCurrentCall", "noCurrentCall", "callContact", "directMessagesProhibited", "agentVersion", "agentNoSubResult", "commandError", "agentCommandError", "invalidFileDescription", "connectionIncognitoChangeProhibited", "connectionUserChangeProhibited", "peerChatVRangeIncompatible", "relayTestError", "internalError", "exception"] +ChatErrorType_Tag = Literal["noActiveUser", "noConnectionUser", "noSndFileUser", "noRcvFileUser", "userUnknown", "userExists", "chatRelayExists", "differentActiveUser", "cantDeleteActiveUser", "cantDeleteLastUser", "cantHideLastUser", "hiddenUserAlwaysMuted", "emptyUserPassword", "userAlreadyHidden", "userNotHidden", "invalidDisplayName", "chatNotStarted", "chatNotStopped", "chatStoreChanged", "invalidConnReq", "unsupportedConnReq", "connReqMessageProhibited", "contactNotReady", "contactNotActive", "contactDisabled", "connectionDisabled", "groupUserRole", "groupMemberInitialRole", "contactIncognitoCantInvite", "groupIncognitoCantInvite", "groupContactRole", "groupDuplicateMember", "groupDuplicateMemberId", "groupNotJoined", "groupMemberNotActive", "cantBlockMemberForSelf", "groupMemberUserRemoved", "groupMemberNotFound", "groupCantResendInvitation", "groupInternal", "fileNotFound", "fileSize", "fileAlreadyReceiving", "fileCancelled", "fileCancel", "fileAlreadyExists", "fileWrite", "fileSend", "fileRcvChunk", "fileInternal", "fileImageType", "fileImageSize", "fileNotReceived", "fileNotApproved", "fallbackToSMPProhibited", "inlineFileProhibited", "invalidForward", "invalidChatItemUpdate", "invalidChatItemDelete", "hasCurrentCall", "noCurrentCall", "callContact", "directMessagesProhibited", "agentVersion", "agentNoSubResult", "commandError", "agentCommandError", "invalidFileDescription", "connectionIncognitoChangeProhibited", "connectionUserChangeProhibited", "peerChatVRangeIncompatible", "relayTestError", "internalError", "exception"] ChatFeature = Literal["timedMessages", "fullDelete", "reactions", "voice", "files", "calls", "sessions"] @@ -2226,6 +2222,7 @@ class NewUser(TypedDict): profile: NotRequired["Profile"] pastTimestamp: bool userChatRelay: bool + clientService: bool class NoteFolder(TypedDict): noteFolderId: int # int64 @@ -3363,8 +3360,9 @@ class User(TypedDict): sendRcptsSmallGroups: bool autoAcceptMemberContacts: bool userMemberProfileUpdatedAt: NotRequired[str] # ISO-8601 timestamp - uiThemes: NotRequired["UIThemeEntityOverrides"] userChatRelay: bool + clientService: bool + uiThemes: NotRequired["UIThemeEntityOverrides"] class UserChatRelay(TypedDict): chatRelayId: int # int64 diff --git a/plans/cli-paste-slowness.md b/plans/cli-paste-slowness.md new file mode 100644 index 0000000000..33255996be --- /dev/null +++ b/plans/cli-paste-slowness.md @@ -0,0 +1,111 @@ +# CLI terminal: event loss root cause analysis + +## Two distinct problems + +### Problem 1: Paste — TMVar capacity-1 bottleneck + +When copy-pasting text, the capacity-1 `TMVar` event channel between the keyboard input reader and the consumer loop throttles stdin reading to terminal redraw speed. + +**Root cause:** `events <- liftIO newEmptyTMVarIO` (`Platform.hsc:64`). Producer blocks on `putTMVar` after each event until consumer finishes redrawing. Consumer does a full terminal redraw per event (`Input.hs:161`). + +**Fix:** Replace `TMVar` with `TQueue` in `Platform.hsc` (6 line changes on POSIX, matching changes on Windows). Decouples producer from consumer — stdin is drained at full speed regardless of redraw speed. + +See previous analysis in git history for full details on this issue. + +--- + +### Problem 2: Heavy load — `outputQ` backpressure blocks `agentSubscriber` + +When the CLI is used as a heavy client (e.g., 1M connections), incoming chat events overwhelm the terminal display, causing cascading backpressure that blocks message acknowledgments and stalls the entire event processing pipeline. + +**This is the more severe problem.** It causes actual message loss at the protocol level, not just UI slowness. + +## Root cause: bounded `outputQ` + single-threaded `agentSubscriber` + +### The queue chain + +``` +Network (SMP/XFTP connections) + → agent internal queues + → subQ (TBQueue, capacity 1024) ← agent → chat boundary + → agentSubscriber (single-threaded) ← Commands.hs:4167 + → processAgentMessage ← Subscriber.hs:109 + → toView_ → writeTBQueue outputQ ← Controller.hs:1528, BLOCKS when full + → outputQ (TBQueue, capacity 1024) ← Chat.hs:152 + → runTerminalOutput ← Output.hs:146 + → printToTerminal (acquires termLock) ← Output.hs:298-303 + → terminal I/O (slow) +``` + +All queues are bounded `TBQueue` with default capacity 1024 (`Options.hs:226`). All writes use `writeTBQueue` which **blocks when full** — no events are dropped within the application, but backpressure cascades upstream. + +### The blocking chain under heavy load + +1. **Terminal I/O is the bottleneck.** `runTerminalOutput` (`Output.hs:146`) reads one event at a time from `outputQ`, acquires `termLock`, prints the message + redraws input, releases lock. Each iteration involves ANSI escape sequences, cursor manipulation, and `flush` syscalls. Throughput: ~hundreds of events/sec at best. + +2. **`outputQ` fills up.** With 1M connections generating events, the arrival rate far exceeds terminal display speed. The 1024-element TBQueue fills in seconds. + +3. **`toView_` blocks.** `Controller.hs:1528`: `writeTBQueue localQ (Nothing, event)` blocks when the queue is full. This call happens inside `processAgentMessage` → `processAgentMessageConn`, which runs within the `agentSubscriber` loop. + +4. **`agentSubscriber` blocks — head-of-line blocking.** `Commands.hs:4164-4167`: + ```haskell + agentSubscriber = do + q <- asks $ subQ . smpAgent + forever (atomically (readTBQueue q) >>= process) + ``` + Single-threaded. When `process` blocks on `toView_`, ALL events for ALL connections queue up behind it. Events for 1M other connections — including time-critical ACKs, keepalives, and handshakes — are stuck. + +5. **ACKs are never sent.** The message receive path (`Subscriber.hs:1537-1540`) calls `toView` BEFORE `ackMsg`: + ```haskell + -- Inside withAckMessage's action: + saveRcvChatItem' ... -- save to DB (succeeds) + toView $ CEvtNewChatItems ... -- BLOCKS here (outputQ full) + -- returns (withRcpt, shouldDelConns) + + -- After action returns (Subscriber.hs:1396-1397): + ackMsg msgMeta ... -- NEVER REACHED while toView blocks + ``` + The developers explicitly acknowledge this at `Subscriber.hs:122-123`: + > *without ACK the message delivery will be stuck* + +6. **`subQ` fills up.** The agent can't deliver events to `subQ` (also capacity 1024) because `agentSubscriber` isn't reading. Agent-level processing stalls. + +7. **Network-level failure.** Connections time out due to unprocessed keepalives and unacknowledged messages. Messages are lost at the protocol level. + +### `termLock` contention worsens the bottleneck + +`termLock` (`Output.hs:55`) is a `TMVar ()` mutex shared between: +- **Output thread** (`runTerminalOutput` → `printToTerminal`): acquires lock for each displayed message +- **Input thread** (`receiveFromTTY` → `updateInput`): acquires lock after each keystroke +- **Live prompt thread** (`blinkLivePrompt` → `updateInputView`): acquires lock every 1 second + +Under heavy load, the output thread dominates the lock (constant stream of messages). The input thread is starved — user keystrokes are delayed. This also slows the output thread itself (lock contention overhead). + +Note: `withTermLock` (`Output.hs:138-142`) is not exception-safe — no `bracket`/`finally`. If the action throws, the lock leaks and all threads deadlock. + +### Error reporting also blocks + +When `processAgentMessage` encounters an error, the error handler (`Commands.hs:4179`) calls `eToView'` → `toView_` → `writeTBQueue outputQ`. If `outputQ` is already full, even error reporting blocks. There is no escape path. + +## Impact summary + +| Load level | `outputQ` state | Effect | +|---|---|---| +| Light (few connections) | Nearly empty | No issues | +| Moderate (hundreds) | Partially filled | Occasional display lag | +| Heavy (thousands+) | Full (1024) | `toView_` blocks → `agentSubscriber` blocks → head-of-line blocking for ALL connections → ACKs delayed → message delivery stuck | +| Extreme (1M connections) | Permanently full | Cascading failure: all event processing stops, connections time out, messages lost at protocol level | + +## Fix + +The core fix: **`toView_` must never block the event processing pipeline on terminal display.** + +Options (in order of simplicity): + +1. **Make `outputQ` unbounded** — replace `TBQueue` with `TQueue` in `Chat.hs:152`. `writeTQueue` never blocks. Events accumulate in memory under heavy load but the event processing pipeline (including ACKs) is never stalled. Tradeoff: unbounded memory growth under sustained heavy load. + +2. **Non-blocking write with drop** — use `tryWriteTBQueue` in `toView_`. When `outputQ` is full, drop the display event (or a coalesced summary). ACKs and network processing proceed unblocked. Tradeoff: some events not displayed, but none lost at protocol level. + +3. **Separate ACK from display** — restructure `withAckMessage` to send ACK immediately after DB save, before `toView`. This decouples protocol correctness from display. `toView` can still block, but ACKs are always timely. Tradeoff: requires careful restructuring of the message processing path. + +4. **Increase queue capacity** — increase `tbqSize` from 1024 to a larger value. Delays the problem but doesn't fix it. Under sustained heavy load, any finite queue eventually fills. diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index 8a91d35f05..e4532c49b5 100644 --- a/scripts/nix/sha256map.nix +++ b/scripts/nix/sha256map.nix @@ -1,5 +1,5 @@ { - "https://github.com/simplex-chat/simplexmq.git"."f03cec7a58ed13a39a52886888c74bcefdb64479" = "0bkd8kqgmwgfh5rwnw7s4p6mx9kwigi4jq9ljlfvzj23pslk1aq7"; + "https://github.com/simplex-chat/simplexmq.git"."f0b7a4be7325cb787297a881076299c5ffbe26e7" = "0a8a9l31l4a9nilcqg8h60mrxpqxpzzqxi58i60nw8h4vxqqlzcz"; "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/simplex-chat.cabal b/simplex-chat.cabal index bdd7fef0b2..e9a5660637 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -134,6 +134,7 @@ library Simplex.Chat.Store.Postgres.Migrations.M20260507_relay_inactive_at Simplex.Chat.Store.Postgres.Migrations.M20260514_relay_request_group_link_index Simplex.Chat.Store.Postgres.Migrations.M20260515_delivery_job_senders + Simplex.Chat.Store.Postgres.Migrations.M20260520_client_services else exposed-modules: Simplex.Chat.Archive @@ -290,6 +291,7 @@ library Simplex.Chat.Store.SQLite.Migrations.M20260507_relay_inactive_at Simplex.Chat.Store.SQLite.Migrations.M20260514_relay_request_group_link_index Simplex.Chat.Store.SQLite.Migrations.M20260515_delivery_job_senders + Simplex.Chat.Store.SQLite.Migrations.M20260520_client_services other-modules: Paths_simplex_chat hs-source-dirs: diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index c3658a1c94..ec17614db3 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -135,7 +135,7 @@ createChatDatabase chatDbOpts migrationConfig = runExceptT $ do agentStore <- ExceptT $ createAgentStore (toDBOpts chatDbOpts agentSuffix False []) migrationConfig pure ChatDatabase {chatStore, agentStore} -newChatController :: ChatDatabase -> Maybe User -> ChatConfig -> ChatOpts -> Bool -> IO ChatController +newChatController :: ChatDatabase -> Maybe User -> ChatConfig -> ChatOpts -> Bool -> IO (Either AgentErrorType ChatController) newChatController ChatDatabase {chatStore, agentStore} user @@ -145,8 +145,6 @@ newChatController let inlineFiles' = if allowInstantFiles || autoAcceptFileSize > 0 then inlineFiles else inlineFiles {sendChunks = 0, receiveInstant = False} confirmMigrations' = if confirmMigrations == MCConsole && yesToUpMigrations then MCYesUp else confirmMigrations config = cfg {logLevel, showReactions, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, presetServers = presetServers', inlineFiles = inlineFiles', autoAcceptFileSize, highlyAvailable, confirmMigrations = confirmMigrations'} - firstTime = dbNew chatStore - currentUser <- newTVarIO user randomPresetServers <- chooseRandomServers presetServers' let rndSrvs = L.toList randomPresetServers operatorWithId (i, op) = (\o -> o {operatorId = DBEntityId i}) <$> pOperator op @@ -154,90 +152,93 @@ newChatController agentSMP <- randomServerCfgs "agent SMP servers" SPSMP opDomains rndSrvs agentXFTP <- randomServerCfgs "agent XFTP servers" SPXFTP opDomains rndSrvs let randomAgentServers = RandomAgentServers {smpServers = agentSMP, xftpServers = agentXFTP} - currentRemoteHost <- newTVarIO Nothing servers <- withTransaction chatStore $ \db -> agentServers db config randomPresetServers randomAgentServers - smpAgent <- getSMPAgentClient aCfg {tbqSize} servers agentStore backgroundMode - agentAsync <- newTVarIO Nothing - random <- liftIO C.newRandom - eventSeq <- newTVarIO 0 - inputQ <- newTBQueueIO tbqSize - outputQ <- newTBQueueIO tbqSize - subscriptionMode <- newTVarIO SMSubscribe - chatLock <- newEmptyTMVarIO - entityLocks <- TM.emptyIO - sndFiles <- newTVarIO M.empty - rcvFiles <- newTVarIO M.empty - currentCalls <- TM.emptyIO - localDeviceName <- newTVarIO $ fromMaybe deviceNameForRemote deviceName - multicastSubscribers <- newTMVarIO 0 - remoteSessionSeq <- newTVarIO 0 - remoteHostSessions <- TM.emptyIO - remoteHostsFolder <- newTVarIO Nothing - remoteCtrlSession <- newTVarIO Nothing - filesFolder <- newTVarIO optFilesFolder - chatStoreChanged <- newTVarIO False - deliveryTaskWorkers <- TM.emptyIO - deliveryJobWorkers <- TM.emptyIO - relayRequestWorkers <- TM.emptyIO - chatRelayTests <- TM.emptyIO - expireCIThreads <- TM.emptyIO - expireCIFlags <- TM.emptyIO - cleanupManagerAsync <- newTVarIO Nothing - relayGroupLinkChecksAsync <- newTVarIO Nothing - timedItemThreads <- TM.emptyIO - chatActivated <- newTVarIO True - showLiveItems <- newTVarIO False - encryptLocalFiles <- newTVarIO False - tempDirectory <- newTVarIO optTempDirectory - assetsDirectory <- newTVarIO Nothing - contactMergeEnabled <- newTVarIO True - pure - ChatController - { firstTime, - currentUser, - randomPresetServers, - randomAgentServers, - currentRemoteHost, - smpAgent, - agentAsync, - chatStore, - chatStoreChanged, - random, - eventSeq, - inputQ, - outputQ, - subscriptionMode, - chatLock, - entityLocks, - sndFiles, - rcvFiles, - currentCalls, - localDeviceName, - multicastSubscribers, - remoteSessionSeq, - remoteHostSessions, - remoteHostsFolder, - remoteCtrlSession, - config, - filesFolder, - deliveryTaskWorkers, - deliveryJobWorkers, - relayRequestWorkers, - chatRelayTests, - expireCIThreads, - expireCIFlags, - cleanupManagerAsync, - relayGroupLinkChecksAsync, - timedItemThreads, - chatActivated, - showLiveItems, - encryptLocalFiles, - tempDirectory, - assetsDirectory, - logFilePath = logFile, - contactMergeEnabled - } + runExceptT (getSMPAgentClient aCfg {tbqSize} servers agentStore backgroundMode) + >>= mapM (mkChatController config randomPresetServers randomAgentServers) where + mkChatController config randomPresetServers randomAgentServers smpAgent = do + currentUser <- newTVarIO user + currentRemoteHost <- newTVarIO Nothing + agentAsync <- newTVarIO Nothing + random <- liftIO C.newRandom + eventSeq <- newTVarIO 0 + inputQ <- newTBQueueIO tbqSize + outputQ <- newTBQueueIO tbqSize + subscriptionMode <- newTVarIO SMSubscribe + chatLock <- newEmptyTMVarIO + entityLocks <- TM.emptyIO + sndFiles <- newTVarIO M.empty + rcvFiles <- newTVarIO M.empty + currentCalls <- TM.emptyIO + localDeviceName <- newTVarIO $ fromMaybe deviceNameForRemote deviceName + multicastSubscribers <- newTMVarIO 0 + remoteSessionSeq <- newTVarIO 0 + remoteHostSessions <- TM.emptyIO + remoteHostsFolder <- newTVarIO Nothing + remoteCtrlSession <- newTVarIO Nothing + filesFolder <- newTVarIO optFilesFolder + chatStoreChanged <- newTVarIO False + deliveryTaskWorkers <- TM.emptyIO + deliveryJobWorkers <- TM.emptyIO + relayRequestWorkers <- TM.emptyIO + relayGroupLinkChecksAsync <- newTVarIO Nothing + chatRelayTests <- TM.emptyIO + expireCIThreads <- TM.emptyIO + expireCIFlags <- TM.emptyIO + cleanupManagerAsync <- newTVarIO Nothing + timedItemThreads <- TM.emptyIO + chatActivated <- newTVarIO True + showLiveItems <- newTVarIO False + encryptLocalFiles <- newTVarIO False + tempDirectory <- newTVarIO optTempDirectory + assetsDirectory <- newTVarIO Nothing + contactMergeEnabled <- newTVarIO True + pure + ChatController + { firstTime = dbNew chatStore, + currentUser, + randomPresetServers, + randomAgentServers, + currentRemoteHost, + smpAgent, + agentAsync, + chatStore, + chatStoreChanged, + random, + eventSeq, + inputQ, + outputQ, + subscriptionMode, + chatLock, + entityLocks, + sndFiles, + rcvFiles, + currentCalls, + localDeviceName, + multicastSubscribers, + remoteSessionSeq, + remoteHostSessions, + remoteHostsFolder, + remoteCtrlSession, + config, + filesFolder, + deliveryTaskWorkers, + deliveryJobWorkers, + relayRequestWorkers, + relayGroupLinkChecksAsync, + chatRelayTests, + expireCIThreads, + expireCIFlags, + cleanupManagerAsync, + timedItemThreads, + chatActivated, + showLiveItems, + encryptLocalFiles, + tempDirectory, + assetsDirectory, + logFilePath = logFile, + contactMergeEnabled + } presetServers' :: PresetServers presetServers' = presetServers {operators = operators', netCfg = netCfg'} where @@ -271,7 +272,8 @@ newChatController ops <- getUpdateServerOperators db presetOps (null users) let opDomains = operatorDomains $ mapMaybe snd ops (smp', xftp') <- unzip <$> mapM (getServers ops opDomains) users - pure InitialAgentServers {smp = M.fromList (optServers smp' smpServers), xftp = M.fromList (optServers xftp' xftpServers), ntf, netCfg, presetDomains, presetServers = L.toList allPresetServers} + let useServices = M.fromList $ map (\User {agentUserId = AgentUserId uId, clientService} -> (uId, isTrue clientService)) users + pure InitialAgentServers {smp = M.fromList (optServers smp' smpServers), xftp = M.fromList (optServers xftp' xftpServers), ntf, netCfg, useServices, presetDomains, presetServers = L.toList allPresetServers} where optServers :: [(UserId, NonEmpty (ServerCfg p))] -> [ProtoServerWithAuth p] -> [(UserId, NonEmpty (ServerCfg p))] optServers srvs overrides_ = case L.nonEmpty overrides_ of diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index fa2d0af009..402bfa6b10 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -255,11 +255,11 @@ data ChatController = ChatController deliveryTaskWorkers :: TMap DeliveryWorkerKey Worker, deliveryJobWorkers :: TMap DeliveryWorkerKey Worker, relayRequestWorkers :: TMap Int Worker, -- single global worker with key 1 is used to fit into existing worker management framework + relayGroupLinkChecksAsync :: TVar (Maybe (Async ())), chatRelayTests :: TMap ConnId RelayTest, expireCIThreads :: TMap UserId (Maybe (Async ())), expireCIFlags :: TMap UserId Bool, cleanupManagerAsync :: TVar (Maybe (Async ())), - relayGroupLinkChecksAsync :: TVar (Maybe (Async ())), chatActivated :: TVar Bool, timedItemThreads :: TMap (ChatRef, ChatItemId) (TVar (Maybe (Weak ThreadId))), showLiveItems :: TVar Bool, @@ -294,6 +294,7 @@ data ChatCommand | UnhideUser UserPwd | MuteUser | UnmuteUser + | SetClientService UserId ContactName Bool | APIDeleteUser {userId :: UserId, delSMPQueues :: Bool, viewPwd :: Maybe UserPwd} | DeleteUser UserName Bool (Maybe UserPwd) | StartChat {mainApp :: Bool, enableSndFiles :: Bool} -- enableSndFiles has no effect when mainApp is True @@ -895,6 +896,7 @@ data ChatEvent | CEvtConnectionsDiff {userIds :: DatabaseDiff AgentUserId, connIds :: DatabaseDiff AgentConnId} | CEvtSubscriptionEnd {user :: User, connectionEntity :: ConnectionEntity} | CEvtSubscriptionStatus {server :: SMPServer, subscriptionStatus :: SubscriptionStatus, connections :: [AgentConnId]} + | CEvtServiceSubStatus {server :: SMPServer, serviceSubEvent :: ServiceSubEvent} | CEvtHostConnected {protocol :: AProtocolType, transportHost :: TransportHost} | CEvtHostDisconnected {protocol :: AProtocolType, transportHost :: TransportHost} | CEvtReceivedGroupInvitation {user :: User, groupInfo :: GroupInfo, contact :: Contact, fromMemberRole :: GroupMemberRole, memberRole :: GroupMemberRole} @@ -1309,6 +1311,13 @@ data ChatItemDeletion = ChatItemDeletion } deriving (Show) +data ServiceSubEvent + = ServiceSubUp {serviceError :: Maybe Text, queueCount :: Int64} + | ServiceSubDown {queueCount :: Int64} + | ServiceSubAll + | ServiceSubEnd {queueCount :: Int64} + deriving (Show) + data ChatLogLevel = CLLDebug | CLLInfo | CLLWarning | CLLError | CLLImportant deriving (Eq, Ord, Show) @@ -1342,7 +1351,6 @@ data ChatErrorType | CENoSndFileUser {agentSndFileId :: AgentSndFileId} | CENoRcvFileUser {agentRcvFileId :: AgentRcvFileId} | CEUserUnknown - | CEActiveUserExists -- TODO delete | CEUserExists {contactName :: ContactName} | CEChatRelayExists | CEDifferentActiveUser {commandUserId :: UserId, activeUserId :: UserId} @@ -1432,6 +1440,9 @@ data SQLiteError = SQLiteErrorNotADatabase | SQLiteError {dbError :: String} throwDBError :: DatabaseError -> CM () throwDBError = throwError . ChatErrorDatabase +chatErrorAgent :: AgentErrorType -> ChatError +chatErrorAgent e = ChatErrorAgent e (AgentConnId B.empty) Nothing + -- TODO review errors, some of it can be covered by HTTP2 errors data RemoteHostError = RHEMissing -- No remote session matches this identifier @@ -1663,7 +1674,7 @@ withAgent :: (AgentClient -> ExceptT AgentErrorType IO a) -> CM a withAgent action = asks smpAgent >>= liftIO . runExceptT . action - >>= liftEither . first (\e -> ChatErrorAgent e (AgentConnId "") Nothing) + >>= liftEither . first chatErrorAgent withAgent' :: (AgentClient -> IO a) -> CM' a withAgent' action = asks smpAgent >>= liftIO . action @@ -1728,6 +1739,8 @@ $(JQ.deriveJSON defaultJSON ''ParsedServerAddress) $(JQ.deriveJSON defaultJSON ''ChatItemDeletion) +$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "ServiceSub") ''ServiceSubEvent) + $(JQ.deriveJSON defaultJSON ''CoreVersionInfo) #if !defined(dbPostgres) diff --git a/src/Simplex/Chat/Core.hs b/src/Simplex/Chat/Core.hs index 3c1ce9bc26..bd6cac2110 100644 --- a/src/Simplex/Chat/Core.hs +++ b/src/Simplex/Chat/Core.hs @@ -59,11 +59,15 @@ simplexChatCore cfg@ChatConfig {confirmMigrations, testView, chatHooks} opts@Cha users <- withTransaction chatStore getUsers u_ <- selectActiveUser coreOptions chatStore users let backgroundMode = maintenance - cc <- newChatController db u_ cfg opts backgroundMode - forM_ (preStartHook chatHooks) ($ cc) - u <- maybe (noMaintenance >> createActiveUser cc coreOptions createBot) pure u_ - unless testView $ putStrLn $ "Current user: " <> userStr u - runSimplexChat cfg opts u cc chat + newChatController db u_ cfg opts backgroundMode >>= \case + Left e -> do + putStrLn $ "Error starting chat: " <> show e + exitFailure + Right cc -> do + forM_ (preStartHook chatHooks) ($ cc) + u <- maybe (noMaintenance >> createActiveUser cc coreOptions createBot) pure u_ + unless testView $ putStrLn $ "Current user: " <> userStr u + runSimplexChat cfg opts u cc chat noMaintenance = when maintenance $ do putStrLn "exiting: no active user in maintenance mode" exitFailure @@ -118,29 +122,27 @@ selectActiveUser CoreChatOpts {chatRelay} st users createActiveUser :: ChatController -> CoreChatOpts -> Maybe CreateBotOpts -> IO User createActiveUser cc CoreChatOpts {chatRelay} = \case - Just CreateBotOpts {botDisplayName, allowFiles} -> do + Just CreateBotOpts {botDisplayName, allowFiles, clientService} -> do let preferences = if allowFiles then Nothing else Just emptyChatPrefs {files = Just FilesPreference {allow = FANo}} - createUser exitFailure $ (mkProfile botDisplayName) {peerType = Just CPTBot, preferences} - Nothing - | chatRelay -> do - putStrLn - "No chat relay user profile found, it will be created now.\n\ - \Please choose chat relay display name." - loop - | otherwise -> do - putStrLn - "No user profiles found, it will be created now.\n\ - \Please choose your display name.\n\ - \It will be sent to your contacts when you connect.\n\ - \It is only stored on your device and you can change it later." - loop + createUser exitFailure clientService $ (mkProfile botDisplayName) {peerType = Just CPTBot, preferences} + Nothing -> putStrLn noProfile >> loop + where + noProfile + | chatRelay = + "No chat relay user profile found, it will be created now.\n\ + \Please choose chat relay display name." + | otherwise = + "No user profiles found, it will be created now.\n\ + \Please choose your display name.\n\ + \It will be sent to your contacts when you connect.\n\ + \It is only stored on your device and you can change it later." + loop = do + displayName <- T.pack <$> withPrompt "display name" getLine + createUser loop False $ mkProfile displayName where - loop = do - displayName <- T.pack <$> withPrompt "display name: " getLine - createUser loop $ mkProfile displayName mkProfile displayName = Profile {displayName, fullName = "", shortDescr = Nothing, image = Nothing, contactLink = Nothing, peerType = Nothing, preferences = Nothing} - createUser onError p = - execChatCommand' (CreateActiveUser NewUser {profile = Just p, pastTimestamp = False, userChatRelay = chatRelay}) 0 `runReaderT` cc >>= \case + createUser onError clientService p = + execChatCommand' (CreateActiveUser NewUser {profile = Just p, pastTimestamp = False, userChatRelay = BoolDef chatRelay, clientService = BoolDef clientService}) 0 `runReaderT` cc >>= \case Right (CRActiveUser user) -> pure user r -> printResponseEvent (Nothing, Nothing) (config cc) r >> onError diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 84eece9915..f835445f0d 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -348,7 +348,7 @@ parseChatCommand = A.parseOnly chatCommandP . B.dropWhileEnd isSpace processChatCommand :: VersionRangeChat -> NetworkRequestMode -> ChatCommand -> CM ChatResponse processChatCommand vr nm = \case ShowActiveUser -> withUser' $ pure . CRActiveUser - CreateActiveUser NewUser {profile, pastTimestamp, userChatRelay} -> do + CreateActiveUser NewUser {profile, pastTimestamp, userChatRelay, clientService} -> do forM_ profile $ \Profile {displayName} -> checkValidName displayName p@Profile {displayName} <- liftIO $ maybe generateRandomProfile pure profile u <- asks currentUser @@ -356,12 +356,13 @@ processChatCommand vr nm = \case forM_ users $ \User {localDisplayName = n, activeUser, viewPwdHash, userChatRelay = userChatRelay'} -> do when (n == displayName) . throwChatError $ if activeUser || isNothing viewPwdHash then CEUserExists displayName else CEInvalidDisplayName {displayName, validName = ""} - when (userChatRelay && isTrue userChatRelay') $ throwChatError CEChatRelayExists + when (isTrue userChatRelay && isTrue userChatRelay') $ throwChatError CEChatRelayExists (uss, (smp', xftp')) <- chooseServers =<< readTVarIO u - auId <- withAgent $ \a -> createUser a smp' xftp' + let service = isTrue clientService + auId <- withAgent $ \a -> createUser a service smp' xftp' ts <- liftIO $ getCurrentTime >>= if pastTimestamp then coupleDaysAgo else pure user <- withFastStore $ \db -> do - user <- createUserRecordAt db (AgentUserId auId) p userChatRelay True ts + user <- createUserRecordAt db (AgentUserId auId) (isTrue userChatRelay) service p True ts mapM_ (setUserServers db user ts) uss createPresetContactCards db user `catchAllErrors` \_ -> pure () createNoteFolder db user @@ -460,6 +461,19 @@ processChatCommand vr nm = \case UnhideUser viewPwd -> withUser $ \User {userId} -> processChatCommand vr nm $ APIUnhideUser userId viewPwd MuteUser -> withUser $ \User {userId} -> processChatCommand vr nm $ APIMuteUser userId UnmuteUser -> withUser $ \User {userId} -> processChatCommand vr nm $ APIUnmuteUser userId + SetClientService userId' name enable -> checkChatStopped $ withUser' $ \currUser@User {userId} -> do + user@User {agentUserId = AgentUserId auId, clientService, profile = LocalProfile {displayName}} <- + if userId == userId' then pure currUser else privateGetUser userId' + unless (name == displayName) $ throwChatError CEUserUnknown + if enable == isTrue clientService + then ok user + else do + withStore' $ \db -> updateClientService db userId' enable + withAgent $ \a -> setUserService a auId enable + let user' = user {clientService = BoolDef enable} :: User + when (userId == userId') $ chatWriteVar currentUser $ Just user' + setStoreChanged + ok user' APIDeleteUser userId' delSMPQueues viewPwd_ -> withUser $ \user -> do user' <- privateGetUser userId' validateUserPassword user user' viewPwd_ @@ -1728,7 +1742,7 @@ processChatCommand vr nm = \case pure $ CRChatItemTTL user (Just ttl) GetChatItemTTL -> withUser' $ \User {userId} -> do processChatCommand vr nm $ APIGetChatItemTTL userId - APISetNetworkConfig cfg -> withUser' $ \_ -> lift (withAgent' (`setNetworkConfig` cfg)) >> ok_ + APISetNetworkConfig cfg -> withUser' $ \_ -> withAgent (`setNetworkConfig` cfg) >> ok_ APIGetNetworkConfig -> withUser' $ \_ -> CRNetworkConfig <$> lift getNetworkConfig SetNetworkConfig simpleNetCfg -> do @@ -1943,8 +1957,7 @@ processChatCommand vr nm = \case subMode <- chatReadVar subscriptionMode let userData = contactShortLinkData (userProfileDirect user incognitoProfile Nothing True) Nothing userLinkData = UserInvLinkData userData - -- TODO [certs rcv] - (connId, (ccLink, _serviceId)) <- withAgent $ \a -> createConnection a nm (aUserId user) True False SCMInvitation (Just userLinkData) Nothing IKPQOn subMode + (connId, ccLink) <- withAgent $ \a -> createConnection a nm (aUserId user) True False SCMInvitation (Just userLinkData) Nothing IKPQOn subMode ccLink' <- shortenCreatedLink ccLink -- TODO PQ pass minVersion from the current range conn <- withFastStore' $ \db -> createDirectConnection db user connId ccLink' Nothing ConnNew incognitoProfile subMode initialChatVersion PQSupportOn @@ -1985,8 +1998,7 @@ processChatCommand vr nm = \case userLinkData_ | short = Just $ UserInvLinkData $ contactShortLinkData (userProfileDirect newUser Nothing Nothing True) Nothing | otherwise = Nothing - -- TODO [certs rcv] - (agConnId, (ccLink, _serviceId)) <- withAgent $ \a -> createConnection a nm (aUserId newUser) True False SCMInvitation userLinkData_ Nothing IKPQOn subMode + (agConnId, ccLink) <- withAgent $ \a -> createConnection a nm (aUserId newUser) True False SCMInvitation userLinkData_ Nothing IKPQOn subMode ccLink' <- shortenCreatedLink ccLink conn' <- withFastStore' $ \db -> do deleteConnectionRecord db user connId @@ -2263,8 +2275,7 @@ processChatCommand vr nm = \case | isTrue userChatRelay = relayShortLinkData (userProfileDirect user Nothing Nothing True) | otherwise = contactShortLinkData (userProfileDirect user Nothing Nothing True) Nothing userLinkData = UserContactLinkData UserContactData {direct = True, owners = [], relays = [], userData} - -- TODO [certs rcv] - (connId, (ccLink, _serviceId)) <- withAgent $ \a -> createConnection a nm (aUserId user) True True SCMContact (Just userLinkData) Nothing IKPQOn subMode + (connId, ccLink) <- withAgent $ \a -> createConnection a nm (aUserId user) True True SCMContact (Just userLinkData) Nothing IKPQOn subMode ccLink' <- shortenCreatedLink ccLink let ccLink'' = if isTrue userChatRelay then setShortLinkType CCTRelay ccLink' else ccLink' withFastStore $ \db -> createUserContactLink db user connId ccLink'' subMode @@ -2594,8 +2605,7 @@ processChatCommand vr nm = \case Nothing -> do gVar <- asks random subMode <- chatReadVar subscriptionMode - -- TODO [certs rcv] - (agentConnId, (CCLink cReq _, _serviceId)) <- withAgent $ \a -> createConnection a nm (aUserId user) True False SCMInvitation Nothing Nothing IKPQOff subMode + (agentConnId, CCLink cReq _) <- withAgent $ \a -> createConnection a nm (aUserId user) True False SCMInvitation Nothing Nothing IKPQOff subMode member <- withFastStore $ \db -> createNewContactMember db gVar user gInfo contact memRole agentConnId cReq subMode sendInvitation member cReq pure $ CRSentGroupInvitation user gInfo contact member @@ -3042,8 +3052,7 @@ processChatCommand vr nm = \case let userData = encodeShortLinkData $ GroupShortLinkData {groupProfile, publicGroupData = Nothing} userLinkData = UserContactLinkData UserContactData {direct = True, owners = [], relays = [], userData} crClientData = encodeJSON $ CRDataGroup groupLinkId - -- TODO [certs rcv] - (connId, (ccLink, _serviceId)) <- withAgent $ \a -> createConnection a nm (aUserId user) True True SCMContact (Just userLinkData) (Just crClientData) IKPQOff subMode + (connId, ccLink) <- withAgent $ \a -> createConnection a nm (aUserId user) True True SCMContact (Just userLinkData) (Just crClientData) IKPQOff subMode ccLink' <- setShortLinkType CCTGroup <$> shortenCreatedLink ccLink gVar <- asks random gLink <- withFastStore $ \db -> createGroupLink db gVar user gInfo connId ccLink' groupLinkId mRole subMode @@ -3083,8 +3092,7 @@ processChatCommand vr nm = \case when (isJust $ memberContactId m) $ throwCmdError "member contact already exists" subMode <- chatReadVar subscriptionMode -- TODO PQ should negotitate contact connection with PQSupportOn? - -- TODO [certs rcv] - (connId, (CCLink cReq _, _serviceId)) <- withAgent $ \a -> createConnection a nm (aUserId user) True False SCMInvitation Nothing Nothing IKPQOff subMode + (connId, CCLink cReq _) <- withAgent $ \a -> createConnection a nm (aUserId user) True False SCMInvitation Nothing Nothing IKPQOff subMode -- [incognito] reuse membership incognito profile ct <- withFastStore' $ \db -> createMemberContact db user connId cReq g m mConn subMode void $ createChatItem user (CDDirectSnd ct) False CIChatBanner Nothing (Just epochStart) @@ -3145,7 +3153,7 @@ processChatCommand vr nm = \case -- [incognito] send membership incognito profile let p = userProfileDirect user (fromLocalProfile <$> incognitoMembershipProfile gInfo) Nothing True dm <- encodeConnInfo $ XInfo p - (sqSecured, _serviceId) <- withAgent $ \a -> joinConnection a nm (aUserId user) (aConnId conn) True cReq dm PQSupportOff subMode + sqSecured <- withAgent $ \a -> joinConnection a nm (aUserId user) (aConnId conn) True cReq dm PQSupportOff subMode let newStatus = if sqSecured then ConnSndReady else ConnJoined void $ withFastStore' $ \db -> updateConnectionStatusFromTo db conn ConnPrepared newStatus CreateGroupLink gName mRole -> withUser $ \user -> do @@ -3452,11 +3460,11 @@ processChatCommand vr nm = \case (chatRef,) <$> case cType of CTGroup -> withFastStore' $ \db -> getMessageMentions db user chatId msg _ -> pure [] -#if !defined(dbPostgres) checkChatStopped :: CM ChatResponse -> CM ChatResponse checkChatStopped a = asks agentAsync >>= readTVarIO >>= maybe a (const $ throwChatError CEChatNotStopped) setStoreChanged :: CM () setStoreChanged = asks chatStoreChanged >>= atomically . (`writeTVar` True) +#if !defined(dbPostgres) withStoreChanged :: CM () -> CM ChatResponse withStoreChanged a = checkChatStopped $ a >> setStoreChanged >> ok_ #endif @@ -3522,7 +3530,7 @@ processChatCommand vr nm = \case joinPreparedConn conn incognitoProfile chatV = do let profileToSend = userProfileDirect user incognitoProfile Nothing True dm <- encodeConnInfoPQ pqSup' chatV $ XInfo profileToSend - (sqSecured, _serviceId) <- withAgent $ \a -> joinConnection a nm (aUserId user) (aConnId conn) True cReq dm pqSup' subMode + sqSecured <- withAgent $ \a -> joinConnection a nm (aUserId user) (aConnId conn) True cReq dm pqSup' subMode let newStatus = if sqSecured then ConnSndReady else ConnJoined conn' <- withFastStore' $ \db -> updateConnectionStatusFromTo db conn ConnPrepared newStatus pure (conn', incognitoProfile) @@ -3988,7 +3996,7 @@ processChatCommand vr nm = \case groupLink = groupSLink } dm <- encodeConnInfo $ XGrpRelayInv relayInv - (sqSecured, _serviceId) <- withAgent $ \a -> joinConnection a nm (aUserId user) (aConnId conn) True cReq dm PQSupportOff subMode + sqSecured <- withAgent $ \a -> joinConnection a nm (aUserId user) (aConnId conn) True cReq dm PQSupportOff subMode let newConnStatus = if sqSecured then ConnSndReady else ConnJoined withFastStore' $ \db -> do void $ updateConnectionStatusFromTo db conn ConnPrepared newConnStatus @@ -4698,7 +4706,7 @@ agentSubscriber = do q <- asks $ subQ . smpAgent forever (atomically (readTBQueue q) >>= process) `catchOwn` \e -> do - eToView' $ ChatErrorAgent (CRITICAL True $ "Message reception stopped: " <> show e) (AgentConnId "") Nothing + eToView' $ chatErrorAgent $ CRITICAL True $ "Message reception stopped: " <> show e E.throwIO e where process :: (ACorrId, AEntityId, AEvt) -> CM' () @@ -4710,7 +4718,7 @@ agentSubscriber = do where run action = action `catchAllOwnErrors'` eToView' -type AgentSubResult = Map ConnId (Either AgentErrorType (Maybe ClientServiceId)) +type AgentSubResult = Map ConnId (Either AgentErrorType ()) cleanupManager :: CM () cleanupManager = do @@ -4925,6 +4933,7 @@ chatCommandP = "/unhide user " *> (UnhideUser <$> pwdP), "/mute user" $> MuteUser, "/unmute user" $> UnmuteUser, + "/set client service " *> (SetClientService <$> A.decimal <* A.char ':' <*> displayNameP <* A.space <*> onOffP), "/_delete user " *> (APIDeleteUser <$> A.decimal <* " del_smp=" <*> onOffP <*> optional (A.space *> jsonP)), "/delete user " *> (DeleteUser <$> displayNameP <*> pure True <*> optional (A.space *> pwdP)), ("/user" <|> "/u") $> ShowActiveUser, @@ -5372,18 +5381,20 @@ chatCommandP = k : ws -> pure (k, if null ws then Nothing else Just $ T.unwords ws) pure CBCCommand {label, keyword, params} quoted = A.char '\'' *> A.takeTill (== '\'') <* A.char '\'' - newUserP userChatRelay = do + newUserP relay = do (cName, shortDescr) <- profileNameDescr + service <- (" service=" *> onOffP) <|> pure False let profile = Just Profile {displayName = cName, fullName = "", shortDescr, image = Nothing, contactLink = Nothing, peerType = Nothing, preferences = Nothing} - pure NewUser {profile, pastTimestamp = False, userChatRelay} + pure NewUser {profile, pastTimestamp = False, userChatRelay = BoolDef relay, clientService = BoolDef service} newBotUserP = do files_ <- optional $ "files=" *> onOffP <* A.space + service <- ("service=" *> onOffP <* A.space) <|> pure False (cName, shortDescr) <- profileNameDescr let preferences = case files_ of Just True -> Nothing _ -> Just (emptyChatPrefs :: Preferences) {files = Just FilesPreference {allow = FANo}} profile = Just Profile {displayName = cName, fullName = "", shortDescr, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences} - pure NewUser {profile, pastTimestamp = False, userChatRelay = False} + pure NewUser {profile, pastTimestamp = False, userChatRelay = BoolDef False, clientService = BoolDef service} jsonP :: J.FromJSON a => Parser a jsonP = J.eitherDecodeStrict' <$?> A.takeByteString groupProfile = do diff --git a/src/Simplex/Chat/Library/Internal.hs b/src/Simplex/Chat/Library/Internal.hs index 8c6d2a20cd..576eb942a5 100644 --- a/src/Simplex/Chat/Library/Internal.hs +++ b/src/Simplex/Chat/Library/Internal.hs @@ -908,8 +908,7 @@ acceptContactRequest nm user@User {userId} UserContactRequest {agentInvitationId pure (ct, conn, ExistingIncognito <$> incognitoProfile) let profileToSend = userProfileDirect user (fromIncognitoProfile <$> incognitoProfile) (Just ct) True dm <- encodeConnInfoPQ pqSup' chatV $ XInfo profileToSend - -- TODO [certs rcv] - (ct,conn,) . fst <$> withAgent (\a -> acceptContact a nm (aUserId user) (aConnId conn) True invId dm pqSup' subMode) + (ct,conn,) <$> withAgent (\a -> acceptContact a nm (aUserId user) (aConnId conn) True invId dm pqSup' subMode) acceptContactRequestAsync :: User -> Int64 -> Contact -> UserContactRequest -> Maybe IncognitoProfile -> CM Contact acceptContactRequestAsync @@ -2059,7 +2058,7 @@ deliverMessagesB msgReqs = do Left _ce -> (prev, Left (AP.INTERNAL "ChatError, skip")) -- as long as it is Left, the agent batchers should just step over it prepareBatch (Right req) (Right ar) = Right (req, ar) prepareBatch (Left ce) _ = Left ce -- restore original ChatError - prepareBatch _ (Left ae) = Left $ ChatErrorAgent ae (AgentConnId "") Nothing + prepareBatch _ (Left ae) = Left $ chatErrorAgent ae createDelivery :: DB.Connection -> (ChatMsgReq, (AgentMsgId, PQEncryption)) -> IO (Either ChatError ([Int64], PQEncryption)) createDelivery db ((Connection {connId}, _, (_, msgIds)), (agentMsgId, pqEnc')) = do Right . (,pqEnc') <$> mapM (createSndMsgDelivery db (SndMsgDelivery {connId, agentMsgId})) msgIds diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index f90630bc77..a661e53752 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/src/Simplex/Chat/Library/Subscriber.hs @@ -88,7 +88,7 @@ import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..), patt import qualified Simplex.Messaging.Crypto.Ratchet as CR import Simplex.Messaging.Encoding (smpEncode) import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Protocol (ErrorType (..), MsgFlags (..)) +import Simplex.Messaging.Protocol (ErrorType (..), MsgFlags (..), ServiceSub (..), ServiceSubError (..), ServiceSubResult (..)) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.ServiceScheme (ServiceScheme (..)) import qualified Simplex.Messaging.TMap as TM @@ -113,7 +113,7 @@ processAgentMessage _ _ (DEL_RCVQS delQs) = processAgentMessage _ _ (DEL_CONNS connIds) = toView $ CEvtAgentConnsDeleted $ L.map AgentConnId connIds processAgentMessage _ "" (ERR e) = - eToView $ ChatErrorAgent e (AgentConnId "") Nothing + eToView $ chatErrorAgent e processAgentMessage corrId connId msg = do lockEntity <- critical connId (withStore (`getChatLockEntity` AgentConnId connId)) withEntityLock "processAgentMessage" lockEntity $ do @@ -144,12 +144,23 @@ processAgentMessageNoConn = \case UP srv conns -> serverEvent srv SSActive conns SUSPENDED -> toView CEvtChatSuspended DEL_USER agentUserId -> toView $ CEvtAgentUserDeleted agentUserId + SERVICE_UP srv (ServiceSubResult e_ ss) -> serviceEvent srv $ ServiceSubUp (errText <$> e_) (smpQueueCount ss) + where + errText = \case + SSErrorServiceId {} -> "unexpected service ID" + SSErrorQueueCount {expectedQueueCount = n} -> "expected " <> tshow n <> " connections" + SSErrorQueueIdsHash {} -> "different IDs hash" + SERVICE_DOWN srv ss -> serviceEvent srv $ ServiceSubDown $ smpQueueCount ss + SERVICE_ALL srv -> serviceEvent srv ServiceSubAll + SERVICE_END srv ss -> serviceEvent srv $ ServiceSubEnd $ smpQueueCount ss ERRS cErrs -> errsEvent $ L.toList cErrs where hostEvent :: ChatEvent -> CM () hostEvent = whenM (asks $ hostEvents . config) . toView serverEvent :: SMPServer -> SubscriptionStatus -> [ConnId] -> CM () serverEvent srv nsStatus conns = toView $ CEvtSubscriptionStatus srv nsStatus $ map AgentConnId conns + serviceEvent :: SMPServer -> ServiceSubEvent -> CM () + serviceEvent srv = toView . CEvtServiceSubStatus srv errsEvent :: [(ConnId, AgentErrorType)] -> CM () errsEvent = toView . CEvtChatErrors . map (\(cId, e) -> ChatErrorAgent e (AgentConnId cId) Nothing) @@ -383,7 +394,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = agentMsgConnStatus :: Connection -> AEvent e -> Maybe ConnStatus agentMsgConnStatus Connection {connStatus = cs} = \case - JOINED True _ -> Just ConnSndReady + JOINED True -> Just ConnSndReady CONF {} -> Just ConnRequested INFO {} -> Just ConnSndReady CON _ -> Just ConnReady @@ -457,8 +468,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = OK -> -- [async agent commands] continuation on receiving OK when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () - -- TODO [certs rcv] - JOINED _ _serviceId -> + JOINED _ -> -- [async agent commands] continuation on receiving JOINED when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () QCONT -> @@ -477,8 +487,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = -- TODO add debugging output _ -> pure () Just ct@Contact {contactId} -> case agentMsg of - -- TODO [certs rcv] - INV (ACR _ cReq) _serviceId -> + INV (ACR _ cReq) -> -- [async agent commands] XGrpMemIntro continuation on receiving INV withCompletedCommand conn agentMsg $ \_ -> case cReq of @@ -667,8 +676,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = OK -> -- [async agent commands] continuation on receiving OK when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () - -- TODO [certs rcv] - JOINED sqSecured _serviceId -> + JOINED sqSecured -> -- [async agent commands] continuation on receiving JOINED when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> when (directOrUsed ct && sqSecured) $ do @@ -709,8 +717,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = processGroupMessage :: AEvent e -> ConnectionEntity -> Connection -> GroupInfo -> GroupMember -> CM () processGroupMessage agentMsg connEntity conn@Connection {connId, connChatVersion, customUserProfileId, connectionCode} gInfo@GroupInfo {groupId, groupProfile, membership, chatSettings} m = case agentMsg of - -- TODO [certs rcv] - INV (ACR _ cReq) _serviceId -> + INV (ACR _ cReq) -> withCompletedCommand conn agentMsg $ \CommandData {cmdFunction} -> case cReq of groupConnReq@(CRInvitationUri _ _) -> case cmdFunction of @@ -1149,8 +1156,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = OK -> -- [async agent commands] continuation on receiving OK when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () - -- TODO [certs rcv] - JOINED sqSecured _serviceId -> + JOINED sqSecured -> -- [async agent commands] continuation on receiving JOINED when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> when (sqSecured && connChatVersion >= batchSend2Version) $ do @@ -1680,7 +1686,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = unless shouldDelConns $ withLog (eInfo <> " ok") $ ackMsg msgMeta $ if withRcpt then Just "" else Nothing -- If showCritical is True, then these errors don't result in ACK and show user visible alert -- This prevents losing the message that failed to be processed. - Left (ChatErrorStore SEDBBusyError {message}) | showCritical -> throwError $ ChatErrorAgent (CRITICAL True message) (AgentConnId "") Nothing + Left (ChatErrorStore SEDBBusyError {message}) | showCritical -> throwError $ chatErrorAgent $ CRITICAL True message Left e -> do withLog (eInfo <> " error: " <> tshow e) $ ackMsg msgMeta Nothing throwError e @@ -3338,10 +3344,10 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = fromGroupId_ = Just groupId, fromGroupMemberId_ = Just (groupMemberId' m), fromGroupMemberConnId_ = Just mConnId, - groupDirectInvStartedConnection = isTrue $ autoAcceptMemberContacts user + groupDirectInvStartedConnection = autoAcceptMemberContacts user } joinExistingContact subMode mCt@Contact {contactId = mContactId} - | isTrue (autoAcceptMemberContacts user) = do + | autoAcceptMemberContacts user = do (cmdId, acId) <- joinConn subMode mCt' <- withStore $ \db -> do updateMemberContactInvited db user mCt groupDirectInv @@ -3359,7 +3365,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = createInternalChatItem user (CDDirectRcv mCt') (CIRcvDirectEvent $ RDEGroupInvLinkReceived gp) Nothing createItems mCt' m createNewContact subMode - | isTrue (autoAcceptMemberContacts user) = do + | autoAcceptMemberContacts user = do (cmdId, acId) <- joinConn subMode -- [incognito] reuse membership incognito profile (mCt, m') <- withStore $ \db -> do diff --git a/src/Simplex/Chat/Mobile.hs b/src/Simplex/Chat/Mobile.hs index 281fc6b03b..018457c7e7 100644 --- a/src/Simplex/Chat/Mobile.hs +++ b/src/Simplex/Chat/Mobile.hs @@ -49,6 +49,7 @@ import Simplex.Chat.Store.Profiles import Simplex.Chat.Types import Simplex.Messaging.Agent.Client (agentClientStore) import Simplex.Messaging.Agent.Env.SQLite (createAgentStore) +import Simplex.Messaging.Agent.Protocol (AgentErrorType) import Simplex.Messaging.Agent.Store.Interface (closeDBStore, reopenDBStore) import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..), MigrationError) import qualified Simplex.Messaging.Crypto as C @@ -72,6 +73,7 @@ data DBMigrationResult | DBMErrorNotADatabase {dbFile :: String} | DBMErrorMigration {dbFile :: String, migrationError :: MigrationError} | DBMErrorSQL {dbFile :: String, migrationSQLError :: String} + | DBMAgentError {agentError :: AgentErrorType} deriving (Show) $(JQ.deriveToJSON (sumTypeJSON $ dropPrefix "DBM") ''DBMigrationResult) @@ -298,12 +300,12 @@ chatMigrateInitKey chatDbOpts keepKey confirm backgroundMode = runExceptT $ do let migrationConfig = MigrationConfig confirmMigrations (Just "") chatStore <- migrate createChatStore (toDBOpts chatDbOpts chatSuffix keepKey chatDBFunctions) migrationConfig agentStore <- migrate createAgentStore (toDBOpts chatDbOpts agentSuffix keepKey []) migrationConfig - liftIO $ initialize chatStore ChatDatabase {chatStore, agentStore} + ExceptT $ initialize chatStore ChatDatabase {chatStore, agentStore} where opts = mobileChatOpts $ removeDbKey chatDbOpts initialize st db = do - user_ <- getActiveUser_ st - newChatController db user_ defaultMobileConfig opts backgroundMode + user_ <- liftIO $ getActiveUser_ st + first DBMAgentError <$> newChatController db user_ defaultMobileConfig opts backgroundMode migrate createStore dbOpts confirmMigrations = ExceptT $ (first (DBMErrorMigration errDbStr) <$> createStore dbOpts confirmMigrations) diff --git a/src/Simplex/Chat/Options.hs b/src/Simplex/Chat/Options.hs index dde223f6b9..08a765077f 100644 --- a/src/Simplex/Chat/Options.hs +++ b/src/Simplex/Chat/Options.hs @@ -74,7 +74,8 @@ data CoreChatOpts = CoreChatOpts data CreateBotOpts = CreateBotOpts { botDisplayName :: Text, - allowFiles :: Bool + allowFiles :: Bool, + clientService :: Bool } data ChatCmdLog = CCLAll | CCLMessages | CCLNone @@ -390,6 +391,11 @@ chatOptsP appDir defaultDbName = do ( long "create-bot-allow-files" <> help "Flag for created bot to allow files (only allowed together with --create-bot option)" ) + createBotClientService <- + switch + ( long "create-bot-client-service" + <> help "Flag for created bot to use client service certificate" + ) pure ChatOpts { coreOptions, @@ -405,9 +411,10 @@ chatOptsP appDir defaultDbName = do muteNotifications, markRead, createBot = case createBotDisplayName of - Just botDisplayName -> Just CreateBotOpts {botDisplayName, allowFiles = createBotAllowFiles} + Just botDisplayName -> Just CreateBotOpts {botDisplayName, allowFiles = createBotAllowFiles, clientService = createBotClientService} Nothing | createBotAllowFiles -> error "--create-bot-allow-files option requires --create-bot-name option" + | createBotClientService -> error "--create-bot-client-service option requires --create-bot-name option" | otherwise -> Nothing } diff --git a/src/Simplex/Chat/Remote.hs b/src/Simplex/Chat/Remote.hs index cfe8e944a5..89100ff890 100644 --- a/src/Simplex/Chat/Remote.hs +++ b/src/Simplex/Chat/Remote.hs @@ -539,7 +539,7 @@ handleRemoteCommand execCC encryption remoteOutputQ HTTP2Request {request, reqBo Left e -> eToView' $ ChatErrorRemoteCtrl $ RCEProtocolError e takeRCStep :: RCStepTMVar a -> CM a -takeRCStep = liftError' (\e -> ChatErrorAgent {agentError = RCP e, agentConnId = AgentConnId "", connectionEntity_ = Nothing}) . atomically . takeTMVar +takeRCStep = liftError' (chatErrorAgent . RCP) . atomically . takeTMVar type GetChunk = Int -> IO ByteString diff --git a/src/Simplex/Chat/Store/Postgres/Migrations.hs b/src/Simplex/Chat/Store/Postgres/Migrations.hs index ed0b3c9312..10368e2e30 100644 --- a/src/Simplex/Chat/Store/Postgres/Migrations.hs +++ b/src/Simplex/Chat/Store/Postgres/Migrations.hs @@ -32,6 +32,7 @@ import Simplex.Chat.Store.Postgres.Migrations.M20260429_relay_request_retries import Simplex.Chat.Store.Postgres.Migrations.M20260507_relay_inactive_at import Simplex.Chat.Store.Postgres.Migrations.M20260514_relay_request_group_link_index import Simplex.Chat.Store.Postgres.Migrations.M20260515_delivery_job_senders +import Simplex.Chat.Store.Postgres.Migrations.M20260520_client_services import Simplex.Messaging.Agent.Store.Shared (Migration (..)) schemaMigrations :: [(String, Text, Maybe Text)] @@ -63,7 +64,8 @@ schemaMigrations = ("20260429_relay_request_retries", m20260429_relay_request_retries, Just down_m20260429_relay_request_retries), ("20260507_relay_inactive_at", m20260507_relay_inactive_at, Just down_m20260507_relay_inactive_at), ("20260514_relay_request_group_link_index", m20260514_relay_request_group_link_index, Just down_m20260514_relay_request_group_link_index), - ("20260515_delivery_job_senders", m20260515_delivery_job_senders, Just down_m20260515_delivery_job_senders) + ("20260515_delivery_job_senders", m20260515_delivery_job_senders, Just down_m20260515_delivery_job_senders), + ("20260520_client_services", m20260520_client_services, Just down_m20260520_client_services) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Chat/Store/Postgres/Migrations/M20260520_client_services.hs b/src/Simplex/Chat/Store/Postgres/Migrations/M20260520_client_services.hs new file mode 100644 index 0000000000..af567130eb --- /dev/null +++ b/src/Simplex/Chat/Store/Postgres/Migrations/M20260520_client_services.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Store.Postgres.Migrations.M20260520_client_services where + +import Data.Text (Text) +import Text.RawString.QQ (r) + +m20260520_client_services :: Text +m20260520_client_services = + [r| +ALTER TABLE users ADD COLUMN client_service SMALLINT NOT NULL DEFAULT 0; +|] + +down_m20260520_client_services :: Text +down_m20260520_client_services = + [r| +ALTER TABLE users DROP COLUMN client_service; +|] diff --git a/src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql b/src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql index 86cce86d9e..35388141bc 100644 --- a/src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql @@ -1433,7 +1433,8 @@ CREATE TABLE test_chat_schema.users ( ui_themes text, active_order bigint DEFAULT 0 NOT NULL, auto_accept_member_contacts smallint DEFAULT 0 NOT NULL, - is_user_chat_relay smallint DEFAULT 0 NOT NULL + is_user_chat_relay smallint DEFAULT 0 NOT NULL, + client_service smallint DEFAULT 0 NOT NULL ); diff --git a/src/Simplex/Chat/Store/Profiles.hs b/src/Simplex/Chat/Store/Profiles.hs index cff3e68234..da45b43f8f 100644 --- a/src/Simplex/Chat/Store/Profiles.hs +++ b/src/Simplex/Chat/Store/Profiles.hs @@ -20,7 +20,6 @@ module Simplex.Chat.Store.Profiles UserMsgReceiptSettings (..), UserContactLink (..), GroupLinkInfo (..), - createUserRecord, createUserRecordAt, getUsersInfo, getUsers, @@ -38,6 +37,7 @@ module Simplex.Chat.Store.Profiles getUserFileInfo, deleteUserRecord, updateUserPrivacy, + updateClientService, updateAllContactReceipts, updateUserContactReceipts, updateUserGroupReceipts, @@ -128,11 +128,8 @@ import Database.SQLite.Simple (Only (..), Query, (:.) (..)) import Database.SQLite.Simple.QQ (sql) #endif -createUserRecord :: DB.Connection -> AgentUserId -> Profile -> Bool -> Bool -> ExceptT StoreError IO User -createUserRecord db auId p userChatRelay activeUser = createUserRecordAt db auId p userChatRelay activeUser =<< liftIO getCurrentTime - -createUserRecordAt :: DB.Connection -> AgentUserId -> Profile -> Bool -> Bool -> UTCTime -> ExceptT StoreError IO User -createUserRecordAt db (AgentUserId auId) Profile {displayName, fullName, shortDescr, image, peerType, preferences = userPreferences} userChatRelay activeUser currentTs = +createUserRecordAt :: DB.Connection -> AgentUserId -> Bool -> Bool -> Profile -> Bool -> UTCTime -> ExceptT StoreError IO User +createUserRecordAt db (AgentUserId auId) userChatRelay clientService Profile {displayName, fullName, shortDescr, image, peerType, preferences = userPreferences} activeUser currentTs = checkConstraint SEDuplicateName . liftIO $ do when activeUser $ DB.execute_ db "UPDATE users SET active_user = 0" let showNtfs = True @@ -142,9 +139,9 @@ createUserRecordAt db (AgentUserId auId) Profile {displayName, fullName, shortDe order <- getNextActiveOrder db DB.execute db - "INSERT INTO users (agent_user_id, local_display_name, active_user, is_user_chat_relay, active_order, contact_id, show_ntfs, send_rcpts_contacts, send_rcpts_small_groups, auto_accept_member_contacts, created_at, updated_at) VALUES (?,?,?,?,?,0,?,?,?,?,?,?)" + "INSERT INTO users (agent_user_id, local_display_name, active_user, is_user_chat_relay, active_order, contact_id, show_ntfs, send_rcpts_contacts, send_rcpts_small_groups, auto_accept_member_contacts, client_service, created_at, updated_at) VALUES (?,?,?,?,?,0,?,?,?,?,?,?,?)" ( (auId, displayName, BI activeUser, BI userChatRelay, order) - :. (BI showNtfs, BI sendRcptsContacts, BI sendRcptsSmallGroups, BI autoAcceptMemberContacts, currentTs, currentTs) + :. (BI showNtfs, BI sendRcptsContacts, BI sendRcptsSmallGroups, BI autoAcceptMemberContacts, BI clientService, currentTs, currentTs) ) userId <- insertedRowId db DB.execute @@ -162,7 +159,7 @@ createUserRecordAt db (AgentUserId auId) Profile {displayName, fullName, shortDe (profileId, displayName, userId, BI True, currentTs, currentTs, currentTs) contactId <- insertedRowId db DB.execute db "UPDATE users SET contact_id = ? WHERE user_id = ?" (contactId, userId) - pure $ toUser $ (userId, auId, contactId, profileId, BI activeUser, order) :. (displayName, fullName, shortDescr, image, Nothing, peerType, userPreferences) :. (BI showNtfs, BI sendRcptsContacts, BI sendRcptsSmallGroups, BI autoAcceptMemberContacts, Nothing, Nothing, Nothing, Nothing, BI userChatRelay) + pure $ toUser $ (userId, auId, contactId, profileId, BI activeUser, order) :. (displayName, fullName, shortDescr, image, Nothing, peerType, userPreferences) :. (BI showNtfs, BI sendRcptsContacts, BI sendRcptsSmallGroups, BI autoAcceptMemberContacts, Nothing, Nothing, Nothing, BI userChatRelay, BI clientService, Nothing) -- TODO [mentions] getUsersInfo :: DB.Connection -> IO [UserInfo] @@ -285,6 +282,17 @@ updateUserPrivacy db User {userId, showNtfs, viewPwdHash} = where hashSalt = L.unzip . fmap (\UserPwdHash {hash, salt} -> (hash, salt)) +updateClientService :: DB.Connection -> UserId -> Bool -> IO () +updateClientService db userId enable = + DB.execute + db + [sql| + UPDATE users + SET client_service = ? + WHERE user_id = ? + |] + (BI enable, userId) + updateAllContactReceipts :: DB.Connection -> Bool -> IO () updateAllContactReceipts db onOff = DB.execute diff --git a/src/Simplex/Chat/Store/SQLite/Migrations.hs b/src/Simplex/Chat/Store/SQLite/Migrations.hs index 65ccb8e58f..2674705181 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations.hs +++ b/src/Simplex/Chat/Store/SQLite/Migrations.hs @@ -155,6 +155,7 @@ import Simplex.Chat.Store.SQLite.Migrations.M20260429_relay_request_retries import Simplex.Chat.Store.SQLite.Migrations.M20260507_relay_inactive_at import Simplex.Chat.Store.SQLite.Migrations.M20260514_relay_request_group_link_index import Simplex.Chat.Store.SQLite.Migrations.M20260515_delivery_job_senders +import Simplex.Chat.Store.SQLite.Migrations.M20260520_client_services import Simplex.Messaging.Agent.Store.Shared (Migration (..)) schemaMigrations :: [(String, Query, Maybe Query)] @@ -309,7 +310,8 @@ schemaMigrations = ("20260429_relay_request_retries", m20260429_relay_request_retries, Just down_m20260429_relay_request_retries), ("20260507_relay_inactive_at", m20260507_relay_inactive_at, Just down_m20260507_relay_inactive_at), ("20260514_relay_request_group_link_index", m20260514_relay_request_group_link_index, Just down_m20260514_relay_request_group_link_index), - ("20260515_delivery_job_senders", m20260515_delivery_job_senders, Just down_m20260515_delivery_job_senders) + ("20260515_delivery_job_senders", m20260515_delivery_job_senders, Just down_m20260515_delivery_job_senders), + ("20260520_client_services", m20260520_client_services, Just down_m20260520_client_services) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/M20260520_client_services.hs b/src/Simplex/Chat/Store/SQLite/Migrations/M20260520_client_services.hs new file mode 100644 index 0000000000..db141d6c03 --- /dev/null +++ b/src/Simplex/Chat/Store/SQLite/Migrations/M20260520_client_services.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Store.SQLite.Migrations.M20260520_client_services where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20260520_client_services :: Query +m20260520_client_services = + [sql| +ALTER TABLE users ADD COLUMN client_service INTEGER NOT NULL DEFAULT 0; +|] + +down_m20260520_client_services :: Query +down_m20260520_client_services = + [sql| +ALTER TABLE users DROP COLUMN client_service; +|] diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/agent_query_plans.txt b/src/Simplex/Chat/Store/SQLite/Migrations/agent_query_plans.txt index de1e0a093d..ee857211aa 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/agent_query_plans.txt +++ b/src/Simplex/Chat/Store/SQLite/Migrations/agent_query_plans.txt @@ -293,6 +293,15 @@ Query: Plan: SEARCH connections USING PRIMARY KEY (conn_id=?) +Query: + INSERT INTO client_services + (user_id, host, port, server_key_hash, service_cert_hash, service_cert, service_priv_key) + VALUES (?,?,?,?,?,?,?) + ON CONFLICT (user_id, host, port, server_key_hash) DO NOTHING + RETURNING 1 + +Plan: + Query: INSERT INTO conn_confirmations (confirmation_id, conn_id, sender_key, e2e_snd_pub_key, ratchet_state, sender_conn_info, smp_reply_queues, smp_client_version, accepted) VALUES (?, ?, ?, ?, ?, ?, ?, ?, 0); @@ -457,6 +466,27 @@ Plan: SCAN ntf_tokens_to_delete USE TEMP B-TREE FOR DISTINCT +Query: + SELECT c.service_cert_hash, c.service_cert, c.service_priv_key, c.service_id + FROM client_services c + JOIN servers s ON c.host = s.host AND c.port = s.port + WHERE c.user_id = ? AND c.host = ? AND c.port = ? + AND COALESCE(c.server_key_hash, s.key_hash) = ? + +Plan: +SEARCH s USING PRIMARY KEY (host=? AND port=?) +SEARCH c USING INDEX idx_server_certs_user_id_host_port (user_id=? AND host=? AND port=?) + +Query: + SELECT c.service_id, c.service_queue_count, c.service_queue_ids_hash + FROM client_services c + JOIN servers s ON s.host = c.host AND s.port = c.port + WHERE c.user_id = ? AND c.host = ? AND c.port = ? AND COALESCE(c.server_key_hash, s.key_hash) = ? AND service_id IS NOT NULL + +Plan: +SEARCH s USING PRIMARY KEY (host=? AND port=?) +SEARCH c USING INDEX idx_server_certs_user_id_host_port (user_id=? AND host=? AND port=?) + Query: SELECT confirmation_id, ratchet_state, own_conn_info, sender_key, e2e_snd_pub_key, sender_conn_info, smp_reply_queues, smp_client_version FROM conn_confirmations @@ -518,6 +548,15 @@ Plan: SEARCH s USING PRIMARY KEY (conn_id=? AND internal_snd_id=?) SEARCH m USING PRIMARY KEY (conn_id=? AND internal_id=?) +Query: + UPDATE rcv_messages + SET receive_attempts = receive_attempts + 1 + WHERE conn_id = ? AND internal_id = ? + RETURNING receive_attempts + +Plan: +SEARCH rcv_messages USING COVERING INDEX idx_rcv_messages_conn_id_internal_id (conn_id=? AND internal_id=?) + Query: DELETE FROM conn_confirmations WHERE conn_id = ? @@ -602,11 +641,11 @@ SEARCH messages USING COVERING INDEX idx_messages_conn_id_internal_rcv_id (conn_ Query: INSERT INTO rcv_queues - ( host, port, rcv_id, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret, + ( host, port, rcv_id, rcv_service_assoc, conn_id, rcv_private_key, rcv_dh_secret, e2e_priv_key, e2e_dh_secret, snd_id, queue_mode, status, to_subscribe, rcv_queue_id, rcv_primary, replace_rcv_queue_id, smp_client_version, server_key_hash, link_id, link_key, link_priv_sig_key, link_enc_fixed_data, ntf_public_key, ntf_private_key, ntf_id, rcv_ntf_dh_secret - ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?); + ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?); Plan: @@ -657,6 +696,21 @@ Query: Plan: SEARCH snd_file_chunk_replica_recipients USING INDEX idx_snd_file_chunk_replica_recipients_snd_file_chunk_replica_id (snd_file_chunk_replica_id=?) +Query: + UPDATE client_services + SET service_id = ? + FROM servers s + WHERE client_services.user_id = ? + AND client_services.host = ? + AND client_services.port = ? + AND s.host = client_services.host + AND s.port = client_services.port + AND COALESCE(client_services.server_key_hash, s.key_hash) = ? + +Plan: +SEARCH s USING PRIMARY KEY (host=? AND port=?) +SEARCH client_services USING COVERING INDEX idx_server_certs_user_id_host_port (user_id=? AND host=? AND port=?) + Query: UPDATE conn_confirmations SET accepted = 1, @@ -746,6 +800,16 @@ Query: Plan: SEARCH rcv_queues USING PRIMARY KEY (host=? AND port=? AND rcv_id=?) +Query: + UPDATE rcv_queues + SET rcv_service_assoc = 0 + FROM connections c + WHERE c.conn_id = rcv_queues.conn_id AND c.user_id = ? + +Plan: +SEARCH c USING COVERING INDEX idx_connections_user (user_id=?) +SEARCH rcv_queues USING COVERING INDEX idx_rcv_queue_id (conn_id=?) + Query: UPDATE rcv_queues SET status = ? @@ -816,7 +880,7 @@ SEARCH s USING PRIMARY KEY (host=? AND port=?) Query: SELECT c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_dh_secret, q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.queue_mode, q.status, c.enable_ntfs, q.client_notice_id, - q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id, q.switch_status, q.smp_client_version, q.delete_errors, + q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id, q.switch_status, q.smp_client_version, q.delete_errors, q.rcv_service_assoc, q.ntf_public_key, q.ntf_private_key, q.ntf_id, q.rcv_ntf_dh_secret, q.link_id, q.link_key, q.link_priv_sig_key, q.link_enc_fixed_data FROM rcv_queues q @@ -831,7 +895,7 @@ SEARCH s USING PRIMARY KEY (host=? AND port=?) Query: SELECT c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_dh_secret, q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.queue_mode, q.status, c.enable_ntfs, q.client_notice_id, - q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id, q.switch_status, q.smp_client_version, q.delete_errors, + q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id, q.switch_status, q.smp_client_version, q.delete_errors, q.rcv_service_assoc, q.ntf_public_key, q.ntf_private_key, q.ntf_id, q.rcv_ntf_dh_secret, q.link_id, q.link_key, q.link_priv_sig_key, q.link_enc_fixed_data FROM rcv_queues q @@ -846,7 +910,7 @@ SEARCH c USING PRIMARY KEY (conn_id=?) Query: SELECT c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_dh_secret, q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.queue_mode, q.status, c.enable_ntfs, q.client_notice_id, - q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id, q.switch_status, q.smp_client_version, q.delete_errors, + q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id, q.switch_status, q.smp_client_version, q.delete_errors, q.rcv_service_assoc, q.ntf_public_key, q.ntf_private_key, q.ntf_id, q.rcv_ntf_dh_secret, q.link_id, q.link_key, q.link_priv_sig_key, q.link_enc_fixed_data FROM rcv_queues q @@ -861,7 +925,7 @@ SEARCH c USING PRIMARY KEY (conn_id=?) Query: SELECT c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_dh_secret, q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.queue_mode, q.status, c.enable_ntfs, q.client_notice_id, - q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id, q.switch_status, q.smp_client_version, q.delete_errors, + q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id, q.switch_status, q.smp_client_version, q.delete_errors, q.rcv_service_assoc, q.ntf_public_key, q.ntf_private_key, q.ntf_id, q.rcv_ntf_dh_secret, q.link_id, q.link_key, q.link_priv_sig_key, q.link_enc_fixed_data FROM rcv_queues q @@ -876,7 +940,7 @@ SEARCH s USING PRIMARY KEY (host=? AND port=?) Query: SELECT c.user_id, COALESCE(q.server_key_hash, s.key_hash), q.conn_id, q.host, q.port, q.rcv_id, q.rcv_private_key, q.rcv_dh_secret, q.e2e_priv_key, q.e2e_dh_secret, q.snd_id, q.queue_mode, q.status, c.enable_ntfs, q.client_notice_id, - q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id, q.switch_status, q.smp_client_version, q.delete_errors, + q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id, q.switch_status, q.smp_client_version, q.delete_errors, q.rcv_service_assoc, q.ntf_public_key, q.ntf_private_key, q.ntf_id, q.rcv_ntf_dh_secret, q.link_id, q.link_key, q.link_priv_sig_key, q.link_enc_fixed_data FROM rcv_queues q @@ -888,6 +952,18 @@ SEARCH q USING PRIMARY KEY (host=? AND port=? AND rcv_id=?) SEARCH s USING PRIMARY KEY (host=? AND port=?) SEARCH c USING PRIMARY KEY (conn_id=?) +Query: + SELECT c.user_id, q.conn_id, q.host, q.port, COALESCE(q.server_key_hash, s.key_hash), q.rcv_id, q.rcv_private_key, q.status, c.enable_ntfs, q.client_notice_id, + q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id + FROM rcv_queues q + JOIN servers s ON q.host = s.host AND q.port = s.port + JOIN connections c ON q.conn_id = c.conn_id + WHERE c.deleted = 0 AND q.deleted = 0 AND c.user_id = ? AND q.host = ? AND q.port = ? AND COALESCE(q.server_key_hash, s.key_hash) = ? AND q.rcv_service_assoc = 0 ORDER BY q.rcv_id LIMIT ? +Plan: +SEARCH s USING PRIMARY KEY (host=? AND port=?) +SEARCH q USING PRIMARY KEY (host=? AND port=?) +SEARCH c USING PRIMARY KEY (conn_id=?) + Query: SELECT c.user_id, q.conn_id, q.host, q.port, COALESCE(q.server_key_hash, s.key_hash), q.rcv_id, q.rcv_private_key, q.status, c.enable_ntfs, q.client_notice_id, q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id @@ -912,6 +988,10 @@ SEARCH q USING INDEX idx_rcv_queues_to_subscribe (to_subscribe=? AND host=? AND SEARCH c USING PRIMARY KEY (conn_id=?) SEARCH s USING PRIMARY KEY (host=? AND port=?) +Query: DELETE FROM client_services WHERE user_id = ? +Plan: +SEARCH client_services USING COVERING INDEX idx_server_certs_user_id_host_port (user_id=?) + Query: DELETE FROM commands WHERE command_id = ? Plan: SEARCH commands USING INTEGER PRIMARY KEY (rowid=?) @@ -1002,6 +1082,7 @@ SEARCH snd_queues USING COVERING INDEX idx_snd_queue_id (conn_id=? AND snd_queue Query: DELETE FROM users WHERE user_id = 2 Plan: SEARCH users USING INTEGER PRIMARY KEY (rowid=?) +SEARCH client_services USING COVERING INDEX idx_server_certs_user_id_host_port (user_id=?) SEARCH deleted_snd_chunk_replicas USING COVERING INDEX idx_deleted_snd_chunk_replicas_user_id (user_id=?) SEARCH snd_files USING COVERING INDEX idx_snd_files_user_id (user_id=?) SEARCH rcv_files USING COVERING INDEX idx_rcv_files_user_id (user_id=?) @@ -1010,6 +1091,7 @@ SEARCH connections USING COVERING INDEX idx_connections_user (user_id=?) Query: DELETE FROM users WHERE user_id = ? Plan: SEARCH users USING INTEGER PRIMARY KEY (rowid=?) +SEARCH client_services USING COVERING INDEX idx_server_certs_user_id_host_port (user_id=?) SEARCH deleted_snd_chunk_replicas USING COVERING INDEX idx_deleted_snd_chunk_replicas_user_id (user_id=?) SEARCH snd_files USING COVERING INDEX idx_snd_files_user_id (user_id=?) SEARCH rcv_files USING COVERING INDEX idx_rcv_files_user_id (user_id=?) @@ -1041,6 +1123,7 @@ Plan: Query: INSERT INTO servers (host, port, key_hash) VALUES (?,?,?) ON CONFLICT (host, port) DO NOTHING RETURNING 1 Plan: +SEARCH client_services USING COVERING INDEX idx_server_certs_host_port (host=? AND port=?) SEARCH inv_short_links USING COVERING INDEX idx_inv_short_links_link_id (host=? AND port=?) SEARCH commands USING COVERING INDEX idx_commands_server_commands (host=? AND port=?) SEARCH ntf_subscriptions USING COVERING INDEX idx_ntf_subscriptions_smp_host_smp_port (smp_host=? AND smp_port=?) @@ -1257,6 +1340,10 @@ Query: UPDATE rcv_queues SET rcv_primary = ?, replace_rcv_queue_id = ? WHERE con Plan: SEARCH rcv_queues USING COVERING INDEX idx_rcv_queue_id (conn_id=? AND rcv_queue_id=?) +Query: UPDATE rcv_queues SET rcv_service_assoc = 1 WHERE host = ? AND port = ? AND rcv_id = ? +Plan: +SEARCH rcv_queues USING PRIMARY KEY (host=? AND port=? AND rcv_id=?) + Query: UPDATE rcv_queues SET to_subscribe = 0 WHERE to_subscribe = 1 Plan: SEARCH rcv_queues USING COVERING INDEX idx_rcv_queues_to_subscribe (to_subscribe=?) diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt b/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt index dbbe2f8a0a..598ee920dd 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt +++ b/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt @@ -5251,6 +5251,14 @@ Query: Plan: SEARCH user_contact_links USING INTEGER PRIMARY KEY (rowid=?) +Query: + UPDATE users + SET client_service = ? + WHERE user_id = ? + +Plan: +SEARCH users USING INTEGER PRIMARY KEY (rowid=?) + Query: UPDATE users SET view_pwd_hash = ?, view_pwd_salt = ?, show_ntfs = ? @@ -5804,7 +5812,7 @@ SEARCH server_operators USING INTEGER PRIMARY KEY (rowid=?) Query: SELECT u.user_id, u.agent_user_id, u.contact_id, ucp.contact_profile_id, u.active_user, u.active_order, u.local_display_name, ucp.full_name, ucp.short_descr, ucp.image, ucp.contact_link, ucp.chat_peer_type, ucp.preferences, - u.show_ntfs, u.send_rcpts_contacts, u.send_rcpts_small_groups, u.auto_accept_member_contacts, u.view_pwd_hash, u.view_pwd_salt, u.user_member_profile_updated_at, u.ui_themes, u.is_user_chat_relay + u.show_ntfs, u.send_rcpts_contacts, u.send_rcpts_small_groups, u.auto_accept_member_contacts, u.view_pwd_hash, u.view_pwd_salt, u.user_member_profile_updated_at, u.is_user_chat_relay, u.client_service, u.ui_themes FROM users u JOIN contacts uct ON uct.contact_id = u.contact_id JOIN contact_profiles ucp ON ucp.contact_profile_id = uct.contact_profile_id @@ -5816,7 +5824,7 @@ SEARCH ucp USING INTEGER PRIMARY KEY (rowid=?) Query: SELECT u.user_id, u.agent_user_id, u.contact_id, ucp.contact_profile_id, u.active_user, u.active_order, u.local_display_name, ucp.full_name, ucp.short_descr, ucp.image, ucp.contact_link, ucp.chat_peer_type, ucp.preferences, - u.show_ntfs, u.send_rcpts_contacts, u.send_rcpts_small_groups, u.auto_accept_member_contacts, u.view_pwd_hash, u.view_pwd_salt, u.user_member_profile_updated_at, u.ui_themes, u.is_user_chat_relay + u.show_ntfs, u.send_rcpts_contacts, u.send_rcpts_small_groups, u.auto_accept_member_contacts, u.view_pwd_hash, u.view_pwd_salt, u.user_member_profile_updated_at, u.is_user_chat_relay, u.client_service, u.ui_themes FROM users u JOIN contacts uct ON uct.contact_id = u.contact_id JOIN contact_profiles ucp ON ucp.contact_profile_id = uct.contact_profile_id @@ -5829,7 +5837,7 @@ SEARCH ucp USING INTEGER PRIMARY KEY (rowid=?) Query: SELECT u.user_id, u.agent_user_id, u.contact_id, ucp.contact_profile_id, u.active_user, u.active_order, u.local_display_name, ucp.full_name, ucp.short_descr, ucp.image, ucp.contact_link, ucp.chat_peer_type, ucp.preferences, - u.show_ntfs, u.send_rcpts_contacts, u.send_rcpts_small_groups, u.auto_accept_member_contacts, u.view_pwd_hash, u.view_pwd_salt, u.user_member_profile_updated_at, u.ui_themes, u.is_user_chat_relay + u.show_ntfs, u.send_rcpts_contacts, u.send_rcpts_small_groups, u.auto_accept_member_contacts, u.view_pwd_hash, u.view_pwd_salt, u.user_member_profile_updated_at, u.is_user_chat_relay, u.client_service, u.ui_themes FROM users u JOIN contacts uct ON uct.contact_id = u.contact_id JOIN contact_profiles ucp ON ucp.contact_profile_id = uct.contact_profile_id @@ -5842,7 +5850,7 @@ SEARCH ucp USING INTEGER PRIMARY KEY (rowid=?) Query: SELECT u.user_id, u.agent_user_id, u.contact_id, ucp.contact_profile_id, u.active_user, u.active_order, u.local_display_name, ucp.full_name, ucp.short_descr, ucp.image, ucp.contact_link, ucp.chat_peer_type, ucp.preferences, - u.show_ntfs, u.send_rcpts_contacts, u.send_rcpts_small_groups, u.auto_accept_member_contacts, u.view_pwd_hash, u.view_pwd_salt, u.user_member_profile_updated_at, u.ui_themes, u.is_user_chat_relay + u.show_ntfs, u.send_rcpts_contacts, u.send_rcpts_small_groups, u.auto_accept_member_contacts, u.view_pwd_hash, u.view_pwd_salt, u.user_member_profile_updated_at, u.is_user_chat_relay, u.client_service, u.ui_themes FROM users u JOIN contacts uct ON uct.contact_id = u.contact_id JOIN contact_profiles ucp ON ucp.contact_profile_id = uct.contact_profile_id @@ -5856,7 +5864,7 @@ SEARCH ucp USING INTEGER PRIMARY KEY (rowid=?) Query: SELECT u.user_id, u.agent_user_id, u.contact_id, ucp.contact_profile_id, u.active_user, u.active_order, u.local_display_name, ucp.full_name, ucp.short_descr, ucp.image, ucp.contact_link, ucp.chat_peer_type, ucp.preferences, - u.show_ntfs, u.send_rcpts_contacts, u.send_rcpts_small_groups, u.auto_accept_member_contacts, u.view_pwd_hash, u.view_pwd_salt, u.user_member_profile_updated_at, u.ui_themes, u.is_user_chat_relay + u.show_ntfs, u.send_rcpts_contacts, u.send_rcpts_small_groups, u.auto_accept_member_contacts, u.view_pwd_hash, u.view_pwd_salt, u.user_member_profile_updated_at, u.is_user_chat_relay, u.client_service, u.ui_themes FROM users u JOIN contacts uct ON uct.contact_id = u.contact_id JOIN contact_profiles ucp ON ucp.contact_profile_id = uct.contact_profile_id @@ -5869,7 +5877,7 @@ SEARCH ucp USING INTEGER PRIMARY KEY (rowid=?) Query: SELECT u.user_id, u.agent_user_id, u.contact_id, ucp.contact_profile_id, u.active_user, u.active_order, u.local_display_name, ucp.full_name, ucp.short_descr, ucp.image, ucp.contact_link, ucp.chat_peer_type, ucp.preferences, - u.show_ntfs, u.send_rcpts_contacts, u.send_rcpts_small_groups, u.auto_accept_member_contacts, u.view_pwd_hash, u.view_pwd_salt, u.user_member_profile_updated_at, u.ui_themes, u.is_user_chat_relay + u.show_ntfs, u.send_rcpts_contacts, u.send_rcpts_small_groups, u.auto_accept_member_contacts, u.view_pwd_hash, u.view_pwd_salt, u.user_member_profile_updated_at, u.is_user_chat_relay, u.client_service, u.ui_themes FROM users u JOIN contacts uct ON uct.contact_id = u.contact_id JOIN contact_profiles ucp ON ucp.contact_profile_id = uct.contact_profile_id @@ -5882,7 +5890,7 @@ SEARCH ucp USING INTEGER PRIMARY KEY (rowid=?) Query: SELECT u.user_id, u.agent_user_id, u.contact_id, ucp.contact_profile_id, u.active_user, u.active_order, u.local_display_name, ucp.full_name, ucp.short_descr, ucp.image, ucp.contact_link, ucp.chat_peer_type, ucp.preferences, - u.show_ntfs, u.send_rcpts_contacts, u.send_rcpts_small_groups, u.auto_accept_member_contacts, u.view_pwd_hash, u.view_pwd_salt, u.user_member_profile_updated_at, u.ui_themes, u.is_user_chat_relay + u.show_ntfs, u.send_rcpts_contacts, u.send_rcpts_small_groups, u.auto_accept_member_contacts, u.view_pwd_hash, u.view_pwd_salt, u.user_member_profile_updated_at, u.is_user_chat_relay, u.client_service, u.ui_themes FROM users u JOIN contacts uct ON uct.contact_id = u.contact_id JOIN contact_profiles ucp ON ucp.contact_profile_id = uct.contact_profile_id @@ -5895,7 +5903,7 @@ SEARCH ucp USING INTEGER PRIMARY KEY (rowid=?) Query: SELECT u.user_id, u.agent_user_id, u.contact_id, ucp.contact_profile_id, u.active_user, u.active_order, u.local_display_name, ucp.full_name, ucp.short_descr, ucp.image, ucp.contact_link, ucp.chat_peer_type, ucp.preferences, - u.show_ntfs, u.send_rcpts_contacts, u.send_rcpts_small_groups, u.auto_accept_member_contacts, u.view_pwd_hash, u.view_pwd_salt, u.user_member_profile_updated_at, u.ui_themes, u.is_user_chat_relay + u.show_ntfs, u.send_rcpts_contacts, u.send_rcpts_small_groups, u.auto_accept_member_contacts, u.view_pwd_hash, u.view_pwd_salt, u.user_member_profile_updated_at, u.is_user_chat_relay, u.client_service, u.ui_themes FROM users u JOIN contacts uct ON uct.contact_id = u.contact_id JOIN contact_profiles ucp ON ucp.contact_profile_id = uct.contact_profile_id @@ -5908,7 +5916,7 @@ SEARCH ucp USING INTEGER PRIMARY KEY (rowid=?) Query: SELECT u.user_id, u.agent_user_id, u.contact_id, ucp.contact_profile_id, u.active_user, u.active_order, u.local_display_name, ucp.full_name, ucp.short_descr, ucp.image, ucp.contact_link, ucp.chat_peer_type, ucp.preferences, - u.show_ntfs, u.send_rcpts_contacts, u.send_rcpts_small_groups, u.auto_accept_member_contacts, u.view_pwd_hash, u.view_pwd_salt, u.user_member_profile_updated_at, u.ui_themes, u.is_user_chat_relay + u.show_ntfs, u.send_rcpts_contacts, u.send_rcpts_small_groups, u.auto_accept_member_contacts, u.view_pwd_hash, u.view_pwd_salt, u.user_member_profile_updated_at, u.is_user_chat_relay, u.client_service, u.ui_themes FROM users u JOIN contacts uct ON uct.contact_id = u.contact_id JOIN contact_profiles ucp ON ucp.contact_profile_id = uct.contact_profile_id @@ -5920,7 +5928,7 @@ SEARCH ucp USING INTEGER PRIMARY KEY (rowid=?) Query: SELECT u.user_id, u.agent_user_id, u.contact_id, ucp.contact_profile_id, u.active_user, u.active_order, u.local_display_name, ucp.full_name, ucp.short_descr, ucp.image, ucp.contact_link, ucp.chat_peer_type, ucp.preferences, - u.show_ntfs, u.send_rcpts_contacts, u.send_rcpts_small_groups, u.auto_accept_member_contacts, u.view_pwd_hash, u.view_pwd_salt, u.user_member_profile_updated_at, u.ui_themes, u.is_user_chat_relay + u.show_ntfs, u.send_rcpts_contacts, u.send_rcpts_small_groups, u.auto_accept_member_contacts, u.view_pwd_hash, u.view_pwd_salt, u.user_member_profile_updated_at, u.is_user_chat_relay, u.client_service, u.ui_themes FROM users u JOIN contacts uct ON uct.contact_id = u.contact_id JOIN contact_profiles ucp ON ucp.contact_profile_id = uct.contact_profile_id @@ -6596,7 +6604,7 @@ Plan: Query: INSERT INTO user_contact_links (user_id, group_id, group_link_id, local_display_name, conn_req_contact, short_link_contact, short_link_data_set, short_link_large_data_set, group_link_member_role, auto_accept, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?,?,?) Plan: -Query: INSERT INTO users (agent_user_id, local_display_name, active_user, is_user_chat_relay, active_order, contact_id, show_ntfs, send_rcpts_contacts, send_rcpts_small_groups, auto_accept_member_contacts, created_at, updated_at) VALUES (?,?,?,?,?,0,?,?,?,?,?,?) +Query: INSERT INTO users (agent_user_id, local_display_name, active_user, is_user_chat_relay, active_order, contact_id, show_ntfs, send_rcpts_contacts, send_rcpts_small_groups, auto_accept_member_contacts, client_service, created_at, updated_at) VALUES (?,?,?,?,?,0,?,?,?,?,?,?,?) Plan: Query: INSERT INTO xftp_file_descriptions (user_id, file_descr_text, file_descr_part_no, file_descr_complete, created_at, updated_at) VALUES (?,?,?,?,?,?) diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql b/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql index 8fca9f2e84..fb72eecfc0 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql @@ -39,7 +39,8 @@ CREATE TABLE users( ui_themes TEXT, active_order INTEGER NOT NULL DEFAULT 0, auto_accept_member_contacts INTEGER NOT NULL DEFAULT 0, - is_user_chat_relay INTEGER NOT NULL DEFAULT 0, -- 1 for active user + is_user_chat_relay INTEGER NOT NULL DEFAULT 0, + client_service INTEGER NOT NULL DEFAULT 0, -- 1 for active user FOREIGN KEY(user_id, local_display_name) REFERENCES display_names(user_id, local_display_name) ON DELETE RESTRICT diff --git a/src/Simplex/Chat/Store/Shared.hs b/src/Simplex/Chat/Store/Shared.hs index af0958ed35..cf630eae02 100644 --- a/src/Simplex/Chat/Store/Shared.hs +++ b/src/Simplex/Chat/Store/Shared.hs @@ -539,15 +539,15 @@ userQuery :: Query userQuery = [sql| SELECT u.user_id, u.agent_user_id, u.contact_id, ucp.contact_profile_id, u.active_user, u.active_order, u.local_display_name, ucp.full_name, ucp.short_descr, ucp.image, ucp.contact_link, ucp.chat_peer_type, ucp.preferences, - u.show_ntfs, u.send_rcpts_contacts, u.send_rcpts_small_groups, u.auto_accept_member_contacts, u.view_pwd_hash, u.view_pwd_salt, u.user_member_profile_updated_at, u.ui_themes, u.is_user_chat_relay + u.show_ntfs, u.send_rcpts_contacts, u.send_rcpts_small_groups, u.auto_accept_member_contacts, u.view_pwd_hash, u.view_pwd_salt, u.user_member_profile_updated_at, u.is_user_chat_relay, u.client_service, u.ui_themes FROM users u JOIN contacts uct ON uct.contact_id = u.contact_id JOIN contact_profiles ucp ON ucp.contact_profile_id = uct.contact_profile_id |] -toUser :: (UserId, UserId, ContactId, ProfileId, BoolInt, Int64) :. (ContactName, Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences) :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString, Maybe B64UrlByteString, Maybe UTCTime, Maybe UIThemeEntityOverrides, BoolInt) -> User -toUser ((userId, auId, userContactId, profileId, BI activeUser, activeOrder) :. (displayName, fullName, shortDescr, image, contactLink, peerType, userPreferences) :. (BI showNtfs, BI sendRcptsContacts, BI sendRcptsSmallGroups, BI autoAcceptMemberContacts, viewPwdHash_, viewPwdSalt_, userMemberProfileUpdatedAt, uiThemes, BI userChatRelay)) = - User {userId, agentUserId = AgentUserId auId, userContactId, localDisplayName = displayName, profile, activeUser, activeOrder, fullPreferences, showNtfs, sendRcptsContacts, sendRcptsSmallGroups, autoAcceptMemberContacts = BoolDef autoAcceptMemberContacts, viewPwdHash, userMemberProfileUpdatedAt, uiThemes, userChatRelay = BoolDef userChatRelay} +toUser :: (UserId, UserId, ContactId, ProfileId, BoolInt, Int64) :. (ContactName, Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact, Maybe ChatPeerType, Maybe Preferences) :. (BoolInt, BoolInt, BoolInt, BoolInt, Maybe B64UrlByteString, Maybe B64UrlByteString, Maybe UTCTime, BoolInt, BoolInt, Maybe UIThemeEntityOverrides) -> User +toUser ((userId, auId, userContactId, profileId, BI activeUser, activeOrder) :. (displayName, fullName, shortDescr, image, contactLink, peerType, userPreferences) :. (BI showNtfs, BI sendRcptsContacts, BI sendRcptsSmallGroups, BI autoAcceptMemberContacts, viewPwdHash_, viewPwdSalt_, userMemberProfileUpdatedAt, BI userChatRelay, BI clientService, uiThemes)) = + User {userId, agentUserId = AgentUserId auId, userContactId, localDisplayName = displayName, profile, activeUser, activeOrder, fullPreferences, showNtfs, sendRcptsContacts, sendRcptsSmallGroups, autoAcceptMemberContacts, viewPwdHash, userMemberProfileUpdatedAt, userChatRelay = BoolDef userChatRelay, clientService = BoolDef clientService, uiThemes} where profile = LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, peerType, preferences = userPreferences, localAlias = ""} fullPreferences = fullPreferences' userPreferences diff --git a/src/Simplex/Chat/Terminal.hs b/src/Simplex/Chat/Terminal.hs index 21781229e4..29299cfeae 100644 --- a/src/Simplex/Chat/Terminal.hs +++ b/src/Simplex/Chat/Terminal.hs @@ -8,6 +8,7 @@ module Simplex.Chat.Terminal where import Control.Monad +import Control.Monad.IO.Class (liftIO) import qualified Data.List.NonEmpty as L import Simplex.Chat (defaultChatConfig) import Simplex.Chat.Controller @@ -22,6 +23,8 @@ import Simplex.Chat.Terminal.Output import Simplex.FileTransfer.Client.Presets (defaultXFTPServers) import Simplex.Messaging.Client (NetworkConfig (..), SMPProxyFallback (..), SMPProxyMode (..), defaultNetworkConfig) import Simplex.Messaging.Util (raceAny_) +import System.Terminal (Key, Modifiers) +import UnliftIO.STM #if !defined(dbPostgres) import Control.Exception (handle, throwIO) import qualified Data.ByteArray as BA @@ -99,4 +102,9 @@ simplexChatTerminal cfg options t = run options #endif runChatTerminal :: ChatTerminal -> ChatController -> ChatOpts -> IO () -runChatTerminal ct cc opts = raceAny_ [runTerminalInput ct cc, runTerminalOutput ct cc opts, runInputLoop ct cc] +runChatTerminal ct cc opts = do + keyQ <- newTQueueIO + raceAny_ [runKeyReader ct keyQ, runTerminalInput ct cc keyQ, runTerminalOutput ct cc opts, runInputLoop ct cc] + +runKeyReader :: ChatTerminal -> TQueue (Key, Modifiers) -> IO () +runKeyReader ct q = withChatTerm ct $ forever $ getKey >>= liftIO . atomically . writeTQueue q diff --git a/src/Simplex/Chat/Terminal/Input.hs b/src/Simplex/Chat/Terminal/Input.hs index e0ee10aff9..effcb7a71c 100644 --- a/src/Simplex/Chat/Terminal/Input.hs +++ b/src/Simplex/Chat/Terminal/Input.hs @@ -152,14 +152,14 @@ sendUpdatedLiveMessage cc sentMsg LiveMessage {chatName, chatItemId} live = do let cmd = UpdateLiveMessage chatName chatItemId live $ T.pack sentMsg execChatCommand' cmd 0 `runReaderT` cc -runTerminalInput :: ChatTerminal -> ChatController -> IO () -runTerminalInput ct cc = withChatTerm ct $ do - updateInput ct - receiveFromTTY cc ct +runTerminalInput :: ChatTerminal -> ChatController -> TQueue (Key, Modifiers) -> IO () +runTerminalInput ct cc keyQ = do + updateInputView ct + receiveFromTTY keyQ cc ct -receiveFromTTY :: forall m. MonadTerminal m => ChatController -> ChatTerminal -> m () -receiveFromTTY cc@ChatController {inputQ, currentUser, currentRemoteHost, chatStore} ct@ChatTerminal {termSize, termState, liveMessageState, activeTo} = - forever $ getKey >>= liftIO . processKey >> withTermLock ct (updateInput ct) +receiveFromTTY :: TQueue (Key, Modifiers) -> ChatController -> ChatTerminal -> IO () +receiveFromTTY keyQ cc@ChatController {inputQ, currentUser, currentRemoteHost, chatStore} ct@ChatTerminal {termSize, termState, liveMessageState, activeTo} = + forever $ atomically (readTQueue keyQ) >>= processKey >> updateInputView ct where processKey :: (Key, Modifiers) -> IO () processKey key = case key of diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index f2892898c4..145f3343f3 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -134,17 +134,19 @@ data User = User showNtfs :: Bool, sendRcptsContacts :: Bool, sendRcptsSmallGroups :: Bool, - autoAcceptMemberContacts :: BoolDef, + autoAcceptMemberContacts :: Bool, userMemberProfileUpdatedAt :: Maybe UTCTime, - uiThemes :: Maybe UIThemeEntityOverrides, - userChatRelay :: BoolDef + userChatRelay :: BoolDef, + clientService :: BoolDef, + uiThemes :: Maybe UIThemeEntityOverrides } deriving (Show) data NewUser = NewUser { profile :: Maybe Profile, pastTimestamp :: Bool, - userChatRelay :: Bool + userChatRelay :: BoolDef, + clientService :: BoolDef } deriving (Show) diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 7785d06d44..725642b6e3 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -481,7 +481,8 @@ chatEventToView hu ChatConfig {logLevel, showReactions, showReceipts, testView} CEvtSubscriptionEnd u acEntity -> let Connection {connId} = entityConnection acEntity in ttyUser u [sShow connId <> ": END"] - CEvtSubscriptionStatus srv status conns -> [plain $ subStatusStr status <> " " <> show (length conns) <> " connections on server " <> showSMPServer srv] + CEvtSubscriptionStatus srv status conns -> [plain $ subStatusStr status <> " " <> tshow (length conns) <> " connections on server " <> showSMPServer srv] + CEvtServiceSubStatus srv event -> [plain $ serviceSubEventStr srv event] CEvtReceivedGroupInvitation {user = u, groupInfo = g, contact = c, memberRole = r} -> ttyUser u $ viewReceivedGroupInvitation g c r CEvtUserJoinedGroup u g m -> ttyUser u $ viewUserJoinedGroup g m CEvtGroupLinkDataUpdated u g groupLink relays relaysChanged @@ -618,13 +619,14 @@ viewUsersList us = in if null ss then ["no users"] else ss where ldn (UserInfo User {localDisplayName = n} _) = T.toLower n - userInfo (UserInfo User {localDisplayName = n, profile = LocalProfile {fullName, shortDescr, peerType}, activeUser, showNtfs, viewPwdHash} count) + userInfo (UserInfo User {localDisplayName = n, profile = LocalProfile {fullName, shortDescr, peerType}, activeUser, showNtfs, viewPwdHash, clientService} count) | activeUser || isNothing viewPwdHash = Just $ ttyFullName n fullName shortDescr <> infoStr <> bot | otherwise = Nothing where infoStr = if null info then "" else " (" <> mconcat (intersperse ", " info) <> ")" info = [highlight' "active" | activeUser] + <> [highlight' "service" | isTrue clientService] <> [highlight' "hidden" | isJust viewPwdHash] <> ["muted" | not showNtfs] <> [plain ("unread: " <> show count) | count /= 0] @@ -632,8 +634,8 @@ viewUsersList us = Just CPTBot -> " (bot)" _ -> "" -showSMPServer :: SMPServer -> String -showSMPServer ProtocolServer {host} = B.unpack $ strEncode host +showSMPServer :: SMPServer -> Text +showSMPServer ProtocolServer {host} = safeDecodeUtf8 $ strEncode host viewHostEvent :: AProtocolType -> TransportHost -> String viewHostEvent p h = map toUpper (B.unpack $ strEncode p) <> " host " <> B.unpack (strEncode h) @@ -1493,7 +1495,7 @@ groupInvitation' g@GroupInfo {localDisplayName = ldn, groupProfile = GroupProfil viewNewMemberContactReceivedInv :: User -> Contact -> GroupInfo -> GroupMember -> [StyledString] viewNewMemberContactReceivedInv user ct@Contact {localDisplayName = c} g m - | isTrue (autoAcceptMemberContacts user) = + | autoAcceptMemberContacts user = [ttyGroup' g <> " " <> ttyMember m <> " is creating direct contact " <> ttyContact' ct <> " with you"] | otherwise = [ ttyGroup' g <> " " <> ttyMember m <> " requests to create direct contact with you", @@ -1579,13 +1581,23 @@ viewConnDiffIds userDiff connDiff where showIds = plain . T.intercalate ", " . map (tshow . unwrapId) -subStatusStr :: SubscriptionStatus -> String +subStatusStr :: SubscriptionStatus -> Text subStatusStr = \case SSActive -> "subscribed" SSPending -> "disconnected" - SSRemoved e -> "removed: " <> e + SSRemoved e -> "removed: " <> T.pack e SSNoSub -> "no subscription" +serviceSubEventStr :: SMPServer -> ServiceSubEvent -> Text +serviceSubEventStr srv = \case + ServiceSubUp e_ n -> "subscribed service " <> conns n <> srvStr <> ": " <> fromMaybe "ok" e_ + ServiceSubDown n -> "disconnected service " <> conns n <> srvStr + ServiceSubAll -> "received messages from service" <> srvStr -- "(" <> n <> "connections)" + ServiceSubEnd n -> "service subscription ended " <> conns n <> srvStr + where + conns n = "(" <> tshow n <> " connections)" + srvStr = " on server " <> showSMPServer srv + viewUserServers :: UserOperatorServers -> [StyledString] viewUserServers (UserOperatorServers _ [] [] []) = [] viewUserServers UserOperatorServers {operator, smpServers, xftpServers, chatRelays} = @@ -1810,7 +1822,7 @@ viewConnectionStats ConnectionStats {rcvQueuesInfo, sndQueuesInfo} = <> ["sending messages via: " <> viewSndQueuesInfo sndQueuesInfo | not $ null sndQueuesInfo] viewRcvQueuesInfo :: [RcvQueueInfo] -> StyledString -viewRcvQueuesInfo = plain . intercalate ", " . map showQueueInfo +viewRcvQueuesInfo = plain . T.intercalate ", " . map showQueueInfo where showQueueInfo RcvQueueInfo {rcvServer, rcvSwitchStatus, canAbortSwitch} = let switchCanBeAborted = if canAbortSwitch then ", can be aborted" else "" @@ -1823,7 +1835,7 @@ viewRcvQueuesInfo = plain . intercalate ", " . map showQueueInfo RSReceivedMessage -> "switch secured" viewSndQueuesInfo :: [SndQueueInfo] -> StyledString -viewSndQueuesInfo = plain . intercalate ", " . map showQueueInfo +viewSndQueuesInfo = plain . T.intercalate ", " . map showQueueInfo where showQueueInfo SndQueueInfo {sndServer, sndSwitchStatus} = showSMPServer sndServer @@ -2584,7 +2596,6 @@ viewChatError isCmd logLevel testView = \case CENoConnectionUser agentConnId -> ["error: message user not found, conn id: " <> sShow agentConnId | logLevel <= CLLError] CENoSndFileUser aFileId -> ["error: snd file user not found, file id: " <> sShow aFileId | logLevel <= CLLError] CENoRcvFileUser aFileId -> ["error: rcv file user not found, file id: " <> sShow aFileId | logLevel <= CLLError] - CEActiveUserExists -> ["error: active user already exists"] CEUserExists name -> ["user with the name " <> ttyContact name <> " already exists"] CEChatRelayExists -> ["chat realy user already exists"] CEUserUnknown -> ["user does not exist or incorrect password"] diff --git a/tests/Bots/DirectoryTests.hs b/tests/Bots/DirectoryTests.hs index 0abbe5bd65..140739b4f4 100644 --- a/tests/Bots/DirectoryTests.hs +++ b/tests/Bots/DirectoryTests.hs @@ -126,6 +126,7 @@ mkDirectoryOpts TestParams {tmpPath = ps} superUsers ownersGroup webFolder = directoryLog = Just $ ps "directory_service.log", migrateDirectoryLog = Nothing, serviceName = "SimpleX Directory", + clientService = True, runCLI = False, searchResults = 3, webFolder, diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index 279a09e718..ede3c1f2a2 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -25,6 +25,7 @@ import Data.Functor (($>)) import Data.List (dropWhileEnd, find) import Data.Maybe (isNothing) import qualified Data.Text as T +import Data.Time.Clock (getCurrentTime) import Network.Socket import Simplex.Chat import Simplex.Chat.Controller (ChatCommand (..), ChatConfig (..), ChatController (..), ChatDatabase (..), ChatLogLevel (..), defaultSimpleNetCfg) @@ -281,11 +282,12 @@ prevVersion (Version v) = Version (v - 1) nextVersion :: Version v -> Version v nextVersion (Version v) = Version (v + 1) -createTestChat :: TestParams -> ChatConfig -> ChatOpts -> String -> Profile -> IO TestCC -createTestChat ps cfg opts@ChatOpts {coreOptions = coreOptions@CoreChatOpts {chatRelay}} dbPrefix profile = do +createTestChat :: TestParams -> ChatConfig -> ChatOpts -> String -> Bool -> Profile -> IO TestCC +createTestChat ps cfg opts@ChatOpts {coreOptions = coreOptions@CoreChatOpts {chatRelay}} dbPrefix clientService profile = do Right db@ChatDatabase {chatStore, agentStore} <- createDatabase ps coreOptions dbPrefix insertUser agentStore - Right user <- withTransaction chatStore $ \db' -> runExceptT $ createUserRecord db' (AgentUserId 1) profile chatRelay True + ts <- getCurrentTime + Right user <- withTransaction chatStore $ \db' -> runExceptT $ createUserRecordAt db' (AgentUserId 1) chatRelay clientService profile True ts startTestChat_ ps db cfg opts user startTestChat :: TestParams -> ChatConfig -> ChatOpts -> String -> IO TestCC @@ -313,7 +315,7 @@ startTestChat_ :: TestParams -> ChatDatabase -> ChatConfig -> ChatOpts -> User - startTestChat_ TestParams {printOutput} db cfg opts@ChatOpts {coreOptions = CoreChatOpts {maintenance}} user = do t <- withVirtualTerminal termSettings pure ct <- newChatTerminal t opts - cc <- newChatController db (Just user) cfg opts False + Right cc <- newChatController db (Just user) cfg opts False void $ execChatCommand' (SetTempFolder "tests/tmp/tmp") 0 `runReaderT` cc chatAsync <- async $ runSimplexChat cfg opts user cc $ \_u cc' -> runChatTerminal ct cc' opts unless maintenance $ atomically $ readTVar (agentAsync cc) >>= \a -> when (isNothing a) retry @@ -351,6 +353,9 @@ stopTestChat ps TestCC {chatController = cc@ChatController {smpAgent, chatStore} withNewTestChat :: HasCallStack => TestParams -> String -> Profile -> (HasCallStack => TestCC -> IO a) -> IO a withNewTestChat ps = withNewTestChatCfgOpts ps testCfg testOpts +withNewTestChat_ :: HasCallStack => TestParams -> String -> Bool -> Profile -> (HasCallStack => TestCC -> IO a) -> IO a +withNewTestChat_ ps = withNewTestChatCfgOpts_ ps testCfg testOpts + withNewTestChatV1 :: HasCallStack => TestParams -> String -> Profile -> (HasCallStack => TestCC -> IO a) -> IO a withNewTestChatV1 ps = withNewTestChatCfg ps testCfgV1 @@ -361,9 +366,12 @@ withNewTestChatOpts :: HasCallStack => TestParams -> ChatOpts -> String -> Profi withNewTestChatOpts ps = withNewTestChatCfgOpts ps testCfg withNewTestChatCfgOpts :: HasCallStack => TestParams -> ChatConfig -> ChatOpts -> String -> Profile -> (HasCallStack => TestCC -> IO a) -> IO a -withNewTestChatCfgOpts ps cfg opts dbPrefix profile runTest = +withNewTestChatCfgOpts ps cfg opts dbPrefix = withNewTestChatCfgOpts_ ps cfg opts dbPrefix False + +withNewTestChatCfgOpts_ :: HasCallStack => TestParams -> ChatConfig -> ChatOpts -> String -> Bool -> Profile -> (HasCallStack => TestCC -> IO a) -> IO a +withNewTestChatCfgOpts_ ps cfg opts dbPrefix clientService profile runTest = bracket - (createTestChat ps cfg opts dbPrefix profile) + (createTestChat ps cfg opts dbPrefix clientService profile) (stopTestChat ps) (\cc -> runTest cc >>= ((cc )) @@ -420,9 +428,11 @@ testChatN :: HasCallStack => ChatConfig -> ChatOpts -> [Profile] -> (HasCallStac testChatN cfg opts ps test params = bracket (getTestCCs $ zip ps [1 ..]) endTests test where + useClientServices = False + -- useClientServices = True getTestCCs :: [(Profile, Int)] -> IO [TestCC] getTestCCs [] = pure [] - getTestCCs ((p, db) : envs') = (:) <$> createTestChat params cfg opts (show db) p <*> getTestCCs envs' + getTestCCs ((p, db) : envs') = (:) <$> createTestChat params cfg opts (show db) useClientServices p <*> getTestCCs envs' endTests tcs = do mapConcurrently_ ( 2" cath #> "#club 3" [alice, bob] *<# "#club cath> 3" + +testClientService :: HasCallStack => TestParams -> IO () +testClientService ps = + withNewTestChat ps "alice" aliceProfile $ \alice -> + withNewTestChat ps "bob" bobProfile $ \bob -> do + -- create user as service + withNewTestChat_ ps "service" True serviceProfile $ \service -> do + connectUsers alice service + alice <##> service + service ##> "/set client service 1:service_user off" + service <## "error: chat not stopped" + service ##> "/users" + service <## "service_user (Service user) (active, service)" + -- connect as service + withTestChat ps "service" $ \service -> do + subscribeClientService service 1 + alice <##> service + setClientService ps "off" + -- connect without service + withTestChat ps "service" $ \service -> do + service <## "subscribed 1 connections on server localhost" + alice <##> service + connectUsers bob service + bob <##> service + setClientService ps "on" + -- connect as service, queue associated + withTestChat ps "service" $ \service -> do + service <## "subscribed 2 connections on server localhost" + alice <##> service + bob <##> service + -- connect as service + withTestChat ps "service" $ \service -> do + subscribeClientService service 2 + alice <##> service + bob <##> service + +testSwitchClientService :: HasCallStack => TestParams -> IO () +testSwitchClientService ps = + withNewTestChat ps "user" aliceProfile $ \alice -> + withNewTestChat ps "bob" bobProfile $ \bob -> do + -- create user without service + withNewTestChat_ ps "service" False serviceProfile $ \service -> do + connectUsers alice service + alice <##> service + -- connect without service + withTestChat ps "service" $ \service -> do + service <## "subscribed 1 connections on server localhost" + alice <##> service + setClientService ps "on" + -- connect as service, queue associated + withTestChat ps "service" $ \service -> do + service <## "subscribed 1 connections on server localhost" + alice <##> service + connectUsers bob service + bob <##> service + -- connect as service + withTestChat ps "service" $ \service -> do + subscribeClientService service 2 + alice <##> service + bob <##> service + -- connect without service + setClientService ps "off" + withTestChat ps "service" $ \service -> do + service <## "subscribed 2 connections on server localhost" + alice <##> service + bob <##> service + +setClientService :: TestParams -> String -> IO () +setClientService ps onOff = + withTestChatCfgOpts ps testCfg testOpts {coreOptions = testCoreOpts {maintenance = True}} "service" $ \service -> do + service ##> ("/set client service 1:service_user " <> onOff) + service <## "ok" + +subscribeClientService :: TestCC -> Int -> IO () +subscribeClientService service n = + service + <### + [ ConsoleString $ "subscribed service (" <> show n <> " connections) on server localhost: ok", + "received messages from service on server localhost" + ] diff --git a/tests/ChatTests/Utils.hs b/tests/ChatTests/Utils.hs index 4b28229348..4987319899 100644 --- a/tests/ChatTests/Utils.hs +++ b/tests/ChatTests/Utils.hs @@ -84,6 +84,9 @@ businessProfile = mkProfile "biz" "Biz Inc" Nothing chatRelayProfile :: Profile chatRelayProfile = mkProfile "relay" "Relay" Nothing +serviceProfile :: Profile +serviceProfile = mkProfile "service_user" "Service user" Nothing + mkProfile :: T.Text -> T.Text -> Maybe ImageData -> Profile mkProfile displayName descr image = Profile {displayName, fullName = "", shortDescr = Just descr, image, contactLink = Nothing, peerType = Nothing, preferences = defaultPrefs} @@ -120,7 +123,7 @@ skip = before_ . pendingWith versionTestMatrix2 :: (HasCallStack => Bool -> Bool -> TestCC -> TestCC -> IO ()) -> SpecWith TestParams versionTestMatrix2 runTest = do it "current" $ testChat2 aliceProfile bobProfile (runTest True True) - it "prev" $ testChatCfg2 testCfgVPrev aliceProfile bobProfile (runTest False True) + it "prev" $ runTestCfg2 testCfgVPrev testCfgVPrev (runTest False True) it "prev to curr" $ runTestCfg2 testCfg testCfgVPrev (runTest False True) it "curr to prev" $ runTestCfg2 testCfgVPrev testCfg (runTest False True) it "old (1st supported)" $ testChatCfg2 testCfgV1 aliceProfile bobProfile (runTest False False) @@ -130,7 +133,7 @@ versionTestMatrix2 runTest = do versionTestMatrix3 :: (HasCallStack => TestCC -> TestCC -> TestCC -> IO ()) -> SpecWith TestParams versionTestMatrix3 runTest = do it "current" $ testChat3 aliceProfile bobProfile cathProfile runTest - it "prev" $ testChatCfg3 testCfgVPrev aliceProfile bobProfile cathProfile runTest + it "prev" $ runTestCfg3 testCfgVPrev testCfgVPrev testCfgVPrev runTest it "prev to curr" $ runTestCfg3 testCfg testCfgVPrev testCfgVPrev runTest it "curr+prev to curr" $ runTestCfg3 testCfg testCfg testCfgVPrev runTest it "curr to prev" $ runTestCfg3 testCfgVPrev testCfg testCfg runTest diff --git a/tests/JSONFixtures.hs b/tests/JSONFixtures.hs index d611df8867..37fab0e4f0 100644 --- a/tests/JSONFixtures.hs +++ b/tests/JSONFixtures.hs @@ -17,10 +17,10 @@ activeUserExistsTagged :: LB.ByteString activeUserExistsTagged = "{\"error\":{\"type\":\"error\",\"errorType\":{\"type\":\"userExists\",\"contactName\":\"alice\"}}}" activeUserSwift :: LB.ByteString -activeUserSwift = "{\"result\":{\"_owsf\":true,\"activeUser\":{\"user\":{\"userId\":1,\"agentUserId\":\"1\",\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"\",\"shortDescr\":\"Alice\",\"localAlias\":\"\"},\"fullPreferences\":{\"timedMessages\":{\"allow\":\"yes\"},\"fullDelete\":{\"allow\":\"no\"},\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"},\"files\":{\"allow\":\"always\"},\"calls\":{\"allow\":\"yes\"},\"sessions\":{\"allow\":\"no\"},\"commands\":[]},\"activeUser\":true,\"activeOrder\":1,\"showNtfs\":true,\"sendRcptsContacts\":true,\"sendRcptsSmallGroups\":true,\"autoAcceptMemberContacts\":false,\"userChatRelay\":false}}}}" +activeUserSwift = "{\"result\":{\"_owsf\":true,\"activeUser\":{\"user\":{\"userId\":1,\"agentUserId\":\"1\",\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"\",\"shortDescr\":\"Alice\",\"localAlias\":\"\"},\"fullPreferences\":{\"timedMessages\":{\"allow\":\"yes\"},\"fullDelete\":{\"allow\":\"no\"},\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"},\"files\":{\"allow\":\"always\"},\"calls\":{\"allow\":\"yes\"},\"sessions\":{\"allow\":\"no\"},\"commands\":[]},\"activeUser\":true,\"activeOrder\":1,\"showNtfs\":true,\"sendRcptsContacts\":true,\"sendRcptsSmallGroups\":true,\"autoAcceptMemberContacts\":false,\"userChatRelay\":false,\"clientService\":false}}}}" activeUserTagged :: LB.ByteString -activeUserTagged = "{\"result\":{\"type\":\"activeUser\",\"user\":{\"userId\":1,\"agentUserId\":\"1\",\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"\",\"shortDescr\":\"Alice\",\"localAlias\":\"\"},\"fullPreferences\":{\"timedMessages\":{\"allow\":\"yes\"},\"fullDelete\":{\"allow\":\"no\"},\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"},\"files\":{\"allow\":\"always\"},\"calls\":{\"allow\":\"yes\"},\"sessions\":{\"allow\":\"no\"},\"commands\":[]},\"activeUser\":true,\"activeOrder\":1,\"showNtfs\":true,\"sendRcptsContacts\":true,\"sendRcptsSmallGroups\":true,\"autoAcceptMemberContacts\":false,\"userChatRelay\":false}}}" +activeUserTagged = "{\"result\":{\"type\":\"activeUser\",\"user\":{\"userId\":1,\"agentUserId\":\"1\",\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"\",\"shortDescr\":\"Alice\",\"localAlias\":\"\"},\"fullPreferences\":{\"timedMessages\":{\"allow\":\"yes\"},\"fullDelete\":{\"allow\":\"no\"},\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"},\"files\":{\"allow\":\"always\"},\"calls\":{\"allow\":\"yes\"},\"sessions\":{\"allow\":\"no\"},\"commands\":[]},\"activeUser\":true,\"activeOrder\":1,\"showNtfs\":true,\"sendRcptsContacts\":true,\"sendRcptsSmallGroups\":true,\"autoAcceptMemberContacts\":false,\"userChatRelay\":false,\"clientService\":false}}}" chatStartedSwift :: LB.ByteString chatStartedSwift = "{\"result\":{\"_owsf\":true,\"chatStarted\":{}}}" diff --git a/tests/MobileTests.hs b/tests/MobileTests.hs index d57411a598..c75bc37166 100644 --- a/tests/MobileTests.hs +++ b/tests/MobileTests.hs @@ -22,6 +22,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BS import Data.ByteString.Internal (create) import qualified Data.ByteString.Lazy.Char8 as LB +import Data.Time.Clock (getCurrentTime) import Data.Word (Word8, Word32) import Foreign.C import Foreign.Marshal.Alloc (mallocBytes) @@ -147,7 +148,8 @@ testChatApi ps = do dbPrefix = tmp "1" Right ChatDatabase {chatStore, agentStore} <- createChatDatabase (ChatDbOpts dbPrefix "myKey" DB.TQOff True) (MigrationConfig MCYesUp Nothing) insertUser agentStore - Right _ <- withTransaction chatStore $ \db -> runExceptT $ createUserRecord db (AgentUserId 1) aliceProfile {preferences = Nothing} False True + ts <- getCurrentTime + Right _ <- withTransaction chatStore $ \db -> runExceptT $ createUserRecordAt db (AgentUserId 1) False False aliceProfile {preferences = Nothing} True ts Right cc <- chatMigrateInit dbPrefix "myKey" "yesUp" Left (DBMErrorNotADatabase _) <- chatMigrateInit dbPrefix "" "yesUp" Left (DBMErrorNotADatabase _) <- chatMigrateInit dbPrefix "anotherKey" "yesUp"