From 2db92ff6ed8376997262f03dfbf87f35671196f7 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Mon, 16 Mar 2026 10:46:35 +0000 Subject: [PATCH] core: group member/owner keys for signing important messages (#6597) * rfc: member keys * update plan * new encoding for message batches * send new batch encoding in relay-based groups * mvp launch plan * update plan * core: verify group member keys (#6669) * core: verify group member keys * refactor, process forwards * refactor parsing * refactor parsing 2 * refactor parser 3 * update rfc * simplify * simplify * log tag * refactor tag logging * refactor withVerifiedSig * simplify * refactor more * comment * fix encoding * fix sending as group for the new binary batch encoding * unify types * update api docs * clean up --------- Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com> * core: signing messages with member keys (#6675) * core: signing messages with member keys (types) * sign messages * refactor batching * better * refactor * remove unused Eq --------- Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com> * core: forward signed messages as unchanged binary strings (#6678) * core: forward signed messages as unchanged binary strings * refactor * consolidate types * refactor VerifiedMsg * refactor more * undo rename Co-authored-by: Evgeny * update schema and plans * add signed status to chat items and events * test signed chat items * unify parser * PostgreSQL fix, remove unused fields, option to send inline files in the tests * change inline files config * revert inline config change * use different characters in batch encoding, to avoid conflict with inline files * fix test, api docs, query plans --------- Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com> --------- Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com> --- .../src/Directory/Service.hs | 2 +- bots/api/COMMANDS.md | 5 + bots/api/EVENTS.md | 6 + bots/api/TYPES.md | 4 + docs/rfcs/2025-04-14-signing-messages.md | 10 + docs/rfcs/2026-01-23-member-keys-plan.md | 652 ++++++++++++++++++ .../types/typescript/src/events.ts | 6 + .../types/typescript/src/responses.ts | 5 + .../types/typescript/src/types.ts | 7 + plans/2026-03-13-message-keys-forwarding.md | 473 +++++++++++++ plans/chat-relays-mvp-launch-plan.md | 293 ++++++++ src/Simplex/Chat/Controller.hs | 22 +- src/Simplex/Chat/Delivery.hs | 8 +- src/Simplex/Chat/Library/Commands.hs | 78 ++- src/Simplex/Chat/Library/Internal.hs | 122 ++-- src/Simplex/Chat/Library/Subscriber.hs | 200 +++--- src/Simplex/Chat/Messages.hs | 17 +- src/Simplex/Chat/Messages/Batch.hs | 126 ++-- src/Simplex/Chat/Messages/CIContent.hs | 2 + src/Simplex/Chat/Messages/CIContent/Events.hs | 1 + src/Simplex/Chat/Protocol.hs | 201 +++++- src/Simplex/Chat/Store/Delivery.hs | 28 +- src/Simplex/Chat/Store/Groups.hs | 12 +- src/Simplex/Chat/Store/Messages.hs | 80 ++- .../Migrations/M20260222_chat_relays.hs | 10 + .../Store/Postgres/Migrations/chat_schema.sql | 7 +- .../Migrations/M20260222_chat_relays.hs | 10 + .../SQLite/Migrations/chat_query_plans.txt | 28 +- .../Store/SQLite/Migrations/chat_schema.sql | 7 +- src/Simplex/Chat/Terminal/Input.hs | 2 +- src/Simplex/Chat/Types.hs | 17 +- src/Simplex/Chat/View.hs | 73 +- tests/ChatTests/Groups.hs | 101 +++ tests/MessageBatching.hs | 137 ++-- tests/ProtocolTests.hs | 16 +- 35 files changed, 2325 insertions(+), 443 deletions(-) create mode 100644 docs/rfcs/2026-01-23-member-keys-plan.md create mode 100644 plans/2026-03-13-message-keys-forwarding.md create mode 100644 plans/chat-relays-mvp-launch-plan.md diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index bb0525de66..a6d6377032 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/apps/simplex-directory-service/src/Directory/Service.hs @@ -674,7 +674,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName let gmId = groupMemberId' m sendComposedMessages cc (SRGroup groupId (Just $ GCSMemberSupport (Just gmId)) False) [MCText rjctNotice] sendChatCmd cc (APIRemoveMembers groupId [gmId] False) >>= \case - Right (CRUserDeletedMembers _ _ (_ : _) _) -> do + Right (CRUserDeletedMembers _ _ (_ : _) _ _) -> do atomically $ TM.delete gmId $ pendingCaptchas env logInfo $ "Member " <> viewName displayName <> " rejected, group " <> tshow groupId <> ":" <> viewGroupName g r -> logError $ "unexpected remove member response: " <> tshow r diff --git a/bots/api/COMMANDS.md b/bots/api/COMMANDS.md index 7f6c6c106d..05801c891c 100644 --- a/bots/api/COMMANDS.md +++ b/bots/api/COMMANDS.md @@ -736,6 +736,7 @@ MembersRoleUser: Members role changed by user. - groupInfo: [GroupInfo](./TYPES.md#groupinfo) - members: [[GroupMember](./TYPES.md#groupmember)] - toRole: [GroupMemberRole](./TYPES.md#groupmemberrole) +- msgSigned: bool ChatCmdError: Command error (only used in WebSockets API). - type: "chatCmdError" @@ -777,6 +778,7 @@ MembersBlockedForAllUser: Members blocked for all by admin. - groupInfo: [GroupInfo](./TYPES.md#groupinfo) - members: [[GroupMember](./TYPES.md#groupmember)] - blocked: bool +- msgSigned: bool ChatCmdError: Command error (only used in WebSockets API). - type: "chatCmdError" @@ -818,6 +820,7 @@ UserDeletedMembers: Members deleted. - groupInfo: [GroupInfo](./TYPES.md#groupinfo) - members: [[GroupMember](./TYPES.md#groupmember)] - withMessages: bool +- msgSigned: bool ChatCmdError: Command error (only used in WebSockets API). - type: "chatCmdError" @@ -1054,6 +1057,7 @@ GroupUpdated: Group updated. - fromGroup: [GroupInfo](./TYPES.md#groupinfo) - toGroup: [GroupInfo](./TYPES.md#groupinfo) - member_: [GroupMember](./TYPES.md#groupmember)? +- msgSigned: bool ChatCmdError: Command error (only used in WebSockets API). - type: "chatCmdError" @@ -1600,6 +1604,7 @@ GroupDeletedUser: User deleted group. - type: "groupDeletedUser" - user: [User](./TYPES.md#user) - groupInfo: [GroupInfo](./TYPES.md#groupinfo) +- msgSigned: bool ChatCmdError: Command error (only used in WebSockets API). - type: "chatCmdError" diff --git a/bots/api/EVENTS.md b/bots/api/EVENTS.md index a71a4540f5..6633c58354 100644 --- a/bots/api/EVENTS.md +++ b/bots/api/EVENTS.md @@ -301,6 +301,7 @@ Group profile or preferences updated. - fromGroup: [GroupInfo](./TYPES.md#groupinfo) - toGroup: [GroupInfo](./TYPES.md#groupinfo) - member_: [GroupMember](./TYPES.md#groupmember)? +- msgSigned: bool --- @@ -330,6 +331,7 @@ Member (or bot user's) group role changed. - member: [GroupMember](./TYPES.md#groupmember) - fromRole: [GroupMemberRole](./TYPES.md#groupmemberrole) - toRole: [GroupMemberRole](./TYPES.md#groupmemberrole) +- msgSigned: bool --- @@ -345,6 +347,7 @@ Another member is removed from the group. - byMember: [GroupMember](./TYPES.md#groupmember) - deletedMember: [GroupMember](./TYPES.md#groupmember) - withMessages: bool +- msgSigned: bool --- @@ -372,6 +375,7 @@ Bot user was removed from the group. - groupInfo: [GroupInfo](./TYPES.md#groupinfo) - member: [GroupMember](./TYPES.md#groupmember) - withMessages: bool +- msgSigned: bool --- @@ -385,6 +389,7 @@ Group was deleted by the owner (not bot user). - user: [User](./TYPES.md#user) - groupInfo: [GroupInfo](./TYPES.md#groupinfo) - member: [GroupMember](./TYPES.md#groupmember) +- msgSigned: bool --- @@ -428,6 +433,7 @@ Another member blocked for all members. - byMember: [GroupMember](./TYPES.md#groupmember) - member: [GroupMember](./TYPES.md#groupmember) - blocked: bool +- msgSigned: bool --- diff --git a/bots/api/TYPES.md b/bots/api/TYPES.md index a99750e1d5..e6dbc42bfe 100644 --- a/bots/api/TYPES.md +++ b/bots/api/TYPES.md @@ -780,6 +780,7 @@ Group: - editable: bool - forwardedByMember: int64? - showGroupAsSender: bool +- msgSigned: bool - createdAt: UTCTime - updatedAt: UTCTime @@ -3125,6 +3126,9 @@ MemberProfileUpdated: NewMemberPendingReview: - type: "newMemberPendingReview" +MsgBadSignature: +- type: "msgBadSignature" + --- diff --git a/docs/rfcs/2025-04-14-signing-messages.md b/docs/rfcs/2025-04-14-signing-messages.md index 8845de0cd8..1ad6e6778f 100644 --- a/docs/rfcs/2025-04-14-signing-messages.md +++ b/docs/rfcs/2025-04-14-signing-messages.md @@ -81,3 +81,13 @@ Cons: - two-stage decoding may be seen as a downside, but it is offset by the fact that re-encodings are avoided, and under the hood JSON is decoded in stages anyway. While deterministic JSON is [quite simple](https://github.com/simplex-chat/aeson/pull/4/files) for aeson implementation, the Option 2 seems more attractive overall, as it avoids questionable design of including signatures into JSON and the need to re-encode JSON to sign and to verify signatures. + +## Signing scope: roster changes only, not content messages + +Only roster-modifying and group management messages are signed (e.g. `XGrpMemNew`, `XGrpMemRole`, `XGrpMemDel`, `XGrpInfo`, `XGrpPrefs`, `XGrpDel`). Regular content messages (`XMsgNew`, etc.) are not signed. + +Two reasons: + +1. **Deniability.** Signing content messages would create non-repudiable proof of authorship — any party with access to the message bytes could prove who wrote a specific message. This is antithetical to SimpleX's privacy model, where messages should be deniable. Administrative actions (adding/removing members, changing roles) don't need deniability — they are organizational actions, not personal communications. + +2. **Different threat model.** Content message manipulation by relays is detectable post-hoc: with multiple independent relays, members can cross-check message consistency and detect forgery after the fact. This is sufficient for content because content delivery is not irreversible — a forged message can be flagged and corrected. Roster and profile changes, on the other hand, are disruptive and irreversible (a member removed, a role changed, a group deleted). By the time forgery is detected, the damage is done. These actions must be authenticated at processing time, before they take effect. diff --git a/docs/rfcs/2026-01-23-member-keys-plan.md b/docs/rfcs/2026-01-23-member-keys-plan.md new file mode 100644 index 0000000000..b278cf0c32 --- /dev/null +++ b/docs/rfcs/2026-01-23-member-keys-plan.md @@ -0,0 +1,652 @@ +# Implementation Plan: Member Keys and Signatures for Simplex Chat + +## Overview + +Add cryptographic signatures to Simplex Chat messages to prevent relay impersonation and roster manipulation in public groups with chat relays. + +## Design Approach + +Following **RFC Option 2: Multi-stage encoding** (recommended in docs/rfcs/2025-04-14-signing-messages.md): +- Encoded JSON body (non-deterministic key ordering OK) +- Conversation binding (group root key + sender member ID for groups) +- Array of (key reference, signature) tuples + +## Key Files to Modify + +### Core Types +- `src/Simplex/Chat/Types.hs` - Add `MemberKey` type, add `memberKey` to `MemberInfo` +- `src/Simplex/Chat/Protocol.hs` - Add member keys to `XMember`, `XGrpLinkMem`; signed message envelope, encoding/decoding + +### Protocol Handling +- `src/Simplex/Chat/Library/Commands.hs` - Sign messages when sending +- `src/Simplex/Chat/Library/Subscriber.hs` - Verify signatures when receiving +- `src/Simplex/Chat/Library/Internal.hs` - Chat-level signature utilities (working with Member profiles, messages) + +### Agent API (simplexmq repo) - New Functions +- `../simplexmq/src/Simplex/Messaging/Agent.hs`: + - `prepareConnectionLink` - NEW: commits to server, generates link address + root key locally (no network) + - `createConnectionWithPreparedLink` - NEW: accepts server + root key, creates queue (single network call) +- `../simplexmq/src/Simplex/Messaging/Agent/Client.hs` - Implement new functions + +### Database +- New migration: `src/Simplex/Chat/Store/SQLite/Migrations/M20260124_member_keys.hs` +- New migration: `src/Simplex/Chat/Store/Postgres/Migrations/M20260124_member_keys.hs` +- `src/Simplex/Chat/Store/Profiles.hs` - Store/retrieve member keys + +## New Types + +### 1. Member Key Type (Types.hs) + +```haskell +newtype MemberKey = MemberKey C.PublicKeyEd25519 + deriving (Eq, Show) + +-- IMPORTANT: memberKey is NOT in Profile - profiles can be updated independently +-- Member keys are fixed at join time and sent via member announcement messages + +-- Add memberKey to MemberInfo (used in XGrpMemNew, XGrpMemIntro, XGrpMemFwd) +data MemberInfo = MemberInfo + { memberId :: MemberId, + memberRole :: GroupMemberRole, + v :: Maybe ChatVersionRange, + profile :: Profile, + memberKey :: Maybe MemberKey -- NEW: member's signing key + } + deriving (Eq, Show) +``` + +### 2. Protocol Messages with Member Keys (Protocol.hs) + +Member keys are communicated via member identification/announcement messages, NOT profile updates: + +```haskell +-- Member self-identification when joining group +-- newMemberKey is required (not Maybe) - every new member must have a key +XMember :: {profile :: Profile, newMemberId :: MemberId, newMemberKey :: MemberKey} -> ChatMsgEvent 'Json + +-- Member joining via group link +XGrpLinkMem :: Profile -> Maybe MemberKey -> ChatMsgEvent 'Json + +-- Member announcements use MemberInfo which now includes memberKey +-- XGrpMemNew, XGrpMemIntro, XGrpMemFwd all use MemberInfo + +-- Profile updates do NOT include memberKey - key is fixed at join time +XGrpMemInfo :: MemberId -> Profile -> ChatMsgEvent 'Json -- unchanged +``` + +**Key points:** +- `XMember.newMemberKey` is required (not Maybe) - joining member must provide key +- `XGrpLinkMem` has `Maybe MemberKey` for backward compatibility +- `MemberInfo.memberKey` is `Maybe` for backward compatibility with existing members +- Profile updates (`XGrpMemInfo`) don't include key - it's fixed at join time + +### 3. Member Key Storage + +- Private key stored in `groups.member_priv_key` (current user's signing key for this group) +- Public key stored in `group_members.member_pub_key` (for all members) +- NOT stored in profiles table - member keys are per-group, not per-profile + +### 4. Signed Message Types (Protocol.hs) + +Types as implemented in Protocol.hs: + +```haskell +-- Key reference tag — indicates which key to use for verification. +-- KRMember means "use the contextual member's key" (sender or forwarded author). +-- Can be extended to support profile identity keys (e.g., secp256k1 for Nostr). +data KeyRef = KRMember + deriving (Eq, Show) + +-- Conversation binding for signature scope +data ChatBinding + = CBDirect {securityCode :: ByteString} + | CBGroup {groupRootKey :: C.PublicKeyEd25519, senderMemberId :: MemberId} + deriving (Eq, Show) + +-- Signature with key reference +data MsgSignature = MsgSignature KeyRef C.ASignature + deriving (Show) + +-- Signatures with chat binding +data MsgSignatures = MsgSignatures + { chatBinding :: ChatBinding, + signatures :: NonEmpty MsgSignature + } + +-- Field order matches wire format: forward data (> prefix), then sig data (/ prefix), then message ({ prefix) +data ParsedMsg = ParsedMsg (Maybe MsgForwardData) (Maybe MsgSigData) AChatMessage + +data MsgSigData = MsgSigData + { signatures :: MsgSignatures, + signedBody :: ByteString -- exact bytes that were signed + } + +data MsgForwardData = MsgForwardData + { fwdMemberId :: MemberId, + fwdMemberName :: ContactName, -- may be empty + fwdBrokerTs :: UTCTime + } +``` + +**Key insight:** The binary batch format preserves the exact bytes of each element via length-prefix framing, enabling signature verification even after the message has been parsed. This is critical for forwarded messages. + +### 5. Key Resolution and Validation + +```haskell +-- Key resolution: lookup member's public key from GroupMember record +resolveKeyRef :: GroupInfo -> KeyRef -> Either String C.APublicVerifyKey +resolveKeyRef gInfo (KRMember mid) = + case findMemberByMemberId mid gInfo >>= memberKey of + Just (MemberKey k) -> Right $ C.APublicVerifyKey C.SEd25519 k + Nothing -> Left $ "unknown member key: " <> show mid + +-- findMemberByMemberId looks up GroupMember by MemberId in GroupInfo +-- memberKey is stored in GroupMember record (from group_members.member_pub_key) + +-- Owner validation: verify member's key matches OwnerAuth chain +-- Called when processing roster-modifying messages from owners +validateOwnerMember :: GroupInfo -> MemberId -> MemberKey -> Either String () +validateOwnerMember gInfo memberId memberKey = do + case findOwnerAuth memberId (groupOwners gInfo) of + Nothing -> Left "member is not an owner" + Just OwnerAuth {ownerId, ownerKey} -> do + when (ownerId /= memberId) $ + Left "owner ID mismatch" + case memberKey of + MemberKey k | k == ownerKey -> Right () + _ -> Left "owner key doesn't match member key" +``` + +### Owner Verification Strategy (future multi-owner support) + +**Question:** How to validate that a member is a legitimate owner? + +**Option A: Request link data from server** +- Fetch current `UserContactData.owners` from SMP server +- Expensive: network roundtrip for each verification + +**Option B: Store OwnerAuth chain locally, verify via signatures** ✓ +- When joining group: receive OwnerAuth chain (from link data or group info) +- When new owner added: receive signed OwnerAuth (signed by root or existing owner) +- Verify locally using signature chain - no network needed +- Store chain in `group_owners` table + +**Current implementation (single owner):** +- Group creator is sole owner +- OwnerAuth created at group creation, stored in link data +- Members receive owner info when joining +- No multi-owner support yet (deferred) + +### 6. Message Batching Analysis + +Analysis of current batching behavior (determines new format requirements): + +**Q1: Can there be multiple compressed parts in one wire message?** + +**NO** - only ONE compressed block is ever created. +- `compressedBatchMsgBody_` (Protocol.hs:712) creates singleton list: `(L.:| []) . compress1` +- Called only in Internal.hs:1901 (connection info) and Internal.hs:1941 (message body) +- Decoder supports `NonEmpty Compressed` for forward compatibility, but encoding always produces 1 block + +**Q2: Can messages from multiple members be batched together?** + +**YES** - in both relay and non-relay groups: +- Relay groups: Delivery.hs:168-184 - `getNextDeliveryTasks` does NOT filter by sender +- Non-relay groups: `sendHistory` (Internal.hs:1171-1184) batches history items from multiple senders + +**Q3: Can forwarded and non-forwarded messages be batched together?** + +**YES** - in `sendHistory` (Internal.hs:1176-1184): +- `XMsgNew` (welcome/description) appended to `XGrpMsgForward` events +- Both sent together via `sendGroupMemberMessages` + +### 7. Wire Format (Protocol.hs) + +#### Current Format (JSON-based batching) + +```abnf +; Current wire format +wireMessage = compressedMsg / jsonMsg +compressedMsg = %s"X" compressedBlock ; single compressed block +jsonMsg = singleJson / jsonArray +singleJson = %s"{" *OCTET ; single JSON object +jsonArray = %s"[" *OCTET ; JSON array of messages +``` + +JSON array batching uses `[msg1,msg2,...]` format - simple but cannot preserve exact bytes for signatures. + +#### New Format (Binary batching for signatures) + +For relay-based groups where signatures are required, use binary batching that preserves exact message bytes: + +```abnf +; Extended wire format (parser accepts all formats) +wireMessage = compressedMsg / binaryBatch / jsonMsg + +; New binary batch format - preserves exact bytes for signature verification +binaryBatch = %s"=" elementCount *batchElement +elementCount = 1*1 OCTET ; 1-255 elements +batchElement = elementLen elementBody +elementLen = 2*2 OCTET ; 16-bit big-endian length +elementBody = signedElement / forwardElement / plainElement + +; Signed element - signatures followed by JSON body +signedElement = %s"/" msgSignatures jsonBody +jsonBody = *OCTET ; JSON bytes (length from elementLen) + +; Forward element - relay forwarding with preserved bytes (relay groups only) +; originalBytes is a nested element (signed or plain, but NOT another forward) +forwardElement = %s">" forwardMeta originalElement +forwardMeta = senderMemberId senderMemberName brokerTs +brokerTs = 8*8 OCTET ; UTC timestamp, big-endian microseconds +originalElement = signedElement / plainElement + +; Plain message element - starts with '{' (JSON object) +plainElement = jsonBody + +; Signature data (no '/' prefix — the element prefix serves that role) +msgSignatures = chatBinding sigCount *msgSignature +chatBinding = directBinding / groupBinding +directBinding = %s"D" securityCode +securityCode = shortString +groupBinding = %s"G" groupRootKey senderMemberId +groupRootKey = 32*32 OCTET ; Ed25519 public key +senderMemberId = shortString + +sigCount = 1*1 OCTET ; 1-255 signatures +msgSignature = keyRef sigBytes +keyRef = memberKeyRef +memberKeyRef = %s"M" ; use contextual member's key (sender or forwarded author) +sigBytes = 64*64 OCTET ; Ed25519 signature + +shortString = length *OCTET +length = 1*1 OCTET + +; Compressed format unchanged - compression wraps the batch +compressedMsg = %s"X" compressedBlock +; After decompression: binaryBatch / jsonMsg +``` + +**Overhead comparison:** +- JSON array: `[` + `]` + `,` between = n+1 bytes for n elements +- Binary batch: `=` + count + 2-byte length per element = 1 + 1 + 2n = 2 + 2n bytes +- Difference: ~1 extra byte per element - acceptable for signature support + +**Format selection:** +- Relay-based groups: Use binary batch (`=` prefix) - preserves bytes for signatures +- Non-relay groups: Use JSON array (`[...]`) - backward compatible, no signatures needed +- Old groups with old members: Use JSON array - full backward compatibility + +**Parser behavior (`parseChatMessages`):** +- `'='` prefix → binary batch (new format) +- `'{'` prefix → single JSON object +- `'['` prefix → JSON array +- `'X'` prefix → compressed (decompress, then re-parse) +- All formats accepted regardless of version for forward/backward compatibility + +**Batcher behavior (`Messages/Batch.hs`):** +- Accept `BatchMode` parameter: `BMJson` or `BMBinary` +- `BMJson`: Current JSON array encoding +- `BMBinary`: Binary format with length prefixes, preserves exact bytes + +```haskell +data BatchMode = BMJson | BMBinary + +batchMessages :: BatchMode -> Int -> [Either ChatError SndMessage] -> [Either ChatError MsgBatch] +-- batchDeliveryTasks1 hardcodes BMBinary (relay groups only) +batchDeliveryTasks1 :: VersionRangeChat -> Int -> NonEmpty MessageDeliveryTask -> (ByteString, [Int64], [Int64]) +``` + +**Key insight:** The binary batch format allows: +1. Each element's exact bytes preserved (length-prefixed, not re-encoded) +2. Mixed signed/unsigned elements in same batch +3. Forwarded messages preserve original sender's signature +4. Relay adds no signature - just wraps in forwarding envelope + +**Forwarding in binary batch (relay groups):** + +For relay-based groups, forwarding is NOT via `XGrpMsgForward` ChatMsgEvent (which would re-encode the inner message). Instead, forwarding uses a **binary batch element format** (`forwardElement` in the ABNF above) that preserves exact bytes: + +```abnf +; Forward element details (defined in batchElement above) +forwardElement = %s">" forwardMeta originalBytes +forwardMeta = senderMemberId senderMemberName brokerTs +senderMemberId = shortString +senderMemberName = shortString ; may be empty +brokerTs = 8*8 OCTET ; UTC timestamp, big-endian microseconds +originalBytes = *OCTET ; original signed message bytes (verbatim) +``` + +Forward elements only appear inside binary batches — there is no standalone forward envelope at the wire level. + +**Flow:** + +1. **Sender** creates signed message: + ``` + /<{"event":"x.msg.new",...}> + ``` + +2. **Relay** receives, parses to validate, stores original bytes in `msg_body` + +3. **Relay** forwards as binary batch element(s): + ``` + =( ">" )* + ``` + +4. **Recipient** parses binary batch, extracts `originalBytes` from forward elements, verifies sender's signature + +**Key difference from current approach:** +- Current: `XGrpMsgForward` nests **parsed** `ChatMessage 'Json` → re-encoded on send → bytes change +- New: Forward element contains **original element bytes** (`/` or `{`) → never re-encoded → signature remains valid +- Forward nesting is guarded: `elementP` rejects nested forward elements (`>` inside `>`) + +**Backward compatibility:** +- Old groups (non-relay): Continue using `XGrpMsgForward` ChatMsgEvent (JSON array batching) +- New relay groups: Use binary batch with forward elements (`>` prefix inside `=` batch) +- `XGrpMsgForward` JSON call site passes `Nothing` for `msgSig_` (no signature data available in JSON path) +- Parser accepts both formats + +**Key resolution:** +- `'M'` (member key ref): Use the contextual member's public key from `group_members.member_pub_key` — the sender (direct messages) or forwarded author (forward elements) + +## Messages Requiring Signatures + +### Owner/Admin Signatures (roster changes) +- `XGrpRelayInv` - Owner inviting relay (relay validates) +- `XGrpMemNew` - Adding new member +- `XGrpMemRole` - Changing member role +- `XGrpMemDel` - Removing member +- `XGrpInfo` - Updating group profile +- `XGrpPrefs` - Updating group preferences +- `XGrpDel` - Deleting group + +### Content messages — NOT signed +- `XMsgNew` and other content messages are not signed to preserve deniability. Relay manipulation of content is detectable post-hoc via cross-relay consistency. + +## Database Migration + +```sql +-- SQLite migration M20260124_member_keys.hs + +-- Group-level keys (current user's keys for this group) +ALTER TABLE groups ADD COLUMN shared_group_id BLOB; -- saved in link fixed data as entity ID +ALTER TABLE groups ADD COLUMN root_priv_key BLOB; -- root private key (only if user is the owner and group creator) +ALTER TABLE groups ADD COLUMN root_pub_key BLOB; -- needed for all members of public groups to verify ownership chains +ALTER TABLE groups ADD COLUMN member_priv_key BLOB; -- current user's member private key for this group + +-- Member public keys (for all members, including current user) +-- Public key is sent via MemberInfo/XMember and stored for signature verification +ALTER TABLE group_members ADD COLUMN member_pub_key BLOB; -- public key (all members) + +-- Note: root_priv_key is the root key from group link (immutable group identity), only for owner/creator +-- Note: root_pub_key is needed for all members of public groups to verify ownership chains +-- Note: member_priv_key is the current user's signing key for this group (unique per group) +-- Note: member_pub_key is received via MemberInfo (XGrpMemNew, etc.) or XMember message +``` + +## Root Key Management (Analysis Required) + +Currently, root key is generated in Agent (`ShortLinkCreds.linkPrivSigKey`) and stored in agent schema (`rcv_queues.link_priv_sig_key`). + +For Chat to sign owner messages, we need access to either: +- The root key (for initial owner) +- The owner key (for subsequent owners in chain) + +**Current Problem: Two-Step Group Creation (2 roundtrips)** + +Current flow in Commands.hs: +1. Chat creates connection → server roundtrip → gets link +2. Chat updates group profile to include link +3. Chat updates link data → another server roundtrip + +Problems: +- Double requests increase latency +- Risk of failing halfway (needs recovery management) +- Can't include signed owner key in initial link data + +**Solution: New Agent API with Prepare + Create Pattern** + +Two new Agent functions: + +```haskell +-- Prepared link data returned by prepare step (NO network, NO database) +-- Contains everything needed to: (a) construct the short link, (b) create the connection later +data PreparedConnLink c = PreparedConnLink + { pclServer :: SMPServerWithAuth, -- Committed server from config + pclNonce :: C.CbNonce, -- Nonce (corrId) - determines sender ID + pclRootKeyPair :: C.KeyPairEd25519, -- Root signing key for link + pclE2eKeyPair :: C.KeyPairX25519, -- E2E DH key for queue address + pclFixedLinkData :: FixedLinkData c, -- Contains connReq (with ratchet params for invitations) + pclLinkKey :: LinkKey, -- Derived from FixedLinkData: sha3_256(encoded fixedData) + pclPrivSigKey :: C.PrivateKeyEd25519 -- For signing link data (same as snd of pclRootKeyPair) + } + +-- 1. prepareConnectionLink: Generates all link parameters locally (NO network, NO database) +-- Returns PreparedConnLink + the actual short link that can be used in addresses +prepareConnectionLink :: ConnectionModeI c + => AgentClient -> UserId -> SConnectionMode c -> Maybe CRClientData -> CR.InitialKeys + -> AM (PreparedConnLink c, ConnShortLink c) +-- Does: +-- - Selects server from config (getSMPServer) +-- - Generates nonce, derives sender ID: sha3_384(corrId)[:24] +-- - Generates root key pair (Ed25519) for signing +-- - Generates e2e DH key pair (X25519) for queue address +-- - For invitations: generates E2E ratchet params +-- - Builds ConnectionRequestUri (contains queue address + ratchet params) +-- - Builds FixedLinkData (contains connReq + rootKey + agentVRange) +-- - Derives linkKey = sha3_256(encoded fixedData) +-- - Constructs ConnShortLink (CSLContact or CSLInvitation) with linkKey +-- Returns (PreparedConnLink, ConnShortLink) - both can be roundtripped, nothing saved + +-- 2. createConnectionWithPreparedLink: Creates connection using prepared link +-- Single network call to create queue with pre-determined sender ID +createConnectionWithPreparedLink :: ConnectionModeI c => + AgentClient -> NetworkRequestMode -> UserId -> Bool -> Bool -> + PreparedConnLink c -> UserConnLinkData c -> SubscriptionMode -> + AM (ConnId, (CreatedConnLink c, Maybe ClientServiceId)) +-- Accepts: +-- - PreparedConnLink from prepare step (contains all crypto material) +-- - UserConnLinkData with signed OwnerAuth array (mutable part) +-- Does: +-- - Uses pclNonce to get deterministic sender ID +-- - Creates connection record (newConnNoQueues) +-- - Creates queue on server with prepared nonce → same sender ID +-- - Encrypts & uploads link data (fixed + user data) +-- Returns same as createConnection +``` + +**Key insights (from RFC 2025-03-16-smp-queues.md):** +- Sender ID = `sha3_384(nonce)[:24]` - derived locally from correlation ID (nonce) +- `FixedLinkData` contains `ConnectionRequestUri` (includes ratchet params for invitations) +- `LinkKey` = `sha3_256(encoded fixedData)` - derived from fixed data hash +- For **contact addresses**: `(link_id, enc_key) = HKDF(link_key, 56)` - fully deterministic +- For **1-time invitations**: `link_id` is server-generated, `enc_key = HKDF(link_key, 32)` +- Public groups use contact mode → short link address fully known at prepare step +- Everything can be roundtripped - no database needed for prepare step + +**New Flow (single roundtrip):** + +```haskell +-- In Chat (Commands.hs) when creating public group: +createPublicGroupWithRelays :: ... -> CM GroupInfo +createPublicGroupWithRelays ... = do + -- 1. Prepare link parameters (NO network, NO database) + -- Returns PreparedConnLink + the short link for use in group address + (preparedLink@PreparedConnLink {pclRootKeyPair = (rootPubKey, rootPrivKey)}, shortLink) <- + prepareConnectionLink c userId SCMContact clientData pqInitKeys + + -- 2. Generate owner's member key pair + (memberPubKey, memberPrivKey) <- liftIO $ atomically $ C.generateKeyPair g + + -- 3. Create signed OwnerAuth (Chat signs with root key) + let ownerAuth = OwnerAuth + { ownerId = memberId, + ownerKey = memberPubKey, + authOwnerSig = C.sign' rootPrivKey (memberId <> C.encodePubKey memberPubKey) + } + + -- 4. Create UserConnLinkData with owners array + let userLinkData = UserContactLinkData $ UserContactData { owners = [ownerAuth], direct = True } + + -- 5. Create connection with prepared link (SINGLE network call) + (connId, (createdLink, _)) <- createConnectionWithPreparedLink c NRMNormal userId + enableNtfs checkNotices preparedLink userLinkData SMSubscribe + + -- 6. Store keys in groups table + updateGroupKeys groupId rootPubKey rootPrivKey memberPrivKey + -- groups.root_pub_key = rootPubKey (for all members of public groups) + -- groups.root_priv_key = rootPrivKey (only for owner/creator) + -- groups.member_priv_key = memberPrivKey (current user's signing key) + -- group_members.member_pub_key = memberPubKey (for current user's membership) + + -- Note: shortLink can be used immediately in group profile/address + -- The link address is determined at step 1, not step 5 +``` + +**Key Points:** +- `prepareConnectionLink` generates all link parameters locally (no network, no DB) +- Returns `(PreparedConnLink, ConnShortLink)` - short link address is known immediately +- Sender ID is deterministic: `sha3_384(nonce)[:24]` - derived locally +- `FixedLinkData` contains `ConnectionRequestUri` (includes ratchet params for invitations) +- `LinkKey` derived from `FixedLinkData`, short link address derived from `LinkKey` +- Chat uses root key to sign owner's member key → OwnerAuth +- `createConnectionWithPreparedLink` makes single network roundtrip with complete link data +- `groups` table: `root_priv_key` (owner only), `root_pub_key` (all members), `member_priv_key` (current user) +- `group_members` table: `member_pub_key` (all members) + +## Current Public Group Creation (to be refactored) + +Review `src/Simplex/Chat/Library/Commands.hs` - current two-step process: +1. `APICreateGroup` / `createPreparedGroup` - creates group with connection +2. Server roundtrip to create link +3. Update profile with link +4. Update link data (another roundtrip) + +This needs refactoring to use new Agent API for single-roundtrip creation. + +## Implementation Steps + +### Phase 0: Agent API Changes (simplexmq) +1. Add `prepareConnectionLink` function - commits to server, generates link + root key locally +2. Add `createConnectionWithPreparedLink` function - accepts server + root key, single network call +3. Update Agent store to handle new flow (connection record without queue record) + +### Phase 1: Types and Encoding +1. Add `MemberKey` type and JSON encoding in Types.hs +2. Add `memberKey :: Maybe MemberKey` field to `MemberInfo` type +3. Add `newMemberKey :: MemberKey` to `XMember` message (required, not Maybe) +4. Add `Maybe MemberKey` parameter to `XGrpLinkMem` message +5. Types already added to Protocol.hs: `KeyRef`, `ChatBinding`, `MsgSignature`, `MsgSignatures`, `ParsedMsg`, `MsgSigData`, `MsgForwardData` +6. Encoding instances added: `KeyRef`, `ChatBinding`, `MsgSignature`, `MsgSignatures`, `MsgSigData`, `MsgForwardData` +7. Binary batch element parser (`elementP`) handles `/`/`>`/`{` prefixes with attoparsec +8. Update `parseChatMessages` to accept both JSON array and binary batch formats +9. Add `BatchMode` parameter to batching functions in Messages/Batch.hs + +### Phase 2: Key Generation and Storage +1. Add database migration for `member_pub_key` in group_members, `member_priv_key` in groups +2. Generate Ed25519 key pair when joining/creating group +3. Store private key in groups.member_priv_key (current user's key for this group) +4. Store public key in group_members.member_pub_key (for all members) +5. Include public key in XMember/XGrpLinkMem/MemberInfo when sending + +### Phase 3: Signing Messages +1. Add `signChatMessage` function in Internal.hs +2. Modify `sendGroupMessage` to sign roster-modifying messages +3. Add owner key to group link when creating public group +4. Sign `XGrpRelayInv` with owner key + +### Phase 4: Signature Verification +1. `verifySig` added in Subscriber.hs — verifies against member's stored public key, checks member ID match +2. `processAChatMsg` verifies direct messages; `xGrpMsgForward` verifies forwarded messages after author resolution +3. `xGrpMsgForward` extended with `Maybe GroupChatScopeInfo` and `Maybe MsgSigData` — eliminated `processForward` duplication +4. Bad signature creates `RGEMsgBadSignature` chat item for the user +5. Add relay validation for `XGrpRelayInv` in Subscriber.hs + +### Phase 5: Version Gating +1. Add new chat version (e.g., `memberSignaturesVersion = VersionChat 17`) +2. Gate signature features behind version check +3. Accept unsigned messages from older clients +4. Send signed messages only to clients supporting new version + +## Signature Verification Logic + +Current implementation (`verifySig` in Subscriber.hs) — minimal first step: + +```haskell +verifySig :: GroupMember -> Maybe MsgSigData -> Bool +verifySig GroupMember {memberPubKey = Just pubKey} (Just MsgSigData {signatures = MsgSignatures {signatures}, signedBody}) = + all verifyOne (L.toList signatures) + where + verifyOne (MsgSignature KRMember sig) = + C.verify (C.APublicVerifyKey C.SEd25519 pubKey) sig signedBody +verifySig _ _ = True +``` + +Verification is called in two places: +- `processAChatMsg`: verifies direct messages from the sender member +- `xGrpMsgForward`: verifies forwarded messages after resolving the author from `MsgForwardData.fwdMemberId` + +Future full verification should additionally: +1. Validate `ChatBinding` matches group (root key, sender member ID) +2. Reject unsigned messages for message types that require signatures + +## Owner Key Integration with Group Link (Separate Key Model) + +When creating a public group: +1. Generate group root key (Ed25519 key pair) - stored in group link's immutable FixedLinkData +2. Generate owner's member key (Ed25519 key pair) - stored in groups.member_priv_key and group_members.member_pub_key +3. Create OwnerAuth entry: `OwnerAuth { ownerId = memberId, ownerKey = memberKey, authOwnerSig = sig(memberId || memberKey, rootKey) }` +4. Add OwnerAuth to group link's mutable UserContactData.owners list + +This model: +- Root key is immutable (defines group identity) +- Owner key is in OwnerAuth chain (supports ownership transfer) +- Member keys are per-group, stored in groups/group_members tables (NOT in profiles) +- New owners can be added by existing owners signing their authorization + +```haskell +-- When creating public group +createPublicGroup :: ... -> CM GroupInfo +createPublicGroup ... = do + -- 1. Generate root key for group identity + (rootPubKey, rootPrivKey) <- generateKeyPair Ed25519 + + -- 2. Generate owner's member key for this group + (memberPubKey, memberPrivKey) <- generateKeyPair Ed25519 + + -- 3. Create owner authorization signed by root + let ownerAuth = OwnerAuth + { ownerId = memberId membership, + ownerKey = memberPubKey, + authOwnerSig = sign rootPrivKey (memberId <> encodePubKey memberPubKey) + } + + -- 4. Store keys: root_priv_key and member_priv_key in groups table + -- member_pub_key in group_members table + -- 5. Add ownerAuth to link data + ... +``` + +## Testing Considerations + +1. **Unit tests**: Encoding/decoding round-trips for signed messages +2. **Integration tests**: Message signing and verification flow +3. **Compatibility tests**: Old clients receiving signed messages +4. **Relay tests**: Signature validation in relay invitation flow +5. **Key rotation tests**: Profile updates with new member key + +## Backward Compatibility + +- **Hard fail mode**: Messages requiring signatures (roster changes) MUST be signed. Unsigned/invalid = rejected. +- Version-gated: Add `memberSignaturesVersion = VersionChat 17` +- New clients: Send signed roster messages, reject unsigned roster messages from new clients +- Old clients: Cannot send roster messages to new-version groups (version negotiation prevents this) +- Migration path: Existing groups without signatures continue working; new public groups require signatures + +## Design Decisions (Confirmed) + +1. **Message signing scope**: Only roster-modifying messages (XGrpRelayInv, XGrpMemNew, XGrpMemRole, XGrpMemDel, XGrpInfo, XGrpPrefs, XGrpDel). Regular content messages (XMsgNew) are NOT signed — signing them would destroy deniability by creating non-repudiable proof of authorship. Content manipulation by relays is detectable post-hoc via cross-relay consistency, which is sufficient because content delivery is not irreversible. Roster/profile changes are disruptive and irreversible (member removed, role changed, group deleted), so they must be authenticated at processing time before taking effect — post-detection is too late. + +2. **Signature failure handling**: Hard fail for all signed message types. Reject any message that should be signed but isn't or has invalid signature. + +3. **Key model**: Separate keys - root key is fixed in group link, owner is authorized via OwnerAuth chain. Supports ownership transfer without breaking group identity. Matches simplexmq pattern. diff --git a/packages/simplex-chat-client/types/typescript/src/events.ts b/packages/simplex-chat-client/types/typescript/src/events.ts index f7b1725843..178d11654a 100644 --- a/packages/simplex-chat-client/types/typescript/src/events.ts +++ b/packages/simplex-chat-client/types/typescript/src/events.ts @@ -215,6 +215,7 @@ export namespace CEvt { fromGroup: T.GroupInfo toGroup: T.GroupInfo member_?: T.GroupMember + msgSigned: boolean } export interface JoinedGroupMember extends Interface { @@ -232,6 +233,7 @@ export namespace CEvt { member: T.GroupMember fromRole: T.GroupMemberRole toRole: T.GroupMemberRole + msgSigned: boolean } export interface DeletedMember extends Interface { @@ -241,6 +243,7 @@ export namespace CEvt { byMember: T.GroupMember deletedMember: T.GroupMember withMessages: boolean + msgSigned: boolean } export interface LeftMember extends Interface { @@ -256,6 +259,7 @@ export namespace CEvt { groupInfo: T.GroupInfo member: T.GroupMember withMessages: boolean + msgSigned: boolean } export interface GroupDeleted extends Interface { @@ -263,6 +267,7 @@ export namespace CEvt { user: T.User groupInfo: T.GroupInfo member: T.GroupMember + msgSigned: boolean } export interface ConnectedToGroupMember extends Interface { @@ -288,6 +293,7 @@ export namespace CEvt { byMember: T.GroupMember member: T.GroupMember blocked: boolean + msgSigned: boolean } export interface GroupMemberUpdated extends Interface { diff --git a/packages/simplex-chat-client/types/typescript/src/responses.ts b/packages/simplex-chat-client/types/typescript/src/responses.ts index ff913fdfa9..8d4f68c000 100644 --- a/packages/simplex-chat-client/types/typescript/src/responses.ts +++ b/packages/simplex-chat-client/types/typescript/src/responses.ts @@ -221,6 +221,7 @@ export namespace CR { type: "groupDeletedUser" user: T.User groupInfo: T.GroupInfo + msgSigned: boolean } export interface GroupLink extends Interface { @@ -276,6 +277,7 @@ export namespace CR { fromGroup: T.GroupInfo toGroup: T.GroupInfo member_?: T.GroupMember + msgSigned: boolean } export interface GroupsList extends Interface { @@ -310,6 +312,7 @@ export namespace CR { groupInfo: T.GroupInfo members: T.GroupMember[] blocked: boolean + msgSigned: boolean } export interface MembersRoleUser extends Interface { @@ -318,6 +321,7 @@ export namespace CR { groupInfo: T.GroupInfo members: T.GroupMember[] toRole: T.GroupMemberRole + msgSigned: boolean } export interface NewChatItems extends Interface { @@ -411,6 +415,7 @@ export namespace CR { groupInfo: T.GroupInfo members: T.GroupMember[] withMessages: boolean + msgSigned: boolean } export interface UserProfileUpdated extends Interface { diff --git a/packages/simplex-chat-client/types/typescript/src/types.ts b/packages/simplex-chat-client/types/typescript/src/types.ts index 061c580d46..efa19b8baa 100644 --- a/packages/simplex-chat-client/types/typescript/src/types.ts +++ b/packages/simplex-chat-client/types/typescript/src/types.ts @@ -795,6 +795,7 @@ export interface CIMeta { editable: boolean forwardedByMember?: number // int64 showGroupAsSender: boolean + msgSigned: boolean createdAt: string // ISO-8601 timestamp updatedAt: string // ISO-8601 timestamp } @@ -3452,6 +3453,7 @@ export type RcvGroupEvent = | RcvGroupEvent.MemberCreatedContact | RcvGroupEvent.MemberProfileUpdated | RcvGroupEvent.NewMemberPendingReview + | RcvGroupEvent.MsgBadSignature export namespace RcvGroupEvent { export type Tag = @@ -3471,6 +3473,7 @@ export namespace RcvGroupEvent { | "memberCreatedContact" | "memberProfileUpdated" | "newMemberPendingReview" + | "msgBadSignature" interface Interface { type: Tag @@ -3555,6 +3558,10 @@ export namespace RcvGroupEvent { export interface NewMemberPendingReview extends Interface { type: "newMemberPendingReview" } + + export interface MsgBadSignature extends Interface { + type: "msgBadSignature" + } } export enum RelayStatus { diff --git a/plans/2026-03-13-message-keys-forwarding.md b/plans/2026-03-13-message-keys-forwarding.md new file mode 100644 index 0000000000..d495b30201 --- /dev/null +++ b/plans/2026-03-13-message-keys-forwarding.md @@ -0,0 +1,473 @@ +# Plan: Signed Message Storage, Forwarding, and Verification + +## Context + +The protocol types for signatures exist (`MsgSignatures`, `MsgSigData`, `ChatBinding`), the parser handles `/`/`>`/`{` element prefixes, and `verifySig` checks signatures. What's missing: + +1. **Signing when sending** — members sign their messages before sending to the relay +2. **Signature storage** — persisting signatures alongside message content +3. **Signature forwarding** — relay preserves and forwards original signatures intact +4. **Binding correctness** — bindings aren't covered by signatures or validated +5. **Required signatures** — admin events must require valid signatures in relay groups +6. **Visibility** — expose signature verification status in chat items + +## Design + +### A. Binding: Reconstructed, Not Sent + +`CBGroup {groupRootKey, senderMemberId}` — both known to verifier from context. Replace with single-byte binding tag on wire. + +Wire: ` ()*` + +Signed payload (constructed by signer and verifier, not on wire): +``` +smpEncode 'G' <> smpEncode (groupRootKey, senderMemberId) <> jsonBody +``` + +The binding tag is separate from the binding-specific prefix. SMP tuple encoding is concatenation, so `smpEncode ('G', k, m) = smpEncode 'G' <> smpEncode (k, m)` — same bytes either way. + +### B. Signing Context — Data, Not Function + +A generic record carries key material and binding data for signing: + +```haskell +data MsgSigning = MsgSigning + { sigBindingTag :: BindingTag + , sigPrefix :: ByteString -- binding-specific, e.g. smpEncode (rootKey, memberId) + , sigPrivKey :: C.PrivateKeyEd25519 + } +``` + +`sigBindingTag` goes into `MsgSignatures` on the wire (tells verifier which binding to reconstruct). `sigPrefix` is the binding-specific bytes. The signing function combines: `smpEncode sigBindingTag <> sigPrefix <> jsonBody`. + +Group-specific constructor: +```haskell +groupMsgSigning :: GroupKeys -> GroupMember -> MsgSigning +groupMsgSigning GroupKeys {groupRootKey, memberPrivKey} GroupMember {memberId} = + MsgSigning BTGroup (smpEncode (groupRootPubKey groupRootKey, memberId)) memberPrivKey +``` + +For contacts in the future — different constructor, different binding tag, same `MsgSigning` record and same `createSndMessages` path. + +### C. Per-Event Signing Decision — Caller, Not Policy + +The decision of whether to sign each event lives with the caller, not inside `createSndMessages`. The caller provides `Maybe MsgSigning` per event: + +```haskell +createSndMessages :: (MsgEncodingI e, Traversable t) + => t (ConnOrGroupId, ChatMsgEvent e, Maybe MsgSigning) + -> CM' (t (Either ChatError SndMessage)) +``` + +In `sendGroupMessages_`: +```haskell +let signing evt = case groupKeys gInfo of + Just gk | requiresSignature (toCMEventTag evt) -> Just (groupMsgSigning gk (membership gInfo)) + _ -> Nothing + idsEvts = L.map (\evt -> (GroupId groupId, evt, signing evt)) events +``` + +`requiresSignature` is group policy — only roster-modifying events (`XGrpDel`, `XGrpInfo`, `XGrpPrefs`, `XGrpMemDel`, `XGrpMemRole`, `XGrpMemRestrict`). Content is never signed (deniability). When contact signing is added, a different caller uses a different predicate — `createSndMessages` is mechanical. + +### D. Signature Storage — Persisted for History + +Signatures are persisted in `msg_sigs BLOB` column alongside `msg_body` in the same INSERT. One DB operation. + +**Why persist (not ephemeral):** History delivery needs original signatures. In relay groups, history is forwarded with signatures preserved. In non-relay groups (if signing is extended), own sent signatures must survive for delivery to new members. Persisting from the start avoids losing generality. + +`msg_body` remains unchanged (JSON, backward compatible). Content and authentication are orthogonal. + +### E. Signing Scope — Deniability vs Authentication + +Only roster-modifying messages are signed. Content messages (`XMsgNew` etc.) are NEVER signed. + +1. **Deniability** — signing content creates non-repudiable proof of authorship. Anyone with the message bytes could prove who wrote it. Antithetical to SimpleX's privacy model. + +2. **Threat model** — relay manipulation of content is detectable post-hoc via cross-relay consistency (multiple independent relays). Sufficient because content is not irreversible. Roster/profile changes are disruptive and irreversible (member removed, role changed, group deleted) — must be authenticated at processing time. + +### F. Symmetric Encoding + +```haskell +encodeMsgElement :: Maybe MsgSignatures -> ByteString -> ByteString +encodeMsgElement Nothing body = body +encodeMsgElement (Just sigs) body = "/" <> smpEncode sigs <> body +``` + +Dual of `elementP`'s `'/'`/`'{'` cases. Used by both send batcher (`batchMessages`) and forward batcher (`batchDeliveryTasks1`). No signing logic in any batcher — only structural encoding. + +### E. Delivery Tasks: `msgBody` not `chatMessage` + +`MessageDeliveryTask` carries `msgBody :: ByteString` (raw JSON from `msg_body`) + `msgSignatures_ :: Maybe MsgSignatures` — NOT `chatMessage :: ChatMessage 'Json`. + +**Why `msgBody` is sufficient:** +- All delivery task processing is structural — encode, batch, send. Content decisions happen at task CREATION time (in `processEvent`), not delivery time. +- `DJRelayRemoved` currently wraps `chatMessage` in JSON `XGrpMsgForward` — but should use binary encoding instead (same `>element` format as normal batching, just single-element). Binary encoding only needs raw bytes + signatures, not parsed ChatMessage. +- More general — works for any future message type without coupling to JSON. +- Eliminates a parse+re-encode cycle (raw bytes → ChatMessage → chatMsgToBody → bytes). + +### F. DJRelayRemoved: Binary Encoding + +Current: wraps chatMessage in JSON `XGrpMsgForward` event. New: produces binary batch with single `>/` element, same as normal forwarding. The receiver already handles binary forwarded elements through `elementP` → `xGrpMsgForward`. + +### G. Verification with Binding + +```haskell +verifySig gInfo GroupMember {memberPubKey = Just pk, memberId} + (Just MsgSigData {signatures = MsgSignatures {bindingTag = BTGroup, signatures}, signedBody}) + | Just gk <- groupKeys gInfo = + let binding = smpEncode ('G', groupRootPubKey (groupRootKey gk), memberId) + in all (\(MsgSignature KRMember sig) -> C.verify pk sig (binding <> signedBody)) signatures +verifySig _ _ _ = True +``` + +### H. Signature Enforcement + +**Must be signed** (reject if unsigned in relay groups with keys): +- `XGrpDel`, `XGrpInfo`, `XGrpPrefs`, `XGrpMemDel`, `XGrpMemRole`, `XGrpMemRestrict` + +**Not signed** (deniability — see §E): +- `XMsgNew` and all other content events + +**Conditionally signed:** +- `XGrpMemNew` — not always signed because members/subscribers can join via chat relays. Signed when owners/admins add members directly. Enforcement is context-dependent (checks sender role, not just event tag). + +**Channel posts** (`FwdChannel`): validate if signed, strip before forwarding. + +### I. Expose in UI + +Two display paths in CLI: + +**Path 1: Chat item history** (also used by mobile UI) +- `CIMeta.msgSigned :: Bool` — set during chat item creation +- Flow: `VerifiedMsg` → `isJust signedMsg_` → `RcvMessage.msgSigned` → `createNewRcvChatItem` → `createNewChatItem_` (INSERT with `msg_signed`) → SELECT reads `msg_signed` → `mkCIMeta` → View.hs +- Migration: `ALTER TABLE chat_items ADD COLUMN msg_signed` (in `chat_relays` migration) +- Note: `RcvMessage` is a goner (see pending refactor). In future, `msgSigned` flows from `VerifiedMsg` directly. + +**Path 2: Immediate CLI events** (ChatEvent/ChatResponse) +- Receive events: add `Bool` to ChatEvent constructors that correspond to signed events + - `CEvtMemberRole` — XGrpMemRole + - `CEvtMemberBlockedForAll` — XGrpMemRestrict + - `CEvtDeletedMemberUser` — XGrpMemDel (self) + - `CEvtDeletedMember` — XGrpMemDel (other) + - `CEvtGroupDeleted` — XGrpDel + - `CEvtGroupUpdated` — XGrpInfo / XGrpPrefs +- Send responses: add `Bool` to ChatResponse constructors for send-side + - `CRMembersRoleUser` — APIMembersRole + - `CRMembersBlockedForAllUser` — APIBlockMembersForAll + - `CRUserDeletedMembers` — APIRemoveMembers + - `CRGroupDeletedUser` — APIDeleteChat (group) + - `CRGroupUpdated` — APIUpdateGroupProfile +- Source: receive `msgSigned` from `RcvMessage`; send from `useRelays' gInfo` +- View.hs: append " (signed)" to event text when Bool is True + +**Correlation: `requiresSignature` events ↔ CLI display** + +| Event | Receive ChatEvent | Send ChatResponse | +|-------|-------------------|-------------------| +| XGrpDel | CEvtGroupDeleted | CRGroupDeletedUser | +| XGrpInfo | CEvtGroupUpdated | CRGroupUpdated | +| XGrpPrefs | CEvtGroupUpdated | CRGroupUpdated | +| XGrpMemDel | CEvtDeletedMember[User] | CRUserDeletedMembers | +| XGrpMemRole | CEvtMemberRole | CRMembersRoleUser | +| XGrpMemRestrict | CEvtMemberBlockedForAll | CRMembersBlockedForAllUser | + +### J. Pending Refactor: Remove RcvMessage + +`RcvMessage` carries redundant fields (`msgBody`, `authorMember` never read; `chatMsgEvent`, `sharedMsgId_` derivable from `verifiedMsg`). Plan: +1. Remove `RcvMessage` type +2. `NewRcvMessage` = `verifiedMsg` + `brokerTs` + `forwardedByMember` (drop `chatMsgEvent`) +3. `createNewRcvMessage` returns just `msgId` +4. Consumers extract what they need from `verifiedMsg` already in scope + +## Implementation Steps + +### Step 1: Foundation — Types + Encoding + Storage Schema ✅ + +- `ChatBinding = CBGroup` with `Encoding` instance (was `BindingTag`) +- `MsgSignatures { chatBinding :: ChatBinding, signatures :: NonEmpty MsgSignature }` +- `MsgSigning { bindingTag, bindingData, keyRef, privKey }` — generic signing context record +- `encodeBatchElement` in `Batch.hs` (moved from Protocol.hs) +- `requiresSignature :: CMEventTag e -> Bool` +- Migration: `ALTER TABLE messages ADD COLUMN msg_sigs BLOB` +- `SndMessage` gains `msgSignatures_ :: Maybe MsgSignatures` +- `createNewRcvMessage`: already accepts and stores `Maybe MsgSignatures` + +### Step 2: Sign on Send + Verify with Binding ✅ + +- `groupMsgSigning :: GroupInfo -> ChatMsgEvent e -> Maybe MsgSigning` in Internal.hs — takes GroupInfo, decides per-event +- `createSndMessages` takes `(ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent e)` triples +- `createNewSndMessage` accepts `Maybe MsgSigning`, signs inline, stores `msg_sigs` in same INSERT +- `batchMessages` encodes elements via `encodeBatchElement` (two parallel lists, encode once per message) +- `verifySig` in Subscriber.hs reconstructs binding prefix from `GroupInfo` + `memberId`, verifies with `C.verify` +- Removed dead code: `signGroupMessages`, `updateSndMsgSignatures`, `groupSignFn`, `signMsgBody` + +### Step 3: Store, Forward, Verify — End-to-End + +Steps 3-5 from the original plan are one flow. They must ship together because the e2e test — member A signs → relay stores → relay forwards → member B verifies — is the only meaningful test. + +#### Critical invariant: original bytes must be preserved + +JSON round-trip through aeson doesn't preserve key ordering. Currently `msg_body` is stored via `chatMsgToBody chatMsg` (re-encoded from parsed `ChatMessage`). These bytes may differ from what the sender signed. For signature verification after forwarding, the relay must store the **original** bytes in `msg_body`. + +When `elementP` parses a signed element (`/`), `A.match msgP` captures the exact JSON bytes as `signedBody` in `MsgSigData`. This is what must be stored as `msg_body` for signed messages. + +For unsigned messages, `chatMsgToBody chatMsg` is fine — no signature to preserve. + +#### E2E Flow + +``` +Member A Relay Member B +───────── ───── ──────── +sign(roster event) + ↓ +/ ──────────→ receive + parse (elementP) + msgSig_ has signedBody (exact bytes) + verify (withVerifiedSig) + store signedBody as msg_body ──(a) + store MsgSignatures as msg_sigs + ↓ + read msg_body + msg_sigs from DB ──(b) + >/ ──────→ receive + parse + elementP: > → / → json + msgSig_ has signedBody + verify (withVerifiedSig) + store signedBody + sigs ──(c) +``` + +#### (a) Relay receives signed message → stores with original bytes + +**Current call chain** (Subscriber.hs → Internal.hs → Store/Messages.hs): + +``` +processAChatMsg(line 920) — has msgSig_ (with signedBody), chatMsg + │ passes chatMsg only, msgSig_ not threaded + ▼ +processEvent(line 941) — has chatMsg only + │ body = chatMsgToBody chatMsg ← RE-ENCODES, loses original bytes + ▼ +saveGroupRcvMsg(Internal.hs:2218) — params: user, groupId, member, conn, msgMeta, body, chatMsg + │ no signature parameter + ▼ +createNewMessageAndRcvMsgDelivery(Store/Messages.hs:262) — no signature parameter + │ passes Nothing for msgSignatures_ + ▼ +createNewRcvMessage(Store/Messages.hs:294) — HAS Maybe MsgSignatures param, receives Nothing + │ + ▼ +INSERT INTO messages ... msg_body=RE-ENCODED, msg_sigs=Nothing +``` + +**Changes (6 functions):** + +1. **`processAChatMsg`** (Subscriber.hs:920→934): pass `msgSig_` to `processEvent` + - Current: `processEvent gInfo' m' chatMsg` + - New: `processEvent gInfo' m' chatMsg msgSig_` + +2. **`processEvent`** (Subscriber.hs:941): accept `Maybe MsgSigData`, use `signedBody` when signed + - Current sig: `GroupInfo -> GroupMember -> ChatMessage e -> CM (Maybe NewMessageDeliveryTask)` + - New sig: `GroupInfo -> GroupMember -> ChatMessage e -> Maybe MsgSigData -> CM (Maybe NewMessageDeliveryTask)` + - Current: `let body = chatMsgToBody chatMsg` + - New: `let body = maybe (chatMsgToBody chatMsg) signedBody msgSig_` + - Extract: `let sigs_ = signatures <$> msgSig_` (where `signatures :: MsgSigData -> MsgSignatures`) + - Pass both `body` and `sigs_` to `saveGroupRcvMsg` + +3. **`saveGroupRcvMsg`** (Internal.hs:2218): add `Maybe MsgSignatures` parameter + - Current sig: `User -> GroupId -> GroupMember -> Connection -> MsgMeta -> MsgBody -> ChatMessage e -> CM (...)` + - New sig: `User -> GroupId -> GroupMember -> Connection -> MsgMeta -> MsgBody -> ChatMessage e -> Maybe MsgSignatures -> CM (...)` + - Pass to `createNewMessageAndRcvMsgDelivery` + - 1 caller: Subscriber.hs:944 + +4. **`createNewMessageAndRcvMsgDelivery`** (Store/Messages.hs:262): add `Maybe MsgSignatures` parameter + - Current sig: `DB.Connection -> ConnOrGroupId -> NewRcvMessage e -> Maybe SharedMsgId -> RcvMsgDelivery -> Maybe GroupMemberId -> ExceptT StoreError IO RcvMessage` + - New: add `Maybe MsgSignatures` after `Maybe SharedMsgId` + - Current: passes `Nothing` to `createNewRcvMessage` + - New: passes the received `Maybe MsgSignatures` + - 2 callers: `saveGroupRcvMsg` (Internal.hs:2226) and `saveDirectRcvMSG` (Internal.hs:2215) + - `saveDirectRcvMSG` passes `Nothing` (direct messages not signed yet) + +5. **`createNewRcvMessage`** (Store/Messages.hs:294): no change — already has `Maybe MsgSignatures` param + +After change: +``` +INSERT INTO messages ... msg_body=ORIGINAL_BYTES, msg_sigs=MsgSignatures +``` + +#### (b) Relay reads delivery tasks → forwards with preserved signatures + +**Current call chain** (Store/Delivery.hs → Delivery.hs → Batch.hs): + +``` +getMsgDeliveryTask_(Store/Delivery.hs:130) + │ SQL: SELECT ... msg.msg_body ... ← no msg_sigs + │ Row type: ... ChatMessage 'Json ... ← parsed via FromField, RE-ENCODES on read + ▼ +MessageDeliveryTask { chatMessage :: ChatMessage 'Json } (Delivery.hs:128) + ▼ +batchDeliveryTasks1(Batch.hs:73) + │ destructures: MessageDeliveryTask {taskId, fwdSender, brokerTs, chatMessage} + ▼ +encodeFwdElement(Batch.hs:96) — takes GrpMsgForward -> ChatMessage 'Json -> ByteString + │ ">" <> smpEncode fwd <> chatMsgToBody chatMessage ← RE-ENCODES AGAIN + ▼ +Wire: > ← signature would fail +``` + +**Changes (5 functions/types):** + +6. **`MessageDeliveryTask`** (Delivery.hs:128): replace `chatMessage` field + - Current: `chatMessage :: ChatMessage 'Json` + - New: `msgBody :: ByteString, msgSignatures_ :: Maybe MsgSignatures` + - `chatMessage` used only in 2 places: `batchDeliveryTasks1` (Batch.hs:86) and `DJRelayRemoved` (Subscriber.hs:3375) — both just encode, no content inspection + +7. **`MessageDeliveryTaskRow`** (Store/Delivery.hs:128): change column type + - Current: `... ChatMessage 'Json, BoolInt` + - New: `... DB.Binary, Maybe MsgSignatures, BoolInt` + +8. **`getMsgDeliveryTask_`** (Store/Delivery.hs:130): add `msg.msg_sigs` to SELECT + - Current SQL: `msg.msg_body, t.message_from_channel` + - New SQL: `msg.msg_body, msg.msg_sigs, t.message_from_channel` + - `toTask`: destructure `DB.Binary` as raw bytes, `Maybe MsgSignatures` from `msg_sigs` + +9. **`encodeFwdElement`** (Batch.hs:96): take raw bytes + signatures + - Current sig: `GrpMsgForward -> ChatMessage 'Json -> ByteString` + - New sig: `GrpMsgForward -> Maybe MsgSignatures -> ByteString -> ByteString` + - Body: `">" <> smpEncode fwd <> encodeBatchElement sigs_ msgBody` + +10. **`batchDeliveryTasks1`** (Batch.hs:73): use new task fields + - Current: `MessageDeliveryTask {taskId, fwdSender, brokerTs = fwdBrokerTs, chatMessage} = task` + - New: `MessageDeliveryTask {taskId, fwdSender, brokerTs = fwdBrokerTs, msgBody, msgSignatures_} = task` + - Current: `msgBody = encodeFwdElement GrpMsgForward {fwdSender, fwdBrokerTs} chatMessage` + - New: `fwdBody = encodeFwdElement GrpMsgForward {fwdSender, fwdBrokerTs} msgSignatures_ msgBody` + +After change: +``` +Wire: >/ ← signature valid +``` + +#### (c) Member receives forwarded message → stores with original bytes + +**Current call chain** (Subscriber.hs → Internal.hs → Store/Messages.hs): + +``` +xGrpMsgForward(Subscriber.hs:3159) — has chatMsg + msgSig_ (with signedBody) + ▼ +processForwardedMsg(Subscriber.hs:3172) — closure, has chatMsg, msgSig_ in scope but not used + │ body = chatMsgToBody chatMsg ← RE-ENCODES + ▼ +saveGroupFwdRcvMsg(Internal.hs:2237) — no signature parameter + │ passes Nothing to createNewRcvMessage + ▼ +createNewRcvMessage(Store/Messages.hs:294) — receives Nothing + ▼ +INSERT INTO messages ... msg_body=RE-ENCODED, msg_sigs=Nothing +``` + +**Changes (3 functions):** + +11. **`processForwardedMsg`** (Subscriber.hs:3172): use `signedBody` when signed, pass sigs + - `msgSig_` is in scope from `xGrpMsgForward` closure + - Current: `let body = chatMsgToBody chatMsg` + - New: `let body = maybe (chatMsgToBody chatMsg) signedBody msgSig_` + - Extract: `let sigs_ = signatures <$> msgSig_` + - Pass `sigs_` to `saveGroupFwdRcvMsg` + +12. **`saveGroupFwdRcvMsg`** (Internal.hs:2237): add `Maybe MsgSignatures` parameter + - Current sig: `User -> GroupInfo -> GroupMember -> Maybe GroupMember -> MsgBody -> ChatMessage e -> UTCTime -> CM (Maybe RcvMessage)` + - New: add `Maybe MsgSignatures` after `UTCTime` + - Current: passes `Nothing` to `createNewRcvMessage` + - New: passes the received `Maybe MsgSignatures` + - 1 caller: Subscriber.hs:3175 + +13. **`createNewRcvMessage`**: no change — already has param + +After change: +``` +INSERT INTO messages ... msg_body=ORIGINAL_BYTES, msg_sigs=MsgSignatures +``` + +#### (d) DJRelayRemoved — binary encoding + +**Current** (Subscriber.hs:3371-3382): +```haskell +let MessageDeliveryTask {senderGMId, fwdSender, brokerTs = fwdBrokerTs, chatMessage} = task + fwdEvt = XGrpMsgForward GrpMsgForward {fwdSender, fwdBrokerTs} chatMessage ← JSON wrapping + cm = ChatMessage {chatVRange = vr, msgId = Nothing, chatMsgEvent = fwdEvt} + body = chatMsgToBody cm ← RE-ENCODES +createMsgDeliveryJob db gInfo jobScope (Just senderGMId) body +``` + +**Change** (1 function, same location): + +14. **DJRelayRemoved handler** (Subscriber.hs:3374): use binary encoding + ```haskell + let MessageDeliveryTask {senderGMId, fwdSender, brokerTs = fwdBrokerTs, msgBody, msgSignatures_} = task + fwd = GrpMsgForward {fwdSender, fwdBrokerTs} + body = encodeBinaryBatch [encodeFwdElement fwd msgSignatures_ msgBody] + createMsgDeliveryJob db gInfo jobScope (Just senderGMId) body + ``` + Receiver handles via `elementP` → same path as batched forwarding. + +#### (e) Enforcement — required signatures + +**Current**: `withVerifiedSig` (Subscriber.hs:3203) calls `verifySig` which returns `True` for `Nothing` (unsigned). All unsigned messages pass. + +**Change** (1 function): + +15. **`withVerifiedSig`** (Subscriber.hs:3203): add unsigned rejection + - Needs the event tag to check `requiresSignature` + - Current sig: `GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> Maybe MsgSigData -> UTCTime -> CM a -> CM (Maybe a)` + - New: add `CMEventTag e` parameter, or pass from caller + - Logic: if `isNothing msgSig_` AND `groupKeys gInfo` is `Just` AND `requiresSignature tag` → reject + +#### (f) Channel stripping + +**Current** (Subscriber.hs:3169): `FwdChannel -> processForwardedMsg Nothing` — skips `withVerifiedSig` entirely. + +**Change** (in `xGrpMsgForward`): + +16. For `FwdChannel`: validate signature if present (call `verifySig`), then call `processForwardedMsg` with `msgSig_` replaced by `Nothing` — strips signatures before storage. Channel posts are anonymous; storing the author's signature would leak identity. + +#### Summary: 16 function changes + +| # | Function | File | Change | +|---|----------|------|--------| +| 1 | `processAChatMsg` | Subscriber.hs:920 | Pass `msgSig_` to `processEvent` | +| 2 | `processEvent` | Subscriber.hs:941 | Accept `Maybe MsgSigData`, use `signedBody` as body when signed | +| 3 | `saveGroupRcvMsg` | Internal.hs:2218 | Add `Maybe MsgSignatures` parameter (1 caller) | +| 4 | `createNewMessageAndRcvMsgDelivery` | Store/Messages.hs:262 | Add `Maybe MsgSignatures` parameter (2 callers: group passes sigs, direct passes Nothing) | +| 5 | `createNewRcvMessage` | Store/Messages.hs:294 | No change — already has param | +| 6 | `MessageDeliveryTask` | Delivery.hs:128 | `msgBody :: ByteString` + `msgSignatures_` instead of `chatMessage` | +| 7 | `MessageDeliveryTaskRow` | Store/Delivery.hs:128 | `DB.Binary` + `Maybe MsgSignatures` instead of `ChatMessage 'Json` | +| 8 | `getMsgDeliveryTask_` | Store/Delivery.hs:130 | Add `msg.msg_sigs` to SELECT, read `msg_body` as raw bytes | +| 9 | `encodeFwdElement` | Batch.hs:96 | `GrpMsgForward -> Maybe MsgSignatures -> ByteString -> ByteString` | +| 10 | `batchDeliveryTasks1` | Batch.hs:73 | Use task's `msgBody` + `msgSignatures_` | +| 11 | `processForwardedMsg` | Subscriber.hs:3172 | Use `signedBody` as body when signed, pass sigs | +| 12 | `saveGroupFwdRcvMsg` | Internal.hs:2237 | Add `Maybe MsgSignatures` parameter (1 caller) | +| 13 | `createNewRcvMessage` | Store/Messages.hs:294 | No change — already has param | +| 14 | DJRelayRemoved handler | Subscriber.hs:3374 | Binary encoding with `encodeFwdElement` | +| 15 | `withVerifiedSig` | Subscriber.hs:3203 | Reject unsigned messages when `requiresSignature` in relay group with keys | +| 16 | `xGrpMsgForward` FwdChannel | Subscriber.hs:3169 | Validate sig if present, strip before storage | + +#### Test + +E2E test in relay group with keys: +1. Member A sends `XGrpMemRole` (requires signature) → signed in DB on A +2. Relay receives → verifies → stores `signedBody` as `msg_body` + `MsgSignatures` as `msg_sigs` +3. Relay reads `msg_body` + `msg_sigs` from DB → `>/` on wire +4. Member B receives → `elementP` parses >→/→json → `signedBody` has original bytes → verifies → stores +5. Unsigned `XGrpDel` from member without keys → rejected by enforcement +6. Channel post with signature → signature stripped before storage + +## Files + +| File | Step | Changes | +|------|------|---------| +| `Protocol.hs` | 1,2 | `ChatBinding`, `MsgSignatures` encoding, `MsgSigning`, `requiresSignature` | +| `Messages.hs` | 1 | `SndMessage` + `msgSignatures_` | +| `Store/Messages.hs` | 1,2,3 | `createNewSndMessage` signs + stores; `createNewRcvMessage` already has sig param; `createNewMessageAndRcvMsgDelivery` add sig param | +| Migration | 1 | `msg_sigs` column | +| `Internal.hs` | 2,3 | `groupMsgSigning`; `createSndMessages` per-event signing; `saveGroupRcvMsg` + `saveGroupFwdRcvMsg` add sig params | +| `Batch.hs` | 2,3 | `encodeBatchElement` in `batchMessages`; `encodeFwdElement` takes sigs + raw bytes; `batchDeliveryTasks1` uses raw task fields | +| `Subscriber.hs` | 2,3 | `verifySig` with binding; `processAChatMsg`→`processEvent` thread `msgSig_`; `processForwardedMsg` use `signedBody`; `withVerifiedSig` enforcement; channel strip; DJRelayRemoved binary | +| `Delivery.hs` | 3 | `MessageDeliveryTask`: `msgBody` + `msgSignatures_` instead of `chatMessage` | +| `Store/Delivery.hs` | 3 | `MessageDeliveryTaskRow` + `getMsgDeliveryTask_`: read `msg_sigs` + raw `msg_body` | diff --git a/plans/chat-relays-mvp-launch-plan.md b/plans/chat-relays-mvp-launch-plan.md new file mode 100644 index 0000000000..64af3c7d42 --- /dev/null +++ b/plans/chat-relays-mvp-launch-plan.md @@ -0,0 +1,293 @@ +# Chat Relays MVP — Launch Plan + +## Contents +- [Executive Summary](#executive-summary) +- [What's Done](#whats-done) +- [What's Remaining](#whats-remaining): Protocol & Crypto | Relay Protocol | Member Connection | UI | Testing | Polish | Directory +- [Dependency Summary](#dependency-summary) +- [Risk Register](#risk-register) +- [Decisions Made](#decisions-made) +- [Post-MVP Backlog](#post-mvp-backlog) + +--- + +## Executive Summary + +Chat Relays enable large public channels where messages flow owner → relay → members, replacing N-to-N connections. This plan covers what remains for MVP launch. + +**Current state**: Core backend ~75% done (delivery system, forwarding, deduplication, relay invitation/acceptance, group creation with relays all working). UI ~15%. Key remaining work: member key signatures, relay identity validation, forward envelope protocol, UI on both platforms. + +**MVP delivers**: Owners create channels with preset relays. Relays validate and serve groups. Members join via links, receive relay-forwarded messages signed by owners. UI differentiates channels from groups. + +**Out of scope**: Relay removal/recovery, periodic relay health monitoring, relay-to-relay sync, history navigation, e2e encryption in support chats, multi-owner support, reaction/comment batching. See [Post-MVP](#post-mvp-backlog). + +--- + +## What's Done + +- Single-roundtrip group creation with relays (`APINewPublicGroup` → `prepareConnectionLink` → `createConnectionForLink` — Agent API complete) +- Relay invitation/acceptance protocol (`XGrpRelayInv`, `XGrpRelayAcpt`) and relay request worker +- Async delivery task/job system with cursor-paginated member delivery +- `FwdChannel` / `FwdMember` forwarding modes, `ShowGroupAsSender` through full pipeline +- Message deduplication on member side +- Binary batch encoding (`=` prefix) in `Messages/Batch.hs` and `Protocol.hs` +- DB schema: `chat_relays`, `group_relays`, `group_members.relay_link`, key columns on `groups`/`group_members` +- Preset relay configuration framework (3 placeholder relays in `Presets.hs`) +- `CIChannelRcv` chat item direction in backend +- Observer role UI already works on both platforms (compose bar hidden, reactions only) + +## What's Remaining + +Organized by architecture layer, not work streams. Items within each section are roughly ordered by dependency. + +--- + +### 1. Protocol & Cryptography + +#### 1.1 Binary Forward Envelope (`F` prefix) +New top-level binary format replacing `XGrpMsgForward` for relay groups. Wraps original sender bytes verbatim — preserves signatures through relay forwarding without re-encoding. + +Format: `F` (see member-keys-plan.md §8). + +Old groups keep `XGrpMsgForward` (JSON). New relay groups use `F` envelope. Parser accepts both. + +**Files**: `Protocol.hs` (parse/encode), `Batch.hs` (batching), `Subscriber.hs` (forwarding handler replacement) + +#### 1.2 Key Generation & Storage +Generate Ed25519 key pairs on group creation/join. Populate existing DB columns: `root_priv_key`/`root_pub_key` on `groups`, `member_priv_key` on `groups`, `member_pub_key` on `group_members`. + +Consider adding to current `M20260222_chat_relays` migration (unreleased) rather than creating a new one. + +**Files**: `Store/Groups.hs`, `Store/Profiles.hs`, `Commands.hs` (creation flow) + +#### 1.3 Message Signing +Sign roster-modifying messages (`XGrpRelayInv`, `XGrpMemNew`, `XGrpMemRole`, `XGrpMemDel`, `XGrpInfo`, `XGrpPrefs`, `XGrpDel`) with owner's member key. + +**Files**: `Internal.hs` (signChatMessage), `Commands.hs` (sendGroupMessage integration) + +#### 1.4 Signature Verification +Verify signatures on received roster messages. Hard fail for missing/invalid signatures in new-version groups. + +**Files**: `Internal.hs` (verifyChatMessage), `Subscriber.hs` (reception) + +#### 1.5 OwnerAuth Chain +Owner authorization signed by root key, stored in group link's `UserContactData.owners`. Members verify owner identity via chain. Type exists; integration TODO. + +**Files**: `Protocol.hs`, `Commands.hs`, `Subscriber.hs` + +#### 1.6 Version Gating +Chat relays is a new feature — relay groups only joinable by clients of the new version. Add `chatRelaysVersion` to version range. No backward compat needed for relay groups themselves (they don't exist in older versions). + +**Files**: `Types.hs` (version constant), `Commands.hs` (gating) + +--- + +### 2. Relay Protocol + +#### 2.1 Relay Address Link Data +On relay address creation, set link data: relay identity (profile, certificate, relay identity key). Members validate this when connecting. + +**Files**: `Commands.hs` (relay address creation), `Protocol.hs` (relay link data structure) + +#### 2.2 Group Profile Validation by Relay +Before accepting to serve group, relay validates group profile, verifies owner's signature, and checks `shared_group_id` in immutable link data (prevents redirect to wrong group). + +**Files**: `Subscriber.hs` (`runRelayRequestWorker` — stub exists, validation logic TODO) + +#### 2.3 Relay Link Data on Acceptance +When accepting, relay sets: relay identity, relay key for group, group ID in immutable part of relay link data. + +**Files**: `Subscriber.hs` (relay link creation) + +#### 2.4 Relay Key/Identity Validation by Members +When member connects to relay, validate relay link data (identity, key, group ID) matches group link data. This is part of the same signature/identity verification work as §1.4. + +**Files**: `Commands.hs` (`connectToRelay`), `Subscriber.hs` + +#### 2.5 Test Chat Relay Command +`APITestChatRelay` / `TestChatRelay` — channel owners need to verify relay connectivity before creating channels. + +**Files**: `Commands.hs` (new command) + +#### 2.6 Real Relay Addresses in Presets +Replace placeholder URLs in `simplexChatRelays`. Depends on relay server deployment. + +**Files**: `Operators/Presets.hs` + +#### 2.7 Channel-Only Behavior Enforcement +In channel groups (`useRelays = True`), the API supports sending both as channel (`asGroup=True`) and as member. For MVP, UI always passes `asGroup=True`. Backend does not enforce — owners retain the API option to send as member for future use. Non-owner/non-admin members can only send reactions (observer role enforced by existing role system). + +**Files**: UI-only enforcement for MVP (both platforms pass `asGroup=True` in compose) + +--- + +### 3. Member Connection Flow + +#### 3.1 Support `/c` API for Relay Groups +Automate `APIPrepareGroup` → `APIConnectPreparedGroup` flow when using `/c` command with a relay group link. Currently requires manual two-step call. + +**Files**: `Commands.hs` (`connectWithPlan`) + +#### 3.2 Relay Connection State Response Type +New response type/events showing per-relay connection state (connecting, connected, temporary error, permanent error). Needed for both member join and owner creation UX. + +**Files**: `Controller.hs` (new ChatResponse variants), `Commands.hs` (emit events) + +#### 3.3 Member Count for Channels +Existing member count display uses loaded member list — won't work for channels, where members only have records for owners and relays. Relays must communicate real member counts (excluding relays themselves) to members and owners. Needs protocol extension for relay → member count communication. + +**Files**: `Protocol.hs` (new event or extension), `Subscriber.hs` (relay reporting), UI (display) + +--- + +### 4. UI — Both Platforms (iOS + Android/Desktop) + +All UI items must be completed on both platforms for MVP. + +#### 4.1 Channel Visual Distinction +Different icon/badge for channels in chat list. "Channel" label. Key off `useRelays` flag in `GroupInfo`. + +No backend dependency — can start immediately. + +#### 4.2 "Message from Channel" Display +`CIChannelRcv` direction NOT yet handled in either platform's UI. Must add to message rendering pipeline. `showGroupAsSender` message rendering. + +Backend complete. No backend dependency. + +#### 4.3 Channel Creation Flow +"Create Channel" button in new chat menu → name/description → relay selection → creation with relay status feedback (invited → accepted → active). Backend `APINewPublicGroup` exists. + +Depends on: §3.2 (relay connection state type) + +#### 4.4 Relay Management (User Settings) +List of configured relays; add/remove/edit; test connectivity. Follow existing SMP server management pattern. + +Depends on: §2.5 (`APITestChatRelay`) + +#### 4.5 Show Relays in Channel Info +Relay list with status and identity in channel info screen. + +#### 4.6 Relay Connection State During Join +Progress feedback when joining: "Connecting to relays..." → per-relay status → "Connected". + +Depends on: §3.2 (relay connection state type) + +#### 4.7 Owner Posting UI +Compose mode always sends as channel (`asGroup=True`). No toggle for MVP. + +#### 4.8 API Type Updates +- **iOS**: Add `apiNewPublicGroup` to `ChatCommand` enum; add `ChatRelay`, `RelayStatus`, `GroupRelay`, `CIChannelRcv` types +- **Android**: Add corresponding types to Kotlin model layer +- Both: relay connection state event types + +--- + +### 5. Testing + +- Delivery loop restored after restart +- Delivery in support scopes inside channels +- Connect plans for relay groups +- Cancellation on failure to create relay group +- Async retry connecting to relay (members) +- Relay privileges +- Binary forward envelope encode/decode round-trips +- Message signing and verification flow +- Relay signature validation in invitation flow +- Backward compat: old clients cannot join relay groups (version gated) + +--- + +### 6. Polish & Edge Cases + +- Create missing service chat items ("relays updated" for owner, "group invite accepted" for relay) +- Disable link data output in CLI (`View.hs` — currently enabled for manual testing, cleanup) +- When deleting chat relay from user config, check `group_relays` references and mark as deleted instead +- Single file description for all recipients (performance) + +--- + +### 7. Directory Service Verification + +Directory service currently has no channel/relay awareness — it only lists regular groups. Needs verification how channels should appear in directory and what integration work is required. Some adaptation may be needed. + +--- + +## Dependency Summary + +``` +Can start immediately (no dependencies): + §1.2 Key Storage, §1.3-1.5 Signing/Verification, §1.6 Version Gating + §2.1 Relay Address Data, §2.7 Channel Enforcement (UI-only) + §4.1 Channel Visual Distinction, §4.2 "Message from Channel" Display + +Needs §1.3-1.5 (signing): + §2.2 Group Profile Validation, §2.3 Relay Link Data + +Needs §2.1+2.3: + §2.4 Relay Key Validation by Members + +Needs §3.2 (relay state type): + §4.3 Channel Creation UI, §4.6 Join State UI + +Needs §2.5 (test command): + §4.4 Relay Management UI + +Late phase: + §5 Testing (needs most backend complete) + §2.6 Real Relay Addresses (needs server deployment) + §7 Directory Verification +``` + +**Critical path**: §1.1 (Forward Envelope) + §1.2-1.5 (Keys/Signing) → §2.2-2.3 (Relay Validation) → §5 (Testing) → Launch + +**Early UI wins**: §4.1, §4.2 can start in Phase 1. + +--- + +## Risk Register + +| Risk | Impact | Mitigation | +|------|--------|------------| +| Forward envelope (`F`) version mismatch relay↔member | High | Version gating — relay groups require new version on all participants | +| Relay server instability under load | High | Load test early; multi-relay redundancy | +| UI on 2 platforms takes longer than expected | Medium | Both required for MVP; start UI early (§4.1, §4.2 have no backend deps) | +| Member count protocol extension complexity | Medium | Can ship without count initially; add in fast-follow | +| Stale relay "Active" status (no health monitoring) | Low | Multi-relay redundancy; manual `APITestChatRelay`; monitoring post-MVP | + +--- + +## Decisions Made + +- **Single-owner channels**: Allowed without warning (sender identity is clear for "messages from channel"). Single-owner is the main MVP case; "from channel" UX is valuable regardless. Revisit with multi-owner support. +- **Channel-only enforcement**: UI-only for MVP (`asGroup=True` always passed). Backend retains API flexibility for future "send as member" option. +- **Default member role**: Observer by default for channels. No additional owner→relay communication of role/rejection rules for MVP. +- **Contact connection refactoring**: Deferred to post-MVP. Current flow works. +- **Member rejection by relay**: Deferred. MemberId clash unlikely; rejection rules postponed. +- **Relay profiles**: Consider for MVP vs post-MVP. Members and owners see relay profiles in group already; linking to single per-config profile is nice-to-have. +- **Chat relay user filtering**: Post-MVP. Relay user will be visible in client for now. + +--- + +## Post-MVP Backlog + +1. Relay removal and group recovery — owner removes relay, members reconnect via updated link +2. Periodic relay health checks — relay verifies link presence in group link data +3. Relay-to-relay synchronization +4. Managing relays in existing group — add/remove relays post-creation +5. Default member role and rejection rules communication owner→relay +6. Member rejection by relay (duplicate member ID, rule violations) +7. Contact connection flow refactoring (`connectViaContact` simplification) +8. Deduplication highlighting — show differences between relay-forwarded messages +9. History navigation — request older messages from channel +10. E2E encryption in admin/support chats +11. Reaction/comment count batching +12. Priority connections — separate queues for messages vs admin requests +13. Member profile delivery optimization +14. Private relays with password +15. Channel content moderation +16. Indefinite file storage for relays +17. Message revocation from history +18. Channel discovery/directory integration (verify and extend) +19. Advanced forwarding envelope — include channel link in forwarded message metadata for distribution +20. Relay profiles linked to single per-config record +21. Chat relay user filtering/separate UI diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 7b44a66d98..3b28064790 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -705,7 +705,7 @@ data ChatResponse | CRUserContactLinkUpdated {user :: User, contactLink :: UserContactLink} | CRContactRequestRejected {user :: User, contactRequest :: UserContactRequest, contact_ :: Maybe Contact} | CRUserAcceptedGroupSent {user :: User, groupInfo :: GroupInfo, hostContact :: Maybe Contact} - | CRUserDeletedMembers {user :: User, groupInfo :: GroupInfo, members :: [GroupMember], withMessages :: Bool} + | CRUserDeletedMembers {user :: User, groupInfo :: GroupInfo, members :: [GroupMember], withMessages :: Bool, msgSigned :: Bool} | CRGroupsList {user :: User, groups :: [GroupInfo]} | CRSentGroupInvitation {user :: User, groupInfo :: GroupInfo, contact :: Contact, member :: GroupMember} | CRFileTransferStatus User (FileTransfer, [Integer]) -- TODO refactor this type to FileTransferStatus @@ -734,7 +734,7 @@ data ChatResponse | CRAcceptingContactRequest {user :: User, contact :: Contact} | CRContactAlreadyExists {user :: User, contact :: Contact} | CRLeftMemberUser {user :: User, groupInfo :: GroupInfo} - | CRGroupDeletedUser {user :: User, groupInfo :: GroupInfo} + | CRGroupDeletedUser {user :: User, groupInfo :: GroupInfo, msgSigned :: Bool} | CRForwardPlan {user :: User, itemsCount :: Int, chatItemIds :: [ChatItemId], forwardConfirmation :: Maybe ForwardConfirmation} | CRRcvFileAccepted {user :: User, chatItem :: AChatItem} -- TODO add chatItem :: AChatItem @@ -754,9 +754,9 @@ data ChatResponse | CRMemberAccepted {user :: User, groupInfo :: GroupInfo, member :: GroupMember} | CRMemberSupportChatRead {user :: User, groupInfo :: GroupInfo, member :: GroupMember} | CRMemberSupportChatDeleted {user :: User, groupInfo :: GroupInfo, member :: GroupMember} - | CRMembersRoleUser {user :: User, groupInfo :: GroupInfo, members :: [GroupMember], toRole :: GroupMemberRole} - | CRMembersBlockedForAllUser {user :: User, groupInfo :: GroupInfo, members :: [GroupMember], blocked :: Bool} - | CRGroupUpdated {user :: User, fromGroup :: GroupInfo, toGroup :: GroupInfo, member_ :: Maybe GroupMember} + | CRMembersRoleUser {user :: User, groupInfo :: GroupInfo, members :: [GroupMember], toRole :: GroupMemberRole, msgSigned :: Bool} + | CRMembersBlockedForAllUser {user :: User, groupInfo :: GroupInfo, members :: [GroupMember], blocked :: Bool, msgSigned :: Bool} + | CRGroupUpdated {user :: User, fromGroup :: GroupInfo, toGroup :: GroupInfo, member_ :: Maybe GroupMember, msgSigned :: Bool} | CRGroupProfile {user :: User, groupInfo :: GroupInfo} | CRGroupDescription {user :: User, groupInfo :: GroupInfo} -- only used in CLI | CRGroupLinkCreated {user :: User, groupInfo :: GroupInfo, groupLink :: GroupLink} @@ -858,17 +858,17 @@ data ChatEvent | CEvtJoinedGroupMember {user :: User, groupInfo :: GroupInfo, member :: GroupMember} -- there is the same command response | CEvtJoinedGroupMemberConnecting {user :: User, groupInfo :: GroupInfo, hostMember :: GroupMember, member :: GroupMember} | CEvtMemberAcceptedByOther {user :: User, groupInfo :: GroupInfo, acceptingMember :: GroupMember, member :: GroupMember} - | CEvtMemberRole {user :: User, groupInfo :: GroupInfo, byMember :: GroupMember, member :: GroupMember, fromRole :: GroupMemberRole, toRole :: GroupMemberRole} - | CEvtMemberBlockedForAll {user :: User, groupInfo :: GroupInfo, byMember :: GroupMember, member :: GroupMember, blocked :: Bool} + | CEvtMemberRole {user :: User, groupInfo :: GroupInfo, byMember :: GroupMember, member :: GroupMember, fromRole :: GroupMemberRole, toRole :: GroupMemberRole, msgSigned :: Bool} + | CEvtMemberBlockedForAll {user :: User, groupInfo :: GroupInfo, byMember :: GroupMember, member :: GroupMember, blocked :: Bool, msgSigned :: Bool} | CEvtConnectedToGroupMember {user :: User, groupInfo :: GroupInfo, member :: GroupMember, memberContact :: Maybe Contact} - | CEvtDeletedMember {user :: User, groupInfo :: GroupInfo, byMember :: GroupMember, deletedMember :: GroupMember, withMessages :: Bool} - | CEvtDeletedMemberUser {user :: User, groupInfo :: GroupInfo, member :: GroupMember, withMessages :: Bool} + | CEvtDeletedMember {user :: User, groupInfo :: GroupInfo, byMember :: GroupMember, deletedMember :: GroupMember, withMessages :: Bool, msgSigned :: Bool} + | CEvtDeletedMemberUser {user :: User, groupInfo :: GroupInfo, member :: GroupMember, withMessages :: Bool, msgSigned :: Bool} | CEvtLeftMember {user :: User, groupInfo :: GroupInfo, member :: GroupMember} | CEvtUnknownMemberCreated {user :: User, groupInfo :: GroupInfo, forwardedByMember :: GroupMember, member :: GroupMember} | CEvtUnknownMemberBlocked {user :: User, groupInfo :: GroupInfo, blockedByMember :: GroupMember, member :: GroupMember} | CEvtUnknownMemberAnnounced {user :: User, groupInfo :: GroupInfo, announcingMember :: GroupMember, unknownMember :: GroupMember, announcedMember :: GroupMember} - | CEvtGroupDeleted {user :: User, groupInfo :: GroupInfo, member :: GroupMember} - | CEvtGroupUpdated {user :: User, fromGroup :: GroupInfo, toGroup :: GroupInfo, member_ :: Maybe GroupMember} -- there is the same command response + | CEvtGroupDeleted {user :: User, groupInfo :: GroupInfo, member :: GroupMember, msgSigned :: Bool} + | CEvtGroupUpdated {user :: User, fromGroup :: GroupInfo, toGroup :: GroupInfo, member_ :: Maybe GroupMember, msgSigned :: Bool} -- there is the same command response | CEvtAcceptingGroupJoinRequestMember {user :: User, groupInfo :: GroupInfo, member :: GroupMember} | CEvtNoMemberContactCreating {user :: User, groupInfo :: GroupInfo, member :: GroupMember} -- only used in CLI | CEvtNewMemberContactReceivedInv {user :: User, contact :: Contact, groupInfo :: GroupInfo, member :: GroupMember} diff --git a/src/Simplex/Chat/Delivery.hs b/src/Simplex/Chat/Delivery.hs index 37d6d4ba09..822ee5efb9 100644 --- a/src/Simplex/Chat/Delivery.hs +++ b/src/Simplex/Chat/Delivery.hs @@ -125,20 +125,14 @@ data NewMessageDeliveryTask = NewMessageDeliveryTask } deriving (Show) -data FwdSender - = FwdMember MemberId ContactName - | FwdChannel - deriving (Show) - data MessageDeliveryTask = MessageDeliveryTask { taskId :: Int64, jobScope :: DeliveryJobScope, senderGMId :: GroupMemberId, fwdSender :: FwdSender, brokerTs :: UTCTime, - chatMessage :: ChatMessage 'Json + verifiedMsg :: VerifiedMsg 'Json } - deriving (Show) deliveryTaskId :: MessageDeliveryTask -> Int64 deliveryTaskId = taskId diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 3a22a9a69a..7487828f08 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -1200,7 +1200,10 @@ processChatCommand vr nm = \case deleteCIFiles user filesInfo (members, recipients) <- getRecipients gInfo let doSendDel = memberActive membership && isOwner - when doSendDel . void $ sendGroupMessage' user gInfo recipients XGrpDel + msgSigned <- + if doSendDel + then isJust . signedMsg_ <$> sendGroupMessage' user gInfo recipients XGrpDel + else pure False deleteGroupLinkIfExists user gInfo deleteMembersConnections' user members doSendDel updateCIGroupInvitationStatus user gInfo CIGISRejected `catchAllErrors` \_ -> pure () @@ -1208,7 +1211,7 @@ processChatCommand vr nm = \case withFastStore' $ \db -> cleanupHostGroupLinkConn db user gInfo withFastStore' $ \db -> deleteGroupMembers db user gInfo withFastStore' $ \db -> deleteGroup db user gInfo - pure $ CRGroupDeletedUser user gInfo + pure $ CRGroupDeletedUser user gInfo msgSigned where getRecipients gInfo | useRelays' gInfo = do @@ -2293,8 +2296,8 @@ processChatCommand vr nm = \case addContactConn ct ctConns = case contactSendConn_ ct of Right conn | directOrUsed ct -> (ct, conn) : ctConns _ -> ctConns - ctSndEvent :: (Contact, Connection) -> (ConnOrGroupId, ChatMsgEvent 'Json) - ctSndEvent (_, Connection {connId}) = (ConnectionId connId, XMsgNew $ MCSimple (extMsgContent mc Nothing)) + ctSndEvent :: (Contact, Connection) -> (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent 'Json) + ctSndEvent (_, Connection {connId}) = (ConnectionId connId, Nothing, XMsgNew $ MCSimple (extMsgContent mc Nothing)) ctMsgReq :: (Contact, Connection) -> SndMessage -> ChatMsgReq ctMsgReq (_, conn) SndMessage {msgId, msgBody} = (conn, MsgFlags {notification = hasNotification XMsgNew_}, (vrValue msgBody, [msgId])) combineResults :: (Contact, Connection) -> Either ChatError SndMessage -> Either ChatError ([Int64], PQEncryption) -> Either ChatError (Contact, SndMessage) @@ -2529,11 +2532,11 @@ processChatCommand vr nm = \case when anyPending $ throwCmdError "can't change role of members pending approval" assertUserGroupRole gInfo $ maximum ([GRAdmin, maxRole, newRole] :: [GroupMemberRole]) (errs1, changed1) <- changeRoleInvitedMems user gInfo invitedMems - (errs2, changed2, acis) <- changeRoleCurrentMems user g currentMems + (errs2, changed2, acis, msgSigned) <- changeRoleCurrentMems user g currentMems unless (null acis) $ toView $ CEvtNewChatItems user acis let errs = errs1 <> errs2 unless (null errs) $ toView $ CEvtChatErrors errs - pure $ CRMembersRoleUser {user, groupInfo = gInfo, members = changed1 <> changed2, toRole = newRole} -- same order is not guaranteed + pure $ CRMembersRoleUser {user, groupInfo = gInfo, members = changed1 <> changed2, toRole = newRole, msgSigned} -- same order is not guaranteed where selfSelected GroupInfo {membership} = elem (groupMemberId' membership) memberIds selectMembers :: [GroupMember] -> ([GroupMember], [GroupMember], [GroupMember], GroupMemberRole, Bool, Bool) @@ -2564,19 +2567,20 @@ processChatCommand vr nm = \case withFastStore' $ \db -> updateGroupMemberRole db user m newRole pure (m :: GroupMember) {memberRole = newRole} _ -> throwChatError $ CEGroupCantResendInvitation gInfo cName - changeRoleCurrentMems :: User -> Group -> [GroupMember] -> CM ([ChatError], [GroupMember], [AChatItem]) + changeRoleCurrentMems :: User -> Group -> [GroupMember] -> CM ([ChatError], [GroupMember], [AChatItem], Bool) changeRoleCurrentMems user (Group gInfo members) memsToChange = case L.nonEmpty memsToChange of - Nothing -> pure ([], [], []) + Nothing -> pure ([], [], [], False) Just memsToChange' -> do let events = L.map (\GroupMember {memberId} -> XGrpMemRole memberId newRole) memsToChange' recipients = filter memberCurrent members (msgs_, _gsr) <- sendGroupMessages user gInfo Nothing recipients events - let itemsData = zipWith (fmap . sndItemData) memsToChange (L.toList msgs_) + let signed = any (either (const False) (isJust . signedMsg_)) msgs_ + itemsData = zipWith (fmap . sndItemData) memsToChange (L.toList msgs_) 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_ - pure (errs, changed, acis) + pure (errs, changed, acis, signed) where sndItemData :: GroupMember -> SndMessage -> NewSndChatItemData c sndItemData GroupMember {groupMemberId, memberProfile} msg = @@ -2618,7 +2622,8 @@ processChatCommand vr nm = \case events = L.map (\GroupMember {memberId} -> XGrpMemRestrict memberId MemberRestrictions {restriction = mrs}) blockMems' recipients = filter memberCurrent remainingMems (msgs_, _gsr) <- sendGroupMessages_ user gInfo recipients events - let itemsData = zipWith (fmap . sndItemData) blockMems (L.toList msgs_) + let msgSigned = any (either (const False) (isJust . signedMsg_)) msgs_ + itemsData = zipWith (fmap . sndItemData) blockMems (L.toList msgs_) 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_ @@ -2627,7 +2632,7 @@ processChatCommand vr nm = \case unless (null errs) $ toView $ CEvtChatErrors errs -- TODO not batched - requires agent batch api forM_ blocked $ \m -> toggleNtf m (not blockFlag) - pure CRMembersBlockedForAllUser {user, groupInfo = gInfo, members = blocked, blocked = blockFlag} + pure CRMembersBlockedForAllUser {user, groupInfo = gInfo, members = blocked, blocked = blockFlag, msgSigned} where sndItemData :: GroupMember -> SndMessage -> NewSndChatItemData c sndItemData GroupMember {groupMemberId, memberProfile} msg = @@ -2646,22 +2651,23 @@ processChatCommand vr nm = \case assertUserGroupRole gInfo $ max GRAdmin maxRole (errs1, deleted1) <- deleteInvitedMems user invitedMems let recipients = filter memberCurrent members - (errs2, deleted2, acis2) <- deleteMemsSend user gInfo Nothing recipients currentMems - (errs3, deleted3, acis3) <- - foldM (\acc m -> deletePendingMember acc user gInfo [m] m) ([], [], []) pendingApprvMems + (errs2, deleted2, acis2, signed2) <- deleteMemsSend user gInfo Nothing recipients currentMems + (errs3, deleted3, acis3, signed3) <- + foldM (\acc m -> deletePendingMember acc user gInfo [m] m) ([], [], [], False) pendingApprvMems let moderators = filter (\GroupMember {memberRole} -> memberRole >= GRModerator) members - (errs4, deleted4, acis4) <- - foldM (\acc m -> deletePendingMember acc user gInfo (m : moderators) m) ([], [], []) pendingRvwMems + (errs4, deleted4, acis4, signed4) <- + foldM (\acc m -> deletePendingMember acc user gInfo (m : moderators) m) ([], [], [], False) pendingRvwMems let acis = acis2 <> acis3 <> acis4 errs = errs1 <> errs2 <> errs3 <> errs4 deleted = deleted1 <> deleted2 <> deleted3 <> deleted4 + msgSigned = signed2 || signed3 || signed4 -- Read group info with updated membersRequireAttention gInfo' <- withFastStore $ \db -> getGroupInfo db vr user groupId let acis' = map (updateACIGroupInfo gInfo') acis unless (null acis') $ toView $ CEvtNewChatItems user acis' unless (null errs) $ toView $ CEvtChatErrors errs when withMessages $ deleteMessages user gInfo' deleted - pure $ CRUserDeletedMembers user gInfo' deleted withMessages -- same order is not guaranteed + pure $ CRUserDeletedMembers user gInfo' deleted withMessages msgSigned -- same order is not guaranteed where selectMembers :: S.Set GroupMemberId -> [GroupMember] -> (Int, [GroupMember], [GroupMember], [GroupMember], [GroupMember], GroupMemberRole, Bool) selectMembers gmIds = foldl' addMember (0, [], [], [], [], GRObserver, False) @@ -2685,19 +2691,20 @@ processChatCommand vr nm = \case delMember db m = do deleteGroupMember db user m pure m {memberStatus = GSMemRemoved} - deletePendingMember :: ([ChatError], [GroupMember], [AChatItem]) -> User -> GroupInfo -> [GroupMember] -> GroupMember -> CM ([ChatError], [GroupMember], [AChatItem]) - deletePendingMember (accErrs, accDeleted, accACIs) user gInfo recipients m = do + deletePendingMember :: ([ChatError], [GroupMember], [AChatItem], Bool) -> User -> GroupInfo -> [GroupMember] -> GroupMember -> CM ([ChatError], [GroupMember], [AChatItem], Bool) + deletePendingMember (accErrs, accDeleted, accACIs, accSigned) user gInfo recipients m = do (m', scopeInfo) <- mkMemberSupportChatInfo m - (errs, deleted, acis) <- deleteMemsSend user gInfo (Just scopeInfo) recipients [m'] - pure (errs <> accErrs, deleted <> accDeleted, acis <> accACIs) - deleteMemsSend :: User -> GroupInfo -> Maybe GroupChatScopeInfo -> [GroupMember] -> [GroupMember] -> CM ([ChatError], [GroupMember], [AChatItem]) + (errs, deleted, acis, signed) <- deleteMemsSend user gInfo (Just scopeInfo) recipients [m'] + pure (errs <> accErrs, deleted <> accDeleted, acis <> accACIs, accSigned || signed) + deleteMemsSend :: User -> GroupInfo -> Maybe GroupChatScopeInfo -> [GroupMember] -> [GroupMember] -> CM ([ChatError], [GroupMember], [AChatItem], Bool) deleteMemsSend user gInfo chatScopeInfo recipients memsToDelete = case L.nonEmpty memsToDelete of - Nothing -> pure ([], [], []) + Nothing -> pure ([], [], [], False) Just memsToDelete' -> do let chatScope = toChatScope <$> chatScopeInfo events = L.map (\GroupMember {memberId} -> XGrpMemDel memberId withMessages) memsToDelete' (msgs_, _gsr) <- sendGroupMessages user gInfo chatScope recipients events - let itemsData_ = zipWith (fmap . sndItemData) memsToDelete (L.toList msgs_) + let signed = any (either (const False) (isJust . signedMsg_)) msgs_ + itemsData_ = zipWith (fmap . sndItemData) memsToDelete (L.toList msgs_) skipUnwantedItem = \case Right Nothing -> Nothing Right (Just a) -> Just $ Right a @@ -2707,7 +2714,7 @@ processChatCommand vr nm = \case 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_ - pure (errs, deleted, acis) + pure (errs, deleted, acis, signed) where sndItemData :: GroupMember -> SndMessage -> Maybe (NewSndChatItemData c) sndItemData GroupMember {groupMemberId, memberProfile, memberStatus} msg @@ -3409,11 +3416,14 @@ processChatCommand vr nm = \case let allowSimplexLinks = maybe True (groupFeatureUserAllowed SGFSimplexLinks) gInfo_' in userProfileInGroup' user allowSimplexLinks incognitoProfile Nothing -> userProfileDirect user incognitoProfile Nothing True - chatEvent = case gInfo_ of - Just (Just gInfo) | useRelays' gInfo -> - let GroupInfo {membership = GroupMember {memberId}} = gInfo - in XMember profileToSend memberId - _ -> XContact profileToSend (Just xContactId) welcomeSharedMsgId msg_ + g <- asks random + chatEvent <- case gInfo_ of + Just (Just gInfo) | useRelays' gInfo -> do + let GroupInfo {membership = GroupMember {memberId}} = gInfo + (memberPubKey, _memberPrivKey) <- atomically $ C.generateKeyPair g + -- TODO: store memberPrivKey in groups.member_priv_key, memberPubKey in group_members.member_pub_key + pure $ XMember profileToSend memberId (MemberKey memberPubKey) + _ -> pure $ XContact profileToSend (Just xContactId) welcomeSharedMsgId msg_ dm <- encodeConnInfoPQ pqSup chatV chatEvent subMode <- chatReadVar subscriptionMode void $ withAgent $ \a -> joinConnection a nm (aUserId user) (aConnId conn) True cReq dm pqSup subMode @@ -3481,8 +3491,8 @@ processChatCommand vr nm = \case mergedProfile = userProfileDirect user Nothing (Just ct) False ct' = updateMergedPreferences user' ct mergedProfile' = userProfileDirect user' Nothing (Just ct') False - ctSndEvent :: ChangedProfileContact -> (ConnOrGroupId, ChatMsgEvent 'Json) - ctSndEvent ChangedProfileContact {mergedProfile', conn = Connection {connId}} = (ConnectionId connId, XInfo mergedProfile') + ctSndEvent :: ChangedProfileContact -> (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent 'Json) + ctSndEvent ChangedProfileContact {mergedProfile', conn = Connection {connId}} = (ConnectionId connId, Nothing, XInfo mergedProfile') ctMsgReq :: ChangedProfileContact -> Either ChatError SndMessage -> Either ChatError ChatMsgReq ctMsgReq ChangedProfileContact {conn} = fmap $ \SndMessage {msgId, msgBody} -> @@ -3548,7 +3558,7 @@ processChatCommand vr nm = \case ci <- saveSndChatItem user cd msg (CISndGroupEvent $ SGEGroupUpdated p') toView $ CEvtNewChatItems user [AChatItem SCTGroup SMDSnd (GroupChat gInfo' Nothing) ci] createGroupFeatureChangedItems user cd CISndGroupFeature gInfo gInfo' - pure $ CRGroupUpdated user gInfo gInfo' Nothing + pure $ CRGroupUpdated user gInfo gInfo' Nothing (isJust $ signedMsg_ msg) checkValidName :: GroupName -> CM () checkValidName displayName = do when (T.null displayName) $ throwChatError CEInvalidDisplayName {displayName, validName = ""} diff --git a/src/Simplex/Chat/Library/Internal.hs b/src/Simplex/Chat/Library/Internal.hs index fe498af067..77ea68274f 100644 --- a/src/Simplex/Chat/Library/Internal.hs +++ b/src/Simplex/Chat/Library/Internal.hs @@ -58,7 +58,7 @@ import Simplex.Chat.Controller import Simplex.Chat.Files import Simplex.Chat.Markdown import Simplex.Chat.Messages -import Simplex.Chat.Messages.Batch (MsgBatch (..), batchMessages) +import Simplex.Chat.Messages.Batch (BatchMode (..), MsgBatch (..), batchMessages) import Simplex.Chat.Messages.CIContent import Simplex.Chat.Messages.CIContent.Events import Simplex.Chat.Operators @@ -95,6 +95,7 @@ import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..)) import qualified Simplex.Messaging.Crypto.File as CF import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..), pattern IKPQOff, pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn) import qualified Simplex.Messaging.Crypto.Ratchet as CR +import Simplex.Messaging.Encoding (smpEncode) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (MsgBody, MsgFlags (..), ProtoServerWithAuth (..), ProtocolServer, ProtocolTypeI (..), SProtocolType (..), SubscriptionMode (..), UserProtocol, XFTPServer) import qualified Simplex.Messaging.Protocol as SMP @@ -1104,7 +1105,7 @@ introduceMember user gInfo@GroupInfo {groupId} toMember@GroupMember {activeConn then do let events = map (memberIntroEvt gInfo) shuffledReMembers forM_ (L.nonEmpty events) $ \events' -> - sendGroupMemberMessages user conn events' groupId + sendGroupMemberMessages user gInfo conn events' else forM_ shuffledReMembers $ \reMember -> void $ sendDirectMemberMessage conn (memberIntroEvt gInfo reMember) groupId updateToMemberVector :: [GroupMember] -> CM () @@ -1139,11 +1140,11 @@ memberIntroEvt gInfo reMember = -- This doesn't create introduction records in db, compared to above methods. introduceModerators :: VersionRangeChat -> User -> GroupInfo -> GroupMember -> CM () introduceModerators _ _ _ GroupMember {activeConn = Nothing} = throwChatError $ CEInternalError "member connection not active" -introduceModerators vr user gInfo@GroupInfo {groupId} GroupMember {activeConn = Just conn} = do +introduceModerators vr user gInfo GroupMember {activeConn = Just conn} = do modMs <- withStore' $ \db -> getGroupModerators db vr user gInfo let events = map (memberIntroEvt gInfo) modMs forM_ (L.nonEmpty events) $ \events' -> - sendGroupMemberMessages user conn events' groupId + sendGroupMemberMessages user gInfo conn events' userProfileInGroup :: User -> GroupInfo -> Maybe Profile -> Profile userProfileInGroup user = userProfileInGroup' user . groupFeatureUserAllowed SGFSimplexLinks @@ -1160,7 +1161,8 @@ memberInfo g m@GroupMember {memberId, memberRole, memberProfile, activeConn} = { memberId, memberRole, v = ChatVersionRange . peerChatVRange <$> activeConn, - profile = redactedMemberProfile allowSimplexLinks $ fromLocalProfile memberProfile + profile = redactedMemberProfile allowSimplexLinks $ fromLocalProfile memberProfile, + memberKey = Nothing -- TODO: get from GroupMember when stored in database } where allowSimplexLinks = groupFeatureMemberAllowed SGFSimplexLinks m g @@ -1175,7 +1177,7 @@ redactedMemberProfile allowSimplexLinks Profile {displayName, fullName, shortDes sendHistory :: User -> GroupInfo -> GroupMember -> CM () sendHistory _ _ GroupMember {activeConn = Nothing} = throwChatError $ CEInternalError "member connection not active" -sendHistory user gInfo@GroupInfo {groupId, membership} m@GroupMember {activeConn = Just conn} = +sendHistory user gInfo@GroupInfo {membership} m@GroupMember {activeConn = Just conn} = when (m `supportsVersion` batchSendVersion) $ do (errs, items) <- partitionEithers <$> withStore' (\db -> getGroupHistoryItems db user gInfo m 100) (errs', events) <- partitionEithers <$> mapM (tryAllErrors . itemForwardEvents) items @@ -1190,7 +1192,7 @@ sendHistory user gInfo@GroupInfo {groupId, membership} m@GroupMember {activeConn _ -> events' <> [descr] Nothing -> pure events' forM_ (L.nonEmpty events_) $ \events'' -> - sendGroupMemberMessages user conn events'' groupId + sendGroupMemberMessages user gInfo conn events'' where descrEvent_ :: Maybe (ChatMsgEvent 'Json) descrEvent_ @@ -1264,9 +1266,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 - memberId_ = memberId' <$> sender_ - memberName_ = memberShortenedName <$> sender_ - msgForwardEvents = map (\cm -> XGrpMsgForward memberId_ memberName_ cm itemTs) (xMsgNewChatMsg : fileDescrChatMsgs) + fwdSender = maybe FwdChannel (\s -> FwdMember (memberId' s) (memberShortenedName s)) sender_ + fwd = GrpMsgForward {fwdSender, fwdBrokerTs = itemTs} + msgForwardEvents = map (XGrpMsgForward fwd) (xMsgNewChatMsg : fileDescrChatMsgs) pure msgForwardEvents memberShortenedName :: GroupMember -> ContactName @@ -1549,7 +1551,7 @@ sendFileInline_ FileTransferMeta {filePath, chunkSize} sharedMsgId sendMsg = parseChatMessage :: Connection -> ByteString -> CM (ChatMessage 'Json) parseChatMessage conn s = do case parseChatMessages s of - [msg] -> liftEither . first (ChatError . errType) $ (\(ACMsg _ m) -> checkEncoding m) =<< msg + [msg] -> liftEither . first (ChatError . errType) $ (\(APMsg _ (ParsedMsg _ _ m)) -> checkEncoding m) =<< msg _ -> throwChatError $ CEException "parseChatMessage: single message is expected" where errType = CEInvalidChatMessage conn Nothing (safeDecodeUtf8 s) @@ -1810,10 +1812,10 @@ sendDirectContactMessages user ct events = do sendDirectContactMessages' :: MsgEncodingI e => User -> Contact -> NonEmpty (ChatMsgEvent e) -> CM [Either ChatError SndMessage] sendDirectContactMessages' user ct events = do conn@Connection {connId} <- liftEither $ contactSendConn_ ct - let idsEvts = L.map (ConnectionId connId,) events + let idsEvts = L.map (ConnectionId connId,Nothing,) events msgFlags = MsgFlags {notification = any (hasNotification . toCMEventTag) events} sndMsgs_ <- lift $ createSndMessages idsEvts - (sndMsgs', pqEnc_) <- batchSendConnMessagesB user conn msgFlags sndMsgs_ + (sndMsgs', pqEnc_) <- batchSendConnMessagesB BMJson user conn msgFlags sndMsgs_ forM_ pqEnc_ $ \pqEnc' -> void $ createContactPQSndItem user ct conn pqEnc' pure sndMsgs' @@ -1851,37 +1853,44 @@ sendDirectMessage_ conn chatMsgEvent connOrGroupId = do createSndMessage :: MsgEncodingI e => ChatMsgEvent e -> ConnOrGroupId -> CM SndMessage createSndMessage chatMsgEvent connOrGroupId = - liftEither . runIdentity =<< lift (createSndMessages $ Identity (connOrGroupId, chatMsgEvent)) + liftEither . runIdentity =<< lift (createSndMessages $ Identity (connOrGroupId, Nothing, chatMsgEvent)) -createSndMessages :: forall e t. (MsgEncodingI e, Traversable t) => t (ConnOrGroupId, ChatMsgEvent e) -> CM' (t (Either ChatError SndMessage)) +createSndMessages :: forall e t. (MsgEncodingI e, Traversable t) => t (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent e) -> CM' (t (Either ChatError SndMessage)) createSndMessages idsEvents = do g <- asks random vr <- chatVersionRange' withStoreBatch $ \db -> fmap (createMsg db g vr) idsEvents where - createMsg :: DB.Connection -> TVar ChaChaDRG -> VersionRangeChat -> (ConnOrGroupId, ChatMsgEvent e) -> IO (Either ChatError SndMessage) - createMsg db g vr (connOrGroupId, evnt) = runExceptT $ do - withExceptT ChatErrorStore $ createNewSndMessage db g connOrGroupId evnt encodeMessage + createMsg :: DB.Connection -> TVar ChaChaDRG -> VersionRangeChat -> (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent e) -> IO (Either ChatError SndMessage) + createMsg db g vr (connOrGroupId, msgSigning_, evnt) = runExceptT $ do + withExceptT ChatErrorStore $ createNewSndMessage db g connOrGroupId evnt msgSigning_ encodeMessage where encodeMessage sharedMsgId = encodeChatMessage maxEncodedMsgLength ChatMessage {chatVRange = vr, msgId = Just sharedMsgId, chatMsgEvent = evnt} -sendGroupMemberMessages :: forall e. MsgEncodingI e => User -> Connection -> NonEmpty (ChatMsgEvent e) -> GroupId -> CM () -sendGroupMemberMessages user conn events groupId = do +groupMsgSigning :: GroupInfo -> ChatMsgEvent e -> Maybe MsgSigning +groupMsgSigning gInfo@GroupInfo {membership = GroupMember {memberId}, groupKeys = Just GroupKeys {groupRootKey, memberPrivKey}} evt + | useRelays' gInfo && requiresSignature (toCMEventTag evt) = + Just $ MsgSigning CBGroup (smpEncode (groupRootPubKey groupRootKey, memberId)) KRMember memberPrivKey +groupMsgSigning _ _ = Nothing + +sendGroupMemberMessages :: forall e. MsgEncodingI e => User -> GroupInfo -> Connection -> NonEmpty (ChatMsgEvent e) -> CM () +sendGroupMemberMessages user gInfo@GroupInfo {groupId} conn events = do when (connDisabled conn) $ throwChatError (CEConnectionDisabled conn) - let idsEvts = L.map (GroupId groupId,) events + let idsEvts = L.map (\evt -> (GroupId groupId, groupMsgSigning gInfo evt, evt)) events + mode = if useRelays' gInfo then BMBinary else BMJson (errs, msgs) <- lift $ partitionEithers . L.toList <$> createSndMessages idsEvts unless (null errs) $ toView $ CEvtChatErrors errs forM_ (L.nonEmpty msgs) $ \msgs' -> - batchSendConnMessages user conn MsgFlags {notification = True} msgs' + batchSendConnMessages mode user conn MsgFlags {notification = True} msgs' -batchSendConnMessages :: User -> Connection -> MsgFlags -> NonEmpty SndMessage -> CM ([Either ChatError SndMessage], Maybe PQEncryption) -batchSendConnMessages user conn msgFlags msgs = - batchSendConnMessagesB user conn msgFlags $ L.map Right msgs +batchSendConnMessages :: BatchMode -> User -> Connection -> MsgFlags -> NonEmpty SndMessage -> CM ([Either ChatError SndMessage], Maybe PQEncryption) +batchSendConnMessages mode user conn msgFlags msgs = + batchSendConnMessagesB mode user conn msgFlags $ L.map Right msgs -batchSendConnMessagesB :: User -> Connection -> MsgFlags -> NonEmpty (Either ChatError SndMessage) -> CM ([Either ChatError SndMessage], Maybe PQEncryption) -batchSendConnMessagesB _user conn msgFlags msgs_ = do - let batched_ = batchSndMessagesJSON msgs_ +batchSendConnMessagesB :: BatchMode -> User -> Connection -> MsgFlags -> NonEmpty (Either ChatError SndMessage) -> CM ([Either ChatError SndMessage], Maybe PQEncryption) +batchSendConnMessagesB mode _user conn msgFlags msgs_ = do + let batched_ = batchSndMessagesJSON mode msgs_ case L.nonEmpty batched_ of Just batched' -> do let msgReqs = L.map (fmap msgBatchReq_) batched' @@ -1902,8 +1911,8 @@ batchSendConnMessagesB _user conn msgFlags msgs_ = do findLastPQEnc :: NonEmpty (Either ChatError ([Int64], PQEncryption)) -> Maybe PQEncryption findLastPQEnc = foldr' (\x acc -> case x of Right (_, pqEnc) -> Just pqEnc; Left _ -> acc) Nothing -batchSndMessagesJSON :: NonEmpty (Either ChatError SndMessage) -> [Either ChatError MsgBatch] -batchSndMessagesJSON = batchMessages maxEncodedMsgLength . L.toList +batchSndMessagesJSON :: BatchMode -> NonEmpty (Either ChatError SndMessage) -> [Either ChatError MsgBatch] +batchSndMessagesJSON mode = batchMessages mode maxEncodedMsgLength . L.toList encodeConnInfo :: MsgEncodingI e => ChatMsgEvent e -> CM ByteString encodeConnInfo chatMsgEvent = do @@ -2029,7 +2038,7 @@ data GroupSndResult = GroupSndResult sendGroupMessages_ :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult) sendGroupMessages_ _user gInfo@GroupInfo {groupId} recipientMembers events = do - let idsEvts = L.map (GroupId groupId,) events + let idsEvts = L.map (\evt -> (GroupId groupId, groupMsgSigning gInfo evt, evt)) events sndMsgs_ <- lift $ createSndMessages idsEvts recipientMembers' <- liftIO $ shuffleMembers recipientMembers let msgFlags = MsgFlags {notification = any (hasNotification . toCMEventTag) events} @@ -2071,7 +2080,8 @@ sendGroupMessages_ _user gInfo@GroupInfo {groupId} recipientMembers events = do mIds' = S.insert mId mIds prepareMsgReqs :: MsgFlags -> NonEmpty (Either ChatError SndMessage) -> [(GroupMember, Connection)] -> [(GroupMember, Connection)] -> ([GroupMemberId], [Either ChatError ChatMsgReq]) prepareMsgReqs msgFlags msgs toSendSeparate toSendBatched = do - let batched_ = batchSndMessagesJSON msgs + let mode = if useRelays' gInfo then BMBinary else BMJson + batched_ = batchSndMessagesJSON mode msgs case L.nonEmpty batched_ of Just batched' -> do let lenMsgs = length msgs @@ -2188,29 +2198,31 @@ sendGroupMemberMessage gInfo@GroupInfo {groupId} m@GroupMember {groupMemberId} c MSAForwarded -> pure () -- TODO ensure order - pending messages interleave with user input messages -sendPendingGroupMessages :: User -> GroupMember -> Connection -> CM () -sendPendingGroupMessages user GroupMember {groupMemberId} conn = do +sendPendingGroupMessages :: User -> GroupInfo -> GroupMember -> Connection -> CM () +sendPendingGroupMessages user gInfo GroupMember {groupMemberId} conn = do + let mode = if useRelays' gInfo then BMBinary else BMJson msgs <- withStore' $ \db -> getPendingGroupMessages db groupMemberId forM_ (L.nonEmpty msgs) $ \msgs' -> do - void $ batchSendConnMessages user conn MsgFlags {notification = True} msgs' + void $ batchSendConnMessages mode user conn MsgFlags {notification = True} msgs' lift . void . withStoreBatch' $ \db -> L.map (\SndMessage {msgId} -> deletePendingGroupMessage db groupMemberId msgId) msgs' -saveDirectRcvMSG :: MsgEncodingI e => Connection -> MsgMeta -> MsgBody -> ChatMessage e -> CM (Connection, RcvMessage) -saveDirectRcvMSG conn@Connection {connId} agentMsgMeta msgBody ChatMessage {chatVRange, msgId = sharedMsgId_, chatMsgEvent} = do +saveDirectRcvMSG :: forall e. MsgEncodingI e => Connection -> MsgMeta -> ChatMessage e -> CM (Connection, RcvMessage) +saveDirectRcvMSG conn@Connection {connId} agentMsgMeta chatMsg@ChatMessage {chatVRange, msgId = sharedMsgId_, chatMsgEvent} = do conn' <- updatePeerChatVRange conn chatVRange let agentMsgId = fst $ recipient agentMsgMeta brokerTs = metaBrokerTs agentMsgMeta - newMsg = NewRcvMessage {chatMsgEvent, msgBody, brokerTs} + newMsg = NewRcvMessage {chatMsgEvent, verifiedMsg = VMUnsigned chatMsg, brokerTs} rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta} msg <- withStore $ \db -> createNewMessageAndRcvMsgDelivery db (ConnectionId connId) newMsg sharedMsgId_ rcvMsgDelivery Nothing pure (conn', msg) -saveGroupRcvMsg :: MsgEncodingI e => User -> GroupId -> GroupMember -> Connection -> MsgMeta -> MsgBody -> ChatMessage e -> CM (GroupMember, Connection, RcvMessage) -saveGroupRcvMsg user groupId authorMember conn@Connection {connId} agentMsgMeta msgBody ChatMessage {chatVRange, msgId = sharedMsgId_, chatMsgEvent} = do +saveGroupRcvMsg :: MsgEncodingI e => User -> GroupId -> GroupMember -> Connection -> MsgMeta -> VerifiedMsg e -> CM (GroupMember, Connection, RcvMessage) +saveGroupRcvMsg user groupId authorMember conn@Connection {connId} agentMsgMeta verifiedMsg = do + let ChatMessage {chatVRange, msgId = sharedMsgId_, chatMsgEvent} = verifiedChatMsg verifiedMsg (am'@GroupMember {memberId = amMemId, groupMemberId = amGroupMemId}, conn') <- updateMemberChatVRange authorMember conn chatVRange let agentMsgId = fst $ recipient agentMsgMeta brokerTs = metaBrokerTs agentMsgMeta - newMsg = NewRcvMessage {chatMsgEvent, msgBody, brokerTs} + newMsg = NewRcvMessage {chatMsgEvent, verifiedMsg, brokerTs} rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta} msg <- withStore (\db -> createNewMessageAndRcvMsgDelivery db (GroupId groupId) newMsg sharedMsgId_ rcvMsgDelivery $ Just amGroupMemId) @@ -2224,9 +2236,10 @@ saveGroupRcvMsg user groupId authorMember conn@Connection {connId} agentMsgMeta _ -> throwError e pure (am', conn', msg) -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} +saveGroupFwdRcvMsg :: MsgEncodingI e => User -> GroupInfo -> GroupMember -> Maybe GroupMember -> VerifiedMsg e -> UTCTime -> CM (Maybe RcvMessage) +saveGroupFwdRcvMsg user gInfo@GroupInfo {groupId} forwardingMember refAuthorMember_ verifiedMsg brokerTs = do + let ChatMessage {msgId = sharedMsgId_, chatMsgEvent} = verifiedChatMsg verifiedMsg + newMsg = NewRcvMessage {chatMsgEvent, verifiedMsg, brokerTs} fwdMemberId = Just $ groupMemberId' forwardingMember refAuthorId = groupMemberId' <$> refAuthorMember_ -- TODO [relays] TBC highlighting difference between deduplicated messages (useRelays branch) @@ -2285,11 +2298,12 @@ saveSndChatItems user cd showGroupAsSender itemsData itemTimed live = do lift $ withStoreBatch (\db -> map (bindRight $ createItem db createdAt) itemsData) where 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 + createItem db createdAt NewSndChatItemData {msg = msg@SndMessage {sharedMsgId, signedMsg_}, content, itemTexts, itemMentions, ciFile, quotedItem, itemForwarded} = do let hasLink_ = ciContentHasLink content (snd itemTexts) + signed = isJust signedMsg_ 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 showGroupAsSender 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 signed createdAt Right <$> case cd of CDGroupSnd g _scope | not (null itemMentions) -> createGroupCIMentions db g ci itemMentions _ -> pure ci @@ -2305,7 +2319,7 @@ ciContentNoParse :: CIContent 'MDRcv -> (CIContent 'MDRcv, (Text, Maybe Markdown ciContentNoParse content = (content, (ciContentToText content, Nothing)) saveRcvChatItem' :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> UTCTime -> (CIContent 'MDRcv, (Text, Maybe MarkdownList)) -> Maybe (CIFile 'MDRcv) -> Maybe CITimed -> Bool -> Map MemberName MsgMention -> CM (ChatItem c 'MDRcv, ChatInfo c) -saveRcvChatItem' user cd msg@RcvMessage {chatMsgEvent, forwardedByMember} sharedMsgId_ brokerTs (content, (t, ft_)) ciFile itemTimed live mentions = do +saveRcvChatItem' user cd msg@RcvMessage {chatMsgEvent, msgSigned, forwardedByMember} sharedMsgId_ brokerTs (content, (t, ft_)) ciFile itemTimed live mentions = do createdAt <- liftIO getCurrentTime vr <- chatVersionRange withStore' $ \db -> do @@ -2320,7 +2334,7 @@ saveRcvChatItem' user cd msg@RcvMessage {chatMsgEvent, forwardedByMember} shared 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 showAsGroup ciId content (t, ft_) ciFile quotedItem sharedMsgId_ itemForwarded itemTimed live userMention hasLink_ brokerTs forwardedByMember createdAt + let ci = mkChatItem_ cd showAsGroup ciId content (t, ft_) ciFile quotedItem sharedMsgId_ itemForwarded itemTimed live userMention hasLink_ brokerTs forwardedByMember msgSigned createdAt ci' <- case toChatInfo cd of GroupChat g _ | not (null mentions') -> createGroupCIMentions db g ci mentions' _ -> pure ci @@ -2348,12 +2362,12 @@ mkChatItem :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ShowGroupAs mkChatItem cd showGroupAsSender ciId content file quotedItem sharedMsgId itemForwarded itemTimed live userMention itemTs forwardedByMember currentTs = let ts@(_, ft_) = ciContentTexts content hasLink_ = ciContentHasLink content ft_ - in mkChatItem_ cd showGroupAsSender ciId content ts file quotedItem sharedMsgId itemForwarded itemTimed live userMention hasLink_ itemTs forwardedByMember currentTs + in mkChatItem_ cd showGroupAsSender ciId content ts file quotedItem sharedMsgId itemForwarded itemTimed live userMention hasLink_ itemTs forwardedByMember False currentTs -mkChatItem_ :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ShowGroupAsSender -> ChatItemId -> CIContent d -> (Text, Maybe MarkdownList) -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> Bool -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> ChatItem c d -mkChatItem_ cd showGroupAsSender ciId content (itemText, formattedText) file quotedItem sharedMsgId itemForwarded itemTimed live userMention hasLink_ itemTs forwardedByMember currentTs = +mkChatItem_ :: (ChatTypeI c, MsgDirectionI d) => ChatDirection c d -> ShowGroupAsSender -> ChatItemId -> CIContent d -> (Text, Maybe MarkdownList) -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> Bool -> ChatItemTs -> Maybe GroupMemberId -> Bool -> UTCTime -> ChatItem c d +mkChatItem_ cd showGroupAsSender ciId content (itemText, formattedText) file quotedItem sharedMsgId itemForwarded itemTimed live userMention hasLink_ itemTs forwardedByMember msgSigned currentTs = let itemStatus = ciCreateStatus content - meta = mkCIMeta ciId content itemText itemStatus Nothing sharedMsgId itemForwarded Nothing False itemTimed (justTrue live) userMention hasLink_ currentTs itemTs forwardedByMember showGroupAsSender currentTs currentTs + meta = mkCIMeta ciId content itemText itemStatus Nothing sharedMsgId itemForwarded Nothing False itemTimed (justTrue live) userMention hasLink_ currentTs itemTs forwardedByMember showGroupAsSender msgSigned currentTs currentTs in ChatItem {chatDir = toCIDirection cd, meta, content, mentions = M.empty, formattedText, quotedItem, reactions = [], file} ciContentHasLink :: CIContent d -> Maybe MarkdownList -> Bool @@ -2661,9 +2675,9 @@ createLocalChatItems user cd itemsData createdAt = do createItem :: DB.Connection -> (CIContent 'MDSnd, Maybe (CIFile 'MDSnd), Maybe CIForwardedFrom, (Text, Maybe MarkdownList)) -> IO (ChatItem 'CTLocal 'MDSnd) createItem db (content, ciFile, itemForwarded, ts@(_, ft_)) = do let hasLink_ = ciContentHasLink content ft_ - ciId <- createNewChatItem_ db user cd False Nothing Nothing content (Nothing, Nothing, Nothing, Nothing, Nothing) itemForwarded Nothing False False hasLink_ createdAt Nothing createdAt + ciId <- createNewChatItem_ db user cd False Nothing Nothing content (Nothing, Nothing, Nothing, Nothing, Nothing) itemForwarded Nothing False False hasLink_ createdAt Nothing False createdAt forM_ ciFile $ \CIFile {fileId} -> updateFileTransferChatItemId db fileId ciId createdAt - pure $ mkChatItem_ cd False ciId content ts ciFile Nothing Nothing itemForwarded Nothing False False hasLink_ createdAt Nothing createdAt + pure $ mkChatItem_ cd False ciId content ts ciFile Nothing Nothing itemForwarded Nothing False False hasLink_ createdAt Nothing False createdAt withUser' :: (User -> CM ChatResponse) -> CM ChatResponse withUser' action = diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index 90f170a6f7..5d491b6bc2 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/src/Simplex/Chat/Library/Subscriber.hs @@ -46,7 +46,7 @@ import Simplex.Chat.Controller import Simplex.Chat.Delivery import Simplex.Chat.Library.Internal import Simplex.Chat.Messages -import Simplex.Chat.Messages.Batch (batchDeliveryTasks1) +import Simplex.Chat.Messages.Batch (batchDeliveryTasks1, encodeBinaryBatch, encodeFwdElement) import Simplex.Chat.Messages.CIContent import Simplex.Chat.Messages.CIContent.Events import Simplex.Chat.ProfileGenerator (generateRandomProfile) @@ -84,6 +84,7 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile (..)) import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn) import qualified Simplex.Messaging.Crypto.Ratchet as CR +import Simplex.Messaging.Encoding (smpEncode) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (ErrorType (..), MsgFlags (..)) import qualified Simplex.Messaging.Protocol as SMP @@ -258,13 +259,13 @@ processAgentMsgSndFile _corrId aFileId msg = do unless (null errs') $ toView $ CEvtChatErrors errs' pure delivered where - connDescrEvents :: Int -> NonEmpty (Connection, (ConnOrGroupId, ChatMsgEvent 'Json)) + connDescrEvents :: Int -> NonEmpty (Connection, (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent 'Json)) connDescrEvents partSize = L.fromList $ concatMap splitText (L.toList connsTransfersDescrs) where - splitText :: (Connection, SndFileTransfer, RcvFileDescrText) -> [(Connection, (ConnOrGroupId, ChatMsgEvent 'Json))] + splitText :: (Connection, SndFileTransfer, RcvFileDescrText) -> [(Connection, (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent 'Json))] splitText (conn, _, rfdText) = - map (\fileDescr -> (conn, (connOrGroupId, XMsgFileDescr {msgId = sharedMsgId, fileDescr}))) (L.toList $ splitFileDescr partSize rfdText) - toMsgReq :: (Connection, (ConnOrGroupId, ChatMsgEvent 'Json)) -> SndMessage -> ChatMsgReq + map (\fileDescr -> (conn, (connOrGroupId, Nothing, XMsgFileDescr {msgId = sharedMsgId, fileDescr}))) (L.toList $ splitFileDescr partSize rfdText) + toMsgReq :: (Connection, (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent 'Json)) -> SndMessage -> ChatMsgReq toMsgReq (conn, _) SndMessage {msgId, msgBody} = (conn, MsgFlags {notification = hasNotification XMsgFileDescr_}, (vrValue msgBody, [msgId])) sendFileError :: FileError -> Text -> VersionRangeChat -> FileTransferMeta -> CM () @@ -461,7 +462,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = (ct', conn') <- updateContactPQRcv user ct conn pqEncryption checkIntegrityCreateItem (CDDirectRcv ct') msgMeta `catchAllErrors` \_ -> pure () forM_ aChatMsgs $ \case - Right (ACMsg _ chatMsg) -> + Right (APMsg _ (ParsedMsg _ _ chatMsg)) -> processEvent ct' conn' tags eInfo chatMsg `catchAllErrors` \e -> eToView e Left e -> do atomically $ modifyTVar' tags ("error" :) @@ -476,8 +477,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = let tag = toCMEventTag chatMsgEvent atomically $ modifyTVar' tags (tshow tag :) logInfo $ "contact msg=" <> tshow tag <> " " <> eInfo - let body = chatMsgToBody chatMsg - (conn'', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveDirectRcvMSG conn' msgMeta body chatMsg + (conn'', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveDirectRcvMSG conn' msgMeta chatMsg let ct'' = ct' {activeConn = Just conn''} :: Contact case event of XMsgNew mc -> newContentMessage ct'' mc msg msgMeta @@ -502,12 +502,12 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = XCallEnd callId -> xCallEnd ct'' callId msg BFileChunk sharedMsgId chunk -> bFileChunk ct'' sharedMsgId chunk msgMeta _ -> messageError $ "unsupported message: " <> T.pack (show event) - checkSendRcpt :: Contact -> [AChatMessage] -> CM Bool + checkSendRcpt :: Contact -> [AParsedMsg] -> CM Bool checkSendRcpt ct' aMsgs = do let Contact {chatSettings = ChatSettings {sendRcpts}} = ct' pure $ fromMaybe (sendRcptsContacts user) sendRcpts && any aChatMsgHasReceipt aMsgs where - aChatMsgHasReceipt (ACMsg _ ChatMessage {chatMsgEvent}) = + aChatMsgHasReceipt (APMsg _ (ParsedMsg _ _ ChatMessage {chatMsgEvent})) = hasDeliveryReceipt (toCMEventTag chatMsgEvent) RCVD msgMeta msgRcpt -> withAckMessage' "contact rcvd" agentConnId msgMeta $ @@ -792,7 +792,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = CON _pqEnc -> unless (memberStatus m == GSMemRejected || memberStatus membership == GSMemRejected) $ do -- TODO [knocking] send pending messages after accepting? -- possible improvement: check for each pending message, requires keeping track of connection state - unless (connDisabled conn) $ sendPendingGroupMessages user m conn + unless (connDisabled conn) $ sendPendingGroupMessages user gInfo m conn withAgent $ \a -> toggleConnectionNtfs a (aConnId conn) $ chatHasNtfs chatSettings case memberCategory m of GCHostMember -> do @@ -868,7 +868,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = sendXGrpLinkMem gInfo'' = do let incognitoProfile = ExistingIncognito <$> incognitoMembershipProfile gInfo'' profileToSend = userProfileInGroup user gInfo (fromIncognitoProfile <$> incognitoProfile) - void $ sendDirectMemberMessage conn (XGrpLinkMem profileToSend) groupId + void $ sendDirectMemberMessage conn (XGrpLinkMem profileToSend Nothing) groupId -- TODO: send member key _ -> do unless (memberPending m) $ withStore' $ \db -> updateGroupMemberStatus db userId m GSMemConnected notifyMemberConnected gInfo m Nothing @@ -897,7 +897,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = -- possible improvement is to choose scope based on event (some events specify scope) (gInfo', m', scopeInfo) <- mkGroupChatScope gInfo m checkIntegrityCreateItem (CDGroupRcv gInfo' scopeInfo m') msgMeta `catchAllErrors` \_ -> pure () - newDeliveryTasks <- reverse <$> foldM (processAChatMsg gInfo' m' tags eInfo) [] aChatMsgs + newDeliveryTasks <- reverse <$> foldM (processAChatMsg gInfo' scopeInfo m' tags eInfo) [] aChatMsgs shouldDelConns <- if isUserGrpFwdRelay gInfo' && not (blockedByAdmin m) then createDeliveryTasks gInfo' m' newDeliveryTasks @@ -909,31 +909,38 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = brokerTs = metaBrokerTs msgMeta processAChatMsg :: GroupInfo -> + Maybe GroupChatScopeInfo -> GroupMember -> TVar [Text] -> Text -> [NewMessageDeliveryTask] -> - Either String AChatMessage -> + Either String AParsedMsg -> CM [NewMessageDeliveryTask] - processAChatMsg gInfo' m' tags eInfo newDeliveryTasks = \case - Right (ACMsg SJson chatMsg) -> do - newTask_ <- processEvent gInfo' m' tags eInfo chatMsg `catchAllErrors` \e -> eToView e $> Nothing - pure $ maybe newDeliveryTasks (: newDeliveryTasks) newTask_ - Right (ACMsg SBinary chatMsg) -> do - void (processEvent gInfo' m' tags eInfo chatMsg) `catchAllErrors` \e -> eToView e - pure newDeliveryTasks + processAChatMsg gInfo' scopeInfo m' tags eInfo newDeliveryTasks = \case + Right (APMsg enc (parsedMsg@(ParsedMsg fwd_ _ ChatMessage {chatMsgEvent}))) -> do + let tag = toCMEventTag chatMsgEvent + atomically $ modifyTVar' tags (tshow tag :) + case fwd_ of + Just fwd | SJson <- enc -> do + logInfo $ "group fwd=" <> tshow tag <> " " <> eInfo + xGrpMsgForward gInfo' scopeInfo m' fwd parsedMsg brokerTs + `catchAllErrors` \e -> eToView e + pure newDeliveryTasks + -- direct JSON and binary messages; binary events don't produce delivery tasks + _ -> do + logInfo $ "group msg=" <> tshow tag <> " " <> eInfo + newTask_ <- join <$> withVerifiedMsg gInfo' scopeInfo m' parsedMsg brokerTs + (\verifiedMsg -> processEvent gInfo' m' verifiedMsg `catchAllErrors` \e -> eToView e $> Nothing) + pure $ maybe id (:) newTask_ newDeliveryTasks Left e -> do atomically $ modifyTVar' tags ("error" :) logInfo $ "group msg=error " <> eInfo <> " " <> tshow e eToView (ChatError . CEException $ "error parsing chat message: " <> e) pure newDeliveryTasks - processEvent :: forall e. MsgEncodingI e => GroupInfo -> GroupMember -> TVar [Text] -> Text -> ChatMessage e -> CM (Maybe NewMessageDeliveryTask) - processEvent gInfo' m' tags eInfo chatMsg@ChatMessage {chatMsgEvent} = do - let tag = toCMEventTag chatMsgEvent - atomically $ modifyTVar' tags (tshow tag :) - logInfo $ "group msg=" <> tshow tag <> " " <> eInfo - let body = chatMsgToBody chatMsg - (m'', conn', msg@RcvMessage {msgId, chatMsgEvent = ACME _ event}) <- saveGroupRcvMsg user groupId m' conn msgMeta body chatMsg + processEvent :: forall e. MsgEncodingI e => GroupInfo -> GroupMember -> VerifiedMsg e -> CM (Maybe NewMessageDeliveryTask) + processEvent gInfo' m' verifiedMsg = do + let chatMsg = verifiedChatMsg verifiedMsg + (m'', conn', msg@RcvMessage {msgId, msgSigned, chatMsgEvent = ACME _ event}) <- saveGroupRcvMsg user groupId m' conn msgMeta verifiedMsg let ctx js = DeliveryTaskContext js False checkSendAsGroup :: Maybe Bool -> CM (Maybe DeliveryTaskContext) -> CM (Maybe DeliveryTaskContext) checkSendAsGroup asGroup_ a @@ -960,7 +967,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = XFileCancel sharedMsgId -> xFileCancelGroup gInfo' (Just m'') sharedMsgId XFileAcptInv sharedMsgId fileConnReq_ fName -> Nothing <$ xFileAcptInvGroup gInfo' m'' sharedMsgId fileConnReq_ fName XInfo p -> fmap ctx <$> xInfoMember gInfo' m'' p brokerTs - XGrpLinkMem p -> Nothing <$ xGrpLinkMem gInfo' m'' conn' p + XGrpLinkMem p memberKey -> Nothing <$ xGrpLinkMem gInfo' m'' conn' p memberKey XGrpLinkAcpt acceptance role memberId -> Nothing <$ xGrpLinkAcpt gInfo' m'' acceptance role memberId msg brokerTs XGrpMemNew memInfo msgScope -> fmap ctx <$> xGrpMemNew gInfo' m'' memInfo msgScope msg brokerTs XGrpMemIntro memInfo memRestrictions_ -> Nothing <$ xGrpMemIntro gInfo' m'' memInfo memRestrictions_ @@ -975,10 +982,10 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = 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' + XGrpPrefs ps' -> fmap ctx <$> xGrpPrefs msgSigned gInfo' m'' ps' -- TODO [knocking] why don't we forward these messages? 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 + XGrpMsgForward fwd msg' -> Nothing <$ xGrpMsgForward gInfo' Nothing m'' fwd (ParsedMsg Nothing Nothing msg') brokerTs XInfoProbe probe -> Nothing <$ xInfoProbe (COMGroupMember m'') probe XInfoProbeCheck probeHash -> Nothing <$ xInfoProbeCheck (COMGroupMember m'') probeHash XInfoProbeOk probe -> Nothing <$ xInfoProbeOk (COMGroupMember m'') probe @@ -986,7 +993,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = _ -> Nothing <$ messageError ("unsupported message: " <> tshow event) forM deliveryTaskContext_ $ \taskContext -> pure $ NewMessageDeliveryTask {messageId = msgId, taskContext} - checkSendRcpt :: [AChatMessage] -> CM Bool + checkSendRcpt :: [AParsedMsg] -> CM Bool checkSendRcpt aMsgs = do let currentMemCount = fromIntegral $ currentMembers $ groupSummary gInfo GroupInfo {chatSettings = ChatSettings {sendRcpts}} = gInfo @@ -995,7 +1002,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = && any aChatMsgHasReceipt aMsgs && currentMemCount <= smallGroupsRcptsMemLimit where - aChatMsgHasReceipt (ACMsg _ ChatMessage {chatMsgEvent}) = + aChatMsgHasReceipt (APMsg _ (ParsedMsg _ _ ChatMessage {chatMsgEvent})) = hasDeliveryReceipt (toCMEventTag chatMsgEvent) createDeliveryTasks :: GroupInfo -> GroupMember -> [NewMessageDeliveryTask] -> CM ShouldDeleteGroupConns createDeliveryTasks gInfo'@GroupInfo {groupId = gId} m' newDeliveryTasks = do @@ -1033,7 +1040,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = sentMsgDeliveryEvent conn msgId checkSndInlineFTComplete conn msgId updateGroupItemsStatus gInfo m conn msgId GSSSent (Just $ isJust proxy) - when continued $ sendPendingGroupMessages user m conn + when continued $ sendPendingGroupMessages user gInfo m conn SWITCH qd phase cStats -> do toView $ CEvtGroupMemberSwitch user gInfo m (SwitchProgress qd phase cStats) (gInfo', m', scopeInfo) <- mkGroupChatScope gInfo m @@ -1098,13 +1105,16 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = let GroupMember {memberId = membershipMemId} = membership incognitoProfile = fromLocalProfile <$> incognitoMembershipProfile gInfo profileToSend = userProfileInGroup user gInfo incognitoProfile - dm <- encodeConnInfo $ XMember profileToSend membershipMemId + g <- asks random + (memberPubKey, _memberPrivKey) <- atomically $ C.generateKeyPair g + -- TODO: store memberPrivKey in groups.member_priv_key, memberPubKey in group_members.member_pub_key + dm <- encodeConnInfo $ XMember profileToSend membershipMemId (MemberKey memberPubKey) subMode <- chatReadVar subscriptionMode void $ joinAgentConnectionAsync user (Just conn) True cReq dm subMode _ -> throwChatError $ CECommandError "unexpected cmdFunction" QCONT -> do continued <- continueSending connEntity conn - when continued $ sendPendingGroupMessages user m conn + when continued $ sendPendingGroupMessages user gInfo m conn MWARN msgId err -> do withStore' $ \db -> updateGroupItemsErrorStatus db msgId (groupMemberId' m) (GSSWarning $ agentSndError err) processConnMWARN connEntity conn err @@ -1211,7 +1221,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo case chatMsgEvent of XContact p xContactId_ welcomeMsgId_ requestMsg_ -> profileContactRequest invId chatVRange p xContactId_ welcomeMsgId_ requestMsg_ pqSupport - XMember p joiningMemberId -> memberJoinRequestViaRelay invId chatVRange p joiningMemberId + XMember p joiningMemberId joiningMemberKey -> memberJoinRequestViaRelay invId chatVRange p joiningMemberId joiningMemberKey XInfo p -> profileContactRequest invId chatVRange p Nothing Nothing Nothing pqSupport XGrpRelayInv groupRelayInv -> xGrpRelayInv invId chatVRange groupRelayInv -- TODO show/log error, other events in contact request @@ -1422,8 +1432,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = lift $ void $ getRelayRequestWorker True -- TODO [relays] owner, relays: TBC how to communicate member rejection rules from owner to relays -- TODO [relays] relay: TBC communicate rejection when memberId already exists (currently checked in createJoiningMember) - memberJoinRequestViaRelay :: InvitationId -> VersionRangeChat -> Profile -> MemberId -> CM () - memberJoinRequestViaRelay invId chatVRange p joiningMemberId = do + memberJoinRequestViaRelay :: InvitationId -> VersionRangeChat -> Profile -> MemberId -> MemberKey -> CM () + memberJoinRequestViaRelay invId chatVRange p joiningMemberId _joiningMemberKey = do -- TODO: store memberKey in group_members.member_pub_key (_ucl, gLinkInfo_) <- withStore $ \db -> getUserContactLinkById db userId uclId case gLinkInfo_ of Just GroupLinkInfo {groupId, memberRole = gLinkMemRole} -> do @@ -2387,8 +2397,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = void $ processMemberProfileUpdate gInfo m p' True (Just brokerTs) pure $ memberEventDeliveryScope m - xGrpLinkMem :: GroupInfo -> GroupMember -> Connection -> Profile -> CM () - xGrpLinkMem gInfo@GroupInfo {membership, businessChat} m@GroupMember {groupMemberId, memberCategory} Connection {viaGroupLink} p' = do + xGrpLinkMem :: GroupInfo -> GroupMember -> Connection -> Profile -> Maybe MemberKey -> CM () + xGrpLinkMem gInfo@GroupInfo {membership, businessChat} m@GroupMember {groupMemberId, memberCategory} Connection {viaGroupLink} p' _memberKey = do -- TODO: store memberKey xGrpLinkMemReceived <- withStore $ \db -> getXGrpLinkMemReceived db groupMemberId if (viaGroupLink || isJust businessChat) && isNothing (memberContactId m) && memberCategory == GCHostMember && not xGrpLinkMemReceived then do @@ -2489,7 +2499,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = updateBusinessChatProfile g@GroupInfo {businessChat} = case businessChat of Just bc | isMainBusinessMember bc m -> do g' <- withStore $ \db -> updateGroupProfileFromMember db user g p' - toView $ CEvtGroupUpdated user g g' (Just m) + toView $ CEvtGroupUpdated user g g' (Just m) False _ -> pure () isMainBusinessMember BusinessChatInfo {chatType, businessId, customerId} GroupMember {memberId} = case chatType of BCBusiness -> businessId == memberId @@ -2733,7 +2743,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = _ -> pure (conn', Nothing) xGrpMemNew :: GroupInfo -> GroupMember -> MemberInfo -> Maybe MsgScope -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope) - xGrpMemNew gInfo m memInfo@(MemberInfo memId memRole _ _) msgScope_ msg brokerTs = do + xGrpMemNew gInfo m memInfo@(MemberInfo memId memRole _ _ _) msgScope_ msg brokerTs = do checkHostRole m memRole if sameMemberId memId (membership gInfo) then pure Nothing @@ -2786,7 +2796,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = pure (announcedMember', Just scopeInfo) xGrpMemIntro :: GroupInfo -> GroupMember -> MemberInfo -> Maybe MemberRestrictions -> CM () - xGrpMemIntro gInfo@GroupInfo {chatSettings} m@GroupMember {memberRole, localDisplayName = c} memInfo@(MemberInfo memId _ memChatVRange _) memRestrictions = do + xGrpMemIntro gInfo@GroupInfo {chatSettings} m@GroupMember {memberRole, localDisplayName = c} memInfo@(MemberInfo memId _ memChatVRange _ _) memRestrictions = do case memberCategory m of GCHostMember -> withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case @@ -2831,7 +2841,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = _ -> messageError "x.grp.mem.inv can be only sent by invitee member" xGrpMemFwd :: GroupInfo -> GroupMember -> MemberInfo -> IntroInvitation -> CM () - xGrpMemFwd gInfo@GroupInfo {membership, chatSettings} m memInfo@(MemberInfo memId memRole memChatVRange _) IntroInvitation {groupConnReq, directConnReq} = do + xGrpMemFwd gInfo@GroupInfo {membership, chatSettings} m memInfo@(MemberInfo memId memRole memChatVRange _ _) IntroInvitation {groupConnReq, directConnReq} = do let GroupMember {memberId = membershipMemId} = membership checkHostRole m memRole toMember <- withStore $ \db -> do @@ -2864,7 +2874,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = withStore' $ \db -> createIntroToMemberContact db user m toMember chatV mcvr groupConnIds directConnIds customUserProfileId subMode xGrpMemRole :: GroupInfo -> GroupMember -> MemberId -> GroupMemberRole -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope) - xGrpMemRole gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId memRole msg brokerTs + xGrpMemRole gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId memRole msg@RcvMessage {msgSigned} brokerTs | membershipMemId == memId = let gInfo' = gInfo {membership = membership {memberRole = memRole}} in changeMemberRole gInfo' membership $ RGEUserRole memRole @@ -2882,7 +2892,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = (gInfo'', m', scopeInfo) <- mkGroupChatScope gInfo' m (ci, cInfo) <- saveRcvChatItemNoParse user (CDGroupRcv gInfo'' scopeInfo m') msg brokerTs (CIRcvGroupEvent gEvent) groupMsgToView cInfo ci - toView CEvtMemberRole {user, groupInfo = gInfo'', byMember = m', member = member {memberRole = memRole}, fromRole, toRole = memRole} + toView CEvtMemberRole {user, groupInfo = gInfo'', byMember = m', member = member {memberRole = memRole}, fromRole, toRole = memRole, msgSigned} pure $ memberEventDeliveryScope member checkHostRole :: GroupMember -> GroupMemberRole -> CM () @@ -2895,12 +2905,12 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = m@GroupMember {memberRole = senderRole} memId MemberRestrictions {restriction} - msg + msg@RcvMessage {msgSigned} brokerTs | membershipMemId == memId = pure Nothing -- ignore - XGrpMemRestrict can be sent to restricted member for efficiency | otherwise = do unknownRole <- unknownMemberRole gInfo - (bm, unknown) <- withStore $ \db -> getCreateUnknownGMByMemberId db vr user gInfo memId Nothing unknownRole + (bm, unknown) <- withStore $ \db -> getCreateUnknownGMByMemberId db vr user gInfo memId "" unknownRole let GroupMember {groupMemberId = bmId, memberRole, blockedByAdmin, memberProfile = bmp} = bm if | blockedByAdmin == mrsBlocked restriction -> pure Nothing @@ -2914,7 +2924,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = (ci, cInfo) <- saveRcvChatItemNoParse user (CDGroupRcv gInfo' scopeInfo m') msg brokerTs ciContent when unknown $ toView $ CEvtUnknownMemberBlocked user gInfo m bm' groupMsgToView cInfo ci - toView CEvtMemberBlockedForAll {user, groupInfo = gInfo', byMember = m', member = bm', blocked} + toView CEvtMemberBlockedForAll {user, groupInfo = gInfo', byMember = m', member = bm', blocked, msgSigned} pure $ memberEventDeliveryScope bm where setMemberBlocked bm = withStore' $ \db -> updateGroupMemberBlocked db user gInfo restriction bm @@ -2928,7 +2938,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = withStore $ \db -> setMemberVectorRelationConnected db refMem sendingMem MRReferencedConnected xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> Bool -> ChatMessage 'Json -> RcvMessage -> UTCTime -> Bool -> CM (Maybe DeliveryJobScope) - xGrpMemDel gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId withMessages chatMsg msg brokerTs forwarded = do + xGrpMemDel gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId withMessages chatMsg msg@RcvMessage {msgSigned} brokerTs forwarded = do let GroupMember {memberId = membershipMemId} = membership if membershipMemId == memId then checkRole membership $ do @@ -2939,7 +2949,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = let membership' = membership {memberStatus = GSMemRemoved} when withMessages $ deleteMessages gInfo membership' SMDSnd deleteMemberItem gInfo RGEUserDeleted - toView $ CEvtDeletedMemberUser user gInfo {membership = membership'} m withMessages + toView $ CEvtDeletedMemberUser user gInfo {membership = membership'} m withMessages msgSigned pure $ Just DJSGroup {jobSpec = DJRelayRemoved} else withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case @@ -2966,7 +2976,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = deletedMember' = deletedMember {memberStatus = GSMemRemoved} when withMessages $ deleteMessages gInfo' deletedMember' SMDRcv unless wasDeleted $ deleteMemberItem gInfo' $ RGEMemberDeleted groupMemberId (fromLocalProfile memberProfile) - toView $ CEvtDeletedMember user gInfo' m deletedMember' withMessages + toView $ CEvtDeletedMember user gInfo' m deletedMember' withMessages msgSigned pure deliveryScope where checkRole GroupMember {memberRole} a @@ -2983,9 +2993,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = | otherwise = markGroupMemberCIsDeleted user gInfo' delMem m forwardToMember :: GroupMember -> CM () forwardToMember member = do - let GroupMember {memberId} = m - memberName = Just $ memberShortenedName m - event = XGrpMsgForward (Just memberId) memberName chatMsg brokerTs + let fwd = GrpMsgForward {fwdSender = FwdMember (memberId' m) (memberShortenedName m), fwdBrokerTs = brokerTs} + event = XGrpMsgForward fwd chatMsg sendGroupMemberMessage gInfo member event isUserGrpFwdRelay :: GroupInfo -> Bool @@ -3015,7 +3024,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = pure $ memberEventDeliveryScope m xGrpDel :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM () - xGrpDel gInfo@GroupInfo {membership} m@GroupMember {memberRole} msg brokerTs = do + xGrpDel gInfo@GroupInfo {membership} m@GroupMember {memberRole} msg@RcvMessage {msgSigned} brokerTs = do when (memberRole /= GROwner) $ throwChatError $ CEGroupUserRole gInfo GROwner withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemGroupDeleted -- TODO [relays] possible improvement is to immediately delete rcv queues if isUserGrpFwdRelay @@ -3023,36 +3032,36 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = (gInfo'', m', scopeInfo) <- mkGroupChatScope gInfo m (ci, cInfo) <- saveRcvChatItemNoParse user (CDGroupRcv gInfo'' scopeInfo m') msg brokerTs (CIRcvGroupEvent RGEGroupDeleted) groupMsgToView cInfo ci - toView $ CEvtGroupDeleted user gInfo'' {membership = membership {memberStatus = GSMemGroupDeleted}} m' + toView $ CEvtGroupDeleted user gInfo'' {membership = membership {memberStatus = GSMemGroupDeleted}} m' msgSigned xGrpInfo :: GroupInfo -> GroupMember -> GroupProfile -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope) - xGrpInfo g@GroupInfo {groupProfile = p, businessChat} m@GroupMember {memberRole} p' msg brokerTs + xGrpInfo g@GroupInfo {groupProfile = p, businessChat} m@GroupMember {memberRole} p' msg@RcvMessage {msgSigned} brokerTs | memberRole < GROwner = messageError "x.grp.info with insufficient member permissions" $> Nothing | otherwise = do case businessChat of Nothing -> unless (p == p') $ do g' <- withStore $ \db -> updateGroupProfile db user g p' (g'', m', scopeInfo) <- mkGroupChatScope g' m - toView $ CEvtGroupUpdated user g g'' (Just m') + toView $ CEvtGroupUpdated user g g'' (Just m') msgSigned let cd = CDGroupRcv g'' scopeInfo m' unless (sameGroupProfileInfo p p') $ do (ci, cInfo) <- saveRcvChatItemNoParse user cd msg brokerTs (CIRcvGroupEvent $ RGEGroupUpdated p') groupMsgToView cInfo ci createGroupFeatureChangedItems user cd CIRcvGroupFeature g g'' void $ forkIO $ void $ setGroupLinkData' NRMBackground user g'' - Just _ -> updateGroupPrefs_ g m $ fromMaybe defaultBusinessGroupPrefs $ groupPreferences p' + Just _ -> updateGroupPrefs_ msgSigned g m $ fromMaybe defaultBusinessGroupPrefs $ groupPreferences p' pure $ Just DJSGroup {jobSpec = DJDeliveryJob {includePending = True}} - xGrpPrefs :: GroupInfo -> GroupMember -> GroupPreferences -> CM (Maybe DeliveryJobScope) - xGrpPrefs g m@GroupMember {memberRole} ps' + xGrpPrefs :: Bool -> GroupInfo -> GroupMember -> GroupPreferences -> CM (Maybe DeliveryJobScope) + xGrpPrefs msgSigned g m@GroupMember {memberRole} ps' | memberRole < GROwner = messageError "x.grp.prefs with insufficient member permissions" $> Nothing - | otherwise = updateGroupPrefs_ g m ps' $> Just DJSGroup {jobSpec = DJDeliveryJob {includePending = True}} + | otherwise = updateGroupPrefs_ msgSigned g m ps' $> Just DJSGroup {jobSpec = DJDeliveryJob {includePending = True}} - updateGroupPrefs_ :: GroupInfo -> GroupMember -> GroupPreferences -> CM () - updateGroupPrefs_ g@GroupInfo {groupProfile = p} m ps' = + updateGroupPrefs_ :: Bool -> GroupInfo -> GroupMember -> GroupPreferences -> CM () + updateGroupPrefs_ msgSigned g@GroupInfo {groupProfile = p} m ps' = unless (groupPreferences p == Just ps') $ do g' <- withStore' $ \db -> updateGroupPreferences db user g ps' - toView $ CEvtGroupUpdated user g g' (Just m) + toView $ CEvtGroupUpdated user g g' (Just m) msgSigned (g'', m', scopeInfo) <- mkGroupChatScope g' m let cd = CDGroupRcv g'' scopeInfo m' createGroupFeatureChangedItems user cd CIRcvGroupFeature g g'' @@ -3146,23 +3155,23 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = toViewTE $ TEContactVerificationReset user ct createInternalChatItem user (CDDirectRcv ct) (CIRcvConnEvent RCEVerificationCodeReset) Nothing - xGrpMsgForward :: GroupInfo -> GroupMember -> Maybe MemberId -> Maybe ContactName -> ChatMessage 'Json -> UTCTime -> UTCTime -> CM () - xGrpMsgForward gInfo m@GroupMember {localDisplayName} memberId_ memberName_ chatMsg msgTs brokerTs = do + xGrpMsgForward :: GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> GrpMsgForward -> ParsedMsg 'Json -> UTCTime -> CM () + xGrpMsgForward gInfo scopeInfo m@GroupMember {localDisplayName} GrpMsgForward {fwdSender, fwdBrokerTs = msgTs} parsedMsg@(ParsedMsg _ _ chatMsg@ChatMessage {chatMsgEvent}) brokerTs = do unless (isMemberGrpFwdRelay gInfo m) $ throwChatError (CEGroupContactRole localDisplayName) - case memberId_ of - Just memberId -> do + case fwdSender of + FwdMember memberId memberName -> do unknownRole <- unknownMemberRole gInfo - (author, unknown) <- withStore $ \db -> getCreateUnknownGMByMemberId db vr user gInfo memberId memberName_ unknownRole + (author, unknown) <- withStore $ \db -> getCreateUnknownGMByMemberId db vr user gInfo memberId memberName unknownRole when unknown $ toView $ CEvtUnknownMemberCreated user gInfo m author - processForwardedMsg (Just author) - Nothing -> processForwardedMsg Nothing + void $ withVerifiedMsg gInfo scopeInfo author parsedMsg msgTs $ + (`processForwardedMsg` Just author) + FwdChannel -> processForwardedMsg (VMUnsigned chatMsg) Nothing where -- ! see isForwardedGroupMsg: forwarded group events should include msgId to be deduplicated - processForwardedMsg :: Maybe GroupMember -> CM () - processForwardedMsg author_ = do - let body = chatMsgToBody chatMsg - rcvMsg_ <- saveGroupFwdRcvMsg user gInfo m author_ body chatMsg brokerTs - forM_ rcvMsg_ $ \rcvMsg@RcvMessage {chatMsgEvent = ACME _ event} -> case event of + processForwardedMsg :: VerifiedMsg 'Json -> Maybe GroupMember -> CM () + processForwardedMsg verifiedMsg author_ = do + rcvMsg_ <- saveGroupFwdRcvMsg user gInfo m author_ verifiedMsg brokerTs + forM_ rcvMsg_ $ \rcvMsg@RcvMessage {msgSigned, chatMsgEvent = ACME _ event} -> case event of XMsgNew mc -> void $ memberCanSend author_ scope $ newGroupContentMessage gInfo author_ mc rcvMsg msgTs True where @@ -3181,7 +3190,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = 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' + XGrpPrefs ps' -> withAuthor XGrpPrefs_ $ \author -> void $ xGrpPrefs msgSigned gInfo author ps' _ -> messageError $ "x.grp.msg.forward: unsupported forwarded event " <> T.pack (show $ toCMEventTag event) where withAuthor :: CMEventTag e -> (GroupMember -> CM ()) -> CM () @@ -3189,6 +3198,27 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = Just author -> action author Nothing -> messageError $ "x.grp.msg.forward: event " <> tshow tag <> " requires author" + withVerifiedMsg :: MsgEncodingI e => GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> ParsedMsg e -> UTCTime -> (VerifiedMsg e -> CM a) -> CM (Maybe a) + withVerifiedMsg gInfo scopeInfo member (ParsedMsg _ signedMsg_ chatMsg@ChatMessage {chatMsgEvent}) ts action + | verified = Just <$> action verifiedMsg + | otherwise = do + createInternalChatItem user (CDGroupRcv gInfo scopeInfo member) (CIRcvGroupEvent RGEMsgBadSignature) (Just ts) + pure Nothing + where + verifiedMsg = case signedMsg_ of + Nothing -> VMUnsigned chatMsg + Just sm -> VMSigned sm chatMsg + verified = case signedMsg_ of + Just SignedMsg {chatBinding, signatures, signedBody} + | GroupMember {memberPubKey = Just pubKey, memberId} <- member -> + case chatBinding of + CBGroup | Just GroupKeys {groupRootKey} <- groupKeys gInfo -> + let prefix = smpEncode chatBinding <> smpEncode (groupRootPubKey groupRootKey, memberId) + in all (\(MsgSignature KRMember sig) -> C.verify (C.APublicVerifyKey C.SEd25519 pubKey) sig (prefix <> signedBody)) signatures + _ -> True -- can't reconstruct binding → accept (enforcement in Step 5) + | otherwise -> True + Nothing -> not (useRelays' gInfo && requiresSignature (toCMEventTag chatMsgEvent)) + directMsgReceived :: Contact -> Connection -> MsgMeta -> NonEmpty MsgReceipt -> CM () directMsgReceived ct conn@Connection {connId} msgMeta msgRcpts = do checkIntegrityCreateItem (CDDirectRcv ct) msgMeta `catchAllErrors` \_ -> pure () @@ -3342,13 +3372,9 @@ 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, 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 + let MessageDeliveryTask {senderGMId, fwdSender, brokerTs = fwdBrokerTs, verifiedMsg} = task + fwd = GrpMsgForward {fwdSender, fwdBrokerTs} + body = encodeBinaryBatch [encodeFwdElement fwd verifiedMsg] withStore' $ \db -> do createMsgDeliveryJob db gInfo jobScope (Just senderGMId) body updateDeliveryTaskStatus db (deliveryTaskId task) DTSProcessed diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 2b9e47bc6a..ef91caaea5 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -512,6 +512,7 @@ data CIMeta (c :: ChatType) (d :: MsgDirection) = CIMeta editable :: Bool, forwardedByMember :: Maybe GroupMemberId, showGroupAsSender :: ShowGroupAsSender, + msgSigned :: Bool, createdAt :: UTCTime, updatedAt :: UTCTime } @@ -519,12 +520,12 @@ data CIMeta (c :: ChatType) (d :: MsgDirection) = CIMeta type ShowGroupAsSender = Bool -mkCIMeta :: forall c d. ChatTypeI c => ChatItemId -> CIContent d -> Text -> CIStatus d -> Maybe Bool -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe (CIDeleted c) -> Bool -> Maybe CITimed -> Maybe Bool -> Bool -> Bool -> UTCTime -> ChatItemTs -> Maybe GroupMemberId -> Bool -> UTCTime -> UTCTime -> CIMeta c d -mkCIMeta itemId itemContent itemText itemStatus sentViaProxy itemSharedMsgId itemForwarded itemDeleted itemEdited itemTimed itemLive userMention hasLink_ currentTs itemTs forwardedByMember showGroupAsSender createdAt updatedAt = +mkCIMeta :: forall c d. ChatTypeI c => ChatItemId -> CIContent d -> Text -> CIStatus d -> Maybe Bool -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe (CIDeleted c) -> Bool -> Maybe CITimed -> Maybe Bool -> Bool -> Bool -> UTCTime -> ChatItemTs -> Maybe GroupMemberId -> Bool -> Bool -> UTCTime -> UTCTime -> CIMeta c d +mkCIMeta itemId itemContent itemText itemStatus sentViaProxy itemSharedMsgId itemForwarded itemDeleted itemEdited itemTimed itemLive userMention hasLink_ currentTs itemTs forwardedByMember showGroupAsSender msgSigned createdAt updatedAt = let deletable = deletable' itemContent itemDeleted itemTs nominalDay currentTs editable = deletable && isNothing itemForwarded hasLink = BoolDef hasLink_ - in CIMeta {itemId, itemTs, itemText, itemStatus, sentViaProxy, itemSharedMsgId, itemForwarded, itemDeleted, itemEdited, itemTimed, itemLive, userMention, hasLink, deletable, editable, forwardedByMember, showGroupAsSender, createdAt, updatedAt} + in CIMeta {itemId, itemTs, itemText, itemStatus, sentViaProxy, itemSharedMsgId, itemForwarded, itemDeleted, itemEdited, itemTimed, itemLive, userMention, hasLink, deletable, editable, forwardedByMember, showGroupAsSender, msgSigned, createdAt, updatedAt} deletable' :: forall c d. ChatTypeI c => CIContent d -> Maybe (CIDeleted c) -> UTCTime -> NominalDiffTime -> UTCTime -> Bool deletable' itemContent itemDeleted itemTs allowedInterval currentTs = @@ -555,6 +556,7 @@ dummyMeta itemId ts itemText = editable = False, forwardedByMember = Nothing, showGroupAsSender = False, + msgSigned = False, createdAt = ts, updatedAt = ts } @@ -1149,23 +1151,22 @@ type ChatItemTs = UTCTime data SndMessage = SndMessage { msgId :: MessageId, sharedMsgId :: SharedMsgId, - msgBody :: MsgBody + msgBody :: MsgBody, + signedMsg_ :: Maybe SignedMsg } deriving (Show) data NewRcvMessage e = NewRcvMessage { chatMsgEvent :: ChatMsgEvent e, - msgBody :: MsgBody, + verifiedMsg :: VerifiedMsg e, brokerTs :: UTCTime } - deriving (Show) data RcvMessage = RcvMessage { msgId :: MessageId, chatMsgEvent :: AChatMsgEvent, sharedMsgId_ :: Maybe SharedMsgId, - msgBody :: MsgBody, - authorMember :: Maybe GroupMemberId, + msgSigned :: Bool, forwardedByMember :: Maybe GroupMemberId } diff --git a/src/Simplex/Chat/Messages/Batch.hs b/src/Simplex/Chat/Messages/Batch.hs index d8868e1787..4684fb0261 100644 --- a/src/Simplex/Chat/Messages/Batch.hs +++ b/src/Simplex/Chat/Messages/Batch.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -6,6 +7,10 @@ module Simplex.Chat.Messages.Batch ( MsgBatch (..), + BatchMode (..), + encodeBatchElement, + encodeFwdElement, + encodeBinaryBatch, batchMessages, batchDeliveryTasks1, ) @@ -22,75 +27,94 @@ import Simplex.Chat.Delivery import Simplex.Chat.Messages import Simplex.Chat.Protocol import Simplex.Chat.Types (VersionRangeChat) +import Simplex.Messaging.Encoding (Large (..), smpEncode, smpEncodeList) + +data BatchMode = BMJson | BMBinary + deriving (Eq, Show) + +-- | Encode a batch element with optional signature prefix. +-- Dual of elementP's '/'/'{'cases. +encodeBatchElement :: Maybe SignedMsg -> ByteString -> ByteString +encodeBatchElement Nothing body = body +encodeBatchElement (Just SignedMsg {chatBinding, signatures}) body = + "/" <> smpEncode (chatBinding, signatures) <> body data MsgBatch = MsgBatch ByteString [SndMessage] --- | Batches SndMessages in [Either ChatError SndMessage] into batches of ByteStrings in form of JSON arrays. +-- | Batches SndMessages in [Either ChatError SndMessage] into batches of ByteStrings. +-- BMJson mode: JSON arrays like [msg1,msg2,...] +-- BMBinary mode: Binary format =()* -- Preserves original errors in the list. --- Does not check if the resulting batch is a valid JSON. --- If a single element is passed, it is returned as is (a JSON string). +-- If a single element is passed, it is returned as is. -- If an element exceeds maxLen, it is returned as ChatError. -batchMessages :: Int -> [Either ChatError SndMessage] -> [Either ChatError MsgBatch] -batchMessages maxLen = addBatch . foldr addToBatch ([], [], 0, 0) +-- Elements are encoded with signature prefix via encodeBatchElement. +batchMessages :: BatchMode -> Int -> [Either ChatError SndMessage] -> [Either ChatError MsgBatch] +batchMessages mode maxLen = addBatch . foldr addToBatch ([], [], [], 0, 0) where - msgBatch batch = Right (MsgBatch (encodeMessages batch) batch) - addToBatch :: Either ChatError SndMessage -> ([Either ChatError MsgBatch], [SndMessage], Int, Int) -> ([Either ChatError MsgBatch], [SndMessage], Int, Int) - addToBatch (Left err) acc = (Left err : addBatch acc, [], 0, 0) -- step over original error - addToBatch (Right msg@SndMessage {msgBody}) acc@(batches, batch, len, n) - | batchLen <= maxLen = (batches, msg : batch, len', n + 1) - | msgLen <= maxLen = (addBatch acc, [msg], msgLen, 1) - | otherwise = (errLarge msg : addBatch acc, [], 0, 0) + addToBatch :: Either ChatError SndMessage -> ([Either ChatError MsgBatch], [ByteString], [SndMessage], Int, Int) -> ([Either ChatError MsgBatch], [ByteString], [SndMessage], Int, Int) + addToBatch (Left err) acc = (Left err : addBatch acc, [], [], 0, 0) -- step over original error + addToBatch (Right msg@SndMessage {msgBody, signedMsg_}) acc@(batches, bodies, msgs, len, n) + | batchLen mode len' n' <= maxLen = (batches, body : bodies, msg : msgs, len', n') + | msgLen <= maxLen = (addBatch acc, [body], [msg], msgLen, 1) + | otherwise = (errLarge msg : addBatch acc, [], [], 0, 0) where - msgLen = B.length msgBody - len' - | n == 0 = msgLen - | otherwise = msgLen + len + 1 -- 1 accounts for comma - batchLen - | n == 0 = len' - | otherwise = len' + 2 -- 2 accounts for opening and closing brackets + body = encodeBatchElement signedMsg_ msgBody + msgLen = B.length body + len' = len + msgLen + n' = n + 1 errLarge SndMessage {msgId} = Left $ ChatError $ CEInternalError ("large message " <> show msgId) - addBatch :: ([Either ChatError MsgBatch], [SndMessage], Int, Int) -> [Either ChatError MsgBatch] - addBatch (batches, batch, _, n) = if n == 0 then batches else msgBatch batch : batches - encodeMessages :: [SndMessage] -> ByteString - encodeMessages = \case - [] -> mempty - [msg] -> body msg - msgs -> B.concat ["[", B.intercalate "," (map body msgs), "]"] - body SndMessage {msgBody} = msgBody + addBatch :: ([Either ChatError MsgBatch], [ByteString], [SndMessage], Int, Int) -> [Either ChatError MsgBatch] + addBatch (batches, bodies, msgs, _, n) + | n == 0 = batches + | otherwise = + let encoded = encodeBatch mode bodies + in Right (MsgBatch encoded msgs) : batches -- | Batches delivery tasks into (batch, [taskIds], [largeTaskIds]). +-- Always uses binary batch format for relay groups. batchDeliveryTasks1 :: VersionRangeChat -> Int -> NonEmpty MessageDeliveryTask -> (ByteString, [Int64], [Int64]) -batchDeliveryTasks1 vr maxLen = toResult . foldl' addToBatch ([], [], [], 0, 0) . L.toList +batchDeliveryTasks1 _vr maxLen = toResult . foldl' addToBatch ([], [], [], 0, 0) . L.toList where addToBatch :: ([ByteString], [Int64], [Int64], Int, Int) -> MessageDeliveryTask -> ([ByteString], [Int64], [Int64], Int, Int) addToBatch (msgBodies, taskIds, largeTaskIds, len, n) task - -- too large: skip msgBody, record taskId in largeTaskIds + -- too large: skip, record taskId in largeTaskIds | msgLen > maxLen = (msgBodies, taskIds, taskId : largeTaskIds, len, n) -- fits: include in batch - | batchLen <= maxLen = (msgBody : msgBodies, taskId : taskIds, largeTaskIds, len', n + 1) - -- doesn’t fit: stop adding further messages + -- batch overhead: '=' + count (2) + 2-byte length prefix per element + | len' + (n + 1) * 2 + 2 <= maxLen = (msgBody : msgBodies, taskId : taskIds, largeTaskIds, len', n + 1) + -- doesn't fit: stop adding further messages | otherwise = (msgBodies, taskIds, largeTaskIds, len, n) where - MessageDeliveryTask {taskId, fwdSender, brokerTs, chatMessage} = task - msgBody = - 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 + MessageDeliveryTask {taskId, fwdSender, brokerTs = fwdBrokerTs, verifiedMsg} = task + msgBody = encodeFwdElement GrpMsgForward {fwdSender, fwdBrokerTs} verifiedMsg msgLen = B.length msgBody - len' - | n == 0 = msgLen - | otherwise = msgLen + len + 1 -- 1 accounts for comma - batchLen - | n == 0 = len' - | otherwise = len' + 2 -- 2 accounts for opening and closing brackets + len' = len + msgLen toResult :: ([ByteString], [Int64], [Int64], Int, Int) -> (ByteString, [Int64], [Int64]) toResult (msgBodies, taskIds, largeTaskIds, _, _) = - (encodeMessages (reverse msgBodies), reverse taskIds, reverse largeTaskIds) - encodeMessages :: [ByteString] -> ByteString - encodeMessages = \case - [] -> mempty - [msg] -> msg - msgs -> B.concat ["[", B.intercalate "," msgs, "]"] + let encoded = encodeBinaryBatch (reverse msgBodies) + in (encoded, reverse taskIds, reverse largeTaskIds) + +-- | Encode a batch element for relay groups: >[/]. +encodeFwdElement :: GrpMsgForward -> VerifiedMsg 'Json -> ByteString +encodeFwdElement fwd verifiedMsg = ">" <> smpEncode fwd <> encodeBatchElement signedMsg_ msgBody + where + (signedMsg_, msgBody) = verifiedMsgParts verifiedMsg + +encodeBatch :: BatchMode -> [ByteString] -> ByteString +encodeBatch _ [] = mempty +encodeBatch _ [msg] = msg +encodeBatch BMJson msgs = B.concat ["[", B.intercalate "," msgs, "]"] +encodeBatch BMBinary msgs = B.cons '=' $ smpEncodeList (map Large msgs) + +-- Always uses batch format (no single-element shortcut) since elements may have F prefix. +encodeBinaryBatch :: [ByteString] -> ByteString +encodeBinaryBatch [] = mempty +encodeBinaryBatch msgs = B.cons '=' $ smpEncodeList (map Large msgs) + +-- Returns length the batch would have if encoded. +-- `len` - the total length of all `n` encoded elements (including signature prefixes) +batchLen :: BatchMode -> Int -> Int -> Int +batchLen _ _ 0 = 0 +batchLen _ len 1 = len +batchLen BMJson len n = len + n + 1 -- (n - 1) commas + 2 brackets +batchLen BMBinary len n = len + n * 2 + 2 -- 2-byte length prefix per element + '=' + count diff --git a/src/Simplex/Chat/Messages/CIContent.hs b/src/Simplex/Chat/Messages/CIContent.hs index fedb6cd8e0..e2e878033d 100644 --- a/src/Simplex/Chat/Messages/CIContent.hs +++ b/src/Simplex/Chat/Messages/CIContent.hs @@ -227,6 +227,7 @@ ciRequiresAttention content = case msgDirection @d of RGEMemberCreatedContact -> False RGEMemberProfileUpdated {} -> False RGENewMemberPendingReview -> True + RGEMsgBadSignature -> False CIRcvConnEvent _ -> True CIRcvChatFeature {} -> False CIRcvChatPreference {} -> False @@ -349,6 +350,7 @@ rcvGroupEventToText = \case RGEMemberCreatedContact -> "started direct connection with you" RGEMemberProfileUpdated {} -> "updated profile" RGENewMemberPendingReview -> "new member wants to join the group" + RGEMsgBadSignature -> "message rejected: bad signature" sndGroupEventToText :: SndGroupEvent -> Text sndGroupEventToText = \case diff --git a/src/Simplex/Chat/Messages/CIContent/Events.hs b/src/Simplex/Chat/Messages/CIContent/Events.hs index adacb06ee4..6406cc74f6 100644 --- a/src/Simplex/Chat/Messages/CIContent/Events.hs +++ b/src/Simplex/Chat/Messages/CIContent/Events.hs @@ -32,6 +32,7 @@ data RcvGroupEvent | RGEMemberCreatedContact -- CRNewMemberContactReceivedInv | RGEMemberProfileUpdated {fromProfile :: Profile, toProfile :: Profile} -- CRGroupMemberUpdated | RGENewMemberPendingReview + | RGEMsgBadSignature deriving (Show) data SndGroupEvent diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 1a5756cf2d..bb42c19aad 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} @@ -21,7 +22,7 @@ module Simplex.Chat.Protocol where import Control.Applicative ((<|>)) -import Control.Monad ((<=<)) +import Control.Monad (when, (<=<)) import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?), (.=)) import qualified Data.Aeson as J import qualified Data.Aeson.Encoding as JE @@ -37,12 +38,13 @@ import Data.Either (fromRight) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, isJust) import Data.String import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Time.Clock (UTCTime) +import Data.Time.Clock.System (systemToUTCTime, utcToSystemTime) import Data.Type.Equality import Data.Typeable (Typeable) import Data.Word (Word32) @@ -54,6 +56,7 @@ import Simplex.Chat.Types.Shared import Simplex.Messaging.Agent.Protocol (VersionSMPA, pqdrSMPAgentVersion) import Simplex.Messaging.Agent.Store.DB (blobFieldDecoder, fromTextField_) import Simplex.Messaging.Compression (Compressed, compress1, decompress1) +import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, fstToLower, parseAll, sumTypeJSON, taggedObjectJSON) @@ -310,6 +313,105 @@ data ChatMessage e = ChatMessage data AChatMessage = forall e. MsgEncodingI e => ACMsg (SMsgEncoding e) (ChatMessage e) +-- Can be extended to support profile identity keys (e.g., secp256k1 for Nostr) +data KeyRef = KRMember + deriving (Eq, Show) + +data ChatBinding = CBGroup + deriving (Eq, Show) + +data MsgSignature = MsgSignature KeyRef C.ASignature + deriving (Show) + +data SignedMsg = SignedMsg + { chatBinding :: ChatBinding, + signatures :: L.NonEmpty MsgSignature, + signedBody :: ByteString -- exact bytes that were signed + } + deriving (Show) + +-- | Post-verification message. Encodes the invariant that signature +-- has been checked (or wasn't required). Store and forward functions +-- accept only VerifiedMsg, preventing unverified messages from being persisted. +data VerifiedMsg e + = VMUnsigned (ChatMessage e) + | VMSigned SignedMsg (ChatMessage e) + +data ParsedMsg e = ParsedMsg (Maybe GrpMsgForward) (Maybe SignedMsg) (ChatMessage e) + +data AParsedMsg = forall e. MsgEncodingI e => APMsg (SMsgEncoding e) (ParsedMsg e) + +data FwdSender + = FwdMember MemberId ContactName + | FwdChannel + deriving (Eq, Show) + +data GrpMsgForward = GrpMsgForward + { fwdSender :: FwdSender, + fwdBrokerTs :: UTCTime + } + deriving (Eq, Show) + + +instance Encoding FwdSender where + smpEncode = \case + FwdMember memberId memberName -> smpEncode ('M', memberId, memberName) + FwdChannel -> "C" + smpP = + A.anyChar >>= \case + 'M' -> uncurry FwdMember <$> smpP + 'C' -> pure FwdChannel + c -> fail $ "invalid FwdSender tag: " <> show c + +instance Encoding GrpMsgForward where + smpEncode GrpMsgForward {fwdSender, fwdBrokerTs} = + smpEncode (fwdSender, utcToSystemTime fwdBrokerTs) + smpP = do + fwdSender <- smpP + fwdBrokerTs <- systemToUTCTime <$> smpP + pure GrpMsgForward {fwdSender, fwdBrokerTs} + +instance Encoding KeyRef where + smpEncode = \case + KRMember -> "M" + smpP = + A.anyChar >>= \case + 'M' -> pure KRMember + c -> fail $ "invalid KeyRef tag: " <> show c + +instance Encoding ChatBinding where + smpEncode CBGroup = "G" + smpP = + A.anyChar >>= \case + 'G' -> pure CBGroup + c -> fail $ "invalid ChatBinding: " <> show c + +instance ToField ChatBinding where toField = toField . decodeLatin1 . smpEncode + +instance FromField ChatBinding where fromField = fromTextField_ $ eitherToMaybe . smpDecode . encodeUtf8 + +instance Encoding MsgSignature where + smpEncode (MsgSignature keyRef sig) = smpEncode (keyRef, C.signatureBytes sig) + smpP = MsgSignature <$> smpP <*> (C.decodeSignature <$?> smpP) + +-- Wire format: ()* +instance Encoding SignedMsg where + smpEncode SignedMsg {chatBinding, signatures, signedBody} = smpEncode (chatBinding, signatures, Tail signedBody) + smpP = do + (chatBinding, signatures, Tail signedBody) <- smpP + pure SignedMsg {chatBinding, signatures, signedBody} + +-- | Generic signing context — data, not function. +-- Callers construct per-event; createSndMessages uses mechanically. +data MsgSigning = MsgSigning + { bindingTag :: ChatBinding, + bindingData :: ByteString, + keyRef :: KeyRef, + privKey :: C.PrivateKeyEd25519 + } + + + data ChatMsgEvent (e :: MsgEncoding) where XMsgNew :: MsgContainer -> ChatMsgEvent 'Json XMsgFileDescr :: {msgId :: SharedMsgId, fileDescr :: FileDescr} -> ChatMsgEvent 'Json @@ -323,13 +425,13 @@ data ChatMsgEvent (e :: MsgEncoding) where XFileCancel :: SharedMsgId -> ChatMsgEvent 'Json XInfo :: Profile -> ChatMsgEvent 'Json XContact :: {profile :: Profile, contactReqId :: Maybe XContactId, welcomeMsgId :: Maybe SharedMsgId, requestMsg :: Maybe (SharedMsgId, MsgContent)} -> ChatMsgEvent 'Json - XMember :: {profile :: Profile, newMemberId :: MemberId} -> ChatMsgEvent 'Json + XMember :: {profile :: Profile, newMemberId :: MemberId, newMemberKey :: MemberKey} -> ChatMsgEvent 'Json XDirectDel :: ChatMsgEvent 'Json XGrpInv :: GroupInvitation -> ChatMsgEvent 'Json XGrpAcpt :: MemberId -> ChatMsgEvent 'Json XGrpLinkInv :: GroupLinkInvitation -> ChatMsgEvent 'Json XGrpLinkReject :: GroupLinkRejection -> ChatMsgEvent 'Json - XGrpLinkMem :: Profile -> ChatMsgEvent 'Json + XGrpLinkMem :: Profile -> Maybe MemberKey -> ChatMsgEvent 'Json XGrpLinkAcpt :: GroupAcceptance -> GroupMemberRole -> MemberId -> ChatMsgEvent 'Json XGrpRelayInv :: GroupRelayInvitation -> ChatMsgEvent 'Json XGrpRelayAcpt :: ShortLinkContact -> ChatMsgEvent 'Json @@ -348,7 +450,7 @@ data ChatMsgEvent (e :: MsgEncoding) where XGrpInfo :: GroupProfile -> ChatMsgEvent 'Json XGrpPrefs :: GroupPreferences -> ChatMsgEvent 'Json XGrpDirectInv :: ConnReqInvitation -> Maybe MsgContent -> Maybe MsgScope -> ChatMsgEvent 'Json - XGrpMsgForward :: Maybe MemberId -> Maybe ContactName -> ChatMessage 'Json -> UTCTime -> ChatMsgEvent 'Json + XGrpMsgForward :: GrpMsgForward -> ChatMessage 'Json -> ChatMsgEvent 'Json XInfoProbe :: Probe -> ChatMsgEvent 'Json XInfoProbeCheck :: ProbeHash -> ChatMsgEvent 'Json XInfoProbeOk :: Probe -> ChatMsgEvent 'Json @@ -673,26 +775,52 @@ encodeChatMessage maxSize msg = do else ECMEncoded body AMBinary m -> ECMEncoded $ strEncode m -parseChatMessages :: ByteString -> [Either String AChatMessage] +parseChatMessages :: ByteString -> [Either String AParsedMsg] parseChatMessages "" = [Left "empty string"] parseChatMessages msg = case B.head msg of 'X' -> decodeCompressed (B.tail msg) c -> parseUncompressed c msg where parseUncompressed c s = case c of - '{' -> [ACMsg SJson <$> J.eitherDecodeStrict' s] '[' -> case J.eitherDecodeStrict' s of - Right v -> map parseItem v + Right v -> map (fmap plainMsg . parseItem) v Left e -> [Left e] - _ -> [ACMsg SBinary <$> (appBinaryToCM =<< strDecode s)] + '=' -> decodeBinaryBatch (B.tail s) + _ -> [parseAll (elementP Nothing) s] + plainMsg = aParsedMsg Nothing Nothing + aParsedMsg fwd sm (ACMsg enc cm) = APMsg enc (ParsedMsg fwd sm cm) + parseMsg s = ACMsg SJson <$> J.eitherDecodeStrict' s + msgP :: A.Parser AChatMessage + msgP = parseMsg <$?> A.takeByteString parseItem :: J.Value -> Either String AChatMessage parseItem v = ACMsg SJson <$> JT.parseEither parseJSON v - decodeCompressed :: ByteString -> [Either String AChatMessage] - decodeCompressed s' = case smpDecode s' of + decodeCompressed :: ByteString -> [Either String AParsedMsg] + decodeCompressed s = case smpDecode s of Left e -> [Left e] - Right (compressed :: L.NonEmpty Compressed) -> concatMap (either (pure . Left) parseUncompressed' . decompress1 maxDecompressedMsgLength) compressed + Right (compressed :: L.NonEmpty Compressed) -> concatMap (either (\e -> [Left e]) parseUncompressed' . decompress1 maxDecompressedMsgLength) compressed parseUncompressed' "" = [Left "empty string"] parseUncompressed' s = parseUncompressed (B.head s) s + -- Binary batch format: '=' ( )* + decodeBinaryBatch :: ByteString -> [Either String AParsedMsg] + decodeBinaryBatch s = case parseAll smpListP s of + Left e -> [Left e] + Right msgs -> map parseBatchElement msgs + parseBatchElement :: Large -> Either String AParsedMsg + parseBatchElement (Large s) = parseAll (elementP Nothing) s + elementP :: Maybe GrpMsgForward -> A.Parser AParsedMsg + elementP fwd = A.peekChar' >>= \case + '/' -> A.char '/' *> do + tag <- smpP + sigs <- smpP + (body, acm) <- A.match msgP + pure $ aParsedMsg fwd (Just $ SignedMsg tag sigs body) acm + '>' -> A.char '>' *> do + when (isJust fwd) $ fail "nested forward elements not supported" + elementP . Just =<< smpP + '{' -> aParsedMsg fwd Nothing <$> msgP + -- 'F' must match BFileChunk_ tag encoding + 'F' -> aParsedMsg fwd Nothing . ACMsg SBinary <$> (appBinaryToCM <$?> strP) + c -> fail $ "invalid element prefix: " <> show c compressedBatchMsgBody_ :: MsgBody -> ByteString compressedBatchMsgBody_ = markCompressedBatch . smpEncode . (L.:| []) . compress1 @@ -997,7 +1125,7 @@ toCMEventTag msg = case msg of XGrpAcpt _ -> XGrpAcpt_ XGrpLinkInv _ -> XGrpLinkInv_ XGrpLinkReject _ -> XGrpLinkReject_ - XGrpLinkMem _ -> XGrpLinkMem_ + XGrpLinkMem _ _ -> XGrpLinkMem_ XGrpLinkAcpt {} -> XGrpLinkAcpt_ XGrpRelayInv _ -> XGrpRelayInv_ XGrpRelayAcpt _ -> XGrpRelayAcpt_ @@ -1063,6 +1191,17 @@ hasDeliveryReceipt = \case XCallInv_ -> True _ -> False +-- | Admin events that must have a valid signature in relay groups. +requiresSignature :: CMEventTag e -> Bool +requiresSignature = \case + XGrpDel_ -> True + XGrpInfo_ -> True + XGrpPrefs_ -> True + XGrpMemDel_ -> True + XGrpMemRole_ -> True + XGrpMemRestrict_ -> True + _ -> False + appBinaryToCM :: AppMessageBinary -> Either String (ChatMessage 'Binary) appBinaryToCM AppMessageBinary {msgId, tag, body} = do eventTag <- strDecode $ B.singleton tag @@ -1112,13 +1251,13 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do reqContent <- opt "content" let requestMsg = (,) <$> reqMsgId <*> reqContent pure XContact {profile, contactReqId, welcomeMsgId, requestMsg} - XMember_ -> XMember <$> p "profile" <*> p "newMemberId" + XMember_ -> XMember <$> p "profile" <*> p "newMemberId" <*> p "newMemberKey" XDirectDel_ -> pure XDirectDel XGrpInv_ -> XGrpInv <$> p "groupInvitation" XGrpAcpt_ -> XGrpAcpt <$> p "memberId" XGrpLinkInv_ -> XGrpLinkInv <$> p "groupLinkInvitation" XGrpLinkReject_ -> XGrpLinkReject <$> p "groupLinkRejection" - XGrpLinkMem_ -> XGrpLinkMem <$> p "profile" + XGrpLinkMem_ -> XGrpLinkMem <$> p "profile" <*> opt "memberKey" XGrpLinkAcpt_ -> XGrpLinkAcpt <$> p "acceptance" <*> p "role" <*> p "memberId" XGrpRelayInv_ -> XGrpRelayInv <$> p "groupRelayInvitation" XGrpRelayAcpt_ -> XGrpRelayAcpt <$> p "relayLink" @@ -1137,7 +1276,12 @@ 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 <$> opt "memberId" <*> opt "memberName" <*> p "msg" <*> p "msgTs" + XGrpMsgForward_ -> do + fwdSender <- opt "memberId" >>= \case + Just memberId -> FwdMember memberId . fromMaybe "" <$> opt "memberName" + Nothing -> pure FwdChannel + fwdBrokerTs <- p "msgTs" + XGrpMsgForward (GrpMsgForward {fwdSender, fwdBrokerTs}) <$> p "msg" XInfoProbe_ -> XInfoProbe <$> p "probe" XInfoProbeCheck_ -> XInfoProbeCheck <$> p "probeHash" XInfoProbeOk_ -> XInfoProbeOk <$> p "probe" @@ -1174,13 +1318,13 @@ chatToAppMessage chatMsg@ChatMessage {chatVRange, msgId, chatMsgEvent} = case en XFileCancel sharedMsgId -> o ["msgId" .= sharedMsgId] XInfo profile -> o ["profile" .= profile] XContact {profile, contactReqId, welcomeMsgId, requestMsg} -> o $ ("contactReqId" .=? contactReqId) $ ("welcomeMsgId" .=? welcomeMsgId) $ ("msgId" .=? (fst <$> requestMsg)) $ ("content" .=? (snd <$> requestMsg)) $ ["profile" .= profile] - XMember {profile, newMemberId} -> o ["profile" .= profile, "newMemberId" .= newMemberId] + XMember {profile, newMemberId, newMemberKey} -> o ["profile" .= profile, "newMemberId" .= newMemberId, "newMemberKey" .= newMemberKey] XDirectDel -> JM.empty XGrpInv groupInv -> o ["groupInvitation" .= groupInv] XGrpAcpt memId -> o ["memberId" .= memId] XGrpLinkInv groupLinkInv -> o ["groupLinkInvitation" .= groupLinkInv] XGrpLinkReject groupLinkRjct -> o ["groupLinkRejection" .= groupLinkRjct] - XGrpLinkMem profile -> o ["profile" .= profile] + XGrpLinkMem profile memberKey -> o $ ("memberKey" .=? memberKey) ["profile" .= profile] XGrpLinkAcpt acceptance role memberId -> o ["acceptance" .= acceptance, "role" .= role, "memberId" .= memberId] XGrpRelayInv groupRelayInv -> o ["groupRelayInvitation" .= groupRelayInv] XGrpRelayAcpt relayLink -> o ["relayLink" .= relayLink] @@ -1199,7 +1343,11 @@ 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 $ ("memberId" .=? memberId) $ ("memberName" .=? memberName) ["msg" .= msg, "msgTs" .= msgTs] + XGrpMsgForward GrpMsgForward {fwdSender, fwdBrokerTs} msg -> o $ encodeFwdSender fwdSender ["msg" .= msg, "msgTs" .= fwdBrokerTs] + where + encodeFwdSender = \case + FwdMember memberId memberName -> (["memberId" .= memberId, "memberName" .= memberName] ++) + FwdChannel -> id XInfoProbe probe -> o ["probe" .= probe] XInfoProbeCheck probeHash -> o ["probeHash" .= probeHash] XInfoProbeOk probe -> o ["probe" .= probe] @@ -1220,6 +1368,20 @@ chatMsgToBody chatMsg = case encoding @e of SBinary -> chatMsgBinaryToBody chatMsg SJson -> LB.toStrict $ J.encode chatMsg +verifiedChatMsg :: VerifiedMsg e -> ChatMessage e +verifiedChatMsg = \case + VMUnsigned cm -> cm + VMSigned _ cm -> cm + +-- | Canonical bytes to store/forward, with optional signature. +-- Signed: original bytes (re-encoding would invalidate signature). +-- Unsigned: re-encoded from parsed ChatMessage (sanitizes stored content). +verifiedMsgParts :: MsgEncodingI e => VerifiedMsg e -> (Maybe SignedMsg, ByteString) +verifiedMsgParts = \case + VMUnsigned chatMsg -> (Nothing, chatMsgToBody chatMsg) + VMSigned sm@SignedMsg {signedBody} _ -> (Just sm, signedBody) + + instance ToJSON (ChatMessage 'Json) where toJSON = (\(AMJson msg) -> toJSON msg) . chatToAppMessage @@ -1244,3 +1406,4 @@ data GroupShortLinkData = GroupShortLinkData $(JQ.deriveJSON defaultJSON ''ContactShortLinkData) $(JQ.deriveJSON defaultJSON ''GroupShortLinkData) + diff --git a/src/Simplex/Chat/Store/Delivery.hs b/src/Simplex/Chat/Store/Delivery.hs index de12b0deb7..5b060f5ca8 100644 --- a/src/Simplex/Chat/Store/Delivery.hs +++ b/src/Simplex/Chat/Store/Delivery.hs @@ -29,8 +29,10 @@ module Simplex.Chat.Store.Delivery ) where +import qualified Data.Aeson as J import Data.ByteString.Char8 (ByteString) import Data.Int (Int64) +import qualified Data.List.NonEmpty as L import Data.Text (Text) import Data.Time.Clock (UTCTime, getCurrentTime) import Simplex.Chat.Delivery @@ -40,7 +42,8 @@ import Simplex.Chat.Types import Simplex.Messaging.Agent.Store.AgentStore (getWorkItem, getWorkItems, maybeFirstRow) import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..)) import qualified Simplex.Messaging.Agent.Store.DB as DB -import Simplex.Messaging.Util (firstRow') +import Simplex.Messaging.Encoding (smpDecode) +import Simplex.Messaging.Util (eitherToMaybe, firstRow') #if defined(dbPostgres) import Database.PostgreSQL.Simple (In (..), Only (..), (:.) (..)) import Database.PostgreSQL.Simple.SqlQQ (sql) @@ -125,7 +128,7 @@ getNextDeliveryTask db deliveryKey = do |] (groupId, workerScope, DTSNew) -type MessageDeliveryTaskRow = (Only Int64) :. DeliveryJobScopeRow :. (GroupMemberId, MemberId, ContactName, UTCTime, ChatMessage 'Json, BoolInt) +type MessageDeliveryTaskRow = (Only Int64) :. DeliveryJobScopeRow :. (GroupMemberId, MemberId, ContactName, UTCTime, Binary ByteString, Maybe ChatBinding, Maybe (Binary ByteString), BoolInt) getMsgDeliveryTask_ :: DB.Connection -> Int64 -> IO (Either StoreError MessageDeliveryTask) getMsgDeliveryTask_ db taskId = @@ -136,7 +139,7 @@ getMsgDeliveryTask_ db taskId = SELECT t.delivery_task_id, t.worker_scope, t.job_scope_spec_tag, t.job_scope_include_pending, t.job_scope_support_gm_id, - m.group_member_id, m.member_id, p.display_name, msg.broker_ts, msg.msg_body, t.message_from_channel + m.group_member_id, m.member_id, p.display_name, msg.broker_ts, msg.msg_body, msg.msg_chat_binding, msg.msg_signatures, t.message_from_channel FROM delivery_tasks t JOIN messages msg ON msg.message_id = t.message_id JOIN group_members m ON m.group_member_id = t.sender_group_member_id @@ -146,12 +149,21 @@ getMsgDeliveryTask_ db taskId = (Only taskId) where toTask :: MessageDeliveryTaskRow -> Either StoreError MessageDeliveryTask - toTask ((Only taskId') :. jobScopeRow :. (senderGMId, senderMemberId, senderMemberName, brokerTs, chatMessage, BI showGroupAsSender)) = - case toJobScope_ jobScopeRow of - Just jobScope -> + toTask ((Only taskId') :. jobScopeRow :. (senderGMId, senderMemberId, senderMemberName, brokerTs, Binary msgBody, chatBinding_, sigs_, BI showGroupAsSender)) = + case (toJobScope_ jobScopeRow, J.eitherDecodeStrict' msgBody) of + (Just jobScope, Right chatMsg) -> let fwdSender = if showGroupAsSender then FwdChannel else FwdMember senderMemberId senderMemberName - in Right $ MessageDeliveryTask {taskId = taskId', jobScope, senderGMId, fwdSender, brokerTs, chatMessage} - Nothing -> Left $ SEInvalidDeliveryTask taskId' + -- Re-parsed from msg_body: validates stored content against current code. + -- Signed: original bytes preserved (re-encoding would invalidate signature). + -- Unsigned: re-encoded from parsed ChatMessage on forward (sanitizes content). + verifiedMsg = case (chatBinding_, decodeSigs sigs_) of + (Just cb, Just sigs) -> VMSigned (SignedMsg cb sigs msgBody) chatMsg + _ -> VMUnsigned chatMsg + in Right $ MessageDeliveryTask {taskId = taskId', jobScope, senderGMId, fwdSender, brokerTs, verifiedMsg} + (Nothing, _) -> Left $ SEInvalidDeliveryTask taskId' + (_, Left _) -> Left $ SEInvalidDeliveryTask taskId' + decodeSigs :: Maybe (Binary ByteString) -> Maybe (L.NonEmpty MsgSignature) + decodeSigs = (>>= eitherToMaybe . smpDecode . (\(Binary bs) -> bs)) markDeliveryTaskFailed_ :: DB.Connection -> Int64 -> IO () markDeliveryTaskFailed_ db taskId = diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index d13003dce8..3ad4e3c71c 100644 --- a/src/Simplex/Chat/Store/Groups.hs +++ b/src/Simplex/Chat/Store/Groups.hs @@ -1087,12 +1087,12 @@ getGroupMemberByMemberId db vr user GroupInfo {groupId} memberId = (groupMemberQuery <> " WHERE m.group_id = ? AND m.member_id = ?") (groupId, memberId) -getCreateUnknownGMByMemberId :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> MemberId -> Maybe ContactName -> GroupMemberRole -> ExceptT StoreError IO (GroupMember, Bool) +getCreateUnknownGMByMemberId :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> MemberId -> ContactName -> GroupMemberRole -> ExceptT StoreError IO (GroupMember, Bool) getCreateUnknownGMByMemberId db vr user gInfo memberId memberName unknownMemberRole = do liftIO (runExceptT $ getGroupMemberByMemberId db vr user gInfo memberId) >>= \case Right m -> pure (m, False) Left (SEGroupMemberNotFoundByMemberId _) -> do - let name = fromMaybe (nameFromMemberId memberId) memberName + let name = if T.null memberName then nameFromMemberId memberId else memberName m <- createNewUnknownGroupMember db vr user gInfo memberId name unknownMemberRole pure (m, True) Left e -> throwError e @@ -1701,7 +1701,7 @@ updateGroupMemberKeys db groupId sharedGroupId rootPubKey memberPrivKey membersh DB.execute db "UPDATE groups SET shared_group_id = ?, root_pub_key = ?, member_priv_key = ?, updated_at = ? WHERE group_id = ?" - (sharedGroupId, rootPubKey, memberPrivKey, currentTs, groupId) + (Binary sharedGroupId, rootPubKey, memberPrivKey, currentTs, groupId) DB.execute db "UPDATE group_members SET member_pub_key = ?, updated_at = ? WHERE group_member_id = ?" @@ -1838,7 +1838,7 @@ createNewMember_ User {userId, userContactId} GroupInfo {groupId} NewGroupMember - { memInfo = MemberInfo memberId memberRole memChatVRange memberProfile, + { memInfo = MemberInfo memberId memberRole memChatVRange memberProfile _memKey, memCategory = memberCategory, memStatus = memberStatus, memRestriction, @@ -2004,7 +2004,7 @@ createIntroReMember db user gInfo - memInfo@(MemberInfo _ _ _ memberProfile) + memInfo@(MemberInfo _ _ _ memberProfile _) memRestrictions_ = do currentTs <- liftIO getCurrentTime (localDisplayName, memProfileId) <- createNewMemberProfile_ db user memberProfile currentTs @@ -2019,7 +2019,7 @@ createIntroReMemberConn _host@GroupMember {memberContactId, activeConn} reMember@GroupMember {groupMemberId} chatV - (MemberInfo _ _ memChatVRange _) + (MemberInfo _ _ memChatVRange _ _) (groupCmdId, groupAgentConnId) subMode = do let mcvr = maybe chatInitialVRange fromChatVRange memChatVRange diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index 50bd3eaeae..26c9d5c60a 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -151,7 +151,7 @@ import Data.Char (toLower) import Data.Either (fromRight, rights) import Data.Int (Int64) import Data.List (foldl', sortBy) -import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M @@ -179,6 +179,7 @@ import Simplex.Messaging.Agent.Store.DB (BoolInt (..)) import qualified Simplex.Messaging.Agent.Store.DB as DB import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..)) +import Simplex.Messaging.Encoding (smpDecode, smpEncode) import Simplex.Messaging.Util (eitherToMaybe) import UnliftIO.STM #if defined(dbPostgres) @@ -218,24 +219,29 @@ deleteGroupChatItemsMessages db User {userId} GroupInfo {groupId} = do DB.execute db "DELETE FROM chat_item_reactions WHERE group_id = ?" (Only groupId) DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND group_id = ? AND item_content_tag != 'chatBanner'" (userId, groupId) -createNewSndMessage :: MsgEncodingI e => DB.Connection -> TVar ChaChaDRG -> ConnOrGroupId -> ChatMsgEvent e -> (SharedMsgId -> EncodedChatMessage) -> ExceptT StoreError IO SndMessage -createNewSndMessage db gVar connOrGroupId chatMsgEvent encodeMessage = +createNewSndMessage :: MsgEncodingI e => DB.Connection -> TVar ChaChaDRG -> ConnOrGroupId -> ChatMsgEvent e -> Maybe MsgSigning -> (SharedMsgId -> EncodedChatMessage) -> ExceptT StoreError IO SndMessage +createNewSndMessage db gVar connOrGroupId chatMsgEvent msgSigning_ encodeMessage = createWithRandomId' db gVar $ \sharedMsgId -> case encodeMessage (SharedMsgId sharedMsgId) of ECMLarge -> pure $ Left SELargeMsg ECMEncoded msgBody -> do + let signedMsg_ = signBody <$> msgSigning_ + signBody MsgSigning {bindingTag, bindingData, keyRef, privKey} = + let sig = C.ASignature C.SEd25519 $ C.sign' privKey (smpEncode bindingTag <> bindingData <> msgBody) + in SignedMsg {chatBinding = bindingTag, signatures = MsgSignature keyRef sig :| [], signedBody = msgBody} createdAt <- getCurrentTime DB.execute db [sql| INSERT INTO messages ( - msg_sent, chat_msg_event, msg_body, connection_id, group_id, + msg_sent, chat_msg_event, msg_body, msg_chat_binding, msg_signatures, connection_id, group_id, shared_msg_id, shared_msg_id_user, created_at, updated_at - ) VALUES (?,?,?,?,?,?,?,?,?) + ) VALUES (?,?,?,?,?,?,?,?,?,?,?) |] - (MDSnd, toCMEventTag chatMsgEvent, DB.Binary msgBody, connId_, groupId_, DB.Binary sharedMsgId, Just (BI True), createdAt, createdAt) + ((MDSnd, toCMEventTag chatMsgEvent, DB.Binary msgBody, chatBinding <$> signedMsg_, smpEncode . signatures <$> signedMsg_, connId_, groupId_) + :. (DB.Binary sharedMsgId, Just (BI True), createdAt, createdAt)) msgId <- insertedRowId db - pure $ Right SndMessage {msgId, sharedMsgId = SharedMsgId sharedMsgId, msgBody} + pure $ Right SndMessage {msgId, sharedMsgId = SharedMsgId sharedMsgId, msgBody, signedMsg_} where (connId_, groupId_) = case connOrGroupId of ConnectionId connId -> (Just connId, Nothing) @@ -287,7 +293,7 @@ getLastRcvMsgInfo db connId = RcvMsgInfo {msgId, msgDeliveryId, msgDeliveryStatus, agentMsgId, agentMsgMeta} createNewRcvMessage :: forall e. MsgEncodingI e => DB.Connection -> ConnOrGroupId -> NewRcvMessage e -> Maybe SharedMsgId -> Maybe GroupMemberId -> Maybe GroupMemberId -> ExceptT StoreError IO RcvMessage -createNewRcvMessage db connOrGroupId NewRcvMessage {chatMsgEvent, msgBody, brokerTs} sharedMsgId_ authorMember forwardedByMember = +createNewRcvMessage db connOrGroupId NewRcvMessage {chatMsgEvent, verifiedMsg, brokerTs} sharedMsgId_ authorMember forwardedByMember = case connOrGroupId of ConnectionId connId -> liftIO $ insertRcvMsg (Just connId) Nothing GroupId groupId -> case sharedMsgId_ of @@ -315,14 +321,15 @@ createNewRcvMessage db connOrGroupId NewRcvMessage {chatMsgEvent, msgBody, broke db [sql| INSERT INTO messages - (msg_sent, chat_msg_event, msg_body, broker_ts, created_at, updated_at, connection_id, group_id, + (msg_sent, chat_msg_event, msg_body, msg_chat_binding, msg_signatures, broker_ts, created_at, updated_at, connection_id, group_id, shared_msg_id, author_group_member_id, forwarded_by_group_member_id) - VALUES (?,?,?,?,?,?,?,?,?,?,?) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?) |] - ((MDRcv, toCMEventTag chatMsgEvent, DB.Binary msgBody, brokerTs, currentTs, currentTs, connId_, groupId_) + ((MDRcv, toCMEventTag chatMsgEvent, DB.Binary msgBody, chatBinding <$> signedMsg_, smpEncode . signatures <$> signedMsg_, brokerTs, currentTs, currentTs, connId_, groupId_) :. (sharedMsgId_, authorMember, forwardedByMember)) msgId <- insertedRowId db - pure RcvMessage {msgId, chatMsgEvent = ACME (encoding @e) chatMsgEvent, sharedMsgId_, msgBody, authorMember, forwardedByMember} + pure RcvMessage {msgId, chatMsgEvent = ACME (encoding @e) chatMsgEvent, sharedMsgId_, msgSigned = isJust signedMsg_, forwardedByMember} + (signedMsg_, msgBody) = verifiedMsgParts verifiedMsg updateSndMsgDeliveryStatus :: DB.Connection -> Int64 -> AgentMsgId -> MsgDeliveryStatus 'MDSnd -> IO () updateSndMsgDeliveryStatus db connId agentMsgId sndMsgDeliveryStatus = do @@ -353,7 +360,7 @@ getPendingGroupMessages db groupMemberId = <$> DB.query db [sql| - SELECT pgm.message_id, m.shared_msg_id, m.msg_body + SELECT pgm.message_id, m.shared_msg_id, m.msg_body, m.msg_chat_binding, m.msg_signatures FROM pending_group_messages pgm JOIN messages m USING (message_id) WHERE pgm.group_member_id = ? @@ -361,8 +368,9 @@ getPendingGroupMessages db groupMemberId = |] (Only groupMemberId) where - pendingGroupMessage (msgId, sharedMsgId, msgBody) = - SndMessage {msgId, sharedMsgId, msgBody} + pendingGroupMessage (msgId, sharedMsgId, msgBody, chatBinding_ :: Maybe ChatBinding, sigs_ :: Maybe ByteString) = + let signedMsg_ = SignedMsg <$> chatBinding_ <*> (sigs_ >>= eitherToMaybe . smpDecode) <*> pure msgBody + in SndMessage {msgId, sharedMsgId, msgBody, signedMsg_} deletePendingGroupMessage :: DB.Connection -> Int64 -> MessageId -> IO () deletePendingGroupMessage db groupMemberId messageId = @@ -526,8 +534,8 @@ setSupportChatMemberAttention db vr user g m memberAttention = do pure $ either (const m) id m_ -- Left shouldn't happen, but types require it 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 +createNewSndChatItem db user chatDirection showGroupAsSender SndMessage {msgId, sharedMsgId, signedMsg_} ciContent quotedItem itemForwarded timed live hasLink createdAt = + createNewChatItem_ db user chatDirection showGroupAsSender createdByMsgId (Just sharedMsgId) ciContent quoteRow itemForwarded timed live False hasLink createdAt Nothing (isJust signedMsg_) createdAt where createdByMsgId = if msgId == 0 then Nothing else Just msgId quoteRow :: NewQuoteRow @@ -542,9 +550,9 @@ createNewSndChatItem db user chatDirection showGroupAsSender SndMessage {msgId, CIQGroupRcv Nothing -> (Just False, Nothing) 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 +createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, msgSigned, forwardedByMember} sharedMsgId_ ciContent timed live userMention hasLink itemTs createdAt = do 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 + ciId <- createNewChatItem_ db user chatDirection showAsGroup (Just msgId) sharedMsgId_ ciContent quoteRow itemForwarded timed live userMention hasLink itemTs forwardedByMember msgSigned createdAt quotedItem <- mapM (getChatItemQuote_ db user chatDirection) quotedMsg pure (ciId, quotedItem, itemForwarded) where @@ -563,13 +571,13 @@ createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, forw 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 = - createNewChatItem_ db user chatDirection showGroupAsSender Nothing sharedMsgId_ ciContent quoteRow Nothing Nothing False False hasLink itemTs Nothing + createNewChatItem_ db user chatDirection showGroupAsSender Nothing sharedMsgId_ ciContent quoteRow Nothing Nothing False False hasLink itemTs Nothing False where quoteRow :: NewQuoteRow quoteRow = (Nothing, Nothing, Nothing, Nothing, Nothing) -createNewChatItem_ :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> ShowGroupAsSender -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> Bool -> UTCTime -> Maybe GroupMemberId -> UTCTime -> IO ChatItemId -createNewChatItem_ db User {userId} chatDirection showGroupAsSender msgId_ sharedMsgId ciContent quoteRow itemForwarded timed live userMention hasLink itemTs forwardedByMember createdAt = do +createNewChatItem_ :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> ShowGroupAsSender -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> Bool -> UTCTime -> Maybe GroupMemberId -> Bool -> UTCTime -> IO ChatItemId +createNewChatItem_ db User {userId} chatDirection showGroupAsSender msgId_ sharedMsgId ciContent quoteRow itemForwarded timed live userMention hasLink itemTs forwardedByMember msgSigned createdAt = do DB.execute db [sql| @@ -578,20 +586,20 @@ createNewChatItem_ db User {userId} chatDirection showGroupAsSender msgId_ share user_id, created_by_msg_id, contact_id, group_id, group_member_id, note_folder_id, group_scope_tag, group_scope_group_member_id, -- meta item_sent, item_ts, item_content, item_content_tag, item_text, item_status, msg_content_tag, shared_msg_id, - forwarded_by_group_member_id, include_in_history, created_at, updated_at, item_live, user_mention, has_link, show_group_as_sender, timed_ttl, timed_delete_at, + forwarded_by_group_member_id, include_in_history, created_at, updated_at, item_live, user_mention, has_link, show_group_as_sender, msg_signed, timed_ttl, timed_delete_at, -- quote quoted_shared_msg_id, quoted_sent_at, quoted_content, quoted_sent, quoted_member_id, -- forwarded from fwd_from_tag, fwd_from_chat_name, fwd_from_msg_dir, fwd_from_contact_id, fwd_from_group_id, fwd_from_chat_item_id - ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) + ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) |] ((userId, msgId_) :. idsRow :. groupScopeRow :. itemRow :. quoteRow' :. forwardedFromRow) ciId <- insertedRowId db forM_ msgId_ $ \msgId -> insertChatItemMessage_ db ciId msgId createdAt pure ciId where - itemRow :: (SMsgDirection d, UTCTime, CIContent d, Text, Text, CIStatus d, Maybe MsgContentTag, Maybe SharedMsgId, Maybe GroupMemberId, BoolInt) :. (UTCTime, UTCTime, Maybe BoolInt, BoolInt, BoolInt, BoolInt) :. (Maybe Int, Maybe UTCTime) - itemRow = (msgDirection @d, itemTs, ciContent, toCIContentTag ciContent, ciContentToText ciContent, ciCreateStatus ciContent, msgContentTag <$> ciMsgContent ciContent, sharedMsgId, forwardedByMember, BI includeInHistory) :. (createdAt, createdAt, BI <$> justTrue live, BI userMention, BI hasLink, BI showGroupAsSender) :. ciTimedRow timed + itemRow :: (SMsgDirection d, UTCTime, CIContent d, Text, Text, CIStatus d, Maybe MsgContentTag, Maybe SharedMsgId, Maybe GroupMemberId, BoolInt) :. (UTCTime, UTCTime, Maybe BoolInt, BoolInt, BoolInt, BoolInt, BoolInt) :. (Maybe Int, Maybe UTCTime) + itemRow = (msgDirection @d, itemTs, ciContent, toCIContentTag ciContent, ciContentToText ciContent, ciCreateStatus ciContent, msgContentTag <$> ciMsgContent ciContent, sharedMsgId, forwardedByMember, BI includeInHistory) :. (createdAt, createdAt, BI <$> justTrue live, BI userMention, BI hasLink, BI showGroupAsSender, BI msgSigned) :. ciTimedRow timed quoteRow' = let (a, b, c, d, e) = quoteRow in (a, b, c, BI <$> d, e) idsRow :: (Maybe ContactId, Maybe GroupId, Maybe GroupMemberId, Maybe NoteFolderId) idsRow = case chatDirection of @@ -1056,7 +1064,7 @@ getLocalChatPreview_ db user (LocalChatPD _ noteFolderId lastItemId_ stats) = do -- this function can be changed so it never fails, not only avoid failure on invalid json toLocalChatItem :: UTCTime -> ChatItemRow -> Either StoreError (CChatItem 'CTLocal) -toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) = +toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink, BI msgSigned) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) = chatItem $ fromRight invalid $ dbParseACIContent itemContentText where invalid = ACIContent msgDir $ CIInvalidJSON itemContentText @@ -1089,7 +1097,7 @@ toLocalChatItem currentTs ((itemId, itemTs, AMsgDirection msgDir, itemContentTex _ -> Just (CIDeleted @'CTLocal deletedTs) itemEdited' = maybe False unBI itemEdited itemForwarded = toCIForwardedFrom forwardedFromRow - in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs Nothing False createdAt updatedAt + in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs Nothing False msgSigned createdAt updatedAt ciTimed :: Maybe CITimed ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} @@ -2210,7 +2218,7 @@ updateLocalChatItemsRead db User {userId} noteFolderId = do type MaybeCIFIleRow = (Maybe Int64, Maybe String, Maybe Integer, Maybe FilePath, Maybe C.SbKey, Maybe C.CbNonce, Maybe ACIFileStatus, Maybe FileProtocol) -type ChatItemModeRow = (Maybe Int, Maybe UTCTime, Maybe BoolInt, BoolInt, BoolInt) +type ChatItemModeRow = (Maybe Int, Maybe UTCTime, Maybe BoolInt, BoolInt, BoolInt, BoolInt) type ChatItemForwardedFromRow = (Maybe CIForwardedFromTag, Maybe Text, Maybe MsgDirection, Maybe Int64, Maybe Int64, Maybe Int64) @@ -2234,7 +2242,7 @@ toQuote (quotedItemId, quotedSharedMsgId, quotedSentAt, quotedMsgContent, _) dir -- this function can be changed so it never fails, not only avoid failure on invalid json toDirectChatItem :: UTCTime -> ChatItemRow :. QuoteRow -> Either StoreError (CChatItem 'CTDirect) -toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. quoteRow) = +toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow :. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink, BI msgSigned) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. quoteRow) = chatItem $ fromRight invalid $ dbParseACIContent itemContentText where invalid = ACIContent msgDir $ CIInvalidJSON itemContentText @@ -2267,7 +2275,7 @@ toDirectChatItem currentTs (((itemId, itemTs, AMsgDirection msgDir, itemContentT _ -> Just (CIDeleted @'CTDirect deletedTs) itemEdited' = maybe False unBI itemEdited itemForwarded = toCIForwardedFrom forwardedFromRow - in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs Nothing False createdAt updatedAt + in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs Nothing False msgSigned createdAt updatedAt ciTimed :: Maybe CITimed ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} @@ -2305,7 +2313,7 @@ toGroupChatItem ( ( (itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sentViaProxy, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. forwardedFromRow - :. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink) + :. (timedTTL, timedDeleteAt, itemLive, BI userMention, BI hasLink, BI msgSigned) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_) ) :. (forwardedByMember, BI showGroupAsSender) @@ -2356,7 +2364,7 @@ toGroupChatItem _ -> Just (maybe (CIDeleted @'CTGroup deletedTs) (CIModerated deletedTs) deletedByGroupMember_) itemEdited' = maybe False unBI itemEdited itemForwarded = toCIForwardedFrom forwardedFromRow - in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs forwardedByMember showGroupAsSender createdAt updatedAt + in mkCIMeta itemId content itemText status (unBI <$> sentViaProxy) sharedMsgId itemForwarded itemDeleted' itemEdited' ciTimed (unBI <$> itemLive) userMention hasLink currentTs itemTs forwardedByMember showGroupAsSender msgSigned createdAt updatedAt ciTimed :: Maybe CITimed ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} @@ -2629,7 +2637,7 @@ getDirectChatItem db User {userId} contactId itemId = ExceptT $ do i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.via_proxy, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.fwd_from_tag, i.fwd_from_chat_name, i.fwd_from_msg_dir, i.fwd_from_contact_id, i.fwd_from_group_id, i.fwd_from_chat_item_id, - i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, + i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed, -- CIFile f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, -- DirectQuote @@ -2984,7 +2992,7 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.via_proxy, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.fwd_from_tag, i.fwd_from_chat_name, i.fwd_from_msg_dir, i.fwd_from_contact_id, i.fwd_from_group_id, i.fwd_from_chat_item_id, - i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, + i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed, -- CIFile f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, -- CIMeta forwardedByMember, showGroupAsSender @@ -3093,7 +3101,7 @@ getLocalChatItem db User {userId} folderId itemId = ExceptT $ do i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.via_proxy, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.fwd_from_tag, i.fwd_from_chat_name, i.fwd_from_msg_dir, i.fwd_from_contact_id, i.fwd_from_group_id, i.fwd_from_chat_item_id, - i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, + i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed, -- CIFile f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol FROM chat_items i diff --git a/src/Simplex/Chat/Store/Postgres/Migrations/M20260222_chat_relays.hs b/src/Simplex/Chat/Store/Postgres/Migrations/M20260222_chat_relays.hs index 905067bf76..87decab6e8 100644 --- a/src/Simplex/Chat/Store/Postgres/Migrations/M20260222_chat_relays.hs +++ b/src/Simplex/Chat/Store/Postgres/Migrations/M20260222_chat_relays.hs @@ -63,6 +63,11 @@ CREATE INDEX idx_group_relays_chat_relay_id ON group_relays(chat_relay_id); ALTER TABLE group_members ADD COLUMN relay_link BYTEA, ADD COLUMN member_pub_key BYTEA; + +ALTER TABLE messages ADD COLUMN msg_chat_binding TEXT; +ALTER TABLE messages ADD COLUMN msg_signatures BYTEA; + +ALTER TABLE chat_items ADD COLUMN msg_signed SMALLINT NOT NULL DEFAULT 0; |] down_m20260222_chat_relays :: Text @@ -101,4 +106,9 @@ DROP TABLE chat_relays; ALTER TABLE group_members DROP COLUMN relay_link, DROP COLUMN member_pub_key; + +ALTER TABLE messages DROP COLUMN msg_chat_binding; +ALTER TABLE messages DROP COLUMN msg_signatures; + +ALTER TABLE chat_items DROP COLUMN msg_signed; |] diff --git a/src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql b/src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql index 3f617ab780..e80bc0ef9a 100644 --- a/src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql @@ -343,7 +343,8 @@ CREATE TABLE test_chat_schema.chat_items ( group_scope_tag text, group_scope_group_member_id bigint, show_group_as_sender smallint DEFAULT 0 NOT NULL, - has_link smallint DEFAULT 0 NOT NULL + has_link smallint DEFAULT 0 NOT NULL, + msg_signed smallint DEFAULT 0 NOT NULL ); @@ -1002,7 +1003,9 @@ CREATE TABLE test_chat_schema.messages ( shared_msg_id_user smallint, author_group_member_id bigint, forwarded_by_group_member_id bigint, - broker_ts timestamp with time zone + broker_ts timestamp with time zone, + msg_chat_binding text, + msg_signatures bytea ); diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/M20260222_chat_relays.hs b/src/Simplex/Chat/Store/SQLite/Migrations/M20260222_chat_relays.hs index 594ea37035..f5f799914f 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/M20260222_chat_relays.hs +++ b/src/Simplex/Chat/Store/SQLite/Migrations/M20260222_chat_relays.hs @@ -75,6 +75,11 @@ CREATE INDEX idx_group_relays_chat_relay_id ON group_relays(chat_relay_id); ALTER TABLE group_members ADD COLUMN relay_link BLOB; ALTER TABLE group_members ADD COLUMN member_pub_key BLOB; + +ALTER TABLE messages ADD COLUMN msg_chat_binding TEXT; +ALTER TABLE messages ADD COLUMN msg_signatures BLOB; + +ALTER TABLE chat_items ADD COLUMN msg_signed INTEGER NOT NULL DEFAULT 0; |] down_m20260222_chat_relays :: Query @@ -113,4 +118,9 @@ DROP TABLE chat_relays; ALTER TABLE group_members DROP COLUMN relay_link; ALTER TABLE group_members DROP COLUMN member_pub_key; + +ALTER TABLE messages DROP COLUMN msg_chat_binding; +ALTER TABLE messages DROP COLUMN msg_signatures; + +ALTER TABLE chat_items DROP COLUMN msg_signed; |] diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt b/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt index f666ea4b72..1f50a7309d 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt +++ b/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt @@ -652,9 +652,9 @@ SEARCH contacts USING COVERING INDEX idx_contacts_contact_group_member_id (conta Query: INSERT INTO messages ( - msg_sent, chat_msg_event, msg_body, connection_id, group_id, + msg_sent, chat_msg_event, msg_body, msg_chat_binding, msg_signatures, connection_id, group_id, shared_msg_id, shared_msg_id_user, created_at, updated_at - ) VALUES (?,?,?,?,?,?,?,?,?) + ) VALUES (?,?,?,?,?,?,?,?,?,?,?) Plan: @@ -1231,9 +1231,9 @@ Plan: Query: INSERT INTO messages - (msg_sent, chat_msg_event, msg_body, broker_ts, created_at, updated_at, connection_id, group_id, + (msg_sent, chat_msg_event, msg_body, msg_chat_binding, msg_signatures, broker_ts, created_at, updated_at, connection_id, group_id, shared_msg_id, author_group_member_id, forwarded_by_group_member_id) - VALUES (?,?,?,?,?,?,?,?,?,?,?) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?) Plan: @@ -1257,7 +1257,7 @@ Query: i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.via_proxy, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.fwd_from_tag, i.fwd_from_chat_name, i.fwd_from_msg_dir, i.fwd_from_contact_id, i.fwd_from_group_id, i.fwd_from_chat_item_id, - i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, + i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed, -- CIFile f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol FROM chat_items i @@ -1274,7 +1274,7 @@ Query: i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.via_proxy, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.fwd_from_tag, i.fwd_from_chat_name, i.fwd_from_msg_dir, i.fwd_from_contact_id, i.fwd_from_group_id, i.fwd_from_chat_item_id, - i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, + i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed, -- CIFile f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, -- CIMeta forwardedByMember, showGroupAsSender @@ -1327,7 +1327,7 @@ Query: i.chat_item_id, i.item_ts, i.item_sent, i.item_content, i.item_text, i.item_status, i.via_proxy, i.shared_msg_id, i.item_deleted, i.item_deleted_ts, i.item_edited, i.created_at, i.updated_at, i.fwd_from_tag, i.fwd_from_chat_name, i.fwd_from_msg_dir, i.fwd_from_contact_id, i.fwd_from_group_id, i.fwd_from_chat_item_id, - i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, + i.timed_ttl, i.timed_delete_at, i.item_live, i.user_mention, i.has_link, i.msg_signed, -- CIFile f.file_id, f.file_name, f.file_size, f.file_path, f.file_crypto_key, f.file_crypto_nonce, f.ci_file_status, f.protocol, -- DirectQuote @@ -3224,7 +3224,7 @@ Query: SELECT t.delivery_task_id, t.worker_scope, t.job_scope_spec_tag, t.job_scope_include_pending, t.job_scope_support_gm_id, - m.group_member_id, m.member_id, p.display_name, msg.broker_ts, msg.msg_body, t.message_from_channel + m.group_member_id, m.member_id, p.display_name, msg.broker_ts, msg.msg_body, msg.msg_chat_binding, msg.msg_signatures, t.message_from_channel FROM delivery_tasks t JOIN messages msg ON msg.message_id = t.message_id JOIN group_members m ON m.group_member_id = t.sender_group_member_id @@ -3664,7 +3664,7 @@ SEARCH m USING INDEX idx_group_members_user_id (user_id=?) SEARCH p USING INTEGER PRIMARY KEY (rowid=?) Query: - SELECT pgm.message_id, m.shared_msg_id, m.msg_body + SELECT pgm.message_id, m.shared_msg_id, m.msg_body, m.msg_chat_binding, m.msg_signatures FROM pending_group_messages pgm JOIN messages m USING (message_id) WHERE pgm.group_member_id = ? @@ -4464,12 +4464,12 @@ Query: user_id, created_by_msg_id, contact_id, group_id, group_member_id, note_folder_id, group_scope_tag, group_scope_group_member_id, -- meta item_sent, item_ts, item_content, item_content_tag, item_text, item_status, msg_content_tag, shared_msg_id, - forwarded_by_group_member_id, include_in_history, created_at, updated_at, item_live, user_mention, has_link, show_group_as_sender, timed_ttl, timed_delete_at, + forwarded_by_group_member_id, include_in_history, created_at, updated_at, item_live, user_mention, has_link, show_group_as_sender, msg_signed, timed_ttl, timed_delete_at, -- quote quoted_shared_msg_id, quoted_sent_at, quoted_content, quoted_sent, quoted_member_id, -- forwarded from fwd_from_tag, fwd_from_chat_name, fwd_from_msg_dir, fwd_from_contact_id, fwd_from_group_id, fwd_from_chat_item_id - ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) + ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) Plan: @@ -5877,9 +5877,6 @@ SEARCH chat_items USING COVERING INDEX idx_chat_items_notes_created_at (user_id= Query: CREATE TABLE temp_delete_members (contact_profile_id INTEGER, member_profile_id INTEGER, local_display_name TEXT) Error: SQLite3 returned ErrorError while attempting to perform prepare "explain query plan CREATE TABLE temp_delete_members (contact_profile_id INTEGER, member_profile_id INTEGER, local_display_name TEXT)": table temp_delete_members already exists -Query: DELETE FROM app_settings -Plan: - Query: DELETE FROM calls WHERE user_id = ? AND contact_id = ? Plan: SEARCH calls USING INDEX idx_calls_contact_id (contact_id=?) @@ -6300,9 +6297,6 @@ Plan: Query: DROP TABLE temp_delete_members Plan: -Query: INSERT INTO app_settings (app_settings) VALUES (?) -Plan: - Query: INSERT INTO chat_item_mentions (chat_item_id, group_id, member_id, display_name) VALUES (?, ?, ?, ?) Plan: diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql b/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql index 84d5a8b001..df675b3c05 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql @@ -404,7 +404,9 @@ CREATE TABLE messages( shared_msg_id_user INTEGER, author_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL, forwarded_by_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL, - broker_ts TEXT + broker_ts TEXT, + msg_chat_binding TEXT, + msg_signatures BLOB ) STRICT; CREATE TABLE pending_group_messages( pending_group_message_id INTEGER PRIMARY KEY, @@ -458,7 +460,8 @@ CREATE TABLE chat_items( group_scope_tag TEXT, group_scope_group_member_id INTEGER REFERENCES group_members(group_member_id) ON DELETE CASCADE, show_group_as_sender INTEGER NOT NULL DEFAULT 0, - has_link INTEGER NOT NULL DEFAULT 0 + has_link INTEGER NOT NULL DEFAULT 0, + msg_signed INTEGER NOT NULL DEFAULT 0 ) STRICT; CREATE TABLE sqlite_sequence(name,seq); CREATE TABLE chat_item_messages( diff --git a/src/Simplex/Chat/Terminal/Input.hs b/src/Simplex/Chat/Terminal/Input.hs index b7eebd141a..ca9d80f434 100644 --- a/src/Simplex/Chat/Terminal/Input.hs +++ b/src/Simplex/Chat/Terminal/Input.hs @@ -79,7 +79,7 @@ runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = forever $ do CRChatItemUpdated u (AChatItem _ SMDSnd cInfo _) -> whenCurrUser cc u $ setActiveChat ct cInfo CRChatItemsDeleted u ((ChatItemDeletion (AChatItem _ _ cInfo _) _) : _) _ _ -> whenCurrUser cc u $ setActiveChat ct cInfo CRContactDeleted u c -> whenCurrUser cc u $ unsetActiveContact ct c - CRGroupDeletedUser u g -> whenCurrUser cc u $ unsetActiveGroup ct g + CRGroupDeletedUser u g _ -> whenCurrUser cc u $ unsetActiveGroup ct g CRSentGroupInvitation u g _ _ -> whenCurrUser cc u $ setActiveGroup ct g CRCmdOk _ -> case cmd of Right APIDeleteUser {} -> setActive ct "" diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 06b968c59d..5dfbdf8f09 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -57,6 +57,7 @@ import Simplex.Messaging.Agent.Store.DB (Binary (..), blobFieldDecoder, fromText import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.File (CryptoFileArgs (..)) import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport, pattern PQEncOff) +import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, sumTypeJSON) import Simplex.Messaging.Util (decodeJSON, encodeJSON, safeDecodeUtf8) @@ -891,11 +892,23 @@ data IntroInvitation = IntroInvitation } deriving (Eq, Show) +newtype MemberKey = MemberKey C.PublicKeyEd25519 + deriving (Eq, Show) + deriving newtype (StrEncoding) + +instance FromJSON MemberKey where + parseJSON = strParseJSON "MemberKey" + +instance ToJSON MemberKey where + toJSON = strToJSON + toEncoding = strToJEncoding + data MemberInfo = MemberInfo { memberId :: MemberId, memberRole :: GroupMemberRole, v :: Maybe ChatVersionRange, - profile :: Profile + profile :: Profile, + memberKey :: Maybe MemberKey } deriving (Eq, Show) @@ -1084,7 +1097,7 @@ data NewGroupMember = NewGroupMember newtype MemberId = MemberId {unMemberId :: ByteString} deriving (Eq, Ord, Show) - deriving newtype (FromField) + deriving newtype (Encoding, FromField) instance ToField MemberId where toField (MemberId m) = toField $ Binary m diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 197d0de3cf..3ba424325f 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -215,11 +215,11 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, testView} liveIte CRUserContactLinkCreated u ccLink -> ttyUser u $ connReqContact_ "Your new chat address is created!" ccLink CRUserContactLinkDeleted u -> ttyUser u viewUserContactLinkDeleted CRUserAcceptedGroupSent u _g _ -> ttyUser u [] -- [ttyGroup' g <> ": joining the group..."] - CRUserDeletedMembers u g members wm -> case members of - [m] -> ttyUser u [ttyGroup' g <> ": you removed " <> ttyMember m <> " from the group" <> withMessages wm] - mems' -> ttyUser u [ttyGroup' g <> ": you removed " <> sShow (length mems') <> " members from the group" <> withMessages wm] + CRUserDeletedMembers u g members wm signed -> case members of + [m] -> ttyUser u [ttyGroup' g <> ": you removed " <> ttyMember m <> " from the group" <> withMessages wm <> signedStr signed] + mems' -> ttyUser u [ttyGroup' g <> ": you removed " <> sShow (length mems') <> " members from the group" <> withMessages wm <> signedStr signed] CRLeftMemberUser u g -> ttyUser u $ [ttyGroup' g <> ": you left the group"] <> groupPreserved g - CRGroupDeletedUser u g -> ttyUser u [ttyGroup' g <> ": you deleted the group"] + CRGroupDeletedUser u g signed -> ttyUser u [ttyGroup' g <> ": you deleted the group" <> signedStr signed] CRForwardPlan u count itemIds fc -> ttyUser u $ viewForwardPlan count itemIds fc CRRcvFileAccepted u ci -> ttyUser u $ savingFile' ci CRRcvFileAcceptedSndCancelled u ft -> ttyUser u $ viewRcvFileSndCancelled ft @@ -238,9 +238,9 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, testView} liveIte CRMemberAccepted u g m -> ttyUser u $ viewMemberAccepted g m CRMemberSupportChatRead u g m -> ttyUser u $ viewSupportChatRead g m CRMemberSupportChatDeleted u g m -> ttyUser u [ttyGroup' g <> ": " <> ttyMember m <> " support chat deleted"] - CRMembersRoleUser u g members r' -> ttyUser u $ viewMemberRoleUserChanged g members r' - CRMembersBlockedForAllUser u g members blocked -> ttyUser u $ viewMembersBlockedForAllUser g members blocked - CRGroupUpdated u g g' m -> ttyUser u $ viewGroupUpdated g g' m + CRMembersRoleUser u g members r' signed -> ttyUser u $ viewMemberRoleUserChanged g members r' signed + CRMembersBlockedForAllUser u g members blocked signed -> ttyUser u $ viewMembersBlockedForAllUser g members blocked signed + CRGroupUpdated u g g' m signed -> ttyUser u $ viewGroupUpdated g g' m signed CRGroupProfile u g -> ttyUser u $ viewGroupProfile g CRGroupDescription u g -> ttyUser u $ viewGroupDescription g CRGroupLinkCreated u g gLink -> ttyUser u $ groupLink_ "Group link is created!" g gLink @@ -358,9 +358,9 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, testView} liveIte Just CIFile {fileSource = Just (CryptoFile fp _)} -> Just fp _ -> Nothing testViewItem :: CChatItem c -> Maybe GroupMember -> Text - testViewItem (CChatItem _ ci@ChatItem {meta = CIMeta {itemText}}) membership_ = + testViewItem (CChatItem _ ci@ChatItem {meta = CIMeta {itemText, msgSigned}}) membership_ = let deleted_ = maybe "" (\t -> " [" <> t <> "]") (chatItemDeletedText ci membership_) - in itemText <> deleted_ + in itemText <> signedStr msgSigned <> deleted_ unmuted :: User -> ChatInfo c -> ChatItem c d -> [StyledString] -> [StyledString] unmuted u chat ci@ChatItem {chatDir} = unmuted' u chat chatDir $ isUserMention ci unmutedReaction :: User -> ChatInfo c -> CIReaction c d -> [StyledString] -> [StyledString] @@ -372,6 +372,9 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, testView} liveIte | otherwise = [] withMessages wm = if wm then " with all messages" else "" +signedStr :: IsString a => Bool -> a +signedStr signed = if signed then " (signed)" else "" + ttyUserPrefix :: (Maybe RemoteHostId, Maybe User) -> Maybe RemoteHostId -> User -> [StyledString] -> [StyledString] ttyUserPrefix _ _ _ [] = [] ttyUserPrefix (currentRH, user_) outputRH User {userId, localDisplayName = u} ss @@ -469,13 +472,13 @@ chatEventToView hu ChatConfig {logLevel, showReactions, showReceipts, testView} CEvtJoinedGroupMemberConnecting u g host m -> ttyUser u $ viewJoinedGroupMemberConnecting g host m CEvtConnectedToGroupMember u g m _ -> ttyUser u $ viewConnectedToGroupMember g m CEvtMemberAcceptedByOther u g acceptingMember m -> ttyUser u $ viewMemberAcceptedByOther g acceptingMember m - CEvtMemberRole u g by m r r' -> ttyUser u $ viewMemberRoleChanged g by m r r' - CEvtMemberBlockedForAll u g by m blocked -> ttyUser u $ viewMemberBlockedForAll g by m blocked - CEvtDeletedMemberUser u g by wm -> ttyUser u $ [ttyGroup' g <> ": " <> ttyMember by <> " removed you from the group" <> withMessages wm] <> groupPreserved g - CEvtDeletedMember u g by m wm -> ttyUser u [ttyGroup' g <> ": " <> ttyMember by <> " removed " <> ttyMember m <> " from the group" <> withMessages wm] + CEvtMemberRole u g by m r r' signed -> ttyUser u $ viewMemberRoleChanged g by m r r' signed + CEvtMemberBlockedForAll u g by m blocked signed -> ttyUser u $ viewMemberBlockedForAll g by m blocked signed + CEvtDeletedMemberUser u g by wm signed -> ttyUser u $ [ttyGroup' g <> ": " <> ttyMember by <> " removed you from the group" <> withMessages wm <> signedStr signed] <> groupPreserved g + CEvtDeletedMember u g by m wm signed -> ttyUser u [ttyGroup' g <> ": " <> ttyMember by <> " removed " <> ttyMember m <> " from the group" <> withMessages wm <> signedStr signed] CEvtLeftMember u g m -> ttyUser u [ttyGroup' g <> ": " <> ttyMember m <> " left the group"] - CEvtGroupDeleted u g m -> ttyUser u [ttyGroup' g <> ": " <> ttyMember m <> " deleted the group", "use " <> highlight ("/d #" <> viewGroupName g) <> " to delete the local copy of the group"] - CEvtGroupUpdated u g g' m -> ttyUser u $ viewGroupUpdated g g' m + CEvtGroupDeleted u g m signed -> ttyUser u [ttyGroup' g <> ": " <> ttyMember m <> " deleted the group" <> signedStr signed, "use " <> highlight ("/d #" <> viewGroupName g) <> " to delete the local copy of the group"] + CEvtGroupUpdated u g g' m signed -> ttyUser u $ viewGroupUpdated g g' m signed CEvtAcceptingGroupJoinRequestMember _ g m -> [ttyFullMember m <> ": accepting request to join group " <> ttyGroup' g <> "..."] CEvtNoMemberContactCreating u g m -> ttyUser u ["member " <> ttyGroup' g <> " " <> ttyMember m <> " does not have direct connection, creating"] CEvtNewMemberContactReceivedInv u ct g m -> ttyUser u $ viewNewMemberContactReceivedInv u ct g m @@ -644,7 +647,7 @@ viewChatItems ttyUser unmuted u chatItems ts tz | otherwise = ttyUser u [sShow (length chatItems) <> " new messages created"] viewChatItem :: forall c d. MsgDirectionI d => ChatInfo c -> ChatItem c d -> Bool -> CurrentTime -> TimeZone -> [StyledString] -viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {itemForwarded, forwardedByMember, userMention}, content, quotedItem, file} doShow ts tz = +viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {itemForwarded, forwardedByMember, userMention, msgSigned}, content, quotedItem, file} doShow ts tz = withGroupMsgForwarded . withItemDeleted <$> viewCI where viewCI = case chat of @@ -727,8 +730,8 @@ viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {itemForwarded, forwa ("", Just _, []) -> [] ("", Just CIFile {fileName}, _) -> view dir context (MCText $ T.pack fileName) ts tz meta _ -> view dir context mc ts tz meta - showSndItem to = showItem $ sentWithTime_ ts tz [to <> plainContent content] meta - showRcvItem from = showItem $ receivedWithTime_ ts tz from [] meta [plainContent content] False + showSndItem to = showItem $ sentWithTime_ ts tz [to <> plainContent content <> signedStr msgSigned] meta + showRcvItem from = showItem $ receivedWithTime_ ts tz from [] meta [plainContent content <> signedStr msgSigned] False showSndItemProhibited to = showItem $ sentWithTime_ ts tz [to <> plainContent content <> " " <> prohibited] meta showRcvItemProhibited from = showItem $ receivedWithTime_ ts tz from [] meta [plainContent content <> " " <> prohibited] False showItem ss = if doShow then ss else [] @@ -1299,29 +1302,29 @@ connectedMember m = case memberCategory m of GCPostMember -> "new member " <> ttyMember m -- without fullName as as it was shown in joinedGroupMemberConnecting _ -> "member " <> ttyMember m -- these case is not used -viewMemberRoleChanged :: GroupInfo -> GroupMember -> GroupMember -> GroupMemberRole -> GroupMemberRole -> [StyledString] -viewMemberRoleChanged g@GroupInfo {membership} by m r r' +viewMemberRoleChanged :: GroupInfo -> GroupMember -> GroupMember -> GroupMemberRole -> GroupMemberRole -> Bool -> [StyledString] +viewMemberRoleChanged g@GroupInfo {membership} by m r r' signed | r == r' = [ttyGroup' g <> ": member role did not change"] | groupMemberId' membership == memId = view "your role" | groupMemberId' by == memId = view "the role" | otherwise = view $ "the role of " <> ttyMember m where memId = groupMemberId' m - view s = [ttyGroup' g <> ": " <> ttyMember by <> " changed " <> s <> " from " <> showRole r <> " to " <> showRole r'] + view s = [ttyGroup' g <> ": " <> ttyMember by <> " changed " <> s <> " from " <> showRole r <> " to " <> showRole r' <> signedStr signed] -viewMemberRoleUserChanged :: GroupInfo -> [GroupMember] -> GroupMemberRole -> [StyledString] -viewMemberRoleUserChanged g members r = case members of - [m] -> [ttyGroup' g <> ": you changed the role of " <> ttyMember m <> " to " <> showRole r] - mems' -> [ttyGroup' g <> ": you changed the role of " <> sShow (length mems') <> " members to " <> showRole r] +viewMemberRoleUserChanged :: GroupInfo -> [GroupMember] -> GroupMemberRole -> Bool -> [StyledString] +viewMemberRoleUserChanged g members r signed = case members of + [m] -> [ttyGroup' g <> ": you changed the role of " <> ttyMember m <> " to " <> showRole r <> signedStr signed] + mems' -> [ttyGroup' g <> ": you changed the role of " <> sShow (length mems') <> " members to " <> showRole r <> signedStr signed] -viewMemberBlockedForAll :: GroupInfo -> GroupMember -> GroupMember -> Bool -> [StyledString] -viewMemberBlockedForAll g by m blocked = - [ttyGroup' g <> ": " <> ttyMember by <> " " <> (if blocked then "blocked" else "unblocked") <> " " <> ttyMember m] +viewMemberBlockedForAll :: GroupInfo -> GroupMember -> GroupMember -> Bool -> Bool -> [StyledString] +viewMemberBlockedForAll g by m blocked signed = + [ttyGroup' g <> ": " <> ttyMember by <> " " <> (if blocked then "blocked" else "unblocked") <> " " <> ttyMember m <> signedStr signed] -viewMembersBlockedForAllUser :: GroupInfo -> [GroupMember] -> Bool -> [StyledString] -viewMembersBlockedForAllUser g members blocked = case members of - [m] -> [ttyGroup' g <> ": you " <> (if blocked then "blocked" else "unblocked") <> " " <> ttyMember m] - mems' -> [ttyGroup' g <> ": you " <> (if blocked then "blocked" else "unblocked") <> " " <> sShow (length mems') <> " members"] +viewMembersBlockedForAllUser :: GroupInfo -> [GroupMember] -> Bool -> Bool -> [StyledString] +viewMembersBlockedForAllUser g members blocked signed = case members of + [m] -> [ttyGroup' g <> ": you " <> (if blocked then "blocked" else "unblocked") <> " " <> ttyMember m <> signedStr signed] + mems' -> [ttyGroup' g <> ": you " <> (if blocked then "blocked" else "unblocked") <> " " <> sShow (length mems') <> " members" <> signedStr signed] showRole :: GroupMemberRole -> StyledString showRole = plain . textEncode @@ -1884,17 +1887,17 @@ countactUserPrefText cup = case cup of CUPUser p -> "default (" <> preferenceText p <> ")" CUPContact p -> preferenceText p -viewGroupUpdated :: GroupInfo -> GroupInfo -> Maybe GroupMember -> [StyledString] +viewGroupUpdated :: GroupInfo -> GroupInfo -> Maybe GroupMember -> Bool -> [StyledString] viewGroupUpdated GroupInfo {localDisplayName = n, groupProfile = GroupProfile {fullName, shortDescr, description, image, groupPreferences = gps, memberAdmission = ma}} g'@GroupInfo {localDisplayName = n', groupProfile = GroupProfile {fullName = fullName', shortDescr = shortDescr', description = description', image = image', groupPreferences = gps', memberAdmission = ma'}} - m = do + m signed = do let update = groupProfileUpdated <> groupPrefsUpdated <> memberAdmissionUpdated if null update then [] else memberUpdated <> update where - memberUpdated = maybe [] (\m' -> [ttyMember m' <> " updated group " <> ttyGroup n <> ":"]) m + memberUpdated = maybe [] (\m' -> [ttyMember m' <> " updated group " <> ttyGroup n <> ":" <> signedStr signed]) m groupProfileUpdated = ["changed to " <> ttyFullGroup g' | n /= n'] <> ["full name " <> if T.null fullName' || fullName' == n' then "removed" else "changed to: " <> plain fullName' | n == n' && fullName /= fullName'] diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index da6eee9ec7..f1a9e1f374 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -8409,6 +8409,107 @@ testChannels1RelayDeliver ps = eve <# "#team cath> > hi" eve <## " + 👍" + -- admin operations are signed in channels + + -- update group profile (XGrpInfo) - signed + alice ##> "/set welcome #team welcome to team" + alice <## "welcome message changed to:" + alice <## "welcome to team" + concurrentlyN_ + [ do + bob <## "alice updated group #team: (signed)" + bob <## "welcome message changed to:" + bob <## "welcome to team", + do + cath <## "alice updated group #team: (signed)" + cath <## "welcome message changed to:" + cath <## "welcome to team", + do + dan <## "alice updated group #team: (signed)" + dan <## "welcome message changed to:" + dan <## "welcome to team", + do + eve <## "alice updated group #team: (signed)" + eve <## "welcome message changed to:" + eve <## "welcome to team" + ] + alice #$> ("/_get chat #1 count=1", chat, [(1, "group profile updated (signed)")]) + + -- update group preferences (XGrpPrefs) - signed + alice ##> "/set delete #team on" + alice <## "updated group preferences:" + alice <## "Full deletion: on" + concurrentlyN_ + [ do + bob <## "alice updated group #team: (signed)" + bob <## "updated group preferences:" + bob <## "Full deletion: on", + do + cath <## "alice updated group #team: (signed)" + cath <## "updated group preferences:" + cath <## "Full deletion: on", + do + dan <## "alice updated group #team: (signed)" + dan <## "updated group preferences:" + dan <## "Full deletion: on", + do + eve <## "alice updated group #team: (signed)" + eve <## "updated group preferences:" + eve <## "Full deletion: on" + ] + + -- change member role (XGrpMemRole) - signed + alice ##> "/mr #team cath admin" + alice <## "#team: you changed the role of cath to admin (signed)" + concurrentlyN_ + [ bob <## "#team: alice changed the role of cath from member to admin (signed)", + cath <## "#team: alice changed your role from member to admin (signed)", + dan <## "#team: alice changed the role of cath from member to admin (signed)", + eve <## "#team: alice changed the role of cath from member to admin (signed)" + ] + alice #$> ("/_get chat #1 count=1", chat, [(1, "changed role of cath to admin (signed)")]) + + -- discover eve so alice can remove her + eve #> "#team hello from eve" + bob <# "#team eve> hello from eve" + alice <## "#team: bob forwarded a message from an unknown member, creating unknown member record eve" + alice <# "#team eve> hello from eve [>>]" + concurrentlyN_ + [ do + dan <## "#team: bob forwarded a message from an unknown member, creating unknown member record eve" + dan <# "#team eve> hello from eve [>>]", + do + cath <## "#team: bob forwarded a message from an unknown member, creating unknown member record eve" + cath <# "#team eve> hello from eve [>>]" + ] + + -- remove member (XGrpMemDel) - signed + threadDelay 1000000 + alice ##> "/rm #team eve" + alice <## "#team: you removed eve from the group (signed)" + concurrentlyN_ + [ bob <## "#team: alice removed eve from the group (signed)", + cath <## "#team: alice removed eve from the group (signed)", + dan <## "#team: alice removed eve from the group (signed)" + ] + alice #$> ("/_get chat #1 count=1", chat, [(1, "removed eve (signed)")]) + bob #$> ("/_get chat #1 count=1", chat, [(0, "removed eve (signed)")]) + + -- delete group (XGrpDel) - signed + alice ##> "/d #team" + alice <## "#team: you deleted the group (signed)" + concurrentlyN_ + [ do + bob <## "#team: alice deleted the group (signed)" + bob <## "use /d #team to delete the local copy of the group", + do + cath <## "#team: alice deleted the group (signed)" + cath <## "use /d #team to delete the local copy of the group", + do + dan <## "#team: alice deleted the group (signed)" + dan <## "use /d #team to delete the local copy of the group" + ] + createChannel1Relay :: String -> TestCC -> TestCC -> TestCC -> TestCC -> TestCC -> IO () createChannel1Relay gName owner relay cath dan eve = do (shortLink, fullLink) <- prepareChannel1Relay gName owner relay diff --git a/tests/MessageBatching.hs b/tests/MessageBatching.hs index 1945a2a7dc..05322a0834 100644 --- a/tests/MessageBatching.hs +++ b/tests/MessageBatching.hs @@ -9,6 +9,7 @@ module MessageBatching (batchingTests) where import Crypto.Number.Serialize (os2ip) import Data.ByteString (ByteString) import qualified Data.ByteString as B +import Data.ByteString.Internal (c2w) import Data.Either (partitionEithers) import Data.Int (Int64) import Data.String (IsString (..)) @@ -19,20 +20,21 @@ import Simplex.Chat.Controller (ChatError (..), ChatErrorType (..)) import Simplex.Chat.Messages (SndMessage (..)) import Simplex.Chat.Protocol (maxEncodedMsgLength) import Simplex.Chat.Types (SharedMsgId (..)) +import Simplex.Messaging.Encoding (Large (..), smpEncodeList) import Test.Hspec batchingTests :: Spec batchingTests = describe "message batching tests" $ do testBatchingCorrectness + testBinaryBatchingCorrectness it "image x.msg.new and x.msg.file.descr should fit into single batch" testImageFitsSingleBatch instance IsString SndMessage where - fromString s = SndMessage {msgId, sharedMsgId = SharedMsgId "", msgBody = s'} + fromString s = SndMessage {msgId, sharedMsgId = SharedMsgId "", msgBody = s', signedMsg_ = Nothing} where s' = encodeUtf8 $ T.pack s msgId = fromInteger $ os2ip s' -deriving instance Eq SndMessage instance IsString ChatError where fromString s = ChatError $ CEInternalError ("large message " <> show msgId) @@ -41,50 +43,77 @@ instance IsString ChatError where msgId = fromInteger (os2ip s') :: Int64 testBatchingCorrectness :: Spec -testBatchingCorrectness = describe "correctness tests" $ do - runBatcherTest 8 ["a"] [] ["a"] - runBatcherTest 8 ["a", "b"] [] ["[a,b]"] - runBatcherTest 8 ["a", "b", "c"] [] ["[a,b,c]"] - runBatcherTest 8 ["a", "bb", "c"] [] ["[a,bb,c]"] - runBatcherTest 8 ["a", "b", "c", "d"] [] ["a", "[b,c,d]"] - runBatcherTest 8 ["a", "bb", "c", "d"] [] ["a", "[bb,c,d]"] - runBatcherTest 8 ["a", "bb", "c", "de"] [] ["[a,bb]", "[c,de]"] - runBatcherTest 8 ["a", "b", "c", "d", "e"] [] ["[a,b]", "[c,d,e]"] - runBatcherTest 8 ["a", "b", "c", "d", "e", "f", "g", "h", "i", "j"] [] ["a", "[b,c,d]", "[e,f,g]", "[h,i,j]"] - runBatcherTest 8 ["aaaaa"] [] ["aaaaa"] - runBatcherTest 8 ["8aaaaaaa"] [] ["8aaaaaaa"] - runBatcherTest 8 ["aaaa", "bbbb"] [] ["aaaa", "bbbb"] - runBatcherTest 8 ["aa", "bbb", "cc", "dd"] [] ["[aa,bbb]", "[cc,dd]"] - runBatcherTest 8 ["aa", "bbb", "cc", "dd", "eee", "fff", "gg", "hh"] [] ["aa", "[bbb,cc]", "[dd,eee]", "fff", "[gg,hh]"] - runBatcherTest 8 ["9aaaaaaaa"] ["9aaaaaaaa"] [] - runBatcherTest 8 ["aaaaa", "bbb", "cc"] [] ["aaaaa", "[bbb,cc]"] - runBatcherTest 8 ["8aaaaaaa", "bbb", "cc"] [] ["8aaaaaaa", "[bbb,cc]"] - runBatcherTest 8 ["9aaaaaaaa", "bbb", "cc"] ["9aaaaaaaa"] ["[bbb,cc]"] - runBatcherTest 8 ["9aaaaaaaa", "bbb", "cc", "dd"] ["9aaaaaaaa"] ["bbb", "[cc,dd]"] - runBatcherTest 8 ["9aaaaaaaa", "bbb", "cc", "dd", "e"] ["9aaaaaaaa"] ["[bbb,cc]", "[dd,e]"] - runBatcherTest 8 ["bbb", "cc", "aaaaa"] [] ["[bbb,cc]", "aaaaa"] - runBatcherTest 8 ["bbb", "cc", "8aaaaaaa"] [] ["[bbb,cc]", "8aaaaaaa"] - runBatcherTest 8 ["bbb", "cc", "9aaaaaaaa"] ["9aaaaaaaa"] ["[bbb,cc]"] - runBatcherTest 8 ["bbb", "cc", "dd", "9aaaaaaaa"] ["9aaaaaaaa"] ["bbb", "[cc,dd]"] - runBatcherTest 8 ["bbb", "cc", "dd", "e", "9aaaaaaaa"] ["9aaaaaaaa"] ["[bbb,cc]", "[dd,e]"] - runBatcherTest 8 ["bbb", "cc", "aaaaa", "dd"] [] ["[bbb,cc]", "aaaaa", "dd"] - runBatcherTest 8 ["bbb", "cc", "aaaaa", "dd", "e"] [] ["[bbb,cc]", "aaaaa", "[dd,e]"] - runBatcherTest 8 ["bbb", "cc", "8aaaaaaa", "dd"] [] ["[bbb,cc]", "8aaaaaaa", "dd"] - runBatcherTest 8 ["bbb", "cc", "8aaaaaaa", "dd", "e"] [] ["[bbb,cc]", "8aaaaaaa", "[dd,e]"] - runBatcherTest 8 ["bbb", "cc", "9aaaaaaaa"] ["9aaaaaaaa"] ["[bbb,cc]"] - runBatcherTest 8 ["bbb", "cc", "9aaaaaaaa", "dd"] ["9aaaaaaaa"] ["[bbb,cc]", "dd"] - runBatcherTest 8 ["bbb", "cc", "9aaaaaaaa", "dd", "e"] ["9aaaaaaaa"] ["[bbb,cc]", "[dd,e]"] - runBatcherTest 8 ["9aaaaaaaa", "10aaaaaaaa"] ["9aaaaaaaa", "10aaaaaaaa"] [] - runBatcherTest 8 ["8aaaaaaa", "9aaaaaaaa", "10aaaaaaaa"] ["9aaaaaaaa", "10aaaaaaaa"] ["8aaaaaaa"] - runBatcherTest 8 ["9aaaaaaaa", "8aaaaaaa", "10aaaaaaaa"] ["9aaaaaaaa", "10aaaaaaaa"] ["8aaaaaaa"] - runBatcherTest 8 ["9aaaaaaaa", "10aaaaaaaa", "8aaaaaaa"] ["9aaaaaaaa", "10aaaaaaaa"] ["8aaaaaaa"] - runBatcherTest 8 ["bb", "cc", "dd", "9aaaaaaaa", "10aaaaaaaa"] ["9aaaaaaaa", "10aaaaaaaa"] ["bb", "[cc,dd]"] - runBatcherTest 8 ["bb", "cc", "9aaaaaaaa", "dd", "10aaaaaaaa"] ["9aaaaaaaa", "10aaaaaaaa"] ["[bb,cc]", "dd"] - runBatcherTest 8 ["bb", "9aaaaaaaa", "cc", "dd", "10aaaaaaaa"] ["9aaaaaaaa", "10aaaaaaaa"] ["bb", "[cc,dd]"] - runBatcherTest 8 ["bb", "9aaaaaaaa", "cc", "10aaaaaaaa", "dd"] ["9aaaaaaaa", "10aaaaaaaa"] ["bb", "cc", "dd"] - runBatcherTest 8 ["9aaaaaaaa", "bb", "cc", "dd", "10aaaaaaaa"] ["9aaaaaaaa", "10aaaaaaaa"] ["bb", "[cc,dd]"] - runBatcherTest 8 ["9aaaaaaaa", "bb", "10aaaaaaaa", "cc", "dd"] ["9aaaaaaaa", "10aaaaaaaa"] ["bb", "[cc,dd]"] - runBatcherTest 8 ["9aaaaaaaa", "10aaaaaaaa", "bb", "cc", "dd"] ["9aaaaaaaa", "10aaaaaaaa"] ["bb", "[cc,dd]"] +testBatchingCorrectness = describe "JSON batching correctness tests" $ do + runBatcherTest BMJson 8 ["a"] [] ["a"] + runBatcherTest BMJson 8 ["a", "b"] [] ["[a,b]"] + runBatcherTest BMJson 8 ["a", "b", "c"] [] ["[a,b,c]"] + runBatcherTest BMJson 8 ["a", "bb", "c"] [] ["[a,bb,c]"] + runBatcherTest BMJson 8 ["a", "b", "c", "d"] [] ["a", "[b,c,d]"] + runBatcherTest BMJson 8 ["a", "bb", "c", "d"] [] ["a", "[bb,c,d]"] + runBatcherTest BMJson 8 ["a", "bb", "c", "de"] [] ["[a,bb]", "[c,de]"] + runBatcherTest BMJson 8 ["a", "b", "c", "d", "e"] [] ["[a,b]", "[c,d,e]"] + runBatcherTest BMJson 8 ["a", "b", "c", "d", "e", "f", "g", "h", "i", "j"] [] ["a", "[b,c,d]", "[e,f,g]", "[h,i,j]"] + runBatcherTest BMJson 8 ["aaaaa"] [] ["aaaaa"] + runBatcherTest BMJson 8 ["8aaaaaaa"] [] ["8aaaaaaa"] + runBatcherTest BMJson 8 ["aaaa", "bbbb"] [] ["aaaa", "bbbb"] + runBatcherTest BMJson 8 ["aa", "bbb", "cc", "dd"] [] ["[aa,bbb]", "[cc,dd]"] + runBatcherTest BMJson 8 ["aa", "bbb", "cc", "dd", "eee", "fff", "gg", "hh"] [] ["aa", "[bbb,cc]", "[dd,eee]", "fff", "[gg,hh]"] + runBatcherTest BMJson 8 ["9aaaaaaaa"] ["9aaaaaaaa"] [] + runBatcherTest BMJson 8 ["aaaaa", "bbb", "cc"] [] ["aaaaa", "[bbb,cc]"] + runBatcherTest BMJson 8 ["8aaaaaaa", "bbb", "cc"] [] ["8aaaaaaa", "[bbb,cc]"] + runBatcherTest BMJson 8 ["9aaaaaaaa", "bbb", "cc"] ["9aaaaaaaa"] ["[bbb,cc]"] + runBatcherTest BMJson 8 ["9aaaaaaaa", "bbb", "cc", "dd"] ["9aaaaaaaa"] ["bbb", "[cc,dd]"] + runBatcherTest BMJson 8 ["9aaaaaaaa", "bbb", "cc", "dd", "e"] ["9aaaaaaaa"] ["[bbb,cc]", "[dd,e]"] + runBatcherTest BMJson 8 ["bbb", "cc", "aaaaa"] [] ["[bbb,cc]", "aaaaa"] + runBatcherTest BMJson 8 ["bbb", "cc", "8aaaaaaa"] [] ["[bbb,cc]", "8aaaaaaa"] + runBatcherTest BMJson 8 ["bbb", "cc", "9aaaaaaaa"] ["9aaaaaaaa"] ["[bbb,cc]"] + runBatcherTest BMJson 8 ["bbb", "cc", "dd", "9aaaaaaaa"] ["9aaaaaaaa"] ["bbb", "[cc,dd]"] + runBatcherTest BMJson 8 ["bbb", "cc", "dd", "e", "9aaaaaaaa"] ["9aaaaaaaa"] ["[bbb,cc]", "[dd,e]"] + runBatcherTest BMJson 8 ["bbb", "cc", "aaaaa", "dd"] [] ["[bbb,cc]", "aaaaa", "dd"] + runBatcherTest BMJson 8 ["bbb", "cc", "aaaaa", "dd", "e"] [] ["[bbb,cc]", "aaaaa", "[dd,e]"] + runBatcherTest BMJson 8 ["bbb", "cc", "8aaaaaaa", "dd"] [] ["[bbb,cc]", "8aaaaaaa", "dd"] + runBatcherTest BMJson 8 ["bbb", "cc", "8aaaaaaa", "dd", "e"] [] ["[bbb,cc]", "8aaaaaaa", "[dd,e]"] + runBatcherTest BMJson 8 ["bbb", "cc", "9aaaaaaaa"] ["9aaaaaaaa"] ["[bbb,cc]"] + runBatcherTest BMJson 8 ["bbb", "cc", "9aaaaaaaa", "dd"] ["9aaaaaaaa"] ["[bbb,cc]", "dd"] + runBatcherTest BMJson 8 ["bbb", "cc", "9aaaaaaaa", "dd", "e"] ["9aaaaaaaa"] ["[bbb,cc]", "[dd,e]"] + runBatcherTest BMJson 8 ["9aaaaaaaa", "10aaaaaaaa"] ["9aaaaaaaa", "10aaaaaaaa"] [] + runBatcherTest BMJson 8 ["8aaaaaaa", "9aaaaaaaa", "10aaaaaaaa"] ["9aaaaaaaa", "10aaaaaaaa"] ["8aaaaaaa"] + runBatcherTest BMJson 8 ["9aaaaaaaa", "8aaaaaaa", "10aaaaaaaa"] ["9aaaaaaaa", "10aaaaaaaa"] ["8aaaaaaa"] + runBatcherTest BMJson 8 ["9aaaaaaaa", "10aaaaaaaa", "8aaaaaaa"] ["9aaaaaaaa", "10aaaaaaaa"] ["8aaaaaaa"] + runBatcherTest BMJson 8 ["bb", "cc", "dd", "9aaaaaaaa", "10aaaaaaaa"] ["9aaaaaaaa", "10aaaaaaaa"] ["bb", "[cc,dd]"] + runBatcherTest BMJson 8 ["bb", "cc", "9aaaaaaaa", "dd", "10aaaaaaaa"] ["9aaaaaaaa", "10aaaaaaaa"] ["[bb,cc]", "dd"] + runBatcherTest BMJson 8 ["bb", "9aaaaaaaa", "cc", "dd", "10aaaaaaaa"] ["9aaaaaaaa", "10aaaaaaaa"] ["bb", "[cc,dd]"] + runBatcherTest BMJson 8 ["bb", "9aaaaaaaa", "cc", "10aaaaaaaa", "dd"] ["9aaaaaaaa", "10aaaaaaaa"] ["bb", "cc", "dd"] + runBatcherTest BMJson 8 ["9aaaaaaaa", "bb", "cc", "dd", "10aaaaaaaa"] ["9aaaaaaaa", "10aaaaaaaa"] ["bb", "[cc,dd]"] + runBatcherTest BMJson 8 ["9aaaaaaaa", "bb", "10aaaaaaaa", "cc", "dd"] ["9aaaaaaaa", "10aaaaaaaa"] ["bb", "[cc,dd]"] + runBatcherTest BMJson 8 ["9aaaaaaaa", "10aaaaaaaa", "bb", "cc", "dd"] ["9aaaaaaaa", "10aaaaaaaa"] ["bb", "[cc,dd]"] + +-- Binary batch format: 'B' ( )* +-- Single element returned as-is (no B prefix) +-- Overhead per batch: 2 bytes (B + count) + 2 bytes per element (length prefix) +testBinaryBatchingCorrectness :: Spec +testBinaryBatchingCorrectness = describe "Binary batching correctness tests" $ do + -- Single element: returned as-is + runBatcherTest BMBinary 10 ["a"] [] ["a"] + runBatcherTest BMBinary 10 ["aaaa"] [] ["aaaa"] + -- Two elements: binary batch format (2 + 2*2 + content = 6 + content) + runBatcherTest BMBinary 10 ["a", "b"] [] [binaryBatch ["a", "b"]] -- 6 + 2 = 8 + runBatcherTest BMBinary 12 ["aa", "bb"] [] [binaryBatch ["aa", "bb"]] -- 6 + 4 = 10 + -- Three elements (2 + 3*2 + content = 8 + content) + runBatcherTest BMBinary 12 ["a", "b", "c"] [] [binaryBatch ["a", "b", "c"]] -- 8 + 3 = 11 + -- Large element: error (9 bytes > limit 8) + runBatcherTest BMBinary 8 ["9aaaaaaaa"] ["9aaaaaaaa"] [] + -- Mix of sizes: batch of 2 3-byte elements = 6 + 6 = 12 + runBatcherTest BMBinary 12 ["aaa", "bbb", "ccc"] [] ["aaa", binaryBatch ["bbb", "ccc"]] + -- 4 elements of 2 bytes: batch of 4 = 2 + 8 + 8 = 18, batch of 3 = 2 + 6 + 6 = 14 + runBatcherTest BMBinary 16 ["aa", "bb", "cc", "dd"] [] ["aa", binaryBatch ["bb", "cc", "dd"]] + -- Each element separate when can't batch due to size differences + runBatcherTest BMBinary 10 ["aa", "9aaaaaaaa", "bb"] [] ["aa", "9aaaaaaaa", "bb"] + runBatcherTest BMBinary 14 ["aa", "9aaaaaaaa", "bb", "cc"] [] ["aa", "9aaaaaaaa", binaryBatch ["bb", "cc"]] + +-- Helper to construct expected binary batch output +binaryBatch :: [ByteString] -> ByteString +binaryBatch msgs = c2w '=' `B.cons` smpEncodeList (map Large msgs) testImageFitsSingleBatch :: IO () testImageFitsSingleBatch = do @@ -97,23 +126,23 @@ testImageFitsSingleBatch = do let xMsgNewStr = B.replicate xMsgNewRoundedSize 1 descrStr = B.replicate descrRoundedSize 2 - msg s = SndMessage {msgId = 0, sharedMsgId = SharedMsgId "", msgBody = s} + msg s = SndMessage {msgId = 0, sharedMsgId = SharedMsgId "", msgBody = s, signedMsg_ = Nothing} batched = "[" <> xMsgNewStr <> "," <> descrStr <> "]" - runBatcherTest' maxEncodedMsgLength [msg xMsgNewStr, msg descrStr] [] [batched] + runBatcherTest' BMJson maxEncodedMsgLength [msg xMsgNewStr, msg descrStr] [] [batched] -runBatcherTest :: Int -> [SndMessage] -> [ChatError] -> [ByteString] -> Spec -runBatcherTest maxLen msgs expectedErrors expectedBatches = +runBatcherTest :: BatchMode -> Int -> [SndMessage] -> [ChatError] -> [ByteString] -> Spec +runBatcherTest mode maxLen msgs expectedErrors expectedBatches = it ( (show (map (\SndMessage {msgBody} -> msgBody) msgs) <> ", limit " <> show maxLen <> ": should return ") <> (show (length expectedErrors) <> " large, ") <> (show (length expectedBatches) <> " batches") ) - (runBatcherTest' maxLen msgs expectedErrors expectedBatches) + (runBatcherTest' mode maxLen msgs expectedErrors expectedBatches) -runBatcherTest' :: Int -> [SndMessage] -> [ChatError] -> [ByteString] -> IO () -runBatcherTest' maxLen msgs expectedErrors expectedBatches = do - let (errors, batches) = partitionEithers $ batchMessages maxLen (map Right msgs) +runBatcherTest' :: BatchMode -> Int -> [SndMessage] -> [ChatError] -> [ByteString] -> IO () +runBatcherTest' mode maxLen msgs expectedErrors expectedBatches = do + let (errors, batches) = partitionEithers $ batchMessages mode maxLen (map Right msgs) batchedStrs = map (\(MsgBatch batchBody _) -> batchBody) batches testErrors errors `shouldBe` testErrors expectedErrors batchedStrs `shouldBe` expectedBatches diff --git a/tests/ProtocolTests.hs b/tests/ProtocolTests.hs index 5bc8dcb233..a01bce6418 100644 --- a/tests/ProtocolTests.hs +++ b/tests/ProtocolTests.hs @@ -66,7 +66,7 @@ quotedMsg = s ==## msg = do case parseChatMessages s of [acMsg] -> case acMsg of - Right (ACMsg _ msg') -> case checkEncoding msg' of + Right (APMsg _ (ParsedMsg _ _ msg')) -> case checkEncoding msg' of Right msg'' -> msg'' `shouldBe` msg Left e -> expectationFailure $ "checkEncoding error: " <> show e Left e -> expectationFailure $ "parse error: " <> show e @@ -247,19 +247,19 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do #==# XGrpAcpt (MemberId "\1\2\3\4") it "x.grp.mem.new" $ "{\"v\":\"1\",\"event\":\"x.grp.mem.new\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}" - #==# XGrpMemNew MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Nothing, profile = testProfile} Nothing + #==# XGrpMemNew MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Nothing, profile = testProfile, memberKey = Nothing} Nothing it "x.grp.mem.new with member chat version range" $ "{\"v\":\"1\",\"event\":\"x.grp.mem.new\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-17\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}" - #==# XGrpMemNew MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Just $ ChatVersionRange supportedChatVRange, profile = testProfile} Nothing + #==# XGrpMemNew MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Just $ ChatVersionRange supportedChatVRange, profile = testProfile, memberKey = Nothing} Nothing it "x.grp.mem.intro" $ "{\"v\":\"1\",\"event\":\"x.grp.mem.intro\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}" - #==# XGrpMemIntro MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Nothing, profile = testProfile} Nothing + #==# XGrpMemIntro MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Nothing, profile = testProfile, memberKey = Nothing} Nothing it "x.grp.mem.intro with member chat version range" $ "{\"v\":\"1\",\"event\":\"x.grp.mem.intro\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-17\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}" - #==# XGrpMemIntro MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Just $ ChatVersionRange supportedChatVRange, profile = testProfile} Nothing + #==# XGrpMemIntro MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Just $ ChatVersionRange supportedChatVRange, profile = testProfile, memberKey = Nothing} Nothing it "x.grp.mem.intro with member restrictions" $ "{\"v\":\"1\",\"event\":\"x.grp.mem.intro\",\"params\":{\"memberRestrictions\":{\"restriction\":\"blocked\"},\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}" - #==# XGrpMemIntro MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Nothing, profile = testProfile} (Just MemberRestrictions {restriction = MRSBlocked}) + #==# XGrpMemIntro MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Nothing, profile = testProfile, memberKey = Nothing} (Just MemberRestrictions {restriction = MRSBlocked}) it "x.grp.mem.inv" $ "{\"v\":\"1\",\"event\":\"x.grp.mem.inv\",\"params\":{\"memberId\":\"AQIDBA==\",\"memberIntro\":{\"directConnReq\":\"simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-4%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D2-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\",\"groupConnReq\":\"simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-4%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D2-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\"}}}" #==# XGrpMemInv (MemberId "\1\2\3\4") IntroInvitation {groupConnReq = testConnReq, directConnReq = Just testConnReq} @@ -268,10 +268,10 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do #==# XGrpMemInv (MemberId "\1\2\3\4") IntroInvitation {groupConnReq = testConnReq, directConnReq = Nothing} it "x.grp.mem.fwd" $ "{\"v\":\"1\",\"event\":\"x.grp.mem.fwd\",\"params\":{\"memberIntro\":{\"directConnReq\":\"simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-4%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D2-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\",\"groupConnReq\":\"simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-4%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D2-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\"},\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}" - #==# XGrpMemFwd MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Nothing, profile = testProfile} IntroInvitation {groupConnReq = testConnReq, directConnReq = Just testConnReq} + #==# XGrpMemFwd MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Nothing, profile = testProfile, memberKey = Nothing} IntroInvitation {groupConnReq = testConnReq, directConnReq = Just testConnReq} it "x.grp.mem.fwd with member chat version range and w/t directConnReq" $ "{\"v\":\"1\",\"event\":\"x.grp.mem.fwd\",\"params\":{\"memberIntro\":{\"groupConnReq\":\"simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-4%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D2-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\"},\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-17\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}" - #==# XGrpMemFwd MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Just $ ChatVersionRange supportedChatVRange, profile = testProfile} IntroInvitation {groupConnReq = testConnReq, directConnReq = Nothing} + #==# XGrpMemFwd MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Just $ ChatVersionRange supportedChatVRange, profile = testProfile, memberKey = Nothing} IntroInvitation {groupConnReq = testConnReq, directConnReq = Nothing} it "x.grp.mem.info" $ "{\"v\":\"1\",\"event\":\"x.grp.mem.info\",\"params\":{\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}" #==# XGrpMemInfo (MemberId "\1\2\3\4") testProfile