From b97a40f3565adf5762bf8d7bef8e85a536f003a7 Mon Sep 17 00:00:00 2001 From: sh <37271604+shumvgolove@users.noreply.github.com> Date: Tue, 9 Sep 2025 07:56:02 +0000 Subject: [PATCH 01/64] flatpak: update metainfo (#6257) --- .../flatpak/chat.simplex.simplex.metainfo.xml | 21 +++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/scripts/flatpak/chat.simplex.simplex.metainfo.xml b/scripts/flatpak/chat.simplex.simplex.metainfo.xml index 630b178aaf..e44251361a 100644 --- a/scripts/flatpak/chat.simplex.simplex.metainfo.xml +++ b/scripts/flatpak/chat.simplex.simplex.metainfo.xml @@ -38,6 +38,27 @@ + + https://simplex.chat/blog/20250729-simplex-chat-v6-4-1-welcome-contacts-protect-groups-app-security.html + +

New in v6.4.5:

+
    +
  • fixes for chats with admins.
    • +
  • better information about network errors.
    • +
+

New in v6.4-6.4.4:

+
    +
  • new UX to connect.
    • +
  • review new group members.
    • +
  • chat with group admins.
    • +
  • new UI languages: Catalan, Indonesian, Romanian and Vietnamese.
    • +
  • Linux app builds for aarch64 CPUs
    • +
  • UI support for bot commands.
    • +
  • support markdown hyperlinks, such as [click here](https://example.com).
    • +
  • option to remove tracking parameters from the links.
    • +
+ + https://simplex.chat/blog/20250729-simplex-chat-v6-4-1-welcome-contacts-protect-groups-app-security.html From f2061a7c88dd505618bb6c1d034a44a31727a4f5 Mon Sep 17 00:00:00 2001 From: sh <37271604+shumvgolove@users.noreply.github.com> Date: Fri, 12 Sep 2025 08:16:12 +0000 Subject: [PATCH 02/64] ci: update libffi to 3.5.2 in Mac build (#6258) --- scripts/desktop/build-lib-mac.sh | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/scripts/desktop/build-lib-mac.sh b/scripts/desktop/build-lib-mac.sh index 934d9b8d7d..a3a824f81b 100755 --- a/scripts/desktop/build-lib-mac.sh +++ b/scripts/desktop/build-lib-mac.sh @@ -41,12 +41,12 @@ mkdir deps 2> /dev/null || true #cp $GHC_LIBS_DIR/libffi.dylib ./deps ( BUILD=$PWD - cp /tmp/libffi-3.4.4/*-apple-darwin*/.libs/libffi.dylib $BUILD/deps || \ + cp /tmp/libffi-3.5.2/*-apple-darwin*/.libs/libffi.dylib $BUILD/deps || \ ( \ cd /tmp && \ - curl --tlsv1.2 "https://gitlab.haskell.org/ghc/libffi-tarballs/-/raw/libffi-3.4.4/libffi-3.4.4.tar.gz?inline=false" -o libffi.tar.gz && \ + curl --tlsv1.2 "https://gitlab.haskell.org/ghc/libffi-tarballs/-/raw/3914c27381526ce586ea0ac0359a332fd82987af/libffi-3.5.2.tar.gz?inline=false" -o libffi.tar.gz && \ tar -xzvf libffi.tar.gz && \ - cd "libffi-3.4.4" && \ + cd "libffi-3.5.2" && \ ./configure && \ make && \ cp *-apple-darwin*/.libs/libffi.dylib $BUILD/deps \ From 382241fe3efab8d8d2cad2d8aaed61aed3f4fe67 Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Fri, 12 Sep 2025 13:22:34 +0000 Subject: [PATCH 03/64] core: rework synchronous group forwarding in receive loop into asynchronous delivery tasks (#6178) --- bots/api/TYPES.md | 21 + cabal.project | 2 +- docs/rfcs/2025-08-11-channels-forwarding.md | 237 ++++++++ .../types/typescript/src/types.ts | 36 ++ scripts/nix/sha256map.nix | 2 +- simplex-chat.cabal | 4 + src/Simplex/Chat.hs | 4 + src/Simplex/Chat/Controller.hs | 5 +- src/Simplex/Chat/Delivery.hs | 188 ++++++ src/Simplex/Chat/Library/Commands.hs | 18 +- src/Simplex/Chat/Library/Internal.hs | 54 +- src/Simplex/Chat/Library/Subscriber.hs | 541 ++++++++++++------ src/Simplex/Chat/Messages.hs | 23 +- src/Simplex/Chat/Messages/Batch.hs | 43 ++ src/Simplex/Chat/Protocol.hs | 36 +- src/Simplex/Chat/Store/Delivery.hs | 362 ++++++++++++ src/Simplex/Chat/Store/Groups.hs | 4 +- src/Simplex/Chat/Store/Messages.hs | 23 +- src/Simplex/Chat/Store/Postgres/Migrations.hs | 4 +- .../Migrations/M20250813_delivery_tasks.hs | 128 +++++ .../Store/Postgres/Migrations/chat_schema.sql | 160 +++++- src/Simplex/Chat/Store/SQLite/Migrations.hs | 4 +- .../Migrations/M20250813_delivery_tasks.hs | 172 ++++++ .../SQLite/Migrations/chat_query_plans.txt | 156 ++++- .../Store/SQLite/Migrations/chat_schema.sql | 83 ++- src/Simplex/Chat/Store/Shared.hs | 15 +- src/Simplex/Chat/Types.hs | 1 + src/Simplex/Chat/View.hs | 2 + tests/ChatTests/Groups.hs | 102 ++-- tests/ChatTests/Profiles.hs | 49 +- 30 files changed, 2151 insertions(+), 328 deletions(-) create mode 100644 docs/rfcs/2025-08-11-channels-forwarding.md create mode 100644 src/Simplex/Chat/Delivery.hs create mode 100644 src/Simplex/Chat/Store/Delivery.hs create mode 100644 src/Simplex/Chat/Store/Postgres/Migrations/M20250813_delivery_tasks.hs create mode 100644 src/Simplex/Chat/Store/SQLite/Migrations/M20250813_delivery_tasks.hs 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" From fa9bc1537c4dd87b6468a4d38cbeae5744959e64 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Sun, 14 Sep 2025 14:41:50 +0100 Subject: [PATCH 04/64] cli: option to disable backup or change backup directory on migration (#6267) * cli: option to disable backup or change backup directory on migration * update nix * update simplexmq --- cabal.project | 2 +- scripts/nix/sha256map.nix | 2 +- src/Simplex/Chat.hs | 10 +++++----- src/Simplex/Chat/Core.hs | 8 ++++---- src/Simplex/Chat/Mobile.hs | 10 ++++++---- src/Simplex/Chat/Options.hs | 7 +++++-- src/Simplex/Chat/Options/Postgres.hs | 3 +++ src/Simplex/Chat/Options/SQLite.hs | 13 +++++++++++++ src/Simplex/Chat/Store.hs | 4 ++-- tests/ChatClient.hs | 7 ++++--- tests/MobileTests.hs | 4 ++-- tests/SchemaDump.hs | 12 ++++++------ 12 files changed, 52 insertions(+), 30 deletions(-) diff --git a/cabal.project b/cabal.project index 8a861a1909..48ac0dc24c 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: 8a7991a3768d632346c8d8f3c319ed64ccba93b6 source-repository-package type: git diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index a5f2790418..09a1407a31 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"."8a7991a3768d632346c8d8f3c319ed64ccba93b6" = "14p3436bvbxrcx3sp2gy97ycc7v0wzhar8vvxa6lcs8anki1va08"; "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/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index e14275b75c..7fa8380c2f 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -45,7 +45,7 @@ import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.Store.Common (DBStore (dbNew)) import qualified Simplex.Messaging.Agent.Store.DB as DB import Simplex.Messaging.Agent.Store.Entity -import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError) +import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..), MigrationError) import Simplex.Messaging.Client (defaultNetworkConfig) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolType (..), SProtocolType (..), SubscriptionMode (..), UserProtocol) @@ -115,10 +115,10 @@ defaultChatConfig = logCfg :: LogConfig logCfg = LogConfig {lc_file = Nothing, lc_stderr = True} -createChatDatabase :: ChatDbOpts -> MigrationConfirmation -> IO (Either MigrationError ChatDatabase) -createChatDatabase chatDbOpts confirmMigrations = runExceptT $ do - chatStore <- ExceptT $ createChatStore (toDBOpts chatDbOpts chatSuffix False) confirmMigrations - agentStore <- ExceptT $ createAgentStore (toDBOpts chatDbOpts agentSuffix False) confirmMigrations +createChatDatabase :: ChatDbOpts -> MigrationConfig -> IO (Either MigrationError ChatDatabase) +createChatDatabase chatDbOpts migrationConfig = runExceptT $ do + chatStore <- ExceptT $ createChatStore (toDBOpts chatDbOpts chatSuffix False) migrationConfig + agentStore <- ExceptT $ createAgentStore (toDBOpts chatDbOpts agentSuffix False) migrationConfig pure ChatDatabase {chatStore, agentStore} newChatController :: ChatDatabase -> Maybe User -> ChatConfig -> ChatOpts -> Bool -> IO ChatController diff --git a/src/Simplex/Chat/Core.hs b/src/Simplex/Chat/Core.hs index fabc45a04c..131b420bd9 100644 --- a/src/Simplex/Chat/Core.hs +++ b/src/Simplex/Chat/Core.hs @@ -30,7 +30,7 @@ import Simplex.Chat.Store.Profiles import Simplex.Chat.Types import Simplex.Chat.Types.Preferences (FeatureAllowed (..), FilesPreference (..), Preferences (..), emptyChatPrefs) import Simplex.Chat.View (ChatResponseEvent, serializeChatError, serializeChatResponse) -import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..)) +import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..)) import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction) import System.Exit (exitFailure) import System.IO (hFlush, stdout) @@ -38,15 +38,15 @@ import Text.Read (readMaybe) import UnliftIO.Async simplexChatCore :: ChatConfig -> ChatOpts -> (User -> ChatController -> IO ()) -> IO () -simplexChatCore cfg@ChatConfig {confirmMigrations, testView, chatHooks} opts@ChatOpts {coreOptions = CoreChatOpts {dbOptions, logAgent, yesToUpMigrations}, createBot, maintenance} chat = +simplexChatCore cfg@ChatConfig {confirmMigrations, testView, chatHooks} opts@ChatOpts {coreOptions = CoreChatOpts {dbOptions, logAgent, yesToUpMigrations, migrationBackupPath}, createBot, maintenance} chat = case logAgent of Just level -> do setLogLevel level withGlobalLogging logCfg initRun _ -> initRun where - initRun = createChatDatabase dbOptions confirm' >>= either exit run - confirm' = if confirmMigrations == MCConsole && yesToUpMigrations then MCYesUp else confirmMigrations + initRun = createChatDatabase dbOptions migrationConfig >>= either exit run + migrationConfig = MigrationConfig (if confirmMigrations == MCConsole && yesToUpMigrations then MCYesUp else confirmMigrations) migrationBackupPath exit e = do putStrLn $ "Error opening database: " <> show e exitFailure diff --git a/src/Simplex/Chat/Mobile.hs b/src/Simplex/Chat/Mobile.hs index f18a3900da..fc61fa6fb5 100644 --- a/src/Simplex/Chat/Mobile.hs +++ b/src/Simplex/Chat/Mobile.hs @@ -50,7 +50,7 @@ import Simplex.Chat.Types import Simplex.Messaging.Agent.Client (agentClientStore) import Simplex.Messaging.Agent.Env.SQLite (createAgentStore) import Simplex.Messaging.Agent.Store.Interface (closeDBStore, reopenDBStore) -import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError) +import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..), MigrationError) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, sumTypeJSON) @@ -254,7 +254,8 @@ mobileChatOpts dbOptions = tbqSize = 4096, deviceName = Nothing, highlyAvailable = False, - yesToUpMigrations = False + yesToUpMigrations = False, + migrationBackupPath = Just "" }, chatCmd = "", chatCmdDelay = 3, @@ -294,8 +295,9 @@ chatMigrateInit dbFilePrefix dbKey confirm = do chatMigrateInitKey :: ChatDbOpts -> Bool -> String -> Bool -> IO (Either DBMigrationResult ChatController) chatMigrateInitKey chatDbOpts keepKey confirm backgroundMode = runExceptT $ do confirmMigrations <- liftEitherWith (const DBMInvalidConfirmation) $ strDecode $ B.pack confirm - chatStore <- migrate createChatStore (toDBOpts chatDbOpts chatSuffix keepKey) confirmMigrations - agentStore <- migrate createAgentStore (toDBOpts chatDbOpts agentSuffix keepKey) confirmMigrations + let migrationConfig = MigrationConfig confirmMigrations (Just "") + chatStore <- migrate createChatStore (toDBOpts chatDbOpts chatSuffix keepKey) migrationConfig + agentStore <- migrate createAgentStore (toDBOpts chatDbOpts agentSuffix keepKey) migrationConfig liftIO $ initialize chatStore ChatDatabase {chatStore, agentStore} where opts = mobileChatOpts $ removeDbKey chatDbOpts diff --git a/src/Simplex/Chat/Options.hs b/src/Simplex/Chat/Options.hs index 9411c66175..2a224aca8b 100644 --- a/src/Simplex/Chat/Options.hs +++ b/src/Simplex/Chat/Options.hs @@ -67,7 +67,8 @@ data CoreChatOpts = CoreChatOpts tbqSize :: Natural, deviceName :: Maybe Text, highlyAvailable :: Bool, - yesToUpMigrations :: Bool + yesToUpMigrations :: Bool, + migrationBackupPath :: Maybe FilePath } data CreateBotOpts = CreateBotOpts @@ -243,6 +244,7 @@ coreChatOptsP appDir defaultDbName = do <> short 'y' <> help "Automatically confirm \"up\" database migrations" ) + migrationBackupPath <- migrationBackupPathP pure CoreChatOpts { dbOptions, @@ -268,7 +270,8 @@ coreChatOptsP appDir defaultDbName = do tbqSize, deviceName, highlyAvailable, - yesToUpMigrations + yesToUpMigrations, + migrationBackupPath } where useTcpTimeout p t = 1000000 * if t > 0 then t else maybe 7 (const 15) p diff --git a/src/Simplex/Chat/Options/Postgres.hs b/src/Simplex/Chat/Options/Postgres.hs index f7c429e93e..46c1faa5e0 100644 --- a/src/Simplex/Chat/Options/Postgres.hs +++ b/src/Simplex/Chat/Options/Postgres.hs @@ -52,6 +52,9 @@ chatDbOptsP _appDir defaultDbName = do ) pure ChatDbOpts {dbConnstr, dbSchemaPrefix, dbPoolSize, dbCreateSchema} +migrationBackupPathP :: Parser (Maybe FilePath) +migrationBackupPathP = pure Nothing + dbString :: ChatDbOpts -> String dbString ChatDbOpts {dbConnstr} = dbConnstr diff --git a/src/Simplex/Chat/Options/SQLite.hs b/src/Simplex/Chat/Options/SQLite.hs index 0507076613..d2e79eea79 100644 --- a/src/Simplex/Chat/Options/SQLite.hs +++ b/src/Simplex/Chat/Options/SQLite.hs @@ -54,6 +54,19 @@ chatDbOptsP appDir defaultDbName = do vacuumOnMigration = not disableVacuum } +migrationBackupPathP :: Parser (Maybe FilePath) +migrationBackupPathP = + flag' Nothing + ( long "disable-backup" + <> help "Disable backup when migrating database" + ) + <|> + (fmap Just . strOption) + ( long "backup-directory" + <> help "Directory to backup database for migration" + <> value "" + ) + dbString :: ChatDbOpts -> String dbString ChatDbOpts {dbFilePrefix} = dbFilePrefix <> "_chat.db, " <> dbFilePrefix <> "_agent.db" diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index d3d3395ed1..e80037be74 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -21,12 +21,12 @@ import Simplex.Chat.Store.Profiles import Simplex.Chat.Store.Shared import Simplex.Messaging.Agent.Store.Common (DBStore (..), withTransaction) import Simplex.Messaging.Agent.Store.Interface (DBOpts, createDBStore) -import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation, MigrationError) +import Simplex.Messaging.Agent.Store.Shared (MigrationConfig, MigrationError) #if defined(dbPostgres) import Simplex.Chat.Store.Postgres.Migrations #else import Simplex.Chat.Store.SQLite.Migrations #endif -createChatStore :: DBOpts -> MigrationConfirmation -> IO (Either MigrationError DBStore) +createChatStore :: DBOpts -> MigrationConfig -> IO (Either MigrationError DBStore) createChatStore dbCreateOpts = createDBStore dbCreateOpts migrations diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index acf7903003..5e5c34d516 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -47,7 +47,7 @@ import Simplex.Messaging.Agent.Env.SQLite import Simplex.Messaging.Agent.Protocol (currentSMPAgentVersion, duplexHandshakeSMPAgentVersion, pqdrSMPAgentVersion, supportedSMPAgentVRange) import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Agent.Store.Interface (closeDBStore) -import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..), MigrationError) +import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..), MigrationError) import qualified Simplex.Messaging.Agent.Store.DB as DB import Simplex.Messaging.Client (ProtocolClientConfig (..)) import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig) @@ -151,7 +151,8 @@ testCoreOpts = tbqSize = 16, deviceName = Nothing, highlyAvailable = False, - yesToUpMigrations = False + yesToUpMigrations = False, + migrationBackupPath = Nothing } #if !defined(dbPostgres) @@ -302,7 +303,7 @@ insertUser :: DBStore -> IO () insertUser st = withTransaction st (`DB.execute_` "INSERT INTO users DEFAULT VALUES") #else createDatabase TestParams {tmpPath} CoreChatOpts {dbOptions} dbPrefix = do - createChatDatabase dbOptions {dbFilePrefix = tmpPath dbPrefix} MCError + createChatDatabase dbOptions {dbFilePrefix = tmpPath dbPrefix} (MigrationConfig MCError Nothing) insertUser :: DBStore -> IO () insertUser st = withTransaction st (`DB.execute_` "INSERT INTO users (user_id) VALUES (1)") diff --git a/tests/MobileTests.hs b/tests/MobileTests.hs index 0ba784a1fc..1814ccb564 100644 --- a/tests/MobileTests.hs +++ b/tests/MobileTests.hs @@ -38,7 +38,7 @@ import Simplex.Chat.Store import Simplex.Chat.Store.Profiles import Simplex.Chat.Types (AgentUserId (..), Profile (..)) import Simplex.Messaging.Agent.Store.Interface -import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..)) +import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..)) import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile(..), CryptoFileArgs (..)) @@ -167,7 +167,7 @@ testChatApi ps = do let tmp = tmpPath ps dbPrefix = tmp "1" f = dbPrefix <> chatSuffix - Right st <- createChatStore (DBOpts f "myKey" False True DB.TQOff) MCYesUp + Right st <- createChatStore (DBOpts f "myKey" False True DB.TQOff) (MigrationConfig MCYesUp Nothing) Right _ <- withTransaction st $ \db -> runExceptT $ createUserRecord db (AgentUserId 1) aliceProfile {preferences = Nothing} True Right cc <- chatMigrateInit dbPrefix "myKey" "yesUp" Left (DBMErrorNotADatabase _) <- chatMigrateInit dbPrefix "" "yesUp" diff --git a/tests/SchemaDump.hs b/tests/SchemaDump.hs index df1739449e..5b6fffd7dc 100644 --- a/tests/SchemaDump.hs +++ b/tests/SchemaDump.hs @@ -26,7 +26,7 @@ import Simplex.Messaging.Agent.Store.DB (TrackQueries (..)) import qualified Simplex.Messaging.Agent.Store.DB as DB import Simplex.Messaging.Agent.Store.Interface import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations -import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationsToRun (..), toDownMigration) +import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfig (..), MigrationConfirmation (..), MigrationsToRun (..), toDownMigration) import Simplex.Messaging.Util (ifM, tshow, whenM) import System.Directory (doesFileExist, removeFile) import System.Process (readCreateProcess, shell) @@ -63,7 +63,7 @@ testVerifySchemaDump :: IO () testVerifySchemaDump = withTmpFiles $ do savedSchema <- ifM (doesFileExist appSchema) (readFile appSchema) (pure "") savedSchema `deepseq` pure () - void $ createChatStore (DBOpts testDB "" False True TQOff) MCError + void $ createChatStore (DBOpts testDB "" False True TQOff) (MigrationConfig MCError Nothing) getSchema testDB appSchema `shouldReturn` savedSchema removeFile testDB @@ -71,14 +71,14 @@ testVerifyLintFKeyIndexes :: IO () testVerifyLintFKeyIndexes = withTmpFiles $ do savedLint <- ifM (doesFileExist appLint) (readFile appLint) (pure "") savedLint `deepseq` pure () - void $ createChatStore (DBOpts testDB "" False True TQOff) MCError + void $ createChatStore (DBOpts testDB "" False True TQOff) (MigrationConfig MCError Nothing) getLintFKeyIndexes testDB "tests/tmp/chat_lint.sql" `shouldReturn` savedLint removeFile testDB testSchemaMigrations :: IO () testSchemaMigrations = withTmpFiles $ do let noDownMigrations = dropWhileEnd (\Migration {down} -> isJust down) Store.migrations - Right st <- createDBStore (DBOpts testDB "" False True TQOff) noDownMigrations MCError + Right st <- createDBStore (DBOpts testDB "" False True TQOff) noDownMigrations (MigrationConfig MCError Nothing) mapM_ (testDownMigration st) $ drop (length noDownMigrations) Store.migrations closeDBStore st removeFile testDB @@ -150,7 +150,7 @@ saveQueryPlans = it "verify and overwrite query plans" $ \TestParams {chatQueryS updatePlans appChatQueryPlans chatQueryStats - (createChatStore (DBOpts testDB "" False True TQOff) MCError) + (createChatStore (DBOpts testDB "" False True TQOff) (MigrationConfig MCError Nothing)) (\db -> do DB.execute_ db "CREATE TABLE IF NOT EXISTS temp_conn_ids (conn_id BLOB)" DB.execute_ db "CREATE TABLE IF NOT EXISTS temp_delete_members (contact_profile_id INTEGER, member_profile_id INTEGER, local_display_name TEXT)" @@ -159,7 +159,7 @@ saveQueryPlans = it "verify and overwrite query plans" $ \TestParams {chatQueryS updatePlans appAgentQueryPlans agentQueryStats - (createAgentStore (DBOpts testAgentDB "" False True TQOff) MCError) + (createAgentStore (DBOpts testAgentDB "" False True TQOff) (MigrationConfig MCError Nothing)) (const $ pure ()) chatSavedPlans' == chatSavedPlans `shouldBe` True agentSavedPlans' == agentSavedPlans `shouldBe` True From 7c92c7666c7c8ae7e4a15068d869c1ff66cd1900 Mon Sep 17 00:00:00 2001 From: sh <37271604+shumvgolove@users.noreply.github.com> Date: Mon, 15 Sep 2025 13:06:39 +0000 Subject: [PATCH 05/64] scripts/db: update documentation, add pg -> sqlite section (#6177) * scripts/db: update doc * scripts/db: update documentation, add pg2sqlite script * scripts/db/pg2sqlite: formatiing, code quality, modularity * scripts/db: parallel pgloader --- scripts/db/README.md | 358 +++++++++++++--- scripts/db/pg2sqlite.py | 899 ++++++++++++++++++++++++++++++++++++++++ scripts/db/sqlite.load | 3 +- 3 files changed, 1197 insertions(+), 63 deletions(-) create mode 100755 scripts/db/pg2sqlite.py diff --git a/scripts/db/README.md b/scripts/db/README.md index 68d4f74ac7..333a6f4acf 100644 --- a/scripts/db/README.md +++ b/scripts/db/README.md @@ -1,96 +1,286 @@ -# Transfer data from SQLite to Postgres database +## Transfer data from SQLite to Postgres database -1. \* Decrypt SQLite database if it is encrypted. +1. Decrypt SQLite database if it is encrypted. - ```sh - sqlcipher encrypted_simplex_v1_agent.db - ``` + 1. Agent: - ```sql - PRAGMA key = 'password'; - ATTACH DATABASE 'simplex_v1_agent.db' AS plaintext KEY ''; - SELECT sqlcipher_export('plaintext'); - DETACH DATABASE plaintext; - ``` + 1. Open sqlite db: - Repeat for `simplex_v1_chat.db`. + ```sh + sqlcipher simplex_v1_agent.db + ``` + + 2. Set your db password: + + ```sql + PRAGMA key = ''; + ``` + + 3. Check if db was successfully decrypted: + + ```sh + SELECT count(*) FROM sqlite_master; + ``` + + 4. Attach new empty db: + + ```sh + ATTACH DATABASE 'simplex_v1_agent_plaintext.db' AS plaintext KEY ''; + ``` + + 5. Export opened db to attached db as plaintext: + + ```sh + SELECT sqlcipher_export('plaintext'); + ``` + + 6. Deattach the plaintext db: + + ```sh + DETACH DATABASE plaintext; + ``` + + 2. Chat: + + 1. Open sqlite db: + + ```sh + sqlcipher simplex_v1_chat.db + ``` + + 2. Set your db password: + + ```sql + PRAGMA key = ''; + ``` + + 3. Check if db was successfully decrypted: + + ```sh + SELECT count(*) FROM sqlite_master; + ``` + + 4. Attach new empty db: + + ```sh + ATTACH DATABASE 'simplex_v1_chat_plaintext.db' AS plaintext KEY ''; + ``` + + 5. Export opened db to attached db as plaintext: + + ```sh + SELECT sqlcipher_export('plaintext'); + ``` + + 6. Deattach the plaintext db: + + ```sh + DETACH DATABASE plaintext; + ``` 2. Prepare Postgres database. - - Create Postgres database. In shell: + 1. Connect to PostgreSQL databse: ```sh - createdb -O simplex simplex_v1 + psql -U postgres -h localhost ``` - Or via query. + 2. Create user with password: - - Build `simplex-chat` executable with `client_postgres` flag and run it to initialize new chat database. + ```sh + CREATE USER simplex WITH ENCRYPTED PASSWORD '123123'; + ``` - This should create `simplex_v1_agent_schema` and `simplex_v1_chat_schema` schemas in `simplex_v1` database, with `migrations` tables populated. Some tables would have initialization data - it will be truncated via pgloader command in next step. + 3. Create database: + + ```sh + CREATE DATABASE simplex_v1; + ``` + + 4. Assign permissions: + + ```sh + GRANT ALL PRIVILEGES ON DATABASE simplex_v1 TO simplex; + ``` + +3. Prepare database: + + You should build the CLI binary from the same `TAG` as the desktop. + + 1. Build CLI with PostgreSQL support: + + ```sh + cabal build -fclient_postgres exe:simplex-chat + ``` + + And rename it to: + + ```sh + mv simplex-chat simplex-chat-pg + ``` + + 2. Execute CLI: + + ```sh + ./simplex-chat-pg -d "postgresql://simplex:123123@localhost:5432/simplex_v1" --create-schema + ``` + + Press `Ctrl+C` when CLI ask for a display name. + + This should create `simplex_v1_agent_schema` and `simplex_v1_chat_schema` schemas in `simplex_v1` database, with `migrations` tables populated. Some tables would have initialization data - it will be truncated via pgloader command in next step. 3. Load data from decrypted SQLite databases to Postgres database via pgloader. Install pgloader and add it to PATH. Run in shell (substitute paths): ```sh - SQLITE_DBPATH='simplex_v1_agent.db' POSTGRES_CONN='postgres://simplex@/simplex_v1' POSTGRES_SCHEMA='simplex_v1_agent_schema' pgloader --on-error-stop sqlite.load + export POSTGRES_CONN='postgresql://simplex:123123@localhost:5432/simplex_v1' + ``` - SQLITE_DBPATH='simplex_v1_chat.db' POSTGRES_CONN='postgres://simplex@/simplex_v1' POSTGRES_SCHEMA='simplex_v1_chat_schema' pgloader --on-error-stop sqlite.load + And then: + + ```sh + SQLITE_DBPATH='simplex_v1_agent_plaintext.db' \ + POSTGRES_SCHEMA='simplex_v1_agent_schema' \ + CPU_CORES=$(nproc) WORKERS=$((CPU_CORES - 1)) pgloader --dynamic-space-size 262144 --on-error-stop sqlite.load + + SQLITE_DBPATH='simplex_v1_chat_plaintext.db' \ + POSTGRES_SCHEMA='simplex_v1_chat_schema' \ + CPU_CORES=$(nproc) WORKERS=$((CPU_CORES - 1)) pgloader --dynamic-space-size 262144 --on-error-stop sqlite.load ``` 4. Update sequences for Postgres tables. - ```sql - DO $$ - DECLARE - rec RECORD; - BEGIN - EXECUTE 'SET SEARCH_PATH TO simplex_v1_agent_schema'; + Connect to db: - FOR rec IN - SELECT - table_name, - column_name, - pg_get_serial_sequence(table_name, column_name) AS seq_name - FROM - information_schema.columns - WHERE - table_schema = 'simplex_v1_agent_schema' - AND identity_generation = 'ALWAYS' - LOOP - EXECUTE format( - 'SELECT setval(%L, (SELECT MAX(%I) FROM %I))', - rec.seq_name, rec.column_name, rec.table_name - ); - END LOOP; - END $$; + ```sh + PGPASSWORD=123123 psql -h localhost -U simplex -d simplex_v1 ``` - Repeat for `simplex_v1_chat_schema`. + Execute the following: -5. \* Compare number of rows between Postgres and SQLite tables. + 1. For `agent`: - To check number of rows for all tables in Postgres database schema run: + ```sql + DO $$ + DECLARE + rec RECORD; + BEGIN + EXECUTE 'SET SEARCH_PATH TO simplex_v1_agent_schema'; - ```sql - WITH tbl AS ( - SELECT table_schema, table_name - FROM information_schema.Tables - WHERE table_name NOT LIKE 'pg_%' - AND table_schema IN ('simplex_v1_agent_schema') - ) - SELECT - table_schema AS schema_name, - table_name, - (xpath('/row/c/text()', query_to_xml( - format('SELECT count(*) AS c FROM %I.%I', table_schema, table_name), false, true, '' - )))[1]::text::int AS records_count - FROM tbl - ORDER BY records_count DESC; - ``` + FOR rec IN + SELECT + table_name, + column_name, + pg_get_serial_sequence(table_name, column_name) AS seq_name + FROM + information_schema.columns + WHERE + table_schema = 'simplex_v1_agent_schema' + AND identity_generation = 'ALWAYS' + LOOP + EXECUTE format( + 'SELECT setval(%L, (SELECT MAX(%I) FROM %I))', + rec.seq_name, rec.column_name, rec.table_name + ); + END LOOP; + END $$; + ``` - Repeat for `simplex_v1_chat_schema`. + 2. For `chat`: + + ```sql + DO $$ + DECLARE + rec RECORD; + BEGIN + EXECUTE 'SET SEARCH_PATH TO simplex_v1_chat_schema'; + + FOR rec IN + SELECT + table_name, + column_name, + pg_get_serial_sequence(table_name, column_name) AS seq_name + FROM + information_schema.columns + WHERE + table_schema = 'simplex_v1_chat_schema' + AND identity_generation = 'ALWAYS' + LOOP + EXECUTE format( + 'SELECT setval(%L, (SELECT MAX(%I) FROM %I))', + rec.seq_name, rec.column_name, rec.table_name + ); + END LOOP; + END $$; + ``` + +5. Compare number of rows between Postgres and SQLite tables. + + **PostgreSQL**: + + 1. For `agent`: + + ```sql + WITH tbl AS ( + SELECT table_schema, table_name + FROM information_schema.Tables + WHERE table_name NOT LIKE 'pg_%' + AND table_schema IN ('simplex_v1_agent_schema') + ) + SELECT + table_schema AS schema_name, + table_name, + (xpath('/row/c/text()', query_to_xml( + format('SELECT count(*) AS c FROM %I.%I', table_schema, table_name), false, true, '' + )))[1]::text::int AS records_count + FROM tbl + ORDER BY records_count DESC; + ``` + + 2. For `chat`: + + ```sql + WITH tbl AS ( + SELECT table_schema, table_name + FROM information_schema.Tables + WHERE table_name NOT LIKE 'pg_%' + AND table_schema IN ('simplex_v1_chat_schema') + ) + SELECT + table_schema AS schema_name, + table_name, + (xpath('/row/c/text()', query_to_xml( + format('SELECT count(*) AS c FROM %I.%I', table_schema, table_name), false, true, '' + )))[1]::text::int AS records_count + FROM tbl + ORDER BY records_count DESC; + ``` + + **SQLite**: + + 1. For `agent`: + + ```sh + db="simplex_v1_agent_plaintext.db" + sqlite3 "$db" "SELECT name FROM sqlite_master WHERE type='table';" | + while read table; do + count=$(sqlite3 "$db" "SELECT COUNT(*) FROM \"$table\";") + echo "$table: $count" + done | sort -k2 -nr | less + ``` + + 2. For `chat`: + + ```sh + db="simplex_v1_chat_plaintext.db" + sqlite3 "$db" "SELECT name FROM sqlite_master WHERE type='table';" | + while read table; do + count=$(sqlite3 "$db" "SELECT COUNT(*) FROM \"$table\";") + echo "$table: $count" + done | sort -k2 -nr | less + ``` 6. Build and run desktop app with Postgres backend. @@ -103,3 +293,47 @@ # or ./gradlew packageDmg -Pdatabase.backend=postgres ``` + +## Transfer data from SQLite to Postgres database + +1. Prepare sqlite db: + + 1. Download simplex-chat CLI: + + You should download the CLI binary from the same `TAG` as the desktop. + + ```sh + export TAG='v6.4.3.1' + curl -L "https://github.com/simplex-chat/simplex-chat/releases/download/${TAG}/simplex-chat-ubuntu-22_04-x86_64" -o 'simplex-chat' + ``` + + 2. Run the CLI: + + ```sh + ./simplex-chat + ``` + + Press `Ctrl+C` when CLI ask for a display name. + + 3. Move database: + + ```sh + mv ~/.simplex/simplex_v1_* ~/.local/share/simplex/ + ``` + +2. Transfer data: + + ```sh + ./pg2sqlite.py --verbose 'postgresql://simplex:123123@localhost:5432/simplex_v1' ~/.local/share/simplex/ + ``` + +4. Update BLOBs: + + ```sh + sqlite3 simplex_v1_chat.db + ``` + + ```sh + UPDATE group_members SET member_role = CAST(member_role as BLOB); + UPDATE user_contact_links SET group_link_member_role = CAST(group_link_member_role AS BLOB) WHERE group_link_member_role is not null; + ``` diff --git a/scripts/db/pg2sqlite.py b/scripts/db/pg2sqlite.py new file mode 100755 index 0000000000..533b15d143 --- /dev/null +++ b/scripts/db/pg2sqlite.py @@ -0,0 +1,899 @@ +#!/usr/bin/env python3 +""" +PostgreSQL -> per-schema SQLite migration with colored, clean logging. + +Usage example: + python db_migrate.py 'postgresql://user:pass@host:5432/db' /path/to/sqlite/dir --dry-run + +Note: color output will be disabled automatically if stdout is not a TTY or if --no-color is passed. +""" + +from __future__ import annotations +import argparse +import logging +import os +import sqlite3 +import sys +import re +import datetime +from pathlib import Path +from typing import Set, List, Tuple, Dict, Optional, NamedTuple + +import psycopg +from psycopg import sql + +# ---------------------- +# Small utilities +# ---------------------- + +try: + sqlite3.register_adapter( + datetime.datetime, + lambda v: v.isoformat(sep=" ", timespec="microseconds"), + ) + sqlite3.register_adapter(datetime.date, lambda v: v.isoformat()) + sqlite3.register_adapter( + datetime.time, lambda v: v.isoformat(timespec="microseconds") + ) +except ValueError: + pass # already registered + +ANSI = { + "reset": "\x1b[0m", + "bold": "\x1b[1m", + "dim": "\x1b[2m", + "red": "\x1b[31m", + "green": "\x1b[32m", + "yellow": "\x1b[33m", + "blue": "\x1b[34m", + "magenta": "\x1b[35m", + "cyan": "\x1b[36m", + "gray": "\x1b[90m", +} + +DEFAULT_BATCH_SIZE = 10000 + +TYPE_COMPATIBILITY = { + "bytea": ["BLOB", "CHAR", "CLOB", "TEXT", "JSON"], + "int": ["INT", "NUMERIC"], + "serial": ["INT", "NUMERIC"], + "numeric": ["NUMERIC", "DECIMAL", "REAL", "FLOAT", "DOUBLE"], + "decimal": ["NUMERIC", "DECIMAL", "REAL", "FLOAT", "DOUBLE"], + "real": ["NUMERIC", "DECIMAL", "REAL", "FLOAT", "DOUBLE"], + "double": ["NUMERIC", "DECIMAL", "REAL", "FLOAT", "DOUBLE"], + "float": ["NUMERIC", "DECIMAL", "REAL", "FLOAT", "DOUBLE"], + "money": ["NUMERIC", "DECIMAL", "REAL", "FLOAT", "DOUBLE"], + "bool": ["BOOL", "INT", "NUMERIC"], + "varchar": ["CHAR", "CLOB", "TEXT"], + "char": ["CHAR", "CLOB", "TEXT"], + "text": ["CHAR", "CLOB", "TEXT"], + "citext": ["CHAR", "CLOB", "TEXT"], + "timestamp": ["DATE", "TIME", "CHAR", "TEXT", "DATETIME"], + "time": ["DATE", "TIME", "CHAR", "TEXT", "DATETIME"], + "date": ["DATE", "TIME", "CHAR", "TEXT", "DATETIME"], + "uuid": ["CHAR", "TEXT", "UUID", "CLOB"], + "json": ["JSON", "TEXT", "CHAR", "CLOB"], + "jsonb": ["JSON", "TEXT", "CHAR", "CLOB"], +} + + +def _sanitize_cursor_name(s: str) -> str: + return re.sub(r"[^A-Za-z0-9_]+", "_", s) + + +def supports_color(force_no: bool) -> bool: + """Return True when we should emit ANSI colors.""" + if force_no: + return False + if os.getenv("NO_COLOR"): + return False + term = os.getenv("TERM", "") + if term == "" or term.lower() == "dumb": + return False + try: + isatty = sys.stdout.isatty() + except Exception: + isatty = False + return isatty + + +class ColoredFormatter(logging.Formatter): + LEVEL_COLORS = { + logging.DEBUG: ANSI["gray"], + logging.INFO: ANSI["green"], + logging.WARNING: ANSI["yellow"], + logging.ERROR: ANSI["red"], + logging.CRITICAL: ANSI["red"] + ANSI["bold"], + } + + TAG_COLORS = { + "SKIP": ANSI["yellow"], + "SCHEMA": ANSI["blue"], + "OK": ANSI["magenta"], + } + + def __init__(self, use_color: bool = True): + super().__init__(fmt="%(message)s") + self.use_color = use_color + + def format(self, record: logging.LogRecord) -> str: + msg = super().format(record) + parts = msg.split(" ", 1) + tag = parts[0] + rest = parts[1] if len(parts) > 1 else "" + plain_label = f"[{tag}]" + + if not self.use_color: + return f"{plain_label}{(' ' + rest) if rest else ''}" + + color = self.TAG_COLORS.get( + tag.upper(), self.LEVEL_COLORS.get(record.levelno, "") + ) + reset = ANSI["reset"] + return f"{color}{plain_label}{reset}{(' ' + rest) if rest else ''}" + + +def setup_logger(verbose: bool, no_color: bool) -> logging.Logger: + use_color = supports_color(no_color) + logger = logging.getLogger("db_migrate") + logger.setLevel(logging.DEBUG if verbose else logging.INFO) + handler = logging.StreamHandler() + handler.setLevel(logging.DEBUG if verbose else logging.INFO) + handler.setFormatter(ColoredFormatter(use_color=use_color)) + logger.handlers.clear() + logger.addHandler(handler) + logging.getLogger("psycopg").setLevel(logging.WARNING) + + if verbose: + logger.debug(f"color_support: {use_color}") + try: + isatty = sys.stdout.isatty() + except Exception: + isatty = False + logger.debug( + f"TERM={os.getenv('TERM', '')!r} " + f"NO_COLOR={os.getenv('NO_COLOR')!r} " + f"isatty={isatty}" + ) + return logger + + +def quote_sqlite_identifier(name: str) -> str: + return '"' + name.replace('"', '""') + '"' + + +def quote_pg_identifier(name: str) -> str: + """Simple PG identifier quoting for building safe SQL strings.""" + return '"' + name.replace('"', '""') + '"' + + +def sqlite_decl_satisfies(pg_type: str, sqlite_decl: str) -> bool: + # Treat empty/blank SQLite declarations more permissively based on PG type. + decl_raw = sqlite_decl or "" + if not decl_raw.strip(): + pg = (pg_type or "").lower() + # arrays -> textual affinity + if pg.endswith("[]"): + return True + # integer-like + if re.search(r"\b(?:int|serial|bigint)\b", pg): + return True + # numeric/float + if re.search(r"\b(?:numeric|decimal|real|double|float|money)\b", pg): + return True + # boolean + if re.search(r"\b(?:bool|boolean)\b", pg): + return True + # binary + if re.search(r"\b(?:bytea)\b", pg): + return True + # textual/json/uuid/timestamps/dates/times + if re.search( + r"\b(?:varchar|char|text|citext|jsonb|json|uuid|timestamp|time|date)\b", pg + ): + return True + # conservative fallback: accept empty decl as permissive + return True + + decl = decl_raw.upper() + pg = (pg_type or "").lower() + + # array type + if pg.endswith("[]"): + return any(tok in decl for tok in ("TEXT", "CHAR", "CLOB", "JSON")) + + for key, allowed_types in TYPE_COMPATIBILITY.items(): + if re.search(r"\b" + re.escape(key) + r"\b", pg): + return any(tok in decl for tok in allowed_types) + + return any( + tok in decl for tok in ("TEXT", "CHAR", "CLOB", "NUMERIC", "BLOB", "INT") + ) + + +# ---------------------- +# Postgres helpers +# ---------------------- + + +def list_user_schemas(pg_cursor) -> List[str]: + pg_cursor.execute( + """ + SELECT nspname + FROM pg_namespace + WHERE nspname NOT LIKE 'pg_%' + AND nspname != 'information_schema' + AND nspname != 'public' + ORDER BY nspname; + """ + ) + return [r[0] for r in pg_cursor.fetchall()] + + +def list_tables_in_schema(pg_cursor, schema: str) -> List[str]: + pg_cursor.execute( + sql.SQL( + """ + SELECT table_name + FROM information_schema.tables + WHERE table_schema = %s + ORDER BY table_name; + """ + ), + (schema,), + ) + return [r[0] for r in pg_cursor.fetchall()] + + +def get_pg_columns(pg_cursor, schema: str, table: str) -> List[Tuple[str, str]]: + pg_cursor.execute( + sql.SQL( + """ + SELECT column_name, data_type + FROM information_schema.columns + WHERE table_schema = %s AND table_name = %s + ORDER BY ordinal_position; + """ + ), + (schema, table), + ) + return [(r[0], r[1]) for r in pg_cursor.fetchall()] + + +# ---------------------- +# SQLite helpers +# ---------------------- + + +class SQLiteCol(NamedTuple): + cid: int + name: str + type: str + notnull: int + dflt_value: str + pk: int + + +def get_sqlite_table_info(sqlite_cursor, table_name: str) -> list[SQLiteCol]: + qname = quote_sqlite_identifier(table_name) + sqlite_cursor.execute(f"PRAGMA table_info({qname});") + return [SQLiteCol(*row) for row in sqlite_cursor.fetchall()] + + +def sqlite_table_has_autoincrement(sqlite_cursor, table_name: str) -> bool: + sqlite_cursor.execute( + "SELECT sql FROM sqlite_master WHERE type='table' AND name = ?;", (table_name,) + ) + row = sqlite_cursor.fetchone() + if not row or not row[0]: + return False + return "AUTOINCREMENT" in row[0].upper() + + +def sqlite_sequence_table_exists(sqlite_cursor) -> bool: + sqlite_cursor.execute( + "SELECT name FROM sqlite_master WHERE type='table' AND name='sqlite_sequence';" + ) + exists = sqlite_cursor.fetchone() is not None + if not exists: + logging.getLogger("db_migrate").debug("sqlite_sequence table not present") + return exists + + +# ---------------------- +# Core migration logic +# ---------------------- + + +def build_select_for_sqlite_columns( + schema: str, + table: str, + sqlite_cols: list[SQLiteCol], + pg_columns_map: Dict[str, Tuple[str, str]], +) -> str: + """Return a plain SQL string (no trailing semicolon) selecting PG columns in the order of sqlite_cols. + Uses simple identifier quoting to avoid psycopg.sql objects which may vary by driver version. + """ + select_parts = [] + for col in sqlite_cols: + lc = col.name.lower() + if lc in pg_columns_map: + pg_name, pg_type = pg_columns_map[lc] + pg_type_l = (pg_type or "").lower() + if any(tok in pg_type_l for tok in ("timestamp", "time")): + expr = f"{quote_pg_identifier(pg_name)}::text" + else: + expr = f"{quote_pg_identifier(pg_name)}" + select_parts.append(expr) + else: + select_parts.append("NULL") + select_list = ", ".join(select_parts) + # Quote schema and table names simply (this is not comprehensive for every corner case but avoids psycopg.sql use) + return f"SELECT {select_list} FROM {quote_pg_identifier(schema)}.{quote_pg_identifier(table)}" + + +def validate_column_compatibility( + sqlite_cols: list[SQLiteCol], + pg_columns_map: Dict[str, Tuple[str, str]], + schema: str, + table: str, +) -> None: + for col in sqlite_cols: + lc = col.name.lower() + if lc not in pg_columns_map: + continue + pg_type = pg_columns_map[lc][1] + if not sqlite_decl_satisfies(pg_type, col.type): + raise ValueError( + f"Type mismatch for {schema}.{table}.{col.name}: " + f"PG='{pg_type}' vs SQLite='{col.type}'" + ) + + +def process_row_for_sqlite(row: Tuple, sqlite_cols: list[SQLiteCol]) -> Tuple: + out = [] + for i, val in enumerate(row): + col = sqlite_cols[i] + decl_raw = col.type or "" + decl = decl_raw.upper() + decl_is_empty = decl_raw.strip() == "" + + if isinstance(val, memoryview): + b = val.tobytes() + if "BLOB" in decl or decl_is_empty: + out.append(sqlite3.Binary(b)) + else: + try: + out.append(b.decode("utf-8")) + except UnicodeDecodeError as e: + raise ValueError( + f"UTF-8 decode failed for column '{col.name}': {e}" + ) + elif isinstance(val, (bytes, bytearray)): + b = bytes(val) + if "BLOB" in decl or decl_is_empty: + out.append(sqlite3.Binary(b)) + else: + try: + out.append(b.decode("utf-8")) + except UnicodeDecodeError as e: + raise ValueError( + f"UTF-8 decode failed for column '{col.name}': {e}" + ) + else: + out.append(val) + return tuple(out) + + +def fetch_and_validate_row_batches( + pg_cursor, + select_sql: str, + sqlite_cols: list[SQLiteCol], + batch_size: int = DEFAULT_BATCH_SIZE, +): + pg_cursor.execute(select_sql) + total_rows_seen = 0 + while True: + rows = pg_cursor.fetchmany(batch_size) + if not rows: + break + validated_batch = [] + for row in rows: + total_rows_seen += 1 + try: + validated_batch.append(process_row_for_sqlite(row, sqlite_cols)) + except ValueError as e: + raise ValueError(f"Row {total_rows_seen} validation error: {e}") + yield validated_batch + + +def _get_postgres_sequence_info( + pg_cursor, schema: str, table: str, pk_col: str +) -> Optional[tuple[str, int]]: + """Get PostgreSQL sequence name and last_value for a table primary key, if any. + + Returns (sequence_name_text, last_value) or None. + """ + pg_cursor.execute( + """ + SELECT data_type + FROM information_schema.columns + WHERE table_schema = %s AND table_name = %s AND column_name = %s; + """, + (schema, table, pk_col), + ) + r = pg_cursor.fetchone() + if not r: + return None + + pg_type = (r[0] or "").lower() + # Match whole words to avoid matching 'interval' etc. + if not re.search(r"\b(?:int|serial|bigint)\b", pg_type): + return None + + # Get sequence name text (NULL if none) + pg_cursor.execute( + "SELECT pg_get_serial_sequence(%s, %s);", + (f"{schema}.{table}", pk_col), + ) + row = pg_cursor.fetchone() + seq_name = row[0] if row else None + if not seq_name: + return None + + try: + # Read last_value by casting the pg_get_serial_sequence result to regclass. + pg_cursor.execute( + "SELECT last_value FROM pg_get_serial_sequence(%s, %s)::regclass;", + (f"{schema}.{table}", pk_col), + ) + rr = pg_cursor.fetchone() + if rr and rr[0] is not None: + return (seq_name, int(rr[0])) + except Exception: + # Swallow errors (best-effort); callers treat missing info as absent + pass + + return None + + +def _get_sqlite_max_pk_value(sqlite_cursor, table: str, pk_col: str) -> Optional[int]: + """Get the maximum primary key value from SQLite table.""" + logger = logging.getLogger("db_migrate") + try: + sqlite_cursor.execute( + f"SELECT MAX({quote_sqlite_identifier(pk_col)}) " + f"FROM {quote_sqlite_identifier(table)};" + ) + r3 = sqlite_cursor.fetchone() + if r3 and r3[0] is not None: + return int(r3[0]) + except Exception: + logger.debug("Failed to read sqlite max pk", exc_info=True) + return None + + +def _update_sqlite_sequence( + sqlite_conn: sqlite3.Connection, table: str, sequence_value: int +) -> bool: + """Update SQLite sqlite_sequence with new value. + + IMPORTANT: This function does not commit; caller must commit/rollback. + """ + s_cur = sqlite_conn.cursor() + s_cur.execute( + "UPDATE sqlite_sequence SET seq = ? WHERE name = ?;", + (sequence_value, table), + ) + if s_cur.rowcount == 0: + s_cur.execute( + "INSERT INTO sqlite_sequence(name, seq) VALUES (?, ?);", + (table, sequence_value), + ) + return True + + +def try_update_sqlite_sequence( + pg_cursor, + sqlite_conn: sqlite3.Connection, + schema: str, + pg_table: str, # PostgreSQL table name + sqlite_table: str, # SQLite table name + sqlite_cols: list[SQLiteCol], +) -> bool: + """Update SQLite sequence table based on PostgreSQL sequence values.""" + logger = logging.getLogger("db_migrate") + # Check if table has a single primary key + pks = [c for c in sqlite_cols if c.pk] + if len(pks) != 1: + return False + pk_col = pks[0].name + + # Check if SQLite has AUTOINCREMENT (use sqlite_table) + s_cur = sqlite_conn.cursor() + if not sqlite_table_has_autoincrement(s_cur, sqlite_table): + return False + if not sqlite_sequence_table_exists(s_cur): + return False + + # Get PostgreSQL sequence info (use pg_table) + seq_info = _get_postgres_sequence_info(pg_cursor, schema, pg_table, pk_col) + pg_last_value = seq_info[1] if seq_info else None + + # Get SQLite max PK value (use sqlite_table) + sqlite_max = _get_sqlite_max_pk_value(s_cur, sqlite_table, pk_col) + + # Determine the value to use + if pg_last_value is not None and sqlite_max is not None: + candidate = max(pg_last_value, sqlite_max) + elif pg_last_value is not None: + candidate = pg_last_value + elif sqlite_max is not None: + candidate = sqlite_max + else: + return False + + updated = _update_sqlite_sequence(sqlite_conn, sqlite_table, candidate) + if updated: + try: + sqlite_conn.commit() + except Exception: + logger.debug("Failed to commit sqlite_sequence update", exc_info=True) + # Let caller proceed; treat as best-effort + return updated + + +# ---------------------- +# Flow: per-schema migration +# ---------------------- + + +def migrate_schema( + pg_conn, + sqlite_dir: str, + schema: str, + skipped_tables: Set[str], + logger: logging.Logger, + dry_run: bool = False, + batch_size: int = DEFAULT_BATCH_SIZE, +) -> Tuple[int, int]: + """Migrate a single schema. Returns (tables_migrated, rows_inserted_total).""" + processed_schema = schema[:-7] if schema.endswith("_schema") else schema + sqlite_db_path = Path(sqlite_dir) / f"{processed_schema}.db" + if not sqlite_db_path.is_file(): + logger.error(f"Missing SQLite DB: {sqlite_db_path}") + return 0, 0 + + tables_migrated = 0 + rows_inserted = 0 + + sqlite_path = sqlite_db_path.resolve() + if dry_run: + uri = sqlite_path.as_uri() + "?mode=ro" + conn_args = {"database": uri, "uri": True} + else: + conn_args = {"database": str(sqlite_path)} + + with sqlite3.connect(**conn_args) as sqlite_conn: + sqlite_cur = sqlite_conn.cursor() + sqlite_cur.execute("SELECT name FROM sqlite_master WHERE type='table';") + sqlite_tables = [r[0] for r in sqlite_cur.fetchall()] + # O(1) lookup map for matching by lowercase name + sqlite_table_map = {t.lower(): t for t in sqlite_tables} + + with pg_conn.cursor() as pg_cur: + # Ensure we start in a clean state for this connection + try: + pg_conn.rollback() + except Exception: + # Ignore rollback failure; connection is newly opened most likely + logger.debug( + "pg_conn.rollback() at schema start ignored", exc_info=True + ) + + # Get table list for this schema, but catch/rollback on failure + try: + tables = list_tables_in_schema(pg_cur, schema) + except Exception as e: + logger.error("ERROR %s (list tables): %s", schema, e) + logger.debug("Traceback (list tables):", exc_info=True) + try: + pg_conn.rollback() + except Exception: + logger.debug( + "pg_conn.rollback() failed after list tables error", + exc_info=True, + ) + return 0, 0 + + for table in tables: + # Defensive: ensure connection is in a clean state before any new PG work. + # A prior error can leave the connection in an aborted transaction; calling + # rollback() clears that and allows subsequent SELECTs to run. + try: + pg_conn.rollback() + except Exception: + # ignore: best-effort cleanup + logger.debug( + "pg_conn.rollback() ignored at start of table loop", + exc_info=True, + ) + + if table.lower() in skipped_tables: + logger.info("SKIP %s.%s (explicit)", schema, table) + continue + if table.lower() not in sqlite_table_map: + logger.info("SKIP %s.%s (no target table)", schema, table) + continue + + matched_table = sqlite_table_map[table.lower()] + logger.info("OK %s.%s -> %s", schema, table, matched_table) + + # Fetch PG columns, but defend against aborted transaction here + try: + pg_cols = get_pg_columns(pg_cur, schema, table) + except Exception as e: + logger.error("ERROR %s.%s (get columns): %s", schema, table, e) + logger.debug("Traceback (get columns):", exc_info=True) + try: + pg_conn.rollback() + except Exception: + logger.debug( + "pg_conn.rollback() failed after get columns error", + exc_info=True, + ) + continue + + pg_map: Dict[str, Tuple[str, str]] = { + name.lower(): (name, dtype) for name, dtype in pg_cols + } + + sqlite_info = get_sqlite_table_info(sqlite_cur, matched_table) + if not sqlite_info: + logger.warning(f"SKIP {schema}.{table} (no sqlite info)") + continue + + # Warn once about schema drift (extra columns) + pg_col_names = {name.lower() for name, _ in pg_cols} + extra_in_sqlite = { + c.name for c in sqlite_info if c.name.lower() not in pg_col_names + } + if extra_in_sqlite: + logger.warning( + f"Schema drift: {schema}.{table} has extra SQLite columns {extra_in_sqlite}" + ) + + try: + validate_column_compatibility(sqlite_info, pg_map, schema, table) + except ValueError as e: + logger.error(f"ERROR {schema}.{table} (type mismatch): {e}") + continue + + select_sql = build_select_for_sqlite_columns( + schema, table, sqlite_info, pg_map + ) + + csr_name = _sanitize_cursor_name(f"csr_{schema}_{table}") + try: + with pg_conn.cursor(name=csr_name) as data_cur: + batch_gen = fetch_and_validate_row_batches( + data_cur, select_sql, sqlite_info, batch_size=batch_size + ) + first_batch = next(batch_gen, None) + + if not first_batch: + logger.info(f"SKIP {schema}.{table} (no rows)") + # data_cur will be closed automatically on leaving the 'with' + continue + + if dry_run: + count = len(first_batch) + for batch in batch_gen: + count += len(batch) + inserted = 0 + logger.info( + f"DRY {schema}.{table} rows_validated={count}" + ) + else: + cur = sqlite_conn.cursor() + quoted_table = quote_sqlite_identifier(matched_table) + col_names = [c.name for c in sqlite_info] + quoted_cols = ", ".join( + quote_sqlite_identifier(c) for c in col_names + ) + placeholders = ", ".join(["?"] * len(col_names)) + + cur.execute("BEGIN;") + try: + cur.execute(f"DELETE FROM {quoted_table};") + inserted = 0 + if first_batch: + cur.executemany( + f"INSERT INTO {quoted_table} ({quoted_cols}) VALUES ({placeholders});", + first_batch, + ) + inserted += len(first_batch) + for batch in batch_gen: + if not batch: + continue + cur.executemany( + f"INSERT INTO {quoted_table} ({quoted_cols}) VALUES ({placeholders});", + batch, + ) + inserted += len(batch) + except Exception: + cur.execute("ROLLBACK;") + raise + else: + cur.execute("COMMIT;") + except ValueError as e: + logger.error("ERROR %s.%s (row validation): %s", schema, table, e) + try: + pg_conn.rollback() + except Exception: + logger.debug( + "pg_conn.rollback() failed after row validation error", + exc_info=True, + ) + continue + except Exception as e: + logger.error("ERROR %s.%s (select failed): %s", schema, table, e) + logger.debug("Traceback (select failed):", exc_info=True) + try: + pg_conn.rollback() + except Exception: + logger.debug( + "pg_conn.rollback() failed after select failed", + exc_info=True, + ) + continue + + rows_inserted += inserted + tables_migrated += 1 + logger.info(f"DONE {schema}.{table} rows={inserted}") + + if not dry_run: + try: + if try_update_sqlite_sequence( + pg_cur, + sqlite_conn, + schema, + table, + matched_table, + sqlite_info, + ): + logger.info( + "SEQ %s.%s sqlite_sequence updated", schema, table + ) + except Exception as e: + logger.warning( + "SEQ %s.%s update failed (ignored): %s", schema, table, e + ) + + return tables_migrated, rows_inserted + + +def migrate_data( + pg_conn_str: str, + sqlite_dir: str, + schema_filter: Optional[str], + dry_run: bool, + skip_tables: str, + logger: logging.Logger, + batch_size: int, +) -> None: + skipped_tables = {t.strip().lower() for t in skip_tables.split(",") if t.strip()} + total_tables = 0 + total_rows = 0 + total_errors = 0 + + # List schemas once with a short-lived connection + with psycopg.connect(pg_conn_str) as tmp_conn: + with tmp_conn.cursor() as cur: + schemas = list_user_schemas(cur) + + if schema_filter: + schemas = [s for s in schemas if s == schema_filter] + if not schemas: + logger.error("No schemas to process") + return + + for schema in schemas: + logger.info("SCHEMA %s", schema) + if dry_run: + logger.info("(dry-run) validating only — no writes will be performed") + + # Use a fresh connection per-schema to isolate failures/aborted transactions + try: + with psycopg.connect(pg_conn_str) as pg_conn: + migrated_tables, inserted_rows = migrate_schema( + pg_conn, + sqlite_dir, + schema, + skipped_tables, + logger, + dry_run=dry_run, + batch_size=batch_size, + ) + except Exception as e: + logger.error("Schema %s failed: %s", schema, e) + logger.debug("Traceback (schema failure):", exc_info=True) + total_errors += 1 + continue + + total_tables += migrated_tables + total_rows += inserted_rows + + logger.info("---") + logger.info( + f"SUMMARY: schemas={len(schemas)} " + f"tables_migrated={total_tables} " + f"rows_inserted={total_rows} " + f"errors={total_errors}" + ) + + +# ---------------------- +# CLI +# ---------------------- + + +def parse_args(argv): + p = argparse.ArgumentParser( + description="Migrate Postgres data into per-schema SQLite DBs (non-invasive)." + ) + p.add_argument("pg_conn", help="Postgres connection string") + p.add_argument( + "sqlite_dir", help="Directory containing per-schema sqlite .db files" + ) + p.add_argument( + "--schema", help="Only migrate this schema (exact match)", default=None + ) + p.add_argument( + "--dry-run", + help="Validate and report only; do not write to sqlite", + action="store_true", + ) + p.add_argument("--verbose", help="Verbose logging (debug)", action="store_true") + p.add_argument("--no-color", help="Disable ANSI color output", action="store_true") + p.add_argument( + "--batch-size", + type=int, + default=DEFAULT_BATCH_SIZE, + help="Batch size for data fetching", + ) + p.add_argument( + "--skip-tables", + help="Comma-separated list of tables to skip", + default="migrations,servers_stats", + ) + + return p.parse_args(argv[1:]) + + +def main(argv): + args = parse_args(argv) + logger = setup_logger(args.verbose, args.no_color) + + sqlite_dir_path = Path(args.sqlite_dir) + if not sqlite_dir_path.is_dir(): + logger.error("SQLite directory does not exist or is not a directory.") + raise SystemExit(1) + + try: + migrate_data( + args.pg_conn, + str(sqlite_dir_path), + args.schema, + args.dry_run, + args.skip_tables, + logger, + args.batch_size, + ) + except Exception as e: + logger.error(f"Fatal error: {e}") + raise SystemExit(2) + + +if __name__ == "__main__": + main(sys.argv) diff --git a/scripts/db/sqlite.load b/scripts/db/sqlite.load index 105e8c39d2..7f60e72c2f 100644 --- a/scripts/db/sqlite.load +++ b/scripts/db/sqlite.load @@ -10,7 +10,8 @@ LOAD DATABASE -- pgloader implementation doesn't find "GENERATED ALWAYS AS IDENTITY" sequences, -- instead we reset sequences manually via custom query after load reset no sequences, - data only + data only, + workers = {{WORKERS}} EXCLUDING TABLE NAMES LIKE 'migrations', 'sqlite_sequence' From c07c17689606c27442360e114532e7cce60dd07d Mon Sep 17 00:00:00 2001 From: Evgeny Date: Tue, 16 Sep 2025 21:58:28 +0100 Subject: [PATCH 06/64] core: batch load queues for subscriptions with PostgreSQL client (#6272) * core: batch load queues for subscriptions with PostgreSQL client * update simplexmq * fix, update simplexmq * update query plans --- cabal.project | 2 +- scripts/db/README.md | 76 ++++--------------- scripts/desktop/build-lib-mac.sh | 2 +- scripts/nix/sha256map.nix | 2 +- src/Simplex/Chat/Options/Postgres.hs | 4 +- .../SQLite/Migrations/agent_query_plans.txt | 25 +++--- tests/ChatClient.hs | 2 +- tests/PostgresSchemaDump.hs | 6 +- 8 files changed, 35 insertions(+), 84 deletions(-) diff --git a/cabal.project b/cabal.project index df72f5da32..a414dbcd5b 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: 112cd9d5f44055b6d9b12cb918a1f108f78726f8 + tag: 7b7616ce7e3ba40eb101d20c5dccd79a14de5580 source-repository-package type: git diff --git a/scripts/db/README.md b/scripts/db/README.md index 333a6f4acf..c204e036c4 100644 --- a/scripts/db/README.md +++ b/scripts/db/README.md @@ -10,33 +10,13 @@ sqlcipher simplex_v1_agent.db ``` - 2. Set your db password: + 2. Run in sqlcipher: ```sql - PRAGMA key = ''; - ``` - - 3. Check if db was successfully decrypted: - - ```sh - SELECT count(*) FROM sqlite_master; - ``` - - 4. Attach new empty db: - - ```sh - ATTACH DATABASE 'simplex_v1_agent_plaintext.db' AS plaintext KEY ''; - ``` - - 5. Export opened db to attached db as plaintext: - - ```sh - SELECT sqlcipher_export('plaintext'); - ``` - - 6. Deattach the plaintext db: - - ```sh + PRAGMA key = ''; -- Set your db password + SELECT count(*) FROM sqlite_master; -- Check if db was successfully decrypted + ATTACH DATABASE 'simplex_v1_agent_plaintext.db' AS plaintext KEY ''; -- Attach new empty db + SELECT sqlcipher_export('plaintext'); -- Export opened db to attached db as plaintext DETACH DATABASE plaintext; ``` @@ -48,33 +28,13 @@ sqlcipher simplex_v1_chat.db ``` - 2. Set your db password: + 2. Run in sqlcipher: ```sql PRAGMA key = ''; - ``` - - 3. Check if db was successfully decrypted: - - ```sh SELECT count(*) FROM sqlite_master; - ``` - - 4. Attach new empty db: - - ```sh ATTACH DATABASE 'simplex_v1_chat_plaintext.db' AS plaintext KEY ''; - ``` - - 5. Export opened db to attached db as plaintext: - - ```sh SELECT sqlcipher_export('plaintext'); - ``` - - 6. Deattach the plaintext db: - - ```sh DETACH DATABASE plaintext; ``` @@ -86,22 +46,14 @@ psql -U postgres -h localhost ``` - 2. Create user with password: + 2. Run in psql: - ```sh - CREATE USER simplex WITH ENCRYPTED PASSWORD '123123'; - ``` - - 3. Create database: - - ```sh - CREATE DATABASE simplex_v1; - ``` - - 4. Assign permissions: - - ```sh - GRANT ALL PRIVILEGES ON DATABASE simplex_v1 TO simplex; + ```sql + CREATE USER simplex WITH ENCRYPTED PASSWORD '123123'; -- Create user with password + -- or + -- CREATE USER simplex; + CREATE DATABASE simplex_v1; -- Create database + GRANT ALL PRIVILEGES ON DATABASE simplex_v1 TO simplex; -- Assign permissions ``` 3. Prepare database: @@ -294,7 +246,7 @@ ./gradlew packageDmg -Pdatabase.backend=postgres ``` -## Transfer data from SQLite to Postgres database +## Transfer data from Postgres to SQLite database 1. Prepare sqlite db: diff --git a/scripts/desktop/build-lib-mac.sh b/scripts/desktop/build-lib-mac.sh index a3a824f81b..6e3415bd80 100755 --- a/scripts/desktop/build-lib-mac.sh +++ b/scripts/desktop/build-lib-mac.sh @@ -28,7 +28,7 @@ rm -rf $BUILD_DIR if [[ "$DATABASE_BACKEND" == "postgres" ]]; then echo "Building with postgres backend..." - cabal build -f client_postgres lib:simplex-chat lib:simplex-chat --ghc-options="-optl-Wl,-rpath,@loader_path -optl-Wl,-L$GHC_LIBS_DIR/$ARCH-osx-ghc-$GHC_VERSION -optl-lHSrts_thr-ghc$GHC_VERSION -optl-lffi" --constraint 'simplexmq +client_library' --constraint 'simplex-chat +client_library' + cabal build lib:simplex-chat lib:simplex-chat --ghc-options="-optl-Wl,-rpath,@loader_path -optl-Wl,-L$GHC_LIBS_DIR/$ARCH-osx-ghc-$GHC_VERSION -optl-lHSrts_thr-ghc$GHC_VERSION -optl-lffi" --constraint 'simplexmq +client_library +client_postgres' --constraint 'simplex-chat +client_library +client_postgres' else echo "Building with sqlite backend..." cabal build lib:simplex-chat lib:simplex-chat --ghc-options="-optl-Wl,-rpath,@loader_path -optl-Wl,-L$GHC_LIBS_DIR/$ARCH-osx-ghc-$GHC_VERSION -optl-lHSrts_thr-ghc$GHC_VERSION -optl-lffi" --constraint 'simplexmq +client_library' --constraint 'simplex-chat +client_library' diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index c8404afde4..cccdc96785 100644 --- a/scripts/nix/sha256map.nix +++ b/scripts/nix/sha256map.nix @@ -1,5 +1,5 @@ { - "https://github.com/simplex-chat/simplexmq.git"."112cd9d5f44055b6d9b12cb918a1f108f78726f8" = "18jp2jrq7a4giqvqpvd3jjrbznwwl1dsh1ymmq3197xdd515wxr1"; + "https://github.com/simplex-chat/simplexmq.git"."7b7616ce7e3ba40eb101d20c5dccd79a14de5580" = "0ccscn8xx09fj8n7721cn8ynligjniwrpzgj2hi1348j1vm8h2j8"; "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/src/Simplex/Chat/Options/Postgres.hs b/src/Simplex/Chat/Options/Postgres.hs index 46c1faa5e0..13af13b20a 100644 --- a/src/Simplex/Chat/Options/Postgres.hs +++ b/src/Simplex/Chat/Options/Postgres.hs @@ -42,7 +42,7 @@ chatDbOptsP _appDir defaultDbName = do ( long "pool-size" <> metavar "DB_POOL_SIZE" <> help "Database connection pool size" - <> value 1 + <> value 10 <> showDefault ) dbCreateSchema <- @@ -81,7 +81,7 @@ mobileDbOpts schemaPrefix connstr = do ChatDbOpts { dbConnstr, dbSchemaPrefix, - dbPoolSize = 1, + dbPoolSize = 10, dbCreateSchema = True } diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/agent_query_plans.txt b/src/Simplex/Chat/Store/SQLite/Migrations/agent_query_plans.txt index 41f01b3b51..b2b4cd87ae 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/agent_query_plans.txt +++ b/src/Simplex/Chat/Store/SQLite/Migrations/agent_query_plans.txt @@ -327,16 +327,6 @@ Plan: SEARCH r USING INTEGER PRIMARY KEY (rowid=?) SEARCH s USING INTEGER PRIMARY KEY (rowid=?) -Query: - SELECT - user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, - last_external_snd_msg_id, deleted, ratchet_sync_state, pq_support - FROM connections - WHERE conn_id = ? - -Plan: -SEARCH connections USING PRIMARY KEY (conn_id=?) - Query: SELECT DISTINCT s.xftp_host, s.xftp_port, s.xftp_key_hash @@ -384,13 +374,13 @@ SEARCH s USING INTEGER PRIMARY KEY (rowid=?) USE TEMP B-TREE FOR DISTINCT Query: - SELECT DISTINCT c.host, c.port, COALESCE(c.server_key_hash, s.key_hash) + SELECT DISTINCT c.conn_id, c.host, c.port, COALESCE(c.server_key_hash, s.key_hash) FROM commands c LEFT JOIN servers s ON s.host = c.host AND s.port = c.port - WHERE conn_id = ? + ORDER BY c.conn_id Plan: -SEARCH c USING INDEX idx_commands_conn_id (conn_id=?) +SCAN c USING INDEX idx_commands_conn_id SEARCH s USING PRIMARY KEY (host=? AND port=?) LEFT-JOIN USE TEMP B-TREE FOR DISTINCT @@ -469,6 +459,15 @@ Plan: SEARCH s USING PRIMARY KEY (conn_id=? AND internal_snd_id=?) SEARCH m USING PRIMARY KEY (conn_id=? AND internal_id=?) +Query: + SELECT user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, + last_external_snd_msg_id, deleted, ratchet_sync_state, pq_support + FROM connections + WHERE conn_id = ? AND deleted = ? + +Plan: +SEARCH connections USING PRIMARY KEY (conn_id=?) + Query: DELETE FROM conn_confirmations WHERE conn_id = ? diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index 5e5c34d516..3f005cb915 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -297,7 +297,7 @@ startTestChat ps cfg opts@ChatOpts {coreOptions} dbPrefix = do createDatabase :: TestParams -> CoreChatOpts -> String -> IO (Either MigrationError ChatDatabase) #if defined(dbPostgres) createDatabase _params CoreChatOpts {dbOptions} dbPrefix = do - createChatDatabase dbOptions {dbSchemaPrefix = "client_" <> dbPrefix} MCError + createChatDatabase dbOptions {dbSchemaPrefix = "client_" <> dbPrefix} (MigrationConfig MCError Nothing) insertUser :: DBStore -> IO () insertUser st = withTransaction st (`DB.execute_` "INSERT INTO users DEFAULT VALUES") diff --git a/tests/PostgresSchemaDump.hs b/tests/PostgresSchemaDump.hs index f1b509ac6f..468cdb19d5 100644 --- a/tests/PostgresSchemaDump.hs +++ b/tests/PostgresSchemaDump.hs @@ -14,7 +14,7 @@ import Data.Maybe (fromJust, isJust) import Simplex.Messaging.Agent.Store.Postgres (closeDBStore, createDBStore) import Simplex.Messaging.Agent.Store.Postgres.Common (DBOpts (..)) import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations -import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfirmation (..), MigrationsToRun (..), toDownMigration) +import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfig (..), MigrationConfirmation (..), MigrationsToRun (..), toDownMigration) import Simplex.Messaging.Util (ifM, whenM) import System.Directory (doesFileExist, removeFile) import System.Process (readCreateProcess, shell) @@ -32,12 +32,12 @@ postgresSchemaDumpTest migrations skipComparisonForDownMigrations testDBOpts@DBO testVerifySchemaDump = do savedSchema <- ifM (doesFileExist srcSchemaPath) (readFile srcSchemaPath) (pure "") savedSchema `deepseq` pure () - void $ createDBStore testDBOpts migrations MCConsole + void $ createDBStore testDBOpts migrations (MigrationConfig MCConsole Nothing) getSchema srcSchemaPath `shouldReturn` savedSchema testSchemaMigrations = do let noDownMigrations = dropWhileEnd (\Migration {down} -> isJust down) migrations - st <- createDBStore testDBOpts noDownMigrations MCYesUpDown >>= \case + st <- createDBStore testDBOpts noDownMigrations (MigrationConfig MCYesUpDown Nothing) >>= \case Right st -> pure st Left e -> error $ show e mapM_ (testDownMigration st) $ drop (length noDownMigrations) migrations From 6a8f973eca740f011991f5b6c1d8776941481877 Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Wed, 17 Sep 2025 07:57:02 +0000 Subject: [PATCH 07/64] core: autoincrement for delivery tasks and jobs id (#6277) --- .../Chat/Store/SQLite/Migrations/M20250813_delivery_tasks.hs | 4 ++-- src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/M20250813_delivery_tasks.hs b/src/Simplex/Chat/Store/SQLite/Migrations/M20250813_delivery_tasks.hs index dfafff674f..3163619477 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/M20250813_delivery_tasks.hs +++ b/src/Simplex/Chat/Store/SQLite/Migrations/M20250813_delivery_tasks.hs @@ -56,7 +56,7 @@ m20250813_delivery_tasks :: Query m20250813_delivery_tasks = [sql| CREATE TABLE delivery_tasks ( - delivery_task_id INTEGER PRIMARY KEY, + delivery_task_id INTEGER PRIMARY KEY AUTOINCREMENT, group_id INTEGER NOT NULL REFERENCES groups ON DELETE CASCADE, worker_scope TEXT NOT NULL, job_scope_spec_tag TEXT, @@ -107,7 +107,7 @@ CREATE INDEX idx_delivery_tasks_created_at ON delivery_tasks(created_at); CREATE TABLE delivery_jobs ( - delivery_job_id INTEGER PRIMARY KEY, + delivery_job_id INTEGER PRIMARY KEY AUTOINCREMENT, group_id INTEGER NOT NULL REFERENCES groups ON DELETE CASCADE, worker_scope TEXT NOT NULL, job_scope_spec_tag TEXT, diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql b/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql index 356990bdee..6fad0d669e 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql @@ -693,7 +693,7 @@ CREATE TABLE chat_item_mentions( display_name TEXT NOT NULL ); CREATE TABLE delivery_tasks( - delivery_task_id INTEGER PRIMARY KEY, + delivery_task_id INTEGER PRIMARY KEY AUTOINCREMENT, group_id INTEGER NOT NULL REFERENCES groups ON DELETE CASCADE, worker_scope TEXT NOT NULL, job_scope_spec_tag TEXT, @@ -709,7 +709,7 @@ CREATE TABLE delivery_tasks( updated_at TEXT NOT NULL DEFAULT(datetime('now')) ); CREATE TABLE delivery_jobs( - delivery_job_id INTEGER PRIMARY KEY, + delivery_job_id INTEGER PRIMARY KEY AUTOINCREMENT, group_id INTEGER NOT NULL REFERENCES groups ON DELETE CASCADE, worker_scope TEXT NOT NULL, job_scope_spec_tag TEXT, From fa0103c7f5eb211293936fc601d02823d51f47c8 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Wed, 17 Sep 2025 09:13:28 +0100 Subject: [PATCH 08/64] core: update simplexmq --- cabal.project | 2 +- scripts/nix/sha256map.nix | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/cabal.project b/cabal.project index 48ac0dc24c..0452f09216 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: 8a7991a3768d632346c8d8f3c319ed64ccba93b6 + tag: 54a2a6c9051f610b8c7533369d9e9cce81af06ad source-repository-package type: git diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index 09a1407a31..1ef1b2f51f 100644 --- a/scripts/nix/sha256map.nix +++ b/scripts/nix/sha256map.nix @@ -1,5 +1,5 @@ { - "https://github.com/simplex-chat/simplexmq.git"."8a7991a3768d632346c8d8f3c319ed64ccba93b6" = "14p3436bvbxrcx3sp2gy97ycc7v0wzhar8vvxa6lcs8anki1va08"; + "https://github.com/simplex-chat/simplexmq.git"."54a2a6c9051f610b8c7533369d9e9cce81af06ad" = "02c6hh5vffm23gz2gkn6rq2ifcyj5c9s6kz0kyk055i78gsfhp43"; "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"; From 429ec9d21a0ab24ddd19240c52023f1b3bec3b43 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Thu, 18 Sep 2025 17:52:47 +0100 Subject: [PATCH 09/64] directory: listings for web pages (#6281) * directory: listings for web pages * refactor * tests --- apps/simplex-directory-service/Main.hs | 8 +- .../src/Directory/Events.hs | 14 +- .../src/Directory/Listing.hs | 97 +++++++++ .../src/Directory/Options.hs | 9 + .../src/Directory/Service.hs | 185 +++++++++++------- .../src/Directory/Store.hs | 144 +++++++++----- .../src/Directory/Util.hs | 31 +++ simplex-chat.cabal | 6 + tests/Bots/DirectoryTests.hs | 83 ++++++-- 9 files changed, 437 insertions(+), 140 deletions(-) create mode 100644 apps/simplex-directory-service/src/Directory/Listing.hs create mode 100644 apps/simplex-directory-service/src/Directory/Util.hs diff --git a/apps/simplex-directory-service/Main.hs b/apps/simplex-directory-service/Main.hs index 2091ab444b..e2b96f5677 100644 --- a/apps/simplex-directory-service/Main.hs +++ b/apps/simplex-directory-service/Main.hs @@ -17,5 +17,9 @@ main = do then directoryServiceCLI st opts else do env <- newServiceState opts - let cfg = terminalChatConfig {chatHooks = defaultChatHooks {acceptMember = Just $ acceptMemberHook opts env}} - simplexChatCore cfg (mkChatOpts opts) $ directoryService st opts env + let chatHooks = + defaultChatHooks + { postStartHook = Just $ directoryStartHook st opts, + acceptMember = Just $ acceptMemberHook opts env + } + simplexChatCore (terminalChatConfig {chatHooks}) (mkChatOpts opts) $ directoryService st opts env diff --git a/apps/simplex-directory-service/src/Directory/Events.hs b/apps/simplex-directory-service/src/Directory/Events.hs index 8ae7f60b3d..1f075c677c 100644 --- a/apps/simplex-directory-service/src/Directory/Events.hs +++ b/apps/simplex-directory-service/src/Directory/Events.hs @@ -135,6 +135,7 @@ data DirectoryCmdTag (r :: DirectoryRole) where DCInviteOwnerToGroup_ :: DirectoryCmdTag 'DRAdmin -- DCAddBlockedWord_ :: DirectoryCmdTag 'DRAdmin -- DCRemoveBlockedWord_ :: DirectoryCmdTag 'DRAdmin + DCPromoteGroup_ :: DirectoryCmdTag 'DRSuperUser DCExecuteCommand_ :: DirectoryCmdTag 'DRSuperUser deriving instance Show (DirectoryCmdTag r) @@ -157,7 +158,7 @@ data DirectoryCmd (r :: DirectoryRole) where DCMemberRole :: UserGroupRegId -> Maybe GroupName -> Maybe GroupMemberRole -> DirectoryCmd 'DRUser DCGroupFilter :: UserGroupRegId -> Maybe GroupName -> Maybe DirectoryMemberAcceptance -> DirectoryCmd 'DRUser DCShowUpgradeGroupLink :: GroupId -> Maybe GroupName -> DirectoryCmd 'DRUser - DCApproveGroup :: {groupId :: GroupId, displayName :: GroupName, groupApprovalId :: GroupApprovalId} -> DirectoryCmd 'DRAdmin + DCApproveGroup :: {groupId :: GroupId, displayName :: GroupName, groupApprovalId :: GroupApprovalId, promote :: Maybe Bool} -> DirectoryCmd 'DRAdmin DCRejectGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin DCSuspendGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin DCResumeGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin @@ -167,6 +168,7 @@ data DirectoryCmd (r :: DirectoryRole) where DCInviteOwnerToGroup :: GroupId -> GroupName -> DirectoryCmd 'DRAdmin -- DCAddBlockedWord :: Text -> DirectoryCmd 'DRAdmin -- DCRemoveBlockedWord :: Text -> DirectoryCmd 'DRAdmin + DCPromoteGroup :: GroupId -> GroupName -> Bool -> DirectoryCmd 'DRSuperUser DCExecuteCommand :: String -> DirectoryCmd 'DRSuperUser DCUnknownCommand :: DirectoryCmd 'DRUser DCCommandError :: DirectoryCmdTag r -> DirectoryCmd r @@ -211,6 +213,7 @@ directoryCmdP = "invite" -> au DCInviteOwnerToGroup_ -- "block_word" -> au DCAddBlockedWord_ -- "unblock_word" -> au DCRemoveBlockedWord_ + "promote" -> su DCPromoteGroup_ "exec" -> su DCExecuteCommand_ "x" -> su DCExecuteCommand_ _ -> fail "bad command tag" @@ -270,7 +273,8 @@ directoryCmdP = DCApproveGroup_ -> do (groupId, displayName) <- gc (,) groupApprovalId <- A.space *> A.decimal - pure DCApproveGroup {groupId, displayName, groupApprovalId} + promote <- Just <$> (" promote=" *> onOffP) <|> pure Nothing + pure DCApproveGroup {groupId, displayName, groupApprovalId, promote} DCRejectGroup_ -> gc DCRejectGroup DCSuspendGroup_ -> gc DCSuspendGroup DCResumeGroup_ -> gc DCResumeGroup @@ -283,12 +287,17 @@ directoryCmdP = DCInviteOwnerToGroup_ -> gc DCInviteOwnerToGroup -- DCAddBlockedWord_ -> DCAddBlockedWord <$> wordP -- DCRemoveBlockedWord_ -> DCRemoveBlockedWord <$> wordP + DCPromoteGroup_ -> do + (groupId, displayName) <- gc (,) + promote <- A.space *> onOffP + pure $ DCPromoteGroup groupId displayName promote DCExecuteCommand_ -> DCExecuteCommand . T.unpack <$> (spacesP *> A.takeText) where gc f = f <$> (spacesP *> A.decimal) <*> (A.char ':' *> displayNameTextP) gc_ f = f <$> (spacesP *> A.decimal) <*> optional (A.char ':' *> displayNameTextP) -- wordP = spacesP *> A.takeTill isSpace spacesP = A.takeWhile1 isSpace + onOffP = (A.string "on" $> True) <|> (A.string "off" $> False) directoryCmdTag :: DirectoryCmd r -> Text directoryCmdTag = \case @@ -314,6 +323,7 @@ directoryCmdTag = \case DCInviteOwnerToGroup {} -> "invite" -- DCAddBlockedWord _ -> "block_word" -- DCRemoveBlockedWord _ -> "unblock_word" + DCPromoteGroup {} -> "promote" DCExecuteCommand _ -> "exec" DCUnknownCommand -> "unknown" DCCommandError _ -> "error" diff --git a/apps/simplex-directory-service/src/Directory/Listing.hs b/apps/simplex-directory-service/src/Directory/Listing.hs new file mode 100644 index 0000000000..a05e82285d --- /dev/null +++ b/apps/simplex-directory-service/src/Directory/Listing.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} + +module Directory.Listing where + +import Control.Applicative ((<|>)) +import Control.Concurrent.STM +import Control.Monad +import qualified Data.Aeson as J +import qualified Data.Aeson.TH as JQ +import Data.ByteString (ByteString) +import Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy as LB +import Data.Maybe (fromMaybe) +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Directory.Store +import Simplex.Chat.Types +import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, taggedObjectJSON) +import System.Directory +import System.FilePath + +listingFileName :: String +listingFileName = "listing.json" + +promotedFileName :: String +promotedFileName = "promoted.json" + +listingImageFolder :: String +listingImageFolder = "images" + +data DirectoryEntryType = DETGroup + { admission :: Maybe GroupMemberAdmission, + summary :: GroupSummary + } + +$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "DET") ''DirectoryEntryType) + +data DirectoryEntry = DirectoryEntry + { entryType :: DirectoryEntryType, + displayName :: Text, + shortDescr :: Maybe Text, + welcomeMessage :: Maybe Text, + imageFile :: Maybe String + } + +$(JQ.deriveJSON defaultJSON ''DirectoryEntry) + +data DirectoryListing = DirectoryListing {entries :: [DirectoryEntry]} + +$(JQ.deriveJSON defaultJSON ''DirectoryListing) + +type ImageFileData = ByteString + +groupDirectoryEntry :: GroupInfoSummary -> (DirectoryEntry, Maybe (FilePath, ImageFileData)) +groupDirectoryEntry (GIS GroupInfo {groupId, groupProfile} summary) = + let GroupProfile {displayName, shortDescr, description, image, memberAdmission} = groupProfile + entryType = DETGroup memberAdmission summary + imgData = imgFileData =<< image + in (DirectoryEntry {entryType, displayName, shortDescr, welcomeMessage = description, imageFile = fst <$> imgData}, imgData) + where + imgFileData (ImageData img) = + let (img', imgExt) = + fromMaybe (img, ".jpg") $ + (,".jpg") <$> T.stripPrefix "data:image/jpg;base64," img + <|> (,".png") <$> T.stripPrefix "data:image/png;base64," img + imgFile = listingImageFolder show groupId <> imgExt + in case B64.decode $ encodeUtf8 img' of + Right img'' -> Just (imgFile, img'') + Left _ -> Nothing + +generateListing :: DirectoryStore -> FilePath -> [GroupInfoSummary] -> IO () +generateListing st dir gs = do + gs' <- filterListedGroups st gs + removePathForcibly (dir listingImageFolder) + createDirectoryIfMissing True (dir listingImageFolder) + gs'' <- forM gs' $ \g@(GIS GroupInfo {groupId} _) -> do + let (g', img) = groupDirectoryEntry g + forM_ img $ \(imgFile, imgData) -> B.writeFile (dir imgFile) imgData + pure (groupId, g') + saveListing listingFileName gs'' + saveListing promotedFileName =<< filterPromotedGroups st gs'' + where + saveListing f = LB.writeFile (dir f) . J.encode . DirectoryListing . map snd + +filterPromotedGroups :: DirectoryStore -> [(GroupId, DirectoryEntry)] -> IO [(GroupId, DirectoryEntry)] +filterPromotedGroups st gs = do + pgs <- readTVarIO $ promotedGroups st + pure $ filter (\g -> fst g `S.member` pgs) gs diff --git a/apps/simplex-directory-service/src/Directory/Options.hs b/apps/simplex-directory-service/src/Directory/Options.hs index 7ad3512fe9..e0052b3b1e 100644 --- a/apps/simplex-directory-service/src/Directory/Options.hs +++ b/apps/simplex-directory-service/src/Directory/Options.hs @@ -33,6 +33,7 @@ data DirectoryOpts = DirectoryOpts serviceName :: T.Text, runCLI :: Bool, searchResults :: Int, + webFolder :: Maybe FilePath, testing :: Bool } @@ -124,6 +125,13 @@ directoryOpts appDir defaultDbName = do ( long "run-cli" <> help "Run directory service as CLI" ) + webFolder <- + optional $ + strOption + ( long "web-folder" + <> metavar "WEB_FOLDER" + <> help "Folder to store static web assets" + ) pure DirectoryOpts { coreOptions, @@ -140,6 +148,7 @@ directoryOpts appDir defaultDbName = do serviceName = T.pack serviceName, runCLI, searchResults = 10, + webFolder, testing = False } diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index f95b04dee1..7bbe4e43a4 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/apps/simplex-directory-service/src/Directory/Service.hs @@ -15,14 +15,14 @@ module Directory.Service directoryService, directoryServiceCLI, newServiceState, - acceptMemberHook + directoryStartHook, + acceptMemberHook, ) where import Control.Concurrent (forkIO) import Control.Concurrent.Async import Control.Concurrent.STM -import qualified Control.Exception as E import Control.Logger.Simple import Control.Monad import Control.Monad.Except @@ -41,20 +41,22 @@ import Data.Time.LocalTime (getCurrentTimeZone) import Directory.BlockedWords import Directory.Captcha import Directory.Events +import Directory.Listing import Directory.Options import Directory.Search import Directory.Store +import Directory.Util import Simplex.Chat.Bot import Simplex.Chat.Bot.KnownContacts import Simplex.Chat.Controller import Simplex.Chat.Core -import Simplex.Chat.Markdown (FormattedText (..), Format (..), parseMaybeMarkdownList, viewName) +import Simplex.Chat.Markdown (Format (..), FormattedText (..), parseMaybeMarkdownList, viewName) import Simplex.Chat.Messages import Simplex.Chat.Options import Simplex.Chat.Protocol (MsgContent (..)) import Simplex.Chat.Store (GroupLink (..)) import Simplex.Chat.Store.Direct (getContact) -import Simplex.Chat.Store.Groups (getGroupInfo, getGroupLink, getGroupSummary, setGroupCustomData) +import Simplex.Chat.Store.Groups (getGroupInfo, getGroupLink, getGroupSummary, getUserGroupsWithSummary, setGroupCustomData) import Simplex.Chat.Store.Profiles (GroupLinkInfo (..), getGroupLinkInfo) import Simplex.Chat.Store.Shared (StoreError (..)) import Simplex.Chat.Terminal (terminalChatConfig) @@ -63,14 +65,11 @@ import Simplex.Chat.Types import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Shared import Simplex.Chat.View (serializeChatError, serializeChatResponse, simplexChatContact, viewContactName, viewGroupName) -import Simplex.Messaging.Agent.Protocol (AConnectionLink (..), ConnectionLink (..), CreatedConnLink (..)) -import Simplex.Messaging.Agent.Store.Common (withTransaction) -import Simplex.Messaging.Agent.Protocol (SConnectionMode (..), sameConnReqContact, sameShortLinkContact) -import qualified Simplex.Messaging.Agent.Store.DB as DB +import Simplex.Messaging.Agent.Protocol (AConnectionLink (..), ConnectionLink (..), CreatedConnLink (..), SConnectionMode (..), sameConnReqContact, sameShortLinkContact) import Simplex.Messaging.Encoding.String import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Util (safeDecodeUtf8, tshow, ($>>=), (<$$>)) +import Simplex.Messaging.Util (safeDecodeUtf8, tshow, unlessM, whenM, ($>>=), (<$$>)) import System.Directory (getAppUserDataDirectory) import System.Exit (exitFailure) import System.Process (readProcess) @@ -147,7 +146,7 @@ directoryServiceCLI st opts = do env <- newServiceState opts eventQ <- newTQueueIO let eventHook cc resp = atomically $ resp <$ writeTQueue eventQ (cc, resp) - chatHooks = defaultChatHooks {postStartHook = Just postStartHook, eventHook = Just eventHook, acceptMember = Just $ acceptMemberHook opts env} + chatHooks = defaultChatHooks {postStartHook = Just $ directoryStartHook st opts, eventHook = Just eventHook, acceptMember = Just $ acceptMemberHook opts env} race_ (simplexChatCLI' terminalChatConfig {chatHooks} (mkChatOpts opts) Nothing) (processEvents eventQ env) @@ -156,18 +155,22 @@ directoryServiceCLI st opts = do (cc, resp) <- atomically $ readTQueue eventQ u_ <- readTVarIO (currentUser cc) forM_ u_ $ \user -> directoryServiceEvent st opts env user cc resp - postStartHook cc = - readTVarIO (currentUser cc) >>= \case - Nothing -> putStrLn "No current user" >> exitFailure - Just User {userId, profile = p@LocalProfile {preferences}} -> do - let cmds = fromMaybe [] $ preferences >>= commands_ - unless (cmds == directoryCommands) $ do - let prefs = (fromMaybe emptyChatPrefs preferences) {files = Just FilesPreference {allow = FANo}, commands = Just directoryCommands} :: Preferences - p' = (fromLocalProfile p) {displayName = serviceName opts, peerType = Just CPTBot, preferences = Just prefs} :: Profile - liftIO $ sendChatCmd cc (APIUpdateProfile userId p') >>= \case - Right CRUserProfileUpdated {} -> putStrLn "Updated directory commands" - Right r -> putStrLn ("Error: unexpected response " <> show r) >> exitFailure - Left e -> putStrLn ("Error: " <> show e) >> exitFailure + +directoryStartHook :: DirectoryStore -> DirectoryOpts -> ChatController -> IO () +directoryStartHook st opts cc = + readTVarIO (currentUser cc) >>= \case + Nothing -> putStrLn "No current user" >> exitFailure + Just user@User {userId, profile = p@LocalProfile {preferences}} -> do + forM_ (webFolder opts) $ updateGroupListingFiles cc st user + let cmds = fromMaybe [] $ preferences >>= commands_ + unless (cmds == directoryCommands) $ do + let prefs = (fromMaybe emptyChatPrefs preferences) {files = Just FilesPreference {allow = FANo}, commands = Just directoryCommands} :: Preferences + p' = (fromLocalProfile p) {displayName = serviceName opts, peerType = Just CPTBot, preferences = Just prefs} :: Profile + liftIO $ + sendChatCmd cc (APIUpdateProfile userId p') >>= \case + Right CRUserProfileUpdated {} -> putStrLn "Updated directory commands" + Right r -> putStrLn ("Error: unexpected response " <> show r) >> exitFailure + Left e -> putStrLn ("Error: " <> show e) >> exitFailure directoryCommands :: [ChatBotCommand] directoryCommands = @@ -323,7 +326,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName void $ addGroupReg st ct g GRSProposed r <- sendChatCmd cc $ APIJoinGroup groupId MFNone sendMessage cc ct $ case r of - Right CRUserAcceptedGroupSent {} -> "Joining the group " <> displayName <> "…" + Right CRUserAcceptedGroupSent {} -> "Joining the group " <> displayName <> "…" _ -> "Error joining group " <> displayName <> ", please re-send the invitation!" deContactConnected :: Contact -> IO () @@ -392,7 +395,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName notifyOwner gr $ "Joined the group " <> displayName <> ", creating the link…" sendChatCmd cc (APICreateGroupLink groupId GRMember) >>= \case Right CRGroupLinkCreated {groupLink = GroupLink {connLinkContact = gLink}} -> do - setGroupStatus st gr GRSPendingUpdate + setGroupStatus st opts cc user gr GRSPendingUpdate notifyOwner gr "Created the public link to join the group via this directory service that is always online.\n\n\ @@ -431,7 +434,9 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName GPServiceLinkError -> do notifyOwner gr $ ("Error: " <> serviceName <> " has no group link for " <> userGroupRef) - <> " after profile was updated" <> byMember <> ". Please report the error to the developers." + <> " after profile was updated" + <> byMember + <> ". Please report the error to the developers." logError $ "Error: no group link for " <> userGroupRef GRSPendingApproval n -> processProfileChange gr byMember False $ n + 1 GRSActive -> processProfileChange gr byMember True 1 @@ -451,7 +456,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName Just DGReserved -> notifyOwner gr $ groupAlreadyListed toGroup _ -> do let gaId = 1 - setGroupStatus st gr $ GRSPendingApproval gaId + setGroupStatus st opts cc user gr $ GRSPendingApproval gaId notifyOwner gr $ ("Thank you! The group link for " <> userGroupReference gr toGroup <> " is added to the welcome message" <> byMember) <> ".\nYou will be notified once the group is added to the directory - it may take up to 48 hours." @@ -461,18 +466,18 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName groupRef = groupReference toGroup groupProfileUpdate >>= \case GPNoServiceLink -> do - setGroupStatus st gr GRSPendingUpdate + setGroupStatus st opts cc user gr GRSPendingUpdate notifyOwner gr $ ("The group profile is updated for " <> userGroupRef <> byMember <> ", but no link is added to the welcome message.\n\n") <> "The group will remain hidden from the directory until the group link is added and the group is re-approved." GPServiceLinkRemoved -> do - setGroupStatus st gr GRSPendingUpdate + setGroupStatus st opts cc user gr GRSPendingUpdate notifyOwner gr $ ("The group link for " <> userGroupRef <> " is removed from the welcome message" <> byMember) <> ".\n\nThe group is hidden from the directory until the group link is added and the group is re-approved." notifyAdminUsers $ "The group link is removed from " <> groupRef <> ", de-listed." GPServiceLinkAdded _ -> do - setGroupStatus st gr $ GRSPendingApproval n' + setGroupStatus st opts cc user gr $ GRSPendingApproval n' notifyOwner gr $ ("The group link is added to " <> userGroupRef <> byMember) <> "!\nIt is hidden from the directory until approved." @@ -485,7 +490,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName <> "!\nThe group is listed in directory." notifyAdminUsers $ "The group " <> groupRef <> " is updated" <> byMember <> " - only link or whitespace changes.\nThe group remained listed in directory." | otherwise -> do - setGroupStatus st gr $ GRSPendingApproval n' + setGroupStatus st opts cc user gr $ GRSPendingApproval n' notifyOwner gr $ ("The group " <> userGroupRef <> " is updated" <> byMember) <> "!\nIt is hidden from the directory until approved." @@ -523,7 +528,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName Just Nothing -> sendToApprove toGroup gr gaId dePendingMember :: GroupInfo -> GroupMember -> IO () - dePendingMember g@GroupInfo {groupProfile = GroupProfile {displayName}} m + dePendingMember g@GroupInfo {groupProfile = GroupProfile {displayName}} m | memberRequiresCaptcha a m = sendMemberCaptcha g m Nothing captchaNotice 0 | otherwise = approvePendingMember a g m where @@ -600,7 +605,8 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName useMemberFilter image $ passCaptcha a sendToApprove :: GroupInfo -> GroupReg -> GroupApprovalId -> IO () - sendToApprove GroupInfo {groupProfile = p@GroupProfile {displayName, image = image'}} GroupReg {dbGroupId, dbContactId} gaId = do + sendToApprove GroupInfo {groupProfile = p@GroupProfile {displayName, image = image'}} GroupReg {dbGroupId, dbContactId, promoted} gaId = do + -- TODO account for promotion ct_ <- getContact' cc user dbContactId gr_ <- getGroupAndSummary cc user dbGroupId let membersStr = maybe "" (\(_, s) -> "_" <> tshow (currentMembers s) <> " members_\n") gr_ @@ -608,9 +614,10 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName maybe ("The group ID " <> tshow dbGroupId <> " submitted: ") (\c -> localDisplayName' c <> " submitted the group ID " <> tshow dbGroupId <> ": ") ct_ <> ("\n" <> groupInfoText p <> "\n" <> membersStr <> "\nTo approve send:") msg = maybe (MCText text) (\image -> MCImage {text, image}) image' + promote <- readTVarIO promoted withAdminUsers $ \cId -> do sendComposedMessage' cc cId Nothing msg - sendMessage' cc cId $ "/approve " <> tshow dbGroupId <> ":" <> viewName displayName <> " " <> tshow gaId + sendMessage' cc cId $ "/approve " <> tshow dbGroupId <> ":" <> viewName displayName <> " " <> tshow gaId <> if promote then " promote=on" else "" deContactRoleChanged :: GroupInfo -> ContactId -> GroupMemberRole -> IO () deContactRoleChanged g@GroupInfo {membership = GroupMember {memberRole = serviceRole}} ctId contactRole = do @@ -621,14 +628,14 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName when (ctId `isOwner` gr) $ do readTVarIO (groupRegStatus gr) >>= \case GRSSuspendedBadRoles -> when (rStatus == GRSOk) $ do - setGroupStatus st gr GRSActive + setGroupStatus st opts cc user gr GRSActive notifyOwner gr $ uCtRole <> ".\n\nThe group is listed in the directory again." notifyAdminUsers $ "The group " <> groupRef <> " is listed " <> suCtRole GRSPendingApproval gaId -> when (rStatus == GRSOk) $ do sendToApprove g gr gaId notifyOwner gr $ uCtRole <> ".\n\nThe group is submitted for approval." GRSActive -> when (rStatus /= GRSOk) $ do - setGroupStatus st gr GRSSuspendedBadRoles + setGroupStatus st opts cc user gr GRSSuspendedBadRoles notifyOwner gr $ uCtRole <> ".\n\nThe group is no longer listed in the directory." notifyAdminUsers $ "The group " <> groupRef <> " is de-listed " <> suCtRole _ -> pure () @@ -647,7 +654,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName readTVarIO (groupRegStatus gr) >>= \case GRSSuspendedBadRoles -> when (serviceRole == GRAdmin) $ whenContactIsOwner gr $ do - setGroupStatus st gr GRSActive + setGroupStatus st opts cc user gr GRSActive notifyOwner gr $ uSrvRole <> ".\n\nThe group is listed in the directory again." notifyAdminUsers $ "The group " <> groupRef <> " is listed " <> suSrvRole GRSPendingApproval gaId -> when (serviceRole == GRAdmin) $ @@ -655,7 +662,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName sendToApprove g gr gaId notifyOwner gr $ uSrvRole <> ".\n\nThe group is submitted for approval." GRSActive -> when (serviceRole /= GRAdmin) $ do - setGroupStatus st gr GRSSuspendedBadRoles + setGroupStatus st opts cc user gr GRSSuspendedBadRoles notifyOwner gr $ uSrvRole <> ".\n\nThe group is no longer listed in the directory." notifyAdminUsers $ "The group " <> groupRef <> " is de-listed " <> suSrvRole _ -> pure () @@ -672,7 +679,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName logInfo $ "contact ID " <> tshow ctId <> " removed from group " <> viewGroupName g withGroupReg g "contact removed" $ \gr -> do when (ctId `isOwner` gr) $ do - setGroupStatus st gr GRSRemoved + setGroupStatus st opts cc user gr GRSRemoved notifyOwner gr $ "You are removed from the group " <> userGroupReference gr g <> ".\n\nThe group is no longer listed in the directory." notifyAdminUsers $ "The group " <> groupReference g <> " is de-listed (group owner is removed)." @@ -681,7 +688,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName logInfo $ "contact ID " <> tshow ctId <> " left group " <> viewGroupName g withGroupReg g "contact left" $ \gr -> do when (ctId `isOwner` gr) $ do - setGroupStatus st gr GRSRemoved + setGroupStatus st opts cc user gr GRSRemoved notifyOwner gr $ "You left the group " <> userGroupReference gr g <> ".\n\nThe group is no longer listed in the directory." notifyAdminUsers $ "The group " <> groupReference g <> " is de-listed (group owner left)." @@ -689,7 +696,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName deServiceRemovedFromGroup g = do logInfo $ "service removed from group " <> viewGroupName g withGroupReg g "service removed" $ \gr -> do - setGroupStatus st gr GRSRemoved + setGroupStatus st opts cc user gr GRSRemoved notifyOwner gr $ serviceName <> " is removed from the group " <> userGroupReference gr g <> ".\n\nThe group is no longer listed in the directory." notifyAdminUsers $ "The group " <> groupReference g <> " is de-listed (directory service is removed)." @@ -697,7 +704,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName deGroupDeleted g = do logInfo $ "group removed " <> viewGroupName g withGroupReg g "group removed" $ \gr -> do - setGroupStatus st gr GRSRemoved + setGroupStatus st opts cc user gr GRSRemoved notifyOwner gr $ "The group " <> userGroupReference gr g <> " is deleted.\n\nThe group is no longer listed in the directory." notifyAdminUsers $ "The group " <> groupReference g <> " is de-listed (group is deleted)." @@ -817,12 +824,13 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName withGroupLinkResult groupRef (sendChatCmd cc $ APIGetGroupLink groupId) $ \GroupLink {connLinkContact = gLink@(CCLink _ sLnk_), acceptMemberRole, shortLinkDataSet, shortLinkLargeDataSet = BoolDef slLargeDataSet} -> do let shouldBeUpgraded = isNothing sLnk_ || not shortLinkDataSet || not slLargeDataSet - sendReply $ T.unlines $ - [ "The link to join the group " <> groupRef <> ":", - groupLinkText gLink, - "New member role: " <> strEncodeTxt acceptMemberRole - ] - <> ["The link is being upgraded..." | shouldBeUpgraded] + sendReply $ + T.unlines $ + [ "The link to join the group " <> groupRef <> ":", + groupLinkText gLink, + "New member role: " <> strEncodeTxt acceptMemberRole + ] + <> ["The link is being upgraded..." | shouldBeUpgraded] when shouldBeUpgraded $ do let send = sendComposedMessage cc ct Nothing . MCText . T.unlines withGroupLinkResult groupRef (sendChatCmd cc $ APIAddGroupShortLink groupId) $ @@ -830,13 +838,16 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName (Just _, Just _) -> send ["The group link is upgraded for: " <> groupRef, "No changes to group needed."] (Nothing, Just sLnk) -> - sendComposedMessages cc (SRDirect $ contactId' ct) - [ MCText $ T.unlines - [ "Please replace the old link in welcome message of your group " <> groupRef, - "If this is the only change, the group will remain listed in directory without re-approval.", - "", - "The new link:" - ], + sendComposedMessages + cc + (SRDirect $ contactId' ct) + [ MCText $ + T.unlines + [ "Please replace the old link in welcome message of your group " <> groupRef, + "If this is the only change, the group will remain listed in directory without re-approval.", + "", + "The new link:" + ], MCText $ strEncodeTxt sLnk ] (_, Nothing) -> @@ -924,8 +935,8 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName deAdminCommand :: Contact -> ChatItemId -> DirectoryCmd 'DRAdmin -> IO () deAdminCommand ct ciId cmd | knownCt `elem` adminUsers || knownCt `elem` superUsers = case cmd of - DCApproveGroup {groupId, displayName = n, groupApprovalId} -> - withGroupAndReg sendReply groupId n $ \g gr@GroupReg {userGroupRegId = ugrId} -> + DCApproveGroup {groupId, displayName = n, groupApprovalId, promote} -> + withGroupAndReg sendReply groupId n $ \g gr@GroupReg {userGroupRegId = ugrId, promoted} -> readTVarIO (groupRegStatus gr) >>= \case GRSPendingApproval gaId | gaId == groupApprovalId -> do @@ -935,7 +946,17 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName _ -> do getGroupRolesStatus g gr >>= \case Just GRSOk -> do - setGroupStatus st gr GRSActive + setGroupStatus st opts cc user gr GRSActive + forM_ promote $ \promo -> + if promo -- admins can unpromote, only super-user can promote when approving + then + unlessM (readTVarIO promoted) $ + if knownCt `elem` superUsers + then setGroupPromoted st opts cc user gr True + else sendReply "You cannot promote groups" + else do + whenM (readTVarIO promoted) $ setGroupPromoted st opts cc user gr False + notifyOtherSuperUsers $ "Group promotion is disabled for " <> groupRef let approved = "The group " <> userGroupReference' gr n <> " is approved" notifyOwner gr $ (approved <> " and listed in directory - please moderate it!\n") @@ -970,7 +991,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName withGroupAndReg sendReply groupId gName $ \_ gr -> readTVarIO (groupRegStatus gr) >>= \case GRSActive -> do - setGroupStatus st gr GRSSuspended + setGroupStatus st opts cc user gr GRSSuspended let suspended = "The group " <> userGroupReference' gr gName <> " is suspended" notifyOwner gr $ suspended <> " and hidden from directory. Please contact the administrators." sendReply "Group suspended!" @@ -981,7 +1002,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName withGroupAndReg sendReply groupId gName $ \_ gr -> readTVarIO (groupRegStatus gr) >>= \case GRSSuspended -> do - setGroupStatus st gr GRSActive + setGroupStatus st opts cc user gr GRSActive let groupStr = "The group " <> userGroupReference' gr gName notifyOwner gr $ groupStr <> " is listed in the directory again!" sendReply "Group listing resumed!" @@ -1002,7 +1023,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName Right () -> do let groupRef = groupReference' groupId gName owner <- groupOwnerInfo groupRef ctId - let invited = " invited " <> owner <> " to owners' group " <> viewName ogName + let invited = " invited " <> owner <> " to owners' group " <> viewName ogName notifyOtherSuperUsers $ viewName (localDisplayName' ct) <> invited sendReply $ "you" <> invited Left err -> sendReply err @@ -1039,7 +1060,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName r -> contErr r r -> contErr r where - alreadyMember = isJust . find ((Just ctId == ) . memberContactId) + alreadyMember = isJust . find ((Just ctId ==) . memberContactId) contErr r = do let err = "error inviting contact ID " <> tshow ctId <> " to owners' group: " <> tshow r putStrLn $ T.unpack err @@ -1053,6 +1074,15 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName deSuperUserCommand :: Contact -> ChatItemId -> DirectoryCmd 'DRSuperUser -> IO () deSuperUserCommand ct ciId cmd | knownContact ct `elem` superUsers = case cmd of + DCPromoteGroup groupId gName promote' -> + withGroupAndReg sendReply groupId gName $ \_ gr@GroupReg {groupRegStatus, promoted} -> do + status <- readTVarIO groupRegStatus + promote <- readTVarIO promoted + when (promote' /= promote) $ setGroupPromoted st opts cc user gr promote' + let msg = + "Group promotion " + <> (if promote' then "enabled" <> (if status == GRSActive then "." else ", but the group is not listed.") else "disabled.") + sendReply msg DCExecuteCommand cmdStr -> sendChatCmdStr cc cmdStr >>= \case Right r -> do @@ -1102,30 +1132,35 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName let text = T.unlines $ [tshow useGroupId <> ". Error: getGroup. Please notify the developers."] <> maybeToList ownerStr_ <> [statusStr] sendComposedMessage cc ct Nothing $ MCText text +setGroupStatus :: DirectoryStore -> DirectoryOpts -> ChatController -> User -> GroupReg -> GroupRegStatus -> IO () +setGroupStatus st opts cc u gr grStatus' = do + let status' = grDirectoryStatus grStatus' + status <- setGroupStatusStore st gr grStatus' + forM_ (webFolder opts) $ \dir -> + when ((status == DSListed || status' == DSListed) && status /= status') $ updateGroupListingFiles cc st u dir + +setGroupPromoted :: DirectoryStore -> DirectoryOpts -> ChatController -> User -> GroupReg -> Bool -> IO () +setGroupPromoted st opts cc u gr grPromoted' = do + (status, grPromoted) <- setGroupPromotedStore st gr grPromoted' + forM_ (webFolder opts) $ \dir -> + when (status == DSListed && grPromoted' /= grPromoted) $ updateGroupListingFiles cc st u dir + +updateGroupListingFiles :: ChatController -> DirectoryStore -> User -> FilePath -> IO () +updateGroupListingFiles cc st u dir = + withDB' "generateListing" cc (\db -> getUserGroupsWithSummary db (vr cc) u Nothing Nothing) >>= \case + Just gs -> generateListing st dir gs + Nothing -> putStrLn "generateListing error: failed to read groups" + getContact' :: ChatController -> User -> ContactId -> IO (Maybe Contact) getContact' cc user ctId = withDB "getContact" cc $ \db -> getContact db (vr cc) user ctId getGroup :: ChatController -> User -> GroupId -> IO (Maybe GroupInfo) getGroup cc user gId = withDB "getGroupInfo" cc $ \db -> getGroupInfo db (vr cc) user gId -withDB' :: Text -> ChatController -> (DB.Connection -> IO a) -> IO (Maybe a) -withDB' cxt cc a = withDB cxt cc $ ExceptT . fmap Right . a - -withDB :: Text -> ChatController -> (DB.Connection -> ExceptT StoreError IO a) -> IO (Maybe a) -withDB cxt ChatController {chatStore} action = do - r_ :: Either ChatError a <- withTransaction chatStore (runExceptT . withExceptT ChatErrorStore . action) `E.catches` handleDBErrors - case r_ of - Right r -> pure $ Just r - Left e -> Nothing <$ logError ("Database error: " <> cxt <> " " <> tshow e) - getGroupAndSummary :: ChatController -> User -> GroupId -> IO (Maybe (GroupInfo, GroupSummary)) getGroupAndSummary cc user gId = withDB "getGroupAndSummary" cc $ \db -> (,) <$> getGroupInfo db (vr cc) user gId <*> liftIO (getGroupSummary db user gId) -vr :: ChatController -> VersionRangeChat -vr ChatController {config = ChatConfig {chatVRange}} = chatVRange -{-# INLINE vr #-} - getGroupLink' :: ChatController -> User -> GroupInfo -> IO (Maybe GroupLink) getGroupLink' cc user gInfo = withDB "getGroupLink" cc $ \db -> getGroupLink db user gInfo diff --git a/apps/simplex-directory-service/src/Directory/Store.hs b/apps/simplex-directory-service/src/Directory/Store.hs index 9498fedf95..16f047202f 100644 --- a/apps/simplex-directory-service/src/Directory/Store.hs +++ b/apps/simplex-directory-service/src/Directory/Store.hs @@ -13,11 +13,14 @@ module Directory.Store GroupApprovalId, DirectoryGroupData (..), DirectoryMemberAcceptance (..), + DirectoryStatus (..), ProfileCondition (..), restoreDirectoryStore, addGroupReg, delGroupReg, - setGroupStatus, + setGroupStatusStore, + setGroupPromotedStore, + grDirectoryStatus, setGroupRegOwner, getGroupReg, getUserGroupReg, @@ -31,13 +34,14 @@ module Directory.Store noJoinFilter, basicJoinFilter, moderateJoinFilter, - strongJoinFilter + strongJoinFilter, ) where +import Control.Applicative ((<|>)) import Control.Concurrent.STM import Control.Monad -import Data.Aeson ((.=), (.:)) +import Data.Aeson ((.:), (.=)) import qualified Data.Aeson.KeyMap as JM import qualified Data.Aeson.TH as JQ import qualified Data.Aeson.Types as JT @@ -55,23 +59,32 @@ import Data.Text (Text) import Simplex.Chat.Types import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON) -import Simplex.Messaging.Util (ifM) -import System.Directory (doesFileExist, renameFile) +import Simplex.Messaging.Util (ifM, whenM) +import System.Directory import System.IO (BufferMode (..), Handle, IOMode (..), hSetBuffering, openFile) data DirectoryStore = DirectoryStore - { groupRegs :: TVar [GroupReg], - listedGroups :: TVar (Set GroupId), + { groupRegs :: TVar [GroupReg], -- most recent first, reversed when listed + listedGroups :: TVar (Set GroupId), -- includes promoted + promotedGroups :: TVar (Set GroupId), reservedGroups :: TVar (Set GroupId), directoryLogFile :: Maybe Handle } +data DirectoryStoreData = DirectoryStoreData + { groupRegs_ :: [GroupReg], + listedGroups_ :: Set GroupId, + promotedGroups_ :: Set GroupId, + reservedGroups_ :: Set GroupId + } + data GroupReg = GroupReg { dbGroupId :: GroupId, userGroupRegId :: UserGroupRegId, dbContactId :: ContactId, dbOwnerMemberId :: TVar (Maybe GroupMemberId), - groupRegStatus :: TVar GroupRegStatus + groupRegStatus :: TVar GroupRegStatus, + promoted :: TVar Bool } data GroupRegData = GroupRegData @@ -79,7 +92,8 @@ data GroupRegData = GroupRegData userGroupRegId_ :: UserGroupRegId, dbContactId_ :: ContactId, dbOwnerMemberId_ :: Maybe GroupMemberId, - groupRegStatus_ :: GroupRegStatus + groupRegStatus_ :: GroupRegStatus, + promoted_ :: Bool } data DirectoryGroupData = DirectoryGroupData @@ -140,7 +154,7 @@ data GroupRegStatus | GRSSuspended | GRSSuspendedBadRoles | GRSRemoved - deriving (Show) + deriving (Eq, Show) pendingApproval :: GroupRegStatus -> Bool pendingApproval = \case @@ -153,6 +167,7 @@ groupRemoved = \case _ -> False data DirectoryStatus = DSListed | DSReserved | DSRegistered | DSRemoved + deriving (Eq) groupRegStatusText :: GroupRegStatus -> Text groupRegStatusText = \case @@ -195,7 +210,7 @@ addGroupReg st ct GroupInfo {groupId} grStatus = do pure $ userGroupRegId_ grData where addGroupReg_ = do - let grData = GroupRegData {dbGroupId_ = groupId, userGroupRegId_ = 1, dbContactId_ = ctId, dbOwnerMemberId_ = Nothing, groupRegStatus_ = grStatus} + let grData = GroupRegData {dbGroupId_ = groupId, userGroupRegId_ = 1, dbContactId_ = ctId, dbOwnerMemberId_ = Nothing, groupRegStatus_ = grStatus, promoted_ = False} gr <- dataToGroupReg grData atomically $ stateTVar (groupRegs st) $ \grs -> let ugrId = 1 + foldl' maxUgrId 0 grs @@ -208,25 +223,38 @@ addGroupReg st ct GroupInfo {groupId} grStatus = do | otherwise = mx delGroupReg :: DirectoryStore -> GroupReg -> IO () -delGroupReg st GroupReg {dbGroupId = gId, groupRegStatus} = do +delGroupReg st gr@GroupReg {dbGroupId = gId, groupRegStatus} = do logGDelete st gId atomically $ writeTVar groupRegStatus GRSRemoved - atomically $ unlistGroup st gId + atomically $ unlistGroup st gr atomically $ modifyTVar' (groupRegs st) $ filter ((gId /=) . dbGroupId) -setGroupStatus :: DirectoryStore -> GroupReg -> GroupRegStatus -> IO () -setGroupStatus st gr grStatus = do - logGUpdateStatus st (dbGroupId gr) grStatus +setGroupStatusStore :: DirectoryStore -> GroupReg -> GroupRegStatus -> IO DirectoryStatus +setGroupStatusStore st gr grStatus' = do + logGUpdateStatus st (dbGroupId gr) grStatus' atomically $ do - writeTVar (groupRegStatus gr) grStatus - updateListing st $ dbGroupId gr + grStatus <- swapTVar (groupRegStatus gr) grStatus' + updateListing st gr + pure $ grDirectoryStatus grStatus where - updateListing = case grDirectoryStatus grStatus of + status' = grDirectoryStatus grStatus' + updateListing = case status' of DSListed -> listGroup DSReserved -> reserveGroup DSRegistered -> unlistGroup DSRemoved -> unlistGroup +setGroupPromotedStore :: DirectoryStore -> GroupReg -> Bool -> IO (DirectoryStatus, Bool) +setGroupPromotedStore st gr grPromoted' = do + let gId = dbGroupId gr + logGUpdatePromotion st gId grPromoted' + atomically $ do + grPromoted <- swapTVar (promoted gr) grPromoted' + status <- grDirectoryStatus <$> readTVar (groupRegStatus gr) + let update = if status == DSListed && grPromoted' then S.insert else S.delete + modifyTVar' (promotedGroups st) $ update gId + pure (status, grPromoted) + setGroupRegOwner :: DirectoryStore -> GroupReg -> GroupMember -> IO () setGroupRegOwner st gr owner = do let memberId = groupMemberId' owner @@ -247,31 +275,39 @@ filterListedGroups st gs = do lgs <- readTVarIO $ listedGroups st pure $ filter (\(GIS GroupInfo {groupId} _) -> groupId `S.member` lgs) gs -listGroup :: DirectoryStore -> GroupId -> STM () -listGroup st gId = do +listGroup :: DirectoryStore -> GroupReg -> STM () +listGroup st gr = do + let gId = dbGroupId gr modifyTVar' (listedGroups st) $ S.insert gId + whenM (readTVar $ promoted gr) $ modifyTVar' (promotedGroups st) $ S.insert gId modifyTVar' (reservedGroups st) $ S.delete gId -reserveGroup :: DirectoryStore -> GroupId -> STM () -reserveGroup st gId = do +reserveGroup :: DirectoryStore -> GroupReg -> STM () +reserveGroup st gr = do + let gId = dbGroupId gr modifyTVar' (listedGroups st) $ S.delete gId + modifyTVar' (promotedGroups st) $ S.delete gId modifyTVar' (reservedGroups st) $ S.insert gId -unlistGroup :: DirectoryStore -> GroupId -> STM () -unlistGroup st gId = do +unlistGroup :: DirectoryStore -> GroupReg -> STM () +unlistGroup st gr = do + let gId = dbGroupId gr modifyTVar' (listedGroups st) $ S.delete gId + modifyTVar' (promotedGroups st) $ S.delete gId modifyTVar' (reservedGroups st) $ S.delete gId data DirectoryLogRecord = GRCreate GroupRegData | GRDelete GroupId | GRUpdateStatus GroupId GroupRegStatus + | GRUpdatePromotion GroupId Bool | GRUpdateOwner GroupId GroupMemberId data DLRTag = GRCreate_ | GRDelete_ | GRUpdateStatus_ + | GRUpdatePromotion_ | GRUpdateOwner_ logDLR :: DirectoryStore -> DirectoryLogRecord -> IO () @@ -286,6 +322,9 @@ logGDelete st = logDLR st . GRDelete logGUpdateStatus :: DirectoryStore -> GroupId -> GroupRegStatus -> IO () logGUpdateStatus st gId = logDLR st . GRUpdateStatus gId +logGUpdatePromotion :: DirectoryStore -> GroupId -> Bool -> IO () +logGUpdatePromotion st gId = logDLR st . GRUpdatePromotion gId + logGUpdateOwner :: DirectoryStore -> GroupId -> GroupMemberId -> IO () logGUpdateOwner st gId = logDLR st . GRUpdateOwner gId @@ -294,12 +333,14 @@ instance StrEncoding DLRTag where GRCreate_ -> "GCREATE" GRDelete_ -> "GDELETE" GRUpdateStatus_ -> "GSTATUS" + GRUpdatePromotion_ -> "GPROMOTE" GRUpdateOwner_ -> "GOWNER" strP = A.takeTill (== ' ') >>= \case "GCREATE" -> pure GRCreate_ "GDELETE" -> pure GRDelete_ "GSTATUS" -> pure GRUpdateStatus_ + "GPROMOTE" -> pure GRUpdatePromotion_ "GOWNER" -> pure GRUpdateOwner_ _ -> fail "invalid DLRTag" @@ -308,30 +349,34 @@ instance StrEncoding DirectoryLogRecord where GRCreate gr -> strEncode (GRCreate_, gr) GRDelete gId -> strEncode (GRDelete_, gId) GRUpdateStatus gId grStatus -> strEncode (GRUpdateStatus_, gId, grStatus) + GRUpdatePromotion gId promoted -> strEncode (GRUpdatePromotion_, gId, promoted) GRUpdateOwner gId grOwnerId -> strEncode (GRUpdateOwner_, gId, grOwnerId) strP = strP_ >>= \case GRCreate_ -> GRCreate <$> strP GRDelete_ -> GRDelete <$> strP GRUpdateStatus_ -> GRUpdateStatus <$> A.decimal <*> _strP + GRUpdatePromotion_ -> GRUpdatePromotion <$> A.decimal <*> _strP GRUpdateOwner_ -> GRUpdateOwner <$> A.decimal <* A.space <*> A.decimal instance StrEncoding GroupRegData where - strEncode GroupRegData {dbGroupId_, userGroupRegId_, dbContactId_, dbOwnerMemberId_, groupRegStatus_} = - B.unwords + strEncode GroupRegData {dbGroupId_, userGroupRegId_, dbContactId_, dbOwnerMemberId_, groupRegStatus_, promoted_} = + B.unwords $ [ "group_id=" <> strEncode dbGroupId_, "user_group_id=" <> strEncode userGroupRegId_, "contact_id=" <> strEncode dbContactId_, "owner_member_id=" <> strEncode dbOwnerMemberId_, "status=" <> strEncode groupRegStatus_ ] + <> ["promoted=" <> strEncode promoted_ | promoted_] strP = do dbGroupId_ <- "group_id=" *> strP_ userGroupRegId_ <- "user_group_id=" *> strP_ dbContactId_ <- "contact_id=" *> strP_ dbOwnerMemberId_ <- "owner_member_id=" *> strP_ groupRegStatus_ <- "status=" *> strP - pure GroupRegData {dbGroupId_, userGroupRegId_, dbContactId_, dbOwnerMemberId_, groupRegStatus_} + promoted_ <- (" promoted=" *> strP) <|> pure False + pure GroupRegData {dbGroupId_, userGroupRegId_, dbContactId_, dbOwnerMemberId_, groupRegStatus_, promoted_} instance StrEncoding GroupRegStatus where strEncode = \case @@ -356,16 +401,18 @@ instance StrEncoding GroupRegStatus where _ -> fail "invalid GroupRegStatus" dataToGroupReg :: GroupRegData -> IO GroupReg -dataToGroupReg GroupRegData {dbGroupId_, userGroupRegId_, dbContactId_, dbOwnerMemberId_, groupRegStatus_} = do +dataToGroupReg GroupRegData {dbGroupId_, userGroupRegId_, dbContactId_, dbOwnerMemberId_, groupRegStatus_, promoted_} = do dbOwnerMemberId <- newTVarIO dbOwnerMemberId_ groupRegStatus <- newTVarIO groupRegStatus_ + promoted <- newTVarIO promoted_ pure GroupReg { dbGroupId = dbGroupId_, userGroupRegId = userGroupRegId_, dbContactId = dbContactId_, dbOwnerMemberId, - groupRegStatus + groupRegStatus, + promoted } restoreDirectoryStore :: Maybe FilePath -> IO DirectoryStore @@ -383,8 +430,8 @@ restoreDirectoryStore = \case h <- writeDirectoryData f grs -- compact mkDirectoryStore h grs -emptyStoreData :: ([GroupReg], Set GroupId, Set GroupId) -emptyStoreData = ([], S.empty, S.empty) +emptyStoreData :: DirectoryStoreData +emptyStoreData = DirectoryStoreData [] S.empty S.empty S.empty newDirectoryStore :: Maybe Handle -> IO DirectoryStore newDirectoryStore = (`mkDirectoryStore_` emptyStoreData) @@ -393,21 +440,27 @@ mkDirectoryStore :: Handle -> [GroupRegData] -> IO DirectoryStore mkDirectoryStore h groups = foldM addGroupRegData emptyStoreData groups >>= mkDirectoryStore_ (Just h) where - addGroupRegData (!grs, !listed, !reserved) gr@GroupRegData {dbGroupId_ = gId} = do + addGroupRegData d gr@GroupRegData {dbGroupId_ = gId} = do gr' <- dataToGroupReg gr - let grs' = gr' : grs + let !grs' = gr' : groupRegs_ d pure $ case grDirectoryStatus $ groupRegStatus_ gr of - DSListed -> (grs', S.insert gId listed, reserved) - DSReserved -> (grs', listed, S.insert gId reserved) - DSRegistered -> (grs', listed, reserved) - DSRemoved -> (grs, listed, reserved) + DSListed -> + let !listed = S.insert gId $ listedGroups_ d + !promoted = (if promoted_ gr then S.insert gId else id) $ promotedGroups_ d + in d {groupRegs_ = grs', listedGroups_ = listed, promotedGroups_ = promoted} + DSReserved -> + let !reserved = S.insert gId $ reservedGroups_ d + in d {groupRegs_ = grs', reservedGroups_ = reserved} + DSRegistered -> d {groupRegs_ = grs'} + DSRemoved -> d -mkDirectoryStore_ :: Maybe Handle -> ([GroupReg], Set GroupId, Set GroupId) -> IO DirectoryStore -mkDirectoryStore_ h (grs, listed, reserved) = do - groupRegs <- newTVarIO grs - listedGroups <- newTVarIO listed - reservedGroups <- newTVarIO reserved - pure DirectoryStore {groupRegs, listedGroups, reservedGroups, directoryLogFile = h} +mkDirectoryStore_ :: Maybe Handle -> DirectoryStoreData -> IO DirectoryStore +mkDirectoryStore_ h d = do + groupRegs <- newTVarIO $ groupRegs_ d + listedGroups <- newTVarIO $ listedGroups_ d + promotedGroups <- newTVarIO $ promotedGroups_ d + reservedGroups <- newTVarIO $ reservedGroups_ d + pure DirectoryStore {groupRegs, listedGroups, promotedGroups, reservedGroups, directoryLogFile = h} readDirectoryData :: FilePath -> IO [GroupRegData] readDirectoryData f = @@ -429,6 +482,9 @@ readDirectoryData f = GRUpdateStatus gId groupRegStatus_ -> case M.lookup gId m of Just gr -> pure $ M.insert gId gr {groupRegStatus_} m Nothing -> m <$ putStrLn ("Warning: no group with ID " <> show gId <> ", status update ignored.") + GRUpdatePromotion gId promoted_ -> case M.lookup gId m of + Just gr -> pure $ M.insert gId gr {promoted_} m + Nothing -> m <$ putStrLn ("Warning: no group with ID " <> show gId <> ", promotion update ignored.") GRUpdateOwner gId grOwnerId -> case M.lookup gId m of Just gr -> pure $ M.insert gId gr {dbOwnerMemberId_ = Just grOwnerId} m Nothing -> m <$ putStrLn ("Warning: no group with ID " <> show gId <> ", owner update ignored.") diff --git a/apps/simplex-directory-service/src/Directory/Util.hs b/apps/simplex-directory-service/src/Directory/Util.hs new file mode 100644 index 0000000000..379da73003 --- /dev/null +++ b/apps/simplex-directory-service/src/Directory/Util.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Directory.Util where + +import qualified Control.Exception as E +import Control.Logger.Simple +import Control.Monad.Except +import Data.Text (Text) +import Simplex.Chat.Controller +import Simplex.Chat.Store.Shared (StoreError (..)) +import Simplex.Chat.Types +import Simplex.Messaging.Agent.Store.Common (withTransaction) +import qualified Simplex.Messaging.Agent.Store.DB as DB +import Simplex.Messaging.Util (tshow) + +vr :: ChatController -> VersionRangeChat +vr ChatController {config = ChatConfig {chatVRange}} = chatVRange +{-# INLINE vr #-} + +withDB' :: Text -> ChatController -> (DB.Connection -> IO a) -> IO (Maybe a) +withDB' cxt cc a = withDB cxt cc $ ExceptT . fmap Right . a + +withDB :: Text -> ChatController -> (DB.Connection -> ExceptT StoreError IO a) -> IO (Maybe a) +withDB cxt ChatController {chatStore} action = do + r_ :: Either ChatError a <- withTransaction chatStore (runExceptT . withExceptT ChatErrorStore . action) `E.catches` handleDBErrors + case r_ of + Right r -> pure $ Just r + Left e -> Nothing <$ logError ("Database error: " <> cxt <> " " <> tshow e) diff --git a/simplex-chat.cabal b/simplex-chat.cabal index fd8a089193..7a9dd3a92d 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -457,10 +457,12 @@ executable simplex-directory-service Directory.BlockedWords Directory.Captcha Directory.Events + Directory.Listing Directory.Options Directory.Search Directory.Service Directory.Store + Directory.Util Paths_simplex_chat ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -threaded build-depends: @@ -468,9 +470,11 @@ executable simplex-directory-service , async ==2.2.* , attoparsec ==0.14.* , base >=4.7 && <5 + , base64-bytestring >=1.0 && <1.3 , composition ==1.0.* , containers ==0.6.* , directory ==1.3.* + , filepath ==1.4.* , mtl >=2.3.1 && <3.0 , optparse-applicative >=0.15 && <0.17 , process >=1.6 && <1.6.18 @@ -539,10 +543,12 @@ test-suite simplex-chat-test Directory.BlockedWords Directory.Captcha Directory.Events + Directory.Listing Directory.Options Directory.Search Directory.Service Directory.Store + Directory.Util Paths_simplex_chat if flag(client_postgres) other-modules: diff --git a/tests/Bots/DirectoryTests.hs b/tests/Bots/DirectoryTests.hs index 3f59863f25..168fd7bfca 100644 --- a/tests/Bots/DirectoryTests.hs +++ b/tests/Bots/DirectoryTests.hs @@ -12,8 +12,10 @@ import ChatTests.Utils import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Exception (finally) import Control.Monad (forM_, when) +import qualified Data.Aeson as J import qualified Data.Text as T import Directory.Captcha +import Directory.Listing import Directory.Options import Directory.Service import Directory.Store @@ -65,8 +67,8 @@ directoryServiceTests = do it "should prohibit confirmation if a duplicate group is listed" testDuplicateProhibitConfirmation it "should prohibit when profile is updated and not send for approval" testDuplicateProhibitWhenUpdated it "should prohibit approval if a duplicate group is listed" testDuplicateProhibitApproval - describe "list groups" $ do - it "should list user's groups" testListUserGroups + describe "list and promote groups" $ do + it "should list and promote user's groups" $ testListUserGroups True describe "member admission" $ do it "should ask member to pass captcha screen" testCapthaScreening describe "store log" $ do @@ -77,8 +79,8 @@ directoryServiceTests = do directoryProfile :: Profile directoryProfile = Profile {displayName = "SimpleX Directory", fullName = "", shortDescr = Nothing, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences = Nothing} -mkDirectoryOpts :: TestParams -> [KnownContact] -> Maybe KnownGroup -> DirectoryOpts -mkDirectoryOpts TestParams {tmpPath = ps} superUsers ownersGroup = +mkDirectoryOpts :: TestParams -> [KnownContact] -> Maybe KnownGroup -> Maybe FilePath -> DirectoryOpts +mkDirectoryOpts TestParams {tmpPath = ps} superUsers ownersGroup webFolder = DirectoryOpts { coreOptions = testCoreOpts @@ -104,6 +106,7 @@ mkDirectoryOpts TestParams {tmpPath = ps} superUsers ownersGroup = serviceName = "SimpleX Directory", runCLI = False, searchResults = 3, + webFolder, testing = True } @@ -531,7 +534,7 @@ testSearchGroups ps = testInviteToOwnersGroup :: HasCallStack => TestParams -> IO () testInviteToOwnersGroup ps = - withDirectoryServiceCfgOwnersGroup ps testCfg True $ \superUser dsLink -> + withDirectoryServiceCfgOwnersGroup ps testCfg True Nothing $ \superUser dsLink -> withNewTestChatCfg ps testCfg "bob" bobProfile $ \bob -> do bob `connectVia` dsLink registerGroupId superUser bob "privacy" "Privacy" 2 1 @@ -1060,14 +1063,15 @@ testDuplicateProhibitApproval ps = superUser <# ("'SimpleX Directory'> > " <> approve) superUser <## " The group ID 2 (privacy) is already listed in the directory." -testListUserGroups :: HasCallStack => TestParams -> IO () -testListUserGroups ps = - withDirectoryService ps $ \superUser dsLink -> +testListUserGroups :: HasCallStack => Bool -> TestParams -> IO () +testListUserGroups promote ps = + withDirectoryServiceCfgOwnersGroup ps testCfg False (Just "./tests/tmp/web") $ \superUser dsLink -> withNewTestChat ps "bob" bobProfile $ \bob -> withNewTestChat ps "cath" cathProfile $ \cath -> do bob `connectVia` dsLink cath `connectVia` dsLink registerGroup superUser bob "privacy" "Privacy" + checkListings ["privacy"] [] connectUsers bob cath fullAddMember "privacy" "Privacy" bob cath GRMember joinGroup "privacy" cath bob @@ -1075,7 +1079,9 @@ testListUserGroups ps = cath <## "contact and member are merged: 'SimpleX Directory', #privacy 'SimpleX Directory_1'" cath <## "use @'SimpleX Directory' to send messages" registerGroupId superUser bob "security" "Security" 2 2 + checkListings ["privacy", "security"] [] registerGroupId superUser cath "anonymity" "Anonymity" 3 1 + checkListings ["privacy", "security", "anonymity"] [] listUserGroup cath "anonymity" "Anonymity" -- with de-listed group groupFound cath "anonymity" @@ -1085,8 +1091,51 @@ testListUserGroups ps = cath <## "" cath <## "The group is no longer listed in the directory." superUser <# "'SimpleX Directory'> The group ID 3 (anonymity) is de-listed (SimpleX Directory role is changed to member)." + checkListings ["privacy", "security"] [] groupNotFound cath "anonymity" listGroups superUser bob cath + when promote $ do + superUser #> "@'SimpleX Directory' /promote 1:privacy on" + superUser <# "'SimpleX Directory'> > /promote 1:privacy on" + superUser <## " Group promotion enabled." + checkListings ["privacy", "security"] ["privacy"] + bob ##> "/gp privacy privacy" + bob <## "description removed" + bob <# "'SimpleX Directory'> The group ID 1 (privacy) is updated!" + bob <## "It is hidden from the directory until approved." + cath <## "bob updated group #privacy:" + cath <## "description removed" + superUser <# "'SimpleX Directory'> The group ID 1 (privacy) is updated." + superUser <# "'SimpleX Directory'> bob submitted the group ID 1:" + superUser <## "privacy" + superUser <## "Welcome message:" + superUser <##. "Link to join the group privacy: https://localhost/g#" + superUser <## "3 members" + superUser <## "" + superUser <## "To approve send:" + superUser <# "'SimpleX Directory'> /approve 1:privacy 1 promote=on" + checkListings ["security"] [] + superUser #> "@'SimpleX Directory' /approve 1:privacy 1" + superUser <# "'SimpleX Directory'> > /approve 1:privacy 1" + superUser <## " Group approved!" + bob <# "'SimpleX Directory'> The group ID 1 (privacy) is approved and listed in directory - please moderate it!" + bob <## "Please note: if you change the group profile it will be hidden from directory until it is re-approved." + bob <## "" + bob <## "Supported commands:" + bob <## "/'filter 1' - to configure anti-spam filter." + bob <## "/'role 1' - to set default member role." + bob <## "/'link 1' - to view/upgrade group link." + checkListings ["privacy", "security"] ["privacy"] + +checkListings :: [T.Text] -> [T.Text] -> IO () +checkListings listed promoted = do + checkListing listingFileName listed + checkListing promotedFileName promoted + where + checkListing f expected = do + Just (DirectoryListing gs) <- J.decodeFileStrict $ "./tests/tmp/web" f + map groupName gs `shouldBe` expected + groupName DirectoryEntry {displayName} = displayName testCapthaScreening :: HasCallStack => TestParams -> IO () testCapthaScreening ps = @@ -1176,7 +1225,7 @@ testCapthaScreening ps = testRestoreDirectory :: HasCallStack => TestParams -> IO () testRestoreDirectory ps = do - testListUserGroups ps + testListUserGroups False ps restoreDirectoryService ps 3 3 $ \superUser _dsLink -> withTestChat ps "bob" $ \bob -> withTestChat ps "cath" $ \cath -> do @@ -1294,10 +1343,10 @@ withDirectoryService :: HasCallStack => TestParams -> (TestCC -> String -> IO () withDirectoryService ps = withDirectoryServiceCfg ps testCfg withDirectoryServiceCfg :: HasCallStack => TestParams -> ChatConfig -> (TestCC -> String -> IO ()) -> IO () -withDirectoryServiceCfg ps cfg = withDirectoryServiceCfgOwnersGroup ps cfg False +withDirectoryServiceCfg ps cfg = withDirectoryServiceCfgOwnersGroup ps cfg False Nothing -withDirectoryServiceCfgOwnersGroup :: HasCallStack => TestParams -> ChatConfig -> Bool -> (TestCC -> String -> IO ()) -> IO () -withDirectoryServiceCfgOwnersGroup ps cfg createOwnersGroup test = do +withDirectoryServiceCfgOwnersGroup :: HasCallStack => TestParams -> ChatConfig -> Bool -> Maybe FilePath -> (TestCC -> String -> IO ()) -> IO () +withDirectoryServiceCfgOwnersGroup ps cfg createOwnersGroup webFolder test = do dsLink <- withNewTestChatCfg ps cfg serviceDbPrefix directoryProfile $ \ds -> withNewTestChatCfg ps cfg "super_user" aliceProfile $ \superUser -> do @@ -1315,7 +1364,7 @@ withDirectoryServiceCfgOwnersGroup ps cfg createOwnersGroup test = do superUser <## "#owners: 'SimpleX Directory' joined the group" ds ##> "/ad" getContactLink ds True - withDirectoryOwnersGroup ps cfg dsLink createOwnersGroup test + withDirectoryOwnersGroup ps cfg dsLink createOwnersGroup webFolder test restoreDirectoryService :: HasCallStack => TestParams -> Int -> Int -> (TestCC -> String -> IO ()) -> IO () restoreDirectoryService ps ctCount grCount test = do @@ -1332,11 +1381,11 @@ restoreDirectoryService ps ctCount grCount test = do withDirectory ps testCfg dsLink test withDirectory :: HasCallStack => TestParams -> ChatConfig -> String -> (TestCC -> String -> IO ()) -> IO () -withDirectory ps cfg dsLink = withDirectoryOwnersGroup ps cfg dsLink False +withDirectory ps cfg dsLink = withDirectoryOwnersGroup ps cfg dsLink False Nothing -withDirectoryOwnersGroup :: HasCallStack => TestParams -> ChatConfig -> String -> Bool -> (TestCC -> String -> IO ()) -> IO () -withDirectoryOwnersGroup ps cfg dsLink createOwnersGroup test = do - let opts = mkDirectoryOpts ps [KnownContact 2 "alice"] $ if createOwnersGroup then Just $ KnownGroup 1 "owners" else Nothing +withDirectoryOwnersGroup :: HasCallStack => TestParams -> ChatConfig -> String -> Bool -> Maybe FilePath -> (TestCC -> String -> IO ()) -> IO () +withDirectoryOwnersGroup ps cfg dsLink createOwnersGroup webFolder test = do + let opts = mkDirectoryOpts ps [KnownContact 2 "alice"] (if createOwnersGroup then Just $ KnownGroup 1 "owners" else Nothing) webFolder runDirectory cfg opts $ withTestChatCfg ps cfg "super_user" $ \superUser -> do superUser <## "1 contacts connected (use /cs for the list)" From a190d4ea9bfcd6aa71ab2d0de3edd2d06a8e0fa7 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Sat, 20 Sep 2025 19:47:50 +0100 Subject: [PATCH 10/64] website: directory page (#6283) * website: directory page * core: use markdown in directory entries * render markdown on directory page * update markdown * toggle secrets on click * update listings asynchronously * add group links to the listing * cleanup * better directory layout with pagination * script to run website * update page navigation * search * readable markdown colors, better "read less" * core: atomic update of directory listings, to avoid files unavailable * fix symlink, sort entries on page with new first * update listings every 15 min, add activeAt time * fix sorting in the page and listing url * replace simplex:/ links on desktop --- apps/simplex-directory-service/Main.hs | 11 +- .../src/Directory/Listing.hs | 87 +++- .../src/Directory/Search.hs | 8 +- .../src/Directory/Service.hs | 130 ++++-- .../src/Directory/Store.hs | 2 +- bots/api/TYPES.md | 1 + bots/src/API/Docs/Types.hs | 18 +- .../types/typescript/src/types.ts | 1 + simplex-chat.cabal | 2 + src/Simplex/Chat/Controller.hs | 2 +- src/Simplex/Chat/Store.hs | 2 - src/Simplex/Chat/Store/Groups.hs | 24 +- src/Simplex/Chat/Store/Messages.hs | 2 - src/Simplex/Chat/Types.hs | 14 +- src/Simplex/Chat/View.hs | 6 +- tests/Bots/DirectoryTests.hs | 13 +- website/run.sh | 8 + website/src/blog.html | 128 ++--- website/src/directory.html | 272 +++++++++++ website/src/img/group.svg | 12 + website/src/js/directory.js | 439 ++++++++++++++++++ website/src/js/script.js | 3 +- 22 files changed, 994 insertions(+), 191 deletions(-) create mode 100755 website/run.sh create mode 100644 website/src/directory.html create mode 100644 website/src/img/group.svg create mode 100644 website/src/js/directory.js diff --git a/apps/simplex-directory-service/Main.hs b/apps/simplex-directory-service/Main.hs index e2b96f5677..88e7739aa0 100644 --- a/apps/simplex-directory-service/Main.hs +++ b/apps/simplex-directory-service/Main.hs @@ -5,8 +5,6 @@ module Main where import Directory.Options import Directory.Service import Directory.Store -import Simplex.Chat.Controller (ChatConfig (..), ChatHooks (..), defaultChatHooks) -import Simplex.Chat.Core import Simplex.Chat.Terminal (terminalChatConfig) main :: IO () @@ -15,11 +13,4 @@ main = do st <- restoreDirectoryStore directoryLog if runCLI then directoryServiceCLI st opts - else do - env <- newServiceState opts - let chatHooks = - defaultChatHooks - { postStartHook = Just $ directoryStartHook st opts, - acceptMember = Just $ acceptMemberHook opts env - } - simplexChatCore (terminalChatConfig {chatHooks}) (mkChatOpts opts) $ directoryService st opts env + else directoryService st opts terminalChatConfig diff --git a/apps/simplex-directory-service/src/Directory/Listing.hs b/apps/simplex-directory-service/src/Directory/Listing.hs index a05e82285d..b9b50cb87b 100644 --- a/apps/simplex-directory-service/src/Directory/Listing.hs +++ b/apps/simplex-directory-service/src/Directory/Listing.hs @@ -1,9 +1,11 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} module Directory.Listing where @@ -11,23 +13,36 @@ module Directory.Listing where import Control.Applicative ((<|>)) import Control.Concurrent.STM import Control.Monad +import Crypto.Hash (Digest, MD5) +import qualified Crypto.Hash as CH import qualified Data.Aeson as J import qualified Data.Aeson.TH as JQ +import qualified Data.ByteArray as BA import Data.ByteString (ByteString) -import Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Base64.URL as B64URL import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as LB -import Data.Maybe (fromMaybe) +import Data.List (isPrefixOf) +import Data.Maybe (catMaybes, fromMaybe) import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) +import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Time.Format.ISO8601 (iso8601Show) import Directory.Store +import Simplex.Chat.Markdown import Simplex.Chat.Types +import Simplex.Messaging.Agent.Protocol +import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, taggedObjectJSON) import System.Directory import System.FilePath +directoryDataPath :: String +directoryDataPath = "data" + listingFileName :: String listingFileName = "listing.json" @@ -47,9 +62,12 @@ $(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "DET") ''DirectoryEntryType) data DirectoryEntry = DirectoryEntry { entryType :: DirectoryEntryType, displayName :: Text, - shortDescr :: Maybe Text, - welcomeMessage :: Maybe Text, - imageFile :: Maybe String + groupLink :: CreatedLinkContact, + shortDescr :: Maybe MarkdownList, + welcomeMessage :: Maybe MarkdownList, + imageFile :: Maybe String, + activeAt :: UTCTime, + createdAt :: UTCTime } $(JQ.deriveJSON defaultJSON ''DirectoryEntry) @@ -60,38 +78,67 @@ $(JQ.deriveJSON defaultJSON ''DirectoryListing) type ImageFileData = ByteString -groupDirectoryEntry :: GroupInfoSummary -> (DirectoryEntry, Maybe (FilePath, ImageFileData)) -groupDirectoryEntry (GIS GroupInfo {groupId, groupProfile} summary) = +groupDirectoryEntry :: GroupInfoSummary -> Maybe (DirectoryEntry, Maybe (FilePath, ImageFileData)) +groupDirectoryEntry (GIS GroupInfo {groupProfile, chatTs, createdAt} summary gLink_) = let GroupProfile {displayName, shortDescr, description, image, memberAdmission} = groupProfile entryType = DETGroup memberAdmission summary - imgData = imgFileData =<< image - in (DirectoryEntry {entryType, displayName, shortDescr, welcomeMessage = description, imageFile = fst <$> imgData}, imgData) + entry groupLink = + let de = + DirectoryEntry + { entryType, + displayName, + groupLink, + shortDescr = toFormattedText <$> shortDescr, + welcomeMessage = toFormattedText <$> description, + imageFile = fst <$> imgData, + activeAt = fromMaybe createdAt chatTs, + createdAt + } + imgData = imgFileData groupLink =<< image + in (de, imgData) + in (entry . connLinkContact) <$> gLink_ where - imgFileData (ImageData img) = + imgFileData :: CreatedConnLink 'CMContact -> ImageData -> Maybe (FilePath, ByteString) + imgFileData groupLink (ImageData img) = let (img', imgExt) = fromMaybe (img, ".jpg") $ (,".jpg") <$> T.stripPrefix "data:image/jpg;base64," img <|> (,".png") <$> T.stripPrefix "data:image/png;base64," img - imgFile = listingImageFolder show groupId <> imgExt + imgName = B.unpack $ B64URL.encodeUnpadded $ BA.convert $ (CH.hash :: ByteString -> Digest MD5) $ strEncode (connFullLink groupLink) + imgFile = listingImageFolder imgName <> imgExt in case B64.decode $ encodeUtf8 img' of Right img'' -> Just (imgFile, img'') Left _ -> Nothing generateListing :: DirectoryStore -> FilePath -> [GroupInfoSummary] -> IO () generateListing st dir gs = do + createDirectoryIfMissing True dir + oldDirs <- filter ((directoryDataPath <> ".") `isPrefixOf`) <$> listDirectory dir + ts <- getCurrentTime + let newDirPath = directoryDataPath <> "." <> iso8601Show ts <> "/" + newDir = dir newDirPath gs' <- filterListedGroups st gs - removePathForcibly (dir listingImageFolder) - createDirectoryIfMissing True (dir listingImageFolder) - gs'' <- forM gs' $ \g@(GIS GroupInfo {groupId} _) -> do - let (g', img) = groupDirectoryEntry g - forM_ img $ \(imgFile, imgData) -> B.writeFile (dir imgFile) imgData - pure (groupId, g') - saveListing listingFileName gs'' - saveListing promotedFileName =<< filterPromotedGroups st gs'' + createDirectoryIfMissing True (newDir listingImageFolder) + gs'' <- + fmap catMaybes $ forM gs' $ \g@(GIS GroupInfo {groupId} _ _) -> + forM (groupDirectoryEntry g) $ \(g', img) -> do + forM_ img $ \(imgFile, imgData) -> B.writeFile (newDir imgFile) imgData + pure (groupId, g') + saveListing newDir listingFileName gs'' + saveListing newDir promotedFileName =<< filterPromotedGroups st gs'' + -- atomically update the link + let newSymLink = newDir <> ".link" + symLink = dir directoryDataPath + createDirectoryLink newDirPath newSymLink + renamePath newSymLink symLink + mapM_ (removePathForcibly . (dir )) oldDirs where - saveListing f = LB.writeFile (dir f) . J.encode . DirectoryListing . map snd + saveListing newDir f = LB.writeFile (newDir f) . J.encode . DirectoryListing . map snd filterPromotedGroups :: DirectoryStore -> [(GroupId, DirectoryEntry)] -> IO [(GroupId, DirectoryEntry)] filterPromotedGroups st gs = do pgs <- readTVarIO $ promotedGroups st pure $ filter (\g -> fst g `S.member` pgs) gs + +toFormattedText :: Text -> MarkdownList +toFormattedText t = fromMaybe [FormattedText Nothing t] $ parseMaybeMarkdownList t diff --git a/apps/simplex-directory-service/src/Directory/Search.hs b/apps/simplex-directory-service/src/Directory/Search.hs index 5b0d650444..2d4cbf9c7b 100644 --- a/apps/simplex-directory-service/src/Directory/Search.hs +++ b/apps/simplex-directory-service/src/Directory/Search.hs @@ -20,13 +20,13 @@ data SearchRequest = SearchRequest data SearchType = STAll | STRecent | STSearch Text takeTop :: Int -> [GroupInfoSummary] -> [GroupInfoSummary] -takeTop n = take n . sortOn (\(GIS _ GroupSummary {currentMembers}) -> Down currentMembers) +takeTop n = take n . sortOn (\(GIS _ GroupSummary {currentMembers} _) -> Down currentMembers) takeRecent :: Int -> [GroupInfoSummary] -> [GroupInfoSummary] -takeRecent n = take n . sortOn (\(GIS GroupInfo {createdAt} _) -> Down createdAt) +takeRecent n = take n . sortOn (\(GIS GroupInfo {createdAt} _ _) -> Down createdAt) groupIds :: [GroupInfoSummary] -> Set GroupId -groupIds = S.fromList . map (\(GIS GroupInfo {groupId} _) -> groupId) +groupIds = S.fromList . map (\(GIS GroupInfo {groupId} _ _) -> groupId) filterNotSent :: Set GroupId -> [GroupInfoSummary] -> [GroupInfoSummary] -filterNotSent sentGroups = filter (\(GIS GroupInfo {groupId} _) -> groupId `S.notMember` sentGroups) +filterNotSent sentGroups = filter (\(GIS GroupInfo {groupId} _ _) -> groupId `S.notMember` sentGroups) diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index 7bbe4e43a4..b7f1bb3629 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/apps/simplex-directory-service/src/Directory/Service.hs @@ -21,7 +21,6 @@ module Directory.Service where import Control.Concurrent (forkIO) -import Control.Concurrent.Async import Control.Concurrent.STM import Control.Logger.Simple import Control.Monad @@ -54,7 +53,6 @@ import Simplex.Chat.Markdown (Format (..), FormattedText (..), parseMaybeMarkdow import Simplex.Chat.Messages import Simplex.Chat.Options import Simplex.Chat.Protocol (MsgContent (..)) -import Simplex.Chat.Store (GroupLink (..)) import Simplex.Chat.Store.Direct (getContact) import Simplex.Chat.Store.Groups (getGroupInfo, getGroupLink, getGroupSummary, getUserGroupsWithSummary, setGroupCustomData) import Simplex.Chat.Store.Profiles (GroupLinkInfo (..), getGroupLinkInfo) @@ -69,7 +67,7 @@ import Simplex.Messaging.Agent.Protocol (AConnectionLink (..), ConnectionLink (. import Simplex.Messaging.Encoding.String import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM -import Simplex.Messaging.Util (safeDecodeUtf8, tshow, unlessM, whenM, ($>>=), (<$$>)) +import Simplex.Messaging.Util (raceAny_, safeDecodeUtf8, tshow, unlessM, whenM, ($>>=), (<$$>)) import System.Directory (getAppUserDataDirectory) import System.Exit (exitFailure) import System.Process (readProcess) @@ -96,7 +94,8 @@ data GroupRolesStatus data ServiceState = ServiceState { searchRequests :: TMap ContactId SearchRequest, blockedWordsCfg :: BlockedWordsConfig, - pendingCaptchas :: TMap GroupMemberId PendingCaptcha + pendingCaptchas :: TMap GroupMemberId PendingCaptcha, + updateListingsJob :: TMVar ChatController } data PendingCaptcha = PendingCaptcha @@ -119,7 +118,8 @@ newServiceState opts = do searchRequests <- TM.emptyIO blockedWordsCfg <- readBlockedWordsConfig opts pendingCaptchas <- TM.emptyIO - pure ServiceState {searchRequests, blockedWordsCfg, pendingCaptchas} + updateListingsJob <- newEmptyTMVarIO + pure ServiceState {searchRequests, blockedWordsCfg, pendingCaptchas, updateListingsJob} welcomeGetOpts :: IO DirectoryOpts welcomeGetOpts = do @@ -146,22 +146,41 @@ directoryServiceCLI st opts = do env <- newServiceState opts eventQ <- newTQueueIO let eventHook cc resp = atomically $ resp <$ writeTQueue eventQ (cc, resp) - chatHooks = defaultChatHooks {postStartHook = Just $ directoryStartHook st opts, eventHook = Just eventHook, acceptMember = Just $ acceptMemberHook opts env} - race_ - (simplexChatCLI' terminalChatConfig {chatHooks} (mkChatOpts opts) Nothing) - (processEvents eventQ env) + chatHooks = defaultChatHooks {postStartHook = Just $ directoryStartHook opts env, eventHook = Just eventHook, acceptMember = Just $ acceptMemberHook opts env} + raceAny_ $ + [ simplexChatCLI' terminalChatConfig {chatHooks} (mkChatOpts opts) Nothing, + processEvents eventQ env + ] + <> updateListingsThread_ st opts env where processEvents eventQ env = forever $ do (cc, resp) <- atomically $ readTQueue eventQ u_ <- readTVarIO (currentUser cc) forM_ u_ $ \user -> directoryServiceEvent st opts env user cc resp -directoryStartHook :: DirectoryStore -> DirectoryOpts -> ChatController -> IO () -directoryStartHook st opts cc = +updateListingDelay :: Int +updateListingDelay = 15 * 60 * 1000000 -- update every 15 minutes + +updateListingsThread_ :: DirectoryStore -> DirectoryOpts -> ServiceState -> [IO ()] +updateListingsThread_ st opts env = maybe [] (\f -> [updateListingsThread f]) $ webFolder opts + where + updateListingsThread f = do + cc <- atomically $ takeTMVar $ updateListingsJob env + forever $ do + u <- readTVarIO $ currentUser cc + forM_ u $ \user -> updateGroupListingFiles cc st user f + delay <- registerDelay updateListingDelay + atomically $ void (takeTMVar $ updateListingsJob env) `orElse` unlessM (readTVar delay) retry + +listingsUpdated :: ServiceState -> ChatController -> IO () +listingsUpdated env = void . atomically . tryPutTMVar (updateListingsJob env) + +directoryStartHook :: DirectoryOpts -> ServiceState -> ChatController -> IO () +directoryStartHook opts env cc = readTVarIO (currentUser cc) >>= \case Nothing -> putStrLn "No current user" >> exitFailure - Just user@User {userId, profile = p@LocalProfile {preferences}} -> do - forM_ (webFolder opts) $ updateGroupListingFiles cc st user + Just User {userId, profile = p@LocalProfile {preferences}} -> do + listingsUpdated env cc let cmds = fromMaybe [] $ preferences >>= commands_ unless (cmds == directoryCommands) $ do let prefs = (fromMaybe emptyChatPrefs preferences) {files = Just FilesPreference {allow = FANo}, commands = Just directoryCommands} :: Preferences @@ -188,12 +207,23 @@ directoryCommands = where idParam = Just "" -directoryService :: DirectoryStore -> DirectoryOpts -> ServiceState -> User -> ChatController -> IO () -directoryService st opts@DirectoryOpts {testing} env user cc = do - initializeBotAddress' (not testing) cc - race_ (forever $ void getLine) . forever $ do - (_, resp) <- atomically . readTBQueue $ outputQ cc - directoryServiceEvent st opts env user cc resp +directoryService :: DirectoryStore -> DirectoryOpts -> ChatConfig -> IO () +directoryService st opts@DirectoryOpts {testing} cfg = do + env <- newServiceState opts + let chatHooks = + defaultChatHooks + { postStartHook = Just $ directoryStartHook opts env, + acceptMember = Just $ acceptMemberHook opts env + } + simplexChatCore cfg {chatHooks} (mkChatOpts opts) $ \user cc -> do + initializeBotAddress' (not testing) cc + raceAny_ $ + [ forever $ void getLine, + forever $ do + (_, resp) <- atomically . readTBQueue $ outputQ cc + directoryServiceEvent st opts env user cc resp + ] + <> updateListingsThread_ st opts env acceptMemberHook :: DirectoryOpts -> ServiceState -> GroupInfo -> GroupLinkInfo -> Profile -> IO (Either GroupRejectionReason (GroupAcceptance, GroupMemberRole)) acceptMemberHook @@ -301,7 +331,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName getDuplicateGroup GroupInfo {groupId, groupProfile = GroupProfile {displayName, fullName}} = getGroups fullName >>= mapM duplicateGroup where - sameGroupNotRemoved (GIS g@GroupInfo {groupId = gId, groupProfile = GroupProfile {displayName = n, fullName = fn}} _) = + sameGroupNotRemoved (GIS g@GroupInfo {groupId = gId, groupProfile = GroupProfile {displayName = n, fullName = fn}} _ _) = gId /= groupId && n == displayName && fn == fullName && not (memberRemoved $ membership g) duplicateGroup [] = pure DGUnique duplicateGroup groups = do @@ -310,13 +340,13 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName then pure DGUnique else do (lgs, rgs) <- atomically $ (,) <$> readTVar (listedGroups st) <*> readTVar (reservedGroups st) - let reserved = any (\(GIS GroupInfo {groupId = gId} _) -> gId `S.member` lgs || gId `S.member` rgs) gs + let reserved = any (\(GIS GroupInfo {groupId = gId} _ _) -> gId `S.member` lgs || gId `S.member` rgs) gs if reserved then pure DGReserved else do removed <- foldM (\r -> fmap (r &&) . isGroupRemoved) True gs pure $ if removed then DGUnique else DGRegistered - isGroupRemoved (GIS GroupInfo {groupId = gId} _) = + isGroupRemoved (GIS GroupInfo {groupId = gId} _ _) = getGroupReg st gId >>= \case Just GroupReg {groupRegStatus} -> groupRemoved <$> readTVarIO groupRegStatus Nothing -> pure True @@ -395,7 +425,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName notifyOwner gr $ "Joined the group " <> displayName <> ", creating the link…" sendChatCmd cc (APICreateGroupLink groupId GRMember) >>= \case Right CRGroupLinkCreated {groupLink = GroupLink {connLinkContact = gLink}} -> do - setGroupStatus st opts cc user gr GRSPendingUpdate + setGroupStatus st env cc gr GRSPendingUpdate notifyOwner gr "Created the public link to join the group via this directory service that is always online.\n\n\ @@ -456,7 +486,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName Just DGReserved -> notifyOwner gr $ groupAlreadyListed toGroup _ -> do let gaId = 1 - setGroupStatus st opts cc user gr $ GRSPendingApproval gaId + setGroupStatus st env cc gr $ GRSPendingApproval gaId notifyOwner gr $ ("Thank you! The group link for " <> userGroupReference gr toGroup <> " is added to the welcome message" <> byMember) <> ".\nYou will be notified once the group is added to the directory - it may take up to 48 hours." @@ -466,18 +496,18 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName groupRef = groupReference toGroup groupProfileUpdate >>= \case GPNoServiceLink -> do - setGroupStatus st opts cc user gr GRSPendingUpdate + setGroupStatus st env cc gr GRSPendingUpdate notifyOwner gr $ ("The group profile is updated for " <> userGroupRef <> byMember <> ", but no link is added to the welcome message.\n\n") <> "The group will remain hidden from the directory until the group link is added and the group is re-approved." GPServiceLinkRemoved -> do - setGroupStatus st opts cc user gr GRSPendingUpdate + setGroupStatus st env cc gr GRSPendingUpdate notifyOwner gr $ ("The group link for " <> userGroupRef <> " is removed from the welcome message" <> byMember) <> ".\n\nThe group is hidden from the directory until the group link is added and the group is re-approved." notifyAdminUsers $ "The group link is removed from " <> groupRef <> ", de-listed." GPServiceLinkAdded _ -> do - setGroupStatus st opts cc user gr $ GRSPendingApproval n' + setGroupStatus st env cc gr $ GRSPendingApproval n' notifyOwner gr $ ("The group link is added to " <> userGroupRef <> byMember) <> "!\nIt is hidden from the directory until approved." @@ -490,7 +520,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName <> "!\nThe group is listed in directory." notifyAdminUsers $ "The group " <> groupRef <> " is updated" <> byMember <> " - only link or whitespace changes.\nThe group remained listed in directory." | otherwise -> do - setGroupStatus st opts cc user gr $ GRSPendingApproval n' + setGroupStatus st env cc gr $ GRSPendingApproval n' notifyOwner gr $ ("The group " <> userGroupRef <> " is updated" <> byMember) <> "!\nIt is hidden from the directory until approved." @@ -628,14 +658,14 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName when (ctId `isOwner` gr) $ do readTVarIO (groupRegStatus gr) >>= \case GRSSuspendedBadRoles -> when (rStatus == GRSOk) $ do - setGroupStatus st opts cc user gr GRSActive + setGroupStatus st env cc gr GRSActive notifyOwner gr $ uCtRole <> ".\n\nThe group is listed in the directory again." notifyAdminUsers $ "The group " <> groupRef <> " is listed " <> suCtRole GRSPendingApproval gaId -> when (rStatus == GRSOk) $ do sendToApprove g gr gaId notifyOwner gr $ uCtRole <> ".\n\nThe group is submitted for approval." GRSActive -> when (rStatus /= GRSOk) $ do - setGroupStatus st opts cc user gr GRSSuspendedBadRoles + setGroupStatus st env cc gr GRSSuspendedBadRoles notifyOwner gr $ uCtRole <> ".\n\nThe group is no longer listed in the directory." notifyAdminUsers $ "The group " <> groupRef <> " is de-listed " <> suCtRole _ -> pure () @@ -654,7 +684,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName readTVarIO (groupRegStatus gr) >>= \case GRSSuspendedBadRoles -> when (serviceRole == GRAdmin) $ whenContactIsOwner gr $ do - setGroupStatus st opts cc user gr GRSActive + setGroupStatus st env cc gr GRSActive notifyOwner gr $ uSrvRole <> ".\n\nThe group is listed in the directory again." notifyAdminUsers $ "The group " <> groupRef <> " is listed " <> suSrvRole GRSPendingApproval gaId -> when (serviceRole == GRAdmin) $ @@ -662,7 +692,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName sendToApprove g gr gaId notifyOwner gr $ uSrvRole <> ".\n\nThe group is submitted for approval." GRSActive -> when (serviceRole /= GRAdmin) $ do - setGroupStatus st opts cc user gr GRSSuspendedBadRoles + setGroupStatus st env cc gr GRSSuspendedBadRoles notifyOwner gr $ uSrvRole <> ".\n\nThe group is no longer listed in the directory." notifyAdminUsers $ "The group " <> groupRef <> " is de-listed " <> suSrvRole _ -> pure () @@ -679,7 +709,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName logInfo $ "contact ID " <> tshow ctId <> " removed from group " <> viewGroupName g withGroupReg g "contact removed" $ \gr -> do when (ctId `isOwner` gr) $ do - setGroupStatus st opts cc user gr GRSRemoved + setGroupStatus st env cc gr GRSRemoved notifyOwner gr $ "You are removed from the group " <> userGroupReference gr g <> ".\n\nThe group is no longer listed in the directory." notifyAdminUsers $ "The group " <> groupReference g <> " is de-listed (group owner is removed)." @@ -688,7 +718,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName logInfo $ "contact ID " <> tshow ctId <> " left group " <> viewGroupName g withGroupReg g "contact left" $ \gr -> do when (ctId `isOwner` gr) $ do - setGroupStatus st opts cc user gr GRSRemoved + setGroupStatus st env cc gr GRSRemoved notifyOwner gr $ "You left the group " <> userGroupReference gr g <> ".\n\nThe group is no longer listed in the directory." notifyAdminUsers $ "The group " <> groupReference g <> " is de-listed (group owner left)." @@ -696,7 +726,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName deServiceRemovedFromGroup g = do logInfo $ "service removed from group " <> viewGroupName g withGroupReg g "service removed" $ \gr -> do - setGroupStatus st opts cc user gr GRSRemoved + setGroupStatus st env cc gr GRSRemoved notifyOwner gr $ serviceName <> " is removed from the group " <> userGroupReference gr g <> ".\n\nThe group is no longer listed in the directory." notifyAdminUsers $ "The group " <> groupReference g <> " is de-listed (directory service is removed)." @@ -704,7 +734,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName deGroupDeleted g = do logInfo $ "group removed " <> viewGroupName g withGroupReg g "group removed" $ \gr -> do - setGroupStatus st opts cc user gr GRSRemoved + setGroupStatus st env cc gr GRSRemoved notifyOwner gr $ "The group " <> userGroupReference gr g <> " is deleted.\n\nThe group is no longer listed in the directory." notifyAdminUsers $ "The group " <> groupReference g <> " is de-listed (group is deleted)." @@ -925,7 +955,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName where msgs = replyMsg :| map foundGroup gs <> [moreMsg | moreGroups > 0] replyMsg = (Just ciId, MCText reply) - foundGroup (GIS GroupInfo {groupId, groupProfile = p@GroupProfile {image = image_}} GroupSummary {currentMembers}) = + foundGroup (GIS GroupInfo {groupId, groupProfile = p@GroupProfile {image = image_}} GroupSummary {currentMembers} _) = let membersStr = "_" <> tshow currentMembers <> " members_" showId = if isAdmin then tshow groupId <> ". " else "" text = showId <> groupInfoText p <> "\n" <> membersStr @@ -946,16 +976,16 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName _ -> do getGroupRolesStatus g gr >>= \case Just GRSOk -> do - setGroupStatus st opts cc user gr GRSActive + setGroupStatus st env cc gr GRSActive forM_ promote $ \promo -> if promo -- admins can unpromote, only super-user can promote when approving then unlessM (readTVarIO promoted) $ if knownCt `elem` superUsers - then setGroupPromoted st opts cc user gr True + then setGroupPromoted st env cc gr True else sendReply "You cannot promote groups" else do - whenM (readTVarIO promoted) $ setGroupPromoted st opts cc user gr False + whenM (readTVarIO promoted) $ setGroupPromoted st env cc gr False notifyOtherSuperUsers $ "Group promotion is disabled for " <> groupRef let approved = "The group " <> userGroupReference' gr n <> " is approved" notifyOwner gr $ @@ -991,7 +1021,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName withGroupAndReg sendReply groupId gName $ \_ gr -> readTVarIO (groupRegStatus gr) >>= \case GRSActive -> do - setGroupStatus st opts cc user gr GRSSuspended + setGroupStatus st env cc gr GRSSuspended let suspended = "The group " <> userGroupReference' gr gName <> " is suspended" notifyOwner gr $ suspended <> " and hidden from directory. Please contact the administrators." sendReply "Group suspended!" @@ -1002,7 +1032,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName withGroupAndReg sendReply groupId gName $ \_ gr -> readTVarIO (groupRegStatus gr) >>= \case GRSSuspended -> do - setGroupStatus st opts cc user gr GRSActive + setGroupStatus st env cc gr GRSActive let groupStr = "The group " <> userGroupReference' gr gName notifyOwner gr $ groupStr <> " is listed in the directory again!" sendReply "Group listing resumed!" @@ -1078,7 +1108,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName withGroupAndReg sendReply groupId gName $ \_ gr@GroupReg {groupRegStatus, promoted} -> do status <- readTVarIO groupRegStatus promote <- readTVarIO promoted - when (promote' /= promote) $ setGroupPromoted st opts cc user gr promote' + when (promote' /= promote) $ setGroupPromoted st env cc gr promote' let msg = "Group promotion " <> (if promote' then "enabled" <> (if status == GRSActive then "." else ", but the group is not listed.") else "disabled.") @@ -1132,18 +1162,16 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName let text = T.unlines $ [tshow useGroupId <> ". Error: getGroup. Please notify the developers."] <> maybeToList ownerStr_ <> [statusStr] sendComposedMessage cc ct Nothing $ MCText text -setGroupStatus :: DirectoryStore -> DirectoryOpts -> ChatController -> User -> GroupReg -> GroupRegStatus -> IO () -setGroupStatus st opts cc u gr grStatus' = do +setGroupStatus :: DirectoryStore -> ServiceState -> ChatController -> GroupReg -> GroupRegStatus -> IO () +setGroupStatus st env cc gr grStatus' = do let status' = grDirectoryStatus grStatus' status <- setGroupStatusStore st gr grStatus' - forM_ (webFolder opts) $ \dir -> - when ((status == DSListed || status' == DSListed) && status /= status') $ updateGroupListingFiles cc st u dir + when ((status == DSListed || status' == DSListed) && status /= status') $ listingsUpdated env cc -setGroupPromoted :: DirectoryStore -> DirectoryOpts -> ChatController -> User -> GroupReg -> Bool -> IO () -setGroupPromoted st opts cc u gr grPromoted' = do +setGroupPromoted :: DirectoryStore -> ServiceState -> ChatController -> GroupReg -> Bool -> IO () +setGroupPromoted st env cc gr grPromoted' = do (status, grPromoted) <- setGroupPromotedStore st gr grPromoted' - forM_ (webFolder opts) $ \dir -> - when (status == DSListed && grPromoted' /= grPromoted) $ updateGroupListingFiles cc st u dir + when (status == DSListed && grPromoted' /= grPromoted) $ listingsUpdated env cc updateGroupListingFiles :: ChatController -> DirectoryStore -> User -> FilePath -> IO () updateGroupListingFiles cc st u dir = diff --git a/apps/simplex-directory-service/src/Directory/Store.hs b/apps/simplex-directory-service/src/Directory/Store.hs index 16f047202f..1c8e1a24b5 100644 --- a/apps/simplex-directory-service/src/Directory/Store.hs +++ b/apps/simplex-directory-service/src/Directory/Store.hs @@ -273,7 +273,7 @@ getUserGroupRegs st ctId = filter ((ctId ==) . dbContactId) <$> readTVarIO (grou filterListedGroups :: DirectoryStore -> [GroupInfoSummary] -> IO [GroupInfoSummary] filterListedGroups st gs = do lgs <- readTVarIO $ listedGroups st - pure $ filter (\(GIS GroupInfo {groupId} _) -> groupId `S.member` lgs) gs + pure $ filter (\(GIS GroupInfo {groupId} _ _) -> groupId `S.member` lgs) gs listGroup :: DirectoryStore -> GroupReg -> STM () listGroup st gr = do diff --git a/bots/api/TYPES.md b/bots/api/TYPES.md index f20c7c4913..6207b1bf64 100644 --- a/bots/api/TYPES.md +++ b/bots/api/TYPES.md @@ -2159,6 +2159,7 @@ MemberSupport: **Record type**: - groupInfo: [GroupInfo](#groupinfo) - groupSummary: [GroupSummary](#groupsummary) +- groupLink: [GroupLink](#grouplink)? --- diff --git a/bots/src/API/Docs/Types.hs b/bots/src/API/Docs/Types.hs index 83675798af..d74f6d37dd 100644 --- a/bots/src/API/Docs/Types.hs +++ b/bots/src/API/Docs/Types.hs @@ -29,7 +29,6 @@ import Simplex.Chat.Messages import Simplex.Chat.Messages.CIContent import Simplex.Chat.Messages.CIContent.Events import Simplex.Chat.Protocol -import Simplex.Chat.Store.Groups import Simplex.Chat.Store.Profiles import Simplex.Chat.Store.Shared import Simplex.Chat.Types @@ -69,7 +68,7 @@ chatTypesDocs = sortOn docTypeName $! snd $! mapAccumL toCTDoc (S.empty, M.empty let (tds', td_) = toTypeDef tds sumTypeInfo in case td_ of Just typeDef -> (tds', CTDoc {typeDef, typeSyntax, typeDescr}) - Nothing -> error $ "Recursive type: " <> typeName + Nothing -> error $ "Recursive type: " <> typeName toTypeDef :: (S.Set String, M.Map String APITypeDef) -> (SumTypeInfo, SumTypeJsonEncoding, String, [ConsName], Expr, Text) -> ((S.Set String, M.Map String APITypeDef), Maybe APITypeDef) toTypeDef acc@(!visited, !typeDefs) (STI typeName allConstrs, jsonEncoding, consPrefix, hideConstrs, _, _) = @@ -84,7 +83,7 @@ toTypeDef acc@(!visited, !typeDefs) (STI typeName allConstrs, jsonEncoding, cons let fields = fromMaybe (error $ "Record type without fields: " <> typeName) $ L.nonEmpty fieldInfos ((visited', typeDefs'), fields') = mapAccumL (toAPIField_ typeName) (S.insert typeName visited, typeDefs) fields td = APITypeDef typeName $ ATDRecord $ L.toList fields' - in ((S.insert typeName visited', M.insert typeName td typeDefs'), Just td) + in ((S.insert typeName visited', M.insert typeName td typeDefs'), Just td) _ -> error $ "Record type with " <> show (length constrs) <> " constructors: " <> typeName STUnion -> if length constrs > 1 then toUnionType constrs else unionError constrs STUnion1 -> if length constrs == 1 then toUnionType constrs else unionError constrs @@ -98,16 +97,16 @@ toTypeDef acc@(!visited, !typeDefs) (STI typeName allConstrs, jsonEncoding, cons toUnionType constrs = let ((visited', typeDefs'), members) = mapAccumL toUnionMember (S.insert typeName visited, typeDefs) $ fromMaybe (unionError constrs) $ L.nonEmpty constrs td = APITypeDef typeName $ ATDUnion members - in ((S.insert typeName visited', M.insert typeName td typeDefs'), Just td) + in ((S.insert typeName visited', M.insert typeName td typeDefs'), Just td) toUnionMember tds RecordTypeInfo {consName, fieldInfos} = let memberTag = normalizeConsName consPrefix consName - in second (ATUnionMember memberTag) $ mapAccumL (toAPIField_ typeName) tds fieldInfos + in second (ATUnionMember memberTag) $ mapAccumL (toAPIField_ typeName) tds fieldInfos unionError constrs = error $ "Union type with " <> show (length constrs) <> " constructor(s): " <> typeName toEnumType = toEnumType_ $ normalizeConsName consPrefix toEnumType_ f constrs = let members = L.map toEnumMember $ fromMaybe (enumError constrs) $ L.nonEmpty constrs td = APITypeDef typeName $ ATDEnum members - in ((S.insert typeName visited, M.insert typeName td typeDefs), Just td) + in ((S.insert typeName visited, M.insert typeName td typeDefs), Just td) where toEnumMember RecordTypeInfo {consName, fieldInfos} = case fieldInfos of [] -> f consName @@ -121,7 +120,7 @@ toAPIField_ typeName tds (FieldInfo fieldName typeInfo) = second (APIRecordField toAPIType = \case TIType (ST name _) -> apiTypeForName name TIOptional tInfo -> second ATOptional $ toAPIType tInfo - TIArray {elemType, nonEmpty} -> second (`ATArray`nonEmpty) $ toAPIType elemType + TIArray {elemType, nonEmpty} -> second (`ATArray` nonEmpty) $ toAPIType elemType TIMap {keyType = ST name _, valueType} | name `elem` primitiveTypes -> second (ATMap (PT name)) $ toAPIType valueType | otherwise -> error $ "Non-primitive key type in " <> typeName <> ", " <> fieldName @@ -133,7 +132,7 @@ toAPIField_ typeName tds (FieldInfo fieldName typeInfo) = second (APIRecordField Nothing -> case find (\(STI name' _, _, _, _, _, _) -> name == name') chatTypesDocsData of Just sumTypeInfo -> let (tds', td_) = toTypeDef tds sumTypeInfo -- recursion to outer function, loops are resolved via type defs map lookup - in case td_ of + in case td_ of Just td -> (tds', ATDef td) Nothing -> (tds', ATRef name) Nothing -> error $ "Undefined type: " <> name @@ -352,7 +351,6 @@ chatTypesDocsData = (sti @XFTPErrorType, STUnion, "", [], "", ""), (sti @XFTPRcvFile, STRecord, "", [], "", ""), (sti @XFTPSndFile, STRecord, "", [], "", "") - -- (sti @DatabaseError, STUnion, "DB", [], "", ""), -- (sti @ChatItemInfo, STRecord, "", [], "", ""), -- (sti @ChatItemVersion, STRecord, "", [], "", ""), @@ -371,7 +369,7 @@ chatTypesDocsData = -- (sti @SendRef, STRecord, "", [], "", ""), -- (sti @SndQueueInfo, STRecord, "", [], "", ""), -- (sti @SndSwitchStatus, STEnum, "", [], "", ""), -- incorrect - ] + ] data SimplePreference = SimplePreference {allow :: FeatureAllowed} deriving (Generic) diff --git a/packages/simplex-chat-client/types/typescript/src/types.ts b/packages/simplex-chat-client/types/typescript/src/types.ts index bdc99ee750..97bc45f3ce 100644 --- a/packages/simplex-chat-client/types/typescript/src/types.ts +++ b/packages/simplex-chat-client/types/typescript/src/types.ts @@ -2451,6 +2451,7 @@ export interface GroupInfo { export interface GroupInfoSummary { groupInfo: GroupInfo groupSummary: GroupSummary + groupLink?: GroupLink } export interface GroupLink { diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 7a9dd3a92d..529873b7d3 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -473,8 +473,10 @@ executable simplex-directory-service , base64-bytestring >=1.0 && <1.3 , composition ==1.0.* , containers ==0.6.* + , crypton ==0.34.* , directory ==1.3.* , filepath ==1.4.* + , memory ==0.18.* , mtl >=2.3.1 && <3.0 , optparse-applicative >=0.15 && <0.17 , process >=1.6 && <1.6.18 diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 0b2f16ad1d..45fd264afc 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -62,7 +62,7 @@ import Simplex.Chat.Protocol import Simplex.Chat.Remote.AppVersion import Simplex.Chat.Remote.Types import Simplex.Chat.Stats (PresentedServersSummary) -import Simplex.Chat.Store (AddressSettings, ChatLockEntity, GroupLink, GroupLinkInfo, StoreError (..), UserContactLink, UserMsgReceiptSettings) +import Simplex.Chat.Store (AddressSettings, ChatLockEntity, GroupLinkInfo, StoreError (..), UserContactLink, UserMsgReceiptSettings) import Simplex.Chat.Types import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Shared diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index e80037be74..e81ec0cc3a 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -6,7 +6,6 @@ module Simplex.Chat.Store ChatLockEntity (..), UserMsgReceiptSettings (..), UserContactLink (..), - GroupLink (..), GroupLinkInfo (..), AddressSettings (..), AutoAccept (..), @@ -16,7 +15,6 @@ module Simplex.Chat.Store ) where -import Simplex.Chat.Store.Groups (GroupLink (..)) import Simplex.Chat.Store.Profiles import Simplex.Chat.Store.Shared import Simplex.Messaging.Agent.Store.Common (DBStore (..), withTransaction) diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index 3d8bdead72..7e9d7b4ae2 100644 --- a/src/Simplex/Chat/Store/Groups.hs +++ b/src/Simplex/Chat/Store/Groups.hs @@ -18,7 +18,6 @@ module Simplex.Chat.Store.Groups GroupInfoRow, GroupMemberRow, MaybeGroupMemberRow, - GroupLink (..), toGroupInfo, toGroupMember, toMaybeGroupMember, @@ -162,7 +161,6 @@ import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class import Crypto.Random (ChaChaDRG) -import qualified Data.Aeson.TH as J import Data.Bifunctor (second) import Data.Bitraversable (bitraverse) import Data.Char (toLower) @@ -188,7 +186,6 @@ import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..)) import qualified Simplex.Messaging.Agent.Store.DB as DB import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Ratchet (pattern PQEncOff, pattern PQSupportOff) -import Simplex.Messaging.Parsers (defaultJSON) import Simplex.Messaging.Protocol (SubscriptionMode (..)) import Simplex.Messaging.Util (eitherToMaybe, firstRow', safeDecodeUtf8, ($>>), ($>>=), (<$$>)) import Simplex.Messaging.Version @@ -280,16 +277,6 @@ deleteGroupLink db User {userId} GroupInfo {groupId} = do (userId, groupId) DB.execute db "DELETE FROM user_contact_links WHERE user_id = ? AND group_id = ?" (userId, groupId) -data GroupLink = GroupLink - { userContactLinkId :: Int64, - connLinkContact :: CreatedLinkContact, - shortLinkDataSet :: Bool, - shortLinkLargeDataSet :: BoolDef, - groupLinkId :: GroupLinkId, - acceptMemberRole :: GroupMemberRole - } - deriving (Show) - getGroupLink :: DB.Connection -> User -> GroupInfo -> ExceptT StoreError IO GroupLink getGroupLink db User {userId} gInfo@GroupInfo {groupId} = ExceptT . firstRow toGroupLink (SEGroupLinkNotFound gInfo) $ @@ -982,9 +969,12 @@ getUserGroupDetails db vr User {userId, userContactId} _contactId_ search_ = do search = maybe "" (map toLower) search_ getUserGroupsWithSummary :: DB.Connection -> VersionRangeChat -> User -> Maybe ContactId -> Maybe String -> IO [GroupInfoSummary] -getUserGroupsWithSummary db vr user _contactId_ search_ = - getUserGroupDetails db vr user _contactId_ search_ - >>= mapM (\g@GroupInfo {groupId} -> GIS g <$> getGroupSummary db user groupId) +getUserGroupsWithSummary db vr user _contactId_ search_ = do + gs <- getUserGroupDetails db vr user _contactId_ search_ + forM gs $ \g@GroupInfo {groupId} -> do + s <- getGroupSummary db user groupId + link_ <- eitherToMaybe <$> runExceptT (getGroupLink db user g) + pure $ GIS g s link_ -- the statuses on non-current members should match memberCurrent' function getGroupSummary :: DB.Connection -> User -> GroupId -> IO GroupSummary @@ -2905,5 +2895,3 @@ updateGroupAlias db userId g@GroupInfo {groupId} localAlias = do updatedAt <- getCurrentTime DB.execute db "UPDATE groups SET local_alias = ?, updated_at = ? WHERE user_id = ? AND group_id = ?" (localAlias, updatedAt, userId, groupId) pure (g :: GroupInfo) {localAlias = localAlias} - -$(J.deriveJSON defaultJSON ''GroupLink) diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index f6d0e7da72..7eba39360f 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -2204,8 +2204,6 @@ updateGroupScopeUnreadStats db vr user g@GroupInfo {membership} scopeInfo (unrea m_ <- runExceptT $ getGroupMemberById db vr user groupMemberId pure $ either (const m) id m_ -- Left shouldn't happen, but types require it -deriving instance Show BoolInt - setGroupChatItemsDeleteAt :: DB.Connection -> User -> GroupId -> [(ChatItemId, Int)] -> UTCTime -> IO [(ChatItemId, UTCTime)] setGroupChatItemsDeleteAt db User {userId} groupId itemIds currentTs = forM itemIds $ \(chatItemId, ttl) -> do let deleteAt = addUTCTime (realToFrac ttl) currentTs diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index c4253942d8..a90d457920 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -527,7 +527,17 @@ data GroupSummary = GroupSummary } deriving (Show) -data GroupInfoSummary = GIS {groupInfo :: GroupInfo, groupSummary :: GroupSummary} +data GroupInfoSummary = GIS {groupInfo :: GroupInfo, groupSummary :: GroupSummary, groupLink :: Maybe GroupLink} + deriving (Show) + +data GroupLink = GroupLink + { userContactLinkId :: Int64, + connLinkContact :: CreatedLinkContact, + shortLinkDataSet :: Bool, + shortLinkLargeDataSet :: BoolDef, + groupLinkId :: GroupLinkId, + acceptMemberRole :: GroupMemberRole + } deriving (Show) data ContactOrGroup = CGContact Contact | CGGroup GroupInfo [GroupMember] @@ -2075,6 +2085,8 @@ $(JQ.deriveJSON defaultJSON ''Group) $(JQ.deriveJSON defaultJSON ''GroupSummary) +$(JQ.deriveJSON defaultJSON ''GroupLink) + $(JQ.deriveJSON defaultJSON ''GroupInfoSummary) instance FromField MsgFilter where fromField = fromIntField_ msgFilterIntP diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index dcaabe433e..015d4e6645 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -50,7 +50,7 @@ import Simplex.Chat.Operators import Simplex.Chat.Protocol import Simplex.Chat.Remote.AppVersion (AppVersion (..), pattern AppVersionRange) import Simplex.Chat.Remote.Types -import Simplex.Chat.Store (AddressSettings (..), AutoAccept (..), GroupLink (..), StoreError (..), UserContactLink (..)) +import Simplex.Chat.Store (AddressSettings (..), AutoAccept (..), StoreError (..), UserContactLink (..)) import Simplex.Chat.Styled import Simplex.Chat.Types import Simplex.Chat.Types.Preferences @@ -1365,8 +1365,8 @@ viewGroupsList [] = ["you have no groups!", "to create: " <> highlight' "/g Text - ldn_ (GIS GroupInfo {localDisplayName} _) = T.toLower localDisplayName - groupSS (GIS g@GroupInfo {membership, chatSettings = ChatSettings {enableNtfs}} GroupSummary {currentMembers}) = + ldn_ (GIS GroupInfo {localDisplayName} _ _) = T.toLower localDisplayName + groupSS (GIS g@GroupInfo {membership, chatSettings = ChatSettings {enableNtfs}} GroupSummary {currentMembers} _) = case memberStatus membership of GSMemInvited -> groupInvitation' g s -> membershipIncognito g <> ttyFullGroup g <> viewMemberStatus s <> alias g diff --git a/tests/Bots/DirectoryTests.hs b/tests/Bots/DirectoryTests.hs index 168fd7bfca..1550a7bd9b 100644 --- a/tests/Bots/DirectoryTests.hs +++ b/tests/Bots/DirectoryTests.hs @@ -21,8 +21,7 @@ import Directory.Service import Directory.Store import GHC.IO.Handle (hClose) import Simplex.Chat.Bot.KnownContacts -import Simplex.Chat.Controller (ChatConfig (..), ChatHooks (..), defaultChatHooks) -import Simplex.Chat.Core +import Simplex.Chat.Controller (ChatConfig (..)) import qualified Simplex.Chat.Markdown as MD import Simplex.Chat.Options (CoreChatOpts (..)) import Simplex.Chat.Options.DB @@ -1129,11 +1128,12 @@ testListUserGroups promote ps = checkListings :: [T.Text] -> [T.Text] -> IO () checkListings listed promoted = do + threadDelay 100000 checkListing listingFileName listed checkListing promotedFileName promoted where checkListing f expected = do - Just (DirectoryListing gs) <- J.decodeFileStrict $ "./tests/tmp/web" f + Just (DirectoryListing gs) <- J.decodeFileStrict $ "./tests/tmp/web/data" f map groupName gs `shouldBe` expected groupName DirectoryEntry {displayName} = displayName @@ -1396,14 +1396,9 @@ withDirectoryOwnersGroup ps cfg dsLink createOwnersGroup webFolder test = do runDirectory :: ChatConfig -> DirectoryOpts -> IO () -> IO () runDirectory cfg opts@DirectoryOpts {directoryLog} action = do st <- restoreDirectoryStore directoryLog - t <- forkIO $ bot st + t <- forkIO $ directoryService st opts cfg threadDelay 500000 action `finally` (mapM_ hClose (directoryLogFile st) >> killThread t) - where - bot st = do - env <- newServiceState opts - let cfg' = cfg {chatHooks = defaultChatHooks {acceptMember = Just $ acceptMemberHook opts env}} - simplexChatCore cfg' (mkChatOpts opts) $ directoryService st opts env registerGroup :: TestCC -> TestCC -> String -> String -> IO () registerGroup su u n fn = registerGroupId su u n fn 1 1 diff --git a/website/run.sh b/website/run.sh new file mode 100755 index 0000000000..a0a8dd0e50 --- /dev/null +++ b/website/run.sh @@ -0,0 +1,8 @@ +#!/bin/bash + +set -e + +cd .. +./website/web.sh +cd website +npm run start diff --git a/website/src/blog.html b/website/src/blog.html index 571b240451..4a0460511a 100644 --- a/website/src/blog.html +++ b/website/src/blog.html @@ -1,36 +1,42 @@ --- layout: layouts/main.html title: "SimpleX blog: the latest news" -description: "SimpleX Chat - a private and encrypted messenger without any user IDs (not even random ones)! Make a private connection via link / QR code to send messages and make calls." +description: "SimpleX Chat - a private and encrypted messenger without any user IDs (not even random ones)! Make a +private connection via link / QR code to send messages and make calls." path: /blog templateEngineOverride: njk active_blog: true --- {% block css_links %} - + {% endblock %}
@@ -39,42 +45,48 @@ active_blog: true {% for blog in collections.blogs %} {% if not(blog.data.draft) %} -
-
-
- {% if blog.data.image %} - {% if blog.data.imageBottom %} - - {% elif blog.data.imageWide %} - - {% else %} - - {% endif %} - {% else %} - - - {% endif %} -
+
+
+
+ {% if blog.data.image %} + {% if blog.data.imageBottom %} + + {% elif blog.data.imageWide %} + + {% else %} + + {% endif %} + {% else %} + + + {% endif %}
-
-
-

- {{ blog.data.title | safe }} -

-

- {{ blog.data.date.toUTCString().split(' ').slice(1, 4).join(' ') }} -

- {% if blog.data.previewBody %} -
- {% include blog.data.previewBody %} -
- {% elif blog.data.preview %} -

{{ blog.data.preview | safe }}

- {% endif %} +
+
+
+

+ {{ blog.data.title | safe }} +

+

+ {{ blog.data.date.toUTCString().split(' ').slice(1, 4).join(' ') }} +

+ {% if blog.data.previewBody %} +
+ {% include blog.data.previewBody %}
- Read More + {% elif blog.data.preview %} +

{{ blog.data.preview | safe }}

+ {% endif %}
-
+ Read More +
+
{% endif %} {% endfor %} diff --git a/website/src/directory.html b/website/src/directory.html new file mode 100644 index 0000000000..247ee6ebc2 --- /dev/null +++ b/website/src/directory.html @@ -0,0 +1,272 @@ +--- +layout: layouts/main.html +title: "SimpleX Directory" +description: "Find communities on SimpleX network and create your own" +templateEngineOverride: njk +--- + +{% set lang = page.url | getlang %} +{% block js_scripts %} + + +{% endblock %} + + + +
+
+

SimpleX Directory

+

Welcome to the selected users' communities that you can join via SimpleX Chat + app.

+

SimpleX Directory is also available as a SimpleX chat bot.

+

Read about how to add your community.

+
+ + +
+
+ +
+
\ No newline at end of file diff --git a/website/src/img/group.svg b/website/src/img/group.svg new file mode 100644 index 0000000000..2a262ef38a --- /dev/null +++ b/website/src/img/group.svg @@ -0,0 +1,12 @@ + + + + + + + + + \ No newline at end of file diff --git a/website/src/js/directory.js b/website/src/js/directory.js new file mode 100644 index 0000000000..2eb8db71a1 --- /dev/null +++ b/website/src/js/directory.js @@ -0,0 +1,439 @@ +const directoryDataURL = 'https://directory.simplex.chat/data/'; + +// const directoryDataURL = 'http://localhost:8080/directory-data/'; + +let allEntries = []; + +let sortedEntries = []; + +let filteredEntries = []; + +let currentSortMode = ''; + +async function initDirectory() { + const listing = await fetchJSON(directoryDataURL + 'listing.json') + const liveBtn = document.querySelector('#top-pagination .live'); + const newBtn = document.querySelector('#top-pagination .new'); + const topBtn = document.querySelector('#top-pagination .top'); + const searchInput = document.getElementById('search'); + allEntries = listing.entries + renderSortedEntries('top', byMemberCountDesc, topBtn) + window.addEventListener('hashchange', renderDirectoryPage); + searchInput.addEventListener('input', (e) => renderFilteredEntries(e.target.value)); + + liveBtn.addEventListener('click', () => renderSortedEntries('live', byActiveAtDesc, liveBtn)); + newBtn.addEventListener('click', () => renderSortedEntries('new', byCreatedAtDesc, newBtn)); + topBtn.addEventListener('click', () => renderSortedEntries('top', byMemberCountDesc, topBtn)); + + function renderSortedEntries(mode, comparator, btn) { + if (currentSortMode === mode) return; + currentSortMode = mode; + if (location.hash) location.hash = ''; + liveBtn.classList.remove('active'); + newBtn.classList.remove('active'); + topBtn.classList.remove('active'); + btn.classList.add('active'); + sortedEntries = allEntries.slice().sort(comparator); + renderFilteredEntries(searchInput.value); + } +} + +function renderDirectoryPage() { + const currentEntries = addPagination(filteredEntries); + displayEntries(currentEntries); +} + +function renderFilteredEntries(s) { + const query = s.toLowerCase().trim(); + if (query === '') { + filteredEntries = sortedEntries.slice(); + } else { + filteredEntries = sortedEntries.filter(entry => + (entry.displayName || '').toLowerCase().includes(query) + || includesQuery(entry.shortDescr, query) + || includesQuery(entry.welcomeMessage, query) + ); + } + renderDirectoryPage(); +} + +function includesQuery(field, query) { + return field + && Array.isArray(field) + && field.some(ft => { + switch (ft.format?.type) { + case 'uri': return uriIncludesQuery(ft.text, query); + case 'hyperLink': return textIncludesQuery(ft.format.showText, query) || uriIncludesQuery(ft.format.linkUri, query); + case 'simplexLink': return textIncludesQuery(ft.format.showText, query); + default: return textIncludesQuery(ft.text, query); + } + }); +} + +function textIncludesQuery(text, query) { + text ? text.toLowerCase().includes(query) : false +} + +function uriIncludesQuery(uri, query) { + if (!uri) return false; + uri = uri.toLowerCase(); + return !uri.includes('simplex') && uri.includes(query); +} + +async function fetchJSON(url) { + try { + const response = await fetch(url) + if (!response.ok) throw new Error(`HTTP error! Status: ${response.status}`) + return await response.json() + } catch (error) { + console.error('Error fetching JSON:', error) + } +} + +function byMemberCountDesc(entry1, entry2) { + return entryMemberCount(entry2) - entryMemberCount(entry1); +} + +function byActiveAtDesc(entry1, entry2) { + return (roundedTs(entry2.activeAt) - roundedTs(entry1.activeAt)) * 10 + + Math.sign(byMemberCountDesc(entry1, entry2)); +} + +function byCreatedAtDesc(entry1, entry2) { + return (roundedTs(entry2.createdAt) - roundedTs(entry1.createdAt)) * 10 + + Math.sign(byMemberCountDesc(entry1, entry2)); +} + +function roundedTs(s) { + try { + // rounded to 15 minutes, which is the frequency of listing update + return Math.floor(new Date(s).valueOf() / 900000); + } catch { + return 0; + } +} + +function entryMemberCount(entry) { + return entry.entryType.type == 'group' + ? (entry.entryType.summary?.currentMembers ?? 0) + : 0 +} + +function displayEntries(entries) { + const directory = document.getElementById('directory'); + directory.innerHTML = ''; + + for (let entry of entries) { + try { + const { entryType, displayName, groupLink, shortDescr, welcomeMessage, imageFile } = entry; + const entryDiv = document.createElement('div'); + entryDiv.className = 'entry w-full flex flex-col items-start md:flex-row rounded-[4px] overflow-hidden shadow-[0px_20px_30px_rgba(0,0,0,0.12)] dark:shadow-none bg-white dark:bg-[#11182F] mb-8'; + + const textContainer = document.createElement('div'); + textContainer.className = 'text-container'; + + const nameElement = document.createElement('h2'); + nameElement.textContent = displayName; + nameElement.className = 'text-grey-black dark:text-white !text-lg md:!text-xl font-bold'; + textContainer.appendChild(nameElement); + + const welcomeMessageHTML = welcomeMessage ? renderMarkdown(welcomeMessage) : undefined; + const shortDescrHTML = shortDescr ? renderMarkdown(shortDescr) : undefined; + if (shortDescrHTML && welcomeMessageHTML?.includes(shortDescrHTML) !== true) { + const descrElement = document.createElement('p'); + descrElement.innerHTML = renderMarkdown(shortDescr); + textContainer.appendChild(descrElement); + } + + if (welcomeMessageHTML) { + const messageElement = document.createElement('p'); + messageElement.innerHTML = welcomeMessageHTML; + textContainer.appendChild(messageElement); + + const readMore = document.createElement('p'); + readMore.textContent = 'Read more'; + readMore.className = 'read-more'; + readMore.style.display = 'none'; + textContainer.appendChild(readMore); + + setTimeout(() => { + const computedStyle = window.getComputedStyle(messageElement); + const lineHeight = parseFloat(computedStyle.lineHeight); + const maxLines = 5; + const maxHeight = maxLines * lineHeight + const maxHeightPx = `${maxHeight}px`; + messageElement.style.maxHeight = maxHeightPx; + messageElement.style.overflow = 'hidden'; + + if (messageElement.scrollHeight > maxHeight + 4) { + readMore.style.display = 'block'; + readMore.addEventListener('click', () => { + if (messageElement.style.maxHeight === maxHeightPx) { + messageElement.style.maxHeight = 'none'; + readMore.className = 'read-less'; + readMore.innerHTML = '▲'; + } else { + messageElement.style.maxHeight = maxHeightPx; + readMore.className = 'read-more'; + readMore.textContent = 'Read more'; + } + }); + } + }, 0); + } + + const memberCount = entryMemberCount(entry); + if (typeof memberCount == 'number' && memberCount > 0) { + const memberCountElement = document.createElement('p'); + memberCountElement.innerText = `${memberCount} members`; + memberCountElement.classList = ['text-sm']; + textContainer.appendChild(memberCountElement); + } + + const imgElement = document.createElement('a'); + imgSource = + imageFile + ? directoryDataURL + imageFile + : "/img/group.svg"; + imgElement.innerHTML = `${displayName}`; + imgElement.href = platformSimplexUri(groupLink.connShortLink ?? groupLink.connFullLink); + if (!isCurrentSite(imgElement.href)) imgElement.target = "_blank"; + imgElement.title = `Join ${displayName}`; + entryDiv.appendChild(imgElement); + + entryDiv.appendChild(textContainer); + directory.appendChild(entryDiv); + } catch (e) { + console.log(e); + } + } + + for (let el of document.querySelectorAll('.secret')) { + el.addEventListener('click', () => el.classList.toggle('visible')); + } + + directory.style.height = ''; +} + +function goToPage(p) { + location.hash = p.toString(); +} + +function addPagination(entries) { + const entriesPerPage = 10; + const totalPages = Math.ceil(entries.length / entriesPerPage); + let currentPage = parseInt(location.hash.slice(1)) || 1; + if (currentPage < 1) currentPage = 1; + if (currentPage > totalPages) currentPage = totalPages; + + const startIndex = (currentPage - 1) * entriesPerPage; + const endIndex = Math.min(startIndex + entriesPerPage, entries.length); + const currentEntries = entries.slice(startIndex, endIndex); + + // addPaginationElements('top-pagination') + addPaginationElements('bottom-pagination') + return currentEntries; + + function addPaginationElements(paginationId) { + const pagination = document.getElementById(paginationId); + if (!pagination) { + return currentEntries; + } + pagination.innerHTML = ''; + + try { + let startPage, endPage; + const pageButtonCount = 8 + if (totalPages <= pageButtonCount) { + startPage = 1; + endPage = totalPages; + } else { + startPage = Math.max(1, currentPage - 4); + endPage = Math.min(totalPages, startPage + pageButtonCount - 1); + if (endPage - startPage + 1 < pageButtonCount) { + startPage = Math.max(1, endPage - pageButtonCount + 1); + } + } + + // if (currentPage > 1 && startPage > 1) { + // const firstBtn = document.createElement('button'); + // firstBtn.textContent = 'First'; + // firstBtn.classList.add('text-btn'); + // firstBtn.addEventListener('click', () => goToPage(1)); + // pagination.appendChild(firstBtn); + // } + + if (currentPage > 1) { + const prevBtn = document.createElement('button'); + prevBtn.textContent = 'Prev'; + prevBtn.classList.add('text-btn'); + prevBtn.addEventListener('click', () => goToPage(currentPage - 1)); + pagination.appendChild(prevBtn); + } + + for (let p = startPage; p <= endPage; p++) { + const pageBtn = document.createElement('button'); + pageBtn.textContent = p.toString(); + if (p === currentPage) { + pageBtn.classList.add('active'); + } else if (p === currentPage - 1 || p === currentPage + 1) { + pageBtn.classList.add('neighbor'); + } + pageBtn.addEventListener('click', () => goToPage(p)); + pagination.appendChild(pageBtn); + } + + if (currentPage < totalPages) { + const nextBtn = document.createElement('button'); + nextBtn.textContent = 'Next'; + nextBtn.classList.add('text-btn'); + nextBtn.addEventListener('click', () => goToPage(currentPage + 1)); + pagination.appendChild(nextBtn); + } + + // if (endPage < totalPages) { + // const lastBtn = document.createElement('button'); + // lastBtn.textContent = 'Last'; + // lastBtn.classList.add('text-btn'); + // lastBtn.addEventListener('click', () => goToPage(totalPages)); + // pagination.appendChild(lastBtn); + // } + + } catch (e) { + console.log(e); + } + } +} + +if (document.readyState === 'loading') { + document.addEventListener('DOMContentLoaded', initDirectory); +} else { + initDirectory(); +} + +function escapeHtml(text) { + return text + .replace(/&/g, "&") + .replace(//g, ">") + .replace(/"/g, """) + .replace(/'/g, "'") + .replace(/\n/g, "
"); +} + +function getSimplexLinkDescr(linkType) { + switch (linkType) { + case 'contact': return 'SimpleX contact address'; + case 'invitation': return 'SimpleX one-time invitation'; + case 'group': return 'SimpleX group link'; + case 'channel': return 'SimpleX channel link'; + case 'relay': return 'SimpleX relay link'; + default: return 'SimpleX link'; + } +} + +function viaHost(smpHosts) { + const first = smpHosts[0] ?? '?'; + return `via ${first}`; +} + +function isCurrentSite(uri) { + return uri.startsWith("https://simplex.chat") || uri.startsWith("https://www.simplex.chat") +} + +function targetBlank(uri) { + return isCurrentSite(uri) ? '' : ' target="_blank"' +} + +function platformSimplexUri(uri) { + if (isMobile.any()) return uri; + if (uri.startsWith('simplex:/g#')) { + const prefixLength = 'simplex:/g#'.length; + const fragment = uri.substring(prefixLength); + const queryIndex = fragment.indexOf('?'); + if (queryIndex === -1) return uri; + const hashPart = fragment.substring(0, queryIndex); + const queryStr = fragment.substring(queryIndex + 1); + const params = new URLSearchParams(queryStr); + const host = params.get('h'); + if (!host) return uri; + params.delete('h'); + let newFragment = hashPart; + const remainingParams = params.toString(); + if (remainingParams) newFragment += '?' + remainingParams; + return `https://${host}:/g#${newFragment}`; + } else if(uri.startsWith('simplex:/')) { + const prefixLength = 'simplex:/'.length; + return 'https://simplex.chat/' + uri.substring(prefixLength); + } else { + return uri; + } +} + +function renderMarkdown(fts) { + let html = ''; + for (const ft of fts) { + const { format, text } = ft; + if (!format) { + html += escapeHtml(text); + continue; + } + try { + switch (format.type) { + case 'bold': + html += `${escapeHtml(text)}`; + break; + case 'italic': + html += `${escapeHtml(text)}`; + break; + case 'strikeThrough': + html += `${escapeHtml(text)}`; + break; + case 'snippet': + html += `${escapeHtml(text)}`; + break; + case 'secret': + html += `${escapeHtml(text)}`; + break; + case 'colored': + html += `${escapeHtml(text)}`; + break; + case 'uri': + let href = text.startsWith('http://') || text.startsWith('https://') || text.startsWith('simplex:/') ? text : 'https://' + text; + html += `${escapeHtml(text)}`; + break; + case 'hyperLink': { + const { showText, linkUri } = format; + html += `${escapeHtml(showText ?? linkUri)}`; + break; + } + case 'simplexLink': { + const { showText, linkType, simplexUri, smpHosts } = format; + const linkText = showText ? escapeHtml(showText) : getSimplexLinkDescr(linkType); + html += `${linkText} (${viaHost(smpHosts)})`; + break; + } + case 'command': + html += `${escapeHtml(text)}`; + break; + case 'mention': + html += `${escapeHtml(text)}`; + break; + case 'email': + html += `${escapeHtml(text)}`; + break; + case 'phone': + html += `${escapeHtml(text)}`; + break; + case 'unknown': + html += escapeHtml(text); + break; + default: + html += escapeHtml(text); + } + } catch { + html += escapeHtml(text); + } + } + return html; +} diff --git a/website/src/js/script.js b/website/src/js/script.js index 5f863f48ee..cf240dd375 100644 --- a/website/src/js/script.js +++ b/website/src/js/script.js @@ -26,7 +26,8 @@ const uniqueSwiper = new Swiper('.unique-swiper', { const isMobile = { Android: () => navigator.userAgent.match(/Android/i), - iOS: () => navigator.userAgent.match(/iPhone|iPad|iPod/i) + iOS: () => navigator.userAgent.match(/iPhone|iPad|iPod/i), + any: () => navigator.userAgent.match(/Android|iPhone|iPad|iPod/i) }; const privateSwiper = new Swiper('.private-swiper', { From a1eee94a863d37df247bc05c60aaf2281b1c34bb Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Sat, 20 Sep 2025 20:11:34 +0100 Subject: [PATCH 11/64] website: fix search in directory --- website/src/js/directory.js | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/website/src/js/directory.js b/website/src/js/directory.js index 2eb8db71a1..d25b5ae275 100644 --- a/website/src/js/directory.js +++ b/website/src/js/directory.js @@ -71,7 +71,7 @@ function includesQuery(field, query) { } function textIncludesQuery(text, query) { - text ? text.toLowerCase().includes(query) : false + return text ? text.toLowerCase().includes(query) : false } function uriIncludesQuery(uri, query) { From 5a951c56b2652657a2d51d9485741d5a1828d674 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Sun, 21 Sep 2025 09:43:02 +0100 Subject: [PATCH 12/64] android, desktop: update dependency --- apps/multiplatform/common/build.gradle.kts | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/apps/multiplatform/common/build.gradle.kts b/apps/multiplatform/common/build.gradle.kts index 8b4dd0e4d7..2227766cfa 100644 --- a/apps/multiplatform/common/build.gradle.kts +++ b/apps/multiplatform/common/build.gradle.kts @@ -113,7 +113,7 @@ kotlin { } // For jSystemThemeDetector only implementation("net.java.dev.jna:jna-platform:5.14.0") - implementation("com.sshtools:two-slices:0.9.0-SNAPSHOT") + implementation("com.sshtools:two-slices:0.9.1") implementation("org.slf4j:slf4j-simple:2.0.12") implementation("uk.co.caprica:vlcj:4.8.3") implementation("net.java.dev.jna:jna:5.14.0") From 83b655ea8318291f8a8017fb0afbf48de2aa74a6 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Sun, 21 Sep 2025 10:40:06 +0100 Subject: [PATCH 13/64] website(directory): add bot address, open simplex links in new tab, improve error handling --- website/src/directory.html | 2 +- website/src/js/directory.js | 40 ++++++++++++++++++++++++------------- 2 files changed, 27 insertions(+), 15 deletions(-) diff --git a/website/src/directory.html b/website/src/directory.html index 247ee6ebc2..333d7faed8 100644 --- a/website/src/directory.html +++ b/website/src/directory.html @@ -256,7 +256,7 @@ templateEngineOverride: njk

SimpleX Directory

Welcome to the selected users' communities that you can join via SimpleX Chat app.

-

SimpleX Directory is also available as a SimpleX chat bot.

+

SimpleX Directory is also available as a SimpleX chat bot.

Read about how to add your community.

diff --git a/website/src/js/directory.js b/website/src/js/directory.js index d25b5ae275..313bdeedec 100644 --- a/website/src/js/directory.js +++ b/website/src/js/directory.js @@ -1,3 +1,4 @@ +(function() { const directoryDataURL = 'https://directory.simplex.chat/data/'; // const directoryDataURL = 'http://localhost:8080/directory-data/'; @@ -83,10 +84,10 @@ function uriIncludesQuery(uri, query) { async function fetchJSON(url) { try { const response = await fetch(url) - if (!response.ok) throw new Error(`HTTP error! Status: ${response.status}`) + if (!response.ok) throw new Error(`HTTP status: ${response.status}`) return await response.json() - } catch (error) { - console.error('Error fetching JSON:', error) + } catch (e) { + console.error(e) } } @@ -196,7 +197,13 @@ function displayEntries(entries) { ? directoryDataURL + imageFile : "/img/group.svg"; imgElement.innerHTML = `${displayName}`; - imgElement.href = platformSimplexUri(groupLink.connShortLink ?? groupLink.connFullLink); + const groupLinkUri = groupLink.connShortLink ?? groupLink.connFullLink + try { + imgElement.href = platformSimplexUri(groupLinkUri); + } catch(e) { + console.log(e); + imgElement.href = groupLinkUri; + } if (!isCurrentSite(imgElement.href)) imgElement.target = "_blank"; imgElement.title = `Join ${displayName}`; entryDiv.appendChild(imgElement); @@ -345,11 +352,17 @@ function targetBlank(uri) { return isCurrentSite(uri) ? '' : ' target="_blank"' } +const simplexAddressRegexp = /^simplex:\/([a-z]+)#(.+)/i; + +const simplexShortLinkTypes = ["a", "c", "g", "i", "r"]; + function platformSimplexUri(uri) { if (isMobile.any()) return uri; - if (uri.startsWith('simplex:/g#')) { - const prefixLength = 'simplex:/g#'.length; - const fragment = uri.substring(prefixLength); + const res = uri.match(simplexAddressRegexp); + if (!res || !Array.isArray(res) || res.length < 3) return uri; + const linkType = res[1]; + const fragment = res[2]; + if (simplexShortLinkTypes.includes(linkType)) { const queryIndex = fragment.indexOf('?'); if (queryIndex === -1) return uri; const hashPart = fragment.substring(0, queryIndex); @@ -361,12 +374,9 @@ function platformSimplexUri(uri) { let newFragment = hashPart; const remainingParams = params.toString(); if (remainingParams) newFragment += '?' + remainingParams; - return `https://${host}:/g#${newFragment}`; - } else if(uri.startsWith('simplex:/')) { - const prefixLength = 'simplex:/'.length; - return 'https://simplex.chat/' + uri.substring(prefixLength); + return `https://${host}:/${linkType}#${newFragment}`; } else { - return uri; + return `https://simplex.chat/${fragment}`; } } @@ -410,7 +420,7 @@ function renderMarkdown(fts) { case 'simplexLink': { const { showText, linkType, simplexUri, smpHosts } = format; const linkText = showText ? escapeHtml(showText) : getSimplexLinkDescr(linkType); - html += `${linkText} (${viaHost(smpHosts)})`; + html += `${linkText} (${viaHost(smpHosts)})`; break; } case 'command': @@ -431,9 +441,11 @@ function renderMarkdown(fts) { default: html += escapeHtml(text); } - } catch { + } catch(e) { + console.log(e); html += escapeHtml(text); } } return html; } +})(); From c09665b9200fa5dfeafcd5fc60944372968355c1 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Sun, 21 Sep 2025 14:36:58 +0100 Subject: [PATCH 14/64] directory: show only recent groups in active/new tabs, page improvements (#6290) * directory: show only recent groups as active or new * round times * sorting order * fix links * improve --- .../src/Directory/Listing.hs | 28 ++++-- website/src/directory.html | 2 +- website/src/js/directory.js | 85 +++++++++++-------- 3 files changed, 72 insertions(+), 43 deletions(-) diff --git a/apps/simplex-directory-service/src/Directory/Listing.hs b/apps/simplex-directory-service/src/Directory/Listing.hs index b9b50cb87b..cef478c273 100644 --- a/apps/simplex-directory-service/src/Directory/Listing.hs +++ b/apps/simplex-directory-service/src/Directory/Listing.hs @@ -23,13 +23,15 @@ import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Base64.URL as B64URL import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as LB +import Data.Int (Int64) import Data.List (isPrefixOf) import Data.Maybe (catMaybes, fromMaybe) import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) -import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Time.Clock +import Data.Time.Clock.System import Data.Time.Format.ISO8601 (iso8601Show) import Directory.Store import Simplex.Chat.Markdown @@ -66,8 +68,8 @@ data DirectoryEntry = DirectoryEntry shortDescr :: Maybe MarkdownList, welcomeMessage :: Maybe MarkdownList, imageFile :: Maybe String, - activeAt :: UTCTime, - createdAt :: UTCTime + activeAt :: Maybe UTCTime, + createdAt :: Maybe UTCTime } $(JQ.deriveJSON defaultJSON ''DirectoryEntry) @@ -78,8 +80,18 @@ $(JQ.deriveJSON defaultJSON ''DirectoryListing) type ImageFileData = ByteString -groupDirectoryEntry :: GroupInfoSummary -> Maybe (DirectoryEntry, Maybe (FilePath, ImageFileData)) -groupDirectoryEntry (GIS GroupInfo {groupProfile, chatTs, createdAt} summary gLink_) = +newOrActive :: NominalDiffTime +newOrActive = 30 * nominalDay + +recentRoundedTime :: Int64 -> UTCTime -> UTCTime -> Maybe UTCTime +recentRoundedTime roundTo now t + | diffUTCTime now t > newOrActive = Nothing + | otherwise = + let secs = (systemSeconds (utcToSystemTime t) `div` roundTo) * roundTo + in Just $ systemToUTCTime $ MkSystemTime secs 0 + +groupDirectoryEntry :: UTCTime -> GroupInfoSummary -> Maybe (DirectoryEntry, Maybe (FilePath, ImageFileData)) +groupDirectoryEntry now (GIS GroupInfo {groupProfile, chatTs, createdAt} summary gLink_) = let GroupProfile {displayName, shortDescr, description, image, memberAdmission} = groupProfile entryType = DETGroup memberAdmission summary entry groupLink = @@ -91,8 +103,8 @@ groupDirectoryEntry (GIS GroupInfo {groupProfile, chatTs, createdAt} summary gLi shortDescr = toFormattedText <$> shortDescr, welcomeMessage = toFormattedText <$> description, imageFile = fst <$> imgData, - activeAt = fromMaybe createdAt chatTs, - createdAt + activeAt = recentRoundedTime 900 now $ fromMaybe createdAt chatTs, + createdAt = recentRoundedTime 86400 now createdAt } imgData = imgFileData groupLink =<< image in (de, imgData) @@ -121,7 +133,7 @@ generateListing st dir gs = do createDirectoryIfMissing True (newDir listingImageFolder) gs'' <- fmap catMaybes $ forM gs' $ \g@(GIS GroupInfo {groupId} _ _) -> - forM (groupDirectoryEntry g) $ \(g', img) -> do + forM (groupDirectoryEntry ts g) $ \(g', img) -> do forM_ img $ \(imgFile, imgData) -> B.writeFile (newDir imgFile) imgData pure (groupId, g') saveListing newDir listingFileName gs'' diff --git a/website/src/directory.html b/website/src/directory.html index 333d7faed8..1d87ffdaa9 100644 --- a/website/src/directory.html +++ b/website/src/directory.html @@ -263,7 +263,7 @@ templateEngineOverride: njk
diff --git a/website/src/js/directory.js b/website/src/js/directory.js index 313bdeedec..72c93d35fb 100644 --- a/website/src/js/directory.js +++ b/website/src/js/directory.js @@ -5,12 +5,14 @@ const directoryDataURL = 'https://directory.simplex.chat/data/'; let allEntries = []; -let sortedEntries = []; - let filteredEntries = []; let currentSortMode = ''; +let currentSearch = ''; + +let currentPage = 1; + async function initDirectory() { const listing = await fetchJSON(directoryDataURL + 'listing.json') const liveBtn = document.querySelector('#top-pagination .live'); @@ -18,24 +20,29 @@ async function initDirectory() { const topBtn = document.querySelector('#top-pagination .top'); const searchInput = document.getElementById('search'); allEntries = listing.entries - renderSortedEntries('top', byMemberCountDesc, topBtn) - window.addEventListener('hashchange', renderDirectoryPage); - searchInput.addEventListener('input', (e) => renderFilteredEntries(e.target.value)); + renderEntries('top', bySortPriority, topBtn) + searchInput.addEventListener('input', (e) => renderEntries('top', bySortPriority, topBtn, e.target.value.trim())); + liveBtn.addEventListener('click', () => renderEntries('live', byActiveAtDesc, liveBtn, '')); + newBtn.addEventListener('click', () => renderEntries('new', byCreatedAtDesc, newBtn, '')); + topBtn.addEventListener('click', () => renderEntries('top', bySortPriority, topBtn, '')); - liveBtn.addEventListener('click', () => renderSortedEntries('live', byActiveAtDesc, liveBtn)); - newBtn.addEventListener('click', () => renderSortedEntries('new', byCreatedAtDesc, newBtn)); - topBtn.addEventListener('click', () => renderSortedEntries('top', byMemberCountDesc, topBtn)); - - function renderSortedEntries(mode, comparator, btn) { - if (currentSortMode === mode) return; + function renderEntries(mode, comparator, btn, search) { + if (currentSortMode === mode && search == currentSearch) return; currentSortMode = mode; if (location.hash) location.hash = ''; liveBtn.classList.remove('active'); newBtn.classList.remove('active'); topBtn.classList.remove('active'); - btn.classList.add('active'); - sortedEntries = allEntries.slice().sort(comparator); - renderFilteredEntries(searchInput.value); + if (search == '') { + currentSearch = ''; + currentPage = 1; + searchInput.value = ''; + btn.classList.add('active'); + } else { + currentSearch = search; + } + filteredEntries = filterEntries(mode, search ?? '').sort(comparator); + renderDirectoryPage(); } } @@ -44,18 +51,20 @@ function renderDirectoryPage() { displayEntries(currentEntries); } -function renderFilteredEntries(s) { - const query = s.toLowerCase().trim(); - if (query === '') { - filteredEntries = sortedEntries.slice(); - } else { - filteredEntries = sortedEntries.filter(entry => - (entry.displayName || '').toLowerCase().includes(query) - || includesQuery(entry.shortDescr, query) - || includesQuery(entry.welcomeMessage, query) - ); - } - renderDirectoryPage(); +function filterEntries(mode, s) { + if (s === '' && mode == 'top') return allEntries.slice(); + const query = s.toLowerCase(); + return allEntries.filter(entry => + ( mode === 'top' + || (mode === 'new' && entry.createdAt) + || (mode === 'live' && entry.activeAt) + ) && + ( query === '' + || (entry.displayName || '').toLowerCase().includes(query) + || includesQuery(entry.shortDescr, query) + || includesQuery(entry.welcomeMessage, query) + ) + ); } function includesQuery(field, query) { @@ -91,18 +100,18 @@ async function fetchJSON(url) { } } -function byMemberCountDesc(entry1, entry2) { - return entryMemberCount(entry2) - entryMemberCount(entry1); +function bySortPriority(entry1, entry2) { + return entrySortPriority(entry2) - entrySortPriority(entry1); } function byActiveAtDesc(entry1, entry2) { return (roundedTs(entry2.activeAt) - roundedTs(entry1.activeAt)) * 10 - + Math.sign(byMemberCountDesc(entry1, entry2)); + + Math.sign(bySortPriority(entry1, entry2)); } function byCreatedAtDesc(entry1, entry2) { return (roundedTs(entry2.createdAt) - roundedTs(entry1.createdAt)) * 10 - + Math.sign(byMemberCountDesc(entry1, entry2)); + + Math.sign(bySortPriority(entry1, entry2)); } function roundedTs(s) { @@ -114,6 +123,14 @@ function roundedTs(s) { } } +const simplexUsersGroup = 'SimpleX users group'; + +function entrySortPriority(entry) { + return entry.displayName === simplexUsersGroup + ? Number.MAX_VALUE + : entryMemberCount(entry) +} + function entryMemberCount(entry) { return entry.entryType.type == 'group' ? (entry.entryType.summary?.currentMembers ?? 0) @@ -204,7 +221,7 @@ function displayEntries(entries) { console.log(e); imgElement.href = groupLinkUri; } - if (!isCurrentSite(imgElement.href)) imgElement.target = "_blank"; + imgElement.target = "_blank"; imgElement.title = `Join ${displayName}`; entryDiv.appendChild(imgElement); @@ -223,13 +240,13 @@ function displayEntries(entries) { } function goToPage(p) { - location.hash = p.toString(); + currentPage = p; + renderDirectoryPage(); } function addPagination(entries) { const entriesPerPage = 10; const totalPages = Math.ceil(entries.length / entriesPerPage); - let currentPage = parseInt(location.hash.slice(1)) || 1; if (currentPage < 1) currentPage = 1; if (currentPage > totalPages) currentPage = totalPages; @@ -376,7 +393,7 @@ function platformSimplexUri(uri) { if (remainingParams) newFragment += '?' + remainingParams; return `https://${host}:/${linkType}#${newFragment}`; } else { - return `https://simplex.chat/${fragment}`; + return `https://simplex.chat/${linkType}#${fragment}`; } } From bfd9d794129c68f6bb7db5e43021baac32b7e6fe Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Sun, 21 Sep 2025 19:15:10 +0100 Subject: [PATCH 15/64] directory: disable search autocomplete --- website/src/directory.html | 2 +- website/src/js/directory.js | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/website/src/directory.html b/website/src/directory.html index 1d87ffdaa9..a75d775bc5 100644 --- a/website/src/directory.html +++ b/website/src/directory.html @@ -259,7 +259,7 @@ templateEngineOverride: njk

SimpleX Directory is also available as a SimpleX chat bot.

Read about how to add your community.

- +