dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-06-03 19:11:37 +00:00
Code Issues Packages Projects Releases Wiki Activity

core: channel messages (#6604)

Browse Source 
* 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>
This commit is contained in:
Evgeny
2026-02-12 07:11:59 +00:00
committed by GitHub
parent e29712c2e8
commit 628b00eb08
31 changed files with 3453 additions and 532 deletions
Download Patch File Download Diff File Expand all files Collapse all files
apps/simplex-directory-service/src/Directory/Service.hs
+3 -3
View File
@@ -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
bots/api/TYPES.md
+3
View File
@@ -606,6 +606,9 @@ GroupRcv:
- type: "groupRcv"
- groupMember: [GroupMember](#groupmember)
ChannelRcv:
- type: "channelRcv"
LocalSnd:
- type: "localSnd"
docs/contributing/CODE.md
+13
View File
@@ -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.
packages/simplex-chat-client/types/typescript/src/types.ts
+13 -1
View File
@@ -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"
}
plans/channel_message_bugs_fix_plan.md
+321
View File
@@ -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 |
plans/deduplication-channel-messages.md
+256
View File
@@ -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`
plans/delivery-context-fix.md
+354
View File
@@ -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`
plans/group_channel_feature_coverage.md
+377
View File
@@ -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*
plans/groups_coverage_fill_plan.md
+368
View File
@@ -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<Feature><Scenario>`
- 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`
plans/groups_test_coverage.md
+441
View File
@@ -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
src/Simplex/Chat/Controller.hs
+2 -7
View File
@@ -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
src/Simplex/Chat/Delivery.hs
+27 -13
View File
@@ -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)
src/Simplex/Chat/Library/Commands.hs
+83 -66
View File
@@ -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)
src/Simplex/Chat/Library/Internal.hs
+65 -50
View File
@@ -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
src/Simplex/Chat/Library/Subscriber.hs
+302 -204
View File
@@ -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
src/Simplex/Chat/Messages.hs
+31 -23
View File
@@ -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
src/Simplex/Chat/Messages/Batch.hs
+6 -4
View File
@@ -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
src/Simplex/Chat/Protocol.hs
+15 -14
View File
@@ -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]
src/Simplex/Chat/Store/Delivery.hs
+8 -6
View File
@@ -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] <-
src/Simplex/Chat/Store/Files.hs
+11 -8
View File
@@ -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
src/Simplex/Chat/Store/Groups.hs
+13 -9
View File
@@ -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 =
src/Simplex/Chat/Store/Messages.hs
+35 -18
View File
@@ -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)
src/Simplex/Chat/Store/SQLite/Migrations/M20230511_reactions.hs
+1 -1
View File
@@ -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,
src/Simplex/Chat/Store/SQLite/Migrations/M20250813_delivery_tasks.hs
+2 -2
View File
@@ -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).
src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt
+8 -6
View File
@@ -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=?)
src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql
+1 -1
View File
@@ -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,
src/Simplex/Chat/Terminal/Output.hs
+2 -1
View File
@@ -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
src/Simplex/Chat/Types.hs
+6
View File
@@ -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
src/Simplex/Chat/View.hs
+62 -48
View File
@@ -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
tests/ChatTests/Groups.hs
+617 -40
View File
@@ -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 [<dir>/ | <path>] to receive it"
concurrentlyN_
[ do
cath <# "#team> sends file test.jpg (136.5 KiB / 139737 bytes) [>>]"
cath <## "use /fr 1 [<dir>/ | <path>] to receive it [>>]",
do
dan <# "#team> sends file test.jpg (136.5 KiB / 139737 bytes) [>>]"
dan <## "use /fr 1 [<dir>/ | <path>] to receive it [>>]",
do
eve <# "#team> sends file test.jpg (136.5 KiB / 139737 bytes) [>>]"
eve <## "use /fr 1 [<dir>/ | <path>] 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 [<dir>/ | <path>] to receive it"
concurrentlyN_
[ do
cath <# "#team> sends file test.jpg (136.5 KiB / 139737 bytes) [>>]"
cath <## "use /fr 1 [<dir>/ | <path>] to receive it [>>]",
do
dan <# "#team> sends file test.jpg (136.5 KiB / 139737 bytes) [>>]"
dan <## "use /fr 1 [<dir>/ | <path>] to receive it [>>]",
do
eve <# "#team> sends file test.jpg (136.5 KiB / 139737 bytes) [>>]"
eve <## "use /fr 1 [<dir>/ | <path>] 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 [<dir>/ | <path>] to receive it"
concurrentlyN_
[ do
cath <# "#team alice> sends file test.jpg (136.5 KiB / 139737 bytes) [>>]"
cath <## "use /fr 1 [<dir>/ | <path>] to receive it [>>]",
do
dan <# "#team alice> sends file test.jpg (136.5 KiB / 139737 bytes) [>>]"
dan <## "use /fr 1 [<dir>/ | <path>] to receive it [>>]",
do
eve <# "#team alice> sends file test.jpg (136.5 KiB / 139737 bytes) [>>]"
eve <## "use /fr 1 [<dir>/ | <path>] 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 [<dir>/ | <path>] to receive it"
concurrentlyN_
[ do
cath <# "#team alice> sends file test.jpg (136.5 KiB / 139737 bytes) [>>]"
cath <## "use /fr 1 [<dir>/ | <path>] to receive it [>>]",
do
dan <# "#team alice> sends file test.jpg (136.5 KiB / 139737 bytes) [>>]"
dan <## "use /fr 1 [<dir>/ | <path>] to receive it [>>]",
do
eve <# "#team alice> sends file test.jpg (136.5 KiB / 139737 bytes) [>>]"
eve <## "use /fr 1 [<dir>/ | <path>] 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 $
tests/ProtocolTests.hs
+7 -7
View File
@@ -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