mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2024-12-17 17:20:21 +01:00
Compare commits
36 Commits
| Author | SHA1 | Date | |
|---|---|---|---|
| f856bb5faf | |||
| 41e6e6b54e | |||
| 1af513c548 | |||
| 137656f13f | |||
| 5c44f0e17e | |||
| baced8a6da | |||
| 6548245883 | |||
| 63026acf46 | |||
| 900aad60e9 | |||
| e5e231fe9e | |||
| eb11e6c409 | |||
| e045aa214d | |||
| 6311a581cf | |||
| 370936aaa1 | |||
| 7b108536fd | |||
| 13d779f41d | |||
| ed12f34330 | |||
| ddd9c6f16f | |||
| 561c923cdb | |||
| a126215c8c | |||
| f21b5af568 | |||
| 73bd003984 | |||
| 4d2452b03f | |||
| 4ceb0dc564 | |||
| 551a34dd1a | |||
| 30f00c2f2e | |||
| b94ced6b39 | |||
| a1216d86fd | |||
| b6cf81e680 | |||
| 998907f107 | |||
| a975ffe82a | |||
| a1d2f4cda9 | |||
| cd3992fd0f | |||
| 1bc47c6910 | |||
| ab07096235 | |||
| 1295e538ed |
@@ -17,18 +17,23 @@ SimpleX Chat Protocol is a protocol used by SimpleX Chat clients to exchange mes
|
||||
The scope of SimpleX Chat Protocol is application level messages, both for chat functionality, related to the conversations between the clients, and extensible for any other application functions. Currently supported chat functions:
|
||||
|
||||
- direct and group messages,
|
||||
- message replies (quoting), forwarded messages and message deletions,
|
||||
- message attachments: images and files,
|
||||
- message replies (quoting), message editing, forwarded messages and message deletions,
|
||||
- message attachments: images, videos, voice messages and files,
|
||||
- creating and managing chat groups,
|
||||
- invitation and signalling for audio/video WebRTC calls.
|
||||
|
||||
## General message format
|
||||
|
||||
SimpleX Chat protocol supports two message formats:
|
||||
SimpleX Chat protocol supports these message formats:
|
||||
|
||||
- JSON-based format for chat and application messages.
|
||||
- compressed format for adapting larger messages to reduced size of message envelope, caused by addition of PQ encryption keys to SMP agent message envelope.
|
||||
- binary format for sending files or any other binary data.
|
||||
|
||||
JSON-based message format supports batching inside a single container message, by encoding list of messages as JSON array.
|
||||
|
||||
Current implementation of chat protocol in SimpleX Chat uses SimpleX File Transfer Protocol (XFTP) for file transfer, with passing file description as chat protocol messages, instead passing files in binary format via SMP connections.
|
||||
|
||||
### JSON format for chat and application messages
|
||||
|
||||
This document uses JTD schemas [RFC 8927](https://www.rfc-editor.org/rfc/rfc8927.html) to define the properties of chat messages, with some additional restrictions on message properties included in metadata member of JTD schemas. In case of any contradiction between JSON examples and JTD schema the latter MUST be considered correct.
|
||||
@@ -77,8 +82,22 @@ For example, this message defines a simple text message `"hello!"`:
|
||||
|
||||
`params` property includes message data, depending on `event`, as defined below and in [JTD schema](./simplex-chat.schema.json).
|
||||
|
||||
### Compressed format
|
||||
|
||||
The syntax of compressed message is defined by the following ABNF notation:
|
||||
|
||||
```abnf
|
||||
compressedMessage = %s"X" 1*15780 OCTET; compressed message data
|
||||
```
|
||||
|
||||
Compressed message is required to fit into 13388 bytes, accounting for agent overhead (see Protocol's maxCompressedMsgLength).
|
||||
|
||||
The actual JSON message is required to fit into 15610 bytes, accounting for group message forwarding (x.grp.msg.forward) overhead (see Protocol's maxEncodedMsgLength).
|
||||
|
||||
### Binary format for sending files
|
||||
|
||||
> Note: Planned to be deprecated. No longer used for file transfer in SimpleX Chat implementation of chat protocol.
|
||||
|
||||
SimpleX Chat clients use separate connections to send files using a binary format. File chunk size send in each message MUST NOT be bigger than 15,780 bytes to fit into 16kb (16384 bytes) transport block.
|
||||
|
||||
The syntax of each message used to send files is defined by the following ABNF notation:
|
||||
@@ -117,7 +136,9 @@ SimpleX Chat Protocol supports the following message types passed in `event` pro
|
||||
- `x.contact` - contact profile and additional data sent as part of contact request to a long-term contact address.
|
||||
- `x.info*` - messages to send, update and de-duplicate contact profiles.
|
||||
- `x.msg.*` - messages to create, update and delete content chat items.
|
||||
- `x.msg.file.descr` - message to transfer XFTP file description.
|
||||
- `x.file.*` - messages to accept and cancel sending files (see files sub-protocol).
|
||||
- `x.direct.del` - message to notify about contact deletion.
|
||||
- `x.grp.*` - messages used to manage groups and group members (see group sub-protocol).
|
||||
- `x.call.*` - messages to invite to WebRTC calls and send signalling messages.
|
||||
- `x.ok` - message sent during connection handshake.
|
||||
@@ -155,6 +176,8 @@ Message content can be one of four types:
|
||||
- `text` - no file attachment is expected for this format, `text` property MUST be non-empty.
|
||||
- `file` - attached file is required, `text` property MAY be empty.
|
||||
- `image` - attached file is required, `text` property MAY be empty.
|
||||
- `video` - attached file is required, `text` property MAY be empty.
|
||||
- `voice` - attached file is required, `text` property MAY be empty.
|
||||
- `link` - no file attachment is expected, `text` property MUST be non-empty. `preview` property contains information about link preview.
|
||||
|
||||
See `/definition/msgContent` in [JTD schema](./simplex-chat.schema.json) for message container format.
|
||||
@@ -181,6 +204,8 @@ File attachment can optionally include connection address to receive the file -
|
||||
|
||||
`x.file.cancel` message is sent to notify the recipient that sending of the file was cancelled. It is sent in response to accepting the file with `x.file.acpt.inv` message. It is sent in the same connection where the file was offered.
|
||||
|
||||
`x.msg.file.descr` message is used to send XFTP file description. File descriptions that don't fit into a single chat protocol message are sent in parts, with messages including part number (`fileDescrPartNo`) and description completion marker (`fileDescrComplete`). Recipient client accumulates description parts and starts file download upon completing file description.
|
||||
|
||||
## Sub-protocol for chat groups
|
||||
|
||||
### Decentralized design for chat groups
|
||||
@@ -197,6 +222,8 @@ The diagram below shows the sequence of messages sent between the users' clients
|
||||
|
||||

|
||||
|
||||
While introduced members establish connection inside group, inviting member forwards messages between them by sending `x.grp.msg.forward` messages. When introduced members finalize connection, they notify inviting member to stop forwarding via `x.grp.mem.con` message.
|
||||
|
||||
### Member roles
|
||||
|
||||
Currently members can have one of three roles - `owner`, `admin` and `member`. The user that created the group is self-assigned owner role, the new members are assigned role by the member who adds them - only `owner` and `admin` members can add new members; only `owner` members can add members with `owner` role.
|
||||
@@ -207,6 +234,10 @@ Currently members can have one of three roles - `owner`, `admin` and `member`. T
|
||||
|
||||
`x.grp.acpt` message is sent as part of group member connection handshake, only to the inviting user.
|
||||
|
||||
`x.grp.link.inv` message is sent as part of connection handshake to member joining via group link, and contains group profile and initial information about inviting and joining member.
|
||||
|
||||
`x.grp.link.mem` message is sent as part of connection handshake to member joining via group link, and contains remaining information about inviting member.
|
||||
|
||||
`x.grp.mem.new` message is sent by the inviting user to all connected members (and scheduled as pending to all announced but not yet connected members) to announce a new member to the existing members. This message MUST only be sent by members with `admin` or `owner` role. Receiving clients MUST ignore this message if it is received from member with `member` role.
|
||||
|
||||
`x.grp.mem.intro` messages are sent by the inviting user to the invited member, via their group member connection, one message for each existing member. When this message is sent by any other member than the one who invited the recipient it MUST be ignored.
|
||||
@@ -219,6 +250,10 @@ Currently members can have one of three roles - `owner`, `admin` and `member`. T
|
||||
|
||||
`x.grp.mem.role` message is sent to update group member role - it is sent to all members by the member who updated the role of the member referenced in this message. This message MUST only be sent by members with `admin` or `owner` role. Receiving clients MUST ignore this message if it is received from member with role less than `admin`.
|
||||
|
||||
`x.grp.mem.restrict` message is sent to group members to communicate group member restrictions, such as member being blocked for sending messages.
|
||||
|
||||
`x.grp.mem.con` message is sent by members connecting inside group to inviting member, to notify the inviting member they have completed the connection and no longer require forwarding messages between them.
|
||||
|
||||
`x.grp.mem.del` message is sent to delete a member - it is sent to all members by the member who deletes the member referenced in this message. This message MUST only be sent by members with `admin` or `owner` role. Receiving clients MUST ignore this message if it is received from member with `member` role.
|
||||
|
||||
`x.grp.leave` message is sent to all members by the member leaving the group. If the only group `owner` leaves the group, it will not be possible to delete it with `x.grp.del` message - but all members can still leave the group with `x.grp.leave` message and then delete a local copy of the group.
|
||||
@@ -227,6 +262,10 @@ Currently members can have one of three roles - `owner`, `admin` and `member`. T
|
||||
|
||||
`x.grp.info` message is sent to all members by the member who updated group profile. Only group owners can update group profiles. Clients MAY implement some conflict resolution strategy - it is currently not implemented by SimpleX Chat client. This message MUST only be sent by members with `owner` role. Receiving clients MUST ignore this message if it is received from member other than with `owner` role.
|
||||
|
||||
`x.grp.direct.inv` message is sent to a group member to propose establishing a direct connection between members, thus creating a contact with another member.
|
||||
|
||||
`x.grp.msg.forward` message is sent by inviting member to forward messages between introduced members, while they are connecting.
|
||||
|
||||
## Sub-protocol for WebRTC audio/video calls
|
||||
|
||||
This sub-protocol is used to send call invitations and to negotiate end-to-end encryption keys and pass WebRTC signalling information.
|
||||
|
||||
@@ -0,0 +1,43 @@
|
||||
# Optimized subscription
|
||||
|
||||
## Problem
|
||||
|
||||
The `subscribeUserConnections` function has a few problems that affect UX on app start:
|
||||
|
||||
1. It loads entity data that isn't used until result processing. This produces a memory spike and takes CPU time to parse all the data.
|
||||
2. Subscription results are processed synchronously after the agent finishes all the batches for user. The app wouldn't see connections as active until the slowest server responds or timeouts.
|
||||
3. User subscriptions are processed sequentially. A currently active user is given a first round of subs, but the remaining are blocked. If a user profile is switched right away, the new user may start receiving updates with even more lag.
|
||||
|
||||
## Solution
|
||||
|
||||
Functions that fetch connections and entities are reduced to return only connection IDs. The filters should be moved from Haskell into specialized SQL queries that only return `[ConnId]`.
|
||||
|
||||
With the connection list on hands the agent subscriber thread forks off to do its thing and process batch results. This allows outer loop to start collecting connections for the remaining users.
|
||||
|
||||
Successful results are communicated with a new `UP srv conns` message emitted from agent when a batch finishes its processing. The `conns` payload would be a list of connections that actually have just switched subs from "pending" to "active". The UP handling machinery processes status updates just as it would in a server reconnect event. This would update connection state in chat apps as soon as the server responds, keeping app and core in tighter sync.
|
||||
|
||||
`reconnectSMPClient` should stop sending UPs to prevent double processing of the same result. The `okConns` membership test it currently uses is the same "did not belong to an active connection" that the batch result would use.
|
||||
|
||||
Sending results with UP allows to reduce summary responses to a bunch of counters so no entity data would be needed for CLI here:
|
||||
|
||||
```haskell
|
||||
| CRContactSubSummary {user :: User, okSubs :: Int, errSubs :: Int}
|
||||
| CRUserGroupLinksSubSummary {user :: User, okSubs :: Int, errSubs :: Int}
|
||||
| CRMemberSubSummary {user :: User, okSubs :: Int, errSubs :: Int}
|
||||
| CRPendingSubSummary {user :: User, okSubs :: Int, errSubs :: Int}
|
||||
```
|
||||
|
||||
Subscription errors are reported to API as `CRNetworkStatuses` as ususal, but the active subs are removed from the list as they are already handled by `UP`.
|
||||
|
||||
Subscription errors for CLI (when connection error reporting is enabled) are reported with the types reduced to a textual name:
|
||||
|
||||
```haskell
|
||||
| CRContactSubError {user :: User, contactName :: ContactName, chatError :: ChatError}
|
||||
| CRMemberSubError {user :: User, groupName :: GroupName, contactName :: ContactName, chatError :: ChatError}
|
||||
| CRSndFileSubError {user :: User, sndFileTransfer :: Text, chatError :: ChatError}
|
||||
| CRRcvFileSubError {user :: User, rcvFileTransfer :: Text, chatError :: ChatError}
|
||||
```
|
||||
|
||||
> A generic constructor could be used instead, but then it would contain extra fields to form a message in View if matching the current output is desired.
|
||||
|
||||
The textual names for connections can be requested for the subset of all connections that needs them with the same procedure that's used in `UP` handling.
|
||||
@@ -146,6 +146,7 @@ library
|
||||
Simplex.Chat.Migrations.M20240510_chat_items_via_proxy
|
||||
Simplex.Chat.Migrations.M20240515_rcv_files_user_approved_relays
|
||||
Simplex.Chat.Migrations.M20240528_quota_err_counter
|
||||
Simplex.Chat.Migrations.M20240530_user_contact_links_user_id
|
||||
Simplex.Chat.Mobile
|
||||
Simplex.Chat.Mobile.File
|
||||
Simplex.Chat.Mobile.Shared
|
||||
|
||||
+92
-119
@@ -3400,71 +3400,55 @@ subscribeUserConnections :: VersionRangeChat -> Bool -> AgentBatchSubscribe -> U
|
||||
subscribeUserConnections vr onlyNeeded agentBatchSubscribe user = do
|
||||
-- get user connections
|
||||
ce <- asks $ subscriptionEvents . config
|
||||
(conns, cts, ucs, gs, ms, sfts, rfts, pcs) <-
|
||||
(conns, ctConns, ucs, gs, mConns, sfts, rfts, pcConns) <-
|
||||
if onlyNeeded
|
||||
then do
|
||||
(conns, entities) <- withStore' (`getConnectionsToSubscribe` vr)
|
||||
let (cts, ucs, ms, sfts, rfts, pcs) = foldl' addEntity (M.empty, M.empty, M.empty, M.empty, M.empty, M.empty) entities
|
||||
(conns, entities) <- withStore' $ \db -> getConnectionsToSubscribe db vr user
|
||||
let (cts, ucs, ms, sfts, rfts, pcs) = foldl' addEntity ([], [], [], M.empty, M.empty, []) entities
|
||||
pure (conns, cts, ucs, [], ms, sfts, rfts, pcs)
|
||||
else do
|
||||
withStore' unsetConnectionToSubscribe
|
||||
(ctConns, cts) <- getContactConns
|
||||
withStore' (`unsetConnectionToSubscribe` user)
|
||||
ctConns <- getContactConns
|
||||
(ucConns, ucs) <- getUserContactLinkConns
|
||||
(gs, mConns, ms) <- getGroupMemberConns
|
||||
(gs, mConns) <- getGroupMemberConns
|
||||
(sftConns, sfts) <- getSndFileTransferConns
|
||||
(rftConns, rfts) <- getRcvFileTransferConns
|
||||
(pcConns, pcs) <- getPendingContactConns
|
||||
pcConns <- getPendingContactConns
|
||||
let conns = concat [ctConns, ucConns, mConns, sftConns, rftConns, pcConns]
|
||||
pure (conns, cts, ucs, gs, ms, sfts, rfts, pcs)
|
||||
-- subscribe using batched commands
|
||||
rs <- withAgent $ \a -> agentBatchSubscribe a conns
|
||||
-- send connection events to view
|
||||
contactSubsToView rs cts ce
|
||||
-- TODO possibly, we could either disable these events or replace with less noisy for API
|
||||
contactLinkSubsToView rs ucs
|
||||
groupSubsToView rs gs ms ce
|
||||
sndFileSubsToView rs sfts
|
||||
rcvFileSubsToView rs rfts
|
||||
pendingConnSubsToView rs pcs
|
||||
pure (conns, ctConns, ucs, gs, mConns, sfts, rfts, pcConns)
|
||||
-- detach subscription and result processing
|
||||
void . lift . forkIO . runSubscriber $ do
|
||||
-- subscribe using batched commands
|
||||
rs <- withAgent $ \a -> agentBatchSubscribe a conns
|
||||
let (errs, _oks) = M.mapEither id rs
|
||||
refs <- if ce then withStore' $ \db -> getConnectionsContacts db (M.keys errs) else pure []
|
||||
let connRefs = M.fromList $ map (\ContactRef {agentConnId = AgentConnId acId, localDisplayName} -> (acId, localDisplayName)) refs
|
||||
contactSubsToView errs ctConns connRefs ce
|
||||
contactLinkSubsToView errs ucs
|
||||
groupSubsToView errs gs mConns connRefs ce
|
||||
sndFileSubsToView errs sfts
|
||||
rcvFileSubsToView errs rfts
|
||||
pendingConnSubsToView errs pcConns
|
||||
where
|
||||
runSubscriber :: CM () -> CM' ()
|
||||
runSubscriber action = tryAllErrors' mkChatError action >>= either (logError . tshow) pure
|
||||
addEntity (cts, ucs, ms, sfts, rfts, pcs) = \case
|
||||
RcvDirectMsgConnection c (Just ct) -> let cts' = addConn c ct cts in (cts', ucs, ms, sfts, rfts, pcs)
|
||||
RcvDirectMsgConnection c Nothing -> let pcs' = addConn c (toPCC c) pcs in (cts, ucs, ms, sfts, rfts, pcs')
|
||||
RcvGroupMsgConnection c _g m -> let ms' = addConn c m ms in (cts, ucs, ms', sfts, rfts, pcs)
|
||||
SndFileConnection c sft -> let sfts' = addConn c sft sfts in (cts, ucs, ms, sfts', rfts, pcs)
|
||||
RcvFileConnection c rft -> let rfts' = addConn c rft rfts in (cts, ucs, ms, sfts, rfts', pcs)
|
||||
UserContactConnection c uc -> let ucs' = addConn c uc ucs in (cts, ucs', ms, sfts, rfts, pcs)
|
||||
addConn :: Connection -> a -> Map ConnId a -> Map ConnId a
|
||||
addConn = M.insert . aConnId
|
||||
toPCC Connection {connId, agentConnId, connStatus, viaUserContactLink, groupLinkId, customUserProfileId, localAlias, createdAt} =
|
||||
PendingContactConnection
|
||||
{ pccConnId = connId,
|
||||
pccAgentConnId = agentConnId,
|
||||
pccConnStatus = connStatus,
|
||||
viaContactUri = False,
|
||||
viaUserContactLink,
|
||||
groupLinkId,
|
||||
customUserProfileId,
|
||||
connReqInv = Nothing,
|
||||
localAlias,
|
||||
createdAt,
|
||||
updatedAt = createdAt
|
||||
}
|
||||
getContactConns :: CM ([ConnId], Map ConnId Contact)
|
||||
getContactConns = do
|
||||
cts <- withStore_ (`getUserContacts` vr)
|
||||
let cts' = mapMaybe (\ct -> (,ct) <$> contactConnId ct) $ filter contactActive cts
|
||||
pure (map fst cts', M.fromList cts')
|
||||
getUserContactLinkConns :: CM ([ConnId], Map ConnId UserContact)
|
||||
RcvDirectMsgConnection c (Just _ct) -> let cts' = aConnId c : cts in (cts', ucs, ms, sfts, rfts, pcs)
|
||||
RcvDirectMsgConnection c Nothing -> let pcs' = aConnId c : pcs in (cts, ucs, ms, sfts, rfts, pcs')
|
||||
RcvGroupMsgConnection c _g _m -> let ms' = aConnId c : ms in (cts, ucs, ms', sfts, rfts, pcs)
|
||||
SndFileConnection c sft -> let sfts' = M.insert (aConnId c) sft sfts in (cts, ucs, ms, sfts', rfts, pcs)
|
||||
RcvFileConnection c rft -> let rfts' = M.insert (aConnId c) rft rfts in (cts, ucs, ms, sfts, rfts', pcs)
|
||||
UserContactConnection c uc -> let ucs' = (aConnId c, isNothing $ userContactGroupId uc) : ucs in (cts, ucs', ms, sfts, rfts, pcs)
|
||||
getContactConns :: CM [ConnId]
|
||||
getContactConns = withStore_ getUserContactConnIds
|
||||
getUserContactLinkConns :: CM ([ConnId], [(ConnId, Bool)])
|
||||
getUserContactLinkConns = do
|
||||
(cs, ucs) <- unzip <$> withStore_ (`getUserContactLinks` vr)
|
||||
let connIds = map aConnId cs
|
||||
pure (connIds, M.fromList $ zip connIds ucs)
|
||||
getGroupMemberConns :: CM ([Group], [ConnId], Map ConnId GroupMember)
|
||||
ucs <- withStore_ getUserContactLinks
|
||||
pure (map fst ucs, ucs)
|
||||
getGroupMemberConns :: CM ([(GroupInfo, [ConnId])], [ConnId])
|
||||
getGroupMemberConns = do
|
||||
gs <- withStore_ (`getUserGroups` vr)
|
||||
let mPairs = concatMap (\(Group _ ms) -> mapMaybe (\m -> (,m) <$> memberConnId m) (filter (not . memberRemoved) ms)) gs
|
||||
pure (gs, map fst mPairs, M.fromList mPairs)
|
||||
gs <- withStore_ (`getUserGroupMemberConnIds` vr)
|
||||
pure (gs, concatMap snd gs)
|
||||
getSndFileTransferConns :: CM ([ConnId], Map ConnId SndFileTransfer)
|
||||
getSndFileTransferConns = do
|
||||
sfts <- withStore_ getLiveSndFileTransfers
|
||||
@@ -3475,92 +3459,81 @@ subscribeUserConnections vr onlyNeeded agentBatchSubscribe user = do
|
||||
rfts <- withStore_ getLiveRcvFileTransfers
|
||||
let rftPairs = mapMaybe (\ft -> (,ft) <$> liveRcvFileTransferConnId ft) rfts
|
||||
pure (map fst rftPairs, M.fromList rftPairs)
|
||||
getPendingContactConns :: CM ([ConnId], Map ConnId PendingContactConnection)
|
||||
getPendingContactConns = do
|
||||
pcs <- withStore_ getPendingContactConnections
|
||||
let connIds = map aConnId' pcs
|
||||
pure (connIds, M.fromList $ zip connIds pcs)
|
||||
contactSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId Contact -> Bool -> CM ()
|
||||
contactSubsToView rs cts ce = do
|
||||
chatModifyVar connNetworkStatuses $ M.union (M.fromList statuses)
|
||||
ifM (asks $ coreApi . config) (notifyAPI statuses) notifyCLI
|
||||
getPendingContactConns :: CM [ConnId]
|
||||
getPendingContactConns = withStore_ getPendingContactConnections
|
||||
contactSubsToView :: Map ConnId AgentErrorType -> [ConnId] -> Map ConnId ContactName -> Bool -> CM ()
|
||||
contactSubsToView errs cts names ce = ifM (asks $ coreApi . config) notifyAPI notifyCLI
|
||||
where
|
||||
conns = S.fromList cts
|
||||
errConns = M.restrictKeys errs conns
|
||||
notifyCLI = do
|
||||
let cRs = resultsFor rs cts
|
||||
cErrors = sortOn (\(Contact {localDisplayName = n}, _) -> n) $ filterErrors cRs
|
||||
toView . CRContactSubSummary user $ map (uncurry ContactSubStatus) cRs
|
||||
when ce $ mapM_ (toView . uncurry (CRContactSubError user)) cErrors
|
||||
notifyAPI = toView . CRNetworkStatuses (Just user) . map (uncurry ConnNetworkStatus)
|
||||
statuses = M.foldrWithKey' addStatus [] cts
|
||||
toView CRContactSubSummary {user, okSubs = S.size conns - M.size errConns, errSubs = M.size errConns}
|
||||
when ce $ forM_ (M.assocs errConns) $ \(acId, err) ->
|
||||
forM_ (M.lookup acId names) $ \contactName ->
|
||||
toView CRContactSubError {user, contactName, chatError = ChatErrorAgent err Nothing}
|
||||
notifyAPI = unless (M.null errConns) $ toView $ CRNetworkStatuses (Just user) $ map status (M.assocs errConns)
|
||||
where
|
||||
addStatus :: ConnId -> Contact -> [(AgentConnId, NetworkStatus)] -> [(AgentConnId, NetworkStatus)]
|
||||
addStatus _ Contact {activeConn = Nothing} nss = nss
|
||||
addStatus connId Contact {activeConn = Just Connection {agentConnId}} nss =
|
||||
let ns = (agentConnId, netStatus $ resultErr connId rs)
|
||||
in ns : nss
|
||||
netStatus :: Maybe ChatError -> NetworkStatus
|
||||
netStatus = maybe NSConnected $ NSError . errorNetworkStatus
|
||||
errorNetworkStatus :: ChatError -> String
|
||||
status (connId, err) = ConnNetworkStatus (AgentConnId connId) $ NSError (errorNetworkStatus err)
|
||||
errorNetworkStatus :: AgentErrorType -> String
|
||||
errorNetworkStatus = \case
|
||||
ChatErrorAgent (BROKER _ NETWORK) _ -> "network"
|
||||
ChatErrorAgent (SMP _ SMP.AUTH) _ -> "contact deleted"
|
||||
BROKER _ NETWORK -> "network"
|
||||
SMP _ SMP.AUTH -> "contact deleted"
|
||||
e -> show e
|
||||
-- TODO possibly below could be replaced with less noisy events for API
|
||||
contactLinkSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId UserContact -> CM ()
|
||||
contactLinkSubsToView rs = toView . CRUserContactSubSummary user . map (uncurry UserContactSubStatus) . resultsFor rs
|
||||
groupSubsToView :: Map ConnId (Either AgentErrorType ()) -> [Group] -> Map ConnId GroupMember -> Bool -> CM ()
|
||||
groupSubsToView rs gs ms ce = do
|
||||
mapM_ groupSub $
|
||||
sortOn (\(Group GroupInfo {localDisplayName = g} _) -> g) gs
|
||||
toView . CRMemberSubSummary user $ map (uncurry MemberSubStatus) mRs
|
||||
contactLinkSubsToView :: Map ConnId AgentErrorType -> [(ConnId, Bool)] -> CM ()
|
||||
contactLinkSubsToView errs ucs = do
|
||||
let (addresses, groupLinks) = partition snd ucs
|
||||
forM_ addresses $ \(acId, _uc) -> toView $ CRUserAddrSubStatus {user, userContactError = (`ChatErrorAgent` Nothing) <$> M.lookup acId errs}
|
||||
let groups = S.fromList $ map fst groupLinks
|
||||
errGroups = M.restrictKeys errs groups
|
||||
unless (S.null groups) $ toView CRUserGroupLinksSubSummary
|
||||
{ user,
|
||||
okSubs = S.size groups - M.size errGroups,
|
||||
errSubs = M.size errGroups
|
||||
}
|
||||
groupSubsToView :: Map ConnId AgentErrorType -> [(GroupInfo, [ConnId])] -> [ConnId] -> Map ConnId ContactName -> Bool -> CM ()
|
||||
groupSubsToView errs gs allMembers names ce = do
|
||||
mapM_ (uncurry groupSub) gs
|
||||
toView CRMemberSubSummary {user, okSubs = S.size conns - M.size errConns, errSubs = M.size errConns}
|
||||
where
|
||||
mRs = resultsFor rs ms
|
||||
groupSub :: Group -> CM ()
|
||||
groupSub (Group g@GroupInfo {membership, groupId = gId} members) = do
|
||||
when ce $ mapM_ (toView . uncurry (CRMemberSubError user g)) mErrors
|
||||
conns = S.fromList allMembers
|
||||
errConns = M.restrictKeys errs conns
|
||||
groupSub :: GroupInfo -> [ConnId] -> CM ()
|
||||
groupSub g@GroupInfo {membership} groupMembers = do
|
||||
when ce $ mapM_ (toView . uncurry (CRMemberSubError user g) ) mErrors
|
||||
toView groupEvent
|
||||
where
|
||||
mErrors :: [(GroupMember, ChatError)]
|
||||
mErrors =
|
||||
sortOn (\(GroupMember {localDisplayName = n}, _) -> n)
|
||||
. filterErrors
|
||||
$ filter (\(GroupMember {groupId}, _) -> groupId == gId) mRs
|
||||
mErrors :: [(ContactName, ChatError)]
|
||||
mErrors = sortOn fst $ mapMaybe mError groupMembers
|
||||
mError :: ConnId -> Maybe (ContactName, ChatError)
|
||||
mError mConnId = do
|
||||
mErr <- M.lookup mConnId errConns
|
||||
name <- M.lookup mConnId names
|
||||
Just (name, ChatErrorAgent mErr Nothing)
|
||||
groupEvent :: ChatResponse
|
||||
groupEvent
|
||||
| memberStatus membership == GSMemInvited = CRGroupInvitation user g
|
||||
| all (\GroupMember {activeConn} -> isNothing activeConn) members =
|
||||
| null groupMembers =
|
||||
if memberActive membership
|
||||
then CRGroupEmpty user g
|
||||
else CRGroupRemoved user g
|
||||
| otherwise = CRGroupSubscribed user g
|
||||
sndFileSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId SndFileTransfer -> CM ()
|
||||
sndFileSubsToView rs sfts = do
|
||||
let sftRs = resultsFor rs sfts
|
||||
forM_ sftRs $ \(ft@SndFileTransfer {fileId, fileStatus}, err_) -> do
|
||||
forM_ err_ $ toView . CRSndFileSubError user ft
|
||||
sndFileSubsToView :: Map ConnId AgentErrorType -> Map ConnId SndFileTransfer -> CM ()
|
||||
sndFileSubsToView errs sfts =
|
||||
forM_ (M.assocs sfts) $ \(acId, ft@SndFileTransfer {fileId, fileStatus}) -> do
|
||||
forM_ (M.lookup acId errs) $ toView . CRSndFileSubError user ft . (`ChatErrorAgent` Nothing)
|
||||
void . forkIO $ do
|
||||
threadDelay 1000000
|
||||
when (fileStatus == FSConnected) . unlessM (isFileActive fileId sndFiles) . withChatLock "subscribe sendFileChunk" $
|
||||
sendFileChunk user ft
|
||||
rcvFileSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId RcvFileTransfer -> CM ()
|
||||
rcvFileSubsToView rs = mapM_ (toView . uncurry (CRRcvFileSubError user)) . filterErrors . resultsFor rs
|
||||
pendingConnSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId PendingContactConnection -> CM ()
|
||||
pendingConnSubsToView rs = toView . CRPendingSubSummary user . map (uncurry PendingSubStatus) . resultsFor rs
|
||||
rcvFileSubsToView :: Map ConnId AgentErrorType -> Map ConnId RcvFileTransfer -> CM ()
|
||||
rcvFileSubsToView errs = mapM_ (toView . uncurry (CRRcvFileSubError user)) . M.mapMaybeWithKey (\acId rft -> (\e -> (rft, ChatErrorAgent e Nothing)) <$> M.lookup acId errs)
|
||||
pendingConnSubsToView :: Map ConnId AgentErrorType -> [ConnId] -> CM () -- XXX: ignored by View
|
||||
pendingConnSubsToView errs pcs = toView CRPendingSubSummary {user, okSubs = S.size conns - M.size errConns, errSubs = M.size errConns}
|
||||
where
|
||||
conns = S.fromList pcs
|
||||
errConns = M.restrictKeys errs conns
|
||||
withStore_ :: (DB.Connection -> User -> IO [a]) -> CM [a]
|
||||
withStore_ a = withStore' (`a` user) `catchChatError` \e -> toView (CRChatError (Just user) e) $> []
|
||||
filterErrors :: [(a, Maybe ChatError)] -> [(a, ChatError)]
|
||||
filterErrors = mapMaybe (\(a, e_) -> (a,) <$> e_)
|
||||
resultsFor :: Map ConnId (Either AgentErrorType ()) -> Map ConnId a -> [(a, Maybe ChatError)]
|
||||
resultsFor rs = M.foldrWithKey' addResult []
|
||||
where
|
||||
addResult :: ConnId -> a -> [(a, Maybe ChatError)] -> [(a, Maybe ChatError)]
|
||||
addResult connId = (:) . (,resultErr connId rs)
|
||||
resultErr :: ConnId -> Map ConnId (Either AgentErrorType ()) -> Maybe ChatError
|
||||
resultErr connId rs = case M.lookup connId rs of
|
||||
Just (Left e) -> Just $ ChatErrorAgent e Nothing
|
||||
Just _ -> Nothing
|
||||
_ -> Just . ChatError . CEAgentNoSubResult $ AgentConnId connId
|
||||
|
||||
cleanupManager :: CM ()
|
||||
cleanupManager = do
|
||||
interval <- asks (cleanupManagerInterval . config)
|
||||
@@ -3746,7 +3719,7 @@ processAgentMessageNoConn = \case
|
||||
where
|
||||
connIds = map AgentConnId conns
|
||||
notifyAPI = toView . CRNetworkStatus nsStatus
|
||||
notifyCLI = do
|
||||
notifyCLI = whenM (asks $ subscriptionEvents . config) $ do
|
||||
cs <- withStore' (`getConnectionsContacts` conns)
|
||||
toView $ event srv cs
|
||||
|
||||
|
||||
@@ -680,9 +680,10 @@ data ChatResponse
|
||||
| CRSubscriptionEnd {user :: User, connectionEntity :: ConnectionEntity}
|
||||
| CRContactsDisconnected {server :: SMPServer, contactRefs :: [ContactRef]}
|
||||
| CRContactsSubscribed {server :: SMPServer, contactRefs :: [ContactRef]}
|
||||
| CRContactSubError {user :: User, contact :: Contact, chatError :: ChatError}
|
||||
| CRContactSubSummary {user :: User, contactSubscriptions :: [ContactSubStatus]}
|
||||
| CRUserContactSubSummary {user :: User, userContactSubscriptions :: [UserContactSubStatus]}
|
||||
| CRContactSubSummary {user :: User, okSubs :: Int, errSubs :: Int}
|
||||
| CRContactSubError {user :: User, contactName :: ContactName, chatError :: ChatError}
|
||||
| CRUserAddrSubStatus {user :: User, userContactError :: Maybe ChatError}
|
||||
| CRUserGroupLinksSubSummary {user :: User, okSubs :: Int, errSubs :: Int}
|
||||
| CRNetworkStatus {networkStatus :: NetworkStatus, connections :: [AgentConnId]}
|
||||
| CRNetworkStatuses {user_ :: Maybe User, networkStatuses :: [ConnNetworkStatus]}
|
||||
| CRHostConnected {protocol :: AProtocolType, transportHost :: TransportHost}
|
||||
@@ -719,10 +720,10 @@ data ChatResponse
|
||||
| CRNewMemberContactSentInv {user :: User, contact :: Contact, groupInfo :: GroupInfo, member :: GroupMember}
|
||||
| CRNewMemberContactReceivedInv {user :: User, contact :: Contact, groupInfo :: GroupInfo, member :: GroupMember}
|
||||
| CRContactAndMemberAssociated {user :: User, contact :: Contact, groupInfo :: GroupInfo, member :: GroupMember, updatedContact :: Contact}
|
||||
| CRMemberSubError {user :: User, groupInfo :: GroupInfo, member :: GroupMember, chatError :: ChatError}
|
||||
| CRMemberSubSummary {user :: User, memberSubscriptions :: [MemberSubStatus]}
|
||||
| CRMemberSubError {user :: User, groupInfo :: GroupInfo, contactName :: ContactName, chatError :: ChatError}
|
||||
| CRMemberSubSummary {user :: User, okSubs :: Int, errSubs :: Int}
|
||||
| CRGroupSubscribed {user :: User, groupInfo :: GroupInfo}
|
||||
| CRPendingSubSummary {user :: User, pendingSubscriptions :: [PendingSubStatus]}
|
||||
| CRPendingSubSummary {user :: User, okSubs :: Int, errSubs :: Int}
|
||||
| CRSndFileSubError {user :: User, sndFileTransfer :: SndFileTransfer, chatError :: ChatError}
|
||||
| CRRcvFileSubError {user :: User, rcvFileTransfer :: RcvFileTransfer, chatError :: ChatError}
|
||||
| CRCallInvitation {callInvitation :: RcvCallInvitation}
|
||||
@@ -731,8 +732,6 @@ data ChatResponse
|
||||
| CRCallExtraInfo {user :: User, contact :: Contact, extraInfo :: WebRTCExtraInfo}
|
||||
| CRCallEnded {user :: User, contact :: Contact}
|
||||
| CRCallInvitations {callInvitations :: [RcvCallInvitation]}
|
||||
| CRUserContactLinkSubscribed -- TODO delete
|
||||
| CRUserContactLinkSubError {chatError :: ChatError} -- TODO delete
|
||||
| CRNtfTokenStatus {status :: NtfTknStatus}
|
||||
| CRNtfToken {token :: DeviceToken, status :: NtfTknStatus, ntfMode :: NotificationsMode, ntfServer :: NtfServer}
|
||||
| CRNtfMessages {user_ :: Maybe User, connEntity_ :: Maybe ConnectionEntity, msgTs :: Maybe UTCTime, ntfMessages :: [NtfMsgInfo]}
|
||||
|
||||
@@ -0,0 +1,18 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Chat.Migrations.M20240530_user_contact_links_user_id where
|
||||
|
||||
import Database.SQLite.Simple (Query)
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
|
||||
m20240530_user_contact_links_user_id :: Query
|
||||
m20240530_user_contact_links_user_id =
|
||||
[sql|
|
||||
CREATE INDEX idx_user_contact_links_user_id ON user_contact_links(user_id);
|
||||
|]
|
||||
|
||||
down_m20240530_user_contact_links_user_id :: Query
|
||||
down_m20240530_user_contact_links_user_id =
|
||||
[sql|
|
||||
DROP INDEX idx_user_contact_links_user_id;
|
||||
|]
|
||||
@@ -882,3 +882,4 @@ CREATE INDEX idx_chat_items_fwd_from_group_id ON chat_items(fwd_from_group_id);
|
||||
CREATE INDEX idx_chat_items_fwd_from_chat_item_id ON chat_items(
|
||||
fwd_from_chat_item_id
|
||||
);
|
||||
CREATE INDEX idx_user_contact_links_user_id ON user_contact_links(user_id);
|
||||
|
||||
@@ -19,7 +19,7 @@ module Simplex.Chat.Store.Connections
|
||||
where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Monad
|
||||
import Control.Monad (forM)
|
||||
import Control.Monad.Except
|
||||
import Data.Int (Int64)
|
||||
import Data.Maybe (catMaybes, fromMaybe)
|
||||
@@ -28,7 +28,6 @@ import Database.SQLite.Simple.QQ (sql)
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Store.Files
|
||||
import Simplex.Chat.Store.Groups
|
||||
import Simplex.Chat.Store.Profiles
|
||||
import Simplex.Chat.Store.Shared
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Messaging.Agent.Protocol (ConnId)
|
||||
@@ -213,19 +212,17 @@ getContactConnEntityByConnReqHash db vr user@User {userId} (cReqHash1, cReqHash2
|
||||
(userId, cReqHash1, cReqHash2, ConnDeleted)
|
||||
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db vr user) connId_
|
||||
|
||||
getConnectionsToSubscribe :: DB.Connection -> VersionRangeChat -> IO ([ConnId], [ConnectionEntity])
|
||||
getConnectionsToSubscribe db vr = do
|
||||
aConnIds <- map fromOnly <$> DB.query_ db "SELECT agent_conn_id FROM connections where to_subscribe = 1"
|
||||
entities <- forM aConnIds $ \acId -> do
|
||||
getUserByAConnId db acId >>= \case
|
||||
Just user -> eitherToMaybe <$> runExceptT (getConnectionEntity db vr user acId)
|
||||
Nothing -> pure Nothing
|
||||
unsetConnectionToSubscribe db
|
||||
getConnectionsToSubscribe :: DB.Connection -> VersionRangeChat -> User -> IO ([ConnId], [ConnectionEntity])
|
||||
getConnectionsToSubscribe db vr user@User {userId} = do
|
||||
aConnIds <- map fromOnly <$> DB.query db "SELECT agent_conn_id FROM connections WHERE to_subscribe = 1 AND user_id = ?" (Only userId)
|
||||
entities <- forM aConnIds $ \acId ->
|
||||
eitherToMaybe <$> runExceptT (getConnectionEntity db vr user acId)
|
||||
unsetConnectionToSubscribe db user
|
||||
let connIds = map (\(AgentConnId connId) -> connId) aConnIds
|
||||
pure (connIds, catMaybes entities)
|
||||
|
||||
unsetConnectionToSubscribe :: DB.Connection -> IO ()
|
||||
unsetConnectionToSubscribe db = DB.execute_ db "UPDATE connections SET to_subscribe = 0 WHERE to_subscribe = 1"
|
||||
unsetConnectionToSubscribe :: DB.Connection -> User -> IO ()
|
||||
unsetConnectionToSubscribe db User {userId} = DB.execute db "UPDATE connections SET to_subscribe = 0 WHERE user_id = ? AND to_subscribe = 1" (Only userId)
|
||||
|
||||
deleteConnectionRecord :: DB.Connection -> User -> Int64 -> IO ()
|
||||
deleteConnectionRecord db User {userId} cId = do
|
||||
|
||||
@@ -56,6 +56,7 @@ module Simplex.Chat.Store.Direct
|
||||
incQuotaErrCounter,
|
||||
setQuotaErrCounter,
|
||||
getUserContacts,
|
||||
getUserContactConnIds,
|
||||
createOrUpdateContactRequest,
|
||||
getContactRequest',
|
||||
getContactRequest,
|
||||
@@ -839,19 +840,9 @@ getUserByContactRequestId db contactRequestId =
|
||||
ExceptT . firstRow toUser (SEUserNotFoundByContactRequestId contactRequestId) $
|
||||
DB.query db (userQuery <> " JOIN contact_requests cr ON cr.user_id = u.user_id WHERE cr.contact_request_id = ?") (Only contactRequestId)
|
||||
|
||||
getPendingContactConnections :: DB.Connection -> User -> IO [PendingContactConnection]
|
||||
getPendingContactConnections db User {userId} = do
|
||||
map toPendingContactConnection
|
||||
<$> DB.queryNamed
|
||||
db
|
||||
[sql|
|
||||
SELECT connection_id, agent_conn_id, conn_status, via_contact_uri_hash, via_user_contact_link, group_link_id, custom_user_profile_id, conn_req_inv, local_alias, created_at, updated_at
|
||||
FROM connections
|
||||
WHERE user_id = :user_id
|
||||
AND conn_type = :conn_type
|
||||
AND contact_id IS NULL
|
||||
|]
|
||||
[":user_id" := userId, ":conn_type" := ConnContact]
|
||||
getPendingContactConnections :: DB.Connection -> User -> IO [ConnId]
|
||||
getPendingContactConnections db User {userId} =
|
||||
map fromOnly <$> DB.query db "SELECT agent_conn_id FROM connections WHERE user_id = ? AND conn_type = ? AND contact_id IS NULL" (userId, ConnContact)
|
||||
|
||||
getContactConnections :: DB.Connection -> VersionRangeChat -> UserId -> Contact -> IO [Connection]
|
||||
getContactConnections db vr userId Contact {contactId} =
|
||||
@@ -873,6 +864,33 @@ getContactConnections db vr userId Contact {contactId} =
|
||||
connections [] = pure []
|
||||
connections rows = pure $ map (toConnection vr) rows
|
||||
|
||||
getUserContactConnIds :: DB.Connection -> User -> IO [ConnId]
|
||||
getUserContactConnIds db User {userId} =
|
||||
map fromOnly
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT c.agent_conn_id
|
||||
FROM contacts ct
|
||||
LEFT JOIN connections c ON c.contact_id = ct.contact_id
|
||||
WHERE ct.user_id = ?
|
||||
AND ct.contact_status = ?
|
||||
AND ct.deleted = 0
|
||||
AND
|
||||
c.connection_id = (
|
||||
SELECT cc_connection_id FROM (
|
||||
SELECT
|
||||
cc.connection_id AS cc_connection_id,
|
||||
cc.created_at AS cc_created_at
|
||||
FROM connections cc
|
||||
WHERE cc.user_id = ct.user_id AND cc.contact_id = ct.contact_id
|
||||
ORDER BY cc_created_at DESC
|
||||
LIMIT 1
|
||||
)
|
||||
)
|
||||
|]
|
||||
(userId, CSActive)
|
||||
|
||||
getConnectionById :: DB.Connection -> VersionRangeChat -> User -> Int64 -> ExceptT StoreError IO Connection
|
||||
getConnectionById db vr User {userId} connId = ExceptT $ do
|
||||
firstRow (toConnection vr) (SEConnectionNotFoundById connId) $
|
||||
|
||||
@@ -52,6 +52,7 @@ module Simplex.Chat.Store.Groups
|
||||
deleteGroupItemsAndMembers,
|
||||
deleteGroup,
|
||||
getUserGroups,
|
||||
getUserGroupMemberConnIds,
|
||||
getUserGroupDetails,
|
||||
getUserGroupsWithSummary,
|
||||
getGroupSummary,
|
||||
@@ -628,6 +629,14 @@ getUserGroups db vr user@User {userId} = do
|
||||
groupIds <- map fromOnly <$> DB.query db "SELECT group_id FROM groups WHERE user_id = ?" (Only userId)
|
||||
rights <$> mapM (runExceptT . getGroup db vr user) groupIds
|
||||
|
||||
getUserGroupMemberConnIds :: DB.Connection -> VersionRangeChat -> User -> IO [(GroupInfo, [ConnId])]
|
||||
getUserGroupMemberConnIds db vr user@User {userId} = do
|
||||
groupIds <- map fromOnly <$> DB.query db "SELECT group_id FROM groups WHERE user_id = ? ORDER BY local_display_name" (Only userId)
|
||||
fmap rights . forM groupIds $ \groupId -> runExceptT $ do
|
||||
gInfo <- getGroupInfo db vr user groupId
|
||||
members <- liftIO $ getGroupMemberConnIds db user gInfo
|
||||
pure (gInfo, members)
|
||||
|
||||
getUserGroupDetails :: DB.Connection -> VersionRangeChat -> User -> Maybe ContactId -> Maybe String -> IO [GroupInfo]
|
||||
getUserGroupDetails db vr User {userId, userContactId} _contactId_ search_ =
|
||||
map (toGroupInfo vr userContactId)
|
||||
@@ -748,6 +757,26 @@ getGroupMembers db vr user@User {userId, userContactId} GroupInfo {groupId} = do
|
||||
(groupMemberQuery <> " WHERE m.group_id = ? AND m.user_id = ? AND (m.contact_id IS NULL OR m.contact_id != ?)")
|
||||
(userId, groupId, userId, userContactId)
|
||||
|
||||
getGroupMemberConnIds :: DB.Connection -> User -> GroupInfo -> IO [ConnId]
|
||||
getGroupMemberConnIds db User {userId, userContactId} GroupInfo {groupId} = do
|
||||
map fromOnly
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT c.agent_conn_id
|
||||
FROM group_members m
|
||||
JOIN connections c ON c.connection_id = (
|
||||
SELECT max(cc.connection_id)
|
||||
FROM connections cc
|
||||
WHERE cc.user_id = ? AND cc.group_member_id = m.group_member_id
|
||||
)
|
||||
WHERE m.group_id = ?
|
||||
AND m.user_id = ?
|
||||
AND (m.contact_id IS NULL OR m.contact_id != ?)
|
||||
AND m.member_status NOT IN (?, ?, ?, ?)
|
||||
|]
|
||||
(userId, groupId, userId, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted, GSMemUnknown)
|
||||
|
||||
getGroupMembersForExpiration :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> IO [GroupMember]
|
||||
getGroupMembersForExpiration db vr user@User {userId, userContactId} GroupInfo {groupId} = do
|
||||
map (toContactMember vr user)
|
||||
|
||||
@@ -110,6 +110,7 @@ import Simplex.Chat.Migrations.M20240501_chat_deleted
|
||||
import Simplex.Chat.Migrations.M20240510_chat_items_via_proxy
|
||||
import Simplex.Chat.Migrations.M20240515_rcv_files_user_approved_relays
|
||||
import Simplex.Chat.Migrations.M20240528_quota_err_counter
|
||||
import Simplex.Chat.Migrations.M20240530_user_contact_links_user_id
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
|
||||
|
||||
schemaMigrations :: [(String, Query, Maybe Query)]
|
||||
@@ -219,7 +220,8 @@ schemaMigrations =
|
||||
("20240501_chat_deleted", m20240501_chat_deleted, Just down_m20240501_chat_deleted),
|
||||
("20240510_chat_items_via_proxy", m20240510_chat_items_via_proxy, Just down_m20240510_chat_items_via_proxy),
|
||||
("20240515_rcv_files_user_approved_relays", m20240515_rcv_files_user_approved_relays, Just down_m20240515_rcv_files_user_approved_relays),
|
||||
("20240528_quota_err_counter", m20240528_quota_err_counter, Just down_m20240528_quota_err_counter)
|
||||
("20240528_quota_err_counter", m20240528_quota_err_counter, Just down_m20240528_quota_err_counter),
|
||||
("20240530_user_contact_links_user_id", m20240530_user_contact_links_user_id, Just down_m20240530_user_contact_links_user_id)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
|
||||
@@ -350,25 +350,17 @@ getUserAddressConnections db vr User {userId} = do
|
||||
|]
|
||||
(userId, userId)
|
||||
|
||||
getUserContactLinks :: DB.Connection -> VersionRangeChat -> User -> IO [(Connection, UserContact)]
|
||||
getUserContactLinks db vr User {userId} =
|
||||
map toUserContactConnection
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id,
|
||||
c.conn_status, c.conn_type, c.contact_conn_initiated, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id,
|
||||
c.created_at, c.security_code, c.security_code_verified_at, c.pq_support, c.pq_encryption, c.pq_snd_enabled, c.pq_rcv_enabled, c.auth_err_counter, c.quota_err_counter,
|
||||
c.conn_chat_version, c.peer_chat_min_version, c.peer_chat_max_version,
|
||||
uc.user_contact_link_id, uc.conn_req_contact, uc.group_id
|
||||
FROM connections c
|
||||
JOIN user_contact_links uc ON c.user_contact_link_id = uc.user_contact_link_id
|
||||
WHERE c.user_id = ? AND uc.user_id = ?
|
||||
|]
|
||||
(userId, userId)
|
||||
where
|
||||
toUserContactConnection :: (ConnectionRow :. (Int64, ConnReqContact, Maybe GroupId)) -> (Connection, UserContact)
|
||||
toUserContactConnection (connRow :. (userContactLinkId, connReqContact, groupId)) = (toConnection vr connRow, UserContact {userContactLinkId, connReqContact, groupId})
|
||||
getUserContactLinks :: DB.Connection -> User -> IO [(ConnId, Bool)]
|
||||
getUserContactLinks db User {userId} =
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT c.agent_conn_id, uc.group_id IS NULL
|
||||
FROM connections c
|
||||
JOIN user_contact_links uc ON c.user_contact_link_id = uc.user_contact_link_id
|
||||
WHERE c.user_id = ? AND uc.user_id = ?
|
||||
|]
|
||||
(userId, userId)
|
||||
|
||||
deleteUserAddress :: DB.Connection -> User -> IO ()
|
||||
deleteUserAddress db user@User {userId} = do
|
||||
|
||||
+13
-21
@@ -18,7 +18,7 @@ import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import Data.Char (isSpace, toUpper)
|
||||
import Data.Function (on)
|
||||
import Data.Int (Int64)
|
||||
import Data.List (groupBy, intercalate, intersperse, partition, sortOn)
|
||||
import Data.List (groupBy, intercalate, intersperse, sortOn)
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Map.Strict (Map)
|
||||
@@ -238,19 +238,13 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
|
||||
in ttyUser u [sShow connId <> ": END"]
|
||||
CRContactsDisconnected srv cs -> [plain $ "server disconnected " <> showSMPServer srv <> " (" <> contactList cs <> ")"]
|
||||
CRContactsSubscribed srv cs -> [plain $ "server connected " <> showSMPServer srv <> " (" <> contactList cs <> ")"]
|
||||
CRContactSubError u c e -> ttyUser u [ttyContact' c <> ": contact error " <> sShow e]
|
||||
CRContactSubSummary u summary ->
|
||||
ttyUser u $ [sShow (length subscribed) <> " contacts connected (use " <> highlight' "/cs" <> " for the list)" | not (null subscribed)] <> viewErrorsSummary errors " contact errors"
|
||||
where
|
||||
(errors, subscribed) = partition (isJust . contactError) summary
|
||||
CRUserContactSubSummary u summary ->
|
||||
ttyUser u $
|
||||
map addressSS addresses
|
||||
<> ([sShow (length groupLinksSubscribed) <> " group links active" | not (null groupLinksSubscribed)] <> viewErrorsSummary groupLinkErrors " group link errors")
|
||||
where
|
||||
(addresses, groupLinks) = partition (\UserContactSubStatus {userContact} -> isNothing . userContactGroupId $ userContact) summary
|
||||
addressSS UserContactSubStatus {userContactError} = maybe ("Your address is active! To show: " <> highlight' "/sa") (\e -> "User address error: " <> sShow e <> ", to delete your address: " <> highlight' "/da") userContactError
|
||||
(groupLinkErrors, groupLinksSubscribed) = partition (isJust . userContactError) groupLinks
|
||||
CRContactSubError u c e -> ttyUser u [ttyContact c <> ": contact error " <> sShow e]
|
||||
CRContactSubSummary {user, okSubs, errSubs} -> ttyUser user $ [sShow okSubs <> " contacts connected (use " <> highlight' "/cs" <> " for the list)" | okSubs > 0] <> viewErrorsSummary errSubs " contact errors"
|
||||
CRUserAddrSubStatus {user, userContactError} -> ttyUser user [maybe ("Your address is active! To show: " <> highlight' "/sa") (\e -> "User address error: " <> sShow e <> ", to delete your address: " <> highlight' "/da") userContactError]
|
||||
CRUserGroupLinksSubSummary {user, okSubs, errSubs} ->
|
||||
ttyUser user $
|
||||
[sShow okSubs <> " group links active" | okSubs > 0]
|
||||
<> viewErrorsSummary errSubs " group link errors"
|
||||
CRNetworkStatus status conns -> if testView then [plain $ show (length conns) <> " connections " <> netStatusStr status] else []
|
||||
CRNetworkStatuses u statuses -> if testView then ttyUser' u $ viewNetworkStatuses statuses else []
|
||||
CRGroupInvitation u g -> ttyUser u [groupInvitation' g]
|
||||
@@ -284,10 +278,10 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
|
||||
CRNewMemberContactSentInv u _ct g m -> ttyUser u ["sent invitation to connect directly to member " <> ttyGroup' g <> " " <> ttyMember m]
|
||||
CRNewMemberContactReceivedInv u ct g m -> ttyUser u [ttyGroup' g <> " " <> ttyMember m <> " is creating direct contact " <> ttyContact' ct <> " with you"]
|
||||
CRContactAndMemberAssociated u ct g m ct' -> ttyUser u $ viewContactAndMemberAssociated ct g m ct'
|
||||
CRMemberSubError u g m e -> ttyUser u [ttyGroup' g <> " member " <> ttyMember m <> " error: " <> sShow e]
|
||||
CRMemberSubSummary u summary -> ttyUser u $ viewErrorsSummary (filter (isJust . memberError) summary) " group member errors"
|
||||
CRMemberSubError u g m e -> ttyUser u [ttyGroup' g <> " member " <> ttyContact m <> " error: " <> sShow e]
|
||||
CRMemberSubSummary {user, errSubs} -> ttyUser user $ viewErrorsSummary errSubs " group member errors"
|
||||
CRGroupSubscribed u g -> ttyUser u $ viewGroupSubscribed g
|
||||
CRPendingSubSummary u _ -> ttyUser u []
|
||||
CRPendingSubSummary {user} -> ttyUser user [] -- XXX: ???
|
||||
CRSndFileSubError u SndFileTransfer {fileId, fileName} e ->
|
||||
ttyUser u ["sent file " <> sShow fileId <> " (" <> plain fileName <> ") error: " <> sShow e]
|
||||
CRRcvFileSubError u RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName}} e ->
|
||||
@@ -298,8 +292,6 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
|
||||
CRCallExtraInfo {user = u, contact} -> ttyUser u ["call extra info from " <> ttyContact' contact]
|
||||
CRCallEnded {user = u, contact} -> ttyUser u ["call with " <> ttyContact' contact <> " ended"]
|
||||
CRCallInvitations _ -> []
|
||||
CRUserContactLinkSubscribed -> ["Your address is active! To show: " <> highlight' "/sa"]
|
||||
CRUserContactLinkSubError e -> ["user address error: " <> sShow e, "to delete your address: " <> highlight' "/da"]
|
||||
CRContactConnectionDeleted u PendingContactConnection {pccConnId} -> ttyUser u ["connection :" <> sShow pccConnId <> " deleted"]
|
||||
CRNtfTokenStatus status -> ["device token status: " <> plain (smpEncode status)]
|
||||
CRNtfToken _ status mode srv -> ["device token status: " <> plain (smpEncode status) <> ", notifications mode: " <> plain (strEncode mode) <> ", server: " <> sShow srv]
|
||||
@@ -458,8 +450,8 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
|
||||
testViewItem (CChatItem _ ci@ChatItem {meta = CIMeta {itemText}}) membership_ =
|
||||
let deleted_ = maybe "" (\t -> " [" <> t <> "]") (chatItemDeletedText ci membership_)
|
||||
in itemText <> deleted_
|
||||
viewErrorsSummary :: [a] -> StyledString -> [StyledString]
|
||||
viewErrorsSummary summary s = [ttyError (T.pack . show $ length summary) <> s <> " (run with -c option to show each error)" | not (null summary)]
|
||||
viewErrorsSummary :: Int -> StyledString -> [StyledString]
|
||||
viewErrorsSummary numErrors s = [ttyError (tshow numErrors) <> s <> " (run with -c option to show each error)" | numErrors > 0]
|
||||
contactList :: [ContactRef] -> String
|
||||
contactList cs = T.unpack . T.intercalate ", " $ map (\ContactRef {localDisplayName = n} -> "@" <> n) cs
|
||||
unmuted :: User -> ChatInfo c -> ChatItem c d -> [StyledString] -> [StyledString]
|
||||
|
||||
@@ -1448,6 +1448,7 @@ testUsersSubscribeAfterRestart :: HasCallStack => FilePath -> IO ()
|
||||
testUsersSubscribeAfterRestart tmp = do
|
||||
withNewTestChat tmp "bob" bobProfile $ \bob -> do
|
||||
withNewTestChat tmp "alice" aliceProfile $ \alice -> do
|
||||
threadDelay 100000
|
||||
connectUsers alice bob
|
||||
alice <##> bob
|
||||
|
||||
@@ -1458,8 +1459,7 @@ testUsersSubscribeAfterRestart tmp = do
|
||||
|
||||
withTestChat tmp "alice" $ \alice -> do
|
||||
-- second user is active
|
||||
alice <## "1 contacts connected (use /cs for the list)"
|
||||
alice <## "[user: alice] 1 contacts connected (use /cs for the list)"
|
||||
alice <### ["1 contacts connected (use /cs for the list)", "[user: alice] 1 contacts connected (use /cs for the list)"]
|
||||
|
||||
-- second user receives message
|
||||
alice <##> bob
|
||||
@@ -1793,8 +1793,7 @@ testUsersRestartCIExpiration tmp = do
|
||||
showActiveUser alice "alice (Alice)"
|
||||
|
||||
withTestChatCfg tmp cfg "alice" $ \alice -> do
|
||||
alice <## "1 contacts connected (use /cs for the list)"
|
||||
alice <## "[user: alisa] 1 contacts connected (use /cs for the list)"
|
||||
alice <### ["1 contacts connected (use /cs for the list)", "[user: alisa] 1 contacts connected (use /cs for the list)"]
|
||||
|
||||
-- first user messages
|
||||
alice ##> "/user alice"
|
||||
@@ -1892,8 +1891,7 @@ testEnableCIExpirationOnlyForOneUser tmp = do
|
||||
alice #$> ("/_get chat @4 count=100", chat, chatFeatures <> [(1, "alisa 1"), (0, "alisa 2"), (1, "alisa 3"), (0, "alisa 4")])
|
||||
|
||||
withTestChatCfg tmp cfg "alice" $ \alice -> do
|
||||
alice <## "1 contacts connected (use /cs for the list)"
|
||||
alice <## "[user: alice] 1 contacts connected (use /cs for the list)"
|
||||
alice <### ["1 contacts connected (use /cs for the list)", "[user: alice] 1 contacts connected (use /cs for the list)"]
|
||||
|
||||
-- messages are not deleted for second user after restart
|
||||
alice #$> ("/_get chat @4 count=100", chat, chatFeatures <> [(1, "alisa 1"), (0, "alisa 2"), (1, "alisa 3"), (0, "alisa 4")])
|
||||
@@ -1948,8 +1946,7 @@ testDisableCIExpirationOnlyForOneUser tmp = do
|
||||
alice #$> ("/_get chat @4 count=100", chat, [])
|
||||
|
||||
withTestChatCfg tmp cfg "alice" $ \alice -> do
|
||||
alice <## "1 contacts connected (use /cs for the list)"
|
||||
alice <## "[user: alice] 1 contacts connected (use /cs for the list)"
|
||||
alice <### ["1 contacts connected (use /cs for the list)", "[user: alice] 1 contacts connected (use /cs for the list)"]
|
||||
|
||||
-- second user still has ttl configured after restart
|
||||
alice #$> ("/ttl", id, "old messages are set to be deleted after: 1 second(s)")
|
||||
@@ -2055,8 +2052,10 @@ testUsersTimedMessages tmp = do
|
||||
alice <# "bob> alisa 4"
|
||||
|
||||
withTestChat tmp "alice" $ \alice -> do
|
||||
alice <## "1 contacts connected (use /cs for the list)"
|
||||
alice <## "[user: alice] 1 contacts connected (use /cs for the list)"
|
||||
alice
|
||||
<### [ "1 contacts connected (use /cs for the list)",
|
||||
"[user: alice] 1 contacts connected (use /cs for the list)"
|
||||
]
|
||||
|
||||
alice ##> "/user alice"
|
||||
showActiveUser alice "alice (Alice)"
|
||||
|
||||
@@ -2590,6 +2590,7 @@ testPlanGroupLinkConnecting :: HasCallStack => FilePath -> IO ()
|
||||
testPlanGroupLinkConnecting tmp = do
|
||||
-- gLink <- withNewTestChatCfg tmp cfg "alice" aliceProfile $ \alice -> do
|
||||
gLink <- withNewTestChatCfg tmp cfg "alice" aliceProfile $ \a -> withTestOutput a $ \alice -> do
|
||||
threadDelay 100000
|
||||
alice ##> "/g team"
|
||||
alice <## "group #team is created"
|
||||
alice <## "to add members use /a team <name> or /create link #team"
|
||||
@@ -3200,6 +3201,7 @@ testPlanGroupLinkNoContactKnown =
|
||||
testPlanGroupLinkNoContactConnecting :: HasCallStack => FilePath -> IO ()
|
||||
testPlanGroupLinkNoContactConnecting tmp = do
|
||||
gLink <- withNewTestChat tmp "alice" aliceProfile $ \alice -> do
|
||||
threadDelay 100000
|
||||
alice ##> "/g team"
|
||||
alice <## "group #team is created"
|
||||
alice <## "to add members use /a team <name> or /create link #team"
|
||||
|
||||
@@ -136,10 +136,10 @@ networkStatuses =
|
||||
#endif
|
||||
|
||||
networkStatusesSwift :: LB.ByteString
|
||||
networkStatusesSwift = "{\"resp\":{\"_owsf\":true,\"networkStatuses\":{\"user_\":" <> userJSON <> ",\"networkStatuses\":[]}}}"
|
||||
networkStatusesSwift = "{\"resp\":{\"_owsf\":true,\"networkStatuses\":{\"networkStatuses\":[]}}}"
|
||||
|
||||
networkStatusesTagged :: LB.ByteString
|
||||
networkStatusesTagged = "{\"resp\":{\"type\":\"networkStatuses\",\"user_\":" <> userJSON <> ",\"networkStatuses\":[]}}"
|
||||
networkStatusesTagged = "{\"resp\":{\"type\":\"networkStatuses\",\"networkStatuses\":[]}}"
|
||||
|
||||
memberSubSummary :: LB.ByteString
|
||||
memberSubSummary =
|
||||
@@ -222,8 +222,7 @@ testChatApi tmp = do
|
||||
chatSendCmd cc "/u" `shouldReturn` activeUser
|
||||
chatSendCmd cc "/create user alice Alice" `shouldReturn` activeUserExists
|
||||
chatSendCmd cc "/_start" `shouldReturn` chatStarted
|
||||
chatRecvMsg cc `shouldReturn` networkStatuses
|
||||
chatRecvMsg cc `shouldReturn` userContactSubSummary
|
||||
chatSendCmd cc "/_network_statuses" `shouldReturn` networkStatuses
|
||||
chatRecvMsgWait cc 10000 `shouldReturn` ""
|
||||
chatParseMarkdown "hello" `shouldBe` "{}"
|
||||
chatParseMarkdown "*hello*" `shouldBe` parsedMarkdown
|
||||
|
||||
Reference in New Issue
Block a user