diff --git a/bots/api/TYPES.md b/bots/api/TYPES.md index 8353359484..f20c7c4913 100644 --- a/bots/api/TYPES.md +++ b/bots/api/TYPES.md @@ -2131,6 +2131,7 @@ MemberSupport: **Record type**: - groupId: int64 +- useRelays: bool - localDisplayName: string - groupProfile: [GroupProfile](#groupprofile) - localAlias: string @@ -3581,6 +3582,26 @@ InvalidQuote: InvalidMention: - type: "invalidMention" +InvalidDeliveryTask: +- type: "invalidDeliveryTask" +- taskId: int64 + +DeliveryTaskNotFound: +- type: "deliveryTaskNotFound" +- taskId: int64 + +InvalidDeliveryJob: +- type: "invalidDeliveryJob" +- jobId: int64 + +DeliveryJobNotFound: +- type: "deliveryJobNotFound" +- jobId: int64 + +WorkItemError: +- type: "workItemError" +- errContext: string + --- diff --git a/cabal.project b/cabal.project index 8a861a1909..dbf8b3c08f 100644 --- a/cabal.project +++ b/cabal.project @@ -12,7 +12,7 @@ constraints: zip +disable-bzip2 +disable-zstd source-repository-package type: git location: https://github.com/simplex-chat/simplexmq.git - tag: 7e98b3103f4eb9a6a9a99604afb6f3a32ffc013d + tag: a4f049d8da1021ee76fbd1b25635d16aef24154a source-repository-package type: git diff --git a/docs/rfcs/2025-08-11-channels-forwarding.md b/docs/rfcs/2025-08-11-channels-forwarding.md new file mode 100644 index 0000000000..ba0711c57a --- /dev/null +++ b/docs/rfcs/2025-08-11-channels-forwarding.md @@ -0,0 +1,237 @@ +# Channels forwarding + +This expands on the previous [channels rfc](./2025-07-30-channels.md), specifically on message forwarding by chat relays. + +## Problem + +Current implementation of groups uses forwarding mechanism for improved message delivery between connecting members. From perspective of reusing it for channels it has following limitations: +- Messages are forwarded only for the duration of members establishing connection, until they report x.grp.mem.con to forwarding admin. +- For a given pair of members only a single admin forwards messages - inviting admin (host) forwards messages between its invitees and members introduced to them. It means: + - This admin can be a single point of failure and/or can cause arbitrary delays in message delivery based on its availability when forwarding messages between these member pairs. + - Member pairs fully trust their single forwarding admin in forwarded content. + +Not limitations of protocol, but other weak points of current implementation: +- Forward operations are synchronous to message reception (by forwarding admin), so they're not resumable on failure. +- Forward operations are carried out as "group sends" to all required members (invitees/introduced members in respect to sending member), number of which is expected to grow very large in channels and can potentially have a big load on the database. + +## Solution + +Chat relays will serve as forwarding agents instead of inviting admins, with following modifications to protocol and implementation. + +### Forwarding not limited to establishing connection + +- In channels members will not connect directly to other members and channel owners. +- Chat relays will not take into consideration status of introductions. +- Chat relays will forward messages between owners and all members (from members to owners, for example, for reactions, comments). + +### All chat relays forward all messages + +- Instead of inviting admins all chat relays will forward all messages. +- Members will deduplicate messages (already implemented). +- Members should highlight differences in deduplicated messages. This would solve trust issue. + - Question: If messages are to be signed by owners, what differences can chat relays introduce? Does this point in initial doc imply owner sending different versions of message to chat relays? Losses in delivery? Answer: Not all messages will be signed. + +#### Highlighting deduplicated messages differences + +Currently we simply ignore duplicate messages - see createNewRcvMessage. + +Some options on how to highlight difference in messages from chat relays: +1. Show only the fact that there is difference. + - Persist duplicate error (SEDuplicateGroupMessage) as flag on chat item to then display warning sign in UI. +2. Save message hashes as some additional entity linked to message or chat item for each chat relay. + - If any new hash differs, set flag on chat item for warning sign in UI. + - Add ability to load additional info (with other chat item info via APIGetChatItemInfo) showing which relays sent different hashes (e.g. 1 differs from 2 others - show 1 as warning, all differ - show all as warning). +3. As previous, but save content. Possibly save content additionally to hashes, for faster comparison. + - Saving content means converting duplicate messages to chat item content, or only saving text, but latter will fail to show difference in files. +4. Create new versions as "different version of another message" chat items. + - Timestamp would have to be made the same as on original chat item, as it's not guaranteed to be the same - each chat relay will forward a broker ts based on its own metadata of receiving message from sender. + - It could be done via special replies, to re-use reply machinery. However, this won't work for messages being replies themselves then. + - Alternatively, it could say "different message from X relay". + +Service events will not have content. We still can/should compare them and indicate difference, e.g. by creating a special chat item (similar to integrity violation). + +How to compute hashes. Problem is with file descriptions, as it is legitimate case that they will be different. Hash could be computed as hash of message, excluding file description from FileInvitation. File digest and names should be the same, the problem of different names needs to be fixed. + +Files can also cause problem with showing difference in content if file preview is the same, but file hash is different. So showing difference in content does not exclude necessity of showing difference in hashes as in option 2. + +As a note, this whole section discusses an edge case of chat relays maliciously changing messages, and countermeasures to prevent them doing so undetectably. May be not worth implementing overly complex solution as MVP (options 3, 4). + +For MVP from UI standpoint this should suffice: a marker on item, that would show in info which relays delivered it with a sign which relay delivered different hash. Possibly also special event item next to marked item (with same timestamp) - for service events that don't create a chat item, or in case we don't account it for some chat items. + +### Forwarding jobs + +- Received messages will be marked for forwarding and picked up by a forwarding worker to form forwarding jobs. +- Forwarding job can be split into smaller batches by members to make smaller group sends one at a time. + +**How forwarding works now:** + +Currently we build ad-hoc forwarding instruction for each message based on its scope (GroupForwardScope). The output of processing a batch of messages is `Map GroupForwardScope (NonEmpty (ChatMessage 'Json))`. Then for each scope message batches are sent separately to different member lists (to clarify, "sent" here means scheduled for sending in agent). All this is done synchronously in receive loop. + +**How forwarding will work:** + +Chat relay should be able to handle channels consisting of hundreds of thousands of members. Synchronous forwarding will be replaced by asynchronous forwarding jobs to reduce load in the receive loop, and make forwarding resumable on failure. Also loading all members in memory will not scale, so these jobs have to be split into smaller batches. + +Question: Should synchronous processing be changed to forwarding jobs for all types of scopes, or only for Main (GFSMain - for regular messages) and All (GFSAll - for all current members and for all pending members scopes), and not for Support scope (GFSMemberSupport)? + - Pros/cons of persisting jobs for all types of scopes: + - Possibly more uniform processing. However, for support scope group member id is required. Either encode scope as json or add field for scope group member id for persistence (see schema below). + - Requires forwarding worker to have more logic ("if"), or different worker types. + - Pros/cons of persisting jobs only for Main and All scopes: + - Forwarding worker and persistence are simpler, but logic lives in 2 places (synchronous as now + worker). + - As a note, support scopes have small number of members to forward to, so optimizing forward for them is not a necessity. + +Answer: All forwarding logic will become asynchronous. This will reduce load in the receive loop for inviting admins in regular groups as well. + +Forwarding jobs for different groups can be concurrent, inside group should be sequential to follow order of messages. One approach could be to create a dedicated forwarding worker for each group. Different scope types can also use dedicated workers (possibly: 1 worker for all + main scopes, 1 - for all support scopes), so heavy full group forwarding wouldn't slow down forwarding in much smaller support scopes. + +Forwarding workers will re-use worker abstraction from agent. + +Forwarding workers should use low priority db pool. + +We roughly need following data for a forwarding job: +- group id, +- forwarding scope (forward_scope), +- sending member - to include memberId in XGrpMsgForward, +- broker timestamp of received messages batch to include in XGrpMsgForward, +- "message from channel" flag from sending owner - see "Hiding sending owner id" section below (group_as_sender), +- list of messages (events). + +**How to build message batches for a forwarding job:** + +Currently for each message a full MsgBody is saved on `messages` table record, which is just a ByteString. Also if received messages were batched, full batch body is saved for each message record (it's a questionable design). For example, here is message body of batched deletion of 2 chat items, which is saved on 2 message records: + +``` +msg_body = [{"v":"1-16","msgId":"ZUd3bzVDTXFHWmc3Z29YSQ==","event":"x.msg.del","params":{"msgId":"QVVuN2RkaXg0aVJJdTZXSA=="}},{"v":"1-16","msgId":"amM5dzV2RkRjNmNYSDRLQQ==","event":"x.msg.del","params":{"msgId":"NzFlV3pNRStpQTRrQjRYUg=="}}] +``` + +On the other hand for forwarding operation we require ChatMessage 'Json (for XGrpMsgForward), which could be saved on message records instead. + +As a side note, it seems we can stop saving full batch body as msg_body for received messages, as it's not used for any purpose. This field is only used for retrieving and sending pending group messages (sent, not received). + +Alternatively, we could read full msg_body, and repeatedly parse list of ChatMessage 'Json. However, this conflicts with possibility that a single batch body will have messages of different scopes, which current processing logic allows, although there's no legitimate case as of now. This means we'd have make jobs forward to different lists of members, or have some supervisor to launch different jobs, which further complicates the processing. Also, this limits forwarding to the same batch sizes (in terms of number of messages) as those batches that received messages came in, and instead we could possibly fit more messages into batches if available. Overall, persisting ChatMessage' Json on each message record, and then retrieving available messages for the job, seems preferable. + +**How to split forwarding jobs into smaller delivery batches:** + +For simplicity, this will be done only for channels, and not for inviting admins in regular groups, at least initially. Inviting admins have more complex logic, involving multiple queries and filters to retrieve less (only necessary) members, as we're trying to limit load on them, as they can be mobile clients. They will be moved to asynchronous processing too, though. + +Forwarding job will read required members in loop using a cursor (e.g., use group_member_id as a cursor) to split into further delivery jobs (group sends) by members. As a reminder, group send in terms of chat logic is not a network operation, but a request to agent. We can consider this part a black box for now, and consider if groups sends should be made concurrently later. For now though, for simplicity we can consider that group sends are done in a synchronous loop with moving cursor for member retrieval. Cursor position can be remembered on the job record after each group send, for recovery. + +It's unclear if there's a need for a separate lower level abstraction for delivery jobs, that could be reused for feeds and other purposes, as they would require different logic of building delivery lists, and scheduling a delivery for agent already serves a similar purpose. For now, it seems this additional abstraction is unnecessary. + +**How a forwarding job will work overall:** + +0. There is some process on start that launches necessary workers for each group/scope client serves as a forwarding agent (for those that have messages that need forwarding). Also message receive loop "kicks" necessary workers. Below we start with a worker for some group/scope trying to retrieve next work item, that is being next message(s) to forward. +1. Worker retrieves next message from `messages` table that was marked for forwarding, that matches the worker's group/scope. + - We may need a separate field on message record to track "forward pending" state, to know what to forward. Setting forward_scope as a task with addition of forward_complete flag to mark forward completion may be enough (see schema below). +2. Worker checks, if this message is already attached to some forwarding job, and the state of the job. + 1. Worker gets job record. + - If message is not attached to any job yet, worker creates a new job record, sets job id on the message record (normal execution path). + - Otherwise worker gets existing job attached to the message (recovery path). + 2. Worker determines forwarding batch encoding for the job. + - If encoding is not saved on the job, it means it wasn't determined before (normal execution): + 1. Worker retrieves more messages that match its group/scope. + - Could be in loop or in bulk. + - We won't know how much we'd need. Some heuristic could be read 100, then mark those that are used with jobId, or load more if needed. + - Also message list has to preserve reception order. + 2. Worker prepares encoding (wraps messages in XGrpMsgForward events with metadata) and saves it on the job record. + - It's important to put encoding into job and mark all relevant messages in one transaction. + - Otherwise worker uses saved encoding (recovery). +3. With moving cursor on group member id for member retrieval, forward encoded batch. In loop: + 1. Retrieve members up to some limit and filtering according to a cursor. In normal execution path on first iteration job would not have a previously saved cursor yet. + - For Main scope all current members will be retrieved. + - For Support scopes - moderators and above + scope member. For support scope job can be done without a cursor, instead simply loading all its members and forwarding. + - For All scope - all current and pending members (In channels there is no need for member review. So possibly we don't have to account for All scope). + - Main difference from forwarding in regular groups here is that for inviting admins we retrieve only introduced and invited members for the message's sending member, that are not yet connected. For channels there will be no such filtering. + 2. Group send encoded batch to retrieved members. + 3. Update cursor on the job. +4. Marks all messages attached to the job as forwarded (forward_complete), deletes the job record. + - Possibly do in cleanup manager and delete after say a week. + +Schema draft: + +```sql +CREATE TABLE forwarding_jobs ( + forwarding_job_id INTEGER PRIMARY KEY, + msg_batch_encoding TEXT, + cursor_group_member_id INTEGER +) + +ALTER TABLE messages ADD COLUMN chat_message_json TEXT; +ALTER TABLE messages ADD COLUMN forward_scope TEXT; +ALTER TABLE messages ADD COLUMN group_as_sender INTEGER NOT NULL DEFAULT 0; -- for "message from channel" flag from owner +ALTER TABLE messages ADD COLUMN forward_complete INTEGER NOT NULL DEFAULT 0; +ALTER TABLE messages ADD COLUMN forwarding_job_id INTEGER REFERENCES forwarding_jobs ON DELETE SET NULL; + +-- indexes for fkey, search based on group/scope and order; +``` + +## Other considerations + +### Hiding sending owner id + +Initial doc mentions "messages sent from channel name" in minimal testable scope. This would be a feature allowing owners to send messages to channel without it being clear for members which owner sent it. For this, we'd also like to hide sending owner's member id from forwarding operation. + +This means MemberId in XGrpMsgForward should become optional. + +```haskell +XGrpMsgForward :: Maybe MemberId -> ChatMessage 'Json -> UTCTime -> ChatMsgEvent 'Json +``` + +Receiving members would then save this message as received from group. We already have necessary machinery for chat items persistence - see ShowGroupAsSender. However, message processing logic would have to be reworked to allow for absence of group member. Also, sending owner would have to indicate it to chat relays in XMsgNew (TBC - other events?). + +```haskell +XMsgNew :: ShowGroupAsSender -> MsgContainer -> ChatMsgEvent 'Json +``` + +ShowGroupAsSender can be in MsgContainer, not separate. + +Chat relays should not hide sending owner from other owners: sending owner should be visible to them, but message shown as from channel. This means forwarding job has to be split into separate sends with different sets of XGrpMsgForward events (with and without sending owner's member id). + +### Connection deleting events + +Forwarding regular messages, reactions, updates and many other events is straightforward. However, naive processing of some events currently breaks forwarding logic, specifically member and group deletion. + +As it is now, forwarding operation follows event processing. So, processing of XGrpMemDel, XGrpDel first deletes member connection (or connections with all members in case of group deletion), then attempts to forward these events, which in reality never works as at this point connection is already deleted. + +Currently we ignore this problem (there are TODOs), as all members according to protocol connect with each other, and forwarding serves only as message delivery improvement/backup, and not a main route, and so members in at least supposedly most cases receive these events from the original sender. + +With chat relays, however, no messages are sent directly from owners to members, so if logic is kept as is these events would never be received. So, their processing should be special cased to delay until after forwarding operation. + +## Further considerations, ideas (Update) + +- Sending member profiles. + - Profiles of owners (and admins, moderators) should be sent to all members on joining. + - Profiles of other members should be sent on interaction with them. + - For MVP: we can show counts on reactions and avoid solving it, but we should have a design to solve this problem, as it would be necessary for comments and later for large groups. + - Solution draft - partition members based on join timestamp and sender last interaction time: + - Track last interaction timestamp on each member. + - When forwarding from this member partition members into two parts: include profile for those who joined after interaction, don't include for those who joined before interaction. + - This suggests that job would be divided into two parts. + - Protocol to request member profile as a fallback. + - This becomes more complex in case batch has multiple members - for n required profiles to send, recipients need to be partitioned into n + 1 parts. + - Better solution - schedule profile deliveries separately from batch on first post-join delivery per sender. + - Track last_profile_delivery_ts (for sender), join_ts (for recipient) on member records. + - On the sender's first overall interaction (last_profile_delivery_ts is null), first create a special task to deliver profile to all (in scope All). + - On following sends on batching, for senders whose last_profile_delivery_ts < any member's join_ts (i.e., some member missed the initial broadcast), create a profile delivery task for those specific senders. + - Message task should have a flag whether profile should be delivered to anyone (set to false on first profile delivery). Checking last_profile_delivery_ts is null seems to be sufficient. +- Don't partition for owners based on "message from channel" flag to simplify delivery - no need for two separate jobs/cursors. +- When chat relay receives group deletion event, or event removing it [chat relay itself] from the group: + - Chat relay should kill all forwarding workers for the group -> delete all jobs -> create one new job to forward group deletion. + - It could be a special type of job. +- Sending each reaction (and in future comment) won't scale well. + - Instead periodically send reaction and comment counts. + - Send reactions and comments themselves on request. + - This implies that instead of message records, special entity for forwarding tasks should be added, for worker to search for next work items - see more below. +- Connections with priority. + - Client could have 2 connections/queues with relay, and relay - 2 subscribers. + - Separation of responsibilities between connections/queues: + - Normal queue to be used for regular forwarding of messages, reactions, etc. + - High-priority queue to be used for serving client requests and sending important service events (e.g. ownership changes, group deletion). + - Possibly special case of connection redundancy. +- Design to be reworked to use special entity for forwarding tasks instead of relying on messages. + - Points for this: + - Batched reactions/comments counts. + - Special logic on group deletion/relay removal. + - Possibly special logic on sending member profiles, as it's not needed for all types of jobs. + - Sum type of task types. + - Some tasks may simply point to message records. + - Some tasks may be created for further updating their metadata / scheduling, e.g. "send reactions/comments count update", and the information itself may be taken from chat items. diff --git a/packages/simplex-chat-client/types/typescript/src/types.ts b/packages/simplex-chat-client/types/typescript/src/types.ts index 3a056293c5..bdc99ee750 100644 --- a/packages/simplex-chat-client/types/typescript/src/types.ts +++ b/packages/simplex-chat-client/types/typescript/src/types.ts @@ -2427,6 +2427,7 @@ export enum GroupFeatureEnabled { export interface GroupInfo { groupId: number // int64 + useRelays: boolean localDisplayName: string groupProfile: GroupProfile localAlias: string @@ -3812,6 +3813,11 @@ export type StoreError = | StoreError.UsageConditionsNotFound | StoreError.InvalidQuote | StoreError.InvalidMention + | StoreError.InvalidDeliveryTask + | StoreError.DeliveryTaskNotFound + | StoreError.InvalidDeliveryJob + | StoreError.DeliveryJobNotFound + | StoreError.WorkItemError export namespace StoreError { export type Tag = @@ -3892,6 +3898,11 @@ export namespace StoreError { | "usageConditionsNotFound" | "invalidQuote" | "invalidMention" + | "invalidDeliveryTask" + | "deliveryTaskNotFound" + | "invalidDeliveryJob" + | "deliveryJobNotFound" + | "workItemError" interface Interface { type: Tag @@ -4269,6 +4280,31 @@ export namespace StoreError { export interface InvalidMention extends Interface { type: "invalidMention" } + + export interface InvalidDeliveryTask extends Interface { + type: "invalidDeliveryTask" + taskId: number // int64 + } + + export interface DeliveryTaskNotFound extends Interface { + type: "deliveryTaskNotFound" + taskId: number // int64 + } + + export interface InvalidDeliveryJob extends Interface { + type: "invalidDeliveryJob" + jobId: number // int64 + } + + export interface DeliveryJobNotFound extends Interface { + type: "deliveryJobNotFound" + jobId: number // int64 + } + + export interface WorkItemError extends Interface { + type: "workItemError" + errContext: string + } } export enum SwitchPhase { diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index a5f2790418..554cbb2286 100644 --- a/scripts/nix/sha256map.nix +++ b/scripts/nix/sha256map.nix @@ -1,5 +1,5 @@ { - "https://github.com/simplex-chat/simplexmq.git"."7e98b3103f4eb9a6a9a99604afb6f3a32ffc013d" = "0g6lm65hs2kp2rsk9lqzj42nq51i5xynxrf16axma80cq0jqzxzl"; + "https://github.com/simplex-chat/simplexmq.git"."a4f049d8da1021ee76fbd1b25635d16aef24154a" = "1wvrmb6swpsl24by8d6wz0nfj8bi2pbkigv26pl7c1binc0qichy"; "https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38"; "https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d"; "https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl"; diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 88a92e6bb4..fd8a089193 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -40,6 +40,7 @@ library Simplex.Chat.AppSettings Simplex.Chat.Call Simplex.Chat.Controller + Simplex.Chat.Delivery Simplex.Chat.Files Simplex.Chat.Library.Commands Simplex.Chat.Library.Internal @@ -72,6 +73,7 @@ library Simplex.Chat.Store.AppSettings Simplex.Chat.Store.Connections Simplex.Chat.Store.ContactRequest + Simplex.Chat.Store.Delivery Simplex.Chat.Store.Direct Simplex.Chat.Store.Files Simplex.Chat.Store.Groups @@ -115,6 +117,7 @@ library Simplex.Chat.Store.Postgres.Migrations.M20250729_member_contact_requests Simplex.Chat.Store.Postgres.Migrations.M20250801_via_group_link_uri Simplex.Chat.Store.Postgres.Migrations.M20250802_chat_peer_type + Simplex.Chat.Store.Postgres.Migrations.M20250813_delivery_tasks else exposed-modules: Simplex.Chat.Archive @@ -255,6 +258,7 @@ library Simplex.Chat.Store.SQLite.Migrations.M20250729_member_contact_requests Simplex.Chat.Store.SQLite.Migrations.M20250801_via_group_link_uri Simplex.Chat.Store.SQLite.Migrations.M20250802_chat_peer_type + Simplex.Chat.Store.SQLite.Migrations.M20250813_delivery_tasks other-modules: Paths_simplex_chat hs-source-dirs: diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index e14275b75c..e39f8d9a77 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -163,6 +163,8 @@ newChatController remoteCtrlSession <- newTVarIO Nothing filesFolder <- newTVarIO optFilesFolder chatStoreChanged <- newTVarIO False + deliveryTaskWorkers <- TM.emptyIO + deliveryJobWorkers <- TM.emptyIO expireCIThreads <- TM.emptyIO expireCIFlags <- TM.emptyIO cleanupManagerAsync <- newTVarIO Nothing @@ -203,6 +205,8 @@ newChatController remoteCtrlSession, config, filesFolder, + deliveryTaskWorkers, + deliveryJobWorkers, expireCIThreads, expireCIFlags, cleanupManagerAsync, diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index d8a6f7a30a..0b2f16ad1d 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -54,6 +54,7 @@ import Numeric.Natural import qualified Paths_simplex_chat as SC import Simplex.Chat.AppSettings import Simplex.Chat.Call +import Simplex.Chat.Delivery import Simplex.Chat.Messages import Simplex.Chat.Messages.CIContent import Simplex.Chat.Operators @@ -70,7 +71,7 @@ import Simplex.Chat.Util (liftIOEither) import Simplex.FileTransfer.Description (FileDescriptionURI) import Simplex.Messaging.Agent (AgentClient, SubscriptionsInfo) import Simplex.Messaging.Agent.Client (AgentLocks, AgentQueuesInfo (..), AgentWorkersDetails (..), AgentWorkersSummary (..), ProtocolTestFailure, SMPServerSubs, ServerQueueInfo, UserNetworkInfo) -import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, NetworkConfig, ServerCfg) +import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, NetworkConfig, ServerCfg, Worker) import Simplex.Messaging.Agent.Lock import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction, withTransactionPriority) @@ -244,6 +245,8 @@ data ChatController = ChatController remoteCtrlSession :: TVar (Maybe (SessionSeq, RemoteCtrlSession)), -- Supervisor process for hosted controllers config :: ChatConfig, filesFolder :: TVar (Maybe FilePath), -- path to files folder for mobile apps, + deliveryTaskWorkers :: TMap DeliveryWorkerKey Worker, + deliveryJobWorkers :: TMap DeliveryWorkerKey Worker, expireCIThreads :: TMap UserId (Maybe (Async ())), expireCIFlags :: TMap UserId Bool, cleanupManagerAsync :: TVar (Maybe (Async ())), diff --git a/src/Simplex/Chat/Delivery.hs b/src/Simplex/Chat/Delivery.hs new file mode 100644 index 0000000000..d0a77514eb --- /dev/null +++ b/src/Simplex/Chat/Delivery.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Simplex.Chat.Delivery where + +import Data.ByteString.Char8 (ByteString) +import Data.Int (Int64) +import Data.Maybe (fromMaybe) +import Data.Time.Clock (UTCTime) +import Simplex.Chat.Messages (GroupChatScopeInfo (..), MessageId) +import Simplex.Chat.Options.DB (FromField (..), ToField (..)) +import Simplex.Chat.Protocol +import Simplex.Chat.Types +import Simplex.Chat.Types.Shared +import Simplex.Messaging.Agent.Store.DB (fromTextField_) +import Simplex.Messaging.Encoding.String + +type DeliveryWorkerKey = (GroupId, DeliveryWorkerScope) + +data DeliveryWorkerScope + = DWSGroup + | DWSMemberSupport + -- | DWSMemberProfileUpdate + deriving (Eq, Ord, Show) + +instance FromField DeliveryWorkerScope where fromField = fromTextField_ textDecode + +instance ToField DeliveryWorkerScope where toField = toField . textEncode + +instance TextEncoding DeliveryWorkerScope where + textDecode = \case + "group" -> Just DWSGroup + "member_support" -> Just DWSMemberSupport + -- "member_profile_update" -> Just DWSMemberProfileUpdate + _ -> Nothing + textEncode = \case + DWSGroup -> "group" + DWSMemberSupport -> "member_support" + -- DWSMemberProfileUpdate -> "member_profile_update" + +data DeliveryJobScope + = DJSGroup {jobSpec :: DeliveryJobSpec} + | DJSMemberSupport {supportGMId :: GroupMemberId} + -- | DJSMemberProfileUpdate + deriving (Show) + +data DeliveryJobSpec + = DJDeliveryJob {includePending :: Bool} + | DJRelayRemoved + deriving (Show) + +data DeliveryJobSpecTag + = DJSTDeliveryJob + | DJSTRelayRemoved + deriving (Show) + +instance FromField DeliveryJobSpecTag where fromField = fromTextField_ textDecode + +instance ToField DeliveryJobSpecTag where toField = toField . textEncode + +instance TextEncoding DeliveryJobSpecTag where + textDecode = \case + "delivery_job" -> Just DJSTDeliveryJob + "relay_removed" -> Just DJSTRelayRemoved + _ -> Nothing + textEncode = \case + DJSTDeliveryJob -> "delivery_job" + DJSTRelayRemoved -> "relay_removed" + +toWorkerScope :: DeliveryJobScope -> DeliveryWorkerScope +toWorkerScope = \case + DJSGroup _ -> DWSGroup + DJSMemberSupport _ -> DWSMemberSupport + -- DJSMemberProfileUpdate -> DWSMemberProfileUpdate + +isRelayRemoved :: DeliveryJobScope -> Bool +isRelayRemoved = \case + DJSGroup {jobSpec} -> case jobSpec of + DJRelayRemoved -> True + _ -> False + _ -> False + +jobScopeImpliedSpec :: DeliveryJobScope -> DeliveryJobSpec +jobScopeImpliedSpec = \case + DJSGroup {jobSpec} -> jobSpec + DJSMemberSupport {} -> DJDeliveryJob {includePending = False} + +jobSpecImpliedPending :: DeliveryJobSpec -> Bool +jobSpecImpliedPending = \case + DJDeliveryJob {includePending} -> includePending + DJRelayRemoved -> True + +infoToDeliveryScope :: GroupInfo -> Maybe GroupChatScopeInfo -> DeliveryJobScope +infoToDeliveryScope GroupInfo {membership} = \case + Nothing -> DJSGroup {jobSpec = DJDeliveryJob {includePending = False}} + Just GCSIMemberSupport {groupMember_} -> + let supportGMId = groupMemberId' $ fromMaybe membership groupMember_ + in DJSMemberSupport {supportGMId} + +memberEventDeliveryScope :: GroupMember -> Maybe DeliveryJobScope +memberEventDeliveryScope m@GroupMember {memberRole, memberStatus} + | memberStatus == GSMemPendingApproval = Nothing + | memberStatus == GSMemPendingReview = Just $ DJSMemberSupport {supportGMId = groupMemberId' m} + | memberRole >= GRModerator = Just DJSGroup {jobSpec = DJDeliveryJob {includePending = True}} + | otherwise = Just DJSGroup {jobSpec = DJDeliveryJob {includePending = False}} + +data NewMessageDeliveryTask = NewMessageDeliveryTask + { messageId :: MessageId, + jobScope :: DeliveryJobScope, + messageFromChannel :: MessageFromChannel + } + deriving (Show) + +data MessageDeliveryTask = MessageDeliveryTask + { taskId :: Int64, + jobScope :: DeliveryJobScope, + senderGMId :: GroupMemberId, + senderMemberId :: MemberId, + senderMemberName :: ContactName, + brokerTs :: UTCTime, + chatMessage :: ChatMessage 'Json, + messageFromChannel :: MessageFromChannel + } + deriving (Show) + +deliveryTaskId :: MessageDeliveryTask -> Int64 +deliveryTaskId = taskId + +data DeliveryTaskStatus + = DTSNew -- created for delivery task worker to pick up and convert into a delivery job + | DTSProcessed -- processed by delivery task worker, delivery job created, task can be deleted + | DTSError -- permanent error + deriving (Show) + +instance FromField DeliveryTaskStatus where fromField = fromTextField_ textDecode + +instance ToField DeliveryTaskStatus where toField = toField . textEncode + +instance TextEncoding DeliveryTaskStatus where + textDecode = \case + "new" -> Just DTSNew + "processed" -> Just DTSProcessed + "error" -> Just DTSError + _ -> Nothing + textEncode = \case + DTSNew -> "new" + DTSProcessed -> "processed" + DTSError -> "error" + +data MessageDeliveryJob = MessageDeliveryJob + { jobId :: Int64, + jobScope :: DeliveryJobScope, + singleSenderGMId_ :: Maybe GroupMemberId, -- Just for single-sender deliveries, Nothing for multi-sender deliveries + body :: ByteString, + cursorGMId_ :: Maybe GroupMemberId + } + deriving (Show) + +deliveryJobId :: MessageDeliveryJob -> Int64 +deliveryJobId = jobId + +data DeliveryJobStatus + = DJSPending -- created for delivery job worker to pick up + | DJSComplete -- complete by delivery job worker, job can be deleted + | DJSError -- permanent error + deriving (Show) + +instance FromField DeliveryJobStatus where fromField = fromTextField_ textDecode + +instance ToField DeliveryJobStatus where toField = toField . textEncode + +instance TextEncoding DeliveryJobStatus where + textDecode = \case + "pending" -> Just DJSPending + "complete" -> Just DJSComplete + "error" -> Just DJSError + _ -> Nothing + textEncode = \case + DJSPending -> "pending" + DJSComplete -> "complete" + DJSError -> "error" + +-- data MemberProfileUpdateTask = undefined + +-- data MemberProfileUpdateJob = undefined diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index b668a1d793..41d684c114 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -74,6 +74,7 @@ import Simplex.Chat.Store import Simplex.Chat.Store.AppSettings import Simplex.Chat.Store.ContactRequest import Simplex.Chat.Store.Connections +import Simplex.Chat.Store.Delivery import Simplex.Chat.Store.Direct import Simplex.Chat.Store.Files import Simplex.Chat.Store.Groups @@ -181,6 +182,7 @@ startChatController mainApp enableSndFiles = do then do startXFTP xftpStartWorkers void $ forkIO $ startFilesToReceive users + startDeliveryWorkers startCleanupManager void $ forkIO $ mapM_ startExpireCIs users else when enableSndFiles $ startXFTP xftpStartSndWorkers @@ -190,6 +192,10 @@ startChatController mainApp enableSndFiles = do runExceptT (withAgent $ \a -> startWorkers a tmp) >>= \case Left e -> liftIO $ putStrLn $ "Error starting XFTP workers: " <> show e Right _ -> pure () + startDeliveryWorkers = + runExceptT (startDeliveryTaskWorkers >> startDeliveryJobWorkers) >>= \case + Left e -> liftIO $ putStrLn $ "Error starting delivery workers: " <> show e + Right _ -> pure () startCleanupManager = do cleanupAsync <- asks cleanupManagerAsync readTVarIO cleanupAsync >>= \case @@ -607,7 +613,6 @@ processChatCommand vr nm = \case gInfo <- withFastStore $ \db -> getGroupInfo db vr user gId let mc = MCReport reportText reportReason cm = ComposedMessage {fileSource = Nothing, quotedItemId = Just reportedItemId, msgContent = mc, mentions = M.empty} - -- TODO [knocking] reports sent to support scope may be wrong sendGroupContentMessages user gInfo (Just $ GCSMemberSupport Nothing) False Nothing [composedMessageReq cm] ReportMessage {groupName, contactName_, reportReason, reportedMessage} -> withUser $ \user -> do gId <- withFastStore $ \db -> getGroupIdByName db user groupName @@ -2379,6 +2384,7 @@ processChatCommand vr nm = \case withGroupLock "blockForAll" groupId $ do Group gInfo members <- withFastStore $ \db -> getGroup db vr user groupId when (selfSelected gInfo) $ throwCmdError "can't block/unblock self" + -- TODO [channels fwd] consider sending restriction to all members (remove filtering), as we do in delivery jobs let (blockMems, remainingMems, maxRole, anyAdmin, anyPending) = selectMembers members when (length blockMems /= length memberIds) $ throwChatError CEGroupMemberNotFound when (length memberIds > 1 && anyAdmin) $ throwCmdError "can't block/unblock multiple members when admins selected" @@ -4314,6 +4320,8 @@ cleanupManager = do forM_ us $ cleanupUser interval stepDelay forM_ us' $ cleanupUser interval stepDelay cleanupMessages `catchAllErrors` eToView + cleanupDeliveryTasks `catchAllErrors` eToView + cleanupDeliveryJobs `catchAllErrors` eToView -- TODO possibly, also cleanup async commands cleanupProbes `catchAllErrors` eToView liftIO $ threadDelay' $ diffToMicroseconds interval @@ -4345,6 +4353,14 @@ cleanupManager = do ts <- liftIO getCurrentTime let cutoffTs = addUTCTime (-(30 * nominalDay)) ts withStore' (`deleteOldMessages` cutoffTs) + cleanupDeliveryTasks = do + ts <- liftIO getCurrentTime + let cutoffTs = addUTCTime (-(7 * nominalDay)) ts + withStore' (`deleteDoneDeliveryTasks` cutoffTs) + cleanupDeliveryJobs = do + ts <- liftIO getCurrentTime + let cutoffTs = addUTCTime (-(7 * nominalDay)) ts + withStore' (`deleteDoneDeliveryJobs` cutoffTs) cleanupProbes = do ts <- liftIO getCurrentTime let cutoffTs = addUTCTime (-(14 * nominalDay)) ts diff --git a/src/Simplex/Chat/Library/Internal.hs b/src/Simplex/Chat/Library/Internal.hs index e3885a3c9a..707ec7c109 100644 --- a/src/Simplex/Chat/Library/Internal.hs +++ b/src/Simplex/Chat/Library/Internal.hs @@ -1441,21 +1441,26 @@ mkGroupChatScope gInfo@GroupInfo {membership} m | otherwise = pure (gInfo, m, Nothing) -mkGetMessageChatScope :: VersionRangeChat -> User -> GroupInfo -> GroupMember -> Maybe MsgScope -> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo) -mkGetMessageChatScope vr user gInfo@GroupInfo {membership} m msgScope_ = +mkGetMessageChatScope :: VersionRangeChat -> User -> GroupInfo -> GroupMember -> MsgContent -> Maybe MsgScope -> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo) +mkGetMessageChatScope vr user gInfo@GroupInfo {membership} m mc msgScope_ = mkGroupChatScope gInfo m >>= \case groupScope@(_gInfo', _m', Just _scopeInfo) -> pure groupScope - (_, _, Nothing) -> case msgScope_ of - Nothing -> pure (gInfo, m, Nothing) - Just (MSMember mId) - | sameMemberId mId membership -> do - (gInfo', scopeInfo) <- mkGroupSupportChatInfo gInfo - pure (gInfo', m, Just scopeInfo) - | otherwise -> do - referredMember <- withStore $ \db -> getGroupMemberByMemberId db vr user gInfo mId - -- TODO [knocking] return patched _referredMember' too? - (_referredMember', scopeInfo) <- mkMemberSupportChatInfo referredMember - pure (gInfo, m, Just scopeInfo) + (_, _, Nothing) + | isReport mc -> do + -- TODO [knocking] return patched _m'? + (_m', scopeInfo) <- mkMemberSupportChatInfo m -- only support scope member can send a report (m is sender) + pure (gInfo, m, Just scopeInfo) + | otherwise -> case msgScope_ of + Nothing -> pure (gInfo, m, Nothing) + Just (MSMember mId) + | sameMemberId mId membership -> do + (gInfo', scopeInfo) <- mkGroupSupportChatInfo gInfo + pure (gInfo', m, Just scopeInfo) + | otherwise -> do + referredMember <- withStore $ \db -> getGroupMemberByMemberId db vr user gInfo mId + -- TODO [knocking] return patched _referredMember'? + (_referredMember', scopeInfo) <- mkMemberSupportChatInfo referredMember + pure (gInfo, m, Just scopeInfo) mkGroupSupportChatInfo :: GroupInfo -> CM (GroupInfo, GroupChatScopeInfo) mkGroupSupportChatInfo gInfo@GroupInfo {membership} = @@ -1971,6 +1976,7 @@ sendGroupMessages_ _user gInfo@GroupInfo {groupId} recipientMembers events = do data MemberSendAction = MSASend Connection | MSASendBatched Connection | MSAPending | MSAForwarded +-- TODO [channels fwd] review for channels - should only directly send to chat relays, for others - MSAForwarded memberSendAction :: GroupInfo -> NonEmpty (ChatMsgEvent e) -> [GroupMember] -> GroupMember -> Maybe MemberSendAction memberSendAction gInfo events members m@GroupMember {memberRole, memberStatus} = case memberConn m of Nothing -> pendingOrForwarded @@ -2010,6 +2016,14 @@ memberSendAction gInfo events members m@GroupMember {memberRole, memberStatus} = XGrpMsgForward {} -> True _ -> False +-- Should match memberSendAction logic +readyMemberConn :: GroupMember -> Maybe (GroupMemberId, Connection) +readyMemberConn GroupMember {groupMemberId, activeConn = Just conn@Connection {connStatus}} + | (connStatus == ConnReady || connStatus == ConnSndReady) && not (connDisabled conn) && not (connInactive conn) = + Just (groupMemberId, conn) + | otherwise = Nothing +readyMemberConn GroupMember {activeConn = Nothing} = Nothing + sendGroupMemberMessage :: MsgEncodingI e => GroupInfo -> GroupMember -> ChatMsgEvent e -> Maybe Int64 -> CM () -> CM () sendGroupMemberMessage gInfo@GroupInfo {groupId} m@GroupMember {groupMemberId} chatMsgEvent introId_ postDeliver = do msg <- createSndMessage chatMsgEvent (GroupId groupId) @@ -2041,7 +2055,8 @@ saveDirectRcvMSG :: MsgEncodingI e => Connection -> MsgMeta -> MsgBody -> ChatMe saveDirectRcvMSG conn@Connection {connId} agentMsgMeta msgBody ChatMessage {chatVRange, msgId = sharedMsgId_, chatMsgEvent} = do conn' <- updatePeerChatVRange conn chatVRange let agentMsgId = fst $ recipient agentMsgMeta - newMsg = NewRcvMessage {chatMsgEvent, msgBody} + brokerTs = metaBrokerTs agentMsgMeta + newMsg = NewRcvMessage {chatMsgEvent, msgBody, brokerTs} rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta} msg <- withStore $ \db -> createNewMessageAndRcvMsgDelivery db (ConnectionId connId) newMsg sharedMsgId_ rcvMsgDelivery Nothing pure (conn', msg) @@ -2050,7 +2065,8 @@ saveGroupRcvMsg :: MsgEncodingI e => User -> GroupId -> GroupMember -> Connectio saveGroupRcvMsg user groupId authorMember conn@Connection {connId} agentMsgMeta msgBody ChatMessage {chatVRange, msgId = sharedMsgId_, chatMsgEvent} = do (am'@GroupMember {memberId = amMemId, groupMemberId = amGroupMemId}, conn') <- updateMemberChatVRange authorMember conn chatVRange let agentMsgId = fst $ recipient agentMsgMeta - newMsg = NewRcvMessage {chatMsgEvent, msgBody} + brokerTs = metaBrokerTs agentMsgMeta + newMsg = NewRcvMessage {chatMsgEvent, msgBody, brokerTs} rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta} msg <- withStore (\db -> createNewMessageAndRcvMsgDelivery db (GroupId groupId) newMsg sharedMsgId_ rcvMsgDelivery $ Just amGroupMemId) @@ -2064,11 +2080,13 @@ saveGroupRcvMsg user groupId authorMember conn@Connection {connId} agentMsgMeta _ -> throwError e pure (am', conn', msg) -saveGroupFwdRcvMsg :: MsgEncodingI e => User -> GroupId -> GroupMember -> GroupMember -> MsgBody -> ChatMessage e -> CM RcvMessage -saveGroupFwdRcvMsg user groupId forwardingMember refAuthorMember@GroupMember {memberId = refMemberId} msgBody ChatMessage {msgId = sharedMsgId_, chatMsgEvent} = do - let newMsg = NewRcvMessage {chatMsgEvent, msgBody} +saveGroupFwdRcvMsg :: MsgEncodingI e => User -> GroupId -> GroupMember -> GroupMember -> MsgBody -> ChatMessage e -> UTCTime -> CM RcvMessage +saveGroupFwdRcvMsg user groupId forwardingMember refAuthorMember@GroupMember {memberId = refMemberId} msgBody ChatMessage {msgId = sharedMsgId_, chatMsgEvent} brokerTs = do + let newMsg = NewRcvMessage {chatMsgEvent, msgBody, brokerTs} fwdMemberId = Just $ groupMemberId' forwardingMember refAuthorId = Just $ groupMemberId' refAuthorMember + -- TODO [channels fwd] recipient should deduplicate its own messages if they are forwarded back + -- TODO - it can happen when chat relay forwards a batch of messages of different senders withStore (\db -> createNewRcvMessage db (GroupId groupId) newMsg sharedMsgId_ refAuthorId fwdMemberId) `catchAllErrors` \e -> case e of ChatErrorStore (SEDuplicateGroupMessage _ _ (Just authorGroupMemberId) Nothing) -> do diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index 9ecc09004e..7dd8595f93 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/src/Simplex/Chat/Library/Subscriber.hs @@ -22,12 +22,14 @@ import Control.Monad import Control.Monad.Except import Control.Monad.IO.Unlift import Control.Monad.Reader +import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Either (lefts, partitionEithers, rights) +import Data.Foldable (foldr') import Data.Functor (($>)) import Data.Int (Int64) -import Data.List (foldl') -import Data.List.NonEmpty (NonEmpty (..), (<|)) +import Data.List (find, foldl') +import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M @@ -41,8 +43,10 @@ import qualified Data.UUID.V4 as V4 import Data.Word (Word32) import Simplex.Chat.Call import Simplex.Chat.Controller +import Simplex.Chat.Delivery import Simplex.Chat.Library.Internal import Simplex.Chat.Messages +import Simplex.Chat.Messages.Batch (batchDeliveryTasks1) import Simplex.Chat.Messages.CIContent import Simplex.Chat.Messages.CIContent.Events import Simplex.Chat.ProfileGenerator (generateRandomProfile) @@ -51,6 +55,7 @@ import Simplex.Chat.Store import Simplex.Chat.Store.Connections import Simplex.Chat.Store.ContactRequest import Simplex.Chat.Store.Direct +import Simplex.Chat.Store.Delivery import Simplex.Chat.Store.Files import Simplex.Chat.Store.Groups import Simplex.Chat.Store.Messages @@ -65,6 +70,8 @@ import Simplex.FileTransfer.Protocol (FilePartyI) import qualified Simplex.FileTransfer.Transport as XFTP import Simplex.FileTransfer.Types (FileErrorType (..), RcvFileId, SndFileId) import Simplex.Messaging.Agent as Agent +import Simplex.Messaging.Agent.Client (getAgentWorker, waitForWork, withWork_, withWorkItems) +import Simplex.Messaging.Agent.Env.SQLite (Worker (..)) import Simplex.Messaging.Agent.Protocol import qualified Simplex.Messaging.Agent.Protocol as AP (AgentErrorType (..)) import qualified Simplex.Messaging.Agent.Store.DB as DB @@ -228,14 +235,8 @@ processAgentMsgSndFile _corrId aFileId msg = do memberFTs :: [GroupMember] -> [(Connection, SndFileTransfer)] memberFTs ms = M.elems $ M.intersectionWith (,) (M.fromList mConns') (M.fromList sfts') where - mConns' = mapMaybe useMember ms + mConns' = mapMaybe readyMemberConn ms sfts' = mapMaybe (\sft@SndFileTransfer {groupMemberId} -> (,sft) <$> groupMemberId) sfts - -- Should match memberSendAction logic - useMember GroupMember {groupMemberId, activeConn = Just conn@Connection {connStatus}} - | (connStatus == ConnReady || connStatus == ConnSndReady) && not (connDisabled conn) && not (connInactive conn) = - Just (groupMemberId, conn) - | otherwise = Nothing - useMember _ = Nothing _ -> pure () _ -> pure () -- TODO error? SFWARN e -> do @@ -898,12 +899,11 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = -- possible improvement is to choose scope based on event (some events specify scope) (gInfo', m', scopeInfo) <- mkGroupChatScope gInfo m checkIntegrityCreateItem (CDGroupRcv gInfo' scopeInfo m') msgMeta `catchAllErrors` \_ -> pure () - (fwdScopesMsgs, shouldDelConns) <- foldM (processAChatMsg gInfo' m' tags eInfo) (M.empty, False) aChatMsgs - when (isUserGrpFwdRelay gInfo') $ do - unless (blockedByAdmin m) $ - forM_ (M.assocs fwdScopesMsgs) $ \(groupForwardScope, fwdMsgs) -> - forwardMsgs groupForwardScope (L.reverse fwdMsgs) `catchAllErrors` eToView - when shouldDelConns $ deleteGroupConnections gInfo' True + newDeliveryTasks <- reverse <$> foldM (processAChatMsg gInfo' m' tags eInfo) [] aChatMsgs + shouldDelConns <- + if isUserGrpFwdRelay gInfo' && not (blockedByAdmin m) + then createDeliveryTasks gInfo' m' newDeliveryTasks + else pure False withRcpt <- checkSendRcpt $ rights aChatMsgs pure (withRcpt, shouldDelConns) where @@ -914,72 +914,69 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = -> GroupMember -> TVar [Text] -> Text - -> (Map GroupForwardScope (NonEmpty (ChatMessage 'Json)), ShouldDeleteGroupConns) + -> [NewMessageDeliveryTask] -> Either String AChatMessage - -> CM (Map GroupForwardScope (NonEmpty (ChatMessage 'Json)), ShouldDeleteGroupConns) - processAChatMsg gInfo' m' tags eInfo (fwdScopeMap, shouldDelConns) = \case + -> CM [NewMessageDeliveryTask] + processAChatMsg gInfo' m' tags eInfo newDeliveryTasks = \case Right (ACMsg SJson chatMsg) -> do - (cmFwdScope_, cmShouldDelConns) <- - processEvent gInfo' m' tags eInfo chatMsg `catchAllErrors` \e -> eToView e $> (Nothing, False) - let fwdScopeMap' = - case cmFwdScope_ of - Nothing -> fwdScopeMap - Just cmFwdScope -> M.alter (Just . maybe [chatMsg] (chatMsg <|)) cmFwdScope fwdScopeMap - shouldDelConns' = shouldDelConns || cmShouldDelConns - pure (fwdScopeMap', shouldDelConns') + newTask_ <- processEvent gInfo' m' tags eInfo chatMsg `catchAllErrors` \e -> eToView e $> Nothing + pure $ maybe newDeliveryTasks (: newDeliveryTasks) newTask_ Right (ACMsg SBinary chatMsg) -> do void (processEvent gInfo' m' tags eInfo chatMsg) `catchAllErrors` \e -> eToView e - pure (fwdScopeMap, shouldDelConns) + pure newDeliveryTasks Left e -> do atomically $ modifyTVar' tags ("error" :) logInfo $ "group msg=error " <> eInfo <> " " <> tshow e eToView (ChatError . CEException $ "error parsing chat message: " <> e) - pure (fwdScopeMap, shouldDelConns) - processEvent :: forall e. MsgEncodingI e => GroupInfo -> GroupMember -> TVar [Text] -> Text -> ChatMessage e -> CM (Maybe GroupForwardScope, ShouldDeleteGroupConns) + pure newDeliveryTasks + processEvent :: forall e. MsgEncodingI e => GroupInfo -> GroupMember -> TVar [Text] -> Text -> ChatMessage e -> CM (Maybe NewMessageDeliveryTask) processEvent gInfo' m' tags eInfo chatMsg@ChatMessage {chatMsgEvent} = do let tag = toCMEventTag chatMsgEvent atomically $ modifyTVar' tags (tshow tag :) logInfo $ "group msg=" <> tshow tag <> " " <> eInfo let body = chatMsgToBody chatMsg - (m'', conn', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveGroupRcvMsg user groupId m' conn msgMeta body chatMsg - -- ! see isForwardedGroupMsg: processing functions should return GroupForwardScope for same events - case event of - XMsgNew mc -> memberCanSend m'' scope $ (,False) <$> newGroupContentMessage gInfo' m'' mc msg brokerTs False + (m'', conn', msg@RcvMessage {msgId, chatMsgEvent = ACME _ event}) <- saveGroupRcvMsg user groupId m' conn msgMeta body chatMsg + -- ! see isForwardedGroupMsg: processing functions should return DeliveryJobScope for same events + deliveryJobScope_ <- case event of + XMsgNew mc -> memberCanSend m'' scope $ newGroupContentMessage gInfo' m'' mc msg brokerTs False where ExtMsgContent {scope} = mcExtMsgContent mc -- file description is always allowed, to allow sending files to support scope - XMsgFileDescr sharedMsgId fileDescr -> (,False) <$> groupMessageFileDescription gInfo' m'' sharedMsgId fileDescr - XMsgUpdate sharedMsgId mContent mentions ttl live msgScope -> memberCanSend m'' msgScope $ (,False) <$> groupMessageUpdate gInfo' m'' sharedMsgId mContent mentions msgScope msg brokerTs ttl live - XMsgDel sharedMsgId memberId scope_ -> (,False) <$> groupMessageDelete gInfo' m'' sharedMsgId memberId scope_ msg brokerTs - XMsgReact sharedMsgId (Just memberId) scope_ reaction add -> (,False) <$> groupMsgReaction gInfo' m'' sharedMsgId memberId scope_ reaction add msg brokerTs + XMsgFileDescr sharedMsgId fileDescr -> groupMessageFileDescription gInfo' m'' sharedMsgId fileDescr + XMsgUpdate sharedMsgId mContent mentions ttl live msgScope -> memberCanSend m'' msgScope $ groupMessageUpdate gInfo' m'' sharedMsgId mContent mentions msgScope msg brokerTs ttl live + XMsgDel sharedMsgId memberId scope_ -> groupMessageDelete gInfo' m'' sharedMsgId memberId scope_ msg brokerTs + XMsgReact sharedMsgId (Just memberId) scope_ reaction add -> groupMsgReaction gInfo' m'' sharedMsgId memberId scope_ reaction add msg brokerTs -- TODO discontinue XFile - XFile fInv -> (Nothing, False) <$ processGroupFileInvitation' gInfo' m'' fInv msg brokerTs - XFileCancel sharedMsgId -> (,False) <$> xFileCancelGroup gInfo' m'' sharedMsgId - XFileAcptInv sharedMsgId fileConnReq_ fName -> (Nothing, False) <$ xFileAcptInvGroup gInfo' m'' sharedMsgId fileConnReq_ fName - XInfo p -> (,False) <$> xInfoMember gInfo' m'' p brokerTs - XGrpLinkMem p -> (Nothing, False) <$ xGrpLinkMem gInfo' m'' conn' p - XGrpLinkAcpt acceptance role memberId -> (Nothing, False) <$ xGrpLinkAcpt gInfo' m'' acceptance role memberId msg brokerTs - XGrpMemNew memInfo msgScope -> (,False) <$> xGrpMemNew gInfo' m'' memInfo msgScope msg brokerTs - XGrpMemIntro memInfo memRestrictions_ -> (Nothing, False) <$ xGrpMemIntro gInfo' m'' memInfo memRestrictions_ - XGrpMemInv memId introInv -> (Nothing, False) <$ xGrpMemInv gInfo' m'' memId introInv - XGrpMemFwd memInfo introInv -> (Nothing, False) <$ xGrpMemFwd gInfo' m'' memInfo introInv - XGrpMemRole memId memRole -> (,False) <$> xGrpMemRole gInfo' m'' memId memRole msg brokerTs - XGrpMemRestrict memId memRestrictions -> (,False) <$> xGrpMemRestrict gInfo' m'' memId memRestrictions msg brokerTs - XGrpMemCon memId -> (Nothing, False) <$ xGrpMemCon gInfo' m'' memId + XFile fInv -> Nothing <$ processGroupFileInvitation' gInfo' m'' fInv msg brokerTs + XFileCancel sharedMsgId -> xFileCancelGroup gInfo' m'' sharedMsgId + XFileAcptInv sharedMsgId fileConnReq_ fName -> Nothing <$ xFileAcptInvGroup gInfo' m'' sharedMsgId fileConnReq_ fName + XInfo p -> xInfoMember gInfo' m'' p brokerTs + XGrpLinkMem p -> Nothing <$ xGrpLinkMem gInfo' m'' conn' p + XGrpLinkAcpt acceptance role memberId -> Nothing <$ xGrpLinkAcpt gInfo' m'' acceptance role memberId msg brokerTs + XGrpMemNew memInfo msgScope -> xGrpMemNew gInfo' m'' memInfo msgScope msg brokerTs + XGrpMemIntro memInfo memRestrictions_ -> Nothing <$ xGrpMemIntro gInfo' m'' memInfo memRestrictions_ + XGrpMemInv memId introInv -> Nothing <$ xGrpMemInv gInfo' m'' memId introInv + XGrpMemFwd memInfo introInv -> Nothing <$ xGrpMemFwd gInfo' m'' memInfo introInv + XGrpMemRole memId memRole -> xGrpMemRole gInfo' m'' memId memRole msg brokerTs + XGrpMemRestrict memId memRestrictions -> xGrpMemRestrict gInfo' m'' memId memRestrictions msg brokerTs + XGrpMemCon memId -> Nothing <$ xGrpMemCon gInfo' m'' memId XGrpMemDel memId withMessages -> case encoding @e of SJson -> xGrpMemDel gInfo' m'' memId withMessages chatMsg msg brokerTs False - SBinary -> pure (Nothing, False) -- impossible - XGrpLeave -> (,False) <$> xGrpLeave gInfo' m'' msg brokerTs - XGrpDel -> (Just GFSAll, True) <$ xGrpDel gInfo' m'' msg brokerTs - XGrpInfo p' -> (,False) <$> xGrpInfo gInfo' m'' p' msg brokerTs - XGrpPrefs ps' -> (,False) <$> xGrpPrefs gInfo' m'' ps' + SBinary -> pure Nothing -- impossible + XGrpLeave -> xGrpLeave gInfo' m'' msg brokerTs + XGrpDel -> Just (DJSGroup {jobSpec = DJRelayRemoved}) <$ xGrpDel gInfo' m'' msg brokerTs + XGrpInfo p' -> xGrpInfo gInfo' m'' p' msg brokerTs + XGrpPrefs ps' -> xGrpPrefs gInfo' m'' ps' -- TODO [knocking] why don't we forward these messages? - XGrpDirectInv connReq mContent_ msgScope -> memberCanSend m'' msgScope $ (Nothing, False) <$ xGrpDirectInv gInfo' m'' conn' connReq mContent_ msg brokerTs - XGrpMsgForward memberId memberName msg' msgTs -> (Nothing, False) <$ xGrpMsgForward gInfo' m'' memberId memberName msg' msgTs - XInfoProbe probe -> (Nothing, False) <$ xInfoProbe (COMGroupMember m'') probe - XInfoProbeCheck probeHash -> (Nothing, False) <$ xInfoProbeCheck (COMGroupMember m'') probeHash - XInfoProbeOk probe -> (Nothing, False) <$ xInfoProbeOk (COMGroupMember m'') probe - BFileChunk sharedMsgId chunk -> (Nothing, False) <$ bFileChunkGroup gInfo' sharedMsgId chunk msgMeta - _ -> (Nothing, False) <$ messageError ("unsupported message: " <> tshow event) + XGrpDirectInv connReq mContent_ msgScope -> memberCanSend m'' msgScope $ Nothing <$ xGrpDirectInv gInfo' m'' conn' connReq mContent_ msg brokerTs + XGrpMsgForward memberId memberName msg' msgTs -> Nothing <$ xGrpMsgForward gInfo' m'' memberId memberName msg' msgTs brokerTs + XInfoProbe probe -> Nothing <$ xInfoProbe (COMGroupMember m'') probe + XInfoProbeCheck probeHash -> Nothing <$ xInfoProbeCheck (COMGroupMember m'') probeHash + XInfoProbeOk probe -> Nothing <$ xInfoProbeOk (COMGroupMember m'') probe + BFileChunk sharedMsgId chunk -> Nothing <$ bFileChunkGroup gInfo' sharedMsgId chunk msgMeta + _ -> Nothing <$ messageError ("unsupported message: " <> tshow event) + forM deliveryJobScope_ $ \jobScope -> + -- TODO [channels fwd] XMsgNew to return messageFromChannel + pure $ NewMessageDeliveryTask {messageId = msgId, jobScope, messageFromChannel = False} checkSendRcpt :: [AChatMessage] -> CM Bool checkSendRcpt aMsgs = do currentMemCount <- withStore' $ \db -> getGroupCurrentMembersCount db user gInfo @@ -991,58 +988,34 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = where aChatMsgHasReceipt (ACMsg _ ChatMessage {chatMsgEvent}) = hasDeliveryReceipt (toCMEventTag chatMsgEvent) - -- TODO forwardMsgs member retrieval can be further optimized: - -- - move remaining filters to SQL (memberCurrentOrPending, memberCurrent) - -- - create new GroupForwardScope for reports to avoid post-filtering moderators in msgsForwardedToMember - -- as an additional step, instead initially retrieve only moderators - -- (reuse getForwardIntroducedModerators, getForwardInvitedModerators + filters) - -- - new GroupForwardScope for excluding members on XGrpMemRestrict - forwardMsgs :: GroupForwardScope -> NonEmpty (ChatMessage 'Json) -> CM () - forwardMsgs groupForwardScope fwdMsgs = do - ms <- buildMemberList - let GroupMember {memberId} = m - memberName = Just $ memberShortenedName m - events = L.map (\cm -> XGrpMsgForward memberId memberName cm brokerTs) fwdMsgs - unless (null ms) $ void $ sendGroupMessages_ user gInfo ms events + createDeliveryTasks :: GroupInfo -> GroupMember -> [NewMessageDeliveryTask] -> CM ShouldDeleteGroupConns + createDeliveryTasks gInfo'@GroupInfo {groupId = gId} m' newDeliveryTasks = do + let relayRemovedTask_ = find (\NewMessageDeliveryTask {jobScope} -> isRelayRemoved jobScope) newDeliveryTasks + createdDeliveryTasks <- case relayRemovedTask_ of + Nothing -> do + withStore' $ \db -> + forM_ newDeliveryTasks $ \newTask -> + createMsgDeliveryTask db gInfo' m' newTask + pure newDeliveryTasks + Just relayRemovedTask -> do + -- if relay is removed, delete all other tasks and jobs + withStore' $ \db -> do + deleteGroupDeliveryTasks db gInfo' + deleteGroupDeliveryJobs db gInfo' + createMsgDeliveryTask db gInfo' m' relayRemovedTask + pure [relayRemovedTask] + lift $ forM_ (uniqueWorkerScopes createdDeliveryTasks) $ \workerScope -> + getDeliveryTaskWorker True (gId, workerScope) + pure $ isJust relayRemovedTask_ where - buildMemberList = case groupForwardScope of - GFSAll -> do - ms <- getAllIntroducedAndInvited - pure $ filter (\mem -> memberCurrentOrPending mem && msgsForwardedToMember fwdMsgs mem) ms - GFSMain -> do - ms <- getAllIntroducedAndInvited - pure $ filter (\mem -> memberCurrent mem && msgsForwardedToMember fwdMsgs mem) ms - GFSMemberSupport scopeGMId -> do - -- moderators introduced to this invited member - introducedModMs <- - if memberCategory m == GCInviteeMember - then withStore' $ \db -> getForwardIntroducedModerators db vr user m - else pure [] - -- invited moderators to which this member was introduced - invitedModMs <- withStore' $ \db -> getForwardInvitedModerators db vr user m - let modMs = introducedModMs <> invitedModMs - moderatorFilter mem = - memberCurrent mem - && maxVersion (memberChatVRange mem) >= groupKnockingVersion - && msgsForwardedToMember fwdMsgs mem - modMs' = filter moderatorFilter modMs - if scopeGMId == groupMemberId' m - then pure modMs' - else - withStore' (\db -> getForwardScopeMember db vr user m scopeGMId) >>= \case - Just scopeMem | msgsForwardedToMember fwdMsgs scopeMem -> pure $ scopeMem : modMs' - _ -> pure modMs' + uniqueWorkerScopes :: [NewMessageDeliveryTask] -> [DeliveryWorkerScope] + uniqueWorkerScopes createdDeliveryTasks = + let workerScopes = map (\NewMessageDeliveryTask {jobScope} -> toWorkerScope jobScope) createdDeliveryTasks + in foldr' addWorkerScope [] workerScopes where - getAllIntroducedAndInvited = do - ChatConfig {highlyAvailable} <- asks config - -- members introduced to this invited member - introducedMembers <- - if memberCategory m == GCInviteeMember - then withStore' $ \db -> getForwardIntroducedMembers db vr user m highlyAvailable - else pure [] - -- invited members to which this member was introduced - invitedMembers <- withStore' $ \db -> getForwardInvitedMembers db vr user m highlyAvailable - pure $ introducedMembers <> invitedMembers + addWorkerScope workerScope acc + | workerScope `elem` acc = acc + | otherwise = workerScope : acc RCVD msgMeta msgRcpt -> withAckMessage' "group rcvd" agentConnId msgMeta $ groupMsgReceived gInfo m conn msgMeta msgRcpt @@ -1484,13 +1457,13 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = memberCanSend :: GroupMember -> Maybe MsgScope -> - CM (Maybe GroupForwardScope, ShouldDeleteGroupConns) -> - CM (Maybe GroupForwardScope, ShouldDeleteGroupConns) + CM (Maybe DeliveryJobScope) -> + CM (Maybe DeliveryJobScope) memberCanSend m@GroupMember {memberRole} msgScope a = case msgScope of Just MSMember {} -> a Nothing | memberRole > GRObserver || memberPending m -> a - | otherwise -> messageError "member is not allowed to send messages" $> (Nothing, False) + | otherwise -> messageError "member is not allowed to send messages" $> Nothing processConnMERR :: ConnectionEntity -> Connection -> AgentErrorType -> CM () processConnMERR connEntity conn err = do @@ -1725,7 +1698,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = pure (fileId, aci) processFDMessage fileId aci fileDescr - groupMessageFileDescription :: GroupInfo -> GroupMember -> SharedMsgId -> FileDescr -> CM (Maybe GroupForwardScope) + groupMessageFileDescription :: GroupInfo -> GroupMember -> SharedMsgId -> FileDescr -> CM (Maybe DeliveryJobScope) groupMessageFileDescription g@GroupInfo {groupId} GroupMember {memberId} sharedMsgId fileDescr = do (fileId, aci) <- withStore $ \db -> do fileId <- getGroupFileIdBySharedMsgId db userId groupId sharedMsgId @@ -1739,7 +1712,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = -- for example failure on not approved relays (CEFileNotApproved). -- we catch error, so that even if processFDMessage fails, message can still be forwarded. processFDMessage fileId aci fileDescr `catchAllErrors` \_ -> pure () - pure $ Just $ toGroupForwardScope g scopeInfo + pure $ Just $ infoToDeliveryScope g scopeInfo else messageError "x.msg.file.descr: file of another member" $> Nothing _ -> messageError "x.msg.file.descr: invalid file description part" $> Nothing @@ -1860,7 +1833,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = else pure Nothing mapM_ toView cEvt_ - groupMsgReaction :: GroupInfo -> GroupMember -> SharedMsgId -> MemberId -> Maybe MsgScope -> MsgReaction -> Bool -> RcvMessage -> UTCTime -> CM (Maybe GroupForwardScope) + groupMsgReaction :: GroupInfo -> GroupMember -> SharedMsgId -> MemberId -> Maybe MsgScope -> MsgReaction -> Bool -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope) groupMsgReaction g m@GroupMember {memberRole} sharedMsgId itemMemberId scope_ reaction add RcvMessage {msgId} brokerTs | groupFeatureAllowed SGFReactions g = do rs <- withStore' $ \db -> getGroupReactions db g m itemMemberId sharedMsgId False @@ -1871,11 +1844,11 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = | memberRole >= GRModerator || scopeMemberId == memberId' m -> withStore $ \db -> do liftIO $ setGroupReaction db g m itemMemberId sharedMsgId False reaction add msgId brokerTs - Just . GFSMemberSupport <$> getScopeMemberIdViaMemberId db user g m scopeMemberId + Just . DJSMemberSupport <$> getScopeMemberIdViaMemberId db user g m scopeMemberId | otherwise -> pure Nothing Nothing -> do withStore' $ \db -> setGroupReaction db g m itemMemberId sharedMsgId False reaction add msgId brokerTs - pure $ Just GFSMain + pure $ Just DJSGroup {jobSpec = DJDeliveryJob {includePending = False}} else pure Nothing | otherwise = pure Nothing where @@ -1892,7 +1865,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = let ci' = CChatItem md ci {reactions} r = ACIReaction SCTGroup SMDRcv (GroupChat g scopeInfo) $ CIReaction (CIGroupRcv m) ci' brokerTs reaction toView $ CEvtChatItemReaction user add r - pure $ Just $ toGroupForwardScope g scopeInfo + pure $ Just $ infoToDeliveryScope g scopeInfo else pure Nothing reactionAllowed :: Bool -> MsgReaction -> [MsgReaction] -> Bool @@ -1904,9 +1877,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = ChatErrorStore (SEChatItemSharedMsgIdNotFound sharedMsgId) -> handle sharedMsgId e -> throwError e - newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> UTCTime -> Bool -> CM (Maybe GroupForwardScope) + newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> UTCTime -> Bool -> CM (Maybe DeliveryJobScope) newGroupContentMessage gInfo m@GroupMember {memberId, memberRole} mc msg@RcvMessage {sharedMsgId_} brokerTs forwarded = do - (gInfo', m', scopeInfo) <- mkGetMessageChatScope vr user gInfo m msgScope_ + (gInfo', m', scopeInfo) <- mkGetMessageChatScope vr user gInfo m content msgScope_ if blockedByAdmin m' then createBlockedByAdmin gInfo' m' scopeInfo $> Nothing else @@ -1920,7 +1893,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = pure Nothing Nothing -> do createContentItem gInfo' m' scopeInfo - pure $ Just $ toGroupForwardScope gInfo scopeInfo + pure $ Just $ infoToDeliveryScope gInfo scopeInfo where rejected gInfo' m' scopeInfo f = newChatItem gInfo' m' scopeInfo (ciContentNoParse $ CIRcvGroupFeatureRejected f) Nothing Nothing False timed' gInfo' = if forwarded then rcvCITimed_ (Just Nothing) itemTTL else rcvGroupCITimed gInfo' itemTTL @@ -1966,7 +1939,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getGroupCIReactions db gInfo' memberId sharedMsgId) sharedMsgId_ groupMsgToView cInfo ci' {reactions} - groupMessageUpdate :: GroupInfo -> GroupMember -> SharedMsgId -> MsgContent -> Map MemberName MsgMention -> Maybe MsgScope -> RcvMessage -> UTCTime -> Maybe Int -> Maybe Bool -> CM (Maybe GroupForwardScope) + groupMessageUpdate :: GroupInfo -> GroupMember -> SharedMsgId -> MsgContent -> Map MemberName MsgMention -> Maybe MsgScope -> RcvMessage -> UTCTime -> Maybe Int -> Maybe Bool -> CM (Maybe DeliveryJobScope) groupMessageUpdate gInfo@GroupInfo {groupId} m@GroupMember {groupMemberId, memberId} sharedMsgId mc mentions msgScope_ msg@RcvMessage {msgId} brokerTs ttl_ live_ | prohibitedSimplexLinks gInfo m ft_ = messageWarning ("x.msg.update ignored: feature not allowed " <> groupFeatureNameText GFSimplexLinks) $> Nothing @@ -1977,14 +1950,14 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = -- Chat item and update message which created it will have different sharedMsgId in this case... let timed_ = rcvGroupCITimed gInfo ttl_ mentions' = if memberBlocked m then [] else mentions - (gInfo', m', scopeInfo) <- mkGetMessageChatScope vr user gInfo m msgScope_ + (gInfo', m', scopeInfo) <- mkGetMessageChatScope vr user gInfo m mc msgScope_ (ci, cInfo) <- saveRcvChatItem' user (CDGroupRcv gInfo' scopeInfo m') msg (Just sharedMsgId) brokerTs (content, ts) Nothing timed_ live mentions' ci' <- withStore' $ \db -> do createChatItemVersion db (chatItemId' ci) brokerTs mc updateGroupChatItem db user groupId ci content True live Nothing ci'' <- blockedMemberCI gInfo' m' ci' toView $ CEvtChatItemUpdated user (AChatItem SCTGroup SMDRcv cInfo ci'') - pure $ Just $ toGroupForwardScope gInfo scopeInfo + pure $ Just $ infoToDeliveryScope gInfo scopeInfo where content = CIRcvMsgContent mc ts@(_, ft_) = msgContentTexts mc @@ -2009,14 +1982,14 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = updateGroupCIMentions db gInfo ci' ciMentions toView $ CEvtChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo scopeInfo) ci') startUpdatedTimedItemThread user (ChatRef CTGroup groupId $ toChatScope <$> scopeInfo) ci ci' - pure $ Just $ toGroupForwardScope gInfo scopeInfo + pure $ Just $ infoToDeliveryScope gInfo scopeInfo else do toView $ CEvtChatItemNotChanged user (AChatItem SCTGroup SMDRcv (GroupChat gInfo scopeInfo) ci) pure Nothing else messageError "x.msg.update: group member attempted to update a message of another member" $> Nothing _ -> messageError "x.msg.update: group member attempted invalid message update" $> Nothing - groupMessageDelete :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe MemberId -> Maybe MsgScope -> RcvMessage -> UTCTime -> CM (Maybe GroupForwardScope) + groupMessageDelete :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe MemberId -> Maybe MsgScope -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope) groupMessageDelete gInfo@GroupInfo {membership} m@GroupMember {memberId, memberRole = senderRole} sharedMsgId sndMemberId_ scope_ RcvMessage {msgId} brokerTs = do let msgMemberId = fromMaybe memberId sndMemberId_ withStore' (\db -> runExceptT $ getGroupMemberCIBySharedMsgId db user gInfo msgMemberId sharedMsgId) >>= \case @@ -2045,32 +2018,32 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = Just (MSMember scopeMemberId) -> withStore $ \db -> do liftIO $ createCIModeration db gInfo m msgMemberId sharedMsgId msgId brokerTs - Just . GFSMemberSupport <$> getScopeMemberIdViaMemberId db user gInfo m scopeMemberId + Just . DJSMemberSupport <$> getScopeMemberIdViaMemberId db user gInfo m scopeMemberId Nothing -> do withStore' $ \db -> createCIModeration db gInfo m msgMemberId sharedMsgId msgId brokerTs - pure $ Just GFSMain + pure $ Just DJSGroup {jobSpec = DJDeliveryJob {includePending = False}} where - moderate :: GroupMember -> CChatItem 'CTGroup -> CM (Maybe GroupForwardScope) + moderate :: GroupMember -> CChatItem 'CTGroup -> CM (Maybe DeliveryJobScope) moderate mem cci = case sndMemberId_ of Just sndMemberId | sameMemberId sndMemberId mem -> checkRole mem $ do - groupForwardScope <- delete cci (Just m) + jobScope <- delete cci (Just m) archiveMessageReports cci m - pure $ Just groupForwardScope + pure $ Just jobScope | otherwise -> messageError "x.msg.del: message of another member with incorrect memberId" $> Nothing _ -> messageError "x.msg.del: message of another member without memberId" $> Nothing checkRole GroupMember {memberRole} a | senderRole < GRModerator || senderRole < memberRole = messageError "x.msg.del: message of another member with insufficient member permissions" $> Nothing | otherwise = a - delete :: CChatItem 'CTGroup -> Maybe GroupMember -> CM GroupForwardScope + delete :: CChatItem 'CTGroup -> Maybe GroupMember -> CM DeliveryJobScope delete cci byGroupMember = do scopeInfo <- withStore $ \db -> getGroupChatScopeInfoForItem db vr user gInfo (cChatItemId cci) deletions <- if groupFeatureMemberAllowed SGFFullDelete m gInfo then deleteGroupCIs user gInfo scopeInfo [cci] byGroupMember brokerTs else markGroupCIsDeleted user gInfo scopeInfo [cci] byGroupMember brokerTs toView $ CEvtChatItemsDeleted user deletions False False - pure $ toGroupForwardScope gInfo scopeInfo + pure $ infoToDeliveryScope gInfo scopeInfo archiveMessageReports :: CChatItem 'CTGroup -> GroupMember -> CM () archiveMessageReports (CChatItem _ ci) byMember = do ciIds <- withStore' $ \db -> markMessageReportsDeleted db user gInfo ci byMember brokerTs @@ -2211,7 +2184,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = _ -> pure () receiveFileChunk ft Nothing meta chunk - xFileCancelGroup :: GroupInfo -> GroupMember -> SharedMsgId -> CM (Maybe GroupForwardScope) + xFileCancelGroup :: GroupInfo -> GroupMember -> SharedMsgId -> CM (Maybe DeliveryJobScope) xFileCancelGroup g@GroupInfo {groupId} GroupMember {memberId} sharedMsgId = do (fileId, aci) <- withStore $ \db -> do fileId <- getGroupFileIdBySharedMsgId db userId groupId sharedMsgId @@ -2225,7 +2198,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = unless (rcvFileCompleteOrCancelled ft) $ do cancelRcvFileTransfer user ft >>= mapM_ deleteAgentConnectionAsync toView $ CEvtRcvFileSndCancelled user aci ft - pure $ Just $ toGroupForwardScope g scopeInfo + pure $ Just $ infoToDeliveryScope g scopeInfo else -- shouldn't happen now that query includes group member id messageError "x.file.cancel: group member attempted to cancel file of another member" $> Nothing @@ -2368,10 +2341,10 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = Profile {displayName = n, fullName = fn, shortDescr = sd, image = i, contactLink = cl} = p Profile {displayName = n', fullName = fn', shortDescr = sd', image = i', contactLink = cl'} = p' - xInfoMember :: GroupInfo -> GroupMember -> Profile -> UTCTime -> CM (Maybe GroupForwardScope) + xInfoMember :: GroupInfo -> GroupMember -> Profile -> UTCTime -> CM (Maybe DeliveryJobScope) xInfoMember gInfo m p' brokerTs = do void $ processMemberProfileUpdate gInfo m p' True (Just brokerTs) - pure $ memberEventForwardScope m + pure $ memberEventDeliveryScope m xGrpLinkMem :: GroupInfo -> GroupMember -> Connection -> Profile -> CM () xGrpLinkMem gInfo@GroupInfo {membership, businessChat} m@GroupMember {groupMemberId, memberCategory} Connection {viaGroupLink} p' = do @@ -2391,7 +2364,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memberId) >>= \case Left _ -> messageError "x.grp.link.acpt error: referenced member does not exist" Right referencedMember -> do - (referencedMember', gInfo') <- withFastStore' $ \db -> do + (referencedMember', gInfo') <- withStore' $ \db -> do referencedMember' <- updateGroupMemberAccepted db user referencedMember (newMemberStatus referencedMember) role gInfo' <- updateGroupMembersRequireAttention db user gInfo referencedMember referencedMember' pure (referencedMember', gInfo') @@ -2750,7 +2723,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = -- TODO show/log error, other events in SMP confirmation _ -> pure (conn', False) - xGrpMemNew :: GroupInfo -> GroupMember -> MemberInfo -> Maybe MsgScope -> RcvMessage -> UTCTime -> CM (Maybe GroupForwardScope) + xGrpMemNew :: GroupInfo -> GroupMember -> MemberInfo -> Maybe MsgScope -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope) xGrpMemNew gInfo m memInfo@(MemberInfo memId memRole _ _) msgScope_ msg brokerTs = do checkHostRole m memRole if sameMemberId memId (membership gInfo) @@ -2766,7 +2739,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = pure (updatedMember, gInfo') toView $ CEvtUnknownMemberAnnounced user gInfo' m unknownMember updatedMember memberAnnouncedToView updatedMember gInfo' - pure $ forwardScope updatedMember + pure $ deliveryJobScope updatedMember Right _ -> messageError "x.grp.mem.new error: member already exists" $> Nothing Left _ -> do (newMember, gInfo') <- withStore $ \db -> do @@ -2776,15 +2749,15 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = else pure gInfo pure (newMember, gInfo') memberAnnouncedToView newMember gInfo' - pure $ forwardScope newMember + pure $ deliveryJobScope newMember where initialStatus = case msgScope_ of Just (MSMember _) -> GSMemPendingReview _ -> GSMemAnnounced - forwardScope GroupMember {groupMemberId, memberStatus} + deliveryJobScope GroupMember {groupMemberId, memberStatus} | memberStatus == GSMemPendingApproval = Nothing - | memberStatus == GSMemPendingReview = Just $ GFSMemberSupport groupMemberId - | otherwise = Just GFSMain + | memberStatus == GSMemPendingReview = Just $ DJSMemberSupport groupMemberId + | otherwise = Just DJSGroup {jobSpec = DJDeliveryJob {includePending = False}} memberAnnouncedToView announcedMember@GroupMember {groupMemberId, memberProfile} gInfo' = do (announcedMember', scopeInfo) <- getMemNewChatScope announcedMember let event = RGEMemberAdded groupMemberId (fromLocalProfile memberProfile) @@ -2872,7 +2845,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = chatV = vr `peerConnChatVersion` mcvr withStore' $ \db -> createIntroToMemberContact db user m toMember chatV mcvr groupConnIds directConnIds customUserProfileId subMode - xGrpMemRole :: GroupInfo -> GroupMember -> MemberId -> GroupMemberRole -> RcvMessage -> UTCTime -> CM (Maybe GroupForwardScope) + xGrpMemRole :: GroupInfo -> GroupMember -> MemberId -> GroupMemberRole -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope) xGrpMemRole gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId memRole msg brokerTs | membershipMemId == memId = let gInfo' = gInfo {membership = membership {memberRole = memRole}} @@ -2892,13 +2865,13 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = (ci, cInfo) <- saveRcvChatItemNoParse user (CDGroupRcv gInfo'' scopeInfo m') msg brokerTs (CIRcvGroupEvent gEvent) groupMsgToView cInfo ci toView CEvtMemberRole {user, groupInfo = gInfo'', byMember = m', member = member {memberRole = memRole}, fromRole, toRole = memRole} - pure $ memberEventForwardScope member + pure $ memberEventDeliveryScope member checkHostRole :: GroupMember -> GroupMemberRole -> CM () checkHostRole GroupMember {memberRole, localDisplayName} memRole = when (memberRole < GRAdmin || memberRole < memRole) $ throwChatError (CEGroupContactRole localDisplayName) - xGrpMemRestrict :: GroupInfo -> GroupMember -> MemberId -> MemberRestrictions -> RcvMessage -> UTCTime -> CM (Maybe GroupForwardScope) + xGrpMemRestrict :: GroupInfo -> GroupMember -> MemberId -> MemberRestrictions -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope) xGrpMemRestrict gInfo@GroupInfo {membership = GroupMember {memberId = membershipMemId}} m@GroupMember {memberRole = senderRole} @@ -2906,9 +2879,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = MemberRestrictions {restriction} msg brokerTs - | membershipMemId == memId = - -- member shouldn't receive this message about themselves - messageError "x.grp.mem.restrict: admin blocks you" $> Nothing + | membershipMemId == memId = pure Nothing -- ignore - XGrpMemRestrict can be sent to restricted member for efficiency | otherwise = withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case Right bm@GroupMember {groupMemberId = bmId, memberRole, blockedByAdmin, memberProfile = bmp} @@ -2923,12 +2894,12 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = (ci, cInfo) <- saveRcvChatItemNoParse user (CDGroupRcv gInfo' scopeInfo m') msg brokerTs ciContent groupMsgToView cInfo ci toView CEvtMemberBlockedForAll {user, groupInfo = gInfo', byMember = m', member = bm', blocked} - pure $ memberEventForwardScope bm + pure $ memberEventDeliveryScope bm Left (SEGroupMemberNotFoundByMemberId _) -> do bm <- createUnknownMember gInfo memId Nothing bm' <- setMemberBlocked bm toView $ CEvtUnknownMemberBlocked user gInfo m bm' - pure $ Just GFSMain + pure $ Just DJSGroup {jobSpec = DJDeliveryJob {includePending = False}} Left e -> throwError $ ChatErrorStore e where setMemberBlocked bm = withStore' $ \db -> updateGroupMemberBlocked db user gInfo restriction bm @@ -2975,22 +2946,25 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = _ -> updateStatus introId GMIntroReConnected updateStatus introId status = withStore' $ \db -> updateIntroStatus db introId status - xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> Bool -> ChatMessage 'Json -> RcvMessage -> UTCTime -> Bool -> CM (Maybe GroupForwardScope, ShouldDeleteGroupConns) + xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> Bool -> ChatMessage 'Json -> RcvMessage -> UTCTime -> Bool -> CM (Maybe DeliveryJobScope) xGrpMemDel gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId withMessages chatMsg msg brokerTs forwarded = do let GroupMember {memberId = membershipMemId} = membership if membershipMemId == memId then checkRole membership $ do deleteGroupLinkIfExists user gInfo - unless (isUserGrpFwdRelay gInfo) $ deleteGroupConnections gInfo False + -- TODO [channels fwd] possible improvement is to immediately delete rcv queues if isUserGrpFwdRelay + unless (isUserGrpFwdRelay gInfo) $ deleteGroupConnections user gInfo False withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemRemoved let membership' = membership {memberStatus = GSMemRemoved} when withMessages $ deleteMessages gInfo membership' SMDSnd deleteMemberItem RGEUserDeleted toView $ CEvtDeletedMemberUser user gInfo {membership = membership'} m withMessages - pure (Just GFSAll, True) + pure $ Just DJSGroup {jobSpec = DJRelayRemoved} else withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case - Left _ -> messageError "x.grp.mem.del with unknown member ID" $> (Just GFSAll, False) + Left _ -> do + messageError "x.grp.mem.del with unknown member ID" + pure $ Just DJSGroup {jobSpec = DJDeliveryJob {includePending = True}} Right deletedMember@GroupMember {groupMemberId, memberProfile} -> checkRole deletedMember $ do -- ? prohibit deleting member if it's the sender - sender should use x.grp.leave @@ -3007,11 +2981,11 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = when withMessages $ deleteMessages gInfo' deletedMember' SMDRcv deleteMemberItem $ RGEMemberDeleted groupMemberId (fromLocalProfile memberProfile) toView $ CEvtDeletedMember user gInfo' m deletedMember' withMessages - pure (memberEventForwardScope deletedMember, False) + pure $ memberEventDeliveryScope deletedMember where checkRole GroupMember {memberRole} a | senderRole < GRAdmin || senderRole < memberRole = - messageError "x.grp.mem.del with insufficient member permissions" $> (Nothing, False) + messageError "x.grp.mem.del with insufficient member permissions" $> Nothing | otherwise = a deleteMemberItem gEvent = do (gInfo', m', scopeInfo) <- mkGroupChatScope gInfo m @@ -3032,13 +3006,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = isUserGrpFwdRelay GroupInfo {membership = GroupMember {memberRole}} = memberRole >= GRAdmin - deleteGroupConnections :: GroupInfo -> Bool -> CM () - deleteGroupConnections gInfo waitDelivery = do - -- member records are not deleted to keep history - members <- withStore' $ \db -> getGroupMembers db vr user gInfo - deleteMembersConnections' user members waitDelivery - - xGrpLeave :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM (Maybe GroupForwardScope) + xGrpLeave :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope) xGrpLeave gInfo m msg brokerTs = do deleteMemberConnection m -- member record is not deleted to allow creation of "member left" chat item @@ -3051,19 +3019,20 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = (ci, cInfo) <- saveRcvChatItemNoParse user (CDGroupRcv gInfo'' scopeInfo m') msg brokerTs (CIRcvGroupEvent RGEMemberLeft) groupMsgToView cInfo ci toView $ CEvtLeftMember user gInfo'' m' {memberStatus = GSMemLeft} - pure $ memberEventForwardScope m + pure $ memberEventDeliveryScope m xGrpDel :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM () xGrpDel gInfo@GroupInfo {membership} m@GroupMember {memberRole} msg brokerTs = do when (memberRole /= GROwner) $ throwChatError $ CEGroupUserRole gInfo GROwner withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemGroupDeleted - unless (isUserGrpFwdRelay gInfo) $ deleteGroupConnections gInfo False + -- TODO [channels fwd] possible improvement is to immediately delete rcv queues if isUserGrpFwdRelay + unless (isUserGrpFwdRelay gInfo) $ deleteGroupConnections user gInfo False (gInfo'', m', scopeInfo) <- mkGroupChatScope gInfo m (ci, cInfo) <- saveRcvChatItemNoParse user (CDGroupRcv gInfo'' scopeInfo m') msg brokerTs (CIRcvGroupEvent RGEGroupDeleted) groupMsgToView cInfo ci toView $ CEvtGroupDeleted user gInfo'' {membership = membership {memberStatus = GSMemGroupDeleted}} m' - xGrpInfo :: GroupInfo -> GroupMember -> GroupProfile -> RcvMessage -> UTCTime -> CM (Maybe GroupForwardScope) + xGrpInfo :: GroupInfo -> GroupMember -> GroupProfile -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope) xGrpInfo g@GroupInfo {groupProfile = p, businessChat} m@GroupMember {memberRole} p' msg brokerTs | memberRole < GROwner = messageError "x.grp.info with insufficient member permissions" $> Nothing | otherwise = do @@ -3078,12 +3047,12 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = groupMsgToView cInfo ci createGroupFeatureChangedItems user cd CIRcvGroupFeature g g'' Just _ -> updateGroupPrefs_ g m $ fromMaybe defaultBusinessGroupPrefs $ groupPreferences p' - pure $ Just GFSAll + pure $ Just DJSGroup {jobSpec = DJDeliveryJob {includePending = True}} - xGrpPrefs :: GroupInfo -> GroupMember -> GroupPreferences -> CM (Maybe GroupForwardScope) + xGrpPrefs :: GroupInfo -> GroupMember -> GroupPreferences -> CM (Maybe DeliveryJobScope) xGrpPrefs g m@GroupMember {memberRole} ps' | memberRole < GROwner = messageError "x.grp.prefs with insufficient member permissions" $> Nothing - | otherwise = updateGroupPrefs_ g m ps' $> Just GFSAll + | otherwise = updateGroupPrefs_ g m ps' $> Just DJSGroup {jobSpec = DJDeliveryJob {includePending = True}} updateGroupPrefs_ :: GroupInfo -> GroupMember -> GroupPreferences -> CM () updateGroupPrefs_ g@GroupInfo {groupProfile = p} m ps' = @@ -3183,8 +3152,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = toViewTE $ TEContactVerificationReset user ct createInternalChatItem user (CDDirectRcv ct) (CIRcvConnEvent RCEVerificationCodeReset) Nothing - xGrpMsgForward :: GroupInfo -> GroupMember -> MemberId -> Maybe ContactName -> ChatMessage 'Json -> UTCTime -> CM () - xGrpMsgForward gInfo@GroupInfo {groupId} m@GroupMember {memberRole, localDisplayName} memberId memberName chatMsg msgTs = do + xGrpMsgForward :: GroupInfo -> GroupMember -> MemberId -> Maybe ContactName -> ChatMessage 'Json -> UTCTime -> UTCTime -> CM () + xGrpMsgForward gInfo@GroupInfo {groupId} m@GroupMember {memberRole, localDisplayName} memberId memberName chatMsg msgTs brokerTs = do when (memberRole < GRAdmin) $ throwChatError (CEGroupContactRole localDisplayName) withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memberId) >>= \case Right author -> processForwardedMsg author @@ -3198,13 +3167,13 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = processForwardedMsg :: GroupMember -> CM () processForwardedMsg author = do let body = chatMsgToBody chatMsg - rcvMsg@RcvMessage {chatMsgEvent = ACME _ event} <- saveGroupFwdRcvMsg user groupId m author body chatMsg + rcvMsg@RcvMessage {chatMsgEvent = ACME _ event} <- saveGroupFwdRcvMsg user groupId m author body chatMsg brokerTs case event of - XMsgNew mc -> void $ memberCanSend author scope $ (,False) <$> newGroupContentMessage gInfo author mc rcvMsg msgTs True + XMsgNew mc -> void $ memberCanSend author scope $ (const Nothing) <$> newGroupContentMessage gInfo author mc rcvMsg msgTs True where ExtMsgContent {scope} = mcExtMsgContent mc -- file description is always allowed, to allow sending files to support scope XMsgFileDescr sharedMsgId fileDescr -> void $ groupMessageFileDescription gInfo author sharedMsgId fileDescr - XMsgUpdate sharedMsgId mContent mentions ttl live msgScope -> void $ memberCanSend author msgScope $ (,False) <$> groupMessageUpdate gInfo author sharedMsgId mContent mentions msgScope rcvMsg msgTs ttl live + XMsgUpdate sharedMsgId mContent mentions ttl live msgScope -> void $ memberCanSend author msgScope $ (const Nothing) <$> groupMessageUpdate gInfo author sharedMsgId mContent mentions msgScope rcvMsg msgTs ttl live XMsgDel sharedMsgId memId scope_ -> void $ groupMessageDelete gInfo author sharedMsgId memId scope_ rcvMsg msgTs XMsgReact sharedMsgId (Just memId) scope_ reaction add -> void $ groupMsgReaction gInfo author sharedMsgId memId scope_ reaction add rcvMsg msgTs XFileCancel sharedMsgId -> void $ xFileCancelGroup gInfo author sharedMsgId @@ -3305,3 +3274,217 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = else pure Nothing else pure Nothing _ -> pure Nothing + +deleteGroupConnections :: User -> GroupInfo -> Bool -> CM () +deleteGroupConnections user gInfo waitDelivery = do + vr <- chatVersionRange + -- member records are not deleted to keep history + members <- withStore' $ \db -> getGroupMembers db vr user gInfo + deleteMembersConnections' user members waitDelivery + +startDeliveryTaskWorkers :: CM () +startDeliveryTaskWorkers = do + workerScopes <- withStore' $ \db -> getPendingDeliveryTaskScopes db + lift $ forM_ workerScopes resumeDeliveryTaskWork + +resumeDeliveryTaskWork :: DeliveryWorkerKey -> CM' () +resumeDeliveryTaskWork = void . getDeliveryTaskWorker False + +getDeliveryTaskWorker :: Bool -> DeliveryWorkerKey -> CM' Worker +getDeliveryTaskWorker hasWork deliveryKey = do + ws <- asks deliveryTaskWorkers + a <- asks smpAgent + getAgentWorker "delivery_task" hasWork a deliveryKey ws $ + runDeliveryTaskWorker a deliveryKey + +runDeliveryTaskWorker :: AgentClient -> DeliveryWorkerKey -> Worker -> CM () +runDeliveryTaskWorker a deliveryKey Worker {doWork} = do + vr <- chatVersionRange + -- TODO [channels fwd] in future may be required to read groupInfo and user on each iteration for up to date state + -- TODO - same for delivery jobs (runDeliveryJobWorker) + gInfo <- withStore $ \db -> do + user <- getUserByGroupId db groupId + getGroupInfo db vr user groupId + forever $ do + lift $ waitForWork doWork + runDeliveryTaskOperation vr gInfo + where + (groupId, workerScope) = deliveryKey + runDeliveryTaskOperation :: VersionRangeChat -> GroupInfo -> CM () + runDeliveryTaskOperation vr gInfo = do + withWork_ a doWork (withStore' $ \db -> getNextDeliveryTask db deliveryKey) $ \task -> + processDeliveryTask task + `catchAllErrors` \e -> do + withStore' $ \db -> setDeliveryTaskErrStatus db (deliveryTaskId task) (tshow e) + eToView e + where + processDeliveryTask :: MessageDeliveryTask -> CM () + processDeliveryTask task@MessageDeliveryTask {jobScope} = + case jobScopeImpliedSpec jobScope of + DJDeliveryJob _includePending -> + withWorkItems a doWork (withStore' $ \db -> getNextDeliveryTasks db gInfo task) $ \nextTasks -> do + let (body, taskIds, largeTaskIds) = batchDeliveryTasks1 vr maxEncodedMsgLength nextTasks + withStore' $ \db -> do + createMsgDeliveryJob db gInfo jobScope (singleSenderGMId_ nextTasks) body + forM_ taskIds $ \taskId -> updateDeliveryTaskStatus db taskId DTSProcessed + forM_ largeTaskIds $ \taskId -> setDeliveryTaskErrStatus db taskId "large" + lift . void $ getDeliveryJobWorker True deliveryKey + where + singleSenderGMId_ :: NonEmpty MessageDeliveryTask -> Maybe GroupMemberId + singleSenderGMId_ (MessageDeliveryTask {senderGMId = senderGMId'} :| ts) + | all (\MessageDeliveryTask {senderGMId} -> senderGMId == senderGMId') ts = Just senderGMId' + | otherwise = Nothing + DJRelayRemoved + | workerScope /= DWSGroup -> + throwChatError $ CEInternalError "delivery task worker: relay removed task in wrong worker scope" + | otherwise -> do + let MessageDeliveryTask {senderGMId, senderMemberId, senderMemberName, brokerTs, chatMessage} = task + fwdEvt = XGrpMsgForward senderMemberId (Just senderMemberName) chatMessage brokerTs + cm = ChatMessage {chatVRange = vr, msgId = Nothing, chatMsgEvent = fwdEvt} + body = chatMsgToBody cm + withStore' $ \db -> do + createMsgDeliveryJob db gInfo jobScope (Just senderGMId) body + updateDeliveryTaskStatus db (deliveryTaskId task) DTSProcessed + lift . void $ getDeliveryJobWorker True deliveryKey + +startDeliveryJobWorkers :: CM () +startDeliveryJobWorkers = do + workerScopes <- withStore' $ \db -> getPendingDeliveryJobScopes db + lift $ forM_ workerScopes resumeDeliveryJobWork + +resumeDeliveryJobWork :: DeliveryWorkerKey -> CM' () +resumeDeliveryJobWork = void . getDeliveryJobWorker False + +getDeliveryJobWorker :: Bool -> DeliveryWorkerKey -> CM' Worker +getDeliveryJobWorker hasWork deliveryKey = do + ws <- asks deliveryJobWorkers + a <- asks smpAgent + getAgentWorker "delivery_job" hasWork a deliveryKey ws $ + runDeliveryJobWorker a deliveryKey + +runDeliveryJobWorker :: AgentClient -> DeliveryWorkerKey -> Worker -> CM () +runDeliveryJobWorker a deliveryKey Worker {doWork} = do + vr <- chatVersionRange + (user, gInfo) <- withStore $ \db -> do + user <- getUserByGroupId db groupId + gInfo <- getGroupInfo db vr user groupId + pure (user, gInfo) + forever $ do + lift $ waitForWork doWork + runDeliveryJobOperation vr user gInfo + where + (groupId, workerScope) = deliveryKey + runDeliveryJobOperation :: VersionRangeChat -> User -> GroupInfo -> CM () + runDeliveryJobOperation vr user gInfo = do + withWork_ a doWork (withStore' $ \db -> getNextDeliveryJob db deliveryKey) $ \job -> + processDeliveryJob job + `catchAllErrors` \e -> do + withStore' $ \db -> setDeliveryJobErrStatus db (deliveryJobId job) (tshow e) + eToView e + where + processDeliveryJob :: MessageDeliveryJob -> CM () + processDeliveryJob job = + case jobScopeImpliedSpec jobScope of + DJDeliveryJob _includePending -> do + sendBodyToMembers + withStore' $ \db -> updateDeliveryJobStatus db jobId DJSComplete + DJRelayRemoved + | workerScope /= DWSGroup -> + throwChatError $ CEInternalError "delivery job worker: relay removed job in wrong worker scope" + | otherwise -> do + sendBodyToMembers + deleteGroupConnections user gInfo True + withStore' $ \db -> updateDeliveryJobStatus db jobId DJSComplete + where + MessageDeliveryJob {jobId, jobScope, singleSenderGMId_, body, cursorGMId_ = startingCursor} = job + sendBodyToMembers :: CM () + sendBodyToMembers + | useRelays gInfo = -- channel + case jobScope of + -- there's no member review in channels, so job spec includePending is ignored + DJSGroup {} -> sendLoop startingCursor + where + dbBatchSize = 1000 -- TODO [channels fwd] review, make configurable + sendLoop :: Maybe GroupMemberId -> CM () + sendLoop cursorGMId_ = do + mems <- withStore' $ \db -> getGroupMembersByCursor db vr user gInfo cursorGMId_ singleSenderGMId_ dbBatchSize + let cursorGMId_' = groupMemberId' $ last mems + unless (null mems) $ deliver body mems + withStore' $ \db -> updateDeliveryJobCursor db jobId cursorGMId_' + unless (length mems < dbBatchSize) $ sendLoop (Just cursorGMId_') + DJSMemberSupport scopeGMId -> do + -- for member support scope we just load all recipients in one go, without cursor + modMs <- withStore' $ \db -> getGroupModerators db vr user gInfo + let moderatorFilter mem = + memberCurrent mem + && maxVersion (memberChatVRange mem) >= groupKnockingVersion + && Just (groupMemberId' mem) /= singleSenderGMId_ + modMs' = filter moderatorFilter modMs + mems <- + if Just scopeGMId == singleSenderGMId_ + then pure modMs' + else do + scopeMem <- withStore $ \db -> getGroupMemberById db vr user scopeGMId + pure $ scopeMem : modMs' + unless (null mems) $ deliver body mems + | otherwise = -- fully connected group + case singleSenderGMId_ of + Nothing -> throwChatError $ CEInternalError "delivery job worker: singleSenderGMId is required when not using relays" + Just singleSenderGMId -> do + sender <- withStore $ \db -> getGroupMemberById db vr user singleSenderGMId + mems <- buildMemberList sender + unless (null mems) $ deliver body mems + where + buildMemberList sender = case jobScope of + DJSGroup {jobSpec} + | jobSpecImpliedPending jobSpec -> + filter memberCurrentOrPending <$> getAllIntroducedAndInvited + | otherwise -> + filter memberCurrent <$> getAllIntroducedAndInvited + DJSMemberSupport scopeGMId -> do + -- moderators introduced to this invited member + introducedModMs <- + if memberCategory sender == GCInviteeMember + then withStore' $ \db -> getForwardIntroducedModerators db vr user sender + else pure [] + -- invited moderators to which this member was introduced + invitedModMs <- withStore' $ \db -> getForwardInvitedModerators db vr user sender + let modMs = introducedModMs <> invitedModMs + modMs' = filter (\mem -> memberCurrent mem && maxVersion (memberChatVRange mem) >= groupKnockingVersion) modMs + if scopeGMId == groupMemberId' sender + then pure modMs' + else + withStore' (\db -> getForwardScopeMember db vr user sender scopeGMId) >>= \case + Just scopeMem -> pure $ scopeMem : modMs' + _ -> pure modMs' + where + getAllIntroducedAndInvited = do + ChatConfig {highlyAvailable} <- asks config + -- members introduced to this invited member + introducedMembers <- + if memberCategory sender == GCInviteeMember + then withStore' $ \db -> getForwardIntroducedMembers db vr user sender highlyAvailable + else pure [] + -- invited members to which this member was introduced + invitedMembers <- withStore' $ \db -> getForwardInvitedMembers db vr user sender highlyAvailable + pure $ introducedMembers <> invitedMembers + where + deliver :: ByteString -> [GroupMember] -> CM () + deliver msgBody mems = + let mConns = mapMaybe (fmap snd . readyMemberConn) mems + msgReqs = foldMemConns mConns + in void $ withAgent (`sendMessages` msgReqs) + where + foldMemConns :: [Connection] -> [MsgReq] + foldMemConns mConns = snd $ foldr' addReq (lastMemIdx_, []) mConns + where + lastMemIdx_ = let len = length mConns in if len > 1 then Just len else Nothing + addReq :: Connection -> (Maybe Int, [MsgReq]) -> (Maybe Int, [MsgReq]) + addReq conn (memIdx_, reqs) = + (subtract 1 <$> memIdx_, req : reqs) + where + req = (aConnId conn, PQEncOff, MsgFlags False, vrValue_) + vrValue_ = case memIdx_ of + Nothing -> VRValue Nothing msgBody -- sending to one member, do not reference body + Just 1 -> VRValue (Just 1) msgBody + Just _ -> VRRef 1 diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 5a5f0922e7..4973e5b9bb 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -31,7 +31,7 @@ import qualified Data.ByteString.Lazy.Char8 as LB import Data.Char (isSpace) import Data.Int (Int64) import Data.Kind (Constraint) -import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty (NonEmpty (..)) import Data.Map.Strict (Map) import Data.Maybe (fromMaybe, isJust, isNothing) import Data.Text (Text) @@ -185,24 +185,6 @@ toMsgScope :: GroupInfo -> GroupChatScopeInfo -> MsgScope toMsgScope GroupInfo {membership} = \case GCSIMemberSupport {groupMember_} -> MSMember $ memberId' $ fromMaybe membership groupMember_ -data GroupForwardScope - = GFSAll -- message should be forwarded to all group members, even pending (e.g. XGrpDel, XGrpInfo) - | GFSMain -- message should be forwarded to current group members only (e.g. regular messages in group) - | GFSMemberSupport GroupMemberId - deriving (Eq, Ord, Show) - -toGroupForwardScope :: GroupInfo -> Maybe GroupChatScopeInfo -> GroupForwardScope -toGroupForwardScope GroupInfo {membership} = \case - Nothing -> GFSMain - Just GCSIMemberSupport {groupMember_} -> GFSMemberSupport $ groupMemberId' $ fromMaybe membership groupMember_ - -memberEventForwardScope :: GroupMember -> Maybe GroupForwardScope -memberEventForwardScope m@GroupMember {memberRole, memberStatus} - | memberStatus == GSMemPendingApproval = Nothing - | memberStatus == GSMemPendingReview = Just $ GFSMemberSupport $ groupMemberId' m - | memberRole >= GRModerator = Just GFSAll - | otherwise = Just GFSMain - chatInfoToRef :: ChatInfo c -> Maybe ChatRef chatInfoToRef = \case DirectChat Contact {contactId} -> Just $ ChatRef CTDirect contactId Nothing @@ -1163,7 +1145,8 @@ data SndMessage = SndMessage data NewRcvMessage e = NewRcvMessage { chatMsgEvent :: ChatMsgEvent e, - msgBody :: MsgBody + msgBody :: MsgBody, + brokerTs :: UTCTime } deriving (Show) diff --git a/src/Simplex/Chat/Messages/Batch.hs b/src/Simplex/Chat/Messages/Batch.hs index c1c45d7b0a..2c3bd2b87d 100644 --- a/src/Simplex/Chat/Messages/Batch.hs +++ b/src/Simplex/Chat/Messages/Batch.hs @@ -7,13 +7,21 @@ module Simplex.Chat.Messages.Batch ( MsgBatch (..), batchMessages, + batchDeliveryTasks1, ) where import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import Data.Int (Int64) +import Data.List (foldl') +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as L import Simplex.Chat.Controller (ChatError (..), ChatErrorType (..)) +import Simplex.Chat.Delivery import Simplex.Chat.Messages +import Simplex.Chat.Protocol +import Simplex.Chat.Types (VersionRangeChat) data MsgBatch = MsgBatch ByteString [SndMessage] @@ -49,3 +57,38 @@ batchMessages maxLen = addBatch . foldr addToBatch ([], [], 0, 0) [msg] -> body msg msgs -> B.concat ["[", B.intercalate "," (map body msgs), "]"] body SndMessage {msgBody} = msgBody + +-- | Batches delivery tasks into (batch, [taskIds], [largeTaskIds]). +batchDeliveryTasks1 :: VersionRangeChat -> Int -> NonEmpty MessageDeliveryTask -> (ByteString, [Int64], [Int64]) +batchDeliveryTasks1 vr maxLen = toResult . foldl' addToBatch ([], [], [], 0, 0) . L.toList + where + addToBatch :: ([ByteString], [Int64], [Int64], Int, Int) -> MessageDeliveryTask -> ([ByteString], [Int64], [Int64], Int, Int) + addToBatch (msgBodies, taskIds, largeTaskIds, len, n) task + -- too large: skip msgBody, record taskId in largeTaskIds + | msgLen > maxLen = (msgBodies, taskIds, taskId : largeTaskIds, len, n) + -- fits: include in batch + | batchLen <= maxLen = (msgBody : msgBodies, taskId : taskIds, largeTaskIds, len', n + 1) + -- doesn’t fit: stop adding further messages + | otherwise = (msgBodies, taskIds, largeTaskIds, len, n) + where + MessageDeliveryTask {taskId, senderMemberId, senderMemberName, brokerTs, chatMessage, messageFromChannel = _messageFromChannel} = task + -- TODO [channels fwd] handle messageFromChannel (null memberId in XGrpMsgForward) + msgBody = + let fwdEvt = XGrpMsgForward senderMemberId (Just senderMemberName) chatMessage brokerTs + cm = ChatMessage {chatVRange = vr, msgId = Nothing, chatMsgEvent = fwdEvt} + in chatMsgToBody cm + msgLen = B.length msgBody + len' + | n == 0 = msgLen + | otherwise = msgLen + len + 1 -- 1 accounts for comma + batchLen + | n == 0 = len' + | otherwise = len' + 2 -- 2 accounts for opening and closing brackets + toResult :: ([ByteString], [Int64], [Int64], Int, Int) -> (ByteString, [Int64], [Int64]) + toResult (msgBodies, taskIds, largeTaskIds, _, _) = + (encodeMessages (reverse msgBodies), reverse taskIds, reverse largeTaskIds) + encodeMessages :: [ByteString] -> ByteString + encodeMessages = \case + [] -> mempty + [msg] -> msg + msgs -> B.concat ["[", B.intercalate "," msgs, "]"] diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index d6b826491e..0916d18eab 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -34,11 +34,10 @@ import qualified Data.ByteString.Char8 as B import Data.ByteString.Internal (c2w, w2c) import qualified Data.ByteString.Lazy.Char8 as LB import Data.Either (fromRight) -import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe, mapMaybe) +import Data.Maybe (fromMaybe) import Data.String import Data.Text (Text) import qualified Data.Text as T @@ -53,7 +52,7 @@ import Simplex.Chat.Types import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Shared import Simplex.Messaging.Agent.Protocol (VersionSMPA, pqdrSMPAgentVersion) -import Simplex.Messaging.Agent.Store.DB (fromTextField_) +import Simplex.Messaging.Agent.Store.DB (blobFieldDecoder, fromTextField_) import Simplex.Messaging.Compression (Compressed, compress1, decompress1) import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String @@ -313,6 +312,8 @@ data ChatMessage e = ChatMessage data AChatMessage = forall e. MsgEncodingI e => ACMsg (SMsgEncoding e) (ChatMessage e) +type MessageFromChannel = Bool + data ChatMsgEvent (e :: MsgEncoding) where XMsgNew :: MsgContainer -> ChatMsgEvent 'Json XMsgFileDescr :: {msgId :: SharedMsgId, fileDescr :: FileDescr} -> ChatMsgEvent 'Json @@ -392,32 +393,6 @@ isForwardedGroupMsg ev = case ev of XGrpPrefs _ -> True _ -> False --- applied after building list of messages to forward and building list of group members to forward to, see Chat; --- --- this filters out members if any of forwarded events in batch is an XGrpMemRestrict event referring to them, --- but practically XGrpMemRestrict is not batched with other events so it wouldn't prevent forwarding of other events --- to these members; --- --- same for reports (MCReport) - they are not batched with other events, so we can safely filter out --- members with role less than moderator when forwarding -msgsForwardedToMember :: NonEmpty (ChatMessage 'Json) -> GroupMember -> Bool -msgsForwardedToMember fwdMsgs GroupMember {memberId, memberRole} = - (memberId `notElem` restrictMemberIds) && (not hasReport || memberRole >= GRModerator) - where - restrictMemberIds = mapMaybe restrictMemberId $ L.toList fwdMsgs - restrictMemberId :: ChatMessage 'Json -> Maybe MemberId - restrictMemberId ChatMessage {chatMsgEvent} = - case chatMsgEvent of - XGrpMemRestrict mId _ -> Just mId - _ -> Nothing - hasReport = any isReportEvent fwdMsgs - isReportEvent ChatMessage {chatMsgEvent} = - case chatMsgEvent of - XMsgNew mc -> case mcExtMsgContent mc of - ExtMsgContent {content = MCReport {}} -> True - _ -> False - _ -> False - data MsgReaction = MREmoji {emoji :: MREmojiChar} | MRUnknown {tag :: Text, json :: J.Object} deriving (Eq, Show) @@ -1222,6 +1197,9 @@ instance ToJSON (ChatMessage 'Json) where instance FromJSON (ChatMessage 'Json) where parseJSON v = appJsonToCM <$?> parseJSON v +instance FromField (ChatMessage 'Json) where + fromField = blobFieldDecoder J.eitherDecodeStrict' + data ContactShortLinkData = ContactShortLinkData { profile :: Profile, message :: Maybe MsgContent, diff --git a/src/Simplex/Chat/Store/Delivery.hs b/src/Simplex/Chat/Store/Delivery.hs new file mode 100644 index 0000000000..632231adef --- /dev/null +++ b/src/Simplex/Chat/Store/Delivery.hs @@ -0,0 +1,362 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeOperators #-} + +module Simplex.Chat.Store.Delivery + ( createMsgDeliveryTask, + deleteGroupDeliveryTasks, + deleteGroupDeliveryJobs, + getPendingDeliveryTaskScopes, + getNextDeliveryTask, + getNextDeliveryTasks, + updateDeliveryTaskStatus, + setDeliveryTaskErrStatus, + deleteDoneDeliveryTasks, + createMsgDeliveryJob, + getPendingDeliveryJobScopes, + getNextDeliveryJob, + updateDeliveryJobStatus, + setDeliveryJobErrStatus, + getGroupMembersByCursor, + updateDeliveryJobCursor, + deleteDoneDeliveryJobs, + ) +where + +import Control.Monad.Except +import Data.ByteString.Char8 (ByteString) +import Data.Either (rights) +import Data.Int (Int64) +import Data.Text (Text) +import Data.Time.Clock (UTCTime, getCurrentTime) +import Simplex.Chat.Delivery +import Simplex.Chat.Protocol hiding (Binary) +import Simplex.Chat.Store.Groups (getGroupMemberById) +import Simplex.Chat.Store.Shared +import Simplex.Chat.Types +import Simplex.Messaging.Agent.Store.AgentStore (getWorkItem, getWorkItems, maybeFirstRow) +import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..)) +import qualified Simplex.Messaging.Agent.Store.DB as DB +import Simplex.Messaging.Util (firstRow') +#if defined(dbPostgres) +import Database.PostgreSQL.Simple (Only (..), (:.) (..)) +import Database.PostgreSQL.Simple.SqlQQ (sql) +#else +import Database.SQLite.Simple (Only (..), (:.) (..)) +import Database.SQLite.Simple.QQ (sql) +#endif + +type DeliveryJobScopeRow = (DeliveryWorkerScope, Maybe DeliveryJobSpecTag, Maybe BoolInt, Maybe GroupMemberId) + +jobScopeRow_ :: DeliveryJobScope -> DeliveryJobScopeRow +jobScopeRow_ = \case + DJSGroup {jobSpec} -> case jobSpec of + DJDeliveryJob {includePending} -> (DWSGroup, Just DJSTDeliveryJob, Just (BI includePending), Nothing) + DJRelayRemoved -> (DWSGroup, Just DJSTRelayRemoved, Nothing, Nothing) + DJSMemberSupport {supportGMId} -> (DWSMemberSupport, Nothing, Nothing, Just supportGMId) + +toJobScope_ :: DeliveryJobScopeRow -> Maybe DeliveryJobScope +toJobScope_ = \case + (DWSGroup, Just DJSTDeliveryJob, Just (BI includePending), Nothing) -> Just $ DJSGroup {jobSpec = DJDeliveryJob {includePending}} + (DWSGroup, Just DJSTRelayRemoved, Nothing, Nothing) -> Just $ DJSGroup {jobSpec = DJRelayRemoved} + (DWSMemberSupport, Nothing, Nothing, Just supportGMId) -> Just $ DJSMemberSupport {supportGMId} + _ -> Nothing + +createMsgDeliveryTask :: DB.Connection -> GroupInfo -> GroupMember -> NewMessageDeliveryTask -> IO () +createMsgDeliveryTask db gInfo sender newTask = do + currentTs <- getCurrentTime + DB.execute + db + [sql| + INSERT INTO delivery_tasks ( + group_id, + worker_scope, job_scope_spec_tag, job_scope_include_pending, job_scope_support_gm_id, + sender_group_member_id, message_id, message_from_channel, task_status, + created_at, updated_at + ) VALUES (?,?,?,?,?,?,?,?,?,?,?) + |] + ((Only groupId) :. jobScopeRow_ jobScope :. (groupMemberId' sender, messageId, BI messageFromChannel, DTSNew, currentTs, currentTs)) + where + GroupInfo {groupId} = gInfo + NewMessageDeliveryTask {messageId, jobScope, messageFromChannel} = newTask + +deleteGroupDeliveryTasks :: DB.Connection -> GroupInfo -> IO () +deleteGroupDeliveryTasks db GroupInfo {groupId} = + DB.execute db "DELETE FROM delivery_tasks WHERE group_id = ?" (Only groupId) + +deleteGroupDeliveryJobs :: DB.Connection -> GroupInfo -> IO () +deleteGroupDeliveryJobs db GroupInfo {groupId} = + DB.execute db "DELETE FROM delivery_jobs WHERE group_id = ?" (Only groupId) + +getPendingDeliveryTaskScopes :: DB.Connection -> IO [DeliveryWorkerKey] +getPendingDeliveryTaskScopes db = + DB.query + db + [sql| + SELECT DISTINCT group_id, worker_scope + FROM delivery_tasks + WHERE failed = 0 AND task_status = ? + |] + (Only DTSNew) + +getNextDeliveryTask :: DB.Connection -> DeliveryWorkerKey -> IO (Either StoreError (Maybe MessageDeliveryTask)) +getNextDeliveryTask db deliveryKey = do + getWorkItem "delivery task" getTaskId (getMsgDeliveryTask_ db) (markDeliveryTaskFailed_ db) + where + (groupId, workerScope) = deliveryKey + getTaskId :: IO (Maybe Int64) + getTaskId = + maybeFirstRow fromOnly $ + DB.query + db + [sql| + SELECT delivery_task_id + FROM delivery_tasks + WHERE group_id = ? AND worker_scope = ? + AND failed = 0 AND task_status = ? + ORDER BY delivery_task_id ASC + LIMIT 1 + |] + (groupId, workerScope, DTSNew) + +type MessageDeliveryTaskRow = (Only Int64) :. DeliveryJobScopeRow :. (GroupMemberId, MemberId, ContactName, UTCTime, ChatMessage 'Json, BoolInt) + +getMsgDeliveryTask_ :: DB.Connection -> Int64 -> IO (Either StoreError MessageDeliveryTask) +getMsgDeliveryTask_ db taskId = + firstRow' toTask (SEDeliveryTaskNotFound taskId) $ + DB.query + db + [sql| + SELECT + t.delivery_task_id, + t.worker_scope, t.job_scope_spec_tag, t.job_scope_include_pending, t.job_scope_support_gm_id, + m.group_member_id, m.member_id, p.display_name, msg.broker_ts, msg.msg_body, t.message_from_channel + FROM delivery_tasks t + JOIN messages msg ON msg.message_id = t.message_id + JOIN group_members m ON m.group_member_id = t.sender_group_member_id + JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) + WHERE t.delivery_task_id = ? + |] + (Only taskId) + where + toTask :: MessageDeliveryTaskRow -> Either StoreError MessageDeliveryTask + toTask ((Only taskId') :. jobScopeRow :. (senderGMId, senderMemberId, senderMemberName, brokerTs, chatMessage, BI messageFromChannel)) = + case toJobScope_ jobScopeRow of + Just jobScope -> Right $ MessageDeliveryTask {taskId = taskId', jobScope, senderGMId, senderMemberId, senderMemberName, brokerTs, chatMessage, messageFromChannel} + Nothing -> Left $ SEInvalidDeliveryTask taskId' + +markDeliveryTaskFailed_ :: DB.Connection -> Int64 -> IO () +markDeliveryTaskFailed_ db taskId = + DB.execute db "UPDATE delivery_tasks SET failed = 1 where delivery_task_id = ?" (Only taskId) + +-- TODO [channels fwd] possible optimization is to read and add tasks to batch iteratively to avoid reading too many tasks +-- passed MessageDeliveryTask defines the jobScope to search for +getNextDeliveryTasks :: DB.Connection -> GroupInfo -> MessageDeliveryTask -> IO (Either StoreError [Either StoreError MessageDeliveryTask]) +getNextDeliveryTasks db gInfo task = + getWorkItems "message delivery task" getTaskIds (getMsgDeliveryTask_ db) (markDeliveryTaskFailed_ db) + where + GroupInfo {groupId, useRelays} = gInfo + MessageDeliveryTask {jobScope, senderGMId} = task + getTaskIds :: IO [Int64] + getTaskIds + | useRelays = + map fromOnly + <$> DB.query + db + [sql| + SELECT delivery_task_id + FROM delivery_tasks + WHERE group_id = ? + AND worker_scope = ? + AND job_scope_spec_tag IS NOT DISTINCT FROM ? + AND job_scope_include_pending IS NOT DISTINCT FROM ? + AND job_scope_support_gm_id IS NOT DISTINCT FROM ? + AND failed = 0 + AND task_status = ? + ORDER BY delivery_task_id ASC + |] + ((Only groupId) :. jobScopeRow_ jobScope :. (Only DTSNew)) + | otherwise = + -- For fully connected groups we guarantee a singleSenderGMId for a delivery job by additionally filtering + -- on sender_group_member_id here, so that the job can then retrieve less members as recipients, + -- optimizing for this single sender (see processDeliveryJob -> getForwardIntroducedMembers, etc.). + -- We do this optimization in the job to decrease load on admins using mobile devices for clients. + map fromOnly + <$> DB.query + db + [sql| + SELECT delivery_task_id + FROM delivery_tasks + WHERE group_id = ? + AND worker_scope = ? + AND job_scope_spec_tag IS NOT DISTINCT FROM ? + AND job_scope_include_pending IS NOT DISTINCT FROM ? + AND job_scope_support_gm_id IS NOT DISTINCT FROM ? + AND sender_group_member_id = ? + AND failed = 0 + AND task_status = ? + ORDER BY delivery_task_id ASC + |] + ((Only groupId) :. jobScopeRow_ jobScope :. (senderGMId, DTSNew)) + +updateDeliveryTaskStatus :: DB.Connection -> Int64 -> DeliveryTaskStatus -> IO () +updateDeliveryTaskStatus db taskId status = updateDeliveryTaskStatus_ db taskId status Nothing + +setDeliveryTaskErrStatus :: DB.Connection -> Int64 -> Text -> IO () +setDeliveryTaskErrStatus db taskId errReason = updateDeliveryTaskStatus_ db taskId DTSError (Just errReason) + +updateDeliveryTaskStatus_ :: DB.Connection -> Int64 -> DeliveryTaskStatus -> Maybe Text -> IO () +updateDeliveryTaskStatus_ db taskId status errReason_ = do + currentTs <- getCurrentTime + DB.execute + db + "UPDATE delivery_tasks SET task_status = ?, task_err_reason = ?, updated_at = ? WHERE delivery_task_id = ?" + (status, errReason_, currentTs, taskId) + +deleteDoneDeliveryTasks :: DB.Connection -> UTCTime -> IO () +deleteDoneDeliveryTasks db createdAtCutoff = do + DB.execute + db + [sql| + DELETE FROM delivery_tasks + WHERE created_at <= ? + AND (task_status IN (?,?) OR failed = 1) + |] + (createdAtCutoff, DTSProcessed, DTSError) + +createMsgDeliveryJob :: DB.Connection -> GroupInfo -> DeliveryJobScope -> Maybe GroupMemberId -> ByteString -> IO () +createMsgDeliveryJob db gInfo jobScope singleSenderGMId_ body = do + currentTs <- getCurrentTime + DB.execute + db + [sql| + INSERT INTO delivery_jobs ( + group_id, + worker_scope, job_scope_spec_tag, job_scope_include_pending, job_scope_support_gm_id, + single_sender_group_member_id, body, job_status, created_at, updated_at + ) VALUES (?,?,?,?,?,?,?,?,?,?) + |] + ((Only groupId) :. jobScopeRow_ jobScope :. (singleSenderGMId_, Binary body, DJSPending, currentTs, currentTs)) + where + GroupInfo {groupId} = gInfo + +getPendingDeliveryJobScopes :: DB.Connection -> IO [DeliveryWorkerKey] +getPendingDeliveryJobScopes db = + DB.query + db + [sql| + SELECT DISTINCT group_id, worker_scope + FROM delivery_jobs + WHERE failed = 0 AND job_status = ? + |] + (Only DJSPending) + +type MessageDeliveryJobRow = (Only Int64) :. DeliveryJobScopeRow :. (Maybe GroupMemberId, Binary ByteString, Maybe GroupMemberId) + +getNextDeliveryJob :: DB.Connection -> DeliveryWorkerKey -> IO (Either StoreError (Maybe MessageDeliveryJob)) +getNextDeliveryJob db deliveryKey = do + getWorkItem "delivery job" getJobId getJob markJobFailed + where + (groupId, workerScope) = deliveryKey + getJobId :: IO (Maybe Int64) + getJobId = + maybeFirstRow fromOnly $ + DB.query + db + [sql| + SELECT delivery_job_id + FROM delivery_jobs + WHERE group_id = ? AND worker_scope = ? + AND failed = 0 AND job_status = ? + ORDER BY delivery_job_id ASC + LIMIT 1 + |] + (groupId, workerScope, DJSPending) + getJob :: Int64 -> IO (Either StoreError MessageDeliveryJob) + getJob jobId = + firstRow' toDeliveryJob (SEDeliveryJobNotFound jobId) $ + DB.query + db + [sql| + SELECT + delivery_job_id, + worker_scope, job_scope_spec_tag, job_scope_include_pending, job_scope_support_gm_id, + single_sender_group_member_id, body, cursor_group_member_id + FROM delivery_jobs + WHERE delivery_job_id = ? + |] + (Only jobId) + where + toDeliveryJob :: MessageDeliveryJobRow -> Either StoreError MessageDeliveryJob + toDeliveryJob ((Only jobId') :. jobScopeRow :. (singleSenderGMId_, Binary body, cursorGMId_)) = + case toJobScope_ jobScopeRow of + Just jobScope -> Right $ MessageDeliveryJob {jobId = jobId', jobScope, singleSenderGMId_, body, cursorGMId_} + Nothing -> Left $ SEInvalidDeliveryJob jobId' + markJobFailed :: Int64 -> IO () + markJobFailed jobId = + DB.execute db "UPDATE delivery_jobs SET failed = 1 where delivery_job_id = ?" (Only jobId) + +updateDeliveryJobStatus :: DB.Connection -> Int64 -> DeliveryJobStatus -> IO () +updateDeliveryJobStatus db jobId status = updateDeliveryJobStatus_ db jobId status Nothing + +setDeliveryJobErrStatus :: DB.Connection -> Int64 -> Text -> IO () +setDeliveryJobErrStatus db jobId errReason = updateDeliveryJobStatus_ db jobId DJSError (Just errReason) + +updateDeliveryJobStatus_ :: DB.Connection -> Int64 -> DeliveryJobStatus -> Maybe Text -> IO () +updateDeliveryJobStatus_ db jobId status errReason_ = do + currentTs <- getCurrentTime + DB.execute + db + "UPDATE delivery_jobs SET job_status = ?, job_err_reason = ?, updated_at = ? WHERE delivery_job_id = ?" + (status, errReason_, currentTs, jobId) + +-- TODO [channels fwd] possible improvement is to prioritize owners and "active" members +getGroupMembersByCursor :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> Maybe GroupMemberId -> Maybe GroupMemberId -> Int -> IO [GroupMember] +getGroupMembersByCursor db vr user GroupInfo {groupId} cursorGMId_ singleSenderGMId_ count = do + memberIds <- + map fromOnly <$> case cursorGMId_ of + Nothing -> + DB.query + db + (query <> orderLimit) + (groupId, singleSenderGMId_, GSMemIntroduced, GSMemIntroInvited, GSMemAccepted, GSMemAnnounced, GSMemConnected, GSMemComplete, count) + Just cursorGMId -> + DB.query + db + (query <> " AND group_member_id > ?" <> orderLimit) + (groupId, singleSenderGMId_, GSMemIntroduced, GSMemIntroInvited, GSMemAccepted, GSMemAnnounced, GSMemConnected, GSMemComplete, cursorGMId, count) + rights <$> mapM (runExceptT . getGroupMemberById db vr user) memberIds + where + query = + [sql| + SELECT group_member_id + FROM group_members + WHERE group_id = ? + AND group_member_id IS DISTINCT FROM ? + AND member_status IN (?,?,?,?,?,?) + |] + orderLimit = " ORDER BY group_member_id ASC LIMIT ?" + +updateDeliveryJobCursor :: DB.Connection -> Int64 -> GroupMemberId -> IO () +updateDeliveryJobCursor db jobId cursorGMId = do + currentTs <- getCurrentTime + DB.execute + db + "UPDATE delivery_jobs SET cursor_group_member_id = ?, updated_at = ? WHERE delivery_job_id = ?" + (cursorGMId, currentTs, jobId) + +deleteDoneDeliveryJobs :: DB.Connection -> UTCTime -> IO () +deleteDoneDeliveryJobs db createdAtCutoff = do + DB.execute + db + [sql| + DELETE FROM delivery_jobs + WHERE created_at <= ? + AND (job_status IN (?,?) OR failed = 1) + |] + (createdAtCutoff, DJSComplete, DJSError) diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index 1b218df56d..3d8bdead72 100644 --- a/src/Simplex/Chat/Store/Groups.hs +++ b/src/Simplex/Chat/Store/Groups.hs @@ -175,7 +175,7 @@ import Data.Text (Text) import Data.Time.Clock (UTCTime (..), getCurrentTime) import Data.Text.Encoding (encodeUtf8) import Simplex.Chat.Messages -import Simplex.Chat.Protocol (MsgMention (..), groupForwardVersion) +import Simplex.Chat.Protocol hiding (Binary) import Simplex.Chat.Store.Direct import Simplex.Chat.Store.Shared import Simplex.Chat.Types @@ -359,6 +359,7 @@ createNewGroup db vr gVar user@User {userId} groupProfile incognitoProfile = Exc pure GroupInfo { groupId, + useRelays = False, localDisplayName = ldn, groupProfile, localAlias = "", @@ -432,6 +433,7 @@ createGroupInvitation db vr user@User {userId} contact@Contact {contactId, activ pure ( GroupInfo { groupId, + useRelays = False, localDisplayName, groupProfile, localAlias = "", diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index c152bdc4bf..f6d0e7da72 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -286,7 +286,7 @@ getLastRcvMsgInfo db connId = RcvMsgInfo {msgId, msgDeliveryId, msgDeliveryStatus, agentMsgId, agentMsgMeta} createNewRcvMessage :: forall e. MsgEncodingI e => DB.Connection -> ConnOrGroupId -> NewRcvMessage e -> Maybe SharedMsgId -> Maybe GroupMemberId -> Maybe GroupMemberId -> ExceptT StoreError IO RcvMessage -createNewRcvMessage db connOrGroupId NewRcvMessage {chatMsgEvent, msgBody} sharedMsgId_ authorMember forwardedByMember = +createNewRcvMessage db connOrGroupId NewRcvMessage {chatMsgEvent, msgBody, brokerTs} sharedMsgId_ authorMember forwardedByMember = case connOrGroupId of ConnectionId connId -> liftIO $ insertRcvMsg (Just connId) Nothing GroupId groupId -> case sharedMsgId_ of @@ -314,10 +314,12 @@ createNewRcvMessage db connOrGroupId NewRcvMessage {chatMsgEvent, msgBody} share db [sql| INSERT INTO messages - (msg_sent, chat_msg_event, msg_body, created_at, updated_at, connection_id, group_id, shared_msg_id, author_group_member_id, forwarded_by_group_member_id) - VALUES (?,?,?,?,?,?,?,?,?,?) + (msg_sent, chat_msg_event, msg_body, broker_ts, created_at, updated_at, connection_id, group_id, + shared_msg_id, author_group_member_id, forwarded_by_group_member_id) + VALUES (?,?,?,?,?,?,?,?,?,?,?) |] - (MDRcv, toCMEventTag chatMsgEvent, DB.Binary msgBody, currentTs, currentTs, connId_, groupId_, sharedMsgId_, authorMember, forwardedByMember) + ((MDRcv, toCMEventTag chatMsgEvent, DB.Binary msgBody, brokerTs, currentTs, currentTs, connId_, groupId_) + :. (sharedMsgId_, authorMember, forwardedByMember)) msgId <- insertedRowId db pure RcvMessage {msgId, chatMsgEvent = ACME (encoding @e) chatMsgEvent, sharedMsgId_, msgBody, authorMember, forwardedByMember} @@ -509,17 +511,17 @@ setSupportChatTs db groupMemberId chatTs = setSupportChatMemberAttention :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> GroupMember -> Int64 -> IO (GroupInfo, GroupMember) setSupportChatMemberAttention db vr user g m memberAttention = do - m' <- updateGMAttention m + m' <- updateGMAttention g' <- updateGroupMembersRequireAttention db user g m m' pure (g', m') where - updateGMAttention m@GroupMember {groupMemberId} = do + updateGMAttention = do currentTs <- getCurrentTime DB.execute db "UPDATE group_members SET support_chat_items_member_attention = ?, updated_at = ? WHERE group_member_id = ?" (memberAttention, currentTs, groupMemberId' m) - m_ <- runExceptT $ getGroupMemberById db vr user groupMemberId + m_ <- runExceptT $ getGroupMemberById db vr user (groupMemberId' m) pure $ either (const m) id m_ -- Left shouldn't happen, but types require it createNewSndChatItem :: DB.Connection -> User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> UTCTime -> IO ChatItemId @@ -2037,7 +2039,7 @@ setDirectChatItemsDeleteAt db User {userId} contactId itemIds currentTs = forM i pure (chatItemId, deleteAt) updateGroupChatItemsRead :: DB.Connection -> User -> GroupInfo -> IO () -updateGroupChatItemsRead db User {userId} GroupInfo {groupId, membership} = do +updateGroupChatItemsRead db User {userId} GroupInfo {groupId} = do currentTs <- getCurrentTime DB.execute db @@ -2082,10 +2084,11 @@ updateSupportChatItemsRead db vr user@User {userId} g@GroupInfo {groupId, member UPDATE group_members SET support_chat_items_unread = 0, support_chat_items_member_attention = 0, - support_chat_items_mentions = 0 + support_chat_items_mentions = 0, + updated_at = ? WHERE group_member_id = ? |] - (Only groupMemberId) + (currentTs, groupMemberId) m_ <- runExceptT $ getGroupMemberById db vr user groupMemberId pure $ either (const m) id m_ -- Left shouldn't happen, but types require it diff --git a/src/Simplex/Chat/Store/Postgres/Migrations.hs b/src/Simplex/Chat/Store/Postgres/Migrations.hs index ce1987db15..4fbed16753 100644 --- a/src/Simplex/Chat/Store/Postgres/Migrations.hs +++ b/src/Simplex/Chat/Store/Postgres/Migrations.hs @@ -16,6 +16,7 @@ import Simplex.Chat.Store.Postgres.Migrations.M20250721_indexes import Simplex.Chat.Store.Postgres.Migrations.M20250729_member_contact_requests import Simplex.Chat.Store.Postgres.Migrations.M20250801_via_group_link_uri import Simplex.Chat.Store.Postgres.Migrations.M20250802_chat_peer_type +import Simplex.Chat.Store.Postgres.Migrations.M20250813_delivery_tasks import Simplex.Messaging.Agent.Store.Shared (Migration (..)) schemaMigrations :: [(String, Text, Maybe Text)] @@ -31,7 +32,8 @@ schemaMigrations = ("20250721_indexes", m20250721_indexes, Just down_m20250721_indexes), ("20250729_member_contact_requests", m20250729_member_contact_requests, Just down_m20250729_member_contact_requests), ("20250801_via_group_link_uri", m20250801_via_group_link_uri, Just down_m20250801_via_group_link_uri), - ("20250802_chat_peer_type", m20250802_chat_peer_type, Just down_m20250802_chat_peer_type) + ("20250802_chat_peer_type", m20250802_chat_peer_type, Just down_m20250802_chat_peer_type), + ("20250813_delivery_tasks", m20250813_delivery_tasks, Just down_m20250813_delivery_tasks) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Chat/Store/Postgres/Migrations/M20250813_delivery_tasks.hs b/src/Simplex/Chat/Store/Postgres/Migrations/M20250813_delivery_tasks.hs new file mode 100644 index 0000000000..688c0aee76 --- /dev/null +++ b/src/Simplex/Chat/Store/Postgres/Migrations/M20250813_delivery_tasks.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Store.Postgres.Migrations.M20250813_delivery_tasks where + +import Data.Text (Text) +import qualified Data.Text as T +import Text.RawString.QQ (r) + +m20250813_delivery_tasks :: Text +m20250813_delivery_tasks = + T.pack + [r| +CREATE TABLE delivery_tasks ( + delivery_task_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + group_id BIGINT NOT NULL REFERENCES groups ON DELETE CASCADE, + worker_scope TEXT NOT NULL, + job_scope_spec_tag TEXT, + job_scope_include_pending SMALLINT, + job_scope_support_gm_id BIGINT REFERENCES group_members(group_member_id) ON DELETE CASCADE, + sender_group_member_id BIGINT NOT NULL REFERENCES group_members(group_member_id) ON DELETE CASCADE, + message_id BIGINT REFERENCES messages ON DELETE CASCADE, + message_from_channel SMALLINT NOT NULL DEFAULT 0, + task_status TEXT NOT NULL, + task_err_reason TEXT, + failed SMALLINT DEFAULT 0, + created_at TIMESTAMPTZ NOT NULL DEFAULT (now()), + updated_at TIMESTAMPTZ NOT NULL DEFAULT (now()) +); + +CREATE INDEX idx_delivery_tasks_group_id ON delivery_tasks(group_id); +CREATE INDEX idx_delivery_tasks_job_scope_support_gm_id ON delivery_tasks(job_scope_support_gm_id); +CREATE INDEX idx_delivery_tasks_sender_group_member_id ON delivery_tasks(sender_group_member_id); +CREATE INDEX idx_delivery_tasks_message_id ON delivery_tasks(message_id); + +CREATE INDEX idx_delivery_tasks_next ON delivery_tasks( + group_id, + worker_scope, + failed, + task_status +); +CREATE INDEX idx_delivery_tasks_next_for_job_scope ON delivery_tasks( + group_id, + worker_scope, + job_scope_spec_tag, + job_scope_include_pending, + job_scope_support_gm_id, + failed, + task_status +); +CREATE INDEX idx_delivery_tasks_next_for_job_scope_sender ON delivery_tasks( + group_id, + worker_scope, + job_scope_spec_tag, + job_scope_include_pending, + job_scope_support_gm_id, + sender_group_member_id, + failed, + task_status +); +CREATE INDEX idx_delivery_tasks_created_at ON delivery_tasks(created_at); + + + +CREATE TABLE delivery_jobs ( + delivery_job_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + group_id BIGINT NOT NULL REFERENCES groups ON DELETE CASCADE, + worker_scope TEXT NOT NULL, + job_scope_spec_tag TEXT, + job_scope_include_pending SMALLINT, + job_scope_support_gm_id BIGINT REFERENCES group_members(group_member_id) ON DELETE CASCADE, + single_sender_group_member_id BIGINT REFERENCES group_members(group_member_id) ON DELETE CASCADE, + body BYTEA, + cursor_group_member_id BIGINT, + job_status TEXT NOT NULL, + job_err_reason TEXT, + failed SMALLINT DEFAULT 0, + created_at TIMESTAMPTZ NOT NULL DEFAULT (now()), + updated_at TIMESTAMPTZ NOT NULL DEFAULT (now()) +); + +CREATE INDEX idx_delivery_jobs_group_id ON delivery_jobs(group_id); +CREATE INDEX idx_delivery_jobs_job_scope_support_gm_id ON delivery_jobs(job_scope_support_gm_id); +CREATE INDEX idx_delivery_jobs_single_sender_group_member_id ON delivery_jobs(single_sender_group_member_id); + +CREATE INDEX idx_delivery_jobs_next ON delivery_jobs( + group_id, + worker_scope, + failed, + job_status +); +CREATE INDEX idx_delivery_jobs_created_at ON delivery_jobs(created_at); + + + +ALTER TABLE messages ADD COLUMN broker_ts TIMESTAMPTZ; +|] + +down_m20250813_delivery_tasks :: Text +down_m20250813_delivery_tasks = + T.pack + [r| +ALTER TABLE messages DROP COLUMN broker_ts; + + + +DROP INDEX idx_delivery_jobs_group_id; +DROP INDEX idx_delivery_jobs_job_scope_support_gm_id; +DROP INDEX idx_delivery_jobs_single_sender_group_member_id; + +DROP INDEX idx_delivery_jobs_next; +DROP INDEX idx_delivery_jobs_created_at; + +DROP TABLE delivery_jobs; + + + +DROP INDEX idx_delivery_tasks_group_id; +DROP INDEX idx_delivery_tasks_job_scope_support_gm_id; +DROP INDEX idx_delivery_tasks_sender_group_member_id; +DROP INDEX idx_delivery_tasks_message_id; + +DROP INDEX idx_delivery_tasks_next; +DROP INDEX idx_delivery_tasks_next_for_job_scope; +DROP INDEX idx_delivery_tasks_next_for_job_scope_sender; +DROP INDEX idx_delivery_tasks_created_at; + +DROP TABLE delivery_tasks; +|] diff --git a/src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql b/src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql index c0560de376..695d7d393f 100644 --- a/src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql @@ -432,6 +432,66 @@ ALTER TABLE test_chat_schema.contacts ALTER COLUMN contact_id ADD GENERATED ALWA +CREATE TABLE test_chat_schema.delivery_jobs ( + delivery_job_id bigint NOT NULL, + group_id bigint NOT NULL, + worker_scope text NOT NULL, + job_scope_spec_tag text, + job_scope_include_pending smallint, + job_scope_support_gm_id bigint, + single_sender_group_member_id bigint, + body bytea, + cursor_group_member_id bigint, + job_status text NOT NULL, + job_err_reason text, + failed smallint DEFAULT 0, + created_at timestamp with time zone DEFAULT now() NOT NULL, + updated_at timestamp with time zone DEFAULT now() NOT NULL +); + + + +ALTER TABLE test_chat_schema.delivery_jobs ALTER COLUMN delivery_job_id ADD GENERATED ALWAYS AS IDENTITY ( + SEQUENCE NAME test_chat_schema.delivery_jobs_delivery_job_id_seq + START WITH 1 + INCREMENT BY 1 + NO MINVALUE + NO MAXVALUE + CACHE 1 +); + + + +CREATE TABLE test_chat_schema.delivery_tasks ( + delivery_task_id bigint NOT NULL, + group_id bigint NOT NULL, + worker_scope text NOT NULL, + job_scope_spec_tag text, + job_scope_include_pending smallint, + job_scope_support_gm_id bigint, + sender_group_member_id bigint NOT NULL, + message_id bigint, + message_from_channel smallint DEFAULT 0 NOT NULL, + task_status text NOT NULL, + task_err_reason text, + failed smallint DEFAULT 0, + created_at timestamp with time zone DEFAULT now() NOT NULL, + updated_at timestamp with time zone DEFAULT now() NOT NULL +); + + + +ALTER TABLE test_chat_schema.delivery_tasks ALTER COLUMN delivery_task_id ADD GENERATED ALWAYS AS IDENTITY ( + SEQUENCE NAME test_chat_schema.delivery_tasks_delivery_task_id_seq + START WITH 1 + INCREMENT BY 1 + NO MINVALUE + NO MAXVALUE + CACHE 1 +); + + + CREATE TABLE test_chat_schema.display_names ( user_id bigint NOT NULL, local_display_name text NOT NULL, @@ -707,7 +767,8 @@ CREATE TABLE test_chat_schema.messages ( shared_msg_id bytea, shared_msg_id_user smallint, author_group_member_id bigint, - forwarded_by_group_member_id bigint + forwarded_by_group_member_id bigint, + broker_ts timestamp with time zone ); @@ -1274,6 +1335,16 @@ ALTER TABLE ONLY test_chat_schema.contacts +ALTER TABLE ONLY test_chat_schema.delivery_jobs + ADD CONSTRAINT delivery_jobs_pkey PRIMARY KEY (delivery_job_id); + + + +ALTER TABLE ONLY test_chat_schema.delivery_tasks + ADD CONSTRAINT delivery_tasks_pkey PRIMARY KEY (delivery_task_id); + + + ALTER TABLE ONLY test_chat_schema.display_names ADD CONSTRAINT display_names_pkey PRIMARY KEY (user_id, local_display_name); @@ -1837,6 +1908,58 @@ CREATE INDEX idx_contacts_xcontact_id ON test_chat_schema.contacts USING btree ( +CREATE INDEX idx_delivery_jobs_created_at ON test_chat_schema.delivery_jobs USING btree (created_at); + + + +CREATE INDEX idx_delivery_jobs_group_id ON test_chat_schema.delivery_jobs USING btree (group_id); + + + +CREATE INDEX idx_delivery_jobs_job_scope_support_gm_id ON test_chat_schema.delivery_jobs USING btree (job_scope_support_gm_id); + + + +CREATE INDEX idx_delivery_jobs_next ON test_chat_schema.delivery_jobs USING btree (group_id, worker_scope, failed, job_status); + + + +CREATE INDEX idx_delivery_jobs_single_sender_group_member_id ON test_chat_schema.delivery_jobs USING btree (single_sender_group_member_id); + + + +CREATE INDEX idx_delivery_tasks_created_at ON test_chat_schema.delivery_tasks USING btree (created_at); + + + +CREATE INDEX idx_delivery_tasks_group_id ON test_chat_schema.delivery_tasks USING btree (group_id); + + + +CREATE INDEX idx_delivery_tasks_job_scope_support_gm_id ON test_chat_schema.delivery_tasks USING btree (job_scope_support_gm_id); + + + +CREATE INDEX idx_delivery_tasks_message_id ON test_chat_schema.delivery_tasks USING btree (message_id); + + + +CREATE INDEX idx_delivery_tasks_next ON test_chat_schema.delivery_tasks USING btree (group_id, worker_scope, failed, task_status); + + + +CREATE INDEX idx_delivery_tasks_next_for_job_scope ON test_chat_schema.delivery_tasks USING btree (group_id, worker_scope, job_scope_spec_tag, job_scope_include_pending, job_scope_support_gm_id, failed, task_status); + + + +CREATE INDEX idx_delivery_tasks_next_for_job_scope_sender ON test_chat_schema.delivery_tasks USING btree (group_id, worker_scope, job_scope_spec_tag, job_scope_include_pending, job_scope_support_gm_id, sender_group_member_id, failed, task_status); + + + +CREATE INDEX idx_delivery_tasks_sender_group_member_id ON test_chat_schema.delivery_tasks USING btree (sender_group_member_id); + + + CREATE INDEX idx_extra_xftp_file_descriptions_file_id ON test_chat_schema.extra_xftp_file_descriptions USING btree (file_id); @@ -2390,6 +2513,41 @@ ALTER TABLE ONLY test_chat_schema.contacts +ALTER TABLE ONLY test_chat_schema.delivery_jobs + ADD CONSTRAINT delivery_jobs_group_id_fkey FOREIGN KEY (group_id) REFERENCES test_chat_schema.groups(group_id) ON DELETE CASCADE; + + + +ALTER TABLE ONLY test_chat_schema.delivery_jobs + ADD CONSTRAINT delivery_jobs_job_scope_support_gm_id_fkey FOREIGN KEY (job_scope_support_gm_id) REFERENCES test_chat_schema.group_members(group_member_id) ON DELETE CASCADE; + + + +ALTER TABLE ONLY test_chat_schema.delivery_jobs + ADD CONSTRAINT delivery_jobs_single_sender_group_member_id_fkey FOREIGN KEY (single_sender_group_member_id) REFERENCES test_chat_schema.group_members(group_member_id) ON DELETE CASCADE; + + + +ALTER TABLE ONLY test_chat_schema.delivery_tasks + ADD CONSTRAINT delivery_tasks_group_id_fkey FOREIGN KEY (group_id) REFERENCES test_chat_schema.groups(group_id) ON DELETE CASCADE; + + + +ALTER TABLE ONLY test_chat_schema.delivery_tasks + ADD CONSTRAINT delivery_tasks_job_scope_support_gm_id_fkey FOREIGN KEY (job_scope_support_gm_id) REFERENCES test_chat_schema.group_members(group_member_id) ON DELETE CASCADE; + + + +ALTER TABLE ONLY test_chat_schema.delivery_tasks + ADD CONSTRAINT delivery_tasks_message_id_fkey FOREIGN KEY (message_id) REFERENCES test_chat_schema.messages(message_id) ON DELETE CASCADE; + + + +ALTER TABLE ONLY test_chat_schema.delivery_tasks + ADD CONSTRAINT delivery_tasks_sender_group_member_id_fkey FOREIGN KEY (sender_group_member_id) REFERENCES test_chat_schema.group_members(group_member_id) ON DELETE CASCADE; + + + ALTER TABLE ONLY test_chat_schema.display_names ADD CONSTRAINT display_names_user_id_fkey FOREIGN KEY (user_id) REFERENCES test_chat_schema.users(user_id) ON DELETE CASCADE; diff --git a/src/Simplex/Chat/Store/SQLite/Migrations.hs b/src/Simplex/Chat/Store/SQLite/Migrations.hs index 3d5fc307ee..e501a7d627 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations.hs +++ b/src/Simplex/Chat/Store/SQLite/Migrations.hs @@ -139,6 +139,7 @@ import Simplex.Chat.Store.SQLite.Migrations.M20250721_indexes import Simplex.Chat.Store.SQLite.Migrations.M20250729_member_contact_requests import Simplex.Chat.Store.SQLite.Migrations.M20250801_via_group_link_uri import Simplex.Chat.Store.SQLite.Migrations.M20250802_chat_peer_type +import Simplex.Chat.Store.SQLite.Migrations.M20250813_delivery_tasks import Simplex.Messaging.Agent.Store.Shared (Migration (..)) schemaMigrations :: [(String, Query, Maybe Query)] @@ -277,7 +278,8 @@ schemaMigrations = ("20250721_indexes", m20250721_indexes, Just down_m20250721_indexes), ("20250729_member_contact_requests", m20250729_member_contact_requests, Just down_m20250729_member_contact_requests), ("20250801_via_group_link_uri", m20250801_via_group_link_uri, Just down_m20250801_via_group_link_uri), - ("20250802_chat_peer_type", m20250802_chat_peer_type, Just down_m20250802_chat_peer_type) + ("20250802_chat_peer_type", m20250802_chat_peer_type, Just down_m20250802_chat_peer_type), + ("20250813_delivery_tasks", m20250813_delivery_tasks, Just down_m20250813_delivery_tasks) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/M20250813_delivery_tasks.hs b/src/Simplex/Chat/Store/SQLite/Migrations/M20250813_delivery_tasks.hs new file mode 100644 index 0000000000..dfafff674f --- /dev/null +++ b/src/Simplex/Chat/Store/SQLite/Migrations/M20250813_delivery_tasks.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Store.SQLite.Migrations.M20250813_delivery_tasks where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +-- TODO [channels fwd] add later in new migration for MemberProfileUpdate delivery jobs: +-- TODO - ALTER TABLE group_members ADD COLUMN last_profile_delivery_ts TEXT; +-- TODO - ALTER TABLE group_members ADD COLUMN join_ts TEXT; + +-- How columns correspond to types: + +-- both tables: +-- - <-> DeliveryWorkerKey = (GroupId, DeliveryWorkerScope), +-- - job_scope_spec_tag <-> Maybe DeliveryJobSpecTag (for DJSGroup job scope), +-- - job_scope_include_pending <-> Maybe Bool (for DJDeliveryJob job spec), +-- - job_scope_support_gm_id <-> Maybe GroupMemberId (for DJSMemberSupport job scope), +-- - failed <-> Bool (for internal worker use, to mark failed work items). + +-- delivery_tasks table: +-- - sender_group_member_id <-> GroupMemberId (sender of the original message that created task), +-- - message_id <-> MessageId (reference to the original message that created task), +-- - message_from_channel <-> Maybe MessageFromChannel (for MessageDeliveryTask), +-- - task_status <-> DeliveryTaskStatus, +-- - task_err_reason <-> Maybe Text (set when task status is DTSError, not encoded in status to allow filtering by DTSError in queries). + +-- delivery_jobs table: +-- - single_sender_group_member_id <-> Maybe GroupMemberId (set when all messages in job's delivery body are from the same sender), +-- - body <-> ByteString (JSON encoded batch of messages or single message packed with forwarding metadata (XGrpMsgForward)), +-- - cursor_group_member_id <-> Maybe GroupMemberId (for tracking progress of job processing buckets of recipient members), +-- - job_status <-> DeliveryJobStatus, +-- - job_err_reason <-> Maybe Text (set when job status is DJSError, not encoded in status to allow filtering by DJSError in queries). +-- +-- Pair of columns defines the scope of work for a worker. +-- +-- Both tasks and jobs are defined by the same range of worker scopes, with a delivery task worker +-- converting tasks into jobs for a delivery job worker of the same scope. +-- Each group can have up to 1 task worker and 1 job worker for each worker scope. +-- See DeliveryWorkerScope. +-- +-- Columns job_scope_spec_tag, job_scope_include_pending, job_scope_support_gm_id narrow down delivery scope for a job. +-- See DeliveryJobScope. +-- +-- In some cases multiple tasks of the same job scope may be converted into a single job. +-- For example, messages referenced in DJDeliveryJob tasks of the same scope/spec can be batched for a single delivery. +-- Some tasks, for example of DJRelayRemoved specialization, are converted one-to-one into jobs. +-- +-- Delivery scopes can be expanded to create more specialized jobs. +-- For example DWSMemberProfileUpdate workers are planned to deliver senders' profiles to +-- all members satisfying criteria: sender last_profile_delivery_ts < recipient join_ts. +-- Tasks for these jobs are planned to be created based on sender and group state, rather than per message, +-- so member profile updates will be delivered separately from message deliveries. +-- See rfc doc for more details. +m20250813_delivery_tasks :: Query +m20250813_delivery_tasks = + [sql| +CREATE TABLE delivery_tasks ( + delivery_task_id INTEGER PRIMARY KEY, + group_id INTEGER NOT NULL REFERENCES groups ON DELETE CASCADE, + worker_scope TEXT NOT NULL, + job_scope_spec_tag TEXT, + job_scope_include_pending INTEGER, + job_scope_support_gm_id INTEGER REFERENCES group_members(group_member_id) ON DELETE CASCADE, + sender_group_member_id INTEGER NOT NULL REFERENCES group_members(group_member_id) ON DELETE CASCADE, + message_id INTEGER REFERENCES messages ON DELETE CASCADE, + message_from_channel INTEGER NOT NULL DEFAULT 0, + task_status TEXT NOT NULL, + task_err_reason TEXT, + failed INTEGER DEFAULT 0, + created_at TEXT NOT NULL DEFAULT (datetime('now')), + updated_at TEXT NOT NULL DEFAULT (datetime('now')) +); + +CREATE INDEX idx_delivery_tasks_group_id ON delivery_tasks(group_id); +CREATE INDEX idx_delivery_tasks_job_scope_support_gm_id ON delivery_tasks(job_scope_support_gm_id); +CREATE INDEX idx_delivery_tasks_sender_group_member_id ON delivery_tasks(sender_group_member_id); +CREATE INDEX idx_delivery_tasks_message_id ON delivery_tasks(message_id); + +CREATE INDEX idx_delivery_tasks_next ON delivery_tasks( + group_id, + worker_scope, + failed, + task_status +); +CREATE INDEX idx_delivery_tasks_next_for_job_scope ON delivery_tasks( + group_id, + worker_scope, + job_scope_spec_tag, + job_scope_include_pending, + job_scope_support_gm_id, + failed, + task_status +); +CREATE INDEX idx_delivery_tasks_next_for_job_scope_sender ON delivery_tasks( + group_id, + worker_scope, + job_scope_spec_tag, + job_scope_include_pending, + job_scope_support_gm_id, + sender_group_member_id, + failed, + task_status +); +CREATE INDEX idx_delivery_tasks_created_at ON delivery_tasks(created_at); + + + +CREATE TABLE delivery_jobs ( + delivery_job_id INTEGER PRIMARY KEY, + group_id INTEGER NOT NULL REFERENCES groups ON DELETE CASCADE, + worker_scope TEXT NOT NULL, + job_scope_spec_tag TEXT, + job_scope_include_pending INTEGER, + job_scope_support_gm_id INTEGER REFERENCES group_members(group_member_id) ON DELETE CASCADE, + single_sender_group_member_id INTEGER REFERENCES group_members(group_member_id) ON DELETE CASCADE, + body BLOB, + cursor_group_member_id INTEGER, + job_status TEXT NOT NULL, + job_err_reason TEXT, + failed INTEGER DEFAULT 0, + created_at TEXT NOT NULL DEFAULT (datetime('now')), + updated_at TEXT NOT NULL DEFAULT (datetime('now')) +); + +CREATE INDEX idx_delivery_jobs_group_id ON delivery_jobs(group_id); +CREATE INDEX idx_delivery_jobs_job_scope_support_gm_id ON delivery_jobs(job_scope_support_gm_id); +CREATE INDEX idx_delivery_jobs_single_sender_group_member_id ON delivery_jobs(single_sender_group_member_id); + +CREATE INDEX idx_delivery_jobs_next ON delivery_jobs( + group_id, + worker_scope, + failed, + job_status +); +CREATE INDEX idx_delivery_jobs_created_at ON delivery_jobs(created_at); + + + +ALTER TABLE messages ADD COLUMN broker_ts TEXT; +|] + +down_m20250813_delivery_tasks :: Query +down_m20250813_delivery_tasks = + [sql| +ALTER TABLE messages DROP COLUMN broker_ts; + + + +DROP INDEX idx_delivery_jobs_group_id; +DROP INDEX idx_delivery_jobs_job_scope_support_gm_id; +DROP INDEX idx_delivery_jobs_single_sender_group_member_id; + +DROP INDEX idx_delivery_jobs_next; +DROP INDEX idx_delivery_jobs_created_at; + +DROP TABLE delivery_jobs; + + + +DROP INDEX idx_delivery_tasks_group_id; +DROP INDEX idx_delivery_tasks_job_scope_support_gm_id; +DROP INDEX idx_delivery_tasks_sender_group_member_id; +DROP INDEX idx_delivery_tasks_message_id; + +DROP INDEX idx_delivery_tasks_next; +DROP INDEX idx_delivery_tasks_next_for_job_scope; +DROP INDEX idx_delivery_tasks_next_for_job_scope_sender; +DROP INDEX idx_delivery_tasks_created_at; + +DROP TABLE delivery_tasks; +|] diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt b/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt index 5a76567db0..a5a494d36d 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt +++ b/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt @@ -95,6 +95,22 @@ SEARCH gp USING INTEGER PRIMARY KEY (rowid=?) SEARCH mu USING INDEX idx_group_members_contact_id (contact_id=?) SEARCH pu USING INTEGER PRIMARY KEY (rowid=?) +Query: + SELECT delivery_task_id + FROM delivery_tasks + WHERE group_id = ? + AND worker_scope = ? + AND job_scope_spec_tag IS NOT DISTINCT FROM ? + AND job_scope_include_pending IS NOT DISTINCT FROM ? + AND job_scope_support_gm_id IS NOT DISTINCT FROM ? + AND sender_group_member_id = ? + AND failed = 0 + AND task_status = ? + ORDER BY delivery_task_id ASC + +Plan: +SEARCH delivery_tasks USING COVERING INDEX idx_delivery_tasks_next_for_job_scope_sender (group_id=? AND worker_scope=? AND job_scope_spec_tag=? AND job_scope_include_pending=? AND job_scope_support_gm_id=? AND sender_group_member_id=? AND failed=? AND task_status=?) + Query: UPDATE contact_profiles SET user_id = ?, updated_at = ? @@ -417,6 +433,17 @@ Plan: SEARCH cr USING INDEX idx_contact_requests_xcontact_id (user_id=? AND xcontact_id=?) SEARCH p USING INTEGER PRIMARY KEY (rowid=?) +Query: + SELECT + delivery_job_id, + worker_scope, job_scope_spec_tag, job_scope_include_pending, job_scope_support_gm_id, + single_sender_group_member_id, body, cursor_group_member_id + FROM delivery_jobs + WHERE delivery_job_id = ? + +Plan: +SEARCH delivery_jobs USING INTEGER PRIMARY KEY (rowid=?) + Query: SELECT COUNT(1) FROM ( @@ -648,6 +675,28 @@ Plan: SEARCH m USING INTEGER PRIMARY KEY (rowid=?) SEARCH ct USING INTEGER PRIMARY KEY (rowid=?) +Query: + SELECT delivery_job_id + FROM delivery_jobs + WHERE group_id = ? AND worker_scope = ? + AND failed = 0 AND job_status = ? + ORDER BY delivery_job_id ASC + LIMIT 1 + +Plan: +SEARCH delivery_jobs USING COVERING INDEX idx_delivery_jobs_next (group_id=? AND worker_scope=? AND failed=? AND job_status=?) + +Query: + SELECT delivery_task_id + FROM delivery_tasks + WHERE group_id = ? AND worker_scope = ? + AND failed = 0 AND task_status = ? + ORDER BY delivery_task_id ASC + LIMIT 1 + +Plan: +SEARCH delivery_tasks USING COVERING INDEX idx_delivery_tasks_next (group_id=? AND worker_scope=? AND failed=? AND task_status=?) + Query: SELECT gp.display_name, gp.full_name, gp.short_descr, gp.description, gp.image, gp.preferences, gp.member_admission FROM group_profiles gp @@ -822,8 +871,9 @@ Plan: Query: INSERT INTO messages - (msg_sent, chat_msg_event, msg_body, created_at, updated_at, connection_id, group_id, shared_msg_id, author_group_member_id, forwarded_by_group_member_id) - VALUES (?,?,?,?,?,?,?,?,?,?) + (msg_sent, chat_msg_event, msg_body, broker_ts, created_at, updated_at, connection_id, group_id, + shared_msg_id, author_group_member_id, forwarded_by_group_member_id) + VALUES (?,?,?,?,?,?,?,?,?,?,?) Plan: @@ -1502,7 +1552,8 @@ Query: UPDATE group_members SET support_chat_items_unread = 0, support_chat_items_member_attention = 0, - support_chat_items_mentions = 0 + support_chat_items_mentions = 0, + updated_at = ? WHERE group_member_id = ? Plan: @@ -2996,6 +3047,23 @@ CORRELATED SCALAR SUBQUERY 1 SEARCH ci USING COVERING INDEX idx_chat_items_notes_created_at (user_id=? AND note_folder_id=?) USE TEMP B-TREE FOR ORDER BY +Query: + SELECT + t.delivery_task_id, + t.worker_scope, t.job_scope_spec_tag, t.job_scope_include_pending, t.job_scope_support_gm_id, + m.group_member_id, m.member_id, p.display_name, msg.broker_ts, msg.msg_body, t.message_from_channel + FROM delivery_tasks t + JOIN messages msg ON msg.message_id = t.message_id + JOIN group_members m ON m.group_member_id = t.sender_group_member_id + JOIN contact_profiles p ON p.contact_profile_id = COALESCE(m.member_profile_id, m.contact_profile_id) + WHERE t.delivery_task_id = ? + +Plan: +SEARCH t USING INTEGER PRIMARY KEY (rowid=?) +SEARCH msg USING INTEGER PRIMARY KEY (rowid=?) +SEARCH m USING INTEGER PRIMARY KEY (rowid=?) +SEARCH p USING INTEGER PRIMARY KEY (rowid=?) + Query: SELECT COUNT(1) FROM chat_items @@ -3990,6 +4058,22 @@ SEARCH group_members USING COVERING INDEX idx_group_members_member_profile_id (m SEARCH group_members USING COVERING INDEX idx_group_members_contact_profile_id (contact_profile_id=?) SEARCH contacts USING COVERING INDEX idx_contacts_contact_profile_id (contact_profile_id=?) +Query: + DELETE FROM delivery_jobs + WHERE created_at <= ? + AND (job_status IN (?,?) OR failed = 1) + +Plan: +SEARCH delivery_jobs USING INDEX idx_delivery_jobs_created_at (created_at True + _ -> False + mkWorkItemError errContext = SEWorkItemError {errContext} + $(J.deriveJSON (sumTypeJSON $ dropPrefix "SE") ''StoreError) insertedRowId :: DB.Connection -> IO Int64 @@ -657,7 +670,7 @@ toGroupInfo vr userContactId chatTags ((groupId, localDisplayName, displayName, groupProfile = GroupProfile {displayName, fullName, shortDescr, description, image, groupPreferences, memberAdmission} businessChat = toBusinessChatInfo businessRow preparedGroup = toPreparedGroup preparedGroupRow - in GroupInfo {groupId, localDisplayName, groupProfile, localAlias, businessChat, fullGroupPreferences, membership, chatSettings, createdAt, updatedAt, chatTs, userMemberProfileSentAt, preparedGroup, chatTags, chatItemTTL, uiThemes, customData, membersRequireAttention, viaGroupLinkUri} + in GroupInfo {groupId, useRelays = False, localDisplayName, groupProfile, localAlias, businessChat, fullGroupPreferences, membership, chatSettings, createdAt, updatedAt, chatTs, userMemberProfileSentAt, preparedGroup, chatTags, chatItemTTL, uiThemes, customData, membersRequireAttention, viaGroupLinkUri} toPreparedGroup :: PreparedGroupRow -> Maybe PreparedGroup toPreparedGroup = \case diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 5d25ae64e3..c4253942d8 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -470,6 +470,7 @@ type GroupId = Int64 data GroupInfo = GroupInfo { groupId :: GroupId, + useRelays :: Bool, localDisplayName :: GroupName, groupProfile :: GroupProfile, localAlias :: Text, diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 89bc58171c..dcaabe433e 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -2527,6 +2527,8 @@ viewChatError isCmd logLevel testView = \case | testView -> ["duplicate group message, group id: " <> sShow groupId <> ", message id: " <> sShow sharedMsgId] | otherwise -> [] SEUserNoteFolderNotFound -> ["no notes folder"] + SEInternalError {message} + | testView && message == "referenced group member not found" -> [] e -> ["chat db error: " <> sShow e] ChatErrorDatabase err -> case err of DBErrorEncrypted -> ["error: chat database is already encrypted"] diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index 7f8761c1e1..2e281cbdea 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -152,7 +152,8 @@ chatGroupTests = do it "manually accept contact with group member" testMemberContactAccept it "manually accept contact with group member incognito" testMemberContactAcceptIncognito describe "group message forwarding" $ do - it "forward messages between invitee and introduced (x.msg.new)" testGroupMsgForward + it "forward messages between invitee and introduced (x.msg.new)" testGroupMsgForwardMessage + it "forward batched messages" testGroupMsgForwardBatched it "forward reports to moderators, don't forward to members (x.msg.new, MCReport)" testGroupMsgForwardReport it "deduplicate forwarded messages" testGroupMsgForwardDeduplicate it "forward message edit (x.msg.update)" testGroupMsgForwardEdit @@ -310,46 +311,26 @@ testGroupShared alice bob cath checkMessages = do bob <## "#team: you don't have permission to send messages" bob ##> "/rm team cath" bob <## "#team: you have insufficient permissions for this action, the required role is admin" - cath #> "#team hello" - concurrentlyN_ - [ alice <# "#team cath> hello", - bob <# "#team cath> hello" - ] alice ##> "/mr team bob admin" concurrentlyN_ [ alice <## "#team: you changed the role of bob to admin", bob <## "#team: alice changed your role from observer to admin", cath <## "#team: alice changed the role of bob from observer to admin" ] - -- remove member - bob ##> "/rm team cath" - concurrentlyN_ - [ bob <## "#team: you removed cath from the group", - alice <## "#team: bob removed cath from the group", - do - cath <## "#team: bob removed you from the group" - cath <## "use /d #team to delete the group" - ] - bob #> "#team hi" - concurrently_ - (alice <# "#team bob> hi") - (cath "#team hello" - concurrently_ - (bob <# "#team alice> hello") - (cath "#team hello" - cath <## "bad chat command: not current member" -- delete contact alice ##> "/d bob" alice <## "bob: contact is deleted" bob <## "alice (Alice) deleted contact with you" when checkMessages $ threadDelay 1000000 alice #> "#team checking connection" - bob <# "#team alice> checking connection" + concurrently_ + (bob <# "#team alice> checking connection") + (cath <# "#team alice> checking connection") when checkMessages $ threadDelay 1000000 bob #> "#team received" - alice <# "#team bob> received" + concurrently_ + (alice <# "#team bob> received") + (cath <# "#team bob> received") when checkMessages $ do alice @@@ [("@cath", "sent invitation to join group team as admin"), ("#team", "received")] bob @@@ [("@alice", "contact deleted"), ("#team", "received")] @@ -710,7 +691,7 @@ testGroupDelete :: HasCallStack => TestParams -> IO () testGroupDelete = testChatCfg3 cfg aliceProfile bobProfile cathProfile $ \alice bob cath -> do - createGroup3 "team" alice bob cath + createGroup3' "team" alice (bob, GRMember) (cath, GRMember) alice ##> "/d #team" concurrentlyN_ [ alice <## "#team: you deleted the group", @@ -978,7 +959,7 @@ testGroupRemoveAdd :: HasCallStack => TestParams -> IO () testGroupRemoveAdd = testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do - createGroup3 "team" alice bob cath + createGroup3' "team" alice (bob, GRMember) (cath, GRMember) threadDelay 100000 @@ -1861,7 +1842,7 @@ testDeleteMemberWithMessages :: HasCallStack => TestParams -> IO () testDeleteMemberWithMessages = testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do - createGroup3 "team" alice bob cath + createGroup3' "team" alice (bob, GRMember) (cath, GRMember) threadDelay 750000 alice ##> "/set delete #team on" alice <## "updated group preferences:" @@ -1899,7 +1880,7 @@ testDeleteMemberMarkMessagesDeleted :: HasCallStack => TestParams -> IO () testDeleteMemberMarkMessagesDeleted = testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do - createGroup3 "team" alice bob cath + createGroup3' "team" alice (bob, GRMember) (cath, GRMember) threadDelay 1000000 bob #> "#team hello" concurrently_ @@ -4855,8 +4836,8 @@ testMemberContactAcceptIncognito = cath ?#> ("@" <> bobIncognito <> " hey") bob ?<# (cathIncognito <> "> hey") -testGroupMsgForward :: HasCallStack => TestParams -> IO () -testGroupMsgForward = +testGroupMsgForwardMessage :: HasCallStack => TestParams -> IO () +testGroupMsgForwardMessage = testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do createGroup3 "team" alice bob cath @@ -4884,6 +4865,61 @@ testGroupMsgForward = cath <# "#team bob> hi there [>>]" cath <# "#team hey team" +testGroupMsgForwardBatched :: HasCallStack => TestParams -> IO () +testGroupMsgForwardBatched = + testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + createGroup3 "team" alice bob cath + setupGroupForwarding alice bob cath + + bob ##> "/_send #1 json [{\"msgContent\": {\"type\": \"text\", \"text\": \"test 1\"}}, {\"msgContent\": {\"type\": \"text\", \"text\": \"test 2\"}}, {\"msgContent\": {\"type\": \"text\", \"text\": \"test 3\"}}]" + bob <# "#team test 1" + bob <# "#team test 2" + bob <# "#team test 3" + alice <# "#team bob> test 1" + alice <# "#team bob> test 2" + alice <# "#team bob> test 3" + cath <# "#team bob> test 1 [>>]" + cath <# "#team bob> test 2 [>>]" + cath <# "#team bob> test 3 [>>]" + + threadDelay 1000000 + + cath ##> "/_send #1 json [{\"msgContent\": {\"type\": \"text\", \"text\": \"test 4\"}}, {\"msgContent\": {\"type\": \"text\", \"text\": \"test 5\"}}, {\"msgContent\": {\"type\": \"text\", \"text\": \"test 6\"}}]" + cath <# "#team test 4" + cath <# "#team test 5" + cath <# "#team test 6" + alice <# "#team cath> test 4" + alice <# "#team cath> test 5" + alice <# "#team cath> test 6" + bob <# "#team cath> test 4 [>>]" + bob <# "#team cath> test 5 [>>]" + bob <# "#team cath> test 6 [>>]" + + alice ##> "/tail #team 6" + alice <# "#team bob> test 1" + alice <# "#team bob> test 2" + alice <# "#team bob> test 3" + alice <# "#team cath> test 4" + alice <# "#team cath> test 5" + alice <# "#team cath> test 6" + + bob ##> "/tail #team 6" + bob <# "#team test 1" + bob <# "#team test 2" + bob <# "#team test 3" + bob <# "#team cath> test 4 [>>]" + bob <# "#team cath> test 5 [>>]" + bob <# "#team cath> test 6 [>>]" + + cath ##> "/tail #team 6" + cath <# "#team bob> test 1 [>>]" + cath <# "#team bob> test 2 [>>]" + cath <# "#team bob> test 3 [>>]" + cath <# "#team test 4" + cath <# "#team test 5" + cath <# "#team test 6" + testGroupMsgForwardReport :: HasCallStack => TestParams -> IO () testGroupMsgForwardReport = testChat3 aliceProfile bobProfile cathProfile $ diff --git a/tests/ChatTests/Profiles.hs b/tests/ChatTests/Profiles.hs index 07bf06b61b..f71e735486 100644 --- a/tests/ChatTests/Profiles.hs +++ b/tests/ChatTests/Profiles.hs @@ -1657,11 +1657,11 @@ testJoinGroupIncognito = alice <## "group #secret_club is created" alice <## "to add members use /a secret_club or /create link #secret_club" -- alice invites bob - alice ##> "/a secret_club bob admin" + alice ##> "/a secret_club bob member" concurrentlyN_ [ alice <## "invitation to join the group #secret_club sent to bob", do - bob <## "#secret_club: alice invites you to join the group as admin" + bob <## "#secret_club: alice invites you to join the group as member" bob <## "use /j secret_club to accept" ] bob ##> "/j secret_club" @@ -1669,11 +1669,11 @@ testJoinGroupIncognito = (alice <## "#secret_club: bob joined the group") (bob <## "#secret_club: you joined the group") -- alice invites cath - alice ##> ("/a secret_club " <> cathIncognito <> " admin") + alice ##> ("/a secret_club " <> cathIncognito <> " member") concurrentlyN_ [ alice <## ("invitation to join the group #secret_club sent to " <> cathIncognito), do - cath <## "#secret_club: alice invites you to join the group as admin" + cath <## "#secret_club: alice invites you to join the group as member" cath <## ("use /j secret_club to join incognito as " <> cathIncognito) ] -- cath uses the same incognito profile when joining group, cath and bob don't merge contacts @@ -1687,15 +1687,12 @@ testJoinGroupIncognito = bob <## ("#secret_club: alice added " <> cathIncognito <> " to the group (connecting...)") bob <## ("#secret_club: new member " <> cathIncognito <> " is connected") ] - -- cath cannot invite to the group because her membership is incognito - cath ##> "/a secret_club dan" - cath <## "you are using an incognito profile for this group - prohibited to invite contacts" -- alice invites dan - alice ##> "/a secret_club dan admin" + alice ##> "/a secret_club dan member" concurrentlyN_ [ alice <## "invitation to join the group #secret_club sent to dan", do - dan <## "#secret_club: alice invites you to join the group as admin" + dan <## "#secret_club: alice invites you to join the group as member" dan <## "use /j secret_club to accept" ] dan ##> "/j secret_club" @@ -1754,39 +1751,39 @@ testJoinGroupIncognito = alice ##> "/ms secret_club" alice <### [ "alice (Alice): owner, you, created group", - "bob (Bob): admin, invited, connected", - ConsoleString $ cathIncognito <> ": admin, invited, connected", - "dan (Daniel): admin, invited, connected" + "bob (Bob): member, invited, connected", + ConsoleString $ cathIncognito <> ": member, invited, connected", + "dan (Daniel): member, invited, connected" ] bob ##> "/ms secret_club" bob <### [ "alice (Alice): owner, host, connected", - "bob (Bob): admin, you, connected", - ConsoleString $ cathIncognito <> ": admin, connected", - "dan (Daniel): admin, connected" + "bob (Bob): member, you, connected", + ConsoleString $ cathIncognito <> ": member, connected", + "dan (Daniel): member, connected" ] cath ##> "/ms secret_club" cath <### [ "alice (Alice): owner, host, connected", - "bob_1 (Bob): admin, connected", - ConsoleString $ "i " <> cathIncognito <> ": admin, you, connected", - "dan_1 (Daniel): admin, connected" + "bob_1 (Bob): member, connected", + ConsoleString $ "i " <> cathIncognito <> ": member, you, connected", + "dan_1 (Daniel): member, connected" ] dan ##> "/ms secret_club" dan <### [ "alice (Alice): owner, host, connected", - "bob (Bob): admin, connected", - ConsoleString $ cathIncognito <> ": admin, connected", - "dan (Daniel): admin, you, connected" + "bob (Bob): member, connected", + ConsoleString $ cathIncognito <> ": member, connected", + "dan (Daniel): member, you, connected" ] -- remove member - bob ##> ("/rm secret_club " <> cathIncognito) + alice ##> ("/rm secret_club " <> cathIncognito) concurrentlyN_ - [ bob <## ("#secret_club: you removed " <> cathIncognito <> " from the group"), - alice <## ("#secret_club: bob removed " <> cathIncognito <> " from the group"), - dan <## ("#secret_club: bob removed " <> cathIncognito <> " from the group"), + [ alice <## ("#secret_club: you removed " <> cathIncognito <> " from the group"), + bob <## ("#secret_club: alice removed " <> cathIncognito <> " from the group"), + dan <## ("#secret_club: alice removed " <> cathIncognito <> " from the group"), do - cath <## "#secret_club: bob_1 removed you from the group" + cath <## "#secret_club: alice removed you from the group" cath <## "use /d #secret_club to delete the group" ] bob #> "#secret_club hi"