dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-05-25 18:34:24 +00:00
Code Issues Packages Projects Releases Wiki Activity

core: update simplexmq (receiving services) (#6212)

Browse Source 
* 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>
This commit is contained in:
Evgeny
2026-05-25 10:37:13 +01:00
committed by GitHub
parent 0bef18138b
commit fe6b5186e1
40 changed files with 681 additions and 258 deletions
Download Patch File Download Diff File Expand all files Collapse all files
apps/simplex-broadcast-bot/src/Broadcast/Options.hs
+1 -1
View File
@@ -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}
}
apps/simplex-directory-service/src/Directory/Options.hs
+9 -2
View File
@@ -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
bots/api/TYPES.md
+3 -4
View File
@@ -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)?
---
bots/src/API/Docs/Commands.hs
+1
View File
@@ -271,6 +271,7 @@ cliCommands =
"SetAddressSettings",
"SetBotCommands",
"SetChatTTL",
"SetClientService",
"SetContactFeature",
"SetContactTimedMessages",
"SetGroupFeature",
bots/src/API/Docs/Events.hs
+1
View File
@@ -188,6 +188,7 @@ undocumentedEvents =
"CEvtCustomChatEvent",
"CEvtGroupMemberRatchetSync",
"CEvtGroupMemberSwitch",
"CEvtServiceSubStatus",
"CEvtNewRemoteHost",
"CEvtNoMemberContactCreating",
"CEvtNtfMessage",
cabal.project
+1 -1
View File
@@ -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
packages/simplex-chat-client/types/typescript/src/types.ts
+3 -7
View File
@@ -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 {
packages/simplex-chat-python/src/simplex_chat/types/_types.py
+4 -6
View File
@@ -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
plans/cli-paste-slowness.md
+111
View File
@@ -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.
scripts/nix/sha256map.nix
+1 -1
View File
@@ -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";
simplex-chat.cabal
+2
View File
@@ -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:
src/Simplex/Chat.hs
+88 -86
View File
@@ -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
src/Simplex/Chat/Controller.hs
+16 -3
View File
@@ -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)
src/Simplex/Chat/Core.hs
+27 -25
View File
@@ -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
src/Simplex/Chat/Library/Commands.hs
+37 -26
View File
@@ -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
src/Simplex/Chat/Library/Internal.hs
+2 -3
View File
@@ -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
src/Simplex/Chat/Library/Subscriber.hs
+23 -17
View File
@@ -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
src/Simplex/Chat/Mobile.hs
+5 -3
View File
@@ -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)
src/Simplex/Chat/Options.hs
+9 -2
View File
@@ -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
}
src/Simplex/Chat/Remote.hs
+1 -1
View File
@@ -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
src/Simplex/Chat/Store/Postgres/Migrations.hs
+3 -1
View File
@@ -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
src/Simplex/Chat/Store/Postgres/Migrations/M20260520_client_services.hs
+19
View File
@@ -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;
|]
src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql
+2 -1
View File
@@ -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
);
src/Simplex/Chat/Store/Profiles.hs
+17 -9
View File
@@ -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
src/Simplex/Chat/Store/SQLite/Migrations.hs
+3 -1
View File
@@ -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
src/Simplex/Chat/Store/SQLite/Migrations/M20260520_client_services.hs
+18
View File
@@ -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;
|]
src/Simplex/Chat/Store/SQLite/Migrations/agent_query_plans.txt
+94 -7
View File
@@ -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=?)
src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt
+19 -11
View File
@@ -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 (?,?,?,?,?,?)
src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql
+2 -1
View File
@@ -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
src/Simplex/Chat/Store/Shared.hs
+4 -4
View File
@@ -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
src/Simplex/Chat/Terminal.hs
+9 -1
View File
@@ -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
src/Simplex/Chat/Terminal/Input.hs
+7 -7
View File
@@ -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
src/Simplex/Chat/Types.hs
+6 -4
View File
@@ -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)
src/Simplex/Chat/View.hs
+21 -10
View File
@@ -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"]
tests/Bots/DirectoryTests.hs
+1
View File
@@ -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,
tests/ChatClient.hs
+18 -8
View File
@@ -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 <// 100000) $>))
@@ -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_ (<// 100000) tcs
mapConcurrently_ (stopTestChat params) tcs
@@ -535,7 +545,7 @@ smpServerCfg =
maxJournalStateLines = 4,
queueIdBytes = 24,
msgIdBytes = 6,
serverStoreCfg = SSCMemory Nothing,
serverStoreCfg = SSCMemory Nothing, -- $ Just StorePaths {storeLogFile = "tmp/smp-server-store.log", storeMsgsFile = Just "tmp/smp-server-messages.log"},
storeNtfsFile = Nothing,
allowNewQueues = True,
-- server password is disabled as otherwise v1 tests fail
tests/ChatTests/Profiles.hs
+83
View File
@@ -110,6 +110,9 @@ chatProfileTests = do
it "should connect via contact address" testShortLinkContactAddress
it "should join group" testShortLinkJoinGroup
describe "short links with attached data" shortLinkTests
describe "client services" $ do
it "should create user as a service, disable and re-enable" testClientService
it "should create user without a service, enable and disable" testSwitchClientService
shortLinkTests :: SpecWith TestParams
shortLinkTests = do
@@ -4137,3 +4140,83 @@ testShortLinkGroupChangeProfileReceived = testChat3 aliceProfile bobProfile cath
[alice, cath] *<# "#club bob> 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"
]
tests/ChatTests/Utils.hs
+5 -2
View File
@@ -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
tests/JSONFixtures.hs
+2 -2
View File
@@ -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\":{}}}"
tests/MobileTests.hs
+3 -1
View File
@@ -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"