mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-04-25 05:35:49 +00:00
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 <evgeny@poberezkin.com> * 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>
This commit is contained in:
Evgeny
@@ -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
|
||||
|
||||
@@ -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"
|
||||
|
||||
@@ -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
|
||||
|
||||
---
|
||||
|
||||
|
||||
@@ -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"
|
||||
|
||||
|
||||
---
|
||||
|
||||
|
||||
@@ -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.
|
||||
|
||||
652
docs/rfcs/2026-01-23-member-keys-plan.md
Normal file
652
docs/rfcs/2026-01-23-member-keys-plan.md
Normal file
@@ -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:
|
||||
```
|
||||
/<binding><sigs><{"event":"x.msg.new",...}>
|
||||
```
|
||||
|
||||
2. **Relay** receives, parses to validate, stores original bytes in `msg_body`
|
||||
|
||||
3. **Relay** forwards as binary batch element(s):
|
||||
```
|
||||
=<count>(<len> ">" <memberId><memberName><brokerTs><original-bytes>)*
|
||||
```
|
||||
|
||||
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.
|
||||
@@ -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 {
|
||||
|
||||
@@ -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 {
|
||||
|
||||
@@ -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 {
|
||||
|
||||
473
plans/2026-03-13-message-keys-forwarding.md
Normal file
473
plans/2026-03-13-message-keys-forwarding.md
Normal file
@@ -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: `<bindingTag:1> <sigCount:1> (<keyRef><sig:64>)*`
|
||||
|
||||
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 `><fwd>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 `><fwd>/<sigs><json>` 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 (`/<sigs><json>`), `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)
|
||||
↓
|
||||
/<sigs><json> ──────────→ 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)
|
||||
><fwd>/<sigs><msg_body> ──────→ 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: ><fwd><re-encoded-json> ← 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: ><fwd>/<sigs><original-json> ← 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 → `><fwd>/<sigs><original-json>` 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` |
|
||||
293
plans/chat-relays-mvp-launch-plan.md
Normal file
293
plans/chat-relays-mvp-launch-plan.md
Normal file
@@ -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<memberId><memberName><brokerTs><original-bytes>` (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
|
||||
@@ -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}
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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 = ""}
|
||||
|
||||
@@ -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 =
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
}
|
||||
|
||||
|
||||
@@ -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 =<count>(<len:2><body>)*
|
||||
-- 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: ><GrpMsgForward>[/<sigs>]<body>.
|
||||
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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -32,6 +32,7 @@ data RcvGroupEvent
|
||||
| RGEMemberCreatedContact -- CRNewMemberContactReceivedInv
|
||||
| RGEMemberProfileUpdated {fromProfile :: Profile, toProfile :: Profile} -- CRGroupMemberUpdated
|
||||
| RGENewMemberPendingReview
|
||||
| RGEMsgBadSignature
|
||||
deriving (Show)
|
||||
|
||||
data SndGroupEvent
|
||||
|
||||
@@ -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: <binding:1> <sigCount:1> (<keyRef><sig:64>)* <body>
|
||||
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: '=' <count:1> (<len:2> <body>)*
|
||||
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)
|
||||
|
||||
|
||||
@@ -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 =
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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;
|
||||
|]
|
||||
|
||||
@@ -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
|
||||
);
|
||||
|
||||
|
||||
|
||||
@@ -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;
|
||||
|]
|
||||
|
||||
@@ -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:
|
||||
|
||||
|
||||
@@ -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(
|
||||
|
||||
@@ -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 ""
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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']
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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' <count:1> (<len:2> <body>)*
|
||||
-- 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
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user