From 628b00eb08596bdb50246528fa4b11288ee574ac Mon Sep 17 00:00:00 2001 From: Evgeny Date: Thu, 12 Feb 2026 07:11:59 +0000 Subject: [PATCH] core: channel messages (#6604) * core: channel messages (WIP) * do not include member ID when quoting channel messages * query plans * reduce duplication * refactor * refactor plan * refactor 2 * all tests * remove plan * refactor 3 * refactor 4 * refactor 5 * refactor 6 * plans * plans to imrove test coverage and fix bugs * update plan * update plan * bug fixes (wip) * new plan * fixes wip * more tests * comment, fix lint * restore comment * restore comments * rename param * move type * simplify * comment * fix stale state * refactor * less diff * simplify * less diff * refactor --------- Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com> Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> --- .../src/Directory/Service.hs | 6 +- bots/api/TYPES.md | 3 + docs/contributing/CODE.md | 13 + .../types/typescript/src/types.ts | 14 +- plans/channel_message_bugs_fix_plan.md | 321 +++++++++ plans/deduplication-channel-messages.md | 256 +++++++ plans/delivery-context-fix.md | 354 ++++++++++ plans/group_channel_feature_coverage.md | 377 ++++++++++ plans/groups_coverage_fill_plan.md | 368 ++++++++++ plans/groups_test_coverage.md | 441 ++++++++++++ src/Simplex/Chat/Controller.hs | 9 +- src/Simplex/Chat/Delivery.hs | 40 +- src/Simplex/Chat/Library/Commands.hs | 149 ++-- src/Simplex/Chat/Library/Internal.hs | 115 +-- src/Simplex/Chat/Library/Subscriber.hs | 506 ++++++++------ src/Simplex/Chat/Messages.hs | 54 +- src/Simplex/Chat/Messages/Batch.hs | 10 +- src/Simplex/Chat/Protocol.hs | 29 +- src/Simplex/Chat/Store/Delivery.hs | 14 +- src/Simplex/Chat/Store/Files.hs | 19 +- src/Simplex/Chat/Store/Groups.hs | 22 +- src/Simplex/Chat/Store/Messages.hs | 53 +- .../SQLite/Migrations/M20230511_reactions.hs | 2 +- .../Migrations/M20250813_delivery_tasks.hs | 4 +- .../SQLite/Migrations/chat_query_plans.txt | 14 +- .../Store/SQLite/Migrations/chat_schema.sql | 2 +- src/Simplex/Chat/Terminal/Output.hs | 3 +- src/Simplex/Chat/Types.hs | 6 + src/Simplex/Chat/View.hs | 110 +-- tests/ChatTests/Groups.hs | 657 ++++++++++++++++-- tests/ProtocolTests.hs | 14 +- 31 files changed, 3453 insertions(+), 532 deletions(-) create mode 100644 plans/channel_message_bugs_fix_plan.md create mode 100644 plans/deduplication-channel-messages.md create mode 100644 plans/delivery-context-fix.md create mode 100644 plans/group_channel_feature_coverage.md create mode 100644 plans/groups_coverage_fill_plan.md create mode 100644 plans/groups_test_coverage.md diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index 41ea081890..3b2e926189 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/apps/simplex-directory-service/src/Directory/Service.hs @@ -579,7 +579,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName [] -> textMsg "" : _ -> textMsg img : _ -> MCImage "" $ ImageData img - sendCaptcha mc = sendComposedMessages_ cc (SRGroup groupId $ Just $ GCSMemberSupport (Just gmId)) [(quotedId, MCText noticeText), (Nothing, mc)] + sendCaptcha mc = sendComposedMessages_ cc (SRGroup groupId (Just $ GCSMemberSupport (Just gmId)) False) [(quotedId, MCText noticeText), (Nothing, mc)] gmId = groupMemberId' m approvePendingMember :: DirectoryMemberAcceptance -> GroupInfo -> GroupMember -> IO () @@ -603,7 +603,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName Just PendingCaptcha {captchaText, sentAt, attempts} | ts `diffUTCTime` sentAt > captchaTTL -> sendMemberCaptcha g m (Just ciId) captchaExpired $ attempts - 1 | matchCaptchaStr captchaText msgText -> do - sendComposedMessages_ cc (SRGroup groupId $ Just $ GCSMemberSupport (Just $ groupMemberId' m)) [(Just ciId, MCText $ "Correct, you joined the group " <> n)] + sendComposedMessages_ cc (SRGroup groupId (Just $ GCSMemberSupport (Just $ groupMemberId' m)) False) [(Just ciId, MCText $ "Correct, you joined the group " <> n)] approvePendingMember a g m | attempts >= maxCaptchaAttempts -> rejectPendingMember tooManyAttempts | otherwise -> sendMemberCaptcha g m (Just ciId) (wrongCaptcha attempts) attempts @@ -613,7 +613,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName a = groupMemberAcceptance g rejectPendingMember rjctNotice = do let gmId = groupMemberId' m - sendComposedMessages cc (SRGroup groupId $ Just $ GCSMemberSupport (Just gmId)) [MCText rjctNotice] + sendComposedMessages cc (SRGroup groupId (Just $ GCSMemberSupport (Just gmId)) False) [MCText rjctNotice] sendChatCmd cc (APIRemoveMembers groupId [gmId] False) >>= \case Right (CRUserDeletedMembers _ _ (_ : _) _) -> do atomically $ TM.delete gmId $ pendingCaptchas env diff --git a/bots/api/TYPES.md b/bots/api/TYPES.md index 25a6565f45..328b923f90 100644 --- a/bots/api/TYPES.md +++ b/bots/api/TYPES.md @@ -606,6 +606,9 @@ GroupRcv: - type: "groupRcv" - groupMember: [GroupMember](#groupmember) +ChannelRcv: +- type: "channelRcv" + LocalSnd: - type: "localSnd" diff --git a/docs/contributing/CODE.md b/docs/contributing/CODE.md index 7ae6d176ac..1dcf795c00 100644 --- a/docs/contributing/CODE.md +++ b/docs/contributing/CODE.md @@ -2,6 +2,12 @@ This file provides guidance on coding style and approaches and on building the code. +## Code Security + +When designing code and planning implementations: +- Apply adversarial thinking, and consider what may happen if one of the communicating parties is malicious. +- Formulate an explicit threat model for each change - who can do which undesirable things and under which circumstances. + ## Code Style, Formatting and Approaches The project uses **fourmolu** for Haskell code formatting. Configuration is in `fourmolu.yaml`. @@ -38,9 +44,16 @@ Some files that use CPP language extension cannot be formatted as a whole, so in **Diff and refactoring:** - Avoid unnecessary changes and code movements +- Never rename existing variables, parameters, or functions unless the rename is the point of the change - Never do refactoring unless it substantially reduces cost of solving the current problem, including the cost of refactoring - Aim to minimize the code changes - do what is minimally required to solve users' problems +**Type-driven development:** +- Types must reflect business semantics, not data shape. E.g., `CIChannelRcv` (channel message) vs `CIGroupRcv GroupMember` (member message) are semantically distinct — do not collapse them into `CIGroupRcv (Maybe GroupMember)` just because the data overlaps. Duplicate pattern match arms across semantic constructors are acceptable. +- Duplicate function bodies are not acceptable. When adding a new variant of existing behavior, parameterize existing functions to handle both variants — do not copy function bodies into parallel code paths. +- Concrete example: if `groupMessageFileDescription` and `channelMessageFileDescription` share 90% of their logic, extract a shared helper and make both into thin wrappers — do not maintain two near-identical function bodies. +- When the return type differs between variants (e.g., one returns `Maybe X`, another returns `()`), use the more general return type and have callers discard what they don't need. + **Document and code structure:** - **Never move existing code or sections around** - add new content at appropriate locations without reorganizing existing structure. - When adding new sections to documents, continue the existing numbering scheme. diff --git a/packages/simplex-chat-client/types/typescript/src/types.ts b/packages/simplex-chat-client/types/typescript/src/types.ts index c04ff3466e..0660f0e968 100644 --- a/packages/simplex-chat-client/types/typescript/src/types.ts +++ b/packages/simplex-chat-client/types/typescript/src/types.ts @@ -554,11 +554,19 @@ export type CIDirection = | CIDirection.DirectRcv | CIDirection.GroupSnd | CIDirection.GroupRcv + | CIDirection.ChannelRcv | CIDirection.LocalSnd | CIDirection.LocalRcv export namespace CIDirection { - export type Tag = "directSnd" | "directRcv" | "groupSnd" | "groupRcv" | "localSnd" | "localRcv" + export type Tag = + | "directSnd" + | "directRcv" + | "groupSnd" + | "groupRcv" + | "channelRcv" + | "localSnd" + | "localRcv" interface Interface { type: Tag @@ -581,6 +589,10 @@ export namespace CIDirection { groupMember: GroupMember } + export interface ChannelRcv extends Interface { + type: "channelRcv" + } + export interface LocalSnd extends Interface { type: "localSnd" } diff --git a/plans/channel_message_bugs_fix_plan.md b/plans/channel_message_bugs_fix_plan.md new file mode 100644 index 0000000000..c50b5ed7ff --- /dev/null +++ b/plans/channel_message_bugs_fix_plan.md @@ -0,0 +1,321 @@ +# Plan: Channel Message Bugs Fix + +## Table of Contents +1. [Executive Summary](#executive-summary) +2. [Bug 1: Delivery Context Flag](#bug-1-delivery-context-flag) +3. [Bug 2: Reaction Attribution](#bug-2-reaction-attribution) +4. [Bug 3: Update Fallback Default](#bug-3-update-fallback-default) +5. [Bug 4: Forward API Parameter](#bug-4-forward-api-parameter) +6. [Bug 5: CLI Forward Hardcode](#bug-5-cli-forward-hardcode) +7. [Test Plan](#test-plan) +8. [Implementation Order](#implementation-order) + +--- + +## Executive Summary + +**5 bugs identified** in channel message handling: + +| # | Location | Bug | Severity | +|---|----------|-----|----------| +| 1 | Subscriber.hs:935-945 | Events use `isChannelOwner` instead of item's `showGroupAsSender` | Critical | +| 2 | Subscriber.hs:1818-1842 | Reactions allow `m_=Nothing` and fall back to membership | High | +| 3 | Subscriber.hs:1950-1969 | Update fallback creates item without correct sendAsGroup flag | Medium | +| 4 | Commands.hs:930,944 | Forward API ignores `_sendAsGroup` parameter | High | +| 5 | Commands.hs:2191,2196,2201,4633 | CLI forward hardcodes False | Medium | + +--- + +## Bug 1: Delivery Context Flag + +### Current Code (Subscriber.hs:935-945) +```haskell +let isChannelOwner = useRelays' gInfo' && memberRole' m'' == GROwner + showGroupAsSender' = case event of + XMsgNew mc -> fromMaybe False (asGroup (mcExtMsgContent mc)) + XMsgUpdate {} -> isChannelOwner -- BUG: should use item's flag + XMsgDel {} -> isChannelOwner -- BUG + XMsgReact {} -> isChannelOwner -- BUG + XMsgFileDescr {} -> isChannelOwner -- BUG + XFileCancel {} -> isChannelOwner -- BUG + _ -> False +``` + +### Problem +Events referencing existing items (update, delete, react, file) compute `showGroupAsSender'` from **current sender role** (`isChannelOwner`) instead of **item's stored `showGroupAsSender` flag**. + +### Fix +Extract `showGroupAsSender` from the chat item being referenced: + +```haskell +showGroupAsSender' = case event of + XMsgNew mc -> fromMaybe False (asGroup (mcExtMsgContent mc)) + XMsgUpdate {} -> itemShowGroupAsSender ci -- from item lookup + XMsgDel {} -> itemShowGroupAsSender ci + XMsgReact {} -> itemShowGroupAsSender ci + XMsgFileDescr {} -> itemShowGroupAsSender ci + XFileCancel {} -> itemShowGroupAsSender ci + _ -> False +``` + +**Note:** Use `chatDir` from ChatItem and pattern match on `CIChannelRcv` to determine sendAsGroup flag. + +### Files Modified +- `src/Simplex/Chat/Library/Subscriber.hs`: Lines 935-945 + +--- + +## Bug 2: Reaction Attribution + +### Current Code (Subscriber.hs:1818-1842) +```haskell +groupMsgReaction :: GroupInfo -> Maybe GroupMember -> SharedMsgId -> Maybe MemberId -> Maybe MsgScope -> MsgReaction -> Bool -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope) +groupMsgReaction g m_ sharedMsgId itemMemberId scope_ reaction add RcvMessage {msgId} brokerTs + ... + where + GroupInfo {membership} = g + reactor = fromMaybe membership m_ -- BUG (line 1842): uses membership when m_ is Nothing + ciDir = maybe CIChannelRcv CIGroupRcv m_ +``` + +### Problem +When `m_` is `Nothing`, reactor incorrectly falls back to `membership` (user's own member record). However, reactions should always come from an identifiable member - the `m_` parameter should never be `Nothing` for reactions. + +### Fix +Reactions can only come from members (including owners), never from channels. XMsgReact handler must be reworked to require `GroupMember` instead of `Maybe GroupMember`. The `m_` parameter should not be optional for reactions. + +### Files Modified +- `src/Simplex/Chat/Library/Subscriber.hs`: Lines 1818-1842 + +--- + +## Bug 3: Update Fallback Default + +### Current Code (Subscriber.hs:1950-1969) +```haskell +updateRcvChatItem `catchCINotFound` \_ -> do + (chatDir, mentions', scopeInfo) <- case m_ of + Just m -> ... + Nothing -> pure (CDChannelRcv gInfo Nothing, M.empty, Nothing) -- BUG: no sendAsGroup info + (ci, cInfo) <- saveRcvChatItem' user chatDir msg ... +``` + +### Problem +When `x.msg.update` arrives for a locally-deleted item in a channel (`m_` is `Nothing`), the fallback creates a new item with `CDChannelRcv gInfo Nothing` but doesn't know the original item's `sendAsGroup` flag. + +### Fix (Option B: Require sender to include flag in the event) +Add `asGroup` field to `XMsgUpdate` message format. + +**Rationale:** We don't know what owner wants otherwise - it may send as channel or it may send as owner, and different members must have the same view (e.g. when multiple relays are used, it would be random). + +### Files Modified +- `src/Simplex/Chat/Library/Subscriber.hs`: Lines 1950-1969 +- Protocol message format (XMsgUpdate) + +--- + +## Bug 4: Forward API Parameter + +### Current Code (Commands.hs:930,944) +```haskell +APIForwardChatItems ... _sendAsGroup -> withUser $ \user -> case toCType of + CTGroup -> do + ... + sendGroupContentMessages user gInfo toScope (sendAsGroup' gInfo) False itemTTL cmrs' + -- ^^^^^^^^^^^^^^^^^^^ BUG: ignores _sendAsGroup +``` + +### Problem +The `_sendAsGroup` parameter is received but ignored. The function computes its own `sendAsGroup' gInfo` instead. + +### Fix +```haskell +APIForwardChatItems ... sendAsGroup -> withUser $ \user -> case toCType of + CTGroup -> do + ... + sendGroupContentMessages user gInfo toScope sendAsGroup False itemTTL cmrs' +``` + +### Files Modified +- `src/Simplex/Chat/Library/Commands.hs`: Line 930 (rename parameter), Line 944 (use parameter) + +--- + +## Bug 5: CLI Forward Hardcode + +### Current Code (Commands.hs) +```haskell +-- Line 2191 +processChatCommand vr nm $ APIForwardChatItems toChatRef (ChatRef CTDirect contactId Nothing) (forwardedItemId :| []) Nothing False + +-- Line 2196 +processChatCommand vr nm $ APIForwardChatItems toChatRef (ChatRef CTGroup groupId Nothing) (forwardedItemId :| []) Nothing False + +-- Line 2201 +processChatCommand vr nm $ APIForwardChatItems toChatRef (ChatRef CTLocal folderId Nothing) (forwardedItemId :| []) Nothing False + +-- Line 4633 +"/_forward " *> (APIForwardChatItems <$> chatRefP <* A.space <*> chatRefP <*> _strP <*> sendMessageTTLP <*> pure False), +``` + +### Problem +All CLI forward commands hardcode `False` for `sendAsGroup` instead of computing based on destination. + +### Fix +Compute `sendAsGroup` before calling API based on destination group's channel status: + +```haskell +-- Lines 2191, 2196, 2201: Need to determine sendAsGroup based on toChatRef +-- If toChatRef is a channel and user is owner, sendAsGroup should default to True + +-- Line 4633: Parser should accept optional flag (parser cannot know context) +``` + +### Files Modified +- `src/Simplex/Chat/Library/Commands.hs`: Lines 2191, 2196, 2201, 4633 + +--- + +## Test Plan + +### New Tests (8 total) + +Tests 1-4 cover Bug 1 (delivery context flag). Each tests a specific event type where the owner sends as member (sendAsGroup=False). Existing tests already cover the "sends as channel" (sendAsGroup=True) case; these tests verify that the delivery context correctly uses the item's stored sendAsGroup=False flag rather than recomputing from the owner's current role. + +#### Test 1: `testChannelOwnerUpdateAsMember` +**Objective:** Verify x.msg.update uses item's sendAsGroup=False, not current role. + +**Scenario:** +1. Owner sends message as member (sendAsGroup=False) +2. Member receives message, verify it shows as from member (not channel) +3. Owner updates message +4. Verify update delivery context uses sendAsGroup=False from the item, not recomputed from owner role + +**Coverage:** Bug 1 + +--- + +#### Test 2: `testChannelOwnerDeleteAsMember` +**Objective:** Verify x.msg.del uses item's sendAsGroup=False, not current role. + +**Scenario:** +1. Owner sends message as member (sendAsGroup=False) +2. Member receives message, verify it shows as from member (not channel) +3. Owner deletes message +4. Verify delete delivery context uses sendAsGroup=False from the item, not recomputed from owner role + +**Coverage:** Bug 1 + +--- + +#### Test 3: `testChannelOwnerFileTransferAsMember` +**Objective:** Verify file delivery (including x.msg.file.descr) uses item's sendAsGroup=False, not current role. + +**Scenario:** +1. Owner sends file as member (sendAsGroup=False) +2. Member receives file, verify it shows as from member (not channel) +3. Verify file delivery uses sendAsGroup=False from the item, not recomputed from owner role + +**Note:** x.msg.file.descr is part of file delivery, not a separate event to test independently. + +**Coverage:** Bug 1 + +--- + +#### Test 4: `testChannelOwnerFileCancelAsMember` +**Objective:** Verify x.file.cancel uses item's sendAsGroup=False, not current role. + +**Scenario:** +1. Owner sends file as member (sendAsGroup=False) +2. Member receives file, verify it shows as from member (not channel) +3. Owner cancels file +4. Verify cancel delivery context uses sendAsGroup=False from the item, not recomputed from owner role + +**Coverage:** Bug 1 + +--- + +#### Test 5: `testChannelReactionAttribution` +**Objective:** Verify reactions require a member sender (not optional). + +**Scenario:** +1. Owner sends channel message +2. Owner adds reaction (as member, not as channel) +3. Verify reaction is attributed to owner's member record +4. Member adds reaction to channel message +5. Verify member reaction is attributed correctly +6. Verify channel cannot send reactions (m_ must be Just) + +**Coverage:** Bug 2 + +--- + +#### Test 6: `testChannelUpdateFallbackSendAsGroup` +**Objective:** Verify update on deleted item creates correct sendAsGroup from protocol field. + +**Scenario:** +1. Owner sends channel message (sendAsGroup=True) +2. Member receives and locally deletes +3. Owner updates message (XMsgUpdate includes asGroup=True) +4. Verify member's recreated item has sendAsGroup=True +5. Owner sends message as member (sendAsGroup=False) +6. Member receives and locally deletes +7. Owner updates message (XMsgUpdate includes asGroup=False) +8. Verify member's recreated item has sendAsGroup=False + +**Coverage:** Bug 3 + +--- + +#### Test 7: `testForwardAPIUsesParameter` +**Objective:** Verify Forward API respects sendAsGroup parameter. + +**Scenario:** +1. Create channel with owner +2. Forward message to channel with sendAsGroup=True +3. Verify message sent as channel +4. Forward message with sendAsGroup=False +5. Verify message sent as member + +**Coverage:** Bug 4 + +--- + +#### Test 8: `testForwardCLISendAsGroup` +**Objective:** Verify CLI forward commands compute sendAsGroup correctly. + +**Scenario:** +1. Create channel with owner +2. Use `/forward` to forward to channel +3. Verify sendAsGroup computed correctly (True for owner in channel) + +**Coverage:** Bug 5 + +--- + +## Implementation Order + +### Phase 1: Critical Fix (Bug 1) +1. Fix delivery context in Subscriber.hs +2. Add Tests 1-4 (`testChannelOwnerUpdateAsMember`, `testChannelOwnerDeleteAsMember`, `testChannelOwnerFileTransferAsMember`, `testChannelOwnerFileCancelAsMember`) + +### Phase 2: API Fixes (Bugs 4, 5) +1. Fix Forward API parameter usage +2. Fix CLI forward hardcodes +3. Add Tests 7 and 8 (`testForwardAPIUsesParameter`, `testForwardCLISendAsGroup`) + +### Phase 3: Behavior Fixes (Bugs 2, 3) +1. Rework XMsgReact handler to require GroupMember (not Maybe GroupMember) +2. Add asGroup field to XMsgUpdate protocol message +3. Add Tests 5 and 6 (`testChannelReactionAttribution`, `testChannelUpdateFallbackSendAsGroup`) + +--- + +## Files Summary + +| File | Changes | +|------|---------| +| `src/Simplex/Chat/Library/Subscriber.hs` | Lines 935-945 (Bug 1), 1818-1842 (Bug 2), 1950-1969 (Bug 3) | +| `src/Simplex/Chat/Library/Commands.hs` | Lines 930,944 (Bug 4), 2191,2196,2201,4633 (Bug 5) | +| Protocol message types | Add asGroup field to XMsgUpdate (Bug 3) | +| `tests/ChatTests/Groups.hs` | Add 8 new tests | diff --git a/plans/deduplication-channel-messages.md b/plans/deduplication-channel-messages.md new file mode 100644 index 0000000000..0d09d00528 --- /dev/null +++ b/plans/deduplication-channel-messages.md @@ -0,0 +1,256 @@ +# Deduplication Plan: Channel Message Functions + +## Table of Contents + +1. [Executive Summary](#executive-summary) +2. [Findings by File](#findings-by-file) +3. [Architectural Note: CIChannelRcv Constructor](#architectural-note) +4. [Implementation Order](#implementation-order) + +--- + +## Executive Summary + +The PR introduces channel message support by creating parallel channel-specific functions that duplicate 60-80% of existing group functions. The core pattern: channel messages are group messages without a member sender. Most channel functions are the group function with `Just member` → `Nothing`, `CIGroupRcv m` → `CIChannelRcv`, and moderation/blocking guards removed. + +**High-value deduplication targets** (ordered by impact): + +| # | Candidate | Feasibility | Shared code | +|---|-----------|-------------|-------------| +| 1 | `channelMessageUpdate_` → merge into `groupMessageUpdate` | HIGH | ~36 lines | +| 2 | `fwdChannelReaction` → extract shared helper with `groupMsgReaction` | MEDIUM | ~15 lines inner function | +| 3 | `newChannelContentMessage_` → parameterize `newGroupContentMessage` | MEDIUM | ~12 lines happy path | +| 4 | `processForwardedChannelMsg` → merge into `processForwardedMsg` | MEDIUM | depends on 1-3 | +| 5 | `getGroupCIBySharedMsgId'` → parameterize `getGroupChatItemBySharedMsgId` | HIGH | eliminates function | +| 6 | `channelMessageDelete` → parameterize `groupMessageDelete` | LOW | ~5 lines; group has 60+ lines moderation | +| 7 | `saveRcvChatItem'` CDChannelRcv branches | HIGH | ~14 lines across 3 spots | +| 8 | `processContentItem` CIChannelRcv branch | HIGH | ~3 lines | +| 9 | View.hs/Store/Internal pattern match branches | DEFERRED | ~24 branches; requires constructor change | + +--- + +## Findings by File + +### Subscriber.hs + +**D1: `channelMessageUpdate_` vs `groupMessageUpdate`** + +The `updateRcvChatItem` inner function is nearly line-for-line identical between both (~36 shared lines). Differences: +- Lookup: `getGroupChatItemBySharedMsgId` (by member) vs `getGroupCIBySharedMsgId'` (no member) — parameterizable by `Maybe GroupMemberId` (see D5) +- Pattern match: `CIGroupRcv m'` with `sameMemberId` check vs `CIChannelRcv` — branch on `Maybe GroupMember` +- `getGroupCIReactions`: `Just memberId` vs `Nothing` — already parameterized +- Chat direction in fallback: `CDGroupRcv` vs `CDChannelRcv` — branch on `Maybe GroupMember` +- `channelMessageUpdate_` has explicit `forwarded` param; `groupMessageUpdate` always uses `rcvGroupCITimed gInfo ttl_` — the merged function needs to accept `forwarded :: Bool` (or always `False` from the non-forwarded path) +- `groupMessageUpdate` has `prohibitedSimplexLinks` and `blockedMemberCI` guards — skip when member is `Nothing` +- Mentions handling: `groupMessageUpdate` has `mentions' = if memberBlocked m then [] else mentions`; `channelMessageUpdate_` passes `mentions` directly — when member is `Nothing`, use `mentions` directly (no blocking check needed) + +**Solution:** Extend `groupMessageUpdate` to take `Maybe GroupMember`. When `Nothing`: skip prohibited links check, skip blocked member CI, use `CDChannelRcv`, use `getGroupChatItemBySharedMsgId` with `Nothing`, pass mentions directly. Delete `channelMessageUpdate_`. + +--- + +**D2: `fwdChannelReaction` vs `groupMsgReaction`** + +These functions share the `updateChatItemReaction` inner function shape (~15 lines), but are **structurally different** in their outer logic: + +- **Parameter types**: `groupMsgReaction` takes a concrete `GroupMember` + `Maybe MemberId` (item member) + `Maybe MsgScope`; `fwdChannelReaction` takes `Maybe GroupMember` (reactor) and always passes `Nothing` as item member +- **Return type**: `groupMsgReaction` returns `CM (Maybe DeliveryJobScope)` — used by the main dispatch for delivery job routing; `fwdChannelReaction` returns `CM ()` — forwarded context doesn't need delivery jobs +- **CIReaction constructor**: `groupMsgReaction` always uses `CIGroupRcv m`; `fwdChannelReaction` uses `maybe CIChannelRcv CIGroupRcv reactor_` — semantically different when reactor is `Nothing` +- **catchCINotFound fallback**: `groupMsgReaction` has scope-aware delivery job logic; `fwdChannelReaction` does bare `setGroupReaction` +- **Reactor**: `groupMsgReaction` uses `m` directly; `fwdChannelReaction` computes `fromMaybe membership reactor_` + +`fwdChannelReaction` is NOT a rename of `groupMsgReaction`. Calling `void $ groupMsgReaction` from forwarded contexts would be **semantically wrong**: it would attribute channel reactions to the membership member via `CIGroupRcv` instead of showing them as `CIChannelRcv`, and would trigger unnecessary delivery job scope logic. + +**Solution:** Extract the shared `updateChatItemReaction` body (~15 lines) into a helper parameterized by the `CIReaction` constructor and reactor member. Both `groupMsgReaction` and `fwdChannelReaction` call this helper with their respective parameters. This preserves the distinct outer logic while eliminating the inner body duplication. + +--- + +**D3: `newChannelContentMessage_` vs `newGroupContentMessage`** + +The channel version is the "happy path" of the group version with all member-specific guards removed: +- No `blockedByAdmin` check +- No `prohibitedGroupContent` check +- No `getCIModeration` / moderation logic (~40 lines) +- No scope resolution (`mkGetMessageChatScope`) +- No `blockedMemberCI` +- No member-conditional mentions filtering / autoAcceptFile guard + +The shared "save-view-react-accept" core is ~12 lines. + +**Solution:** Extract a shared `saveGroupContentItem` helper containing: process file invitation, save chat item, get reactions, view, auto-accept, return scope. `newGroupContentMessage` calls it after its checks; `newChannelContentMessage_` calls it directly. This keeps `newGroupContentMessage`'s complex flow intact while eliminating the body duplication. + +Alternatively: extend `newGroupContentMessage` to take `Maybe GroupMember`. When `Nothing`: skip all member-specific guards and use `CDChannelRcv`. This is cleaner but changes the function's signature and control flow significantly. + +--- + +**D4: `processForwardedChannelMsg` vs `processForwardedMsg`** + +These are dispatch tables with identical structure. Each event arm calls the group or channel variant: + +``` +processForwardedMsg author: processForwardedChannelMsg: + XMsgNew → newGroupContentMessage XMsgNew → newChannelContentMessage_ + XMsgFileDescr → groupMessageFileDescription XMsgFileDescr → channelMessageFileDescription + XMsgUpdate → groupMessageUpdate XMsgUpdate → channelMessageUpdate_ + ... ... +``` + +If the underlying functions (D1-D3) are parameterized by `Maybe GroupMember`, this dispatch unifies automatically. The extra group-management events (`XInfo`, `XGrpMemNew`, etc.) are guarded by `Just author`. + +**Subtlety: `XMsgReact` handling.** The `XMsgReact` arm has a three-way split: +- `processForwardedMsg` with `Just memId` → `groupMsgReaction` (member reaction with scope/delivery-job logic) +- `processForwardedMsg` with `Nothing` memId → `fwdChannelReaction gInfo (Just author)` (channel reaction from known author) +- `processForwardedChannelMsg` → `fwdChannelReaction gInfo Nothing` (channel reaction, no author) + +This three-way split needs careful handling in the merged function, since `fwdChannelReaction` differs structurally from `groupMsgReaction` (see D2). + +**Solution:** After D1-D3, merge into `processForwardedMsg` taking `Maybe GroupMember`. When `Nothing`, skip group-management events. The `XMsgReact` arm passes the author to `fwdChannelReaction` when in channel mode. Delete `processForwardedChannelMsg`. + +--- + +**D5: `channelMessageDelete` vs `groupMessageDelete`** + +`groupMessageDelete` has ~60 lines of moderation logic (moderate, checkRole, archiveMessageReports, CIModeration creation) that `channelMessageDelete` does not need. The shared portion is only ~5-7 lines (delete/mark-deleted + view). Additionally, the lookup functions differ: `channelMessageDelete` uses `getGroupCIBySharedMsgId'` (no member); `groupMessageDelete` uses `getGroupMemberCIBySharedMsgId` (JOINs group_members by MemberId). The delete condition also differs: `groupFeatureAllowed` vs `groupFeatureMemberAllowed`. + +**Solution:** LOW priority. The functions are architecturally different enough that forced unification would harm readability. If desired, extend `groupMessageDelete` with a `Maybe GroupMember` parameter where `Nothing` takes the simple "channel delete" path early. But the code clarity cost may exceed the deduplication benefit. + +--- + +### Store/Messages.hs + +**D6: `getGroupCIBySharedMsgId'` vs `getGroupChatItemBySharedMsgId`** + +`getGroupChatItemBySharedMsgId` filters by `group_member_id = ?`. +`getGroupCIBySharedMsgId'` omits the `group_member_id` filter entirely (matches any row regardless of member). + +Channel items store `group_member_id = NULL`. Parameterizing with `Maybe GroupMemberId` and `IS NOT DISTINCT FROM` would: +- `Just gmId` → only that member (existing behavior) +- `Nothing` → only NULL rows (channel items) + +This is **stricter** than `getGroupCIBySharedMsgId'`'s current behavior (which matches any member's items too), but this is actually a correctness improvement — all four callers (Subscriber.hs lines 1846, 1962, 1988, 3233) are channel-specific contexts where items have `group_member_id = NULL`. + +**Solution:** Change `getGroupChatItemBySharedMsgId` to take `Maybe GroupMemberId`. SQL becomes: +```sql +WHERE user_id = ? AND group_id = ? AND group_member_id IS NOT DISTINCT FROM ? AND shared_msg_id = ? +``` +Delete `getGroupCIBySharedMsgId'`. Update all callers to pass `Just gmId` or `Nothing`. + +**Note:** `getGroupMemberCIBySharedMsgId` is a different function (takes `MemberId`, JOINs `group_members` to resolve). It is NOT a duplicate and should be kept. + +**Additional Store/Messages.hs duplications** (minor, collapse with constructor change): +- `createNewRcvChatItem` quoteRow (lines 560-563): `CDGroupRcv` and `CDChannelRcv` branches are verbatim identical +- `getChatItemQuote_` (lines 649-654): `CDChannelRcv` branch is a subset of `CDGroupRcv` (missing sender-specific case) +- `createNewChatItem_` idsRow/groupScope: `CDChannelRcv` branches repeat `CDGroupSnd`-like tuples + +These are inherent to the separate constructor and collapse automatically with the architectural change (see note below). Not worth addressing independently. + +--- + +### Library/Internal.hs + +**D7: `saveRcvChatItem'` CDChannelRcv branches** + +Three duplicate spots within this function, all verbatim copies of CDGroupRcv branches: + +1. **Mentions/userMention computation** (~7 lines): `getRcvCIMentions`, `userReply` via `cmToQuotedMsg`, `userMention'` via membership check. Verbatim identical between CDGroupRcv and CDChannelRcv. + +2. **createGroupCIMentions** (~2 lines): Both branches call `createGroupCIMentions db g ci mentions'` guarded by `not (null mentions')`. Identical. + +3. **memberChatStats / memberAttentionChange** (~3 lines): Only difference is `Just m` vs `Nothing` passed to `memberAttentionChange`. + +Total: ~14 lines of duplication across 3 spots. + +**Solution:** Extract `GroupInfo` and `Maybe GroupMember` from either constructor at the top: +```haskell +case cd of + CDGroupRcv g _s m -> (g, Just m) + CDChannelRcv g _s -> (g, Nothing) +``` +Then use the extracted values for all three spots. The `memberAttentionChange` call already takes `Maybe GroupMember`. + +--- + +**D8: `processContentItem` CIChannelRcv branch** + +Near-duplicate of `CIGroupRcv` branch (lines 1196-1199 vs 1200-1202). Only difference: no `blockedByAdmin` guard, passes `Nothing` instead of `Just sender`. + +**Solution:** Merge the two branches: +```haskell +(CChatItem SMDRcv ci@ChatItem {chatDir, content = CIRcvMsgContent mc, file}) + | maybe True (not . blockedByAdmin) sender_ -> do + fInvDescr_ <- join <$> forM file getRcvFileInvDescr + processContentItem sender_ ci mc fInvDescr_ + where sender_ = case chatDir of CIGroupRcv m -> Just m; CIChannelRcv -> Nothing; _ -> Nothing +``` + +**Additional Internal.hs duplication** (minor): +- `quoteData` (lines 228-229): `CIGroupRcv m` returns `(qmc, CIQGroupRcv $ Just m, False, Just m)`, `CIChannelRcv` returns `(qmc, CIQGroupRcv Nothing, False, Nothing)`. Two one-liners differing only in `Just m` vs `Nothing`. Trivial but noted. + +--- + +### View.hs + +**D9: View.hs pattern match duplication** + +The actual count of `CIChannelRcv` pattern match branches: +- **View.hs**: 6 branches (chatDirNtf, viewChatItem new, viewChatItem updated, reaction display, sentByMember', fileFrom) +- **Terminal/Output.hs**: 1 branch +- **Commands.hs**: 2 branches (itemDeletable, itemsMsgMemIds) +- **Internal.hs**: 2 branches (quoteData, processContentItem) +- **Subscriber.hs**: ~6 branches (scattered) +- **Store/Messages.hs**: ~4 branches (toGroupChatItem, createNewRcvChatItem, createNewChatItem_, getChatItemQuote_) + +Total: **~24 pattern match sites** across all files (~17 `CIChannelRcv` + ~7 `CDChannelRcv`). Each mirrors the corresponding `CIGroupRcv m` / `CDGroupRcv` branch passing `Nothing` instead of `Just m`. + +The `ttyFromGroup*` family of functions in View.hs was correctly generalized to take `Maybe GroupMember` — the duplication is at the call sites, not in the helper functions. + +**Solution:** This duplication is **inherent to the separate constructor choice** and can only be eliminated by the architectural change (merging `CIChannelRcv` into `CIGroupRcv (Maybe GroupMember)`). Without that change, the branches must remain. Extracting local helpers at each call site would add complexity without reducing total code. + +--- + +### Other Files (no significant deduplication needed) + +- **Commands.hs:** Parameter threading (`ShowGroupAsSender`, `SRGroup`). Clean, no duplication. +- **Protocol.hs:** Wire protocol changes (`ExtMsgContent.asGroup`, `XGrpMsgForward Maybe MemberId`). Necessary. +- **Delivery.hs:** `FwdSender` type replaces separate fields. Could be `Maybe (MemberId, ContactName)` but not a priority. +- **Store/Files.hs:** `createRcvGroupFileTransfer` takes `Maybe GroupMember`. Clean parameterization. +- **Store/Groups.hs:** `createPreparedGroup` returns `Maybe GroupMember`. Necessary for relay groups. +- **Types.hs:** `sendAsGroup'`, `groupId'` utilities. Minor. + +--- + +## Architectural Note: CIChannelRcv Constructor {#architectural-note} + +The deepest source of duplication is the choice to add `CIChannelRcv` / `CDChannelRcv` as separate constructors rather than parameterizing `CIGroupRcv :: Maybe GroupMember -> CIDirection 'CTGroup 'MDRcv` and `CDGroupRcv :: GroupInfo -> Maybe GroupChatScopeInfo -> Maybe GroupMember -> ChatDirection 'CTGroup 'MDRcv`. + +This creates ~24 pattern match branches across the codebase, almost all passing `Nothing` where `CIGroupRcv` passes `Just m`. The `chatItemMember` function already returns `Maybe GroupMember`, confirming the abstraction is correct. + +**However**, changing these constructors is a large cross-cutting refactor affecting Messages.hs, View.hs, Commands.hs, Internal.hs, Subscriber.hs, Store/Messages.hs, and tests. It may be better suited as a follow-up PR. + +**Decision needed from user:** Merge `CIChannelRcv` into `CIGroupRcv (Maybe GroupMember)` in this PR, or defer? + +--- + +## Implementation Order + +### Phase 1: Store layer (D6) +1. Parameterize `getGroupChatItemBySharedMsgId` with `Maybe GroupMemberId` + `IS NOT DISTINCT FROM` +2. Delete `getGroupCIBySharedMsgId'` +3. Update all callers (pass `Just gmId` or `Nothing`) + +### Phase 2: Subscriber.hs function merges (D1, D2, D3) +4. Merge `channelMessageUpdate_` into `groupMessageUpdate` (takes `Maybe GroupMember`) +5. Extract shared `updateChatItemReaction` helper from `groupMsgReaction` and `fwdChannelReaction` +6. Merge `newChannelContentMessage_` into `newGroupContentMessage` (extract shared save-view helper or take `Maybe GroupMember`) + +### Phase 3: Dispatch unification (D4) +7. Merge `processForwardedChannelMsg` into `processForwardedMsg` (takes `Maybe GroupMember`; handle `XMsgReact` three-way split) + +### Phase 4: Internal cleanup (D7, D8) +8. Deduplicate `saveRcvChatItem'` CDChannelRcv branches (3 spots) +9. Merge `processContentItem` CIChannelRcv branch + +### Phase 5 (deferred unless approved): Constructor change (D9) +10. Merge `CIChannelRcv` into `CIGroupRcv (Maybe GroupMember)` — eliminates ~24 pattern match branches across all files + +### Phase 6 (optional): channelMessageDelete (D5) +11. Only if user wants it — extend `groupMessageDelete` with `Maybe GroupMember` diff --git a/plans/delivery-context-fix.md b/plans/delivery-context-fix.md new file mode 100644 index 0000000000..4b1b13c30a --- /dev/null +++ b/plans/delivery-context-fix.md @@ -0,0 +1,354 @@ +# Plan: Fix Channel Message Delivery Architecture + +## Table of Contents +1. [Context](#context) +2. [Executive Summary](#executive-summary) +3. [Issue 1: Eliminate memberForChannel/memberIdForChannel](#issue-1) +4. [Issue 2: groupMsgReaction required GroupMember](#issue-2) +5. [Issue 3: Fix groupMessageUpdate lookup](#issue-3) +6. [Issue 4: DeliveryTaskContext type](#issue-4) +7. [Issue 5: Fix testChannelReactionAttribution](#issue-5) +8. [Issue 6: Fix testChannelUpdateFallbackSendAsGroup comment](#issue-6) +9. [Other: sendAsGroup parameter ordering](#other-issue) +10. [Verification](#verification) + +## Context + +The current implementation on `ep/channel-messages-2` determines delivery context (whether to forward messages as channel or as member) using `isChannelOwner` — inferring from the sender's role whether they're the channel owner. This is architecturally wrong: the delivery context should be determined **from the item's direction** (`CIChannelRcv` vs `CIGroupRcv`), not from who sent it. The `f/msg-from-channel` branch has the correct approach. + +## Executive Summary + +7 changes across 7 files: +1. **Delivery.hs** — Add `DeliveryTaskContext` type, update `NewMessageDeliveryTask` only (`MessageDeliveryTask` unchanged) +2. **Subscriber.hs** — Eliminate `isChannelOwner`/`memberForChannel`/`memberIdForChannel`; all processing functions return `Maybe DeliveryTaskContext`; determine `sentAsGroup` from item direction; `groupMsgReaction` takes required `GroupMember`; add `withAuthor` in forwarded handler +3. **Store/Delivery.hs** — Update SQL row mapping for `taskContext` +4. **Commands.hs** — Reorder `sendAsGroup` param in `APIForwardChatItems` +5. **Store/Messages.hs** — Reorder `showGroupAsSender` param in `createNewSndChatItem` +6. **Internal.hs** — Reorder `showGroupAsSender` param in `saveSndChatItems`, `prepareGroupMsg` +7. **Tests** — Fix reaction test comment/expectations, fix update fallback test comment + +--- + +## Issue 1: Eliminate memberForChannel/memberIdForChannel {#issue-1} + +**File:** `src/Simplex/Chat/Library/Subscriber.hs` lines 935-937, 939-991 + +**Problem:** `isChannelOwner`, `memberForChannel`, `memberIdForChannel` computed at lines 935-937 and passed to processing functions. This pre-infers delivery context from member role. + +**Fix:** Remove these three bindings entirely. Always pass `(Just m'')` to functions that take `Maybe GroupMember`. Functions determine `sentAsGroup` from item direction internally. + +**Direct handler changes (lines 939-991):** +``` +-- BEFORE: +let isChannelOwner = useRelays' gInfo' && memberRole' m'' == GROwner + memberForChannel = if isChannelOwner then Nothing else Just m'' + memberIdForChannel = memberId' <$> memberForChannel +(deliveryJobScope_, showGroupAsSender') <- case event of + ... +forM deliveryJobScope_ $ \jobScope -> + pure $ NewMessageDeliveryTask {messageId = msgId, jobScope, showGroupAsSender = showGroupAsSender'} + +-- AFTER: +deliveryTaskContext_ <- case event of + XMsgNew mc -> ... -- returns Maybe DeliveryTaskContext + XMsgFileDescr ... -> groupMessageFileDescription gInfo' (Just m'') sharedMsgId fileDescr + XMsgUpdate ... -> memberCanSend m'' msgScope Nothing $ groupMessageUpdate gInfo' (Just m'') sharedMsgId ... + XMsgDel ... -> groupMessageDelete gInfo' (Just m'') sharedMsgId ... + XMsgReact ... -> groupMsgReaction gInfo' m'' sharedMsgId ... -- required member + XFileCancel sharedMsgId -> xFileCancelGroup gInfo' (Just m'') sharedMsgId + ...other events -> Just <$> memberEventDeliveryContext m'' / Nothing +forM deliveryTaskContext_ $ \taskContext -> + pure $ NewMessageDeliveryTask {messageId = msgId, taskContext} +``` + +**Processing function signature changes:** +- `groupMessageFileDescription :: GroupInfo -> Maybe GroupMember -> SharedMsgId -> FileDescr -> CM (Maybe DeliveryTaskContext)` — drop both `Maybe MemberId` params, pass `Maybe GroupMember`, determine `sentAsGroup` from `chatDir` of found item +- `groupMessageUpdate :: GroupInfo -> Maybe GroupMember -> SharedMsgId -> ... -> Maybe Bool -> CM (Maybe DeliveryTaskContext)` — drop `senderGMId_` param +- `groupMessageDelete :: GroupInfo -> Maybe GroupMember -> SharedMsgId -> ... -> CM (Maybe DeliveryTaskContext)` — drop `senderGMId_` param; fix `findOwnerCI` dual-lookup (lines 2028-2035) same as Issue 3: when `m_ = Nothing` search with `Nothing`, when `m_ = Just m` use member lookup directly +- `xFileCancelGroup :: GroupInfo -> Maybe GroupMember -> SharedMsgId -> CM (Maybe DeliveryTaskContext)` — drop both `Maybe MemberId` params + +**`validSender` simplification:** Remove second `Maybe MemberId` parameter. With `(Just m'')` always passed, validation is just: +```haskell +validSender :: Maybe MemberId -> CIDirection 'CTGroup 'MDRcv -> Bool +validSender (Just mId) (CIGroupRcv m) = sameMemberId mId m +validSender Nothing CIChannelRcv = True +validSender _ _ = False +``` + +**`isChannelDir` helper** remains as-is (line 1870-1872) — used to derive `sentAsGroup` from item's `chatDir`. + +**`memberCanSend`** (line 1436): Generic signature `a -> CM a -> CM a` — no change needed. Default values at call sites change from `(Nothing, False)` to `Nothing`. + +**`memberCanSend'`** (line 1448): Return type changes from `CM (Maybe DeliveryJobScope)` to `CM (Maybe DeliveryTaskContext)`. Used in forwarded handler (lines 3153, 3159). + +--- + +## Issue 2: groupMsgReaction required GroupMember {#issue-2} + +**File:** `src/Simplex/Chat/Library/Subscriber.hs` line 1814 + +**Problem:** `groupMsgReaction :: GroupInfo -> Maybe GroupMember -> ...` allows `Nothing`, uses `fromMaybe membership m_` fallback. + +**Fix:** Change to required `GroupMember`: +```haskell +groupMsgReaction :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe MemberId -> Maybe MsgScope -> MsgReaction -> Bool -> RcvMessage -> UTCTime -> CM (Maybe DeliveryTaskContext) +``` + +- No `reactor` binding needed — use `m` directly (eliminates `fromMaybe membership m_` fallback) +- `ciDir = CIGroupRcv (Just m)` (reactions always attributed to member) +- Always return `sentAsGroup = False` — reactions are never from channel +- Return type: `Maybe DeliveryTaskContext` (not tuple) + +**Direct handler call site (line 958-960):** +```haskell +XMsgReact sharedMsgId memberId scope_ reaction add -> + groupMsgReaction gInfo' m'' sharedMsgId memberId scope_ reaction add msg brokerTs +``` + +**Forwarded handler call site (line 3162-3163):** +```haskell +XMsgReact sharedMsgId memId_ scope_ reaction add -> + withAuthor XMsgReact_ $ \author -> groupMsgReaction gInfo author sharedMsgId memId_ scope_ reaction add rcvMsg msgTs +``` + +--- + +## Issue 3: Fix groupMessageUpdate lookup {#issue-3} + +**File:** `src/Simplex/Chat/Library/Subscriber.hs` lines 1973-1994 + +**Problem:** Dual-lookup with `catchError` tries `Nothing` first, then falls back to `senderGMId_`. This is wrong — the `asGroup_` flag from XMsgUpdate should drive the search. + +**Fix:** Use `asGroup_` (the wire flag) to determine search strategy. No `senderGMId_` parameter needed: +```haskell +updateRcvChatItem = do + (cci, scopeInfo) <- withStore $ \db -> do + cci <- case m_ of + Just m -> getGroupMemberCIBySharedMsgId db user gInfo (memberId' m) sharedMsgId + Nothing -> getGroupChatItemBySharedMsgId db user gInfo Nothing sharedMsgId + (cci,) <$> getGroupChatScopeInfoForItem db vr user gInfo (cChatItemId cci) +``` + +When `m_ = Nothing` (channel owner as channel), search with `Nothing` group_member_id → finds channel items. +When `m_ = Just m` (attributed member message), search with member's `memberId` → finds member items. + +The `isSender` check also simplifies — just check `m_` matches the found item's member. + +**Fallback path** (lines 1948-1968, `catchCINotFound`): When item not found, `showGroupAsSender` is derived from `asGroup_` flag (or defaults based on `m_`), which maps to `sentAsGroup` in the `DeliveryTaskContext`. + +--- + +## Issue 4: DeliveryTaskContext type {#issue-4} + +**File:** `src/Simplex/Chat/Delivery.hs` + +### 4a. Add DeliveryTaskContext type +```haskell +data DeliveryTaskContext = DeliveryTaskContext + { jobScope :: DeliveryJobScope, + sentAsGroup :: ShowGroupAsSender + } + deriving (Show) +``` + +Uses existing `type ShowGroupAsSender = Bool` from Messages.hs. + +### 4b. Modify existing helpers +Rename `infoToDeliveryScope` → `infoToDeliveryContext`, inline the scope logic, add `ShowGroupAsSender` parameter: +```haskell +infoToDeliveryContext :: GroupInfo -> Maybe GroupChatScopeInfo -> ShowGroupAsSender -> DeliveryTaskContext +infoToDeliveryContext GroupInfo {membership} scopeInfo sentAsGroup = DeliveryTaskContext {jobScope, sentAsGroup} + where + jobScope = case scopeInfo of + Nothing -> DJSGroup {jobSpec = DJDeliveryJob {includePending = False}} + Just GCSIMemberSupport {groupMember_} -> + let supportGMId = groupMemberId' $ fromMaybe membership groupMember_ + in DJSMemberSupport {supportGMId} +``` +Remove `infoToDeliveryScope` entirely. + +Rename `memberEventDeliveryScope` → `memberEventDeliveryContext`, change return type: +```haskell +memberEventDeliveryContext :: GroupMember -> Maybe DeliveryTaskContext +memberEventDeliveryContext m@GroupMember {memberRole, memberStatus} + | memberStatus == GSMemPendingApproval = Nothing + | memberStatus == GSMemPendingReview = Just $ DeliveryTaskContext {jobScope = DJSMemberSupport {supportGMId = groupMemberId' m}, sentAsGroup = False} + | memberRole >= GRModerator = Just $ DeliveryTaskContext {jobScope = DJSGroup {jobSpec = DJDeliveryJob {includePending = True}}, sentAsGroup = False} + | otherwise = Just $ DeliveryTaskContext {jobScope = DJSGroup {jobSpec = DJDeliveryJob {includePending = False}}, sentAsGroup = False} +``` + +### 4c. Update NewMessageDeliveryTask +```haskell +data NewMessageDeliveryTask = NewMessageDeliveryTask + { messageId :: MessageId, + taskContext :: DeliveryTaskContext + } + deriving (Show) +``` + +### 4d. MessageDeliveryTask — no change + +`MessageDeliveryTask` stays as-is. It's constructed from DB rows in `getMsgDeliveryTask_` and consumed by relay forwarding code — those consumers need `jobScope` and `fwdSender` directly, not `DeliveryTaskContext`. `DeliveryTaskContext` is only for the path from processing functions → `NewMessageDeliveryTask` creation. + +### 4e. Update Store/Delivery.hs + +**`createMsgDeliveryTask`** (line 71-87): Extract `jobScope` and `sentAsGroup` from `taskContext` instead of separate `jobScope`/`showGroupAsSender` fields. + +**`getMsgDeliveryTask_`** — no change needed (`MessageDeliveryTask` unchanged). + +### 4f. Consumers of MessageDeliveryTask — no change needed + +**Subscriber.hs** lines ~3325-3333 and **Messages/Batch.hs** lines ~77-80 already pattern match on `FwdSender` and use `jobScope` from `MessageDeliveryTask`. Since `MessageDeliveryTask` is unchanged, no updates needed. + +### 4g. Return type changes in processing functions + +All functions currently returning `(Maybe DeliveryJobScope, ShowGroupAsSender)` change to `Maybe DeliveryTaskContext`: +- `groupMessageFileDescription` → `CM (Maybe DeliveryTaskContext)` +- `groupMessageUpdate` → `CM (Maybe DeliveryTaskContext)` +- `groupMessageDelete` → `CM (Maybe DeliveryTaskContext)` +- `xFileCancelGroup` → `CM (Maybe DeliveryTaskContext)` +- `groupMsgReaction` → `CM (Maybe DeliveryTaskContext)` + +Events that return `(Nothing, False)` or `(Just scope, False)` are updated: +- `(Nothing, False)` → `Nothing` +- `(Just scope, False)` → `Just $ DeliveryTaskContext scope False` (or use `memberEventDeliveryContext`) +- `(Just scope, showGroupAsSender)` → `Just $ DeliveryTaskContext scope showGroupAsSender` (or use `infoToDeliveryContext`) + +--- + +## Issue 5: Fix testChannelReactionAttribution {#issue-5} + +**File:** `tests/ChatTests/Groups.hs` lines 9057-9084 + +**Problem:** Comment says "reaction is forwarded as channel (owner is anonymous)" and expects `#team>`. Owner should react **as member** — reactions are always `sentAsGroup = False`. + +**Fix:** Change comment and expectations: +```haskell +-- owner reacts to own member message - reaction is forwarded as member +alice ##> "+1 #team hello" +alice <## "added 👍" +bob <# "#team alice> > alice hello" +bob <## " + 👍" +concurrentlyN_ + [ do cath <# "#team alice> > alice hello" + cath <## " + 👍", + do dan <# "#team alice> > alice hello" + dan <## " + 👍", + do eve <# "#team alice> > alice hello" + eve <## " + 👍" + ] +``` + +--- + +## Issue 6: Fix testChannelUpdateFallbackSendAsGroup comment {#issue-6} + +**File:** `tests/ChatTests/Groups.hs` line 9127 + +**Problem:** Comment says "bob's internally deleted item is still in DB, update finds it with correct member direction". This is wrong — the item was internally deleted, then XMsgUpdate re-creates it via the `catchCINotFound` fallback. + +**Fix:** Change comment to: +```haskell +-- bob's internally deleted item is re-created as from member (sendAsGroup=False) +``` + +--- + +## Other: sendAsGroup parameter ordering {#other-issue} + +**Problem:** `sendAsGroup`/`ShowGroupAsSender` should come right after direction/scope, not at the end. + +### 7a. `APIForwardChatItems` constructor + +**File:** `src/Simplex/Chat/Library/Commands.hs` (ChatCommand type definition + parser) + +Current: `APIForwardChatItems toChat fromChat itemIds itemTTL sendAsGroup` +New: `APIForwardChatItems toChat sendAsGroup fromChat itemIds itemTTL` + +Affects: +- Constructor definition in `src/Simplex/Chat/Controller.hs` line 341 +- Parser at line 4639 +- Call sites at lines 930, 2192, 2198, 2204 + +### 7b. `createNewSndChatItem` + +**File:** `src/Simplex/Chat/Store/Messages.hs` line 528 + +Current: `createNewSndChatItem db user chatDirection msg ciContent quotedItem itemForwarded timed live hasLink showGroupAsSender createdAt` +New: `createNewSndChatItem db user chatDirection showGroupAsSender msg ciContent quotedItem itemForwarded timed live hasLink createdAt` + +Move `showGroupAsSender` right after `chatDirection` (direction context). + +Affects call site in `Internal.hs` line 2276. + +### 7c. `saveSndChatItems` + +**File:** `src/Simplex/Chat/Library/Internal.hs` line 2256-2265 + +Current param order: `user -> cd -> itemsData -> itemTimed -> live -> showGroupAsSender` +New: `user -> cd -> showGroupAsSender -> itemsData -> itemTimed -> live` + +Move `showGroupAsSender` right after `cd` (direction context). + +Affects call sites: Internal.hs line 2242, Commands.hs lines 2561, 2608 (and the `saveSndChatItem'` wrapper at line 2240). + +### 7d. `prepareGroupMsg` + +**File:** `src/Simplex/Chat/Library/Internal.hs` line 203 + +Current: `prepareGroupMsg db user gInfo msgScope mc mentions quotedItemId_ itemForwarded fInv_ timed_ live showGroupAsSender` +New: `prepareGroupMsg db user gInfo msgScope showGroupAsSender mc mentions quotedItemId_ itemForwarded fInv_ timed_ live` + +Move `showGroupAsSender` right after `msgScope` (scope context). + +Affects call sites: Internal.hs line 1249, Commands.hs line 4094. + +--- + +## Forwarded handler (xGrpMsgForward) changes + +**File:** `src/Simplex/Chat/Library/Subscriber.hs` lines 3136-3173 + +Add `withAuthor` helper to replace ad-hoc `| Just author <- author_` guards: +```haskell +where + withAuthor :: CMEventTag e -> (GroupMember -> CM ()) -> CM () + withAuthor tag action = case author_ of + Just author -> action author + Nothing -> messageError $ "x.grp.msg.forward: event " <> tshow tag <> " requires author" +``` + +Update forwarded event handling: +- `XMsgFileDescr` → pass `author_` (Maybe GroupMember) directly +- `XMsgUpdate` → pass `author_` directly, void result +- `XMsgDel` → pass `author_` directly, void result +- `XMsgReact` → use `withAuthor` (required member) +- `XFileCancel` → pass `author_` directly +- Other events with `| Just author <- author_` → use `withAuthor` + +--- + +## Files Modified + +| File | Changes | +|------|---------| +| `src/Simplex/Chat/Delivery.hs` | Add `DeliveryTaskContext`, update `NewMessageDeliveryTask` only | +| `src/Simplex/Chat/Store/Delivery.hs` | Update `createMsgDeliveryTask` to extract from `taskContext` | +| `src/Simplex/Chat/Library/Subscriber.hs` | Eliminate `isChannelOwner`/`memberForChannel`/`memberIdForChannel`; change function signatures to return `Maybe DeliveryTaskContext`; add `withAuthor`; simplify `validSender`; `groupMsgReaction` required member; fix lookup | +| `src/Simplex/Chat/Controller.hs` | Reorder `sendAsGroup` in `APIForwardChatItems` constructor | +| `src/Simplex/Chat/Library/Commands.hs` | Reorder `sendAsGroup` in `APIForwardChatItems` parser + call sites | +| `src/Simplex/Chat/Store/Messages.hs` | Reorder `showGroupAsSender` in `createNewSndChatItem` | +| `src/Simplex/Chat/Library/Internal.hs` | Reorder `showGroupAsSender` in `saveSndChatItems`, `prepareGroupMsg` | +| `src/Simplex/Chat/Messages/Batch.hs` | No change needed (`MessageDeliveryTask` unchanged) | +| `tests/ChatTests/Groups.hs` | Fix reaction test expectations + update fallback comment | + +--- + +## Verification + +1. `cabal build --ghc-options=-O0` — must compile clean +2. Run channel test suite: `cabal test simplex-chat-test --test-option='-m "channels"' --ghc-options=-O0` +3. Adversarial self-review loop until 2 consecutive clean passes +4. Verify no `isChannelOwner` references remain in Subscriber.hs direct handler +5. Verify `groupMsgReaction` signature has required `GroupMember` (no Maybe) +6. Verify no dual-lookup with `catchError` in `groupMessageUpdate` diff --git a/plans/group_channel_feature_coverage.md b/plans/group_channel_feature_coverage.md new file mode 100644 index 0000000000..f4b6e49353 --- /dev/null +++ b/plans/group_channel_feature_coverage.md @@ -0,0 +1,377 @@ +# Group & Channel Feature Test Coverage Plan + +## Table of Contents + +1. [Executive Summary](#executive-summary) +2. [Feature Coverage Matrix](#feature-coverage-matrix) +3. [Gap Analysis by Category](#gap-analysis-by-category) +4. [Recommended New Tests](#recommended-new-tests) +5. [Implementation Roadmap](#implementation-roadmap) + +--- + +## Executive Summary + +**Current State:** The test suite in `Groups.hs` provides comprehensive coverage across 120+ scenarios in 14 categories. Core functionality (group CRUD, messaging, member management) is well-tested. + +**Key Gaps Identified:** +- Business/contact card group links (untested invitation flow) +- Legacy group link auto-accept path +- Permission enforcement for `SGFFullDelete` +- Error recovery paths (file transfers, database busy, duplicate forwarding) +- Moderator-only scoped message delivery (`DJSMemberSupport`) +- Edge cases in channel message deletion + +**Risk Assessment:** +| Priority | Gap Count | Impact | +|----------|-----------|--------| +| Critical | 3 | Production failures in business flows | +| High | 5 | Feature regressions possible | +| Medium | 4 | Edge case handling incomplete | + +**Recommendation:** Add 12 new test scenarios in 3 phases over 2 sprints. + +--- + +## Feature Coverage Matrix + +### Legend +- ✅ Tested (comprehensive) +- ⚠️ Partial (some paths covered) +- ❌ Untested + +### Core Group Operations + +| Feature | Status | Test Location | Notes | +|---------|--------|---------------|-------| +| Group creation | ✅ | `testGroup` | Basic + edge cases | +| Group deletion | ✅ | `testGroupDelete*` | Multiple scenarios | +| Group naming/description | ✅ | `testUpdateGroupProfile` | | +| Group preferences | ✅ | `testGroupPreferences` | Voice, files, etc. | +| Group link creation | ✅ | `testGroupLink*` | | +| Group link via contact card | ❌ | - | Business links untested | +| Legacy auto-accept | ❌ | - | Deprecated path | + +### Message Operations + +| Feature | Status | Test Location | Notes | +|---------|--------|---------------|-------| +| XMsgNew (send) | ✅ | Multiple | Core flow | +| XMsgUpdate (edit) | ✅ | `testGroupMessageUpdate` | | +| XMsgDel (delete) | ✅ | `testGroupMessageDelete` | | +| XMsgReact | ✅ | `testGroupMsgReaction` | | +| XMsgFileDescr | ✅ | `testGroupFileTransfer` | | +| Batch messages | ✅ | `testBatch*` | | +| Live messages | ✅ | `testGroupLiveMessage` | | +| Quote messages | ✅ | `testGroup*Quote*` | | +| Duplicate forwarding | ❌ | - | De-dup logic untested | + +### Member Management + +| Feature | Status | Test Location | Notes | +|---------|--------|---------------|-------| +| Member add | ✅ | `testGroupAddMember*` | | +| Member remove | ✅ | `testGroupRemoveMember*` | | +| Member roles | ✅ | `testGroupMemberRole*` | | +| Member blocking | ✅ | `testGroupBlock*` | | +| Member merging | ✅ | `testMergeMemberContact*` | | +| Member deletion errors | ❌ | - | Error paths missing | +| Contact from member | ✅ | `testCreateMemberContact*` | | + +### Moderation & Full Delete + +| Feature | Status | Test Location | Notes | +|---------|--------|---------------|-------| +| Moderate message | ✅ | `testGroupModerate*` | | +| Block for all | ✅ | `testGroupBlockForAll*` | | +| SGFFullDelete enabled | ✅ | `testFullDeleteGroup*` | | +| SGFFullDelete restricted | ❌ | - | Permission checks | + +### Channels & Relays + +| Feature | Status | Test Location | Notes | +|---------|--------|---------------|-------| +| 1-relay delivery | ✅ | `testChannel1Relay*` | | +| 2-relay delivery | ✅ | `testChannel2Relay*` | | +| Owner-only sending | ✅ | `testChannel*Message*` | | +| Identity protection | ✅ | `testChannel*Incognito*` | | +| Channel msg delete errors | ❌ | - | Invalid state handling | + +### Scoped Messages (Support Chats) + +| Feature | Status | Test Location | Notes | +|---------|--------|---------------|-------| +| Single moderator | ✅ | `testSupportChat*` | | +| Multi moderator | ✅ | `testSupportChat*Multi*` | | +| Member reports | ✅ | `testReportMessage*` | | +| Forwarding in scope | ✅ | `testSupportChatForward*` | | +| Stats | ✅ | `testSupportChatStats` | | +| DJSMemberSupport delivery | ❌ | - | Moderator-only path | + +### Group Links & Invitations + +| Feature | Status | Test Location | Notes | +|---------|--------|---------------|-------| +| Create/delete link | ✅ | `testGroupLink*` | | +| Join via link | ✅ | `testGroupLink*` | | +| Link screening | ✅ | `testGroupLink*Screening*` | | +| Connection plans | ✅ | `testPlanGroupLink*` | | +| Short links | ✅ | `testGroupShortLink*` | | +| Business link invitation | ❌ | - | Contact card flow | + +### Error Handling + +| Feature | Status | Test Location | Notes | +|---------|--------|---------------|-------| +| CEGroupNotJoined | ⚠️ | Implicit | Some coverage | +| CEGroupMemberNotFound | ⚠️ | Implicit | Some coverage | +| File transfer errors | ❌ | - | Recovery paths | +| Database busy | ❌ | - | Retry logic | +| Simplex link warnings | ❌ | - | Feature gate | + +### History & Disappearing + +| Feature | Status | Test Location | Notes | +|---------|--------|---------------|-------| +| History on join | ✅ | `testGroupHistory*` | | +| File history | ✅ | `testGroupHistoryFiles` | | +| Disappearing messages | ✅ | `testGroupHistoryDisappear*` | | + +--- + +## Gap Analysis by Category + +### Critical Priority (Production Impact) + +#### 1. Business Group Link via Contact Card +**Location:** `APIAddMember` with `InvitationContact` path +**Risk:** Business users cannot invite via contact cards +**Current State:** Only `InvitationMember` path tested +**Missing Coverage:** +- `processGroupInvitation` with `CTContactRequest` +- Auto-accept flow for business links +- Profile merge on business join + +#### 2. SGFFullDelete Permission Enforcement +**Location:** `canFullDelete`, `checkFullDeleteAllowed` +**Risk:** Non-admins might delete others' messages +**Missing Coverage:** +- `SGFFullDelete` set to `FAAdmins` restriction +- Error `CECommandError` when non-admin attempts full delete +- Role-based permission matrix + +#### 3. DJSMemberSupport Delivery Path +**Location:** `deliverGroupMessages`, `groupMsgDeliveryJobs` +**Risk:** Support messages not reaching moderators correctly +**Missing Coverage:** +- `DJSMemberSupport` job creation +- Moderator-only broadcast logic +- Scope isolation verification + +### High Priority (Feature Regressions) + +#### 4. Channel Message Deletion Errors +**Location:** `apiDeleteMemberChatItem`, `deleteGroupChatItemInternal` +**Missing Coverage:** +- Delete non-existent channel message +- Delete by non-owner in channel +- `CEInvalidChatItemDelete` error path + +#### 5. Member Deletion Error Paths +**Location:** `removeMemberDeleteItem`, `deleteGroupChatItem` +**Missing Coverage:** +- Delete item for already-removed member +- Concurrent deletion race condition +- `CEGroupMemberNotFound` specific handling + +#### 6. File Transfer Error Recovery +**Location:** `rcvFileError`, `sndFileError` +**Missing Coverage:** +- Partial transfer resume +- `CEFileTransferError` handling +- Cleanup on failed transfers + +#### 7. Legacy Group Link Auto-Accept +**Location:** `processGroupInvitation`, `autoAcceptGroupLink` +**Risk:** Breaking change for older clients +**Missing Coverage:** +- V1 protocol compatibility +- Auto-accept timing + +#### 8. Duplicate Message Forwarding +**Location:** `forwardGroupMessage`, `checkDuplicateForward` +**Missing Coverage:** +- Same message forwarded twice +- De-duplication by `sharedMsgId` +- UI state consistency + +### Medium Priority (Edge Cases) + +#### 9. Simplex Links Feature Warnings +**Location:** `simplexLinkWarning`, `SGFSimplexLinks` +**Missing Coverage:** +- Warning when feature disabled +- Link detection in messages +- User preference override + +#### 10. Database Busy Error Handling +**Location:** `withTransaction`, `retryOnBusy` +**Missing Coverage:** +- Concurrent group operations +- Retry exhaustion +- State consistency after retry + +#### 11. Invalid Channel/Member Scope Errors +**Location:** `validateGroupChatScope`, `scopeNotAllowed` +**Missing Coverage:** +- Member sending to wrong scope +- Scope mismatch on receive +- `CECommandError "scope not allowed"` path + +#### 12. Contact Card Profile Merge +**Location:** `mergeMemberContactProfile`, `updateContactProfile` +**Missing Coverage:** +- Profile conflict resolution +- Image merge logic +- Display name precedence + +--- + +## Recommended New Tests + +### Phase 1: Critical (Sprint 1) + +```haskell +-- Test 1: Business Group Link Invitation +testBusinessGroupLinkInvitation :: HasCallStack => TestParams -> IO () +-- Covers: InvitationContact path, CTContactRequest, auto-accept + +-- Test 2: Full Delete Permission Restriction +testFullDeletePermissionRestricted :: HasCallStack => TestParams -> IO () +-- Covers: SGFFullDelete FAAdmins, non-admin rejection, CECommandError + +-- Test 3: Moderator-Only Support Delivery +testSupportChatModeratorOnlyDelivery :: HasCallStack => TestParams -> IO () +-- Covers: DJSMemberSupport, moderator broadcast, scope isolation +``` + +### Phase 2: High (Sprint 1-2) + +```haskell +-- Test 4: Channel Message Delete Errors +testChannelMessageDeleteErrors :: HasCallStack => TestParams -> IO () +-- Covers: non-existent delete, non-owner delete, CEInvalidChatItemDelete + +-- Test 5: Member Deletion Error Paths +testMemberDeletionErrorPaths :: HasCallStack => TestParams -> IO () +-- Covers: removed member delete, concurrent delete, CEGroupMemberNotFound + +-- Test 6: File Transfer Error Recovery +testGroupFileTransferErrorRecovery :: HasCallStack => TestParams -> IO () +-- Covers: partial resume, CEFileTransferError, cleanup + +-- Test 7: Legacy Group Link Compatibility +testLegacyGroupLinkAutoAccept :: HasCallStack => TestParams -> IO () +-- Covers: V1 protocol, auto-accept timing + +-- Test 8: Duplicate Forward Prevention +testDuplicateMessageForwardPrevention :: HasCallStack => TestParams -> IO () +-- Covers: duplicate detection, sharedMsgId, UI consistency +``` + +### Phase 3: Medium (Sprint 2) + +```haskell +-- Test 9: Simplex Links Feature Warning +testSimplexLinksFeatureWarning :: HasCallStack => TestParams -> IO () +-- Covers: disabled feature warning, link detection + +-- Test 10: Database Busy Retry +testGroupOperationsDatabaseBusy :: HasCallStack => TestParams -> IO () +-- Covers: concurrent ops, retry logic, state consistency + +-- Test 11: Scope Validation Errors +testGroupChatScopeValidationErrors :: HasCallStack => TestParams -> IO () +-- Covers: wrong scope send, scope mismatch, CECommandError + +-- Test 12: Contact Card Profile Merge +testMemberContactProfileMerge :: HasCallStack => TestParams -> IO () +-- Covers: conflict resolution, image merge, name precedence +``` + +--- + +## Implementation Roadmap + +### Sprint 1 (Week 1-2) + +| Day | Task | Owner | Deliverable | +|-----|------|-------|-------------| +| 1-2 | Test 1: Business link | - | PR ready | +| 3-4 | Test 2: Full delete perms | - | PR ready | +| 5 | Test 3: Moderator delivery | - | PR ready | +| 6-7 | Test 4: Channel delete errors | - | PR ready | +| 8-9 | Test 5: Member delete errors | - | PR ready | +| 10 | Integration + Review | - | Merged | + +### Sprint 2 (Week 3-4) + +| Day | Task | Owner | Deliverable | +|-----|------|-------|-------------| +| 1-2 | Test 6: File error recovery | - | PR ready | +| 3-4 | Test 7: Legacy link compat | - | PR ready | +| 5-6 | Test 8: Duplicate forward | - | PR ready | +| 7-8 | Tests 9-12: Medium priority | - | PR ready | +| 9-10 | Final integration + CI | - | Release | + +### Dependencies + +``` +Test 1 (Business Link) ─┬─> Test 12 (Profile Merge) + │ +Test 3 (Moderator) ─────┴─> Test 11 (Scope Validation) + +Test 4 (Channel Delete) ──> Test 5 (Member Delete) + +Test 6 (File Error) ──────> (standalone) + +Test 7 (Legacy Link) ─────> Test 1 (Business Link) + +Test 8 (Duplicate) ───────> (standalone) + +Tests 9, 10 ──────────────> (standalone) +``` + +### Success Criteria + +1. **Coverage Target:** 95%+ of identified gaps covered +2. **CI Integration:** All tests in nightly suite +3. **Documentation:** Test rationale in docstrings +4. **No Regressions:** Existing 120+ tests still pass + +### Risk Mitigation + +| Risk | Mitigation | +|------|------------| +| Test flakiness | Use explicit waits, avoid timing assumptions | +| Database state leaks | Ensure proper cleanup in each test | +| Protocol version issues | Test both V1 and V2 where applicable | +| CI timeout | Parallelize independent tests | + +--- + +## Appendix: Test File Locations + +| Test Category | Primary File | Secondary | +|---------------|--------------|-----------| +| Group Core | `tests/ChatTests/Groups.hs` | - | +| Channels | `tests/ChatTests/Groups.hs` | `Channels/` if split | +| Support Chats | `tests/ChatTests/Groups.hs` | `ScopedMessages/` if split | +| File Transfers | `tests/ChatTests/Files.hs` | `Groups.hs` | +| Error Handling | Inline with feature tests | - | + +--- + +*Generated: 2026-02-06* +*Branch: ep/channel-messages-2* +*Coverage baseline: 120+ scenarios, 14 categories* diff --git a/plans/groups_coverage_fill_plan.md b/plans/groups_coverage_fill_plan.md new file mode 100644 index 0000000000..ffe0b7a52c --- /dev/null +++ b/plans/groups_coverage_fill_plan.md @@ -0,0 +1,368 @@ +# Plan: Filling Group/Channel Test Coverage Gaps + +## Table of Contents +1. [Executive Summary](#executive-summary) +2. [Test File Organization](#test-file-organization) +3. [Priority 0: Critical Channel Paths](#priority-0-critical-channel-paths) +4. [Priority 1: Error and Fallback Paths](#priority-1-error-and-fallback-paths) +5. [Priority 2: Scope-Related Features](#priority-2-scope-related-features) +6. [Priority 3: Feature Restrictions](#priority-3-feature-restrictions) + +--- + +## Executive Summary + +This plan addresses the coverage gaps identified in `groups_test_coverage.md`, focusing exclusively on DSL-based scenario tests using the existing test infrastructure. All tests follow patterns established in `tests/ChatTests/Groups.hs`. + +**Excluded from scope:** JSON serialization tests (per user request). + +**Key gap categories:** +- Non-channel-owner members sending in channel groups +- Moderation/delete paths in channels (`memberDelete`) +- Error fallback paths (`catchCINotFound`) +- Member support scope (`GCSIMemberSupport`) +- Full-delete feature, live updates, mentions + +--- + +## Test File Organization + +All new tests go in `tests/ChatTests/Groups.hs` under existing or new `describe` blocks. + +### New `describe` blocks to add: + +```haskell +describe "channel moderation" $ do + -- Tests for memberDelete path, channel moderation errors + +describe "channel error paths" $ do + -- Tests for catchCINotFound, invalid sender, etc. + +describe "channel mentions" $ do + -- Tests for mentions in channel messages + +describe "group full delete feature" $ do + -- Tests for SGFFullDelete enabled +``` + +--- + +## Priority 0: Critical Channel Paths + +### Test 1: `testChannelMemberModerate` +**File:** `tests/ChatTests/Groups.hs` +**Add to:** `describe "channel moderation"` + +**Objective:** Cover `memberDelete` path in `groupMessageDelete` (lines 2016-2076) - moderation of channel messages by admin/owner. + +**Scenario:** +1. Create channel with owner (alice) + relay (bob) + members (cath, dan) +2. Owner sends channel message +3. Admin/owner moderates (deletes) the channel message +4. Verify message marked deleted for all members +5. Verify moderation event is forwarded + +**Coverage targets:** +- `memberDelete` function execution +- `moderate` helper with role checks +- `delete` with `delMember_` populated + +--- + +### Test 2: `testChannelMemberDeleteError` +**File:** `tests/ChatTests/Groups.hs` +**Add to:** `describe "channel error paths"` + +**Objective:** Cover error path `CIChannelRcv -> messageError "x.msg.del: unexpected channel message in member delete"` (line 2036). + +**Scenario:** +1. Create channel with owner + relay + member +2. Attempt to trigger memberDelete on CIChannelRcv item (malformed delete request) +3. Verify error is logged/handled correctly + +**Coverage targets:** +- Line 2036: `CIChannelRcv` error case in `memberDelete` + +--- + +### Test 3: `testChannelUpdateNotFound` +**File:** `tests/ChatTests/Groups.hs` +**Add to:** `describe "channel error paths"` + +**Objective:** Cover `catchCINotFound` fallback in `groupMessageUpdate` (lines 1950-1969) - update arrives for locally deleted item. + +**Scenario:** +1. Create channel with owner + relay + member +2. Owner sends message, member receives +3. Member locally deletes the message +4. Owner updates the message +5. Verify member creates new item from update (fallback path) + +**Coverage targets:** +- Line 1960: `Nothing -> pure (CDChannelRcv gInfo Nothing, M.empty, Nothing)` +- Lines 1951-1969: create-from-update fallback + +--- + +### Test 4: `testChannelReactionNotFound` +**File:** `tests/ChatTests/Groups.hs` +**Add to:** `describe "channel error paths"` + +**Objective:** Cover `catchCINotFound` fallback in `groupMsgReaction` (lines 1823-1837) - reaction on locally deleted item. + +**Scenario:** +1. Create channel with owner + relay + member +2. Owner sends message, member receives +3. Member locally deletes the message +4. Owner adds reaction +5. Verify reaction is handled without crash + +**Coverage targets:** +- Lines 1835-1837: channel reaction fallback + +--- + +### Test 5: `testChannelForwardedMessages` +**File:** `tests/ChatTests/Groups.hs` +**Add to:** `describe "relay delivery"` (existing) + +**Objective:** Cover `FwdChannel` branch in delivery task (line 3311) and forwarded message parameters. + +**Scenario:** +1. Create channel with owner + 2 relays + members +2. Send various message types (new, update, delete, reaction) +3. Verify all are forwarded through relay chain +4. Check forwarded parameters are correctly passed + +**Coverage targets:** +- Line 3311: `FwdChannel -> (Nothing, Nothing)` +- Lines 3139-3145: forwarded message handlers + +--- + +## Priority 1: Error and Fallback Paths + +### Test 6: `testGroupDeleteNotFound` +**File:** `tests/ChatTests/Groups.hs` +**Add to:** `describe "channel error paths"` or existing moderation tests + +**Objective:** Cover delete error when message not found (line 2039). + +**Scenario:** +1. Create group with alice, bob +2. Bob sends message +3. Alice locally deletes it +4. Bob broadcasts delete for the same message +5. Verify error path is handled + +**Coverage targets:** +- Line 2039: `messageError ("x.msg.del: message not found, " <> tshow e)` + +--- + +### Test 7: `testGroupInvalidSenderUpdate` +**File:** `tests/ChatTests/Groups.hs` +**Add to:** `describe "channel error paths"` + +**Objective:** Cover `validSender _ _ = False` (line 1874) and update from wrong member error (line 1980). + +**Scenario:** +1. Create group with alice, bob, cath +2. Bob sends message +3. Cath (with spoofed member ID) attempts to update bob's message +4. Verify error is thrown + +**Coverage targets:** +- Line 1874: `validSender _ _ = False` +- Line 1980: `messageError "x.msg.update: group member attempted to update..."` + +--- + +### Test 8: `testGroupReactionDisabled` +**File:** `tests/ChatTests/Groups.hs` +**Add to:** existing `describe "group message reactions"` + +**Objective:** Cover reaction disabled path (line 1839). + +**Scenario:** +1. Create group with reactions feature disabled +2. Member attempts to add reaction +3. Verify reaction is rejected + +**Coverage targets:** +- Line 1839: `otherwise = pure Nothing` when reactions not allowed + +--- + +### Test 9: `testChannelItemNotChanged` +**File:** `tests/ChatTests/Groups.hs` +**Add to:** `describe "channel message operations"` (existing) + +**Objective:** Cover `CEvtChatItemNotChanged` path (lines 2001-2002) - update with same content. + +**Scenario:** +1. Create channel with owner + relay + member +2. Owner sends message +3. Owner "updates" message with identical content +4. Verify no change event is emitted + +**Coverage targets:** +- Lines 2001-2002: `CEvtChatItemNotChanged` path + +--- + +## Priority 2: Scope-Related Features + +### Test 10: `testScopedSupportMentions` +**File:** `tests/ChatTests/Groups.hs` +**Add to:** `describe "group scoped messages"` (existing) + +**Objective:** Cover mentions in scoped support messages (`getRcvCIMentions` with non-empty mentions). + +**Scenario:** +1. Create group with alice (owner), bob (member), dan (moderator) +2. Bob sends support message mentioning @alice +3. Alice receives with mention highlighted +4. Verify `userMention` flag is set correctly + +**Coverage targets:** +- Line 2316: `getRcvCIMentions` with actual mentions +- Line 2319: `sameMemberId mId membership` in userReply check +- Lines 279-281: `uniqueMsgMentions` path + +--- + +### Test 11: `testMemberChatStats` +**File:** `tests/ChatTests/Groups.hs` +**Add to:** `describe "group scoped messages"` (existing) + +**Objective:** Cover `memberChatStats` function (lines 2323-2330) for both `CDGroupRcv` and `CDChannelRcv` with scope. + +**Scenario:** +1. Create group with support enabled +2. Member sends support message +3. Verify unread stats are updated +4. Verify `memberAttentionChange` is computed + +**Coverage targets:** +- Lines 2325-2329: `memberChatStats` branches +- Line 2621: `memberAttentionChange` + +**Note:** Tests `testScopedSupportUnreadStatsOnRead` and `testScopedSupportUnreadStatsOnDelete` exist but may not cover all branches. + +--- + +### Test 12: `testMkGetMessageChatScope` +**File:** `tests/ChatTests/Groups.hs` +**Add to:** `describe "group scoped messages"` (existing) + +**Objective:** Cover `mkGetMessageChatScope` branches (lines 1599-1617). + +**Scenario:** +1. Create group with pending member (knocking) +2. Pending member sends message with scope +3. Verify correct scope resolution +4. Test with `isReport mc` content type + +**Coverage targets:** +- Line 1601: `Just _scopeInfo` return +- Line 1604: `isReport mc` branch +- Lines 1610-1617: `sameMemberId` and `otherwise` branches + +--- + +## Priority 3: Feature Restrictions + +### Test 13: `testGroupFullDelete` +**File:** `tests/ChatTests/Groups.hs` +**Add to:** new `describe "group full delete feature"` + +**Objective:** Cover `groupFeatureAllowed SGFFullDelete` = True path (line 2067) - `deleteGroupCIs` instead of `markGroupCIsDeleted`. + +**Scenario:** +1. Create group with full delete enabled: `/set delete #team on` +2. Bob sends message +3. Alice (or bob) deletes message +4. Verify message is fully deleted (not just marked) + +**Coverage targets:** +- Line 2067: `deleteGroupCIs` path +- `groupFeatureAllowed SGFFullDelete` returns True + +--- + +### Test 14: `testGroupLiveMessage` +**File:** `tests/ChatTests/Groups.hs` +**Note:** `testGroupLiveMessage` exists but may not cover update path. + +**Objective:** Cover live message update path (line 830 in View.hs, `itemLive == Just True`). + +**Scenario:** +1. Create group +2. Send live message +3. Update live message content +4. Verify live update is processed + +**Coverage targets:** +- Line 830: `itemLive == Just True && not liveItems -> []` +- Live update in `groupMessageUpdate` + +--- + +### Test 15: `testGroupVoiceDisabled` +**File:** `tests/ChatTests/Groups.hs` +**Add to:** existing tests or new `describe "group feature restrictions"` + +**Objective:** Cover voice message rejection (line 342 in Internal.hs). + +**Scenario:** +1. Create group with voice disabled: `/set voice #team off` +2. Member attempts to send voice message +3. Verify rejection + +**Coverage targets:** +- Line 342: `isVoice mc && not (groupFeatureMemberAllowed SGFVoice m gInfo)` + +--- + +### Test 16: `testGroupReportsDisabled` +**File:** `tests/ChatTests/Groups.hs` +**Add to:** `describe "group member reports"` (existing) + +**Objective:** Cover reports disabled path (line 344 in Internal.hs). + +**Scenario:** +1. Create group with reports disabled +2. Member attempts to send report +3. Verify rejection + +**Coverage targets:** +- Line 344: `isReport mc && ... not (groupFeatureAllowed SGFReports gInfo)` + +--- + +## Implementation Order + +1. **Phase 1 (P0):** Tests 1-5 - Critical channel paths +2. **Phase 2 (P1):** Tests 6-9 - Error and fallback paths +3. **Phase 3 (P2):** Tests 10-12 - Scope-related features +4. **Phase 4 (P3):** Tests 13-16 - Feature restrictions + +Each test should: +- Use existing DSL operators (`##>`, `<#`, `#$>`, etc.) +- Follow naming convention `test` +- Include `HasCallStack` constraint +- Use appropriate test helpers (`createGroup2`, `createChannel1Relay`, etc.) + +--- + +## Dependencies + +- Existing test infrastructure in `ChatTests.Utils` +- Helper functions: `createChannel1Relay`, `createGroup2`, `createGroup3`, etc. +- DSL operators for assertions + +## Estimated New Tests: 16 + +## Files Modified: 1 +- `tests/ChatTests/Groups.hs` diff --git a/plans/groups_test_coverage.md b/plans/groups_test_coverage.md new file mode 100644 index 0000000000..7ee01f1d6f --- /dev/null +++ b/plans/groups_test_coverage.md @@ -0,0 +1,441 @@ +# Group/Channel Test Coverage Analysis + +Coverage run: `cabal test simplex-chat-test --enable-coverage --ghc-options=-O0 --test-options="-m group"` + +Full 164 group tests executed (151 passed, 13 failed due to unrelated issues). + +## Coverage Summary + +After running all group tests: +- Expressions: 48% +- Alternatives: 33% +- Local declarations: 64% +- Top-level: 34% + +--- + +## What IS Covered (Channel-Specific Paths) + +- `createNewRcvChatItem` with `CDChannelRcv` - channel message creation +- `toGroupChatItem` with `showGroupAsSender = True` - channel message reading +- `validSender Nothing CIChannelRcv = True` - channel sender validation +- `getGroupChatItemBySharedMsgId` with `Nothing` memberId (`IS NOT DISTINCT FROM`) +- `toCIDirection CDChannelRcv -> CIChannelRcv` +- `toChatInfo CDChannelRcv g s -> GroupChat g s` +- `chatItemMember CIChannelRcv -> Nothing` +- `viewChatItem` for both `CIGroupRcv` and `CIChannelRcv` +- `viewItemReaction` dispatch to `groupReaction` for both constructors +- Channel delete happy path (`channelDelete` -> `delete Nothing`) + +--- + +## Uncovered Code Paths + +### 1. Subscriber.hs + +#### `processGroupMessage` dispatch (lines 935-972) + +| Line | Code | Status | +|------|------|--------| +| 956 | `asGroup == Just True && memberRole' m'' < GROwner` | tickonlyfalse - rejecting non-owner sending as group never tested | +| 963 | `ttl` parameter in `groupMessageUpdate` | nottickedoff | +| 965 | `scope_` parameter in `groupMsgReaction` | nottickedoff | +| 967 | `XFile` handler | nottickedoff | +| 970 | `XFileAcptInv` handler | nottickedoff | +| 987 | `XGrpPrefs` handler | nottickedoff | +| 993 | `BFileChunk` handler | nottickedoff | +| 994 | Catch-all `_` for unsupported messages | nottickedoff | + +#### `memberCanSend` / `memberCanSend'` (lines 1446-1454) + +| Line | Code | Status | +|------|------|--------| +| 1449 | `memberPending m` part of condition | tickonlytrue - never false | +| 1450 | `otherwise` branch (error "member is not allowed to send messages") | nottickedoff | + +#### `newGroupContentMessage` (lines 1876-1940) + +| Line | Code | Status | +|------|------|--------| +| 1879 | `vr` parameter in `mkGetMessageChatScope` | nottickedoff | +| 1882 | `ft_` and `False` parameters to `prohibitedGroupContent` | nottickedoff | +| 1883 | `rejected` helper invocation | nottickedoff | +| 1895 | `mentions` parameter for channel messages | nottickedoff | +| 1896 | `pure []` for reactions when `sharedMsgId_` is Nothing | nottickedoff | +| 1901 | `rejected` function body | nottickedoff | +| 1902 | `Just Nothing` for timed_ when forwarded | nottickedoff | +| 1910 | `M.empty` for mentions when blocked | tickonlyfalse | +| 1914 | `gInfo'` and `m'` params to `processFileInv` | nottickedoff | + +#### `groupMessageUpdate` (lines 1943-2002) + +| Line | Code | Status | +|------|------|--------| +| 1960 | `Nothing -> pure (CDChannelRcv gInfo Nothing, M.empty, Nothing)` | nottickedoff - channel catchCINotFound | +| 1967 | `CDChannelRcv {} -> pure ci'` | nottickedoff | +| 1977 | `mentions' = if memberBlocked m then []` | tickonlyfalse | +| 1980 | `otherwise -> messageError "x.msg.update: group member attempted to update..."` | nottickedoff | +| 1984 | `messageError "x.msg.update: invalid message update"` | nottickedoff | +| 2001-2002 | `CEvtChatItemNotChanged` path | nottickedoff | + +#### `groupMessageDelete` (lines 2004-2076) + +**channelDelete path:** +| Line | Code | Status | +|------|------|--------| +| 2013 | `messageError "x.msg.del: invalid channel message delete"` | nottickedoff | +| 2015 | `messageError ("x.msg.del: channel message not found, " <> tshow e)` | nottickedoff | + +**memberDelete path:** +| Line | Code | Status | +|------|------|--------| +| 2028 | `messageError "x.msg.del: member attempted invalid message delete"` | tickonlyfalse | +| 2036 | `CIChannelRcv -> messageError "x.msg.del: unexpected channel message..."` | nottickedoff | +| 2039 | `messageError ("x.msg.del: message not found, " <> tshow e)` | tickonlyfalse | +| 2041-2042 | `messageError "...message of another member with insufficient..."` | tickonlyfalse | +| 2044-2047 | `createCIModeration` scoped moderation path | nottickedoff | + +**moderate helper:** +| Line | Code | Status | +|------|------|--------| +| 2058 | `messageError "x.msg.del: message of another member with incorrect memberId"` | nottickedoff | +| 2059 | `messageError "x.msg.del: message of another member without memberId"` | nottickedoff | +| 2062 | `messageError "...insufficient member permissions"` | tickonlyfalse | + +#### `groupMsgReaction` (lines 1818-1860) + +| Line | Code | Status | +|------|------|--------| +| 1823-1837 | Entire `catchCINotFound` fallback | nottickedoff | +| 1825-1831 | Scoped reaction path for member with scope | nottickedoff | +| 1832-1834 | Regular group reaction when item not found | nottickedoff | +| 1835-1837 | Channel reaction when item not found | nottickedoff | +| 1839 | `otherwise = pure Nothing` when reactions not allowed | tickonlyfalse | +| 1859 | `Nothing` return for channel (`isJust m_` is False) | nottickedoff | +| 1860 | `pure Nothing` when `ciReactionAllowed` is False | nottickedoff | + +#### `validSender` (lines 1871-1874) + +| Line | Code | Status | +|------|------|--------| +| 1872 | `validSender (Just mId) (CIGroupRcv m) = sameMemberId mId m` | nottickedoff | +| 1873 | `validSender Nothing CIChannelRcv = True` | **covered** | +| 1874 | `validSender _ _ = False` | nottickedoff | + +#### `processForwardedMsg` / `xGrpMsgForward` (lines 3127-3153) + +| Line | Code | Status | +|------|------|--------| +| 3133 | `(const Nothing)` wrapper | nottickedoff | +| 3139 | `mentions`, `msgScope`, `ttl`, `live`, `True` to `groupMessageUpdate` | nottickedoff | +| 3141 | `scope_` and `rcvMsg` to `groupMessageDelete` | nottickedoff | +| 3143 | `scope_` to `groupMsgReaction` | nottickedoff | +| 3145 | `XInfo` handler when `author_` is Just | nottickedoff | +| 3152 | `XGrpPrefs` forwarding | nottickedoff | +| 3153 | Catch-all error for unsupported forwarded event | nottickedoff | +| 3311 | `FwdChannel -> (Nothing, Nothing)` | nottickedoff | + +--- + +### 2. View.hs + +#### `viewChatItem` (line 646) + +| Line | Code | Status | +|------|------|--------| +| 555 | `groupNtf user g mention` - `mention` parameter for channel | nottickedoff | +| 673 | `showSndItemProhibited to` for `CISndGroupInvitation` | nottickedoff | +| 674 | `showSndItem to` fallback for GroupChat | nottickedoff | +| 682 | `CIRcvIntegrityError` in group context | nottickedoff | +| 683 | `CIRcvGroupInvitation` with `isJust m_` guard | nottickedoff | +| 684 | `CIRcvModerated` in group context | nottickedoff | +| 685 | `CIRcvBlocked` in group context | nottickedoff | +| 686 | `showRcvItem from` fallback | nottickedoff | +| 691 | `forwardedFrom` in context computation | nottickedoff | + +#### `viewItemUpdate` (line 798) + +| Line | Code | Status | +|------|------|--------| +| 819 | `CIGroupRcv m -> updGroupItem (Just m)` | nottickedoff | +| 822 | `CIGroupSnd _ -> []` fallback | nottickedoff | +| 825 | `ttyToGroup g scopeInfo` (non-edited send path) | nottickedoff | +| 830 | `itemLive == Just True && not liveItems -> []` | tickonlyfalse | +| 832 | `_ -> []` fallback for non-message content | nottickedoff | +| 834 | `ttyFromGroup g scopeInfo m_` (non-edited receive path) | nottickedoff | +| 837 | `forwardedFrom` in context | nottickedoff | +| 838 | `groupQuote g` in context | nottickedoff | + +#### `viewItemReaction` (line 890) + +| Line | Code | Status | +|------|------|--------| +| 898-899 | `sentByMember' g itemDir` in both CIGroupRcv and CIChannelRcv | nottickedoff | +| 913 | `groupReaction _ -> []` (non-message-content fallback) | nottickedoff | +| 917 | `else sentBy` branch when `showGroupAsSender` is False | nottickedoff | +| 958 | `sentByMember'` function | **entirely nottickedoff** | +| 962 | `CIChannelRcv -> Nothing` in sentByMember' | nottickedoff | + +#### `viewItemDelete` (line 869) + +| Line | Code | Status | +|------|------|--------| +| 880 | `_ -> prohibited` in GroupChat branch | nottickedoff | + +#### `viewGroupChatItemsDeleted` (line 866) + +| Line | Code | Status | +|------|------|--------| +| 158 | `member_` parameter | nottickedoff | +| 866 | `maybe "" (\m -> " " <> ttyMember m) member_` - empty string fallback | nottickedoff | +| - | Entire function | **entirely nottickedoff** | + +#### `groupScopeInfoStr` (line 2785) + +| Line | Code | Status | +|------|------|--------| +| - | `Just (GCSIMemberSupport {groupMember_}) -> ...` | nottickedoff | +| - | `Nothing -> "(support)"` sub-branch | nottickedoff | +| - | `Just m -> "(support: " <> viewMemberName m <> ")"` sub-branch | nottickedoff | + +#### Scope info display + +| Line | Code | Status | +|------|------|--------| +| 2768 | `groupScopeInfoStr scopeInfo` in `ttyToGroup` | nottickedoff | +| 2779 | `groupScopeInfoStr scopeInfo` in `ttyToGroupEdited` | nottickedoff | +| 2782 | `groupScopeInfoStr scopeInfo` in `fromGroupAttention_` | nottickedoff | + +#### Other display functions + +| Line | Code | Status | +|------|------|--------| +| 625 | `GroupChat g scopeInfo -> [" " <> ttyToGroup g scopeInfo]` | nottickedoff | +| 766 | `(SMDSnd, GroupChat gInfo _scopeInfo) -> Just $ "you #" <> ...` | nottickedoff | +| 767 | `(SMDRcv, GroupChat gInfo _scopeInfo) -> Just $ "#" <> ...` | nottickedoff | +| 936 | `viewReactionMembers` | **entirely nottickedoff** | +| 1020 | `viewChatCleared` GroupChat branch | nottickedoff | + +--- + +### 3. Internal.hs + +#### `saveRcvChatItem'` (lines 2294-2340) + +| Line | Code | Status | +|------|------|--------| +| 2288 | `M.empty` for non-group mentions | nottickedoff | +| 2299 | `groupMentions` parameters `db` and `membership` | nottickedoff | +| 2300 | `_ -> pure (M.empty, False)` for non-group | nottickedoff | +| 2303 | `contactChatDeleted cd` | tickonlyfalse | +| 2303 | `vr` parameter in `updateChatTsStats` | nottickedoff | +| 2304 | `else pure $ toChatInfo cd` | nottickedoff | +| 2316 | `getRcvCIMentions` - `db`, `user`, `mentions` parameters | nottickedoff | +| 2319 | `sameMemberId mId membership` in userReply check | nottickedoff | +| 2320 | `\CIMention {memberId} -> sameMemberId memberId membership` | nottickedoff | +| 2311 | `createGroupCIMentions db g ci mentions'` | nottickedoff (mentions always empty) | + +#### `memberChatStats` (line 2323) + +| Line | Code | Status | +|------|------|--------| +| 2325-2327 | `CDGroupRcv _g (Just scope) m -> ...` | nottickedoff | +| 2328-2329 | `CDChannelRcv _g (Just scope) -> ...` | nottickedoff | +| 2330 | `_ -> Nothing` | nottickedoff | +| - | Entire function | **entirely nottickedoff** | + +#### `memberAttentionChange` (line 2621) + +| Line | Code | Status | +|------|------|--------| +| - | Entire function | **entirely nottickedoff** | + +#### `getRcvCIMentions` (line 277) + +| Line | Code | Status | +|------|------|--------| +| 279 | `not (null ft) && not (null mentions) -> ...` | nottickedoff | +| 280 | `uniqueMsgMentions maxRcvMentions mentions $ mentionedNames ft` | nottickedoff | +| 281 | `mapM (getMentionedMemberByMemberId db user groupId) mentions'` | nottickedoff | + +#### `uniqueMsgMentions` (line 286) + +| Line | Code | Status | +|------|------|--------| +| - | Entire function | **entirely nottickedoff** | + +#### `prepareGroupMsg` / `quoteData` (line 204) + +| Line | Code | Status | +|------|------|--------| +| 209 | `MCForward $ ExtMsgContent ...` forward branch | nottickedoff | +| 227 | `CIGroupSnd` with `showGroupAsSender` False | nottickedoff | +| 228 | `CIGroupRcv m -> pure (qmc, CIQGroupRcv $ Just m, False, Just m)` | nottickedoff | + +#### `mkGetMessageChatScope` (lines 1599-1617) + +| Line | Code | Status | +|------|------|--------| +| 1601 | `groupScope@(_gInfo', _m', Just _scopeInfo) -> pure groupScope` | nottickedoff | +| 1604 | `isReport mc -> ...` | tickonlyfalse | +| 1610 | `sameMemberId mId membership -> ...` | nottickedoff | +| 1614 | `otherwise -> do referredMember <- ...` | nottickedoff | +| 1614 | `vr` parameter in `getGroupMemberByMemberId` | nottickedoff | + +#### `mkGroupSupportChatInfo` (line 1620) + +| Line | Code | Status | +|------|------|--------| +| - | Entire function | **entirely nottickedoff** | + +#### Feature checks (tickonlyfalse - never true) + +| Line | Code | Status | +|------|------|--------| +| 342 | `isVoice mc && not (groupFeatureMemberAllowed SGFVoice m gInfo)` | tickonlyfalse | +| 344 | `isReport mc && ... not (groupFeatureAllowed SGFReports gInfo)` | tickonlyfalse | +| 485 | `isACIUserMention deletedChatItem` | tickonlyfalse | +| 1593 | `memberPending m` | tickonlyfalse | + +#### `sendGroupMessages` (line 1986) + +| Line | Code | Status | +|------|------|--------| +| 1989 | `sendProfileUpdate catchAllErrors eToView` | nottickedoff | +| 1995 | `isJust scope = False` branch | nottickedoff | + +--- + +### 4. Messages.hs + +#### JSON direction functions - ALL ENTIRELY UNTESTED + +**`jsonCIDirection` (lines 314-321):** +| Line | Code | Status | +|------|------|--------| +| 315 | `CIDirectSnd -> JCIDirectSnd` | nottickedoff | +| 316 | `CIDirectRcv -> JCIDirectRcv` | nottickedoff | +| 317 | `CIGroupSnd -> JCIGroupSnd` | nottickedoff | +| 318 | `CIGroupRcv m -> JCIGroupRcv m` | nottickedoff | +| 319 | `CIChannelRcv -> JCIChannelRcv` | nottickedoff | +| 320 | `CILocalSnd -> JCILocalSnd` | nottickedoff | +| 321 | `CILocalRcv -> JCILocalRcv` | nottickedoff | + +**`jsonACIDirection` (lines 324-331):** +| Line | Code | Status | +|------|------|--------| +| 325-331 | All branches including `JCIChannelRcv -> ACID SCTGroup SMDRcv CIChannelRcv` | nottickedoff | + +**`jsonCIQDirection` (lines 646-651):** +| Line | Code | Status | +|------|------|--------| +| 647 | `CIQDirectSnd -> JCIDirectSnd` | nottickedoff | +| 648 | `CIQDirectRcv -> JCIDirectRcv` | nottickedoff | +| 649 | `CIQGroupSnd -> JCIGroupSnd` | nottickedoff | +| 650 | `CIQGroupRcv (Just m) -> JCIGroupRcv m` | nottickedoff | +| 651 | `CIQGroupRcv Nothing -> JCIChannelRcv` | nottickedoff | + +**`jsonACIQDirection` (lines 654-661):** +| Line | Code | Status | +|------|------|--------| +| 655-659 | All branches including `JCIChannelRcv -> Right $ ACIQDirection SCTGroup $ CIQGroupRcv Nothing` | nottickedoff | +| 660 | `JCILocalSnd -> Left "unquotable"` | nottickedoff | +| 661 | `JCILocalRcv -> Left "unquotable"` | nottickedoff | + +**ToJSON/FromJSON instances:** +| Line | Code | Status | +|------|------|--------| +| 1469-1470 | `CIDirection` ToJSON | nottickedoff | +| 1473 | `CCIDirection` FromJSON | nottickedoff | +| 1476 | `ACIDirection` FromJSON | nottickedoff | +| 1479 | `CIQDirection` FromJSON | nottickedoff | +| 1482-1483 | `CIQDirection` ToJSON | nottickedoff | + +#### Other Messages.hs functions + +| Line | Code | Status | +|------|------|--------| +| 372-375 | `chatItemRcvFromMember` | partially covered - `_ -> Nothing` nottickedoff | +| 403 | `toCIDirection CDLocalRcv _ -> CILocalRcv` | nottickedoff | +| 413 | `toChatInfo CDLocalRcv l -> LocalChat l` | nottickedoff | +| 486 | `aChatItemRcvFromMember` | nottickedoff | +| 665 | `quoteMsgDirection CIQDirectSnd -> MDSnd` | nottickedoff | +| 666 | `quoteMsgDirection CIQDirectRcv -> MDRcv` | nottickedoff | + +--- + +### 5. Store/Messages.hs + +#### Scope-filtered query functions - ALL ENTIRELY UNTESTED + +| Function | Lines | Status | +|----------|-------|--------| +| `findGroupChatPreviews_` | 862-900 | nottickedoff | +| `getChatContentTypes` | 1183-1197 | nottickedoff | +| `getChatItemIDs` | 1476-1505 | nottickedoff | +| `queryUnreadGroupItems` | 1686-1707 | nottickedoff | +| `updateSupportChatItemsRead` | 2038-2077 | nottickedoff | +| `getGroupUnreadTimedItems` | 2080-2102 | nottickedoff | +| `getGroupMemberCIBySharedMsgId` | 2950-2960 | nottickedoff | + +#### `toGroupChatItem` (lines 2327-2337) + +| Line | Code | Status | +|------|------|--------| +| 2329 | `CIChannelRcv` with file | **covered** | +| 2332 | `CIChannelRcv` without file | **covered** | +| 2334 | `CIGroupRcv member` with file | nottickedoff | +| 2336 | `CIGroupRcv member` without file | nottickedoff | +| 2337 | `badItem` fallback | nottickedoff | +| 2321 | `deletedByGroupMember_` parsing | nottickedoff | + +#### `getChatItemQuote_` CDChannelRcv (lines 648-653) + +| Line | Code | Status | +|------|------|--------| +| 651 | `mId == userMemberId` check | nottickedoff | +| 651 | `getUserGroupChatItemId_` call | nottickedoff | +| 652 | `otherwise` fallback | nottickedoff | +| 653 | `_ -> pure . ciQuote Nothing $ CIQGroupRcv Nothing` | **covered** | + +#### Reaction functions + +| Line | Code | Status | +|------|------|--------| +| 3275 | `getGroupCIReactions` | **covered** | +| 3328 | `deleteGroupCIReactions_` | nottickedoff | + +--- + +## Summary + +### Well-tested channel paths: +- Channel message create/read/delete happy paths +- Basic channel reactions +- Channel quote creation (quoting nothing) +- `validSender Nothing CIChannelRcv` +- `getGroupChatItemBySharedMsgId` with `Nothing` memberId + +### Major gaps: + +1. **Non-channel-owner member in channel groups** - `isChannelOwner` always True, `memberForChannel = Just m''` never executed + +2. **All JSON serialization for CI directions** - `jsonCIDirection`, `jsonACIDirection`, `jsonCIQDirection`, `jsonACIQDirection` and all `ToJSON`/`FromJSON` instances entirely untested + +3. **Member support scope (`GCSIMemberSupport`)** - `mkGroupSupportChatInfo`, `groupScopeInfoStr`, `memberChatStats` entirely untested + +4. **Mentions in channel/group messages** - `getRcvCIMentions` with non-empty mentions, `uniqueMsgMentions`, `createGroupCIMentions` never called + +5. **Error/fallback paths** - `catchCINotFound` in update/delete/reaction, invalid sender validation, permission errors + +6. **Full-delete feature** - `groupFeatureAllowed SGFFullDelete` always false, `deleteGroupCIs` never called + +7. **Live message updates** - `itemLive == Just True` always false + +8. **Forwarded message handling** - Most parameters to forwarded handlers untested, `FwdChannel` branch untested + +9. **View functions** - `sentByMember'`, `viewGroupChatItemsDeleted`, `viewReactionMembers` entirely untested + +10. **Scope-filtered store queries** - 7 functions entirely untested + +11. **Feature restriction checks** - Voice messages (`SGFVoice`), reports (`SGFReports`) feature checks never triggered diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 6fc6818730..a0a8111160 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -338,7 +338,7 @@ data ChatCommand | APIChatItemReaction {chatRef :: ChatRef, chatItemId :: ChatItemId, add :: Bool, reaction :: MsgReaction} | APIGetReactionMembers {userId :: UserId, groupId :: GroupId, chatItemId :: ChatItemId, reaction :: MsgReaction} | APIPlanForwardChatItems {fromChatRef :: ChatRef, chatItemIds :: NonEmpty ChatItemId} - | APIForwardChatItems {toChatRef :: ChatRef, fromChatRef :: ChatRef, chatItemIds :: NonEmpty ChatItemId, ttl :: Maybe Int} + | APIForwardChatItems {toChatRef :: ChatRef, sendAsGroup :: ShowGroupAsSender, fromChatRef :: ChatRef, chatItemIds :: NonEmpty ChatItemId, ttl :: Maybe Int} | APIUserRead UserId | UserRead | APIChatRead {chatRef :: ChatRef} @@ -934,14 +934,9 @@ logEventToFile = \case data SendRef = SRDirect ContactId - | SRGroup GroupId (Maybe GroupChatScope) + | SRGroup GroupId (Maybe GroupChatScope) ShowGroupAsSender deriving (Eq, Show) -sendToChatRef :: SendRef -> ChatRef -sendToChatRef = \case - SRDirect cId -> ChatRef CTDirect cId Nothing - SRGroup gId scope -> ChatRef CTGroup gId scope - data ChatPagination = CPLast Int | CPAfter ChatItemId Int diff --git a/src/Simplex/Chat/Delivery.hs b/src/Simplex/Chat/Delivery.hs index d0a77514eb..37d6d4ba09 100644 --- a/src/Simplex/Chat/Delivery.hs +++ b/src/Simplex/Chat/Delivery.hs @@ -10,7 +10,7 @@ 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.Messages (GroupChatScopeInfo (..), MessageId, ShowGroupAsSender) import Simplex.Chat.Options.DB (FromField (..), ToField (..)) import Simplex.Chat.Protocol import Simplex.Chat.Types @@ -41,6 +41,16 @@ instance TextEncoding DeliveryWorkerScope where DWSMemberSupport -> "member_support" -- DWSMemberProfileUpdate -> "member_profile_update" +-- Context for creating a delivery task. Separate from DeliveryJobScope because +-- sentAsGroup is only needed for task persistence and batching into XGrpMsgForward events. +-- Once batched into jobs, sentAsGroup=True and sentAsGroup=False messages can be mixed, +-- so jobs don't need this flag. +data DeliveryTaskContext = DeliveryTaskContext + { jobScope :: DeliveryJobScope, + sentAsGroup :: ShowGroupAsSender + } + deriving (Show) + data DeliveryJobScope = DJSGroup {jobSpec :: DeliveryJobSpec} | DJSMemberSupport {supportGMId :: GroupMemberId} @@ -93,12 +103,14 @@ 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} +infoToDeliveryContext :: GroupInfo -> Maybe GroupChatScopeInfo -> ShowGroupAsSender -> DeliveryTaskContext +infoToDeliveryContext GroupInfo {membership} scopeInfo sentAsGroup = DeliveryTaskContext {jobScope, sentAsGroup} + where + jobScope = case scopeInfo of + 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} @@ -109,20 +121,22 @@ memberEventDeliveryScope m@GroupMember {memberRole, memberStatus} data NewMessageDeliveryTask = NewMessageDeliveryTask { messageId :: MessageId, - jobScope :: DeliveryJobScope, - messageFromChannel :: MessageFromChannel + taskContext :: DeliveryTaskContext } deriving (Show) +data FwdSender + = FwdMember MemberId ContactName + | FwdChannel + deriving (Show) + data MessageDeliveryTask = MessageDeliveryTask { taskId :: Int64, jobScope :: DeliveryJobScope, senderGMId :: GroupMemberId, - senderMemberId :: MemberId, - senderMemberName :: ContactName, + fwdSender :: FwdSender, brokerTs :: UTCTime, - chatMessage :: ChatMessage 'Json, - messageFromChannel :: MessageFromChannel + chatMessage :: ChatMessage 'Json } deriving (Show) diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index c2194f7b8f..d7d4fb29bc 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -620,12 +620,12 @@ processChatCommand vr nm = \case mapM_ assertNoMentions cms withContactLock "sendMessage" chatId $ sendContactContentMessages user chatId live itemTTL (L.map composedMessageReq cms) - SRGroup chatId gsScope -> + SRGroup chatId gsScope asGroup -> withGroupLock "sendMessage" chatId $ do (gInfo, cmrs) <- withFastStore $ \db -> do g <- getGroupInfo db vr user chatId (g,) <$> mapM (composedMessageReqMentions db user g) cms - sendGroupContentMessages user gInfo gsScope live itemTTL cmrs + sendGroupContentMessages user gInfo gsScope asGroup live itemTTL cmrs APICreateChatTag (ChatTagData emoji text) -> withUser $ \user -> withFastStore' $ \db -> do _ <- createChatTag db user emoji text CRChatTags user <$> getUserChatTags db user @@ -654,7 +654,7 @@ 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} - sendGroupContentMessages user gInfo (Just $ GCSMemberSupport Nothing) False Nothing [composedMessageReq cm] + sendGroupContentMessages user gInfo (Just $ GCSMemberSupport Nothing) False False Nothing [composedMessageReq cm] ReportMessage {groupName, contactName_, reportReason, reportedMessage} -> withUser $ \user -> do gId <- withFastStore $ \db -> getGroupIdByName db user groupName reportedItemId <- withFastStore $ \db -> getGroupChatItemIdByText db user gId contactName_ reportedMessage @@ -672,7 +672,7 @@ processChatCommand vr nm = \case let changed = mc /= oldMC if changed || fromMaybe False itemLive then do - let event = XMsgUpdate itemSharedMId mc M.empty (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive) Nothing + let event = XMsgUpdate itemSharedMId mc M.empty (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive) Nothing Nothing (SndMessage {msgId}, _) <- sendDirectContactMessage user ct event ci' <- withFastStore' $ \db -> do currentTs <- liftIO getCurrentTime @@ -695,7 +695,7 @@ processChatCommand vr nm = \case -- TODO [knocking] check chat item scope? cci <- withFastStore $ \db -> getGroupCIWithReactions db user gInfo itemId case cci of - CChatItem SMDSnd ci@ChatItem {meta = CIMeta {itemSharedMsgId, itemTimed, itemLive, editable}, content = ciContent} -> do + CChatItem SMDSnd ci@ChatItem {meta = CIMeta {itemSharedMsgId, itemTimed, itemLive, editable, showGroupAsSender}, content = ciContent} -> do case (ciContent, itemSharedMsgId, editable) of (CISndMsgContent oldMC, Just itemSharedMId, True) -> do chatScopeInfo <- mapM (getChatScopeInfo vr user) scope @@ -706,7 +706,7 @@ processChatCommand vr nm = \case ciMentions <- withFastStore $ \db -> getCIMentions db user gInfo ft_ mentions let msgScope = toMsgScope gInfo <$> chatScopeInfo mentions' = M.map (\CIMention {memberId} -> MsgMention {memberId}) ciMentions - event = XMsgUpdate itemSharedMId mc mentions' (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive) msgScope + event = XMsgUpdate itemSharedMId mc mentions' (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive) msgScope (Just showGroupAsSender) SndMessage {msgId} <- sendGroupMessage user gInfo scope recipients event ci' <- withFastStore' $ \db -> do currentTs <- liftIO getCurrentTime @@ -852,10 +852,10 @@ processChatCommand vr nm = \case throwCmdError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFReactions) unless (ciReactionAllowed ci) $ throwCmdError "reaction not allowed - chat item has no content" - let GroupMember {memberId = itemMemberId} = chatItemMember g ci + let itemMemberId = memberId' <$> chatItemMember g ci rs <- withFastStore' $ \db -> getGroupReactions db g membership itemMemberId itemSharedMId True checkReactionAllowed rs - SndMessage {msgId} <- sendGroupMessage user g scope recipients (XMsgReact itemSharedMId (Just itemMemberId) (toMsgScope g <$> chatScopeInfo) reaction add) + SndMessage {msgId} <- sendGroupMessage user g scope recipients (XMsgReact itemSharedMId itemMemberId (toMsgScope g <$> chatScopeInfo) reaction add) createdAt <- liftIO getCurrentTime reactions <- withFastStore' $ \db -> do setGroupReaction db g membership itemMemberId itemSharedMId True reaction add msgId createdAt @@ -927,7 +927,7 @@ processChatCommand vr nm = \case MCChat {} -> True MCUnknown {} -> True -- TODO [knocking] forward from / to scope - APIForwardChatItems toChat@(ChatRef toCType toChatId toScope) fromChat@(ChatRef fromCType fromChatId _fromScope) itemIds itemTTL -> withUser $ \user -> case toCType of + APIForwardChatItems toChat@(ChatRef toCType toChatId toScope) sendAsGroup fromChat@(ChatRef fromCType fromChatId _fromScope) itemIds itemTTL -> withUser $ \user -> case toCType of CTDirect -> do cmrs <- prepareForward user case L.nonEmpty cmrs of @@ -941,7 +941,7 @@ processChatCommand vr nm = \case Just cmrs' -> withGroupLock "forwardChatItem, to group" toChatId $ do gInfo <- withFastStore $ \db -> getGroupInfo db vr user toChatId - sendGroupContentMessages user gInfo toScope False itemTTL cmrs' + sendGroupContentMessages user gInfo toScope sendAsGroup False itemTTL cmrs' Nothing -> pure $ CRNewChatItems user [] CTLocal -> do cmrs <- prepareForward user @@ -1275,7 +1275,7 @@ processChatCommand vr nm = \case sendWelcomeMsg user ct ucl UserContactRequest {welcomeSharedMsgId} = forM_ (autoReply $ addressSettings ucl) $ \mc -> case welcomeSharedMsgId of Just smId -> - void $ sendDirectContactMessage user ct $ XMsgUpdate smId mc M.empty Nothing Nothing Nothing + void $ sendDirectContactMessage user ct $ XMsgUpdate smId mc M.empty Nothing Nothing Nothing Nothing Nothing -> do (msg, _) <- sendDirectContactMessage user ct $ XMsgNew $ MCSimple $ extMsgContent mc Nothing ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc) @@ -1880,7 +1880,8 @@ processChatCommand vr nm = \case groupPreferences = maybe defaultBusinessGroupPrefs businessGroupPrefs preferences groupProfile = businessGroupProfile profile groupPreferences gVar <- asks random - (gInfo, hostMember) <- withStore $ \db -> createPreparedGroup db gVar vr user groupProfile True ccLink welcomeSharedMsgId False + (gInfo, hostMember_) <- withStore $ \db -> createPreparedGroup db gVar vr user groupProfile True ccLink welcomeSharedMsgId False + hostMember <- maybe (throwCmdError "no host member") pure hostMember_ void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing (Just epochStart) let cd = CDGroupRcv gInfo Nothing hostMember createItem sharedMsgId content = createChatItem user cd True content sharedMsgId Nothing @@ -1909,13 +1910,9 @@ processChatCommand vr nm = \case welcomeSharedMsgId <- forM description $ \_ -> getSharedMsgId let useRelays = not direct gVar <- asks random - (gInfo, hostMember) <- withStore $ \db -> createPreparedGroup db gVar vr user gp False ccLink welcomeSharedMsgId useRelays + (gInfo, hostMember_) <- withStore $ \db -> createPreparedGroup db gVar vr user gp False ccLink welcomeSharedMsgId useRelays void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing (Just epochStart) - -- TODO [relays] member: TBC save items as message from channel - -- TODO - hostMember to later be associated with owner profile when relays send it - -- TODO - pick any owner at random from initial introductions, find unknown member in group? - -- TODO - alternatively support not having a member in CDGroupRcv direction? - let cd = CDGroupRcv gInfo Nothing hostMember + let cd = maybe (CDChannelRcv gInfo Nothing) (CDGroupRcv gInfo Nothing) hostMember_ cInfo = GroupChat gInfo Nothing void $ createGroupFeatureItems_ user cd True CIRcvGroupFeature gInfo aci <- forM description $ \descr -> createChatItem user cd True (CIRcvMsgContent $ MCText descr) welcomeSharedMsgId Nothing @@ -1933,11 +1930,17 @@ processChatCommand vr nm = \case lift $ createContactChangedFeatureItems user ct ct' pure $ CRContactUserChanged user ct newUser ct' APIChangePreparedGroupUser groupId newUserId -> withUser $ \user -> do - (gInfo, hostMember) <- withFastStore $ \db -> (,) <$> getGroupInfo db vr user groupId <*> getHostMember db vr user groupId + gInfo <- withFastStore $ \db -> getGroupInfo db vr user groupId when (isNothing $ preparedGroup gInfo) $ throwCmdError "group doesn't have link to connect" - when (isJust $ memberConn hostMember) $ throwCmdError "host member already has connection" + hostMember_ <- + if useRelays' gInfo + then pure Nothing + else do + hostMember <- withFastStore $ \db -> getHostMember db vr user groupId + when (isJust $ memberConn hostMember) $ throwCmdError "host member already has connection" + pure $ Just hostMember newUser <- privateGetUser newUserId - gInfo' <- withFastStore $ \db -> updatePreparedGroupUser db vr user gInfo hostMember newUser + gInfo' <- withFastStore $ \db -> updatePreparedGroupUser db vr user gInfo hostMember_ newUser pure $ CRGroupUserChanged user gInfo newUser gInfo' APIConnectPreparedContact contactId incognito msgContent_ -> withUser $ \user -> do ct@Contact {preparedContact} <- withFastStore $ \db -> getContact db vr user contactId @@ -1985,7 +1988,7 @@ processChatCommand vr nm = \case pure $ CRStartedConnectionToContact user ct' customUserProfile CVRConnectedContact ct' -> pure $ CRContactAlreadyExists user ct' APIConnectPreparedGroup groupId incognito msgContent_ -> withUser $ \user -> do - (gInfo, hostMember) <- withFastStore $ \db -> (,) <$> getGroupInfo db vr user groupId <*> getHostMember db vr user groupId + gInfo <- withFastStore $ \db -> getGroupInfo db vr user groupId case gInfo of GroupInfo {preparedGroup = Nothing} -> throwCmdError "group doesn't have link to connect" GroupInfo {useRelays = BoolDef True, preparedGroup = Just PreparedGroup {connLinkToConnect}} -> do @@ -2050,6 +2053,7 @@ processChatCommand vr nm = \case newConnIds <- getAgentConnShortLinkAsync user relayLink withStore' $ \db -> createRelayMemberConnectionAsync db user gInfo' relayMember relayLink newConnIds subMode GroupInfo {preparedGroup = Just PreparedGroup {connLinkToConnect, welcomeSharedMsgId, requestSharedMsgId}} -> do + hostMember <- withFastStore $ \db -> getHostMember db vr user groupId msg_ <- forM msgContent_ $ \mc -> case requestSharedMsgId of Just smId -> pure (smId, mc) Nothing -> do @@ -2184,17 +2188,20 @@ processChatCommand vr nm = \case contactId <- withFastStore $ \db -> getContactIdByName db user fromContactName forwardedItemId <- withFastStore $ \db -> getDirectChatItemIdByText' db user contactId forwardedMsg toChatRef <- getChatRef user toChatName - processChatCommand vr nm $ APIForwardChatItems toChatRef (ChatRef CTDirect contactId Nothing) (forwardedItemId :| []) Nothing + asGroup <- getSendAsGroup user toChatRef + processChatCommand vr nm $ APIForwardChatItems toChatRef asGroup (ChatRef CTDirect contactId Nothing) (forwardedItemId :| []) Nothing ForwardGroupMessage toChatName fromGroupName fromMemberName_ forwardedMsg -> withUser $ \user -> do groupId <- withFastStore $ \db -> getGroupIdByName db user fromGroupName forwardedItemId <- withFastStore $ \db -> getGroupChatItemIdByText db user groupId fromMemberName_ forwardedMsg toChatRef <- getChatRef user toChatName - processChatCommand vr nm $ APIForwardChatItems toChatRef (ChatRef CTGroup groupId Nothing) (forwardedItemId :| []) Nothing + asGroup <- getSendAsGroup user toChatRef + processChatCommand vr nm $ APIForwardChatItems toChatRef asGroup (ChatRef CTGroup groupId Nothing) (forwardedItemId :| []) Nothing ForwardLocalMessage toChatName forwardedMsg -> withUser $ \user -> do folderId <- withFastStore (`getUserNoteFolderId` user) forwardedItemId <- withFastStore $ \db -> getLocalChatItemIdByText' db user folderId forwardedMsg toChatRef <- getChatRef user toChatName - processChatCommand vr nm $ APIForwardChatItems toChatRef (ChatRef CTLocal folderId Nothing) (forwardedItemId :| []) Nothing + asGroup <- getSendAsGroup user toChatRef + processChatCommand vr nm $ APIForwardChatItems toChatRef asGroup (ChatRef CTLocal folderId Nothing) (forwardedItemId :| []) Nothing SendMessage sendName msg -> withUser $ \user -> do let mc = MCText msg case sendName of @@ -2214,13 +2221,14 @@ processChatCommand vr nm = \case _ -> throwChatError $ CEContactNotFound name Nothing SNGroup name scope_ -> do - (gId, cScope_, mentions) <- withFastStore $ \db -> do - gId <- getGroupIdByName db user name + (gInfo, cScope_, mentions) <- withFastStore $ \db -> do + gInfo <- getGroupInfoByName db vr user name + let gId = groupId' gInfo cScope_ <- forM scope_ $ \(GSNMemberSupport mName_) -> GCSMemberSupport <$> mapM (getGroupMemberIdByName db user gId) mName_ - (gId,cScope_,) <$> liftIO (getMessageMentions db user gId msg) - let sendRef = SRGroup gId cScope_ + (gInfo, cScope_,) <$> liftIO (getMessageMentions db user gId msg) + let sendRef = SRGroup (groupId' gInfo) cScope_ (sendAsGroup' gInfo) processChatCommand vr nm $ APISendMessages sendRef False Nothing [ComposedMessage Nothing Nothing mc mentions] SNLocal -> do folderId <- withFastStore (`getUserNoteFolderId` user) @@ -2247,7 +2255,7 @@ processChatCommand vr nm = \case processChatCommand vr nm $ APIAcceptMemberContact contactId SendLiveMessage chatName msg -> withUser $ \user -> do (chatRef, mentions) <- getChatRefAndMentions user chatName msg - withSendRef chatRef $ \sendRef -> do + withSendRef user chatRef $ \sendRef -> do let mc = MCText msg processChatCommand vr nm $ APISendMessages sendRef True Nothing [ComposedMessage Nothing Nothing mc mentions] SendMessageBroadcast mc -> withUser $ \user -> do @@ -2289,7 +2297,7 @@ processChatCommand vr nm = \case combineResults _ _ (Left e) = Left e createCI :: DB.Connection -> User -> Bool -> UTCTime -> (Contact, SndMessage) -> IO () createCI db user hasLink createdAt (ct, sndMsg) = - void $ createNewSndChatItem db user (CDDirectSnd ct) sndMsg (CISndMsgContent mc) Nothing Nothing Nothing False hasLink createdAt + void $ createNewSndChatItem db user (CDDirectSnd ct) False sndMsg (CISndMsgContent mc) Nothing Nothing Nothing False hasLink createdAt SendMessageQuote cName (AMsgDirection msgDir) quotedMsg msg -> withUser $ \user@User {userId} -> do contactId <- withFastStore $ \db -> getContactIdByName db user cName quotedItemId <- withFastStore $ \db -> getDirectChatItemIdByText db userId contactId msgDir quotedMsg @@ -2497,7 +2505,7 @@ processChatCommand vr nm = \case pure $ CRMemberSupportChatDeleted user gInfo' m' APIMembersRole groupId memberIds newRole -> withUser $ \user -> withGroupLock "memberRole" groupId $ do - -- TODO [channels fwd] possible optimization is to read only required members + relays + -- TODO [relays] possible optimization is to read only required members + relays g@(Group gInfo members) <- withFastStore $ \db -> getGroup db vr user groupId when (selfSelected gInfo) $ throwCmdError "can't change role for self" let (invitedMems, currentMems, unchangedMems, maxRole, anyAdmin, anyPending) = selectMembers members @@ -2550,7 +2558,7 @@ processChatCommand vr nm = \case recipients = filter memberCurrent members (msgs_, _gsr) <- sendGroupMessages user gInfo Nothing recipients events let itemsData = zipWith (fmap . sndItemData) memsToChange (L.toList msgs_) - cis_ <- saveSndChatItems user (CDGroupSnd gInfo Nothing) itemsData Nothing False + cis_ <- saveSndChatItems user (CDGroupSnd gInfo Nothing) False itemsData Nothing False when (length cis_ /= length memsToChange) $ logError "changeRoleCurrentMems: memsToChange and cis_ length mismatch" (errs, changed) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (updMember db) memsToChange) let acis = map (AChatItem SCTGroup SMDSnd (GroupChat gInfo Nothing)) $ rights cis_ @@ -2566,10 +2574,10 @@ processChatCommand vr nm = \case pure (m :: GroupMember) {memberRole = newRole} APIBlockMembersForAll groupId memberIds blockFlag -> withUser $ \user -> withGroupLock "blockForAll" groupId $ do - -- TODO [channels fwd] possible optimization is to read only required members + relays + -- TODO [relays] possible optimization is to read only required members + relays 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 + -- TODO [relays] 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" @@ -2597,7 +2605,7 @@ processChatCommand vr nm = \case recipients = filter memberCurrent remainingMems (msgs_, _gsr) <- sendGroupMessages_ user gInfo recipients events let itemsData = zipWith (fmap . sndItemData) blockMems (L.toList msgs_) - cis_ <- saveSndChatItems user (CDGroupSnd gInfo Nothing) itemsData Nothing False + cis_ <- saveSndChatItems user (CDGroupSnd gInfo Nothing) False itemsData Nothing False when (length cis_ /= length blockMems) $ logError "blockMembers: blockMems and cis_ length mismatch" let acis = map (AChatItem SCTGroup SMDSnd (GroupChat gInfo Nothing)) $ rights cis_ unless (null acis) $ toView $ CEvtNewChatItems user acis @@ -2614,7 +2622,7 @@ processChatCommand vr nm = \case in NewSndChatItemData msg content ts M.empty Nothing Nothing Nothing APIRemoveMembers {groupId, groupMemberIds, withMessages} -> withUser $ \user -> withGroupLock "removeMembers" groupId $ do - -- TODO [channels fwd] possible optimization is to read only required members + relays + -- TODO [relays] possible optimization is to read only required members + relays Group gInfo members <- withFastStore $ \db -> getGroup db vr user groupId let (count, invitedMems, pendingApprvMems, pendingRvwMems, currentMems, maxRole, anyAdmin) = selectMembers gmIds members gmIds = S.fromList $ L.toList groupMemberIds @@ -2681,7 +2689,7 @@ processChatCommand vr nm = \case Right (Just a) -> Just $ Right a Left e -> Just $ Left e itemsData = mapMaybe skipUnwantedItem itemsData_ - cis_ <- saveSndChatItems user (CDGroupSnd gInfo chatScopeInfo) itemsData Nothing False + cis_ <- saveSndChatItems user (CDGroupSnd gInfo chatScopeInfo) False itemsData Nothing False deleteMembersConnections' user memsToDelete True (errs, deleted) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (delMember db) memsToDelete) let acis = map (AChatItem SCTGroup SMDSnd (GroupChat gInfo chatScopeInfo)) $ rights cis_ @@ -2913,13 +2921,14 @@ processChatCommand vr nm = \case groupId <- withFastStore $ \db -> getGroupIdByName db user gName processChatCommand vr nm $ APIGetGroupLink groupId SendGroupMessageQuote gName cName quotedMsg msg -> withUser $ \user -> do - (groupId, quotedItemId, mentions) <- + (gInfo, quotedItemId, mentions) <- withFastStore $ \db -> do - gId <- getGroupIdByName db user gName + gInfo <- getGroupInfoByName db vr user gName + let gId = groupId' gInfo qiId <- getGroupChatItemIdByText db user gId cName quotedMsg - (gId, qiId,) <$> liftIO (getMessageMentions db user gId msg) + (gInfo, qiId,) <$> liftIO (getMessageMentions db user gId msg) let mc = MCText msg - processChatCommand vr nm $ APISendMessages (SRGroup groupId Nothing) False Nothing [ComposedMessage Nothing (Just quotedItemId) mc mentions] + processChatCommand vr nm $ APISendMessages (SRGroup (groupId' gInfo) Nothing (sendAsGroup' gInfo)) False Nothing [ComposedMessage Nothing (Just quotedItemId) mc mentions] ClearNoteFolder -> withUser $ \user -> do folderId <- withFastStore (`getUserNoteFolderId` user) processChatCommand vr nm $ APIClearChat (ChatRef CTLocal folderId Nothing) @@ -2960,10 +2969,10 @@ processChatCommand vr nm = \case chatRef <- getChatRef user chatName case chatRef of ChatRef CTLocal folderId _ -> processChatCommand vr nm $ APICreateChatItems folderId [composedMessage (Just f) (MCFile "")] - _ -> withSendRef chatRef $ \sendRef -> processChatCommand vr nm $ APISendMessages sendRef False Nothing [composedMessage (Just f) (MCFile "")] + _ -> withSendRef user chatRef $ \sendRef -> processChatCommand vr nm $ APISendMessages sendRef False Nothing [composedMessage (Just f) (MCFile "")] SendImage chatName f@(CryptoFile fPath _) -> withUser $ \user -> do chatRef <- getChatRef user chatName - withSendRef chatRef $ \sendRef -> do + withSendRef user chatRef $ \sendRef -> do filePath <- lift $ toFSFilePath fPath unless (any (`isSuffixOf` map toLower fPath) imageExtensions) $ throwChatError CEFileImageType {filePath} fileSize <- getFileSize filePath @@ -3194,6 +3203,9 @@ processChatCommand vr nm = \case | otherwise -> throwCmdError "not supported" _ -> throwCmdError "not supported" pure $ ChatRef cType chatId Nothing + getSendAsGroup :: User -> ChatRef -> CM ShowGroupAsSender + getSendAsGroup user' (ChatRef CTGroup chatId _) = sendAsGroup' <$> withFastStore (\db -> getGroupInfo db vr user' chatId) + getSendAsGroup _ _ = pure False getChatRefAndMentions :: User -> ChatName -> Text -> CM (ChatRef, Map MemberName GroupMemberId) getChatRefAndMentions user cName msg = do chatRef@(ChatRef cType chatId _) <- getChatRef user cName @@ -3539,7 +3551,7 @@ processChatCommand vr nm = \case assertDeletable gInfo items assertUserGroupRole gInfo GRModerator let msgMemIds = itemsMsgMemIds gInfo items - events = L.nonEmpty $ map (\(msgId, memId) -> XMsgDel msgId (Just memId) $ toMsgScope gInfo <$> chatScopeInfo) msgMemIds + events = L.nonEmpty $ map (\(msgId, memId) -> XMsgDel msgId memId $ toMsgScope gInfo <$> chatScopeInfo) msgMemIds mapM_ (sendGroupMessages_ user gInfo ms) events delGroupChatItems user gInfo chatScopeInfo items True where @@ -3552,14 +3564,16 @@ processChatCommand vr nm = \case case chatDir of CIGroupRcv GroupMember {memberRole} -> memberRole' membership >= memberRole && isJust itemSharedMsgId CIGroupSnd -> isJust itemSharedMsgId - itemsMsgMemIds :: GroupInfo -> [CChatItem 'CTGroup] -> [(SharedMsgId, MemberId)] + CIChannelRcv -> memberRole' membership == GROwner && isJust itemSharedMsgId + itemsMsgMemIds :: GroupInfo -> [CChatItem 'CTGroup] -> [(SharedMsgId, Maybe MemberId)] itemsMsgMemIds GroupInfo {membership = GroupMember {memberId = membershipMemId}} = mapMaybe itemMsgMemIds where - itemMsgMemIds :: CChatItem 'CTGroup -> Maybe (SharedMsgId, MemberId) + itemMsgMemIds :: CChatItem 'CTGroup -> Maybe (SharedMsgId, Maybe MemberId) itemMsgMemIds (CChatItem _ ChatItem {chatDir, meta = CIMeta {itemSharedMsgId}}) = join <$> forM itemSharedMsgId $ \msgId -> Just $ case chatDir of - CIGroupRcv GroupMember {memberId} -> (msgId, memberId) - CIGroupSnd -> (msgId, membershipMemId) + CIGroupRcv GroupMember {memberId} -> (msgId, Just memberId) + CIGroupSnd -> (msgId, Just membershipMemId) + CIChannelRcv -> (msgId, Nothing) delGroupChatItems :: User -> GroupInfo -> Maybe GroupChatScopeInfo -> [CChatItem 'CTGroup] -> Bool -> CM [ChatItemDeletion] delGroupChatItems user gInfo@GroupInfo {membership} chatScopeInfo items moderation = do @@ -3977,7 +3991,7 @@ processChatCommand vr nm = \case msgs_ <- sendDirectContactMessages user ct $ L.map XMsgNew msgContainers let itemsData = prepareSndItemsData (L.toList cmrs) (L.toList ciFiles_) (L.toList quotedItems_) msgs_ when (length itemsData /= length cmrs) $ logError "sendContactContentMessages: cmrs and itemsData length mismatch" - r@(_, cis) <- partitionEithers <$> saveSndChatItems user (CDDirectSnd ct) itemsData timed_ live + r@(_, cis) <- partitionEithers <$> saveSndChatItems user (CDDirectSnd ct) False itemsData timed_ live processSendErrs r forM_ (timed_ >>= timedDeleteAt') $ \deleteAt -> forM_ cis $ \ci -> @@ -3996,8 +4010,8 @@ processChatCommand vr nm = \case prepareMsgs cmsFileInvs timed_ = withFastStore $ \db -> forM cmsFileInvs $ \((ComposedMessage {quotedItemId, msgContent = mc}, itemForwarded, _, _), fInv_) -> do case (quotedItemId, itemForwarded) of - (Nothing, Nothing) -> pure (MCSimple (ExtMsgContent mc M.empty fInv_ (ttl' <$> timed_) (justTrue live) Nothing), Nothing) - (Nothing, Just _) -> pure (MCForward (ExtMsgContent mc M.empty fInv_ (ttl' <$> timed_) (justTrue live) Nothing), Nothing) + (Nothing, Nothing) -> pure (MCSimple (ExtMsgContent mc M.empty fInv_ (ttl' <$> timed_) (justTrue live) Nothing Nothing), Nothing) + (Nothing, Just _) -> pure (MCForward (ExtMsgContent mc M.empty fInv_ (ttl' <$> timed_) (justTrue live) Nothing Nothing), Nothing) (Just qiId, Nothing) -> do CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <- getDirectChatItem db user contactId qiId @@ -4005,7 +4019,7 @@ processChatCommand vr nm = \case let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Nothing} qmc = quoteContent mc origQmc file quotedItem = CIQuote {chatDir = qd, itemId = Just qiId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc, formattedText} - pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc M.empty fInv_ (ttl' <$> timed_) (justTrue live) Nothing), Just quotedItem) + pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc M.empty fInv_ (ttl' <$> timed_) (justTrue live) Nothing Nothing), Just quotedItem) (Just _, Just _) -> throwError SEInvalidQuote where quoteData :: ChatItem c d -> ExceptT StoreError IO (MsgContent, CIQDirection 'CTDirect, Bool) @@ -4013,17 +4027,17 @@ processChatCommand vr nm = \case quoteData ChatItem {content = CISndMsgContent qmc} = pure (qmc, CIQDirectSnd, True) quoteData ChatItem {content = CIRcvMsgContent qmc} = pure (qmc, CIQDirectRcv, False) quoteData _ = throwError SEInvalidQuote - sendGroupContentMessages :: User -> GroupInfo -> Maybe GroupChatScope -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse - sendGroupContentMessages user gInfo scope live itemTTL cmrs = do + sendGroupContentMessages :: User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse + sendGroupContentMessages user gInfo scope showGroupAsSender live itemTTL cmrs = do assertMultiSendable live cmrs chatScopeInfo <- mapM (getChatScopeInfo vr user) scope recipients <- getGroupRecipients vr user gInfo chatScopeInfo modsCompatVersion - sendGroupContentMessages_ user gInfo scope chatScopeInfo recipients live itemTTL cmrs + sendGroupContentMessages_ user gInfo scope showGroupAsSender chatScopeInfo recipients live itemTTL cmrs where hasReport = any (\(ComposedMessage {msgContent}, _, _, _) -> isReport msgContent) cmrs modsCompatVersion = if hasReport then contentReportsVersion else groupKnockingVersion - sendGroupContentMessages_ :: User -> GroupInfo -> Maybe GroupChatScope -> Maybe GroupChatScopeInfo -> [GroupMember] -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse - sendGroupContentMessages_ user gInfo@GroupInfo {groupId, membership} scope chatScopeInfo recipients live itemTTL cmrs = do + sendGroupContentMessages_ :: User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> Maybe GroupChatScopeInfo -> [GroupMember] -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse + sendGroupContentMessages_ user gInfo@GroupInfo {groupId, membership} scope showGroupAsSender chatScopeInfo recipients live itemTTL cmrs = do forM_ allowedRole $ assertUserGroupRole gInfo assertGroupContentAllowed processComposedMessages @@ -4048,13 +4062,13 @@ processChatCommand vr nm = \case Nothing processComposedMessages :: CM ChatResponse processComposedMessages = do - -- TODO [channels fwd] single description for all recipients + -- TODO [relays] single description for all recipients (fInvs_, ciFiles_) <- L.unzip <$> setupSndFileTransfers (length recipients) timed_ <- sndGroupCITimed live gInfo itemTTL (chatMsgEvents, quotedItems_) <- L.unzip <$> prepareMsgs (L.zip cmrs fInvs_) timed_ (msgs_, gsr) <- sendGroupMessages user gInfo Nothing recipients chatMsgEvents let itemsData = prepareSndItemsData (L.toList cmrs) (L.toList ciFiles_) (L.toList quotedItems_) (L.toList msgs_) - cis_ <- saveSndChatItems user (CDGroupSnd gInfo chatScopeInfo) itemsData timed_ live + cis_ <- saveSndChatItems user (CDGroupSnd gInfo chatScopeInfo) showGroupAsSender itemsData timed_ live when (length cis_ /= length cmrs) $ logError "sendGroupContentMessages: cmrs and cis_ length mismatch" createMemberSndStatuses cis_ msgs_ gsr let r@(_, cis) = partitionEithers cis_ @@ -4077,7 +4091,7 @@ processChatCommand vr nm = \case forM cmsFileInvs $ \((ComposedMessage {quotedItemId, msgContent = mc}, itemForwarded, _, ciMentions), fInv_) -> let msgScope = toMsgScope gInfo <$> chatScopeInfo mentions = M.map (\CIMention {memberId} -> MsgMention {memberId}) ciMentions - in prepareGroupMsg db user gInfo msgScope mc mentions quotedItemId itemForwarded fInv_ timed_ live + in prepareGroupMsg db user gInfo msgScope showGroupAsSender mc mentions quotedItemId itemForwarded fInv_ timed_ live createMemberSndStatuses :: [Either ChatError (ChatItem 'CTGroup 'MDSnd)] -> NonEmpty (Either ChatError SndMessage) -> @@ -4226,10 +4240,12 @@ processChatCommand vr nm = \case getConnQueueInfo user Connection {connId, agentConnId = AgentConnId acId} = do msgInfo <- withFastStore' (`getLastRcvMsgInfo` connId) CRQueueInfo user msgInfo <$> withAgent (\a -> getConnectionQueueInfo a nm acId) - withSendRef :: ChatRef -> (SendRef -> CM ChatResponse) -> CM ChatResponse - withSendRef chatRef a = case chatRef of + withSendRef :: User -> ChatRef -> (SendRef -> CM ChatResponse) -> CM ChatResponse + withSendRef user chatRef a = case chatRef of ChatRef CTDirect cId _ -> a $ SRDirect cId - ChatRef CTGroup gId scope -> a $ SRGroup gId scope + ChatRef CTGroup gId scope -> do + gInfo <- withFastStore $ \db -> getGroupInfo db vr user gId + a $ SRGroup gId scope (sendAsGroup' gInfo) _ -> throwCmdError "not supported" getSharedMsgId :: CM SharedMsgId getSharedMsgId = do @@ -4620,7 +4636,7 @@ chatCommandP = "/_reaction " *> (APIChatItemReaction <$> chatRefP <* A.space <*> A.decimal <* A.space <*> onOffP <* A.space <*> (knownReaction <$?> jsonP)), "/_reaction members " *> (APIGetReactionMembers <$> A.decimal <* " #" <*> A.decimal <* A.space <*> A.decimal <* A.space <*> (knownReaction <$?> jsonP)), "/_forward plan " *> (APIPlanForwardChatItems <$> chatRefP <*> _strP), - "/_forward " *> (APIForwardChatItems <$> chatRefP <* A.space <*> chatRefP <*> _strP <*> sendMessageTTLP), + "/_forward " *> (APIForwardChatItems <$> chatRefP <*> (" as_group=" *> onOffP <|> pure False) <* A.space <*> chatRefP <*> _strP <*> sendMessageTTLP), "/_read user " *> (APIUserRead <$> A.decimal), "/read user" $> UserRead, "/_read chat " *> (APIChatRead <$> chatRefP), @@ -5047,7 +5063,8 @@ chatCommandP = cType -> (\chatId -> ChatRef cType chatId Nothing) <$> A.decimal sendRefP = (A.char '@' $> SRDirect <*> A.decimal) - <|> (A.char '#' $> SRGroup <*> A.decimal <*> optional gcScopeP) + <|> (A.char '#' $> SRGroup <*> A.decimal <*> optional gcScopeP <*> asGroupP) + asGroupP = ("(as_group=" *> onOffP <* A.char ')') <|> pure False gcScopeP = "(_support" *> (GCSMemberSupport <$> optional (A.char ':' *> A.decimal)) <* A.char ')' sendNameP = (A.char '@' $> SNDirect <*> displayNameP) diff --git a/src/Simplex/Chat/Library/Internal.hs b/src/Simplex/Chat/Library/Internal.hs index 5095197585..6240ff4a24 100644 --- a/src/Simplex/Chat/Library/Internal.hs +++ b/src/Simplex/Chat/Library/Internal.hs @@ -200,30 +200,33 @@ toggleNtf m ntfOn = forM_ (memberConnId m) $ \connId -> withAgent (\a -> toggleConnectionNtfs a connId ntfOn) `catchAllErrors` eToView -prepareGroupMsg :: DB.Connection -> User -> GroupInfo -> Maybe MsgScope -> MsgContent -> Map MemberName MsgMention -> Maybe ChatItemId -> Maybe CIForwardedFrom -> Maybe FileInvitation -> Maybe CITimed -> Bool -> ExceptT StoreError IO (ChatMsgEvent 'Json, Maybe (CIQuote 'CTGroup)) -prepareGroupMsg db user g@GroupInfo {membership} msgScope mc mentions quotedItemId_ itemForwarded fInv_ timed_ live = case (quotedItemId_, itemForwarded) of +prepareGroupMsg :: DB.Connection -> User -> GroupInfo -> Maybe MsgScope -> ShowGroupAsSender -> MsgContent -> Map MemberName MsgMention -> Maybe ChatItemId -> Maybe CIForwardedFrom -> Maybe FileInvitation -> Maybe CITimed -> Bool -> ExceptT StoreError IO (ChatMsgEvent 'Json, Maybe (CIQuote 'CTGroup)) +prepareGroupMsg db user g@GroupInfo {membership} msgScope showGroupAsSender mc mentions quotedItemId_ itemForwarded fInv_ timed_ live = case (quotedItemId_, itemForwarded) of (Nothing, Nothing) -> - let mc' = MCSimple $ ExtMsgContent mc mentions fInv_ (ttl' <$> timed_) (justTrue live) msgScope + let mc' = MCSimple $ ExtMsgContent mc mentions fInv_ (ttl' <$> timed_) (justTrue live) msgScope (justTrue showGroupAsSender) in pure (XMsgNew mc', Nothing) (Nothing, Just _) -> - let mc' = MCForward $ ExtMsgContent mc mentions fInv_ (ttl' <$> timed_) (justTrue live) msgScope + let mc' = MCForward $ ExtMsgContent mc mentions fInv_ (ttl' <$> timed_) (justTrue live) msgScope (justTrue showGroupAsSender) in pure (XMsgNew mc', Nothing) (Just quotedItemId, Nothing) -> do CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, mentions = quoteMentions, file} <- getGroupCIWithReactions db user g quotedItemId - (origQmc, qd, sent, GroupMember {memberId}) <- quoteData qci membership - let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Just memberId} + (origQmc, qd, sent, member_) <- quoteData qci membership + let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = memberId' <$> member_} qmc = quoteContent mc origQmc file (qmc', ft', _) = updatedMentionNames qmc formattedText quoteMentions quotedItem = CIQuote {chatDir = qd, itemId = Just quotedItemId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc', formattedText = ft'} - mc' = MCQuote QuotedMsg {msgRef, content = qmc'} (ExtMsgContent mc mentions fInv_ (ttl' <$> timed_) (justTrue live) msgScope) + mc' = MCQuote QuotedMsg {msgRef, content = qmc'} (ExtMsgContent mc mentions fInv_ (ttl' <$> timed_) (justTrue live) msgScope (justTrue showGroupAsSender)) pure (XMsgNew mc', Just quotedItem) (Just _, Just _) -> throwError SEInvalidQuote where - quoteData :: ChatItem c d -> GroupMember -> ExceptT StoreError IO (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember) + quoteData :: ChatItem c d -> GroupMember -> ExceptT StoreError IO (MsgContent, CIQDirection 'CTGroup, Bool, Maybe GroupMember) quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} _ = throwError SEInvalidQuote - quoteData ChatItem {chatDir = CIGroupSnd, content = CISndMsgContent qmc} membership' = pure (qmc, CIQGroupSnd, True, membership') - quoteData ChatItem {chatDir = CIGroupRcv m, content = CIRcvMsgContent qmc} _ = pure (qmc, CIQGroupRcv $ Just m, False, m) + quoteData ChatItem {chatDir = CIGroupSnd, content = CISndMsgContent qmc, meta = CIMeta {showGroupAsSender = sentAsGroup}} membership' + | sentAsGroup = pure (qmc, CIQGroupSnd, True, Nothing) + | otherwise = pure (qmc, CIQGroupSnd, True, Just membership') + quoteData ChatItem {chatDir = CIGroupRcv m, content = CIRcvMsgContent qmc} _ = pure (qmc, CIQGroupRcv $ Just m, False, Just m) + quoteData ChatItem {chatDir = CIChannelRcv, content = CIRcvMsgContent qmc} _ = pure (qmc, CIQGroupRcv Nothing, False, Nothing) quoteData _ _ = throwError SEInvalidQuote updatedMentionNames :: MsgContent -> Maybe MarkdownList -> Map MemberName CIMention -> (MsgContent, Maybe MarkdownList, Map MemberName CIMention) @@ -1190,13 +1193,15 @@ sendHistory user gInfo@GroupInfo {groupId, membership} m@GroupMember {activeConn | otherwise = Nothing itemForwardEvents :: CChatItem 'CTGroup -> CM [ChatMsgEvent 'Json] itemForwardEvents cci = case cci of - (CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv sender, content = CIRcvMsgContent mc, file}) - | not (blockedByAdmin sender) -> do + (CChatItem SMDRcv ci@ChatItem {content = CIRcvMsgContent mc, file}) + | not (maybe False blockedByAdmin sender_) -> do fInvDescr_ <- join <$> forM file getRcvFileInvDescr - processContentItem sender ci mc fInvDescr_ + processContentItem sender_ ci mc fInvDescr_ + | otherwise -> pure [] + where sender_ = chatItemRcvFromMember ci (CChatItem SMDSnd ci@ChatItem {content = CISndMsgContent mc, file}) -> do fInvDescr_ <- join <$> forM file getSndFileInvDescr - processContentItem membership ci mc fInvDescr_ + processContentItem (Just membership) ci mc fInvDescr_ _ -> pure [] where getRcvFileInvDescr :: CIFile 'MDRcv -> CM (Maybe (FileInvitation, RcvFileDescrText)) @@ -1229,8 +1234,8 @@ sendHistory user gInfo@GroupInfo {groupId, membership} m@GroupMember {activeConn fInv = xftpFileInvitation fileName fileSize fInvDescr in Just (fInv, fileDescrText) | otherwise = Nothing - processContentItem :: GroupMember -> ChatItem 'CTGroup d -> MsgContent -> Maybe (FileInvitation, RcvFileDescrText) -> CM [ChatMsgEvent 'Json] - processContentItem sender ChatItem {formattedText, meta, quotedItem, mentions} mc fInvDescr_ = + processContentItem :: Maybe GroupMember -> ChatItem 'CTGroup d -> MsgContent -> Maybe (FileInvitation, RcvFileDescrText) -> CM [ChatMsgEvent 'Json] + processContentItem sender_ ChatItem {formattedText, meta, quotedItem, mentions} mc fInvDescr_ = if isNothing fInvDescr_ && not (msgContentHasText mc) then pure [] else do @@ -1239,9 +1244,11 @@ sendHistory user gInfo@GroupInfo {groupId, membership} m@GroupMember {activeConn fInv_ = fst <$> fInvDescr_ (mc', _, mentions') = updatedMentionNames mc formattedText mentions mentions'' = M.map (\CIMention {memberId} -> MsgMention {memberId}) mentions' + asGroup = isNothing sender_ -- TODO [knocking] send history to other scopes too? - (chatMsgEvent, _) <- withStore $ \db -> prepareGroupMsg db user gInfo Nothing mc' mentions'' quotedItemId_ Nothing fInv_ itemTimed False - let senderVRange = memberChatVRange' sender + (chatMsgEvent, _) <- withStore $ \db -> prepareGroupMsg db user gInfo Nothing asGroup mc' mentions'' quotedItemId_ Nothing fInv_ itemTimed False + -- for channel messages default chat version range to membership range + let senderVRange = maybe (memberChatVRange' membership) memberChatVRange' sender_ xMsgNewChatMsg = ChatMessage {chatVRange = senderVRange, msgId = itemSharedMsgId, chatMsgEvent} fileDescrEvents <- case (snd <$> fInvDescr_, itemSharedMsgId) of (Just fileDescrText, Just msgId) -> do @@ -1250,9 +1257,9 @@ sendHistory user gInfo@GroupInfo {groupId, membership} m@GroupMember {activeConn pure . L.toList $ L.map (XMsgFileDescr msgId) parts _ -> pure [] let fileDescrChatMsgs = map (ChatMessage senderVRange Nothing) fileDescrEvents - GroupMember {memberId} = sender - memberName = Just $ memberShortenedName sender - msgForwardEvents = map (\cm -> XGrpMsgForward memberId memberName cm itemTs) (xMsgNewChatMsg : fileDescrChatMsgs) + memberId_ = memberId' <$> sender_ + memberName_ = memberShortenedName <$> sender_ + msgForwardEvents = map (\cm -> XGrpMsgForward memberId_ memberName_ cm itemTs) (xMsgNewChatMsg : fileDescrChatMsgs) pure msgForwardEvents memberShortenedName :: GroupMember -> ContactName @@ -2105,7 +2112,7 @@ memberSendAction gInfo@GroupInfo {membership} events members m@GroupMember {memb | isRelay membership && not (isRelay m) -> MSASendBatched . snd <$> readyMemberConn m -- if user is not chat relay, send only to chat relays | not (isRelay membership) && isRelay m -> MSASendBatched . snd <$> readyMemberConn m - | otherwise -> Nothing -- TODO [channels fwd] MSAForwarded to create GSSForwarded snd statuses? + | otherwise -> Nothing -- TODO [relays] MSAForwarded to create GSSForwarded snd statuses? | otherwise = case memberConn m of Nothing -> pendingOrForwarded Just conn@Connection {connStatus} @@ -2204,12 +2211,12 @@ saveGroupRcvMsg user groupId authorMember conn@Connection {connId} agentMsgMeta _ -> throwError e pure (am', conn', msg) -saveGroupFwdRcvMsg :: MsgEncodingI e => User -> GroupInfo -> GroupMember -> GroupMember -> MsgBody -> ChatMessage e -> UTCTime -> CM (Maybe RcvMessage) -saveGroupFwdRcvMsg user gInfo@GroupInfo {groupId} forwardingMember refAuthorMember@GroupMember {memberId = refMemberId} msgBody ChatMessage {msgId = sharedMsgId_, chatMsgEvent} brokerTs = do +saveGroupFwdRcvMsg :: MsgEncodingI e => User -> GroupInfo -> GroupMember -> Maybe GroupMember -> MsgBody -> ChatMessage e -> UTCTime -> CM (Maybe RcvMessage) +saveGroupFwdRcvMsg user gInfo@GroupInfo {groupId} forwardingMember refAuthorMember_ msgBody ChatMessage {msgId = sharedMsgId_, chatMsgEvent} brokerTs = do let newMsg = NewRcvMessage {chatMsgEvent, msgBody, brokerTs} fwdMemberId = Just $ groupMemberId' forwardingMember - refAuthorId = Just $ groupMemberId' refAuthorMember - -- TODO [channels fwd] TBC highlighting difference between deduplicated messages (useRelays branch) + refAuthorId = groupMemberId' <$> refAuthorMember_ + -- TODO [relays] TBC highlighting difference between deduplicated messages (useRelays branch) withStore' (\db -> runExceptT $ createNewRcvMessage db (GroupId groupId) newMsg sharedMsgId_ refAuthorId fwdMemberId) >>= \case Right msg -> pure $ Just msg Left e@SEDuplicateGroupMessage {authorGroupMemberId, forwardedByGroupMemberId} @@ -2218,7 +2225,7 @@ saveGroupFwdRcvMsg user gInfo@GroupInfo {groupId} forwardingMember refAuthorMemb (Just authorGMId, Nothing) -> do vr <- chatVersionRange am@GroupMember {memberId = amMemberId} <- withStore $ \db -> getGroupMember db vr user groupId authorGMId - if sameMemberId refMemberId am + if maybe False (\ref -> sameMemberId (memberId' ref) am) refAuthorMember_ then forM_ (memberConn forwardingMember) $ \fmConn -> void $ sendDirectMemberMessage fmConn (XGrpMemCon amMemberId) groupId else toView $ CEvtMessageError user "error" "saveGroupFwdRcvMsg: referenced author member id doesn't match message member id" @@ -2233,7 +2240,7 @@ saveSndChatItem user cd msg content = saveSndChatItem' user cd msg content Nothi saveSndChatItem' :: ChatTypeI c => User -> ChatDirection c 'MDSnd -> SndMessage -> CIContent 'MDSnd -> Maybe (CIFile 'MDSnd) -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> CM (ChatItem c 'MDSnd) saveSndChatItem' user cd msg content ciFile quotedItem itemForwarded itemTimed live = do let itemTexts = ciContentTexts content - saveSndChatItems user cd [Right NewSndChatItemData {msg, content, itemTexts, itemMentions = M.empty, ciFile, quotedItem, itemForwarded}] itemTimed live >>= \case + saveSndChatItems user cd False [Right NewSndChatItemData {msg, content, itemTexts, itemMentions = M.empty, ciFile, quotedItem, itemForwarded}] itemTimed live >>= \case [Right ci] -> pure ci _ -> throwChatError $ CEInternalError "saveSndChatItem': expected 1 item" @@ -2252,11 +2259,12 @@ saveSndChatItems :: ChatTypeI c => User -> ChatDirection c 'MDSnd -> + ShowGroupAsSender -> [Either ChatError (NewSndChatItemData c)] -> Maybe CITimed -> Bool -> CM [Either ChatError (ChatItem c 'MDSnd)] -saveSndChatItems user cd itemsData itemTimed live = do +saveSndChatItems user cd showGroupAsSender itemsData itemTimed live = do createdAt <- liftIO getCurrentTime vr <- chatVersionRange when (contactChatDeleted cd || any (\NewSndChatItemData {content} -> ciRequiresAttention content) (rights itemsData)) $ @@ -2266,9 +2274,9 @@ saveSndChatItems user cd itemsData itemTimed live = do createItem :: DB.Connection -> UTCTime -> NewSndChatItemData c -> IO (Either ChatError (ChatItem c 'MDSnd)) createItem db createdAt NewSndChatItemData {msg = msg@SndMessage {sharedMsgId}, content, itemTexts, itemMentions, ciFile, quotedItem, itemForwarded} = do let hasLink_ = ciContentHasLink content (snd itemTexts) - ciId <- createNewSndChatItem db user cd msg content quotedItem itemForwarded itemTimed live hasLink_ createdAt + ciId <- createNewSndChatItem db user cd showGroupAsSender msg content quotedItem itemForwarded itemTimed live hasLink_ createdAt forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt - let ci = mkChatItem_ cd False ciId content itemTexts ciFile quotedItem (Just sharedMsgId) itemForwarded itemTimed live False hasLink_ createdAt Nothing createdAt + let ci = mkChatItem_ cd showGroupAsSender ciId content itemTexts ciFile quotedItem (Just sharedMsgId) itemForwarded itemTimed live False hasLink_ createdAt Nothing createdAt Right <$> case cd of CDGroupSnd g _scope | not (null itemMentions) -> createGroupCIMentions db g ci itemMentions _ -> pure ci @@ -2288,33 +2296,38 @@ saveRcvChatItem' user cd msg@RcvMessage {chatMsgEvent, forwardedByMember} shared createdAt <- liftIO getCurrentTime vr <- chatVersionRange withStore' $ \db -> do - (mentions' :: Map MemberName CIMention, userMention) <- case cd of - CDGroupRcv g@GroupInfo {membership} _scope _m -> do - mentions' <- getRcvCIMentions db user g ft_ mentions - let userReply = case cmToQuotedMsg chatMsgEvent of - Just QuotedMsg {msgRef = MsgRef {memberId = Just mId}} -> sameMemberId mId membership - _ -> False - userMention' = userReply || any (\CIMention {memberId} -> sameMemberId memberId membership) mentions' - in pure (mentions', userMention') - CDDirectRcv _ -> pure (M.empty, False) + (mentions' :: Map MemberName CIMention, userMention) <- case toChatInfo cd of + GroupChat g@GroupInfo {membership} _ -> groupMentions db g membership + _ -> pure (M.empty, False) cInfo' <- if (ciRequiresAttention content || contactChatDeleted cd) then updateChatTsStats db vr user cd createdAt (memberChatStats userMention) else pure $ toChatInfo cd - let hasLink_ = ciContentHasLink content ft_ + let showAsGroup = case cd of CDChannelRcv {} -> True; _ -> False + hasLink_ = ciContentHasLink content ft_ (ciId, quotedItem, itemForwarded) <- createNewRcvChatItem db user cd msg sharedMsgId_ content itemTimed live userMention hasLink_ brokerTs createdAt forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt - let ci = mkChatItem_ cd False ciId content (t, ft_) ciFile quotedItem sharedMsgId_ itemForwarded itemTimed live userMention hasLink_ brokerTs forwardedByMember createdAt - ci' <- case cd of - CDGroupRcv g _scope _m | not (null mentions') -> createGroupCIMentions db g ci mentions' + let ci = mkChatItem_ cd showAsGroup ciId content (t, ft_) ciFile quotedItem sharedMsgId_ itemForwarded itemTimed live userMention hasLink_ brokerTs forwardedByMember createdAt + ci' <- case toChatInfo cd of + GroupChat g _ | not (null mentions') -> createGroupCIMentions db g ci mentions' _ -> pure ci pure (ci', cInfo') where + groupMentions db g membership = do + mentions' <- getRcvCIMentions db user g ft_ mentions + let userReply = case cmToQuotedMsg chatMsgEvent of + Just QuotedMsg {msgRef = MsgRef {memberId = Just mId}} -> sameMemberId mId membership + _ -> False + userMention' = userReply || any (\CIMention {memberId} -> sameMemberId memberId membership) mentions' + in pure (mentions', userMention') memberChatStats :: Bool -> Maybe (Int, MemberAttention, Int) memberChatStats userMention = case cd of - CDGroupRcv _g (Just scope) m -> do + CDGroupRcv _g (Just scope) m -> let unread = fromEnum $ ciCreateStatus content == CISRcvNew - in Just (unread, memberAttentionChange unread (Just brokerTs) m scope, fromEnum userMention) + in Just (unread, memberAttentionChange unread (Just brokerTs) (Just m) scope, fromEnum userMention) + CDChannelRcv _g (Just scope) -> + let unread = fromEnum $ ciCreateStatus content == CISRcvNew + in Just (unread, memberAttentionChange unread (Just brokerTs) Nothing scope, fromEnum userMention) _ -> Nothing -- TODO [mentions] optimize by avoiding unnecessary parsing @@ -2594,7 +2607,7 @@ createChatItems user itemTs_ dirsCIContents = do memberChatStats = case cd of CDGroupRcv _g (Just scope) m -> do let unread = length $ filter (ciRequiresAttention . fst) contents - in Just (unread, memberAttentionChange unread itemTs_ m scope, 0) + in Just (unread, memberAttentionChange unread itemTs_ (Just m) scope, 0) _ -> Nothing createACIs :: DB.Connection -> UTCTime -> UTCTime -> (ChatDirection c d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId)]) -> [IO AChatItem] createACIs db itemTs createdAt (cd, showGroupAsSender, contents) = map createACI contents @@ -2605,10 +2618,12 @@ createChatItems user itemTs_ dirsCIContents = do let ci = mkChatItem cd showGroupAsSender ciId content Nothing Nothing Nothing Nothing Nothing False False itemTs Nothing createdAt pure $ AChatItem (chatTypeI @c) (msgDirection @d) (toChatInfo cd) ci -memberAttentionChange :: Int -> (Maybe UTCTime) -> GroupMember -> GroupChatScopeInfo -> MemberAttention -memberAttentionChange unread brokerTs_ rcvMem = \case +-- rcvMem_ Nothing means message from channel - treated same as message from moderator, +-- e.g. it can reset unanswered counter if newer than last unanswered message. +memberAttentionChange :: Int -> (Maybe UTCTime) -> Maybe GroupMember -> GroupChatScopeInfo -> MemberAttention +memberAttentionChange unread brokerTs_ rcvMem_ = \case GCSIMemberSupport (Just suppMem) - | groupMemberId' suppMem == groupMemberId' rcvMem -> MAInc unread brokerTs_ + | maybe False ((groupMemberId' suppMem ==) . groupMemberId') rcvMem_ -> MAInc unread brokerTs_ | msgIsNewerThanLastUnanswered -> MAReset | otherwise -> MAInc 0 Nothing where diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index 1f1b56598c..a172b141ec 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/src/Simplex/Chat/Library/Subscriber.hs @@ -210,7 +210,7 @@ processAgentMsgSndFile _corrId aFileId msg = do Nothing -> eToView $ ChatError $ CEInternalError "SFDONE, sendFileDescriptions: expected at least 1 result" lift $ withAgent' (`xftpDeleteSndFileInternal` aFileId) (_, _, SMDSnd, GroupChat g@GroupInfo {groupId} _scope) -> do - -- TODO [channels fwd] single description for all recipients + -- TODO [relays] single description for all recipients ms <- getRecipients let rfdsMemberFTs = zipWith (\rfd (conn, sft) -> (conn, sft, fileDescrText rfd)) rfds (memberFTs ms) extraRFDs = drop (length rfdsMemberFTs) rfds @@ -480,7 +480,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = case event of XMsgNew mc -> newContentMessage ct'' mc msg msgMeta XMsgFileDescr sharedMsgId fileDescr -> messageFileDescription ct'' sharedMsgId fileDescr - XMsgUpdate sharedMsgId mContent _ ttl live _msgScope -> messageUpdate ct'' sharedMsgId mContent msg msgMeta ttl live + XMsgUpdate sharedMsgId mContent _ ttl live _msgScope _ -> messageUpdate ct'' sharedMsgId mContent msg msgMeta ttl live XMsgDel sharedMsgId _ _ -> messageDelete ct'' sharedMsgId msg msgMeta XMsgReact sharedMsgId _ _ reaction add -> directMsgReaction ct'' sharedMsgId reaction add msg msgMeta -- TODO discontinue XFile @@ -667,7 +667,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = where sendAutoReply ct mc = \case Just UserContactRequest {welcomeSharedMsgId = Just smId} -> - void $ sendDirectContactMessage user ct $ XMsgUpdate smId mc M.empty Nothing Nothing Nothing + void $ sendDirectContactMessage user ct $ XMsgUpdate smId mc M.empty Nothing Nothing Nothing Nothing _ -> do (msg, _) <- sendDirectContactMessage user ct $ XMsgNew $ MCSimple $ extMsgContent mc Nothing ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc) @@ -932,48 +932,58 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = logInfo $ "group msg=" <> tshow tag <> " " <> eInfo let body = chatMsgToBody chatMsg (m'', conn', msg@RcvMessage {msgId, chatMsgEvent = ACME _ event}) <- saveGroupRcvMsg user groupId m' conn msgMeta body chatMsg + let ctx js = DeliveryTaskContext js False + checkSendAsGroup :: Maybe Bool -> CM (Maybe DeliveryTaskContext) -> CM (Maybe DeliveryTaskContext) + checkSendAsGroup asGroup_ a + | asGroup_ == Just True && memberRole' m'' < GROwner = + messageError "member is not allowed to send as group" $> Nothing + | otherwise = a -- ! 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 + deliveryTaskContext_ <- case event of + XMsgNew mc -> + checkSendAsGroup asGroup $ + memberCanSend (Just m'') scope $ newGroupContentMessage gInfo' (Just m'') mc msg brokerTs False where - ExtMsgContent {scope} = mcExtMsgContent mc + ExtMsgContent {scope, asGroup} = mcExtMsgContent mc -- file description is always allowed, to allow sending files to support scope - 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 + XMsgFileDescr sharedMsgId fileDescr -> groupMessageFileDescription gInfo' (Just m'') sharedMsgId fileDescr + XMsgUpdate sharedMsgId mContent mentions ttl live msgScope asGroup_ -> + checkSendAsGroup asGroup_ $ + memberCanSend (Just m'') msgScope $ + groupMessageUpdate gInfo' (Just m'') sharedMsgId mContent mentions msgScope msg brokerTs ttl live asGroup_ + XMsgDel sharedMsgId memberId_ scope_ -> groupMessageDelete gInfo' (Just m'') sharedMsgId memberId_ scope_ msg brokerTs + XMsgReact sharedMsgId memberId scope_ reaction add -> groupMsgReaction gInfo' m'' sharedMsgId memberId scope_ reaction add msg brokerTs -- TODO discontinue XFile XFile fInv -> Nothing <$ processGroupFileInvitation' gInfo' m'' fInv msg brokerTs - XFileCancel sharedMsgId -> xFileCancelGroup gInfo' m'' sharedMsgId + XFileCancel sharedMsgId -> xFileCancelGroup gInfo' (Just m'') sharedMsgId XFileAcptInv sharedMsgId fileConnReq_ fName -> Nothing <$ xFileAcptInvGroup gInfo' m'' sharedMsgId fileConnReq_ fName - XInfo p -> xInfoMember gInfo' m'' p brokerTs + XInfo p -> fmap ctx <$> 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 + XGrpMemNew memInfo msgScope -> fmap ctx <$> 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 + XGrpMemRole memId memRole -> fmap ctx <$> xGrpMemRole gInfo' m'' memId memRole msg brokerTs + XGrpMemRestrict memId memRestrictions -> fmap ctx <$> 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 -- 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' + SJson -> fmap ctx <$> xGrpMemDel gInfo' m'' memId withMessages chatMsg msg brokerTs False + SBinary -> pure Nothing + XGrpLeave -> fmap ctx <$> xGrpLeave gInfo' m'' msg brokerTs + XGrpDel -> Just (DeliveryTaskContext (DJSGroup {jobSpec = DJRelayRemoved}) False) <$ xGrpDel gInfo' m'' msg brokerTs + XGrpInfo p' -> fmap ctx <$> xGrpInfo gInfo' m'' p' msg brokerTs + XGrpPrefs ps' -> fmap ctx <$> xGrpPrefs gInfo' m'' ps' -- TODO [knocking] why don't we forward these messages? - XGrpDirectInv connReq mContent_ msgScope -> memberCanSend m'' msgScope $ Nothing <$ xGrpDirectInv gInfo' m'' conn' connReq mContent_ msg brokerTs + XGrpDirectInv connReq mContent_ msgScope -> memberCanSend (Just 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} + forM deliveryTaskContext_ $ \taskContext -> + pure $ NewMessageDeliveryTask {messageId = msgId, taskContext} checkSendRcpt :: [AChatMessage] -> CM Bool checkSendRcpt aMsgs = do currentMemCount <- withStore' $ \db -> getGroupCurrentMembersCount db user gInfo @@ -987,7 +997,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = hasDeliveryReceipt (toCMEventTag chatMsgEvent) createDeliveryTasks :: GroupInfo -> GroupMember -> [NewMessageDeliveryTask] -> CM ShouldDeleteGroupConns createDeliveryTasks gInfo'@GroupInfo {groupId = gId} m' newDeliveryTasks = do - let relayRemovedTask_ = find (\NewMessageDeliveryTask {jobScope} -> isRelayRemoved jobScope) newDeliveryTasks + let relayRemovedTask_ = find (\NewMessageDeliveryTask {taskContext = DeliveryTaskContext {jobScope}} -> isRelayRemoved jobScope) newDeliveryTasks createdDeliveryTasks <- case relayRemovedTask_ of Nothing -> do withStore' $ \db -> @@ -1007,7 +1017,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = where uniqueWorkerScopes :: [NewMessageDeliveryTask] -> [DeliveryWorkerScope] uniqueWorkerScopes createdDeliveryTasks = - let workerScopes = map (\NewMessageDeliveryTask {jobScope} -> toWorkerScope jobScope) createdDeliveryTasks + let workerScopes = map (\NewMessageDeliveryTask {taskContext = DeliveryTaskContext {jobScope}} -> toWorkerScope jobScope) createdDeliveryTasks in foldr' addWorkerScope [] workerScopes where addWorkerScope workerScope acc @@ -1128,7 +1138,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = _ -> pure Nothing sendGroupAutoReply mc = \case Just UserContactRequest {welcomeSharedMsgId = Just smId} -> - void $ sendGroupMessage' user gInfo [m] $ XMsgUpdate smId mc M.empty Nothing Nothing Nothing + void $ sendGroupMessage' user gInfo [m] $ XMsgUpdate smId mc M.empty Nothing Nothing Nothing Nothing _ -> do msg <- sendGroupMessage' user gInfo [m] $ XMsgNew $ MCSimple $ extMsgContent mc Nothing ci <- saveSndChatItem user (CDGroupSnd gInfo Nothing) msg (CISndMsgContent mc) @@ -1338,7 +1348,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = upsertBusinessRequestItem cd@(CDGroupRcv gInfo@GroupInfo {groupId} _ clientMember) = upsertRequestItem cd updateRequestItem markRequestItemDeleted where updateRequestItem (sharedMsgId, mc) = - withStore (\db -> getGroupChatItemBySharedMsgId db user gInfo (groupMemberId' clientMember) sharedMsgId) >>= \case + withStore (\db -> getGroupChatItemBySharedMsgId db user gInfo (Just $ groupMemberId' clientMember) sharedMsgId) >>= \case CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv m', content = CIRcvMsgContent oldMC} | sameMemberId (memberId' clientMember) m' -> if mc /= oldMC @@ -1364,6 +1374,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = else markGroupCIsDeleted user gInfo Nothing [cci] Nothing currentTs toView $ CEvtChatItemsDeleted user deletions False False _ -> pure () + upsertBusinessRequestItem (CDChannelRcv _ _) = const $ pure Nothing createRequestItem :: ChatTypeI c => ChatDirection c 'MDRcv -> (SharedMsgId, MsgContent) -> CM AChatItem createRequestItem cd (sharedMsgId, mc) = do aci <- createChatItem user cd False (CIRcvMsgContent mc) (Just sharedMsgId) Nothing @@ -1417,12 +1428,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = Nothing -> messageError "memberJoinRequestViaRelay: no group link info for relay link" - memberCanSend :: - GroupMember -> - Maybe MsgScope -> - CM (Maybe DeliveryJobScope) -> - CM (Maybe DeliveryJobScope) - memberCanSend m@GroupMember {memberRole} msgScope a = case msgScope of + memberCanSend :: Maybe GroupMember -> Maybe MsgScope -> CM (Maybe DeliveryTaskContext) -> CM (Maybe DeliveryTaskContext) + memberCanSend Nothing _ a = a -- channel message - was previously checked and allowed by relay + memberCanSend (Just m@GroupMember {memberRole}) msgScope a = case msgScope of Just MSMember {} -> a Nothing | memberRole > GRObserver || memberPending m -> a @@ -1618,7 +1626,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = newContentMessage :: Contact -> MsgContainer -> RcvMessage -> MsgMeta -> CM () newContentMessage ct mc msg@RcvMessage {sharedMsgId_} msgMeta = do - let ExtMsgContent content _ fInv_ _ _ _ = mcExtMsgContent mc + let ExtMsgContent content _ fInv_ _ _ _ _ = mcExtMsgContent mc -- Uncomment to test stuck delivery on errors - see test testDirectMessageDelete -- case content of -- MCText "hello 111" -> @@ -1629,7 +1637,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = then do void $ newChatItem (ciContentNoParse $ CIRcvChatFeatureRejected CFVoice) Nothing Nothing False else do - let ExtMsgContent _ _ _ itemTTL live_ _ = mcExtMsgContent mc + let ExtMsgContent _ _ _ itemTTL live_ _ _ = mcExtMsgContent mc timed_ = rcvContactCITimed ct itemTTL live = fromMaybe False live_ file_ <- processFileInvitation fInv_ content $ \db -> createRcvFileTransfer db userId ct @@ -1656,22 +1664,21 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = pure (fileId, aci) processFDMessage fileId aci fileDescr - groupMessageFileDescription :: GroupInfo -> GroupMember -> SharedMsgId -> FileDescr -> CM (Maybe DeliveryJobScope) - groupMessageFileDescription g@GroupInfo {groupId} GroupMember {memberId} sharedMsgId fileDescr = do + groupMessageFileDescription :: GroupInfo -> Maybe GroupMember -> SharedMsgId -> FileDescr -> CM (Maybe DeliveryTaskContext) + groupMessageFileDescription g@GroupInfo {groupId} m_ sharedMsgId fileDescr = do (fileId, aci) <- withStore $ \db -> do fileId <- getGroupFileIdBySharedMsgId db userId groupId sharedMsgId aci <- getChatItemByFileId db vr user fileId pure (fileId, aci) case aci of - AChatItem SCTGroup SMDRcv (GroupChat _g scopeInfo) ChatItem {chatDir = CIGroupRcv m} -> - if sameMemberId memberId m - then do + AChatItem SCTGroup SMDRcv (GroupChat _g scopeInfo) ChatItem {chatDir} + | validSender m_ chatDir -> do -- in processFDMessage some paths are programmed as errors, -- 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 $ infoToDeliveryScope g scopeInfo - else messageError "x.msg.file.descr: file of another member" $> Nothing + pure $ Just $ infoToDeliveryContext g scopeInfo (isChannelDir chatDir) + | otherwise -> messageError "x.msg.file.descr: file/sender mismatch" $> Nothing _ -> messageError "x.msg.file.descr: invalid file description part" $> Nothing processFDMessage :: FileTransferId -> AChatItem -> FileDescr -> CM () @@ -1791,28 +1798,31 @@ 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 DeliveryJobScope) - groupMsgReaction g m@GroupMember {memberRole} sharedMsgId itemMemberId scope_ reaction add RcvMessage {msgId} brokerTs + groupMsgReaction :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe MemberId -> Maybe MsgScope -> MsgReaction -> Bool -> RcvMessage -> UTCTime -> CM (Maybe DeliveryTaskContext) + groupMsgReaction g m sharedMsgId itemMemberId scope_ reaction add RcvMessage {msgId} brokerTs | groupFeatureAllowed SGFReactions g = do rs <- withStore' $ \db -> getGroupReactions db g m itemMemberId sharedMsgId False if reactionAllowed add reaction rs then updateChatItemReaction `catchCINotFound` \_ -> case scope_ of Just (MSMember scopeMemberId) - | memberRole >= GRModerator || scopeMemberId == memberId' m -> - withStore $ \db -> do + | memberRole' m >= GRModerator || scopeMemberId == memberId' m -> do + djScope <- withStore $ \db -> do liftIO $ setGroupReaction db g m itemMemberId sharedMsgId False reaction add msgId brokerTs Just . DJSMemberSupport <$> getScopeMemberIdViaMemberId db user g m scopeMemberId + pure $ fmap (\js -> DeliveryTaskContext js False) djScope | otherwise -> pure Nothing Nothing -> do withStore' $ \db -> setGroupReaction db g m itemMemberId sharedMsgId False reaction add msgId brokerTs - pure $ Just DJSGroup {jobSpec = DJDeliveryJob {includePending = False}} + pure $ Just $ DeliveryTaskContext (DJSGroup {jobSpec = DJDeliveryJob {includePending = False}}) False else pure Nothing | otherwise = pure Nothing where updateChatItemReaction = do (CChatItem md ci, scopeInfo) <- withStore $ \db -> do - cci <- getGroupMemberCIBySharedMsgId db user g itemMemberId sharedMsgId + cci <- case itemMemberId of + Just itemMemberId' -> getGroupMemberCIBySharedMsgId db user g itemMemberId' sharedMsgId + Nothing -> getGroupChatItemBySharedMsgId db user g Nothing sharedMsgId scopeInfo <- getGroupChatScopeInfoForItem db vr user g (cChatItemId cci) pure (cci, scopeInfo) if ciReactionAllowed ci @@ -1823,7 +1833,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 $ infoToDeliveryScope g scopeInfo + pure $ Just $ infoToDeliveryContext g scopeInfo False else pure Nothing reactionAllowed :: Bool -> MsgReaction -> [MsgReaction] -> Bool @@ -1835,70 +1845,92 @@ 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 DeliveryJobScope) - newGroupContentMessage gInfo m@GroupMember {memberId, memberRole} mc msg@RcvMessage {sharedMsgId_} brokerTs forwarded = do - (gInfo', m', scopeInfo) <- mkGetMessageChatScope vr user gInfo m content msgScope_ - if blockedByAdmin m' - then createBlockedByAdmin gInfo' m' scopeInfo $> Nothing - else case prohibitedGroupContent gInfo' m' scopeInfo content ft_ fInv_ False of - Just f -> rejected gInfo' m' scopeInfo f $> Nothing - Nothing -> - withStore' (\db -> getCIModeration db vr user gInfo' memberId sharedMsgId_) >>= \case - Just ciModeration -> do - applyModeration gInfo' m' scopeInfo ciModeration - withStore' $ \db -> deleteCIModeration db gInfo' memberId sharedMsgId_ - pure Nothing - Nothing -> do - createContentItem gInfo' m' scopeInfo - pure $ Just $ infoToDeliveryScope gInfo scopeInfo + validSender :: Maybe GroupMember -> CIDirection 'CTGroup 'MDRcv -> Bool + validSender (Just m) (CIGroupRcv mem) = sameMemberId (memberId' m) mem + validSender m_ CIChannelRcv = maybe True (\m -> memberRole' m == GROwner) m_ + validSender _ _ = False + + isChannelDir :: CIDirection 'CTGroup 'MDRcv -> ShowGroupAsSender + isChannelDir CIChannelRcv = True + isChannelDir _ = False + + newGroupContentMessage :: GroupInfo -> Maybe GroupMember -> MsgContainer -> RcvMessage -> UTCTime -> Bool -> CM (Maybe DeliveryTaskContext) + newGroupContentMessage gInfo m_ mc msg@RcvMessage {sharedMsgId_} brokerTs forwarded = case m_ of + Nothing -> do + createContentItem gInfo Nothing Nothing + -- no delivery task - message already forwarded by relay + pure Nothing + Just m@GroupMember {memberId} -> do + (gInfo', m', scopeInfo) <- mkGetMessageChatScope vr user gInfo m content msgScope_ + if blockedByAdmin m' + then createBlockedByAdmin gInfo' (Just m') scopeInfo $> Nothing + else case prohibitedGroupContent gInfo' m' scopeInfo content ft_ fInv_ False of + Just f -> rejected gInfo' (Just m') scopeInfo f $> Nothing + Nothing -> + withStore' (\db -> getCIModeration db vr user gInfo' memberId sharedMsgId_) >>= \case + Just ciModeration -> do + applyModeration gInfo' m' scopeInfo ciModeration + withStore' $ \db -> deleteCIModeration db gInfo' memberId sharedMsgId_ + pure Nothing + Nothing -> do + createContentItem gInfo' (Just m') scopeInfo + pure $ Just $ infoToDeliveryContext gInfo' scopeInfo sentAsGroup 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 + timed_ gInfo' = if forwarded then rcvCITimed_ (Just Nothing) itemTTL else rcvGroupCITimed gInfo' itemTTL live' = fromMaybe False live_ - ExtMsgContent content mentions fInv_ itemTTL live_ msgScope_ = mcExtMsgContent mc + ExtMsgContent content mentions fInv_ itemTTL live_ msgScope_ asGroup_ = mcExtMsgContent mc + sentAsGroup = asGroup_ == Just True ts@(_, ft_) = msgContentTexts content - saveRcvCI gInfo' m' scopeInfo = saveRcvChatItem' user (CDGroupRcv gInfo' scopeInfo m') msg sharedMsgId_ brokerTs + -- m' is Maybe GroupMember + saveRcvCI gInfo' m' scopeInfo = + let itemMember_ = if sentAsGroup then Nothing else m' + chatDir = maybe (CDChannelRcv gInfo' scopeInfo) (CDGroupRcv gInfo' scopeInfo) itemMember_ + in saveRcvChatItem' user chatDir msg sharedMsgId_ brokerTs createBlockedByAdmin gInfo' m' scopeInfo | groupFeatureAllowed SGFFullDelete gInfo' = do -- ignores member role when blocked by admin - (ci, cInfo) <- saveRcvCI gInfo' m' scopeInfo (ciContentNoParse CIRcvBlocked) Nothing (timed' gInfo') False M.empty + (ci, cInfo) <- saveRcvCI gInfo' m' scopeInfo (ciContentNoParse CIRcvBlocked) Nothing (timed_ gInfo') False M.empty ci' <- withStore' $ \db -> updateGroupCIBlockedByAdmin db user gInfo' ci brokerTs groupMsgToView cInfo ci' | otherwise = do - file_ <- processFileInv m' + file_ <- processFileInv gInfo' m' (ci, cInfo) <- createNonLive gInfo' m' scopeInfo file_ ci' <- withStore' $ \db -> markGroupCIBlockedByAdmin db user gInfo' ci groupMsgToView cInfo ci' - applyModeration gInfo' m' scopeInfo CIModeration {moderatorMember = moderator@GroupMember {memberRole = moderatorRole}, moderatedAt} + applyModeration gInfo' m'@GroupMember {memberRole} scopeInfo CIModeration {moderatorMember = moderator@GroupMember {memberRole = moderatorRole}, moderatedAt} | moderatorRole < GRModerator || moderatorRole < memberRole = - createContentItem gInfo' m' scopeInfo + createContentItem gInfo' (Just m') scopeInfo | groupFeatureMemberAllowed SGFFullDelete moderator gInfo' = do - (ci, cInfo) <- saveRcvCI gInfo' m' scopeInfo (ciContentNoParse CIRcvModerated) Nothing (timed' gInfo') False M.empty + (ci, cInfo) <- saveRcvCI gInfo' (Just m') scopeInfo (ciContentNoParse CIRcvModerated) Nothing (timed_ gInfo') False M.empty ci' <- withStore' $ \db -> updateGroupChatItemModerated db user gInfo' ci moderator moderatedAt groupMsgToView cInfo ci' | otherwise = do - file_ <- processFileInv m' - (ci, _cInfo) <- createNonLive gInfo' m' scopeInfo file_ + file_ <- processFileInv gInfo' (Just m') + (ci, _cInfo) <- createNonLive gInfo' (Just m') scopeInfo file_ deletions <- markGroupCIsDeleted user gInfo' scopeInfo [CChatItem SMDRcv ci] (Just moderator) moderatedAt toView $ CEvtChatItemsDeleted user deletions False False + -- m' is Maybe GroupMember createNonLive gInfo' m' scopeInfo file_ = do - saveRcvCI gInfo' m' scopeInfo (CIRcvMsgContent content, ts) (snd <$> file_) (timed' gInfo') False mentions + saveRcvCI gInfo' m' scopeInfo (CIRcvMsgContent content, ts) (snd <$> file_) (timed_ gInfo') False mentions createContentItem gInfo' m' scopeInfo = do - file_ <- processFileInv m' - newChatItem gInfo' m' scopeInfo (CIRcvMsgContent content, ts) (snd <$> file_) (timed' gInfo') live' - unless (memberBlocked m') $ autoAcceptFile file_ - processFileInv m' = - processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m' - newChatItem gInfo' m' scopeInfo ciContent ciFile_ timed_ live = do - let mentions' = if memberBlocked m' then [] else mentions - (ci, cInfo) <- saveRcvCI gInfo' m' scopeInfo ciContent ciFile_ timed_ live mentions' - ci' <- blockedMemberCI gInfo' m' ci - reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getGroupCIReactions db gInfo' memberId sharedMsgId) sharedMsgId_ + file_ <- processFileInv gInfo' m' + newChatItem gInfo' m' scopeInfo (CIRcvMsgContent content, ts) (snd <$> file_) (timed_ gInfo') live' + unless (maybe False memberBlocked m') $ autoAcceptFile file_ + processFileInv gInfo' m' = + let fileMember_ = if sentAsGroup then Nothing else m' + in processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId gInfo' fileMember_ + newChatItem gInfo' m' scopeInfo ciContent ciFile_ timed live = do + let mentions' = if maybe False memberBlocked m' then [] else mentions + (ci, cInfo) <- saveRcvCI gInfo' m' scopeInfo ciContent ciFile_ timed live mentions' + ci' <- maybe (pure ci) (\m -> blockedMemberCI gInfo' m ci) m' + let memberId_ = memberId' <$> m' + 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 DeliveryJobScope) - groupMessageUpdate gInfo@GroupInfo {groupId} m@GroupMember {groupMemberId, memberId} sharedMsgId mc mentions msgScope_ msg@RcvMessage {msgId} brokerTs ttl_ live_ - | prohibitedSimplexLinks gInfo m ft_ = + groupMessageUpdate :: GroupInfo -> Maybe GroupMember -> SharedMsgId -> MsgContent -> Map MemberName MsgMention -> Maybe MsgScope -> RcvMessage -> UTCTime -> Maybe Int -> Maybe Bool -> Maybe Bool -> CM (Maybe DeliveryTaskContext) + groupMessageUpdate gInfo@GroupInfo {groupId} m_ sharedMsgId mc mentions msgScope_ msg@RcvMessage {msgId} brokerTs ttl_ live_ asGroup_ + | Just m <- m_, prohibitedSimplexLinks gInfo m ft_ = messageWarning ("x.msg.update ignored: feature not allowed " <> groupFeatureNameText GFSimplexLinks) $> Nothing | otherwise = do updateRcvChatItem `catchCINotFound` \_ -> do @@ -1906,103 +1938,158 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = -- received an update from the sender, so that it can be referenced later (e.g. by broadcast delete). -- 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 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 $ infoToDeliveryScope gInfo scopeInfo + showGroupAsSender = fromMaybe (isNothing m_) asGroup_ + if showGroupAsSender && maybe False (\m -> memberRole' m < GROwner) m_ + then messageError "x.msg.update: member attempted to update as group" $> Nothing + else do + (gInfo', chatDir, mentions', scopeInfo) <- + if showGroupAsSender + then pure (gInfo, CDChannelRcv gInfo Nothing, mentions, Nothing) + else case m_ of + Just m -> do + let mentions' = if memberBlocked m then [] else mentions + (gInfo', m', scopeInfo) <- mkGetMessageChatScope vr user gInfo m mc msgScope_ + pure (gInfo', CDGroupRcv gInfo' scopeInfo m', mentions', scopeInfo) + Nothing -> pure (gInfo, CDChannelRcv gInfo Nothing, mentions, Nothing) + (ci, cInfo) <- saveRcvChatItem' user chatDir 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'' <- case chatDir of + CDGroupRcv gi' _ m' -> blockedMemberCI gi' m' ci' + CDChannelRcv {} -> pure ci' + toView $ CEvtChatItemUpdated user (AChatItem SCTGroup SMDRcv cInfo ci'') + pure $ Just $ infoToDeliveryContext gInfo' scopeInfo showGroupAsSender where content = CIRcvMsgContent mc ts@(_, ft_) = msgContentTexts mc live = fromMaybe False live_ updateRcvChatItem = do (cci, scopeInfo) <- withStore $ \db -> do - cci <- getGroupChatItemBySharedMsgId db user gInfo groupMemberId sharedMsgId + cci <- + if asGroup_ == Just True + then getGroupChatItemBySharedMsgId db user gInfo Nothing sharedMsgId + else case m_ of + Just m -> getGroupMemberCIBySharedMsgId db user gInfo (memberId' m) sharedMsgId + Nothing -> getGroupChatItemBySharedMsgId db user gInfo Nothing sharedMsgId (cci,) <$> getGroupChatScopeInfoForItem db vr user gInfo (cChatItemId cci) case cci of - CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv m', meta = CIMeta {itemLive}, content = CIRcvMsgContent oldMC} -> - if sameMemberId memberId m' - then do - let changed = mc /= oldMC - if changed || fromMaybe False itemLive - then do - ci' <- withStore' $ \db -> do - when changed $ - addInitialAndNewCIVersions db (chatItemId' ci) (chatItemTs' ci, oldMC) (brokerTs, mc) - reactions <- getGroupCIReactions db gInfo memberId sharedMsgId - let edited = itemLive /= Just True - ciMentions <- getRcvCIMentions db user gInfo ft_ mentions - ci' <- updateGroupChatItem db user groupId ci {reactions} content edited live $ Just msgId - 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 $ 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 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 - Right cci@(CChatItem _ ci@ChatItem {chatDir}) -> case chatDir of - CIGroupRcv mem -> case sndMemberId_ of - -- regular deletion - Nothing - | sameMemberId memberId mem && msgMemberId == memberId && rcvItemDeletable ci brokerTs -> - Just <$> delete cci Nothing - | otherwise -> - messageError "x.msg.del: member attempted invalid message delete" $> Nothing - -- moderation (not limited by time) - Just _ - | sameMemberId memberId mem && msgMemberId == memberId -> - Just <$> delete cci (Just m) - | otherwise -> - moderate mem cci - CIGroupSnd -> moderate membership cci - Left e - | msgMemberId == memberId -> - messageError ("x.msg.del: message not found, " <> tshow e) $> Nothing - | senderRole < GRModerator -> do - messageError $ "x.msg.del: message not found, message of another member with insufficient member permissions, " <> tshow e + CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv m', meta = CIMeta {itemLive}, content = CIRcvMsgContent oldMC} + | isSender m' -> updateCI False ci scopeInfo oldMC itemLive (Just $ memberId' m') + | otherwise -> messageError "x.msg.update: group member attempted to update a message of another member" $> Nothing + CChatItem SMDRcv ci@ChatItem {chatDir = CIChannelRcv, meta = CIMeta {itemLive}, content = CIRcvMsgContent oldMC} + | maybe True (\m -> memberRole' m == GROwner) m_ -> updateCI True ci scopeInfo oldMC itemLive Nothing + | otherwise -> messageError "x.msg.update: member attempted to update channel message" $> Nothing + _ -> messageError "x.msg.update: invalid message update" $> Nothing + where + isSender m' = maybe False (\m -> sameMemberId (memberId' m) m') m_ + updateCI :: ShowGroupAsSender -> ChatItem 'CTGroup 'MDRcv -> Maybe GroupChatScopeInfo -> MsgContent -> Maybe Bool -> Maybe MemberId -> CM (Maybe DeliveryTaskContext) + updateCI showGroupAsSender ci scopeInfo oldMC itemLive memberId = do + let changed = mc /= oldMC + if changed || fromMaybe False itemLive + then do + ci' <- withStore' $ \db -> do + when changed $ + addInitialAndNewCIVersions db (chatItemId' ci) (chatItemTs' ci, oldMC) (brokerTs, mc) + reactions <- getGroupCIReactions db gInfo memberId sharedMsgId + let edited = itemLive /= Just True + ciMentions <- getRcvCIMentions db user gInfo ft_ mentions + ci' <- updateGroupChatItem db user groupId ci {reactions} content edited live $ Just msgId + 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 $ infoToDeliveryContext gInfo scopeInfo showGroupAsSender + else do + toView $ CEvtChatItemNotChanged user (AChatItem SCTGroup SMDRcv (GroupChat gInfo scopeInfo) ci) pure Nothing - | otherwise -> case scope_ of - Just (MSMember scopeMemberId) -> - withStore $ \db -> do - liftIO $ createCIModeration db gInfo m msgMemberId sharedMsgId msgId brokerTs - Just . DJSMemberSupport <$> getScopeMemberIdViaMemberId db user gInfo m scopeMemberId - Nothing -> do - withStore' $ \db -> createCIModeration db gInfo m msgMemberId sharedMsgId msgId brokerTs - pure $ Just DJSGroup {jobSpec = DJDeliveryJob {includePending = False}} + + groupMessageDelete :: GroupInfo -> Maybe GroupMember -> SharedMsgId -> Maybe MemberId -> Maybe MsgScope -> RcvMessage -> UTCTime -> CM (Maybe DeliveryTaskContext) + groupMessageDelete gInfo@GroupInfo {membership} m_ sharedMsgId sndMemberId_ scope_ rcvMsg brokerTs = + findItem >>= \case + Right cci@(CChatItem _ ci@ChatItem {chatDir}) -> case (chatDir, m_) of + (CIGroupRcv mem, Just m@GroupMember {memberId}) -> + let msgMemberId = fromMaybe memberId sndMemberId_ + in case sndMemberId_ of + -- regular deletion + Nothing + | sameMemberId memberId mem && rcvItemDeletable ci brokerTs -> + delete cci False Nothing + | otherwise -> + messageError "x.msg.del: member attempted invalid message delete" $> Nothing + -- moderation (not limited by time) + Just _ + | sameMemberId memberId mem && msgMemberId == memberId -> + delete cci False (Just m) + | otherwise -> moderate m mem cci + (CIChannelRcv, _) + | isNothing sndMemberId_ && isOwner -> delete cci True Nothing + | otherwise -> messageError "x.msg.del: invalid channel message delete" $> Nothing + (CIGroupSnd, Just m) -> moderate m membership cci + _ -> messageError "x.msg.del: invalid message deletion" $> Nothing + Left e -> case m_ of + Just m@GroupMember {memberId, memberRole = senderRole} -> do + let msgMemberId = fromMaybe memberId sndMemberId_ + if + | msgMemberId == memberId -> + messageError ("x.msg.del: message not found, " <> tshow e) $> Nothing + | senderRole < GRModerator -> do + messageError $ "x.msg.del: message not found, message of another member with insufficient member permissions, " <> tshow e + pure Nothing + | otherwise -> case scope_ of + Just (MSMember scopeMemberId) -> + withStore $ \db -> do + liftIO $ createCIModeration db gInfo m msgMemberId sharedMsgId msgId brokerTs + supportGMId <- getScopeMemberIdViaMemberId db user gInfo m scopeMemberId + pure $ Just $ DeliveryTaskContext {jobScope = DJSMemberSupport supportGMId, sentAsGroup = False} + Nothing -> do + withStore' $ \db -> createCIModeration db gInfo m msgMemberId sharedMsgId msgId brokerTs + pure $ Just $ DeliveryTaskContext {jobScope = DJSGroup {jobSpec = DJDeliveryJob {includePending = False}}, sentAsGroup = False} + Nothing -> + messageError ("x.msg.del: channel message not found, " <> tshow e) $> Nothing where - moderate :: GroupMember -> CChatItem 'CTGroup -> CM (Maybe DeliveryJobScope) - moderate mem cci = case sndMemberId_ of + isOwner = maybe True (\m -> memberRole' m == GROwner) m_ + RcvMessage {msgId} = rcvMsg + findItem = do + let tryMemberLookup mId = + withStore' (\db -> runExceptT $ getGroupMemberCIBySharedMsgId db user gInfo mId sharedMsgId) + tryChannelLookup = + withStore' (\db -> runExceptT $ getGroupChatItemBySharedMsgId db user gInfo Nothing sharedMsgId) + case sndMemberId_ of + Just sId -> tryMemberLookup sId + Nothing -> case m_ of + Just GroupMember {memberId} -> + tryMemberLookup memberId >>= \case + Right cci -> pure (Right cci) + Left e -> + tryChannelLookup >>= \case + Right cci -> pure (Right cci) + Left _ -> pure (Left e) + Nothing -> tryChannelLookup + moderate :: GroupMember -> GroupMember -> CChatItem 'CTGroup -> CM (Maybe DeliveryTaskContext) + moderate sender mem cci = case sndMemberId_ of Just sndMemberId - | sameMemberId sndMemberId mem -> checkRole mem $ do - jobScope <- delete cci (Just m) - archiveMessageReports cci m - pure $ Just jobScope + | sameMemberId sndMemberId mem -> checkRole (memberRole' sender) mem $ do + ctx_ <- delete cci False (Just sender) + archiveMessageReports cci sender + pure ctx_ | 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 + checkRole senderRole 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 DeliveryJobScope - delete cci byGroupMember = do + delete :: CChatItem 'CTGroup -> Bool -> Maybe GroupMember -> CM (Maybe DeliveryTaskContext) + delete cci asGroup byGroupMember = do scopeInfo <- withStore $ \db -> getGroupChatScopeInfoForItem db vr user gInfo (cChatItemId cci) + let fullDelete + | asGroup = groupFeatureAllowed SGFFullDelete gInfo + | otherwise = maybe False (\m -> groupFeatureMemberAllowed SGFFullDelete m gInfo) m_ deletions <- - if groupFeatureMemberAllowed SGFFullDelete m gInfo + if fullDelete then deleteGroupCIs user gInfo scopeInfo [cci] byGroupMember brokerTs else markGroupCIsDeleted user gInfo scopeInfo [cci] byGroupMember brokerTs toView $ CEvtChatItemsDeleted user deletions False False - pure $ infoToDeliveryScope gInfo scopeInfo + pure $ if isNothing m_ then Nothing else Just $ infoToDeliveryContext gInfo scopeInfo asGroup archiveMessageReports :: CChatItem 'CTGroup -> GroupMember -> CM () archiveMessageReports (CChatItem _ ci) byMember = do ciIds <- withStore' $ \db -> markMessageReportsDeleted db user gInfo ci byMember brokerTs @@ -2028,7 +2115,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = processGroupFileInvitation' gInfo m fInv@FileInvitation {fileName, fileSize} msg@RcvMessage {sharedMsgId_} brokerTs = do ChatConfig {fileChunkSize} <- asks config inline <- receiveInlineMode fInv Nothing fileChunkSize - RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvGroupFileTransfer db userId m fInv inline fileChunkSize + RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvGroupFileTransfer db userId gInfo (Just m) fInv inline fileChunkSize let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol} content = ciContentNoParse $ CIRcvMsgContent $ MCFile "" @@ -2139,22 +2226,20 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = _ -> pure () receiveFileChunk ft Nothing meta chunk - xFileCancelGroup :: GroupInfo -> GroupMember -> SharedMsgId -> CM (Maybe DeliveryJobScope) - xFileCancelGroup g@GroupInfo {groupId} GroupMember {memberId} sharedMsgId = do + xFileCancelGroup :: GroupInfo -> Maybe GroupMember -> SharedMsgId -> CM (Maybe DeliveryTaskContext) + xFileCancelGroup g@GroupInfo {groupId} m_ sharedMsgId = do (fileId, aci) <- withStore $ \db -> do fileId <- getGroupFileIdBySharedMsgId db userId groupId sharedMsgId (fileId,) <$> getChatItemByFileId db vr user fileId case aci of - AChatItem SCTGroup SMDRcv (GroupChat _g scopeInfo) ChatItem {chatDir = CIGroupRcv m} -> do - if sameMemberId memberId m - then do + AChatItem SCTGroup SMDRcv (GroupChat _g scopeInfo) ChatItem {chatDir} + | validSender m_ chatDir -> do ft <- withStore $ \db -> getRcvFileTransfer db user fileId unless (rcvFileCompleteOrCancelled ft) $ do cancelRcvFileTransfer user ft toView $ CEvtRcvFileSndCancelled user aci ft - 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 + pure $ Just $ infoToDeliveryContext g scopeInfo (isChannelDir chatDir) + | otherwise -> messageError "x.file.cancel: file cancel sender mismatch" $> Nothing _ -> messageError "x.file.cancel: group member attempted invalid file cancel" $> Nothing xFileAcptInvGroup :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe ConnReqInvitation -> String -> CM () @@ -2840,7 +2925,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = if membershipMemId == memId then checkRole membership $ do deleteGroupLinkIfExists user gInfo - -- TODO [channels fwd] possible improvement is to immediately delete rcv queues if isUserGrpFwdRelay + -- TODO [relays] 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} @@ -2892,7 +2977,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = forwardToMember member = do let GroupMember {memberId} = m memberName = Just $ memberShortenedName m - event = XGrpMsgForward memberId memberName chatMsg brokerTs + event = XGrpMsgForward (Just memberId) memberName chatMsg brokerTs sendGroupMemberMessage gInfo member event isUserGrpFwdRelay :: GroupInfo -> Bool @@ -2920,7 +3005,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = xGrpDel gInfo@GroupInfo {membership} m@GroupMember {memberRole} msg brokerTs = do when (memberRole /= GROwner) $ throwChatError $ CEGroupUserRole gInfo GROwner withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemGroupDeleted - -- TODO [channels fwd] possible improvement is to immediately delete rcv queues if isUserGrpFwdRelay + -- TODO [relays] 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) @@ -3048,37 +3133,47 @@ 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 -> UTCTime -> CM () - xGrpMsgForward gInfo m@GroupMember {localDisplayName} memberId memberName chatMsg msgTs brokerTs = do + xGrpMsgForward :: GroupInfo -> GroupMember -> Maybe MemberId -> Maybe ContactName -> ChatMessage 'Json -> UTCTime -> UTCTime -> CM () + xGrpMsgForward gInfo m@GroupMember {localDisplayName} memberId_ memberName_ chatMsg msgTs brokerTs = do unless (isMemberGrpFwdRelay gInfo m) $ throwChatError (CEGroupContactRole localDisplayName) - (author, unknown) <- withStore $ \db -> getCreateUnknownGMByMemberId db vr user gInfo memberId memberName - when unknown $ toView $ CEvtUnknownMemberCreated user gInfo m author - processForwardedMsg author + case memberId_ of + Just memberId -> do + (author, unknown) <- withStore $ \db -> getCreateUnknownGMByMemberId db vr user gInfo memberId memberName_ + when unknown $ toView $ CEvtUnknownMemberCreated user gInfo m author + processForwardedMsg (Just author) + Nothing -> processForwardedMsg Nothing where -- ! see isForwardedGroupMsg: forwarded group events should include msgId to be deduplicated - processForwardedMsg :: GroupMember -> CM () - processForwardedMsg author = do + processForwardedMsg :: Maybe GroupMember -> CM () + processForwardedMsg author_ = do let body = chatMsgToBody chatMsg - rcvMsg_ <- saveGroupFwdRcvMsg user gInfo m author body chatMsg brokerTs + rcvMsg_ <- saveGroupFwdRcvMsg user gInfo m author_ body chatMsg brokerTs forM_ rcvMsg_ $ \rcvMsg@RcvMessage {chatMsgEvent = ACME _ event} -> case event of - XMsgNew mc -> void $ memberCanSend author scope $ (const Nothing) <$> newGroupContentMessage gInfo author mc rcvMsg msgTs True + XMsgNew mc -> + void $ memberCanSend author_ scope $ 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 $ (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 - XInfo p -> void $ xInfoMember gInfo author p msgTs - XGrpMemNew memInfo msgScope -> void $ xGrpMemNew gInfo author memInfo msgScope rcvMsg msgTs - XGrpMemRole memId memRole -> void $ xGrpMemRole gInfo author memId memRole rcvMsg msgTs - XGrpMemDel memId withMessages -> void $ xGrpMemDel gInfo author memId withMessages chatMsg rcvMsg msgTs True - XGrpLeave -> void $ xGrpLeave gInfo author rcvMsg msgTs - XGrpDel -> void $ xGrpDel gInfo author rcvMsg msgTs - XGrpInfo p' -> void $ xGrpInfo gInfo author p' rcvMsg msgTs - XGrpPrefs ps' -> void $ xGrpPrefs gInfo author ps' + XMsgFileDescr sharedMsgId fileDescr -> void $ groupMessageFileDescription gInfo author_ sharedMsgId fileDescr + XMsgUpdate sharedMsgId mContent mentions ttl live msgScope asGroup_ -> + void $ memberCanSend author_ msgScope $ groupMessageUpdate gInfo author_ sharedMsgId mContent mentions msgScope rcvMsg msgTs ttl live asGroup_ + XMsgDel sharedMsgId memId scope_ -> void $ groupMessageDelete gInfo author_ sharedMsgId memId scope_ rcvMsg msgTs + XMsgReact sharedMsgId memId scope_ reaction add -> withAuthor XMsgReact_ $ \author -> void $ groupMsgReaction gInfo author sharedMsgId memId scope_ reaction add rcvMsg msgTs + XFileCancel sharedMsgId -> void $ xFileCancelGroup gInfo author_ sharedMsgId + XInfo p -> withAuthor XInfo_ $ \author -> void $ xInfoMember gInfo author p msgTs + XGrpMemNew memInfo msgScope -> withAuthor XGrpMemNew_ $ \author -> void $ xGrpMemNew gInfo author memInfo msgScope rcvMsg msgTs + XGrpMemRole memId memRole -> withAuthor XGrpMemRole_ $ \author -> void $ xGrpMemRole gInfo author memId memRole rcvMsg msgTs + XGrpMemDel memId withMessages -> withAuthor XGrpMemDel_ $ \author -> void $ xGrpMemDel gInfo author memId withMessages chatMsg rcvMsg msgTs True + XGrpLeave -> withAuthor XGrpLeave_ $ \author -> void $ xGrpLeave gInfo author rcvMsg msgTs + XGrpDel -> withAuthor XGrpDel_ $ \author -> void $ xGrpDel gInfo author rcvMsg msgTs + XGrpInfo p' -> withAuthor XGrpInfo_ $ \author -> void $ xGrpInfo gInfo author p' rcvMsg msgTs + XGrpPrefs ps' -> withAuthor XGrpPrefs_ $ \author -> void $ xGrpPrefs gInfo author ps' _ -> messageError $ "x.grp.msg.forward: unsupported forwarded event " <> T.pack (show $ toCMEventTag event) + where + withAuthor :: CMEventTag e -> (GroupMember -> CM ()) -> CM () + withAuthor tag action = case author_ of + Just author -> action author + Nothing -> messageError $ "x.grp.msg.forward: event " <> tshow tag <> " requires author" directMsgReceived :: Contact -> Connection -> MsgMeta -> NonEmpty MsgReceipt -> CM () directMsgReceived ct conn@Connection {connId} msgMeta msgRcpts = do @@ -3194,7 +3289,7 @@ runDeliveryTaskWorker :: AgentClient -> DeliveryWorkerKey -> Worker -> CM () runDeliveryTaskWorker a deliveryKey Worker {doWork} = do delay <- asks $ deliveryWorkerDelay . config vr <- chatVersionRange - -- TODO [channels fwd] in future may be required to read groupInfo and user on each iteration for up to date state + -- TODO [relays] 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 @@ -3233,8 +3328,11 @@ runDeliveryTaskWorker a deliveryKey Worker {doWork} = do | 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 + let MessageDeliveryTask {senderGMId, fwdSender, brokerTs, chatMessage} = task + (memberId_, memberName_) = case fwdSender of + FwdMember mid mname -> (Just mid, Just mname) + FwdChannel -> (Nothing, Nothing) + fwdEvt = XGrpMsgForward memberId_ memberName_ chatMessage brokerTs cm = ChatMessage {chatVRange = vr, msgId = Nothing, chatMsgEvent = fwdEvt} body = chatMsgToBody cm withStore' $ \db -> do diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 056b857f80..2b9e47bc6a 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -116,8 +116,7 @@ checkChatType x = case testEquality (chatTypeI @c) (chatTypeI @c') of Just Refl -> Right x Nothing -> Left "bad chat type" -data GroupChatScope - = GCSMemberSupport {groupMemberId_ :: Maybe GroupMemberId} -- Nothing means own conversation with support +data GroupChatScope = GCSMemberSupport {groupMemberId_ :: Maybe GroupMemberId} -- Nothing means own conversation with support deriving (Eq, Show, Ord) data GroupChatScopeTag @@ -172,8 +171,7 @@ data ChatInfo (c :: ChatType) where deriving instance Show (ChatInfo c) -data GroupChatScopeInfo - = GCSIMemberSupport {groupMember_ :: Maybe GroupMember} +data GroupChatScopeInfo = GCSIMemberSupport {groupMember_ :: Maybe GroupMember} deriving (Show) toChatScope :: GroupChatScopeInfo -> GroupChatScope @@ -292,6 +290,7 @@ data CIDirection (c :: ChatType) (d :: MsgDirection) where CIDirectRcv :: CIDirection 'CTDirect 'MDRcv CIGroupSnd :: CIDirection 'CTGroup 'MDSnd CIGroupRcv :: GroupMember -> CIDirection 'CTGroup 'MDRcv + CIChannelRcv :: CIDirection 'CTGroup 'MDRcv CILocalSnd :: CIDirection 'CTLocal 'MDSnd CILocalRcv :: CIDirection 'CTLocal 'MDRcv @@ -306,6 +305,7 @@ data JSONCIDirection | JCIDirectRcv | JCIGroupSnd | JCIGroupRcv {groupMember :: GroupMember} + | JCIChannelRcv | JCILocalSnd | JCILocalRcv deriving (Show) @@ -316,6 +316,7 @@ jsonCIDirection = \case CIDirectRcv -> JCIDirectRcv CIGroupSnd -> JCIGroupSnd CIGroupRcv m -> JCIGroupRcv m + CIChannelRcv -> JCIChannelRcv CILocalSnd -> JCILocalSnd CILocalRcv -> JCILocalRcv @@ -325,6 +326,7 @@ jsonACIDirection = \case JCIDirectRcv -> ACID SCTDirect SMDRcv CIDirectRcv JCIGroupSnd -> ACID SCTGroup SMDSnd CIGroupSnd JCIGroupRcv m -> ACID SCTGroup SMDRcv $ CIGroupRcv m + JCIChannelRcv -> ACID SCTGroup SMDRcv CIChannelRcv JCILocalSnd -> ACID SCTLocal SMDSnd CILocalSnd JCILocalRcv -> ACID SCTLocal SMDRcv CILocalRcv @@ -359,10 +361,13 @@ chatItemTimed ChatItem {meta = CIMeta {itemTimed}} = itemTimed timedDeleteAt' :: CITimed -> Maybe UTCTime timedDeleteAt' CITimed {deleteAt} = deleteAt -chatItemMember :: GroupInfo -> ChatItem 'CTGroup d -> GroupMember -chatItemMember GroupInfo {membership} ChatItem {chatDir} = case chatDir of - CIGroupSnd -> membership - CIGroupRcv m -> m +chatItemMember :: GroupInfo -> ChatItem 'CTGroup d -> Maybe GroupMember +chatItemMember GroupInfo {membership} ChatItem {chatDir, meta = CIMeta {showGroupAsSender}} = case chatDir of + CIGroupSnd + | showGroupAsSender -> Nothing + | otherwise -> Just membership + CIGroupRcv m -> Just m + CIChannelRcv -> Nothing chatItemRcvFromMember :: ChatItem c d -> Maybe GroupMember chatItemRcvFromMember ChatItem {chatDir} = case chatDir of @@ -383,6 +388,7 @@ data ChatDirection (c :: ChatType) (d :: MsgDirection) where CDDirectRcv :: Contact -> ChatDirection 'CTDirect 'MDRcv CDGroupSnd :: GroupInfo -> Maybe GroupChatScopeInfo -> ChatDirection 'CTGroup 'MDSnd CDGroupRcv :: GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> ChatDirection 'CTGroup 'MDRcv + CDChannelRcv :: GroupInfo -> Maybe GroupChatScopeInfo -> ChatDirection 'CTGroup 'MDRcv CDLocalSnd :: NoteFolder -> ChatDirection 'CTLocal 'MDSnd CDLocalRcv :: NoteFolder -> ChatDirection 'CTLocal 'MDRcv @@ -392,6 +398,7 @@ toCIDirection = \case CDDirectRcv _ -> CIDirectRcv CDGroupSnd _ _ -> CIGroupSnd CDGroupRcv _ _ m -> CIGroupRcv m + CDChannelRcv _ _ -> CIChannelRcv CDLocalSnd _ -> CILocalSnd CDLocalRcv _ -> CILocalRcv @@ -401,6 +408,7 @@ toChatInfo = \case CDDirectRcv c -> DirectChat c CDGroupSnd g s -> GroupChat g s CDGroupRcv g s _ -> GroupChat g s + CDChannelRcv g s -> GroupChat g s CDLocalSnd l -> LocalChat l CDLocalRcv l -> LocalChat l @@ -634,23 +642,23 @@ deriving instance Show (CIQDirection c) data ACIQDirection = forall c. (ChatTypeI c, ChatTypeQuotable c) => ACIQDirection (SChatType c) (CIQDirection c) -jsonCIQDirection :: CIQDirection c -> Maybe JSONCIDirection +jsonCIQDirection :: CIQDirection c -> JSONCIDirection jsonCIQDirection = \case - CIQDirectSnd -> Just JCIDirectSnd - CIQDirectRcv -> Just JCIDirectRcv - CIQGroupSnd -> Just JCIGroupSnd - CIQGroupRcv (Just m) -> Just $ JCIGroupRcv m - CIQGroupRcv Nothing -> Nothing + CIQDirectSnd -> JCIDirectSnd + CIQDirectRcv -> JCIDirectRcv + CIQGroupSnd -> JCIGroupSnd + CIQGroupRcv (Just m) -> JCIGroupRcv m + CIQGroupRcv Nothing -> JCIChannelRcv -jsonACIQDirection :: Maybe JSONCIDirection -> Either String ACIQDirection +jsonACIQDirection :: JSONCIDirection -> Either String ACIQDirection jsonACIQDirection = \case - Just JCIDirectSnd -> Right $ ACIQDirection SCTDirect CIQDirectSnd - Just JCIDirectRcv -> Right $ ACIQDirection SCTDirect CIQDirectRcv - Just JCIGroupSnd -> Right $ ACIQDirection SCTGroup CIQGroupSnd - Just (JCIGroupRcv m) -> Right $ ACIQDirection SCTGroup $ CIQGroupRcv (Just m) - Nothing -> Right $ ACIQDirection SCTGroup $ CIQGroupRcv Nothing - Just JCILocalSnd -> Left "unquotable" - Just JCILocalRcv -> Left "unquotable" + JCIDirectSnd -> Right $ ACIQDirection SCTDirect CIQDirectSnd + JCIDirectRcv -> Right $ ACIQDirection SCTDirect CIQDirectRcv + JCIGroupSnd -> Right $ ACIQDirection SCTGroup CIQGroupSnd + JCIGroupRcv m -> Right $ ACIQDirection SCTGroup $ CIQGroupRcv (Just m) + JCIChannelRcv -> Right $ ACIQDirection SCTGroup $ CIQGroupRcv Nothing + JCILocalSnd -> Left "unquotable" + JCILocalRcv -> Left "unquotable" quoteMsgDirection :: CIQDirection c -> MsgDirection quoteMsgDirection = \case @@ -1468,7 +1476,7 @@ instance FromJSON ACIDirection where parseJSON v = jsonACIDirection <$> J.parseJSON v instance ChatTypeI c => FromJSON (CIQDirection c) where - parseJSON v = (jsonACIQDirection >=> \(ACIQDirection _ x) -> checkChatType x) <$?> J.parseJSON v + parseJSON v = (jsonACIQDirection . fromMaybe JCIChannelRcv >=> \(ACIQDirection _ x) -> checkChatType x) <$?> J.parseJSON v instance ToJSON (CIQDirection c) where toJSON = J.toJSON . jsonCIQDirection diff --git a/src/Simplex/Chat/Messages/Batch.hs b/src/Simplex/Chat/Messages/Batch.hs index 2c3bd2b87d..d8868e1787 100644 --- a/src/Simplex/Chat/Messages/Batch.hs +++ b/src/Simplex/Chat/Messages/Batch.hs @@ -71,12 +71,14 @@ batchDeliveryTasks1 vr maxLen = toResult . foldl' addToBatch ([], [], [], 0, 0) -- 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) + MessageDeliveryTask {taskId, fwdSender, brokerTs, chatMessage} = task msgBody = - let fwdEvt = XGrpMsgForward senderMemberId (Just senderMemberName) chatMessage brokerTs + let (memberId_, memberName_) = case fwdSender of + FwdMember mid mname -> (Just mid, Just mname) + FwdChannel -> (Nothing, Nothing) + fwdEvt = XGrpMsgForward memberId_ memberName_ chatMessage brokerTs cm = ChatMessage {chatVRange = vr, msgId = Nothing, chatMsgEvent = fwdEvt} - in chatMsgToBody cm + in chatMsgToBody cm msgLen = B.length msgBody len' | n == 0 = msgLen diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index b7cfe7f25c..83880ae4bb 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -238,7 +238,7 @@ data MsgRef = MsgRef { msgId :: Maybe SharedMsgId, sentAt :: UTCTime, sent :: Bool, - memberId :: Maybe MemberId -- must be present in all group message references, both referencing sent and received + memberId :: Maybe MemberId -- present in group message references, Nothing for channel messages } deriving (Eq, Show) @@ -305,12 +305,10 @@ 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 - XMsgUpdate :: {msgId :: SharedMsgId, content :: MsgContent, mentions :: Map MemberName MsgMention, ttl :: Maybe Int, live :: Maybe Bool, scope :: Maybe MsgScope} -> ChatMsgEvent 'Json + XMsgUpdate :: {msgId :: SharedMsgId, content :: MsgContent, mentions :: Map MemberName MsgMention, ttl :: Maybe Int, live :: Maybe Bool, scope :: Maybe MsgScope, asGroup :: Maybe Bool} -> ChatMsgEvent 'Json XMsgDel :: {msgId :: SharedMsgId, memberId :: Maybe MemberId, scope :: Maybe MsgScope} -> ChatMsgEvent 'Json XMsgDeleted :: ChatMsgEvent 'Json XMsgReact :: {msgId :: SharedMsgId, memberId :: Maybe MemberId, scope :: Maybe MsgScope, reaction :: MsgReaction, add :: Bool} -> ChatMsgEvent 'Json @@ -345,7 +343,7 @@ data ChatMsgEvent (e :: MsgEncoding) where XGrpInfo :: GroupProfile -> ChatMsgEvent 'Json XGrpPrefs :: GroupPreferences -> ChatMsgEvent 'Json XGrpDirectInv :: ConnReqInvitation -> Maybe MsgContent -> Maybe MsgScope -> ChatMsgEvent 'Json - XGrpMsgForward :: MemberId -> Maybe ContactName -> ChatMessage 'Json -> UTCTime -> ChatMsgEvent 'Json + XGrpMsgForward :: Maybe MemberId -> Maybe ContactName -> ChatMessage 'Json -> UTCTime -> ChatMsgEvent 'Json XInfoProbe :: Probe -> ChatMsgEvent 'Json XInfoProbeCheck :: ProbeHash -> ChatMsgEvent 'Json XInfoProbeOk :: Probe -> ChatMsgEvent 'Json @@ -624,7 +622,8 @@ data ExtMsgContent = ExtMsgContent file :: Maybe FileInvitation, ttl :: Maybe Int, live :: Maybe Bool, - scope :: Maybe MsgScope + scope :: Maybe MsgScope, + asGroup :: Maybe Bool } deriving (Eq, Show) @@ -714,10 +713,11 @@ parseMsgContainer v = live <- v .:? "live" mentions <- fromMaybe M.empty <$> (v .:? "mentions") scope <- v .:? "scope" - pure ExtMsgContent {content, mentions, file, ttl, live, scope} + asGroup <- v .:? "asGroup" + pure ExtMsgContent {content, mentions, file, ttl, live, scope, asGroup} extMsgContent :: MsgContent -> Maybe FileInvitation -> ExtMsgContent -extMsgContent mc file = ExtMsgContent mc M.empty file Nothing Nothing Nothing +extMsgContent mc file = ExtMsgContent mc M.empty file Nothing Nothing Nothing Nothing justTrue :: Bool -> Maybe Bool justTrue True = Just True @@ -770,8 +770,8 @@ msgContainerJSON = \case MCSimple mc -> o $ msgContent mc where o = JM.fromList - msgContent ExtMsgContent {content, mentions, file, ttl, live, scope} = - ("file" .=? file) $ ("ttl" .=? ttl) $ ("live" .=? live) $ ("mentions" .=? nonEmptyMap mentions) $ ("scope" .=? scope) ["content" .= content] + msgContent ExtMsgContent {content, mentions, file, ttl, live, scope, asGroup} = + ("file" .=? file) $ ("ttl" .=? ttl) $ ("live" .=? live) $ ("mentions" .=? nonEmptyMap mentions) $ ("scope" .=? scope) $ ("asGroup" .=? asGroup) ["content" .= content] nonEmptyMap :: Map k v -> Maybe (Map k v) nonEmptyMap m = if M.null m then Nothing else Just m @@ -1089,7 +1089,8 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do ttl <- opt "ttl" live <- opt "live" scope <- opt "scope" - pure XMsgUpdate {msgId = msgId', content, mentions, ttl, live, scope} + asGroup <- opt "asGroup" + pure XMsgUpdate {msgId = msgId', content, mentions, ttl, live, scope, asGroup} XMsgDel_ -> XMsgDel <$> p "msgId" <*> opt "memberId" <*> opt "scope" XMsgDeleted_ -> pure XMsgDeleted XMsgReact_ -> XMsgReact <$> p "msgId" <*> opt "memberId" <*> opt "scope" <*> p "reaction" <*> p "add" @@ -1131,7 +1132,7 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do XGrpInfo_ -> XGrpInfo <$> p "groupProfile" XGrpPrefs_ -> XGrpPrefs <$> p "groupPreferences" XGrpDirectInv_ -> XGrpDirectInv <$> p "connReq" <*> opt "content" <*> opt "scope" - XGrpMsgForward_ -> XGrpMsgForward <$> p "memberId" <*> opt "memberName" <*> p "msg" <*> p "msgTs" + XGrpMsgForward_ -> XGrpMsgForward <$> opt "memberId" <*> opt "memberName" <*> p "msg" <*> p "msgTs" XInfoProbe_ -> XInfoProbe <$> p "probe" XInfoProbeCheck_ -> XInfoProbeCheck <$> p "probeHash" XInfoProbeOk_ -> XInfoProbeOk <$> p "probe" @@ -1158,7 +1159,7 @@ chatToAppMessage chatMsg@ChatMessage {chatVRange, msgId, chatMsgEvent} = case en params = \case XMsgNew container -> msgContainerJSON container XMsgFileDescr msgId' fileDescr -> o ["msgId" .= msgId', "fileDescr" .= fileDescr] - XMsgUpdate {msgId = msgId', content, mentions, ttl, live, scope} -> o $ ("ttl" .=? ttl) $ ("live" .=? live) $ ("scope" .=? scope) $ ("mentions" .=? nonEmptyMap mentions) ["msgId" .= msgId', "content" .= content] + XMsgUpdate {msgId = msgId', content, mentions, ttl, live, scope, asGroup} -> o $ ("asGroup" .=? asGroup) $ ("ttl" .=? ttl) $ ("live" .=? live) $ ("scope" .=? scope) $ ("mentions" .=? nonEmptyMap mentions) ["msgId" .= msgId', "content" .= content] XMsgDel msgId' memberId scope -> o $ ("memberId" .=? memberId) $ ("scope" .=? scope) ["msgId" .= msgId'] XMsgDeleted -> JM.empty XMsgReact msgId' memberId scope reaction add -> o $ ("memberId" .=? memberId) $ ("scope" .=? scope) ["msgId" .= msgId', "reaction" .= reaction, "add" .= add] @@ -1193,7 +1194,7 @@ chatToAppMessage chatMsg@ChatMessage {chatVRange, msgId, chatMsgEvent} = case en XGrpInfo p -> o ["groupProfile" .= p] XGrpPrefs p -> o ["groupPreferences" .= p] XGrpDirectInv connReq content scope -> o $ ("content" .=? content) $ ("scope" .=? scope) ["connReq" .= connReq] - XGrpMsgForward memberId memberName msg msgTs -> o $ ("memberName" .=? memberName) ["memberId" .= memberId, "msg" .= msg, "msgTs" .= msgTs] + XGrpMsgForward memberId memberName msg msgTs -> o $ ("memberId" .=? memberId) $ ("memberName" .=? memberName) ["msg" .= msg, "msgTs" .= msgTs] XInfoProbe probe -> o ["probe" .= probe] XInfoProbeCheck probeHash -> o ["probeHash" .= probeHash] XInfoProbeOk probe -> o ["probe" .= probe] diff --git a/src/Simplex/Chat/Store/Delivery.hs b/src/Simplex/Chat/Store/Delivery.hs index f6e0a0c77c..de12b0deb7 100644 --- a/src/Simplex/Chat/Store/Delivery.hs +++ b/src/Simplex/Chat/Store/Delivery.hs @@ -81,10 +81,10 @@ createMsgDeliveryTask db gInfo sender newTask = do created_at, updated_at ) VALUES (?,?,?,?,?,?,?,?,?,?,?) |] - ((Only groupId) :. jobScopeRow_ jobScope :. (groupMemberId' sender, messageId, BI messageFromChannel, DTSNew, currentTs, currentTs)) + ((Only groupId) :. jobScopeRow_ jobScope :. (groupMemberId' sender, messageId, BI sentAsGroup, DTSNew, currentTs, currentTs)) where GroupInfo {groupId} = gInfo - NewMessageDeliveryTask {messageId, jobScope, messageFromChannel} = newTask + NewMessageDeliveryTask {messageId, taskContext = DeliveryTaskContext {jobScope, sentAsGroup}} = newTask deleteGroupDeliveryTasks :: DB.Connection -> GroupInfo -> IO () deleteGroupDeliveryTasks db GroupInfo {groupId} = @@ -146,16 +146,18 @@ getMsgDeliveryTask_ db taskId = (Only taskId) where toTask :: MessageDeliveryTaskRow -> Either StoreError MessageDeliveryTask - toTask ((Only taskId') :. jobScopeRow :. (senderGMId, senderMemberId, senderMemberName, brokerTs, chatMessage, BI messageFromChannel)) = + toTask ((Only taskId') :. jobScopeRow :. (senderGMId, senderMemberId, senderMemberName, brokerTs, chatMessage, BI showGroupAsSender)) = case toJobScope_ jobScopeRow of - Just jobScope -> Right $ MessageDeliveryTask {taskId = taskId', jobScope, senderGMId, senderMemberId, senderMemberName, brokerTs, chatMessage, messageFromChannel} + Just jobScope -> + let fwdSender = if showGroupAsSender then FwdChannel else FwdMember senderMemberId senderMemberName + in Right $ MessageDeliveryTask {taskId = taskId', jobScope, senderGMId, fwdSender, brokerTs, chatMessage} 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 +-- TODO [relays] 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 = @@ -316,7 +318,7 @@ updateDeliveryJobStatus_ db jobId status errReason_ = do "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 +-- TODO [relays] 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@User {userContactId} GroupInfo {groupId} cursorGMId_ singleSenderGMId_ count = do gmIds :: [Int64] <- diff --git a/src/Simplex/Chat/Store/Files.hs b/src/Simplex/Chat/Store/Files.hs index eac046666b..951fce8958 100644 --- a/src/Simplex/Chat/Store/Files.hs +++ b/src/Simplex/Chat/Store/Files.hs @@ -380,14 +380,16 @@ createRcvFileTransfer db userId Contact {contactId, localDisplayName = c} f@File (fileId, FSNew, fileConnReq, fileInline, rcvFileInline, rfdId, currentTs, currentTs) pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Nothing, cryptoArgs = Nothing} -createRcvGroupFileTransfer :: DB.Connection -> UserId -> GroupMember -> FileInvitation -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer -createRcvGroupFileTransfer db userId GroupMember {groupId, groupMemberId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq, fileInline, fileDescr} rcvFileInline chunkSize = do +createRcvGroupFileTransfer :: DB.Connection -> UserId -> GroupInfo -> Maybe GroupMember -> FileInvitation -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer +createRcvGroupFileTransfer db userId GroupInfo {groupId, localDisplayName = gName} m_ f@FileInvitation {fileName, fileSize, fileConnReq, fileInline, fileDescr} rcvFileInline chunkSize = do currentTs <- liftIO getCurrentTime rfd_ <- mapM (createRcvFD_ db userId currentTs) fileDescr let rfdId = (\RcvFileDescr {fileDescrId} -> fileDescrId) <$> rfd_ -- cryptoArgs = Nothing here, the decision to encrypt is made when receiving it xftpRcvFile = (\rfd -> XFTPRcvFile {rcvFileDescription = rfd, agentRcvFileId = Nothing, agentRcvFileDeleted = False, userApprovedRelays = False}) <$> rfd_ fileProtocol = if isJust rfd_ then FPXFTP else FPSMP + grpMemberId_ = groupMemberId' <$> m_ + senderName = maybe gName (\GroupMember {localDisplayName = c} -> c) m_ fileId <- liftIO $ do DB.execute db @@ -398,8 +400,8 @@ createRcvGroupFileTransfer db userId GroupMember {groupId, groupMemberId, localD DB.execute db "INSERT INTO rcv_files (file_id, file_status, file_queue_info, file_inline, rcv_file_inline, group_member_id, file_descr_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)" - (fileId, FSNew, fileConnReq, fileInline, rcvFileInline, groupMemberId, rfdId, currentTs, currentTs) - pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Just groupMemberId, cryptoArgs = Nothing} + (fileId, FSNew, fileConnReq, fileInline, rcvFileInline, grpMemberId_, rfdId, currentTs, currentTs) + pure RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, senderDisplayName = senderName, chunkSize, cancelled = False, grpMemberId = grpMemberId_, cryptoArgs = Nothing} createRcvStandaloneFileTransfer :: DB.Connection -> UserId -> CryptoFile -> Int64 -> Word32 -> ExceptT StoreError IO Int64 createRcvStandaloneFileTransfer db userId (CryptoFile filePath cfArgs_) fileSize chunkSize = do @@ -528,11 +530,12 @@ getRcvFileTransfer_ db userId fileId = do SELECT r.file_status, r.file_queue_info, r.group_member_id, f.file_name, f.file_size, f.chunk_size, f.cancelled, cs.local_display_name, m.local_display_name, f.file_path, f.file_crypto_key, f.file_crypto_nonce, r.file_inline, r.rcv_file_inline, - r.agent_rcv_file_id, r.agent_rcv_file_deleted, r.user_approved_relays + r.agent_rcv_file_id, r.agent_rcv_file_deleted, r.user_approved_relays, g.local_display_name FROM rcv_files r JOIN files f USING (file_id) LEFT JOIN contacts cs ON cs.contact_id = f.contact_id LEFT JOIN group_members m ON m.group_member_id = r.group_member_id + LEFT JOIN groups g ON g.group_id = f.group_id WHERE f.user_id = ? AND f.file_id = ? |] (userId, fileId) @@ -541,10 +544,10 @@ getRcvFileTransfer_ db userId fileId = do where rcvFileTransfer :: Maybe RcvFileDescr -> - (FileStatus, Maybe ConnReqInvitation, Maybe Int64, String, Integer, Integer, Maybe BoolInt) :. (Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe C.SbKey, Maybe C.CbNonce, Maybe InlineFileMode, Maybe InlineFileMode, Maybe AgentRcvFileId, BoolInt, BoolInt) -> + (FileStatus, Maybe ConnReqInvitation, Maybe Int64, String, Integer, Integer, Maybe BoolInt) :. (Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe C.SbKey, Maybe C.CbNonce, Maybe InlineFileMode, Maybe InlineFileMode, Maybe AgentRcvFileId, BoolInt, BoolInt) :. Only (Maybe ContactName) -> ExceptT StoreError IO RcvFileTransfer - rcvFileTransfer rfd_ ((fileStatus', fileConnReq, grpMemberId, fileName, fileSize, chunkSize, cancelled_) :. (contactName_, memberName_, filePath_, fileKey, fileNonce, fileInline, rcvFileInline, agentRcvFileId, BI agentRcvFileDeleted, BI userApprovedRelays)) = - case contactName_ <|> memberName_ <|> standaloneName_ of + rcvFileTransfer rfd_ ((fileStatus', fileConnReq, grpMemberId, fileName, fileSize, chunkSize, cancelled_) :. (contactName_, memberName_, filePath_, fileKey, fileNonce, fileInline, rcvFileInline, agentRcvFileId, BI agentRcvFileDeleted, BI userApprovedRelays) :. Only groupName_) = + case contactName_ <|> memberName_ <|> groupName_ <|> standaloneName_ of Nothing -> throwError $ SERcvFileInvalid fileId Just name -> case fileStatus' of diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index 7abc865ef1..f603e6d9ba 100644 --- a/src/Simplex/Chat/Store/Groups.hs +++ b/src/Simplex/Chat/Store/Groups.hs @@ -582,23 +582,27 @@ deleteContactCardKeepConn db connId Contact {contactId, profile = LocalProfile { DB.execute db "DELETE FROM contacts WHERE contact_id = ?" (Only contactId) DB.execute db "DELETE FROM contact_profiles WHERE contact_profile_id = ?" (Only profileId) -createPreparedGroup :: DB.Connection -> TVar ChaChaDRG -> VersionRangeChat -> User -> GroupProfile -> Bool -> CreatedLinkContact -> Maybe SharedMsgId -> Bool -> ExceptT StoreError IO (GroupInfo, GroupMember) +createPreparedGroup :: DB.Connection -> TVar ChaChaDRG -> VersionRangeChat -> User -> GroupProfile -> Bool -> CreatedLinkContact -> Maybe SharedMsgId -> Bool -> ExceptT StoreError IO (GroupInfo, Maybe GroupMember) createPreparedGroup db gVar vr user@User {userId, userContactId} groupProfile business connLinkToConnect welcomeSharedMsgId useRelays = do currentTs <- liftIO getCurrentTime let prepared = Just (connLinkToConnect, welcomeSharedMsgId) (groupId, groupLDN) <- createGroup_ db userId groupProfile prepared Nothing useRelays Nothing currentTs - hostMemberId <- insertHost_ currentTs groupId groupLDN + hostMemberId_ <- + if useRelays + then pure Nothing + else Just <$> insertHost_ currentTs groupId groupLDN userMemberId <- if useRelays then liftIO $ MemberId <$> encodedRandomBytes gVar 12 else pure $ MemberId $ encodeUtf8 groupLDN <> "_user_unknown_id" let userMember = MemberIdRole userMemberId GRMember -- TODO [member keys] user key must be included here. Should key be added when group is prepared? - membership <- createContactMemberInv_ db user groupId (Just hostMemberId) user userMember GCUserMember GSMemUnknown IBUnknown Nothing Nothing currentTs vr - hostMember <- getGroupMember db vr user groupId hostMemberId - when business $ liftIO $ setGroupBusinessChatInfo groupId membership hostMember + membership <- createContactMemberInv_ db user groupId hostMemberId_ user userMember GCUserMember GSMemUnknown IBUnknown Nothing Nothing currentTs vr + hostMember_ <- forM hostMemberId_ $ getGroupMember db vr user groupId + forM_ hostMember_ $ \hostMember -> + when business $ liftIO $ setGroupBusinessChatInfo groupId membership hostMember g <- getGroupInfo db vr user groupId - pure (g, hostMember) + pure (g, hostMember_) where insertHost_ currentTs groupId groupLDN = do randHostId <- liftIO $ encodedRandomBytes gVar 12 @@ -637,12 +641,12 @@ updateBusinessChatInfo db groupId businessChatInfo = |] (businessChatInfoRow businessChatInfo :. (Only groupId)) -updatePreparedGroupUser :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> GroupMember -> User -> ExceptT StoreError IO GroupInfo -updatePreparedGroupUser db vr user gInfo@GroupInfo {groupId, membership} hostMember newUser@User {userId = newUserId} = do +updatePreparedGroupUser :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> Maybe GroupMember -> User -> ExceptT StoreError IO GroupInfo +updatePreparedGroupUser db vr user gInfo@GroupInfo {groupId, membership} hostMember_ newUser@User {userId = newUserId} = do currentTs <- liftIO getCurrentTime updateGroup gInfo currentTs liftIO $ updateMembership membership currentTs - updateHostMember hostMember currentTs + forM_ hostMember_ $ \hostMember -> updateHostMember hostMember currentTs getGroupInfo db vr newUser groupId where updateGroup GroupInfo {localDisplayName = oldGroupLDN, groupProfile = GroupProfile {displayName = groupDisplayName}} currentTs = diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index 15b17cd19c..00ab18e939 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -525,9 +525,9 @@ setSupportChatMemberAttention db vr user g m memberAttention = do 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 -> Bool -> UTCTime -> IO ChatItemId -createNewSndChatItem db user chatDirection SndMessage {msgId, sharedMsgId} ciContent quotedItem itemForwarded timed live hasLink createdAt = - createNewChatItem_ db user chatDirection False createdByMsgId (Just sharedMsgId) ciContent quoteRow itemForwarded timed live False hasLink createdAt Nothing createdAt +createNewSndChatItem :: DB.Connection -> User -> ChatDirection c 'MDSnd -> ShowGroupAsSender -> SndMessage -> CIContent 'MDSnd -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> UTCTime -> IO ChatItemId +createNewSndChatItem db user chatDirection showGroupAsSender SndMessage {msgId, sharedMsgId} ciContent quotedItem itemForwarded timed live hasLink createdAt = + createNewChatItem_ db user chatDirection showGroupAsSender createdByMsgId (Just sharedMsgId) ciContent quoteRow itemForwarded timed live False hasLink createdAt Nothing createdAt where createdByMsgId = if msgId == 0 then Nothing else Just msgId quoteRow :: NewQuoteRow @@ -543,7 +543,8 @@ createNewSndChatItem db user chatDirection SndMessage {msgId, sharedMsgId} ciCon createNewRcvChatItem :: ChatTypeQuotable c => DB.Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> Maybe CITimed -> Bool -> Bool -> Bool -> UTCTime -> UTCTime -> IO (ChatItemId, Maybe (CIQuote c), Maybe CIForwardedFrom) createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, forwardedByMember} sharedMsgId_ ciContent timed live userMention hasLink itemTs createdAt = do - ciId <- createNewChatItem_ db user chatDirection False (Just msgId) sharedMsgId_ ciContent quoteRow itemForwarded timed live userMention hasLink itemTs forwardedByMember createdAt + let showAsGroup = case chatDirection of CDChannelRcv {} -> True; _ -> False + ciId <- createNewChatItem_ db user chatDirection showAsGroup (Just msgId) sharedMsgId_ ciContent quoteRow itemForwarded timed live userMention hasLink itemTs forwardedByMember createdAt quotedItem <- mapM (getChatItemQuote_ db user chatDirection) quotedMsg pure (ciId, quotedItem, itemForwarded) where @@ -557,6 +558,8 @@ createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, forw CDDirectRcv _ -> (Just $ not sent, Nothing) CDGroupRcv GroupInfo {membership = GroupMember {memberId = userMemberId}} _ _ -> (Just $ Just userMemberId == memberId, memberId) + CDChannelRcv GroupInfo {membership = GroupMember {memberId = userMemberId}} _ -> + (Just $ Just userMemberId == memberId, memberId) createNewChatItemNoMsg :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> ShowGroupAsSender -> CIContent d -> Maybe SharedMsgId -> Bool -> UTCTime -> UTCTime -> IO ChatItemId createNewChatItemNoMsg db user chatDirection showGroupAsSender ciContent sharedMsgId_ hasLink itemTs = @@ -596,12 +599,14 @@ createNewChatItem_ db User {userId} chatDirection showGroupAsSender msgId_ share CDDirectSnd Contact {contactId} -> (Just contactId, Nothing, Nothing, Nothing) CDGroupRcv GroupInfo {groupId} _ GroupMember {groupMemberId} -> (Nothing, Just groupId, Just groupMemberId, Nothing) CDGroupSnd GroupInfo {groupId} _ -> (Nothing, Just groupId, Nothing, Nothing) + CDChannelRcv GroupInfo {groupId} _ -> (Nothing, Just groupId, Nothing, Nothing) CDLocalRcv NoteFolder {noteFolderId} -> (Nothing, Nothing, Nothing, Just noteFolderId) CDLocalSnd NoteFolder {noteFolderId} -> (Nothing, Nothing, Nothing, Just noteFolderId) groupScope :: Maybe (Maybe GroupChatScopeInfo) groupScope = case chatDirection of CDGroupRcv _ scope _ -> Just scope CDGroupSnd _ scope -> Just scope + CDChannelRcv _ scope -> Just scope _ -> Nothing groupScopeRow :: (Maybe GroupChatScopeTag, Maybe GroupMemberId) groupScopeRow = case groupScope of @@ -640,6 +645,12 @@ getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRe | mId == senderMemberId -> (`ciQuote` CIQGroupRcv (Just sender)) <$> getGroupChatItemId_ groupId senderGMId | otherwise -> getGroupChatItemQuote_ groupId mId _ -> pure . ciQuote Nothing $ CIQGroupRcv Nothing + CDChannelRcv GroupInfo {groupId, membership = GroupMember {memberId = userMemberId}} _s -> + case memberId of + Just mId + | mId == userMemberId -> (`ciQuote` CIQGroupSnd) <$> getUserGroupChatItemId_ groupId + | otherwise -> getGroupChatItemQuote_ groupId mId + _ -> pure . ciQuote Nothing $ CIQGroupRcv Nothing where ciQuote :: Maybe ChatItemId -> CIQDirection c -> CIQuote c ciQuote itemId dir = CIQuote dir itemId msgId sentAt content . parseMaybeMarkdownList $ msgContentText content @@ -2313,6 +2324,12 @@ toGroupChatItem Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent (maybeCIFile fileStatus) (ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, _, Nothing) -> Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent Nothing + (ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Nothing, Just (AFS SMDRcv fileStatus)) + | showGroupAsSender -> + Right $ cItem SMDRcv CIChannelRcv ciStatus ciContent (maybeCIFile fileStatus) + (ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Nothing, Nothing) + | showGroupAsSender -> + Right $ cItem SMDRcv CIChannelRcv ciStatus ciContent Nothing (ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just member, Just (AFS SMDRcv fileStatus)) -> Right $ cItem SMDRcv (CIGroupRcv member) ciStatus ciContent (maybeCIFile fileStatus) (ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just member, Nothing) -> @@ -2668,7 +2685,7 @@ groupCIWithReactions db g cci@(CChatItem md ci@ChatItem {meta = CIMeta {itemId, mentions <- getGroupCIMentions db itemId case itemSharedMsgId of Just sharedMsgId -> do - let GroupMember {memberId} = chatItemMember g ci + let memberId = memberId' <$> chatItemMember g ci reactions <- getGroupCIReactions db g memberId sharedMsgId pure $ CChatItem md ci {reactions, mentions} Nothing -> pure $ if null mentions then cci else CChatItem md ci {mentions} @@ -2913,8 +2930,8 @@ markReceivedGroupReportsDeleted db User {userId} GroupInfo {groupId, membership} |] (DBCIDeleted, deletedTs, groupMemberId' membership, currentTs, userId, groupId, MCReport_, DBCINotDeleted) -getGroupChatItemBySharedMsgId :: DB.Connection -> User -> GroupInfo -> GroupMemberId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTGroup) -getGroupChatItemBySharedMsgId db user@User {userId} g@GroupInfo {groupId} groupMemberId sharedMsgId = do +getGroupChatItemBySharedMsgId :: DB.Connection -> User -> GroupInfo -> Maybe GroupMemberId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTGroup) +getGroupChatItemBySharedMsgId db user@User {userId} g@GroupInfo {groupId} groupMemberId_ sharedMsgId = do itemId <- ExceptT . firstRow fromOnly (SEChatItemSharedMsgIdNotFound sharedMsgId) $ DB.query @@ -2922,11 +2939,11 @@ getGroupChatItemBySharedMsgId db user@User {userId} g@GroupInfo {groupId} groupM [sql| SELECT chat_item_id FROM chat_items - WHERE user_id = ? AND group_id = ? AND group_member_id = ? AND shared_msg_id = ? + WHERE user_id = ? AND group_id = ? AND group_member_id IS NOT DISTINCT FROM ? AND shared_msg_id = ? ORDER BY chat_item_id DESC LIMIT 1 |] - (userId, groupId, groupMemberId, sharedMsgId) + (userId, groupId, groupMemberId_, sharedMsgId) getGroupCIWithReactions db user g itemId getGroupMemberCIBySharedMsgId :: DB.Connection -> User -> GroupInfo -> MemberId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTGroup) @@ -3254,7 +3271,7 @@ getDirectCIReactions db Contact {contactId} itemSharedMsgId = |] (contactId, itemSharedMsgId) -getGroupCIReactions :: DB.Connection -> GroupInfo -> MemberId -> SharedMsgId -> IO [CIReactionCount] +getGroupCIReactions :: DB.Connection -> GroupInfo -> Maybe MemberId -> SharedMsgId -> IO [CIReactionCount] getGroupCIReactions db GroupInfo {groupId} itemMemberId itemSharedMsgId = map toCIReaction <$> DB.query @@ -3262,7 +3279,7 @@ getGroupCIReactions db GroupInfo {groupId} itemMemberId itemSharedMsgId = [sql| SELECT reaction, MAX(reaction_sent), COUNT(chat_item_reaction_id) FROM chat_item_reactions - WHERE group_id = ? AND item_member_id = ? AND shared_msg_id = ? + WHERE group_id = ? AND item_member_id IS NOT DISTINCT FROM ? AND shared_msg_id = ? GROUP BY reaction |] (groupId, itemMemberId, itemSharedMsgId) @@ -3296,7 +3313,7 @@ getACIReactions db aci@(AChatItem _ md chat ci@ChatItem {meta = CIMeta {itemShar reactions <- getDirectCIReactions db ct itemSharedMId pure $ AChatItem SCTDirect md chat ci {reactions} GroupChat g _s -> do - let GroupMember {memberId} = chatItemMember g ci + let memberId = memberId' <$> chatItemMember g ci reactions <- getGroupCIReactions db g memberId itemSharedMId pure $ AChatItem SCTGroup md chat ci {reactions} _ -> pure aci @@ -3310,10 +3327,10 @@ deleteDirectCIReactions_ db contactId ChatItem {meta = CIMeta {itemSharedMsgId}} deleteGroupCIReactions_ :: DB.Connection -> GroupInfo -> ChatItem 'CTGroup d -> IO () deleteGroupCIReactions_ db g@GroupInfo {groupId} ci@ChatItem {meta = CIMeta {itemSharedMsgId}} = forM_ itemSharedMsgId $ \itemSharedMId -> do - let GroupMember {memberId} = chatItemMember g ci + let memberId = memberId' <$> chatItemMember g ci DB.execute db - "DELETE FROM chat_item_reactions WHERE group_id = ? AND shared_msg_id = ? AND item_member_id = ?" + "DELETE FROM chat_item_reactions WHERE group_id = ? AND shared_msg_id = ? AND item_member_id IS NOT DISTINCT FROM ?" (groupId, itemSharedMId, memberId) toCIReaction :: (MsgReaction, BoolInt, Int) -> CIReactionCount @@ -3351,7 +3368,7 @@ setDirectReaction db ct itemSharedMId sent reaction add msgId reactionTs |] (contactId' ct, itemSharedMId, BI sent, reaction) -getGroupReactions :: DB.Connection -> GroupInfo -> GroupMember -> MemberId -> SharedMsgId -> Bool -> IO [MsgReaction] +getGroupReactions :: DB.Connection -> GroupInfo -> GroupMember -> Maybe MemberId -> SharedMsgId -> Bool -> IO [MsgReaction] getGroupReactions db GroupInfo {groupId} m itemMemberId itemSharedMId sent = map fromOnly <$> DB.query @@ -3359,11 +3376,11 @@ getGroupReactions db GroupInfo {groupId} m itemMemberId itemSharedMId sent = [sql| SELECT reaction FROM chat_item_reactions - WHERE group_id = ? AND group_member_id = ? AND item_member_id = ? AND shared_msg_id = ? AND reaction_sent = ? + WHERE group_id = ? AND group_member_id = ? AND item_member_id IS NOT DISTINCT FROM ? AND shared_msg_id = ? AND reaction_sent = ? |] (groupId, groupMemberId' m, itemMemberId, itemSharedMId, BI sent) -setGroupReaction :: DB.Connection -> GroupInfo -> GroupMember -> MemberId -> SharedMsgId -> Bool -> MsgReaction -> Bool -> MessageId -> UTCTime -> IO () +setGroupReaction :: DB.Connection -> GroupInfo -> GroupMember -> Maybe MemberId -> SharedMsgId -> Bool -> MsgReaction -> Bool -> MessageId -> UTCTime -> IO () setGroupReaction db GroupInfo {groupId} m itemMemberId itemSharedMId sent reaction add msgId reactionTs | add = DB.execute @@ -3379,7 +3396,7 @@ setGroupReaction db GroupInfo {groupId} m itemMemberId itemSharedMId sent reacti db [sql| DELETE FROM chat_item_reactions - WHERE group_id = ? AND group_member_id = ? AND shared_msg_id = ? AND item_member_id = ? AND reaction_sent = ? AND reaction = ? + WHERE group_id = ? AND group_member_id = ? AND shared_msg_id = ? AND item_member_id IS NOT DISTINCT FROM ? AND reaction_sent = ? AND reaction = ? |] (groupId, groupMemberId' m, itemSharedMId, itemMemberId, BI sent, reaction) diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/M20230511_reactions.hs b/src/Simplex/Chat/Store/SQLite/Migrations/M20230511_reactions.hs index 17ecb97649..18e9c5f6b6 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/M20230511_reactions.hs +++ b/src/Simplex/Chat/Store/SQLite/Migrations/M20230511_reactions.hs @@ -10,7 +10,7 @@ m20230511_reactions = [sql| CREATE TABLE chat_item_reactions ( chat_item_reaction_id INTEGER PRIMARY KEY AUTOINCREMENT, - item_member_id BLOB, -- member that created item, NULL for items in direct chats + item_member_id BLOB, shared_msg_id BLOB NOT NULL, contact_id INTEGER REFERENCES contacts ON DELETE CASCADE, group_id INTEGER REFERENCES groups ON DELETE CASCADE, 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 0b70fb9dcb..35f2006cef 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/M20250813_delivery_tasks.hs +++ b/src/Simplex/Chat/Store/SQLite/Migrations/M20250813_delivery_tasks.hs @@ -5,7 +5,7 @@ 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 [relays] 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; @@ -21,7 +21,7 @@ import Database.SQLite.Simple.QQ (sql) -- 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), +-- - message_from_channel <-> ShowGroupAsSender (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). 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 a61e6a34e0..90c44f9734 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt +++ b/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt @@ -1105,7 +1105,7 @@ SEARCH chat_item_reactions USING INDEX idx_chat_item_reactions_contact (contact_ Query: DELETE FROM chat_item_reactions - WHERE group_id = ? AND group_member_id = ? AND shared_msg_id = ? AND item_member_id = ? AND reaction_sent = ? AND reaction = ? + WHERE group_id = ? AND group_member_id = ? AND shared_msg_id = ? AND item_member_id IS NOT DISTINCT FROM ? AND reaction_sent = ? AND reaction = ? Plan: SEARCH chat_item_reactions USING INDEX idx_chat_item_reactions_group (group_id=? AND shared_msg_id=?) @@ -1406,7 +1406,7 @@ SEARCH ct USING INTEGER PRIMARY KEY (rowid=?) Query: SELECT chat_item_id FROM chat_items - WHERE user_id = ? AND group_id = ? AND group_member_id = ? AND shared_msg_id = ? + WHERE user_id = ? AND group_id = ? AND group_member_id IS NOT DISTINCT FROM ? AND shared_msg_id = ? ORDER BY chat_item_id DESC LIMIT 1 @@ -1611,11 +1611,12 @@ Query: SELECT r.file_status, r.file_queue_info, r.group_member_id, f.file_name, f.file_size, f.chunk_size, f.cancelled, cs.local_display_name, m.local_display_name, f.file_path, f.file_crypto_key, f.file_crypto_nonce, r.file_inline, r.rcv_file_inline, - r.agent_rcv_file_id, r.agent_rcv_file_deleted, r.user_approved_relays + r.agent_rcv_file_id, r.agent_rcv_file_deleted, r.user_approved_relays, g.local_display_name FROM rcv_files r JOIN files f USING (file_id) LEFT JOIN contacts cs ON cs.contact_id = f.contact_id LEFT JOIN group_members m ON m.group_member_id = r.group_member_id + LEFT JOIN groups g ON g.group_id = f.group_id WHERE f.user_id = ? AND f.file_id = ? Plan: @@ -1623,6 +1624,7 @@ SEARCH f USING INTEGER PRIMARY KEY (rowid=?) SEARCH r USING INTEGER PRIMARY KEY (rowid=?) SEARCH cs USING INTEGER PRIMARY KEY (rowid=?) LEFT-JOIN SEARCH m USING INTEGER PRIMARY KEY (rowid=?) LEFT-JOIN +SEARCH g USING INTEGER PRIMARY KEY (rowid=?) LEFT-JOIN Query: SELECT r.probe, r.contact_id, g.group_id, r.group_member_id @@ -3700,7 +3702,7 @@ SEARCH chat_item_reactions USING INDEX idx_chat_item_reactions_contact (contact_ Query: SELECT reaction FROM chat_item_reactions - WHERE group_id = ? AND group_member_id = ? AND item_member_id = ? AND shared_msg_id = ? AND reaction_sent = ? + WHERE group_id = ? AND group_member_id = ? AND item_member_id IS NOT DISTINCT FROM ? AND shared_msg_id = ? AND reaction_sent = ? Plan: SEARCH chat_item_reactions USING INDEX idx_chat_item_reactions_group (group_id=? AND shared_msg_id=?) @@ -3718,7 +3720,7 @@ USE TEMP B-TREE FOR GROUP BY Query: SELECT reaction, MAX(reaction_sent), COUNT(chat_item_reaction_id) FROM chat_item_reactions - WHERE group_id = ? AND item_member_id = ? AND shared_msg_id = ? + WHERE group_id = ? AND item_member_id IS NOT DISTINCT FROM ? AND shared_msg_id = ? GROUP BY reaction Plan: @@ -5885,7 +5887,7 @@ Query: DELETE FROM chat_item_reactions WHERE group_id = ? Plan: SEARCH chat_item_reactions USING COVERING INDEX idx_chat_item_reactions_group_id (group_id=?) -Query: DELETE FROM chat_item_reactions WHERE group_id = ? AND shared_msg_id = ? AND item_member_id = ? +Query: DELETE FROM chat_item_reactions WHERE group_id = ? AND shared_msg_id = ? AND item_member_id IS NOT DISTINCT FROM ? Plan: SEARCH chat_item_reactions USING INDEX idx_chat_item_reactions_group (group_id=? AND shared_msg_id=?) diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql b/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql index 12951307bb..84d5a8b001 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql @@ -541,7 +541,7 @@ CREATE TABLE chat_item_versions( ) STRICT; CREATE TABLE chat_item_reactions( chat_item_reaction_id INTEGER PRIMARY KEY AUTOINCREMENT, - item_member_id BLOB, -- member that created item, NULL for items in direct chats + item_member_id BLOB, shared_msg_id BLOB NOT NULL, contact_id INTEGER REFERENCES contacts ON DELETE CASCADE, group_id INTEGER REFERENCES groups ON DELETE CASCADE, diff --git a/src/Simplex/Chat/Terminal/Output.hs b/src/Simplex/Chat/Terminal/Output.hs index ca591903ff..2c842a609e 100644 --- a/src/Simplex/Chat/Terminal/Output.hs +++ b/src/Simplex/Chat/Terminal/Output.hs @@ -180,7 +180,8 @@ chatEventNotification t@ChatTerminal {sendNotification} cc = \case whenCurrUser cc u $ setActiveChat t cInfo case (cInfo, chatDir) of (DirectChat ct, _) -> sendNtf (viewContactName ct <> "> ", text) - (GroupChat g scopeInfo, CIGroupRcv m) -> sendNtf (fromGroup_ g scopeInfo m, text) + (GroupChat g scopeInfo, CIGroupRcv m) -> sendNtf (fromGroup_ g scopeInfo (Just m), text) + (GroupChat g scopeInfo, CIChannelRcv) -> sendNtf (fromGroup_ g scopeInfo Nothing, text) _ -> pure () where text = msgText mc formattedText diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 02916d0d82..2329c21e74 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -494,6 +494,12 @@ data GroupInfo = GroupInfo useRelays' :: GroupInfo -> Bool useRelays' GroupInfo {useRelays} = isTrue useRelays +sendAsGroup' :: GroupInfo -> Bool +sendAsGroup' gInfo@GroupInfo {membership} = useRelays' gInfo && memberRole' membership == GROwner + +groupId' :: GroupInfo -> GroupId +groupId' GroupInfo {groupId} = groupId + data BusinessChatType = BCBusiness -- used on the customer side | BCCustomer -- used on the business side diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index b1fa59f9ef..5784e9b7e0 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -552,6 +552,7 @@ chatDirNtf :: User -> ChatInfo c -> CIDirection c d -> Bool -> Bool chatDirNtf user cInfo chatDir mention = case (cInfo, chatDir) of (DirectChat ct, CIDirectRcv) -> contactNtf user ct mention (GroupChat g _scopeInfo, CIGroupRcv m) -> groupNtf user g mention && not (memberBlocked m) + (GroupChat g _scopeInfo, CIChannelRcv) -> groupNtf user g mention _ -> True contactNtf :: User -> Contact -> Bool -> Bool @@ -673,16 +674,18 @@ viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {itemForwarded, forwa _ -> showSndItem to where to = ttyToGroup g scopeInfo - CIGroupRcv m -> case content of - CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from context mc - CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta - CIRcvGroupInvitation {} -> showRcvItemProhibited from - CIRcvModerated {} -> receivedWithTime_ ts tz (ttyFromGroup g scopeInfo m) context meta [plainContent content] False - CIRcvBlocked {} -> receivedWithTime_ ts tz (ttyFromGroup g scopeInfo m) context meta [plainContent content] False - _ -> showRcvItem from - where - from = ttyFromGroupAttention g scopeInfo m userMention + CIGroupRcv m -> rcvGroupItem (Just m) + CIChannelRcv -> rcvGroupItem Nothing where + rcvGroupItem m_ = case content of + CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from context mc + CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta + CIRcvGroupInvitation {} | isJust m_ -> showRcvItemProhibited from + CIRcvModerated {} -> receivedWithTime_ ts tz (ttyFromGroup g scopeInfo m_) context meta [plainContent content] False + CIRcvBlocked {} -> receivedWithTime_ ts tz (ttyFromGroup g scopeInfo m_) context meta [plainContent content] False + _ -> showRcvItem from + where + from = ttyFromGroupAttention g scopeInfo m_ userMention context = maybe (maybe [] forwardedFrom itemForwarded) @@ -813,19 +816,22 @@ viewItemUpdate chat ChatItem {chatDir, meta = meta@CIMeta {itemForwarded, itemEd (directQuote chatDir) quotedItem GroupChat g scopeInfo -> case chatDir of - CIGroupRcv m -> case content of - CIRcvMsgContent mc - | itemLive == Just True && not liveItems -> [] - | otherwise -> viewReceivedUpdatedMessage from context mc ts tz meta - _ -> [] - where - from = if itemEdited then ttyFromGroupEdited g scopeInfo m else ttyFromGroup g scopeInfo m + CIGroupRcv m -> updGroupItem (Just m) + CIChannelRcv -> updGroupItem Nothing CIGroupSnd -> case content of CISndMsgContent mc -> hideLive meta $ viewSentMessage to context mc ts tz meta _ -> [] where to = if itemEdited then ttyToGroupEdited g scopeInfo else ttyToGroup g scopeInfo where + updGroupItem :: Maybe GroupMember -> [StyledString] + updGroupItem m_ = case content of + CIRcvMsgContent mc + | itemLive == Just True && not liveItems -> [] + | otherwise -> viewReceivedUpdatedMessage from context mc ts tz meta + _ -> [] + where + from = if itemEdited then ttyFromGroupEdited g scopeInfo m_ else ttyFromGroup g scopeInfo m_ context = maybe (maybe [] forwardedFrom itemForwarded) @@ -881,7 +887,7 @@ viewItemDelete chat ci@ChatItem {chatDir, meta, content = deletedContent} toItem prohibited = [styled (colored Red) ("[unexpected message deletion, please report to developers]" :: String)] viewItemReaction :: forall c d. Bool -> ChatInfo c -> CIReaction c d -> Bool -> CurrentTime -> TimeZone -> [StyledString] -viewItemReaction showReactions chat CIReaction {chatDir, chatItem = CChatItem md ChatItem {chatDir = itemDir, content}, sentAt, reaction} added ts tz = +viewItemReaction showReactions chat CIReaction {chatDir, chatItem = CChatItem md ChatItem {chatDir = itemDir, content, meta = CIMeta {showGroupAsSender}}, sentAt, reaction} added ts tz = case (chat, chatDir) of (DirectChat c, CIDirectRcv) -> case ciMsgContent content of Just mc -> view from $ reactionMsg mc @@ -889,12 +895,8 @@ viewItemReaction showReactions chat CIReaction {chatDir, chatItem = CChatItem md where from = ttyFromContact c reactionMsg mc = quoteText mc $ if toMsgDirection md == MDSnd then ">>" else ">" - (GroupChat g scopeInfo, CIGroupRcv m) -> case ciMsgContent content of - Just mc -> view from $ reactionMsg mc - _ -> [] - where - from = ttyFromGroup g scopeInfo m - reactionMsg mc = quoteText mc . ttyQuotedMember . Just $ sentByMember' g itemDir + (GroupChat g scopeInfo, CIGroupRcv m) -> groupReaction g scopeInfo (Just m) (sentByMember' g itemDir) + (GroupChat g scopeInfo, CIChannelRcv) -> groupReaction g scopeInfo Nothing (sentByMember' g itemDir) (LocalChat _, CILocalRcv) -> case ciMsgContent content of Just mc -> view from $ reactionMsg mc _ -> [] @@ -906,6 +908,13 @@ viewItemReaction showReactions chat CIReaction {chatDir, chatItem = CChatItem md (_, CILocalSnd) -> [sentText] (CInfoInvalidJSON {}, _) -> [] where + groupReaction g scopeInfo m_ sentBy = case ciMsgContent content of + Just mc -> view from $ reactionMsg mc + _ -> [] + where + from = ttyFromGroup g scopeInfo m_ + reactionMsg mc = quoteText mc . ttyQuotedMember $ + if showGroupAsSender then Nothing else sentBy view from msg | showReactions = viewReceivedReaction from msg reactionText ts tz sentAt | otherwise = [] @@ -946,10 +955,11 @@ sentByMember GroupInfo {membership} = \case CIQGroupSnd -> Just membership CIQGroupRcv m -> m -sentByMember' :: GroupInfo -> CIDirection 'CTGroup d -> GroupMember +sentByMember' :: GroupInfo -> CIDirection 'CTGroup d -> Maybe GroupMember sentByMember' GroupInfo {membership} = \case - CIGroupSnd -> membership - CIGroupRcv m -> m + CIGroupSnd -> Just membership + CIGroupRcv m -> Just m + CIChannelRcv -> Nothing quoteText :: MsgContent -> StyledString -> [StyledString] quoteText qmc sentBy = prependFirst (sentBy <> " ") $ msgPreview qmc @@ -2270,6 +2280,7 @@ cryptoFileArgsStr testView cfArgs@(CFArgs key nonce) fileFrom :: ChatInfo c -> CIDirection c d -> StyledString fileFrom (DirectChat ct) CIDirectRcv = " from " <> ttyContact' ct fileFrom _ (CIGroupRcv m) = " from " <> ttyMember m +fileFrom (GroupChat g _) CIChannelRcv = " from " <> ttyGroup' g fileFrom _ _ = "" receivingFile_ :: StyledString -> RcvFileTransfer -> [StyledString] @@ -2698,7 +2709,7 @@ ttyQuotedContact Contact {localDisplayName = c} = ttyFrom $ viewName c <> ">" ttyQuotedMember :: Maybe GroupMember -> StyledString ttyQuotedMember (Just GroupMember {localDisplayName = c}) = "> " <> ttyFrom (viewName c) -ttyQuotedMember _ = "> " <> ttyFrom "?" +ttyQuotedMember Nothing = ">" ttyFromContact :: Contact -> StyledString ttyFromContact ct@Contact {localDisplayName = c} = ctIncognito ct <> ttyFrom (viewName c <> "> ") @@ -2734,26 +2745,29 @@ ttyFullGroup :: GroupInfo -> StyledString ttyFullGroup GroupInfo {localDisplayName = g, groupProfile = GroupProfile {fullName, shortDescr}} = ttyGroup g <> optFullName g fullName shortDescr -ttyFromGroup :: GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> StyledString -ttyFromGroup g scopeInfo m = ttyFromGroupAttention g scopeInfo m False +ttyFromGroup :: GroupInfo -> Maybe GroupChatScopeInfo -> Maybe GroupMember -> StyledString +ttyFromGroup g scopeInfo m_ = ttyFromGroupAttention g scopeInfo m_ False -ttyFromGroupAttention :: GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> Bool -> StyledString -ttyFromGroupAttention g scopeInfo m attention = membershipIncognito g <> ttyFrom (fromGroupAttention_ g scopeInfo m attention) +ttyFromGroupAttention :: GroupInfo -> Maybe GroupChatScopeInfo -> Maybe GroupMember -> Bool -> StyledString +ttyFromGroupAttention g scopeInfo m_ attention = membershipIncognito g <> ttyFrom (fromGroupAttention_ g scopeInfo m_ attention) -ttyFromGroupEdited :: GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> StyledString -ttyFromGroupEdited g scopeInfo m = membershipIncognito g <> ttyFrom (fromGroup_ g scopeInfo m <> "[edited] ") +ttyFromGroupEdited :: GroupInfo -> Maybe GroupChatScopeInfo -> Maybe GroupMember -> StyledString +ttyFromGroupEdited g scopeInfo m_ = membershipIncognito g <> ttyFrom (fromGroup_ g scopeInfo m_ <> "[edited] ") -ttyFromGroupDeleted :: GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> Maybe Text -> StyledString -ttyFromGroupDeleted g scopeInfo m deletedText_ = - membershipIncognito g <> ttyFrom (fromGroup_ g scopeInfo m <> maybe "" (\t -> "[" <> t <> "] ") deletedText_) +ttyFromGroupDeleted :: GroupInfo -> Maybe GroupChatScopeInfo -> Maybe GroupMember -> Maybe Text -> StyledString +ttyFromGroupDeleted g scopeInfo m_ deletedText_ = + membershipIncognito g <> ttyFrom (fromGroup_ g scopeInfo m_ <> maybe "" (\t -> "[" <> t <> "] ") deletedText_) -fromGroup_ :: GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> Text -fromGroup_ g scopeInfo m = fromGroupAttention_ g scopeInfo m False +fromGroup_ :: GroupInfo -> Maybe GroupChatScopeInfo -> Maybe GroupMember -> Text +fromGroup_ g scopeInfo m_ = fromGroupAttention_ g scopeInfo m_ False -fromGroupAttention_ :: GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> Bool -> Text -fromGroupAttention_ g scopeInfo m attention = +fromGroupAttention_ :: GroupInfo -> Maybe GroupChatScopeInfo -> Maybe GroupMember -> Bool -> Text +fromGroupAttention_ g scopeInfo m_ attention = let attn = if attention then "!" else "" - in "#" <> viewGroupName g <> " " <> groupScopeInfoStr scopeInfo <> viewMemberName m <> attn <> "> " + in "#" <> viewGroupName g + <> maybe "" (" " <>) (groupScopeInfoStr scopeInfo) + <> maybe "" ((" " <>) . viewMemberName) m_ + <> attn <> "> " ttyFrom :: Text -> StyledString ttyFrom = styled $ colored Yellow @@ -2762,17 +2776,17 @@ ttyTo :: Text -> StyledString ttyTo = styled $ colored Cyan ttyToGroup :: GroupInfo -> Maybe GroupChatScopeInfo -> StyledString -ttyToGroup g scopeInfo = membershipIncognito g <> ttyTo ("#" <> viewGroupName g <> " " <> groupScopeInfoStr scopeInfo) +ttyToGroup g scopeInfo = membershipIncognito g <> ttyTo ("#" <> viewGroupName g <> maybe "" (" " <>) (groupScopeInfoStr scopeInfo) <> " ") ttyToGroupEdited :: GroupInfo -> Maybe GroupChatScopeInfo -> StyledString -ttyToGroupEdited g scopeInfo = membershipIncognito g <> ttyTo ("#" <> viewGroupName g <> groupScopeInfoStr scopeInfo <> " [edited] ") +ttyToGroupEdited g scopeInfo = membershipIncognito g <> ttyTo ("#" <> viewGroupName g <> maybe "" (" " <>) (groupScopeInfoStr scopeInfo) <> " [edited] ") -groupScopeInfoStr :: Maybe GroupChatScopeInfo -> Text +groupScopeInfoStr :: Maybe GroupChatScopeInfo -> Maybe Text groupScopeInfoStr = \case - Nothing -> "" - Just (GCSIMemberSupport {groupMember_}) -> case groupMember_ of - Nothing -> "(support) " - Just m -> "(support: " <> viewMemberName m <> ") " + Nothing -> Nothing + Just (GCSIMemberSupport {groupMember_}) -> Just $ case groupMember_ of + Nothing -> "(support)" + Just m -> "(support: " <> viewMemberName m <> ")" ttyFilePath :: FilePath -> StyledString ttyFilePath = plain diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index ad0d0651b1..da6eee9ec7 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -230,7 +230,7 @@ chatGroupTests = do it "should remove support chat with member when member is removed" testScopedSupportMemberRemoved it "should remove support chat with member when user removes member" testScopedSupportUserRemovesMember it "should remove support chat with member when member leaves" testScopedSupportMemberLeaves - -- TODO [channels fwd] add tests for channels + -- TODO [relays] add tests for channels -- TODO - tests with delivery loop over members restored after restart -- TODO - delivery in support scopes inside channels -- TODO - connect plans for relay groups @@ -249,6 +249,24 @@ chatGroupTests = do describe "multiple relays" $ do it "2 relays: should deliver messages to members" testChannels2RelaysDeliver it "should share same incognito profile with all relays" testChannels2RelaysIncognito + describe "channel message operations" $ do + it "should update channel message" testChannelMessageUpdate + it "should delete channel message" testChannelMessageDelete + it "should send and receive channel message file" testChannelMessageFile + it "should cancel channel message file" testChannelMessageFileCancel + it "should quote channel message" testChannelMessageQuote + it "should not leak owner identity in channel reaction" testChannelOwnerReaction + it "should not leak owner identity in channel quote" testChannelOwnerQuote + it "should update channel message sent as member" testChannelOwnerUpdateAsMember + it "should delete channel message sent as member" testChannelOwnerDeleteAsMember + it "should send and receive file sent as member" testChannelOwnerFileTransferAsMember + it "should cancel file sent as member" testChannelOwnerFileCancelAsMember + it "should attribute reactions to member" testChannelReactionAttribution + it "should recreate deleted item with correct sendAsGroup from update" testChannelUpdateFallbackSendAsGroup + it "should respect sendAsGroup parameter in forward API" testForwardAPIUsesParameter + it "should compute sendAsGroup in CLI forward" testForwardCLISendAsGroup + it "should update member message in channel" testChannelMemberMessageUpdate + it "should delete member message in channel" testChannelMemberMessageDelete testGroupCheckMessages :: HasCallStack => TestParams -> IO () testGroupCheckMessages = @@ -8374,21 +8392,21 @@ testChannels1RelayDeliver ps = createChannel1Relay "team" alice bob cath dan eve alice #> "#team hi" - bob <# "#team alice> hi" - [cath, dan, eve] *<# "#team alice> hi [>>]" + bob <# "#team> hi" + [cath, dan, eve] *<# "#team> hi [>>]" cath ##> "+1 #team hi" cath <## "added 👍" - bob <# "#team cath> > alice hi" + bob <# "#team cath> > hi" bob <## " + 👍" alice <## "#team: bob forwarded a message from an unknown member, creating unknown member record cath" - alice <# "#team cath> > alice hi" + alice <# "#team cath> > hi" alice <## " + 👍" dan <## "#team: bob forwarded a message from an unknown member, creating unknown member record cath" - dan <# "#team cath> > alice hi" + dan <# "#team cath> > hi" dan <## " + 👍" eve <## "#team: bob forwarded a message from an unknown member, creating unknown member record cath" - eve <# "#team cath> > alice hi" + eve <# "#team cath> > hi" eve <## " + 👍" createChannel1Relay :: String -> TestCC -> TestCC -> TestCC -> TestCC -> TestCC -> IO () @@ -8539,21 +8557,21 @@ testChannels1RelayDeliverLoop deliveryBucketSize ps = createChannel1Relay "team" alice bob cath dan eve alice #> "#team hi" - bob <# "#team alice> hi" - [cath, dan, eve] *<# "#team alice> hi [>>]" + bob <# "#team> hi" + [cath, dan, eve] *<# "#team> hi [>>]" cath ##> "+1 #team hi" cath <## "added 👍" - bob <# "#team cath> > alice hi" + bob <# "#team cath> > hi" bob <## " + 👍" alice <## "#team: bob forwarded a message from an unknown member, creating unknown member record cath" - alice <# "#team cath> > alice hi" + alice <# "#team cath> > hi" alice <## " + 👍" dan <## "#team: bob forwarded a message from an unknown member, creating unknown member record cath" - dan <# "#team cath> > alice hi" + dan <# "#team cath> > hi" dan <## " + 👍" eve <## "#team: bob forwarded a message from an unknown member, creating unknown member record cath" - eve <# "#team cath> > alice hi" + eve <# "#team cath> > hi" eve <## " + 👍" where cfg = testCfg {deliveryBucketSize} @@ -8578,9 +8596,9 @@ testChannelsSenderDeduplicateOwn ps = do withTestChatCfgOpts ps cfg relayTestOpts "bob" $ \bob -> do bob <## "subscribed 6 connections on server localhost" bob - <### [ WithTime "#team alice> 1", - WithTime "#team alice> 2", - WithTime "#team alice> 3", + <### [ WithTime "#team> 1", + WithTime "#team> 2", + WithTime "#team> 3", WithTime "#team cath> 4", WithTime "#team cath> 5", WithTime "#team dan> 6" @@ -8594,25 +8612,25 @@ testChannelsSenderDeduplicateOwn ps = do ] cath <### [ "#team: bob forwarded a message from an unknown member, creating unknown member record dan", - WithTime "#team alice> 1 [>>]", - WithTime "#team alice> 2 [>>]", - WithTime "#team alice> 3 [>>]", + WithTime "#team> 1 [>>]", + WithTime "#team> 2 [>>]", + WithTime "#team> 3 [>>]", WithTime "#team dan> 6 [>>]" ] dan <### [ "#team: bob forwarded a message from an unknown member, creating unknown member record cath", - WithTime "#team alice> 1 [>>]", - WithTime "#team alice> 2 [>>]", - WithTime "#team alice> 3 [>>]", + WithTime "#team> 1 [>>]", + WithTime "#team> 2 [>>]", + WithTime "#team> 3 [>>]", WithTime "#team cath> 4 [>>]", WithTime "#team cath> 5 [>>]" ] eve <### [ "#team: bob forwarded a message from an unknown member, creating unknown member record cath", "#team: bob forwarded a message from an unknown member, creating unknown member record dan", - WithTime "#team alice> 1 [>>]", - WithTime "#team alice> 2 [>>]", - WithTime "#team alice> 3 [>>]", + WithTime "#team> 1 [>>]", + WithTime "#team> 2 [>>]", + WithTime "#team> 3 [>>]", WithTime "#team cath> 4 [>>]", WithTime "#team cath> 5 [>>]", WithTime "#team dan> 6 [>>]" @@ -8631,23 +8649,23 @@ testChannels2RelaysDeliver ps = createChannel2Relays "team" alice bob cath dan eve frank alice #> "#team hi" - [bob, cath] *<# "#team alice> hi" - [dan, eve, frank] *<# "#team alice> hi [>>]" + [bob, cath] *<# "#team> hi" + [dan, eve, frank] *<# "#team> hi [>>]" dan ##> "+1 #team hi" dan <## "added 👍" - bob <# "#team dan> > alice hi" + bob <# "#team dan> > hi" bob <## " + 👍" - cath <# "#team dan> > alice hi" + cath <# "#team dan> > hi" cath <## " + 👍" alice .<## " forwarded a message from an unknown member, creating unknown member record dan" - alice <# "#team dan> > alice hi" + alice <# "#team dan> > hi" alice <## " + 👍" eve .<## " forwarded a message from an unknown member, creating unknown member record dan" - eve <# "#team dan> > alice hi" + eve <# "#team dan> > hi" eve <## " + 👍" frank .<## " forwarded a message from an unknown member, creating unknown member record dan" - frank <# "#team dan> > alice hi" + frank <# "#team dan> > hi" frank <## " + 👍" -- remove below if default role is changed to observer @@ -8669,24 +8687,24 @@ testChannels2RelaysIncognito ps = memberJoinChannel "team" [bob, cath] shortLink fullLink member alice #> "#team hi" - [bob, cath] *<# "#team alice> hi" - dan ?<# "#team alice> hi [>>]" - [eve, frank] *<# "#team alice> hi [>>]" + [bob, cath] *<# "#team> hi" + dan ?<# "#team> hi [>>]" + [eve, frank] *<# "#team> hi [>>]" dan ##> "+1 #team hi" dan <## "added 👍" - bob <# ("#team " <> danIncognito <> "> > alice hi") + bob <# ("#team " <> danIncognito <> "> > hi") bob <## " + 👍" - cath <# ("#team " <> danIncognito <> "> > alice hi") + cath <# ("#team " <> danIncognito <> "> > hi") cath <## " + 👍" alice .<## (" forwarded a message from an unknown member, creating unknown member record " <> danIncognito) - alice <# ("#team " <> danIncognito <> "> > alice hi") + alice <# ("#team " <> danIncognito <> "> > hi") alice <## " + 👍" eve .<## (" forwarded a message from an unknown member, creating unknown member record " <> danIncognito) - eve <# ("#team " <> danIncognito <> "> > alice hi") + eve <# ("#team " <> danIncognito <> "> > hi") eve <## " + 👍" frank .<## (" forwarded a message from an unknown member, creating unknown member record " <> danIncognito) - frank <# ("#team " <> danIncognito <> "> > alice hi") + frank <# ("#team " <> danIncognito <> "> > hi") frank <## " + 👍" -- remove below if default role is changed to observer @@ -8694,6 +8712,565 @@ testChannels2RelaysIncognito ps = [bob, cath] *<# ("#team " <> danIncognito <> "> hey") [alice, eve, frank] *<# ("#team " <> danIncognito <> "> hey [>>]") +testChannelMessageUpdate :: HasCallStack => TestParams -> IO () +testChannelMessageUpdate ps = + withNewTestChat ps "alice" aliceProfile $ \alice -> + withNewTestChatOpts ps relayTestOpts "bob" bobProfile $ \bob -> + withNewTestChat ps "cath" cathProfile $ \cath -> + withNewTestChat ps "dan" danProfile $ \dan -> + withNewTestChat ps "eve" eveProfile $ \eve -> do + createChannel1Relay "team" alice bob cath dan eve + + -- owner sends channel message + alice #> "#team hello" + bob <# "#team> hello" + [cath, dan, eve] *<# "#team> hello [>>]" + + -- owner updates channel message + msgId <- lastItemId alice + alice ##> ("/_update item #1 " <> msgId <> " text hello updated") + alice <# "#team [edited] hello updated" + bob <# "#team> [edited] hello updated" + [cath, dan, eve] *<# "#team> [edited] hello updated" -- TODO show as forwarded + +testChannelMessageDelete :: HasCallStack => TestParams -> IO () +testChannelMessageDelete ps = + withNewTestChat ps "alice" aliceProfile $ \alice -> + withNewTestChatOpts ps relayTestOpts "bob" bobProfile $ \bob -> + withNewTestChat ps "cath" cathProfile $ \cath -> + withNewTestChat ps "dan" danProfile $ \dan -> + withNewTestChat ps "eve" eveProfile $ \eve -> do + createChannel1Relay "team" alice bob cath dan eve + + -- owner sends channel message + alice #> "#team hello" + bob <# "#team> hello" + [cath, dan, eve] *<# "#team> hello [>>]" + + -- owner deletes channel message (broadcast) + msgId <- lastItemId alice + alice #$> ("/_delete item #1 " <> msgId <> " broadcast", id, "message marked deleted") + bob <# "#team> [marked deleted] hello" + [cath, dan, eve] *<# "#team> [marked deleted] hello" -- TODO show as forwarded + +testChannelMessageFile :: HasCallStack => TestParams -> IO () +testChannelMessageFile ps = + withNewTestChat ps "alice" aliceProfile $ \alice -> + withNewTestChatOpts ps relayTestOpts "bob" bobProfile $ \bob -> + withNewTestChat ps "cath" cathProfile $ \cath -> + withNewTestChat ps "dan" danProfile $ \dan -> + withNewTestChat ps "eve" eveProfile $ \eve -> withXFTPServer $ do + createChannel1Relay "team" alice bob cath dan eve + + -- owner sends file as channel message + alice #> "/f #team ./tests/fixtures/test.jpg" + alice <## "use /fc 1 to cancel sending" + alice <## "completed uploading file 1 (test.jpg) for #team" + bob <# "#team> sends file test.jpg (136.5 KiB / 139737 bytes)" + bob <## "use /fr 1 [/ | ] to receive it" + concurrentlyN_ + [ do + cath <# "#team> sends file test.jpg (136.5 KiB / 139737 bytes) [>>]" + cath <## "use /fr 1 [/ | ] to receive it [>>]", + do + dan <# "#team> sends file test.jpg (136.5 KiB / 139737 bytes) [>>]" + dan <## "use /fr 1 [/ | ] to receive it [>>]", + do + eve <# "#team> sends file test.jpg (136.5 KiB / 139737 bytes) [>>]" + eve <## "use /fr 1 [/ | ] to receive it [>>]" + ] + + -- all members receive the file concurrently + src <- B.readFile "./tests/fixtures/test.jpg" + concurrentlyN_ + [ receiveFile bob "bob" src, + receiveFile cath "cath" src, + receiveFile dan "dan" src, + receiveFile eve "eve" src + ] + where + receiveFile cc name src = do + let path = "./tests/tmp/test_" <> name <> ".jpg" + cc ##> ("/fr 1 " <> path) + cc + <### [ ConsoleString ("saving file 1 from #team to " <> path), + "started receiving file 1 (test.jpg) from #team" + ] + cc <## "completed receiving file 1 (test.jpg) from #team" + B.readFile path >>= (`shouldBe` src) + +testChannelMessageFileCancel :: HasCallStack => TestParams -> IO () +testChannelMessageFileCancel ps = + withNewTestChat ps "alice" aliceProfile $ \alice -> + withNewTestChatOpts ps relayTestOpts "bob" bobProfile $ \bob -> + withNewTestChat ps "cath" cathProfile $ \cath -> + withNewTestChat ps "dan" danProfile $ \dan -> + withNewTestChat ps "eve" eveProfile $ \eve -> withXFTPServer $ do + createChannel1Relay "team" alice bob cath dan eve + + -- owner sends file as channel message + alice #> "/f #team ./tests/fixtures/test.jpg" + alice <## "use /fc 1 to cancel sending" + alice <## "completed uploading file 1 (test.jpg) for #team" + bob <# "#team> sends file test.jpg (136.5 KiB / 139737 bytes)" + bob <## "use /fr 1 [/ | ] to receive it" + concurrentlyN_ + [ do + cath <# "#team> sends file test.jpg (136.5 KiB / 139737 bytes) [>>]" + cath <## "use /fr 1 [/ | ] to receive it [>>]", + do + dan <# "#team> sends file test.jpg (136.5 KiB / 139737 bytes) [>>]" + dan <## "use /fr 1 [/ | ] to receive it [>>]", + do + eve <# "#team> sends file test.jpg (136.5 KiB / 139737 bytes) [>>]" + eve <## "use /fr 1 [/ | ] to receive it [>>]" + ] + + -- owner cancels file + alice ##> "/fc 1" + alice <## "cancelled sending file 1 (test.jpg) to bob" + bob <## "team cancelled sending file 1 (test.jpg)" + concurrentlyN_ + [ cath <## "team cancelled sending file 1 (test.jpg)", + dan <## "team cancelled sending file 1 (test.jpg)", + eve <## "team cancelled sending file 1 (test.jpg)" + ] + +testChannelMessageQuote :: HasCallStack => TestParams -> IO () +testChannelMessageQuote ps = + withNewTestChat ps "alice" aliceProfile $ \alice -> + withNewTestChatOpts ps relayTestOpts "bob" bobProfile $ \bob -> + withNewTestChat ps "cath" cathProfile $ \cath -> + withNewTestChat ps "dan" danProfile $ \dan -> + withNewTestChat ps "eve" eveProfile $ \eve -> do + createChannel1Relay "team" alice bob cath dan eve + + -- owner sends channel message + alice #> "#team hello from channel" + bob <# "#team> hello from channel" + [cath, dan, eve] *<# "#team> hello from channel [>>]" + + -- member quotes channel message + cath `send` "> #team (hello from) replying to channel" + cath <# "#team > hello from channel" + cath <## " replying to channel" + bob <# "#team cath> > hello from channel" + bob <## " replying to channel" + concurrentlyN_ + [ do + alice <## "#team: bob forwarded a message from an unknown member, creating unknown member record cath" + alice <# "#team cath> > hello from channel [>>]" + alice <## " replying to channel [>>]", + do + dan <## "#team: bob forwarded a message from an unknown member, creating unknown member record cath" + dan <# "#team cath> > hello from channel [>>]" + dan <## " replying to channel [>>]", + do + eve <## "#team: bob forwarded a message from an unknown member, creating unknown member record cath" + eve <# "#team cath> > hello from channel [>>]" + eve <## " replying to channel [>>]" + ] + +testChannelOwnerReaction :: HasCallStack => TestParams -> IO () +testChannelOwnerReaction ps = + withNewTestChat ps "alice" aliceProfile $ \alice -> + withNewTestChatOpts ps relayTestOpts "bob" bobProfile $ \bob -> + withNewTestChat ps "cath" cathProfile $ \cath -> + withNewTestChat ps "dan" danProfile $ \dan -> + withNewTestChat ps "eve" eveProfile $ \eve -> do + createChannel1Relay "team" alice bob cath dan eve + + -- owner sends channel message + alice #> "#team hello" + bob <# "#team> hello" + [cath, dan, eve] *<# "#team> hello [>>]" + + -- owner reacts to own channel message - reaction is forwarded as member + alice ##> "+1 #team hello" + alice <## "added 👍" + bob <# "#team alice> > hello" + bob <## " + 👍" + concurrentlyN_ + [ do cath <# "#team alice> > hello" + cath <## " + 👍", + do dan <# "#team alice> > hello" + dan <## " + 👍", + do eve <# "#team alice> > hello" + eve <## " + 👍" + ] + +testChannelOwnerQuote :: HasCallStack => TestParams -> IO () +testChannelOwnerQuote ps = + withNewTestChat ps "alice" aliceProfile $ \alice -> + withNewTestChatOpts ps relayTestOpts "bob" bobProfile $ \bob -> + withNewTestChat ps "cath" cathProfile $ \cath -> + withNewTestChat ps "dan" danProfile $ \dan -> + withNewTestChat ps "eve" eveProfile $ \eve -> do + createChannel1Relay "team" alice bob cath dan eve + + -- owner sends channel message + alice #> "#team hello from channel" + bob <# "#team> hello from channel" + [cath, dan, eve] *<# "#team> hello from channel [>>]" + + -- owner quotes own channel message (sender sees own name locally, not a protocol leak) + alice `send` "> #team (hello from) my reply" + alice <# "#team > alice hello from channel" + alice <## " my reply" + bob <# "#team> > hello from channel" + bob <## " my reply" + concurrentlyN_ + [ do cath <# "#team> > hello from channel [>>]" + cath <## " my reply [>>]", + do dan <# "#team> > hello from channel [>>]" + dan <## " my reply [>>]", + do eve <# "#team> > hello from channel [>>]" + eve <## " my reply [>>]" + ] + +testChannelOwnerUpdateAsMember :: HasCallStack => TestParams -> IO () +testChannelOwnerUpdateAsMember ps = + withNewTestChat ps "alice" aliceProfile $ \alice -> + withNewTestChatOpts ps relayTestOpts "bob" bobProfile $ \bob -> + withNewTestChat ps "cath" cathProfile $ \cath -> + withNewTestChat ps "dan" danProfile $ \dan -> + withNewTestChat ps "eve" eveProfile $ \eve -> do + createChannel1Relay "team" alice bob cath dan eve + + -- owner sends message as member (not as channel) + alice ##> "/_send #1(as_group=off) text hello" + alice <# "#team hello" + bob <# "#team alice> hello" + [cath, dan, eve] *<# "#team alice> hello [>>]" + + -- owner updates message + msgId <- lastItemId alice + alice ##> ("/_update item #1 " <> msgId <> " text hello updated") + alice <# "#team [edited] hello updated" + bob <# "#team alice> [edited] hello updated" + [cath, dan, eve] *<# "#team alice> [edited] hello updated" + +testChannelOwnerDeleteAsMember :: HasCallStack => TestParams -> IO () +testChannelOwnerDeleteAsMember ps = + withNewTestChat ps "alice" aliceProfile $ \alice -> + withNewTestChatOpts ps relayTestOpts "bob" bobProfile $ \bob -> + withNewTestChat ps "cath" cathProfile $ \cath -> + withNewTestChat ps "dan" danProfile $ \dan -> + withNewTestChat ps "eve" eveProfile $ \eve -> do + createChannel1Relay "team" alice bob cath dan eve + + -- owner sends message as member (not as channel) + alice ##> "/_send #1(as_group=off) text hello" + alice <# "#team hello" + bob <# "#team alice> hello" + [cath, dan, eve] *<# "#team alice> hello [>>]" + + -- owner deletes message (broadcast) + msgId <- lastItemId alice + alice #$> ("/_delete item #1 " <> msgId <> " broadcast", id, "message marked deleted") + bob <# "#team alice> [marked deleted] hello" + [cath, dan, eve] *<# "#team alice> [marked deleted] hello" + +testChannelOwnerFileTransferAsMember :: HasCallStack => TestParams -> IO () +testChannelOwnerFileTransferAsMember ps = + withNewTestChat ps "alice" aliceProfile $ \alice -> + withNewTestChatOpts ps relayTestOpts "bob" bobProfile $ \bob -> + withNewTestChat ps "cath" cathProfile $ \cath -> + withNewTestChat ps "dan" danProfile $ \dan -> + withNewTestChat ps "eve" eveProfile $ \eve -> withXFTPServer $ do + createChannel1Relay "team" alice bob cath dan eve + + -- owner sends file as member (not as channel) + alice ##> "/_send #1(as_group=off) json [{\"filePath\": \"./tests/fixtures/test.jpg\", \"msgContent\": {\"type\": \"file\", \"text\": \"\"}}]" + alice <# "/f #team ./tests/fixtures/test.jpg" + alice <## "use /fc 1 to cancel sending" + alice <## "completed uploading file 1 (test.jpg) for #team" + bob <# "#team alice> sends file test.jpg (136.5 KiB / 139737 bytes)" + bob <## "use /fr 1 [/ | ] to receive it" + concurrentlyN_ + [ do + cath <# "#team alice> sends file test.jpg (136.5 KiB / 139737 bytes) [>>]" + cath <## "use /fr 1 [/ | ] to receive it [>>]", + do + dan <# "#team alice> sends file test.jpg (136.5 KiB / 139737 bytes) [>>]" + dan <## "use /fr 1 [/ | ] to receive it [>>]", + do + eve <# "#team alice> sends file test.jpg (136.5 KiB / 139737 bytes) [>>]" + eve <## "use /fr 1 [/ | ] to receive it [>>]" + ] + + -- all members receive the file + src <- B.readFile "./tests/fixtures/test.jpg" + concurrentlyN_ + [ receiveFile bob "bob" src, + receiveFile cath "cath" src, + receiveFile dan "dan" src, + receiveFile eve "eve" src + ] + where + receiveFile cc name src = do + let path = "./tests/tmp/test_" <> name <> ".jpg" + cc ##> ("/fr 1 " <> path) + cc + <### [ ConsoleString ("saving file 1 from alice to " <> path), + "started receiving file 1 (test.jpg) from alice" + ] + cc <## "completed receiving file 1 (test.jpg) from alice" + B.readFile path >>= (`shouldBe` src) + +testChannelOwnerFileCancelAsMember :: HasCallStack => TestParams -> IO () +testChannelOwnerFileCancelAsMember ps = + withNewTestChat ps "alice" aliceProfile $ \alice -> + withNewTestChatOpts ps relayTestOpts "bob" bobProfile $ \bob -> + withNewTestChat ps "cath" cathProfile $ \cath -> + withNewTestChat ps "dan" danProfile $ \dan -> + withNewTestChat ps "eve" eveProfile $ \eve -> withXFTPServer $ do + createChannel1Relay "team" alice bob cath dan eve + + -- owner sends file as member (not as channel) + alice ##> "/_send #1(as_group=off) json [{\"filePath\": \"./tests/fixtures/test.jpg\", \"msgContent\": {\"type\": \"file\", \"text\": \"\"}}]" + alice <# "/f #team ./tests/fixtures/test.jpg" + alice <## "use /fc 1 to cancel sending" + alice <## "completed uploading file 1 (test.jpg) for #team" + bob <# "#team alice> sends file test.jpg (136.5 KiB / 139737 bytes)" + bob <## "use /fr 1 [/ | ] to receive it" + concurrentlyN_ + [ do + cath <# "#team alice> sends file test.jpg (136.5 KiB / 139737 bytes) [>>]" + cath <## "use /fr 1 [/ | ] to receive it [>>]", + do + dan <# "#team alice> sends file test.jpg (136.5 KiB / 139737 bytes) [>>]" + dan <## "use /fr 1 [/ | ] to receive it [>>]", + do + eve <# "#team alice> sends file test.jpg (136.5 KiB / 139737 bytes) [>>]" + eve <## "use /fr 1 [/ | ] to receive it [>>]" + ] + + -- owner cancels file + alice ##> "/fc 1" + alice <## "cancelled sending file 1 (test.jpg) to bob" + bob <## "alice cancelled sending file 1 (test.jpg)" + concurrentlyN_ + [ cath <## "alice cancelled sending file 1 (test.jpg)", + dan <## "alice cancelled sending file 1 (test.jpg)", + eve <## "alice cancelled sending file 1 (test.jpg)" + ] + +testChannelReactionAttribution :: HasCallStack => TestParams -> IO () +testChannelReactionAttribution ps = + withNewTestChat ps "alice" aliceProfile $ \alice -> + withNewTestChatOpts ps relayTestOpts "bob" bobProfile $ \bob -> + withNewTestChat ps "cath" cathProfile $ \cath -> + withNewTestChat ps "dan" danProfile $ \dan -> + withNewTestChat ps "eve" eveProfile $ \eve -> do + createChannel1Relay "team" alice bob cath dan eve + + -- owner sends message as member + alice ##> "/_send #1(as_group=off) text hello" + alice <# "#team hello" + bob <# "#team alice> hello" + [cath, dan, eve] *<# "#team alice> hello [>>]" + + -- owner reacts to own member message - reaction is forwarded as member + alice ##> "+1 #team hello" + alice <## "added 👍" + bob <# "#team alice> > alice hello" + bob <## " + 👍" + concurrentlyN_ + [ do cath <# "#team alice> > alice hello" + cath <## " + 👍", + do dan <# "#team alice> > alice hello" + dan <## " + 👍", + do eve <# "#team alice> > alice hello" + eve <## " + 👍" + ] + +testChannelUpdateFallbackSendAsGroup :: HasCallStack => TestParams -> IO () +testChannelUpdateFallbackSendAsGroup ps = + withNewTestChat ps "alice" aliceProfile $ \alice -> + withNewTestChatOpts ps relayTestOpts "bob" bobProfile $ \bob -> + withNewTestChat ps "cath" cathProfile $ \cath -> + withNewTestChat ps "dan" danProfile $ \dan -> + withNewTestChat ps "eve" eveProfile $ \eve -> do + createChannel1Relay "team" alice bob cath dan eve + + -- owner sends channel message (sendAsGroup=True) + alice #> "#team channel msg" + bob <# "#team> channel msg" + [cath, dan, eve] *<# "#team> channel msg [>>]" + + -- bob locally deletes the item + bobMsgId <- lastItemId bob + bob #$> ("/_delete item #1 " <> bobMsgId <> " internal", id, "message deleted") + + -- owner updates message (XMsgUpdate includes asGroup=True) + aliceMsgId <- lastItemId alice + alice ##> ("/_update item #1 " <> aliceMsgId <> " text channel msg updated") + alice <# "#team [edited] channel msg updated" + -- bob's item was locally deleted, fallback recreates it with [edited] marker + bob <# "#team> [edited] channel msg updated" + [cath, dan, eve] *<# "#team> [edited] channel msg updated" + + -- now test sendAsGroup=False case + -- owner sends message as member + alice ##> "/_send #1(as_group=off) text member msg" + alice <# "#team member msg" + bob <# "#team alice> member msg" + [cath, dan, eve] *<# "#team alice> member msg [>>]" + + -- bob locally deletes the item + bobMsgId2 <- lastItemId bob + bob #$> ("/_delete item #1 " <> bobMsgId2 <> " internal", id, "message deleted") + + -- owner updates message (XMsgUpdate includes asGroup=False) + aliceMsgId2 <- lastItemId alice + alice ##> ("/_update item #1 " <> aliceMsgId2 <> " text member msg updated") + alice <# "#team [edited] member msg updated" + -- bob's internally deleted item is re-created as from member (sendAsGroup=False) + bob <# "#team alice> [edited] member msg updated" + -- forwarded members see correct member attribution + [cath, dan, eve] *<# "#team alice> [edited] member msg updated" + +testForwardAPIUsesParameter :: HasCallStack => TestParams -> IO () +testForwardAPIUsesParameter ps = + withNewTestChat ps "alice" aliceProfile $ \alice -> + withNewTestChatOpts ps relayTestOpts "bob" bobProfile $ \bob -> + withNewTestChat ps "cath" cathProfile $ \cath -> + withNewTestChat ps "dan" danProfile $ \dan -> + withNewTestChat ps "eve" eveProfile $ \eve -> + withNewTestChat ps "frank" frankProfile $ \frank -> do + createChannel1Relay "team" alice bob cath dan eve + connectUsers alice frank + + -- frank sends alice a message + frank #> "@alice hi there" + alice <# "frank> hi there" + + -- forward to channel with sendAsGroup=True (as channel) + alice ##> "/last_item_id @frank" + msgId <- getTermLine alice + alice ##> ("/_forward #1 as_group=on @2 " <> msgId) + alice <# "#team <- @frank" + alice <## " hi there" + bob <# "#team> -> forwarded" + bob <## " hi there" + concurrentlyN_ + [ do cath <# "#team> -> forwarded [>>]" + cath <## " hi there [>>]", + do dan <# "#team> -> forwarded [>>]" + dan <## " hi there [>>]", + do eve <# "#team> -> forwarded [>>]" + eve <## " hi there [>>]" + ] + + -- forward to channel with sendAsGroup=False (as member) + alice ##> ("/_forward #1 as_group=off @2 " <> msgId) + alice <# "#team <- @frank" + alice <## " hi there" + bob <# "#team alice> -> forwarded" + bob <## " hi there" + concurrentlyN_ + [ do cath <# "#team alice> -> forwarded [>>]" + cath <## " hi there [>>]", + do dan <# "#team alice> -> forwarded [>>]" + dan <## " hi there [>>]", + do eve <# "#team alice> -> forwarded [>>]" + eve <## " hi there [>>]" + ] + +testForwardCLISendAsGroup :: HasCallStack => TestParams -> IO () +testForwardCLISendAsGroup ps = + withNewTestChat ps "alice" aliceProfile $ \alice -> + withNewTestChatOpts ps relayTestOpts "bob" bobProfile $ \bob -> + withNewTestChat ps "cath" cathProfile $ \cath -> + withNewTestChat ps "dan" danProfile $ \dan -> + withNewTestChat ps "eve" eveProfile $ \eve -> + withNewTestChat ps "frank" frankProfile $ \frank -> do + createChannel1Relay "team" alice bob cath dan eve + connectUsers alice frank + + -- frank sends alice a message + frank #> "@alice hi" + alice <# "frank> hi" + + -- CLI forward to channel computes sendAsGroup=True (owner in channel) + alice `send` "#team <- @frank hi" + alice <# "#team <- @frank" + alice <## " hi" + bob <# "#team> -> forwarded" + bob <## " hi" + concurrentlyN_ + [ do cath <# "#team> -> forwarded [>>]" + cath <## " hi [>>]", + do dan <# "#team> -> forwarded [>>]" + dan <## " hi [>>]", + do eve <# "#team> -> forwarded [>>]" + eve <## " hi [>>]" + ] + +testChannelMemberMessageUpdate :: HasCallStack => TestParams -> IO () +testChannelMemberMessageUpdate ps = + withNewTestChat ps "alice" aliceProfile $ \alice -> + withNewTestChatOpts ps relayTestOpts "bob" bobProfile $ \bob -> + withNewTestChat ps "cath" cathProfile $ \cath -> + withNewTestChat ps "dan" danProfile $ \dan -> + withNewTestChat ps "eve" eveProfile $ \eve -> do + createChannel1Relay "team" alice bob cath dan eve + + -- member sends a message + cath #> "#team hello" + bob <# "#team cath> hello" + concurrentlyN_ + [ do alice <## "#team: bob forwarded a message from an unknown member, creating unknown member record cath" + alice <# "#team cath> hello [>>]", + do dan <## "#team: bob forwarded a message from an unknown member, creating unknown member record cath" + dan <# "#team cath> hello [>>]", + do eve <## "#team: bob forwarded a message from an unknown member, creating unknown member record cath" + eve <# "#team cath> hello [>>]" + ] + + -- member updates their message + cathMsgId <- lastItemId cath + cath ##> ("/_update item #1 " <> cathMsgId <> " text hello updated") + cath <# "#team [edited] hello updated" + bob <# "#team cath> [edited] hello updated" + concurrentlyN_ + [ alice <# "#team cath> [edited] hello updated", + dan <# "#team cath> [edited] hello updated", + eve <# "#team cath> [edited] hello updated" + ] + +testChannelMemberMessageDelete :: HasCallStack => TestParams -> IO () +testChannelMemberMessageDelete ps = + withNewTestChat ps "alice" aliceProfile $ \alice -> + withNewTestChatOpts ps relayTestOpts "bob" bobProfile $ \bob -> + withNewTestChat ps "cath" cathProfile $ \cath -> + withNewTestChat ps "dan" danProfile $ \dan -> + withNewTestChat ps "eve" eveProfile $ \eve -> do + createChannel1Relay "team" alice bob cath dan eve + + -- member sends a message + cath #> "#team hello" + bob <# "#team cath> hello" + concurrentlyN_ + [ do alice <## "#team: bob forwarded a message from an unknown member, creating unknown member record cath" + alice <# "#team cath> hello [>>]", + do dan <## "#team: bob forwarded a message from an unknown member, creating unknown member record cath" + dan <# "#team cath> hello [>>]", + do eve <## "#team: bob forwarded a message from an unknown member, creating unknown member record cath" + eve <# "#team cath> hello [>>]" + ] + + -- member deletes their message + cathMsgId <- lastItemId cath + cath #$> ("/_delete item #1 " <> cathMsgId <> " broadcast", id, "message marked deleted") + bob <# "#team cath> [marked deleted] hello" + concurrentlyN_ + [ alice <# "#team cath> [marked deleted] hello", + dan <# "#team cath> [marked deleted] hello", + eve <# "#team cath> [marked deleted] hello" + ] + testGroupLinkContentFilter :: HasCallStack => TestParams -> IO () testGroupLinkContentFilter = testChat3 aliceProfile bobProfile cathProfile $ diff --git a/tests/ProtocolTests.hs b/tests/ProtocolTests.hs index d61f1350d5..c740c7561f 100644 --- a/tests/ProtocolTests.hs +++ b/tests/ProtocolTests.hs @@ -116,10 +116,10 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do #==# XMsgNew (MCSimple (extMsgContent (MCText "hello") Nothing)) it "x.msg.new simple text - timed message TTL" $ "{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"ttl\":3600}}" - #==# XMsgNew (MCSimple (ExtMsgContent (MCText "hello") [] Nothing (Just 3600) Nothing Nothing)) + #==# XMsgNew (MCSimple (ExtMsgContent (MCText "hello") [] Nothing (Just 3600) Nothing Nothing Nothing)) it "x.msg.new simple text - live message" $ "{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"live\":true}}" - #==# XMsgNew (MCSimple (ExtMsgContent (MCText "hello") [] Nothing Nothing (Just True) Nothing)) + #==# XMsgNew (MCSimple (ExtMsgContent (MCText "hello") [] Nothing Nothing (Just True) Nothing Nothing)) it "x.msg.new simple link" $ "{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"https://simplex.chat\",\"type\":\"link\",\"preview\":{\"description\":\"SimpleX Chat\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgA\",\"title\":\"SimpleX Chat\",\"uri\":\"https://simplex.chat\"}}}}" #==# XMsgNew (MCSimple (extMsgContent (MCLink "https://simplex.chat" $ LinkPreview {uri = "https://simplex.chat", title = "SimpleX Chat", description = "SimpleX Chat", image = ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgA", content = Nothing}) Nothing)) @@ -146,22 +146,22 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") - (XMsgNew (MCQuote quotedMsg (ExtMsgContent (MCText "hello to you too") [] Nothing (Just 3600) Nothing Nothing))) + (XMsgNew (MCQuote quotedMsg (ExtMsgContent (MCText "hello to you too") [] Nothing (Just 3600) Nothing Nothing Nothing))) it "x.msg.new quote - live message" $ "{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello to you too\",\"type\":\"text\"},\"quote\":{\"content\":{\"text\":\"hello there!\",\"type\":\"text\"},\"msgRef\":{\"msgId\":\"BQYHCA==\",\"sent\":true,\"sentAt\":\"1970-01-01T00:00:01.000000001Z\"}},\"live\":true}}" ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") - (XMsgNew (MCQuote quotedMsg (ExtMsgContent (MCText "hello to you too") [] Nothing Nothing (Just True) Nothing))) + (XMsgNew (MCQuote quotedMsg (ExtMsgContent (MCText "hello to you too") [] Nothing Nothing (Just True) Nothing Nothing))) it "x.msg.new forward" $ "{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true}}" ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (extMsgContent (MCText "hello") Nothing)) it "x.msg.new forward - timed message TTL" $ "{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true,\"ttl\":3600}}" - ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (ExtMsgContent (MCText "hello") [] Nothing (Just 3600) Nothing Nothing)) + ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (ExtMsgContent (MCText "hello") [] Nothing (Just 3600) Nothing Nothing Nothing)) it "x.msg.new forward - live message" $ "{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true,\"live\":true}}" - ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (ExtMsgContent (MCText "hello") [] Nothing Nothing (Just True) Nothing)) + ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (ExtMsgContent (MCText "hello") [] Nothing Nothing (Just True) Nothing Nothing)) it "x.msg.new simple text with file" $ "{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"file\":{\"fileSize\":12345,\"fileName\":\"photo.jpg\"}}}" #==# XMsgNew (MCSimple (extMsgContent (MCText "hello") (Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileDigest = Nothing, fileConnReq = Nothing, fileInline = Nothing, fileDescr = Nothing}))) @@ -193,7 +193,7 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (extMsgContent (MCText "hello") (Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileDigest = Nothing, fileConnReq = Nothing, fileInline = Nothing, fileDescr = Nothing}))) it "x.msg.update" $ "{\"v\":\"1\",\"event\":\"x.msg.update\",\"params\":{\"msgId\":\"AQIDBA==\", \"content\":{\"text\":\"hello\",\"type\":\"text\"}}}" - #==# XMsgUpdate (SharedMsgId "\1\2\3\4") (MCText "hello") [] Nothing Nothing Nothing + #==# XMsgUpdate (SharedMsgId "\1\2\3\4") (MCText "hello") [] Nothing Nothing Nothing Nothing it "x.msg.del" $ "{\"v\":\"1\",\"event\":\"x.msg.del\",\"params\":{\"msgId\":\"AQIDBA==\"}}" #==# XMsgDel (SharedMsgId "\1\2\3\4") Nothing Nothing