From 30ae0d864ce28e30c193cd1e8617b37cb4205041 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Thu, 16 Apr 2026 23:48:19 +0100 Subject: [PATCH] core: share links to channels and verify shared links when connecting (#6810) * core: share links to channels and verify shared links when connecting * refactor * improve * refactor case * simplify * exctract encodeChatBinding * share api * corrections Co-authored-by: Evgeny * tests * verify signature in the tests * drop signature if context does not match on reception * try to test "fake" forward * fix * fix direct chat sharing test * channel test * sign link * rename api * refactor view * chal link item CLI view, tests * clean up * share channel in channel as channel * query plan * fix test * refactor * whitespace * simpler * refactor * dont use partial field update --------- Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com> --- bots/api/COMMANDS.md | 1 + bots/api/TYPES.md | 30 +++ bots/src/API/Docs/Commands.hs | 2 + bots/src/API/Docs/Responses.hs | 1 + bots/src/API/Docs/Types.hs | 4 + bots/src/API/TypeInfo.hs | 1 + cabal.project | 2 +- .../types/typescript/src/commands.ts | 1 + .../types/typescript/src/types.ts | 29 ++ ...026-04-11-channel-invitations-directory.md | 255 ++++++++++++++++++ src/Simplex/Chat/Controller.hs | 22 +- src/Simplex/Chat/Library/Commands.hs | 161 +++++++---- src/Simplex/Chat/Library/Internal.hs | 12 +- src/Simplex/Chat/Library/Subscriber.hs | 24 +- src/Simplex/Chat/Protocol.hs | 36 ++- src/Simplex/Chat/Store/Messages.hs | 6 +- .../SQLite/Migrations/chat_query_plans.txt | 39 +++ src/Simplex/Chat/View.hs | 54 +++- tests/ChatTests/ChatRelays.hs | 163 +++++++++++ tests/ChatTests/Groups.hs | 38 ++- tests/ChatTests/Utils.hs | 3 + 21 files changed, 791 insertions(+), 93 deletions(-) create mode 100644 plans/2026-04-11-channel-invitations-directory.md diff --git a/bots/api/COMMANDS.md b/bots/api/COMMANDS.md index b5d49077c0..07bb692e0f 100644 --- a/bots/api/COMMANDS.md +++ b/bots/api/COMMANDS.md @@ -1280,6 +1280,7 @@ Determine SimpleX link type and if the bot is already connected via this link. **Parameters**: - userId: int64 - connectionLink: string? +- linkOwnerSig: [LinkOwnerSig](./TYPES.md#linkownersig)? **Syntax**: diff --git a/bots/api/TYPES.md b/bots/api/TYPES.md index aee16ac5ea..de9952063c 100644 --- a/bots/api/TYPES.md +++ b/bots/api/TYPES.md @@ -117,6 +117,7 @@ This file is generated automatically. - [InvitationLinkPlan](#invitationlinkplan) - [InvitedBy](#invitedby) - [LinkContent](#linkcontent) +- [LinkOwnerSig](#linkownersig) - [LinkPreview](#linkpreview) - [LocalProfile](#localprofile) - [MemberCriteria](#membercriteria) @@ -132,6 +133,7 @@ This file is generated automatically. - [NetworkError](#networkerror) - [NewUser](#newuser) - [NoteFolder](#notefolder) +- [OwnerVerification](#ownerverification) - [PendingContactConnection](#pendingcontactconnection) - [PrefEnabled](#prefenabled) - [Preferences](#preferences) @@ -1698,6 +1700,7 @@ Error: Ok: - type: "ok" - contactSLinkData_: [ContactShortLinkData](#contactshortlinkdata)? +- ownerVerification: [OwnerVerification](#ownerverification)? OwnLink: - type: "ownLink" @@ -2261,6 +2264,7 @@ Ok: - type: "ok" - groupSLinkInfo_: [GroupShortLinkInfo](#groupshortlinkinfo)? - groupSLinkData_: [GroupShortLinkData](#groupshortlinkdata)? +- ownerVerification: [OwnerVerification](#ownerverification)? OwnLink: - type: "ownLink" @@ -2526,6 +2530,7 @@ Public: Ok: - type: "ok" - contactSLinkData_: [ContactShortLinkData](#contactshortlinkdata)? +- ownerVerification: [OwnerVerification](#ownerverification)? OwnLink: - type: "ownLink" @@ -2578,6 +2583,16 @@ Unknown: - json: JSONObject +--- + +## LinkOwnerSig + +**Record type**: +- ownerId: string? +- chatBinding: string +- ownerSig: string + + --- ## LinkPreview @@ -2683,6 +2698,7 @@ Chat: - type: "chat" - text: string - chatLink: [MsgChatLink](#msgchatlink) +- ownerSig: [LinkOwnerSig](#linkownersig)? Unknown: - type: "unknown" @@ -2830,6 +2846,20 @@ SubscribeError: - unread: bool +--- + +## OwnerVerification + +**Discriminated union type**: + +Verified: +- type: "verified" + +Failed: +- type: "failed" +- reason: string + + --- ## PendingContactConnection diff --git a/bots/src/API/Docs/Commands.hs b/bots/src/API/Docs/Commands.hs index 26b48e56b0..de91c751d2 100644 --- a/bots/src/API/Docs/Commands.hs +++ b/bots/src/API/Docs/Commands.hs @@ -282,6 +282,7 @@ cliCommands = "SetUserGroupReceipts", "SetUserAutoAcceptMemberContacts", "SetUserTimedMessages", + "SharePublicGroup", "ShowChatItem", "ShowChatItemInfo", "ShowGroupDescription", @@ -407,6 +408,7 @@ undocumentedCommands = "APISetUserGroupReceipts", "APISetUserServers", "APISetUserUIThemes", + "APIShareChatMsgContent", "APIStandaloneFileInfo", "APIStorageEncryption", "APISuspendChat", diff --git a/bots/src/API/Docs/Responses.hs b/bots/src/API/Docs/Responses.hs index 873ca5eb97..eb67c5670b 100644 --- a/bots/src/API/Docs/Responses.hs +++ b/bots/src/API/Docs/Responses.hs @@ -132,6 +132,7 @@ undocumentedResponses = "CRChatItemInfo", "CRChatItems", "CRChatItemTTL", + "CRChatMsgContent", "CRChatRelayTestResult", "CRChats", "CRConnectionsDiff", diff --git a/bots/src/API/Docs/Types.hs b/bots/src/API/Docs/Types.hs index 826b8c1957..18b7d5e43b 100644 --- a/bots/src/API/Docs/Types.hs +++ b/bots/src/API/Docs/Types.hs @@ -299,6 +299,7 @@ chatTypesDocsData = (sti @InvitationLinkPlan, STUnion, "ILP", [], "", ""), (sti @InvitedBy, STUnion, "IB", [], "", ""), (sti @LinkContent, STUnion, "LC", [], "", ""), + (sti @LinkOwnerSig, STRecord, "", [], "", ""), (sti @LinkPreview, STRecord, "", [], "", ""), (sti @LocalProfile, STRecord, "", [], "", ""), (sti @MemberCriteria, STEnum1, "MC", [], "", ""), @@ -314,6 +315,7 @@ chatTypesDocsData = (sti @NetworkError, STUnion, "NE", [], "", ""), (sti @NewUser, STRecord, "", [], "", ""), (sti @NoteFolder, STRecord, "", [], "", ""), + (sti @OwnerVerification, STUnion, "OV", [], "", ""), (sti @PendingContactConnection, STRecord, "", [], "", ""), (sti @PrefEnabled, STRecord, "", [], "", ""), (sti @Preferences, STRecord, "", [], "", ""), @@ -506,6 +508,7 @@ deriving instance Generic JSONCIDirection deriving instance Generic JSONCIFileStatus deriving instance Generic JSONCIStatus deriving instance Generic LinkContent +deriving instance Generic LinkOwnerSig deriving instance Generic LinkPreview deriving instance Generic LocalProfile deriving instance Generic MemberCriteria @@ -521,6 +524,7 @@ deriving instance Generic MsgSigStatus deriving instance Generic NetworkError deriving instance Generic NewUser deriving instance Generic NoteFolder +deriving instance Generic OwnerVerification deriving instance Generic PendingContactConnection deriving instance Generic PrefEnabled deriving instance Generic Preferences diff --git a/bots/src/API/TypeInfo.hs b/bots/src/API/TypeInfo.hs index 37f74e4275..36e87db62d 100644 --- a/bots/src/API/TypeInfo.hs +++ b/bots/src/API/TypeInfo.hs @@ -214,6 +214,7 @@ toTypeInfo tr = "ProtocolServer", "SbKey", "SharedMsgId", + "Signature", "TransportHost", "UIColor", "UserPwd", diff --git a/cabal.project b/cabal.project index 65983d22a5..e7d70bde64 100644 --- a/cabal.project +++ b/cabal.project @@ -21,7 +21,7 @@ constraints: zip +disable-bzip2 +disable-zstd source-repository-package type: git location: https://github.com/simplex-chat/simplexmq.git - tag: bc5ea42bec3a63e46b191e4150dd79957f114e01 + tag: 95b17ada2795e1c5c84bbe2a50a0752ee66d0aad source-repository-package type: git diff --git a/packages/simplex-chat-client/types/typescript/src/commands.ts b/packages/simplex-chat-client/types/typescript/src/commands.ts index d5c3046e3a..2f2b114bfe 100644 --- a/packages/simplex-chat-client/types/typescript/src/commands.ts +++ b/packages/simplex-chat-client/types/typescript/src/commands.ts @@ -471,6 +471,7 @@ export namespace APIAddContact { export interface APIConnectPlan { userId: number // int64 connectionLink?: string + linkOwnerSig?: T.LinkOwnerSig } export namespace APIConnectPlan { diff --git a/packages/simplex-chat-client/types/typescript/src/types.ts b/packages/simplex-chat-client/types/typescript/src/types.ts index 621a69dcc8..f9735f2b0c 100644 --- a/packages/simplex-chat-client/types/typescript/src/types.ts +++ b/packages/simplex-chat-client/types/typescript/src/types.ts @@ -1986,6 +1986,7 @@ export namespace ContactAddressPlan { export interface Ok extends Interface { type: "ok" contactSLinkData_?: ContactShortLinkData + ownerVerification?: OwnerVerification } export interface OwnLink extends Interface { @@ -2577,6 +2578,7 @@ export namespace GroupLinkPlan { type: "ok" groupSLinkInfo_?: GroupShortLinkInfo groupSLinkData_?: GroupShortLinkData + ownerVerification?: OwnerVerification } export interface OwnLink extends Interface { @@ -2787,6 +2789,7 @@ export namespace InvitationLinkPlan { export interface Ok extends Interface { type: "ok" contactSLinkData_?: ContactShortLinkData + ownerVerification?: OwnerVerification } export interface OwnLink extends Interface { @@ -2856,6 +2859,12 @@ export namespace LinkContent { } } +export interface LinkOwnerSig { + ownerId?: string + chatBinding: string + ownerSig: string +} + export interface LinkPreview { uri: string title: string @@ -2973,6 +2982,7 @@ export namespace MsgContent { type: "chat" text: string chatLink: MsgChatLink + ownerSig?: LinkOwnerSig } export interface Unknown extends Interface { @@ -3131,6 +3141,25 @@ export interface NoteFolder { unread: boolean } +export type OwnerVerification = OwnerVerification.Verified | OwnerVerification.Failed + +export namespace OwnerVerification { + export type Tag = "verified" | "failed" + + interface Interface { + type: Tag + } + + export interface Verified extends Interface { + type: "verified" + } + + export interface Failed extends Interface { + type: "failed" + reason: string + } +} + export interface PendingContactConnection { pccConnId: number // int64 pccAgentConnId: string diff --git a/plans/2026-04-11-channel-invitations-directory.md b/plans/2026-04-11-channel-invitations-directory.md new file mode 100644 index 0000000000..6ae2c046db --- /dev/null +++ b/plans/2026-04-11-channel-invitations-directory.md @@ -0,0 +1,255 @@ +# Public Group Invitations & Directory Listing + +## Goal + +Enable public group (channel) subscribers to invite new subscribers by sharing a channel card in any chat where they can send messages. Channel owners can prove ownership via a signed card. This unblocks directory service support for public groups alongside regular groups. + +Sharing channels should be as simple as forwarding — share button on channel opens chat picker, sends a channel card as a regular message. Old clients show the text; new clients show a rich card with profile and join button. + +## Context + +### Current state +- Public groups have `PublicGroupProfile {groupType = GTChannel, groupLink, publicGroupId}` and `useRelays = True` +- Users join public groups via link → `APIPrepareGroup` → `APIConnectPreparedGroup` +- `MCChat` message content exists with `MsgChatLink` variants for contacts, invitations, and groups (`MCLGroup`) +- Group invitations (`XGrpInv`) carry `connRequest :: ConnReqInvitation` — public groups don't use this mechanism +- Directory bot registers groups via group invitation (owner invites bot as admin) — public groups need a different flow + +### Owner keys in public group links +- `FixedLinkData.rootKey :: PublicKeyEd25519` — genesis root key +- `UserContactData.owners :: [OwnerAuth]` — chain of authorized owner keys, each signed by root or previous owner +- Public group creator stores `GroupKeys {groupRootKey = GRKPrivate rootPrivKey, memberPrivKey}` +- `memberPrivKey`'s public key = `ownerKey` in the `OwnerAuth` entry (created via `newOwnerAuth`) +- `publicGroupId = sha256(rootPubKey)` — immutable group identity + +### DR connection shared secret +- Each direct connection has `rcAD` (Associated Data) from X3DH key exchange +- `getConnectionRatchetAdHash` returns `sha256(rcAD)` — binding for replay protection + +## Design + +### Channel cards as MCChat messages + +Channel invitations are sent as regular `XMsgNew` with `MCChat` content. No new protocol messages. + +```haskell +data MsgContent + = ... + | MCChat {text :: Text, chatLink :: MsgChatLink, ownerSig :: Maybe LinkOwnerSig} + | ... +``` + +`ownerSig` is optional. Old clients ignore it (missing field) and show `text` as a regular message. + +```haskell +data LinkOwnerSig = LinkOwnerSig + { ownerId :: Maybe OwnerId, -- Nothing = root key, Just = owner key from OwnerAuth chain + binding :: B64UrlByteString, + ownerSig :: B64UrlByteString + } +``` + +Sending is supported for channel cards only (for now). Verification is generic for all `MsgChatLink` types: +- `ownerId = Just id`: verified against matching `OwnerAuth.ownerKey` in the link's owner chain (channels) +- `ownerId = Nothing`: verified against `rootKey` from `FixedLinkData` (contacts, invitations) + +The sender proves control over the link regardless of type. + +### What is signed + +`smpEncode chatBinding <> bindingData <> smpEncode chatLink` signed with `memberPrivKey`. + +Binding depends on where the card is sent: +- **Direct chat**: `CBDirect` with `ratchetAdHash` +- **Public group**: `CBGroup` with `smpEncode (publicGroupId, memberId)` +- **Group without public identity**: signature treated as failed at verification time + +Binding is to chat, not to message (`sharedMsgId` is not included). This allows the sender to forward their own signed card within the same chat (e.g., re-sharing a channel link as a reminder) without invalidating the signature. Message-level binding would prevent this since forwarded messages get new `sharedMsgId`s. + +### Sending flow + +1. User presses "Share" on channel → API call `APIPrepareLinkOwnerSig GroupId` returns `Maybe LinkOwnerSig` +2. Opens chat picker (same as forwarding) — chats with disabled simplex links greyed out +3. Sends `XMsgNew` with `MCChat {text = displayName, chatLink = MCLGroup {connLink, groupProfile}, ownerSig}` +4. Creates regular `CISndMsgContent` chat item — no new item types, no new response types + +### Receiving flow + +Regular `XMsgNew` processing. Creates `CIRcvMsgContent (MCChat ...)`. No hidden groups, no async verification, no special events. + +UI renders channel card with profile, member count, join button. If `ownerSig` present, shows "signed by owner" indicator (unverified until join). + +### Verification at join time + +When user taps "Join" on a channel card: + +1. UI extracts `connLink` and `ownerSig` from `MCChat` message content +2. UI calls `APIConnectPlan` with the link and signature. `APIConnectPlan` extended: + ```haskell + APIConnectPlan {userId :: UserId, connectionLink :: Maybe AConnectionLink, linkOwnerSig :: Maybe LinkOwnerSig} + ``` + Parser: `/_connect plan [sig=]` +3. Inside `connectPlan`, if `linkOwnerSig` is present: + - Gets `FixedLinkData {rootKey}` and `UserContactData {owners}` from resolved link + - Finds verification key: `ownerId = Nothing` → `rootKey`, `ownerId = Just id` → matching `OwnerAuth.ownerKey` + - Verifies binding data against expected value from context + - Verifies signature +4. Each "OK" plan variant extended with verification result: + ```haskell + data LinkSigVerification = LSVVerified | LSVFailed {reason :: Text} + + ILPOk {contactSLinkData_, linkSigVerification :: Maybe LinkSigVerification} + CAPOk {contactSLinkData_, linkSigVerification :: Maybe LinkSigVerification} + GLPOk {groupSLinkInfo_, groupSLinkData_, linkSigVerification :: Maybe LinkSigVerification} + -- Nothing = not signed, Just LSVVerified = verified, Just LSVFailed = failed with reason + ``` + Reasons: "unknown owner ID", "binding data mismatch", "signature verification failed", "no group identity for verification" +5. UI shows verification result in join/connect alert for the OK plan variants +6. User confirms → `APIPrepareGroup` → `APIConnectPreparedGroup` — existing join flow, no changes + +Pasted links (no message context) pass `linkOwnerSig = Nothing` — plan shows "not signed." + +### Forwarding + +When `MCChat` is forwarded, `ownerSig` is dropped — UNLESS forwarded by sender in the same chat (re-sharing own card as reminder). Signature is bound to chat context, so forwarding in the same chat preserves validity. + +Implementation: in forwarding code, drop `ownerSig` unless `fromChatRef == toChatRef` and sender is the same user. + +### Simplex link permission + +`MCChat` IS a simplex link — if `SGFSimplexLinks` is prohibited for the sender's role, `MCChat` should be prohibited regardless of content. + +Currently `prohibitedSimplexLinks` (Internal.hs:363) only checks formatted text. Fix: also check `MsgContent` type — if it's `MCChat` and simplex links are not allowed, prohibit it. This covers both send and receive via existing `prohibitedGroupContent` calls. + +For backward compatibility, the current text-level check is sufficient since the link is included in `text`. But the `MCChat` type check is the correct long-term fix. + +### CLI view + +`MCChat` with `MCLGroup` renders as channel card with display name. If `ownerSig` present, shows "(signed)" indicator. + +## Directory bot changes + +### Registration flow + +Bot receives regular `CIRcvMsgContent (MCChat ...)` messages in direct chat from channel owners. Bot checks `ownerSig` is present. Verifies at join time via `connectPlan`. No special events needed. + +- Owner sends channel card to bot in DM (signed) +- Bot resolves link, verifies owner signature +- Bot joins channel as subscriber +- Simplified approval flow: `GRSProposed` → `GRSPendingApproval` → `GRSActive` + +### Profile monitoring + +Bot as subscriber receives `XGrpInfo` when owner updates profile. On profile change: re-resolve link, compare. Periodic re-verification. + +### Search and listing + +Search includes both groups and public groups. No separate listing category — `groupProfile.publicGroup` is the source of truth. `DETGroup` works for both in JSON listing. + +## Implementation plan (diff from master) + +### Step 1: LinkOwnerSig type + +- `LinkOwnerSig` type in Types.hs (or Protocol.hs alongside `MCChat`) +- `ownerSig :: Maybe LinkOwnerSig` field on `MCChat` +- JSON derivation with backward compat (optional field) + +### Step 2: CBDirect + +- Add `CBDirect` to `ChatBinding` in Protocol.hs (already done on master via refactoring PR) + +### Step 3: Share chat message content API + +New command that constructs the complete `MCChat` content for sharing: +```haskell +-- Controller.hs +APIShareChatMsgContent {shareChatRef :: ChatRef, toChatRef :: ChatRef} +-- returns CRChatMsgContent {user :: User, msgContent :: MsgContent} +``` + +Implementation in Commands.hs: +1. Load shared chat info from `shareChatRef` — initially only `CTGroup` with public groups supported +2. Get `PublicGroupProfile {groupLink}` and `groupProfile` from group +3. Determine if user is owner (has `GroupKeys {memberPrivKey}`) +4. If owner, compute binding based on `toChatRef`: + - `ChatRef CTDirect contactId` → `getConnectionRatchetAdHash` on contact's connection → `CBDirect` + - `ChatRef CTGroup groupId` → `smpEncode (publicGroupId, memberId)` if group has identity → `CBGroup` + - Group without identity → `Nothing` (can't sign) +5. If owner and binding available, sign `smpEncode chatBinding <> bindingData <> smpEncode chatLink` with `memberPrivKey` +6. Return `MCChat {text = displayName, chatLink = MCLGroup {connLink = groupLink, groupProfile}, ownerSig}` + +Parser: `/_share_chat ` + +UI flow: press Share on channel → chat picker → select destination → call `APIShareChatMsgContent` → get `MsgContent` → send via existing `APISendMessages` + +All business logic (ownership check, signing decision, link extraction, profile inclusion) stays in core. UI only passes two chat refs and sends the returned content. + +### Step 4: connectPlan verification + +Extend `APIConnectPlan` (Controller.hs:472): +```haskell +APIConnectPlan {userId :: UserId, connectionLink :: Maybe AConnectionLink, linkOwnerSig :: Maybe LinkOwnerSig} +``` + +Parser (Commands.hs:4945): extend to accept optional JSON `LinkOwnerSig` parameter. + +In `connectPlan` (Commands.hs), pass `linkOwnerSig` to `groupShortLinkPlan` / `groupJoinRequestPlan`. + +In `groupShortLinkPlan` (Commands.hs ~line 3944): after resolving the link via `getShortLinkConnReq`, if `linkOwnerSig` is present: +1. Extract `FixedLinkData {rootKey}` and `UserContactData {owners}` +2. If `ownerId = Nothing`: verify against `rootKey` +3. If `ownerId = Just id`: find `OwnerAuth` where `ownerId == id`, verify against `ownerKey` +4. Check binding data matches expected +5. Verify signature + +Extend `GroupLinkPlan` (Controller.hs:1025): +```haskell +GLPOk {groupSLinkInfo_, groupSLinkData_, ownerVerified :: Maybe Bool} +``` +`Nothing` = not signed, `Just True` = verified, `Just False` = failed. + +`CRConnectionPlan` response carries this through to UI — shown in plan alert. + +### Step 5: Forwarding — drop ownerSig + +In message forwarding code (Commands.hs, `APIForwardChatItems`), when forwarding `MCChat` content, set `ownerSig = Nothing`. + +Location: Commands.hs where forwarded message content is constructed — find where `MCChat` is handled in forwarding and strip the signature. + +### Step 6: Permission check + +Fix `prohibitedSimplexLinks` (Internal.hs:363) to also check `MsgContent` type — if `MCChat`, treat as simplex link. Covers both send and receive paths via existing `prohibitedGroupContent` calls. + +For backward compatibility, the link is also in `text` field, so existing text-level check catches it. The type check is the correct fix. + +### Step 7: CLI view + +In `viewChatItem` (View.hs), `MCChat` content already renders via `ttyMsgContent`. Extend to show channel card format and "(signed)" indicator when `ownerSig` is present. + +### Step 8: groupLinkData owners preservation + +Fix `groupLinkData` (Internal.hs:1330) to reconstruct `OwnerAuth` from `GroupKeys` instead of hardcoding `owners = []`. This ensures the resolved link data has the owner keys needed for verification. + +Implementation: when `GroupKeys` has `GRKPrivate rootPrivKey` and `memberPrivKey`, reconstruct `OwnerAuth` with `ownerId = unMemberId memberId`, `ownerKey = publicKey memberPrivKey`, `authOwnerSig = sign rootPrivKey (ownerId <> encodePubKey ownerKey)`. + +### Step 9: Tests + +- Share channel card in direct chat (owner signed) +- Share channel card in group (unsigned — no binding for groups without identity) +- Share channel card in channel +- Join via channel card — verify `connectPlan` shows verification result +- Non-public group share rejected +- Forwarded card has no signature +- Old client compatibility (text field shown) + +### Step 10: Directory bot + +- Handle `MCChat` with `MCLGroup` in `crDirectoryEvent_` +- Channel registration flow +- Profile monitoring + +## What stays from refactoring PR (already on master) + +- `CBDirect` in `ChatBinding` +- `HasShortLink` typeclass with `connShortLink'` +- `setShortLinkType` / `setShortLinkType_` diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 16652f90dd..f4757ca501 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -341,6 +341,7 @@ data ChatCommand | APIGetReactionMembers {userId :: UserId, groupId :: GroupId, chatItemId :: ChatItemId, reaction :: MsgReaction} | APIPlanForwardChatItems {fromChatRef :: ChatRef, chatItemIds :: NonEmpty ChatItemId} | APIForwardChatItems {toChatRef :: ChatRef, sendAsGroup :: ShowGroupAsSender, fromChatRef :: ChatRef, chatItemIds :: NonEmpty ChatItemId, ttl :: Maybe Int} + | APIShareChatMsgContent {shareChatRef :: ChatRef, toSendRef :: SendRef} | APIUserRead UserId | UserRead | APIChatRead {chatRef :: ChatRef} @@ -469,7 +470,7 @@ data ChatCommand | AddContact IncognitoEnabled | APISetConnectionIncognito Int64 IncognitoEnabled | APIChangeConnectionUser Int64 UserId -- new user id to switch connection to - | APIConnectPlan {userId :: UserId, connectionLink :: Maybe AConnectionLink} -- Maybe is used to report link parsing failure as special error + | APIConnectPlan {userId :: UserId, connectionLink :: Maybe AConnectionLink, linkOwnerSig :: Maybe LinkOwnerSig} -- Maybe AConnectionLink is used to report link parsing failure as special error | APIPrepareContact UserId ACreatedConnLink ContactShortLinkData | APIPrepareGroup UserId CreatedLinkContact DirectLink GroupShortLinkData | APIChangePreparedContactUser ContactId UserId @@ -500,6 +501,7 @@ data ChatCommand | ForwardMessage {toChatName :: ChatName, fromContactName :: ContactName, forwardedMsg :: Text} | ForwardGroupMessage {toChatName :: ChatName, fromGroupName :: GroupName, fromMemberName_ :: Maybe ContactName, forwardedMsg :: Text} | ForwardLocalMessage {toChatName :: ChatName, forwardedMsg :: Text} + | SharePublicGroup {shareGroupName :: GroupName, toChatName :: ChatName} | SendMessage SendName Text | SendMemberContactMessage GroupName ContactName Text | AcceptMemberContact ContactName @@ -760,6 +762,7 @@ data ChatResponse | CRLeftMemberUser {user :: User, groupInfo :: GroupInfo} | CRGroupDeletedUser {user :: User, groupInfo :: GroupInfo, msgSigned :: Bool} | CRForwardPlan {user :: User, itemsCount :: Int, chatItemIds :: [ChatItemId], forwardConfirmation :: Maybe ForwardConfirmation} + | CRChatMsgContent {user :: User, msgContent :: MsgContent} | CRRcvFileAccepted {user :: User, chatItem :: AChatItem} -- TODO add chatItem :: AChatItem | CRRcvFileAcceptedSndCancelled {user :: User, rcvFileTransfer :: RcvFileTransfer} @@ -1007,14 +1010,14 @@ data ConnectionPlan deriving (Show) data InvitationLinkPlan - = ILPOk {contactSLinkData_ :: Maybe ContactShortLinkData} + = ILPOk {contactSLinkData_ :: Maybe ContactShortLinkData, ownerVerification :: Maybe OwnerVerification} | ILPOwnLink | ILPConnecting {contact_ :: Maybe Contact} | ILPKnown {contact :: Contact} deriving (Show) data ContactAddressPlan - = CAPOk {contactSLinkData_ :: Maybe ContactShortLinkData} + = CAPOk {contactSLinkData_ :: Maybe ContactShortLinkData, ownerVerification :: Maybe OwnerVerification} | CAPOwnLink | CAPConnectingConfirmReconnect | CAPConnectingProhibit {contact :: Contact} @@ -1023,13 +1026,18 @@ data ContactAddressPlan deriving (Show) data GroupLinkPlan - = GLPOk {groupSLinkInfo_ :: Maybe GroupShortLinkInfo, groupSLinkData_ :: Maybe GroupShortLinkData} + = GLPOk {groupSLinkInfo_ :: Maybe GroupShortLinkInfo, groupSLinkData_ :: Maybe GroupShortLinkData, ownerVerification :: Maybe OwnerVerification} | GLPOwnLink {groupInfo :: GroupInfo} | GLPConnectingConfirmReconnect | GLPConnectingProhibit {groupInfo_ :: Maybe GroupInfo} | GLPKnown {groupInfo :: GroupInfo} deriving (Show) +data OwnerVerification + = OVVerified + | OVFailed {reason :: Text} + deriving (Show) + type DirectLink = Bool data GroupShortLinkInfo = GroupShortLinkInfo @@ -1042,11 +1050,11 @@ data GroupShortLinkInfo = GroupShortLinkInfo connectionPlanProceed :: ConnectionPlan -> Bool connectionPlanProceed = \case CPInvitationLink ilp -> case ilp of - ILPOk _ -> True + ILPOk {} -> True ILPOwnLink -> True _ -> False CPContactAddress cap -> case cap of - CAPOk _ -> True + CAPOk {} -> True CAPOwnLink -> True CAPConnectingConfirmReconnect -> True CAPContactViaAddress _ -> True @@ -1631,6 +1639,8 @@ $(JQ.deriveJSON (enumJSON $ dropPrefix "HS") ''HelpSection) $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CLQ") ''ChatListQuery) +$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "OV") ''OwnerVerification) + $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "ILP") ''InvitationLinkPlan) $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CAP") ''ContactAddressPlan) diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index d2660c6203..3a1cc76a44 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -101,6 +101,7 @@ import qualified Simplex.Messaging.Crypto.ShortLink as SL 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 IKPQOn, pattern PQEncOff, pattern PQSupportOff, pattern PQSupportOn) +import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (base64P) import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType (..), MsgFlags (..), NtfServer, ProtoServerWithAuth (..), ProtocolServer, ProtocolType (..), ProtocolTypeI (..), SProtocolType (..), SubscriptionMode (..), UserProtocol, userProtocol) @@ -690,7 +691,7 @@ processChatCommand vr nm = \case gInfo@GroupInfo {groupId, membership} <- withFastStore $ \db -> getGroupInfo db vr user chatId when (isNothing scope) $ assertUserGroupRole gInfo GRAuthor let (_, ft_) = msgContentTexts mc - if prohibitedSimplexLinks gInfo membership ft_ + if prohibitedSimplexLinks gInfo membership mc ft_ then throwCmdError ("feature not allowed " <> T.unpack (groupFeatureNameText GFSimplexLinks)) else do -- TODO [knocking] check chat item scope? @@ -999,7 +1000,13 @@ processChatCommand vr nm = \case CTContactConnection -> throwCmdError "not supported" where prepareMsgReq :: CChatItem c -> CM (Maybe (MsgContent, Maybe CryptoFile)) - prepareMsgReq (CChatItem _ ci) = forwardMsgContent ci $>>= forwardContent ci + prepareMsgReq (CChatItem md ci) = forwardMsgContent ci $>>= forwardContent ci . dropOwnerSig + where + dropOwnerSig = \case + mc@MCChat {text, chatLink} + | SMDSnd <- md, fromChat == toChat -> mc + | otherwise -> MCChat {text, chatLink, ownerSig = Nothing} + mc -> mc forwardCIFF :: ChatItem c d -> Maybe CIForwardedFrom -> Maybe CIForwardedFrom forwardCIFF ChatItem {meta = CIMeta {itemForwarded}} ciff = case itemForwarded of Nothing -> ciff @@ -1067,6 +1074,41 @@ processChatCommand vr nm = \case let formattedDate = formatTime defaultTimeLocale "%Y%m%d_%H%M%S" currentDate let ext = takeExtension fileName pure $ prefix <> formattedDate <> ext + APIShareChatMsgContent (ChatRef CTGroup groupId _) toSendRef -> withUser $ \user -> do + GroupInfo {groupProfile = gp@GroupProfile {publicGroup}, membership = GroupMember {memberId, memberRole}, groupKeys} <- + withFastStore $ \db -> getGroupInfo db vr user groupId + case publicGroup of + Nothing -> throwCmdError "not a public group" + Just PublicGroupProfile {groupLink} -> do + let signingKeys = case (memberRole, groupKeys) of + (GROwner, Just gk@GroupKeys {groupRootKey = GRKPrivate _}) -> Just gk + _ -> Nothing + ownerSig <- + pure signingKeys $>>= \GroupKeys {memberPrivKey} -> + mkLinkOwnerSig memberPrivKey groupLink memberId <$$> shareChatBinding user toSendRef + let text = safeDecodeUtf8 $ strEncode groupLink + pure $ CRChatMsgContent user MCChat {text, chatLink = MCLGroup groupLink gp, ownerSig} + where + mkLinkOwnerSig :: ConnectionModeI m => C.PrivateKeyEd25519 -> ConnShortLink m -> MemberId -> (ChatBinding, ByteString) -> LinkOwnerSig + mkLinkOwnerSig privKey connLink MemberId {unMemberId} (cbTag, bindingData) = + let ownerId = Just $ B64UrlByteString unMemberId + cb = encodeChatBinding cbTag bindingData + ownerSig = C.sign' privKey $ cb <> smpEncode connLink + in LinkOwnerSig {ownerId, chatBinding = B64UrlByteString cb, ownerSig} + shareChatBinding :: User -> SendRef -> CM (Maybe (ChatBinding, ByteString)) + shareChatBinding u = \case + SRDirect contactId -> do + ct <- withFastStore $ \db -> getContact db vr u contactId + forM (contactConn ct) $ \conn -> + (CBDirect,) <$> withAgent (`getConnectionRatchetAdHash` aConnId conn) + SRGroup toGroupId _ asGroup -> do + GroupInfo {groupProfile = GroupProfile {publicGroup}, membership = m} <- withFastStore $ \db -> getGroupInfo db vr u toGroupId + pure $ mkBinding m <$> publicGroup + where + mkBinding GroupMember {memberId} PublicGroupProfile {publicGroupId = pgId} + | asGroup = (CBChannel, smpEncode pgId) + | otherwise = (CBGroup, smpEncode (pgId, memberId)) + APIShareChatMsgContent _ _ -> throwCmdError "sharing is only supported for public groups" APIUserRead userId -> withUserId userId $ \user -> withFastStore' (`setUserChatsRead` user) >> ok user UserRead -> withUser $ \User {userId} -> processChatCommand vr nm $ APIUserRead userId APIChatRead chatRef@(ChatRef cType chatId scope_) -> withUser $ \_ -> case cType of @@ -1933,9 +1975,9 @@ processChatCommand vr nm = \case createDirectConnection db newUser agConnId ccLink' Nothing ConnNew Nothing subMode initialChatVersion PQSupportOn deleteAgentConnectionAsync (aConnId' conn) pure conn' - APIConnectPlan userId (Just cLink) -> withUserId userId $ \user -> - uncurry (CRConnectionPlan user) <$> connectPlan user cLink - APIConnectPlan _ Nothing -> throwChatError CEInvalidConnReq + APIConnectPlan userId (Just cLink) linkOwnerSig_ -> withUserId userId $ \user -> + uncurry (CRConnectionPlan user) <$> connectPlan user cLink linkOwnerSig_ + APIConnectPlan _ Nothing _ -> throwChatError CEInvalidConnReq APIPrepareContact userId accLink contactSLinkData -> withUserId userId $ \user -> do let ContactShortLinkData {profile, message, business} = contactSLinkData welcomeSharedMsgId <- forM message $ \_ -> getSharedMsgId @@ -2176,7 +2218,7 @@ processChatCommand vr nm = \case Connect incognito (Just cLink@(ACL m cLink')) -> withUser $ \user -> do -- TODO [relays] member: /c api to support groups with relays -- TODO - possibly by going through APIPrepareGroup -> APIConnectPreparedGroup - (ccLink, plan) <- connectPlan user cLink `catchAllErrors` \e -> case cLink' of CLFull cReq -> pure (ACCL m (CCLink cReq Nothing), CPInvitationLink (ILPOk Nothing)); _ -> throwError e + (ccLink, plan) <- connectPlan user cLink Nothing `catchAllErrors` \e -> case cLink' of CLFull cReq -> pure (ACCL m (CCLink cReq Nothing), CPInvitationLink (ILPOk Nothing Nothing)); _ -> throwError e connectWithPlan user incognito ccLink plan Connect _ Nothing -> throwChatError CEInvalidConnReq APIConnectContactViaAddress userId incognito contactId -> withUserId userId $ \user -> do @@ -2194,7 +2236,7 @@ processChatCommand vr nm = \case toView $ CEvtChatInfoUpdated user (AChatInfo SCTDirect $ DirectChat ct') throwError e ConnectSimplex incognito -> withUser $ \user -> do - plan <- contactRequestPlan user adminContactReq Nothing `catchAllErrors` const (pure $ CPContactAddress (CAPOk Nothing)) + plan <- contactRequestPlan user adminContactReq Nothing Nothing `catchAllErrors` const (pure $ CPContactAddress (CAPOk Nothing Nothing)) connectWithPlan user incognito (ACCL SCMContact (CCLink adminContactReq Nothing)) plan DeleteContact cName cdm -> withContactName cName $ \ctId -> APIDeleteChat (ChatRef CTDirect ctId Nothing) cdm ClearContact cName -> withContactName cName $ \chatId -> APIClearChat $ ChatRef CTDirect chatId Nothing @@ -2288,6 +2330,19 @@ processChatCommand vr nm = \case toChatRef <- getChatRef user toChatName asGroup <- getSendAsGroup user toChatRef processChatCommand vr nm $ APIForwardChatItems toChatRef asGroup (ChatRef CTLocal folderId Nothing) (forwardedItemId :| []) Nothing + SharePublicGroup shareGroupName toChatName -> withUser $ \user -> do + groupId <- withFastStore $ \db -> getGroupIdByName db user shareGroupName + toChatRef <- getChatRef user toChatName + sendRef <- case toChatRef of + ChatRef CTDirect ctId _ -> pure $ SRDirect ctId + ChatRef CTGroup gId scope_ -> do + gInfo <- withFastStore $ \db -> getGroupInfo db vr user gId + pure $ SRGroup gId scope_ (useRelays' gInfo) + _ -> throwCmdError "unsupported share target" + processChatCommand vr nm (APIShareChatMsgContent (ChatRef CTGroup groupId Nothing) sendRef) >>= \case + CRChatMsgContent _ mc -> + processChatCommand vr nm $ APISendMessages sendRef False Nothing [composedMessage Nothing mc] + r -> pure r SendMessage sendName msg -> withUser $ \user -> do let mc = MCText msg case sendName of @@ -3888,28 +3943,29 @@ processChatCommand vr nm = \case pure (gId, chatSettings) _ -> throwCmdError "not supported" processChatCommand vr nm $ APISetChatSettings (ChatRef cType chatId Nothing) $ updateSettings chatSettings - connectPlan :: User -> AConnectionLink -> CM (ACreatedConnLink, ConnectionPlan) - connectPlan user (ACL SCMInvitation cLink) = case cLink of - CLFull cReq -> invitationReqAndPlan cReq Nothing Nothing + connectPlan :: User -> AConnectionLink -> Maybe LinkOwnerSig -> CM (ACreatedConnLink, ConnectionPlan) + connectPlan user (ACL SCMInvitation cLink) sig_ = case cLink of + CLFull cReq -> invitationReqAndPlan cReq Nothing Nothing Nothing CLShort l -> do let l' = serverShortLink l knownLinkPlans l' >>= \case Just r -> pure r Nothing -> do - (FixedLinkData {linkConnReq = cReq}, cData) <- getShortLinkConnReq nm user l' + (FixedLinkData {linkConnReq = cReq, rootKey}, cData) <- getShortLinkConnReq nm user l' contactSLinkData_ <- liftIO $ decodeLinkUserData cData - invitationReqAndPlan cReq (Just l') contactSLinkData_ + let ov = verifyLinkOwner rootKey [] l sig_ + invitationReqAndPlan cReq (Just l') contactSLinkData_ ov where knownLinkPlans l' = withFastStore $ \db -> do let inv cReq = ACCL SCMInvitation $ CCLink cReq (Just l') liftIO (getConnectionEntityViaShortLink db vr user l') >>= \case - Just (cReq, ent) -> pure $ Just (inv cReq, invitationEntityPlan Nothing ent) + Just (cReq, ent) -> pure $ Just (inv cReq, invitationEntityPlan Nothing Nothing ent) -- deleted contact is returned as known, as invitation link cannot be re-used too connect anyway Nothing -> bimap inv (CPInvitationLink . ILPKnown) <$$> getContactViaShortLinkToConnect db vr user l' - invitationReqAndPlan cReq sLnk_ contactSLinkData_ = do - plan <- invitationRequestPlan user cReq contactSLinkData_ `catchAllErrors` (pure . CPError) + invitationReqAndPlan cReq sLnk_ cld ov = do + plan <- invitationRequestPlan user cReq cld ov `catchAllErrors` (pure . CPError) pure (ACCL SCMInvitation (CCLink cReq sLnk_), plan) - connectPlan user (ACL SCMContact cLink) = case cLink of + connectPlan user (ACL SCMContact cLink) sig_ = case cLink of CLFull cReq -> do plan <- contactOrGroupRequestPlan user cReq `catchAllErrors` (pure . CPError) pure (ACCL SCMContact $ CCLink cReq Nothing, plan) @@ -3919,12 +3975,14 @@ processChatCommand vr nm = \case knownLinkPlans >>= \case Just r -> pure r Nothing -> do - (FixedLinkData {linkConnReq = cReq}, cData) <- getShortLinkConnReq nm user l' + (FixedLinkData {linkConnReq = cReq, rootKey}, cData) <- getShortLinkConnReq nm user l' withFastStore' (\db -> getContactWithoutConnViaShortAddress db vr user l') >>= \case Just ct' | not (contactDeleted ct') -> pure (con cReq, CPContactAddress (CAPContactViaAddress ct')) _ -> do contactSLinkData_ <- liftIO $ decodeLinkUserData cData - plan <- contactRequestPlan user cReq contactSLinkData_ + let ContactLinkData _ UserContactData {owners} = cData + ov = verifyLinkOwner rootKey owners l' sig_ + plan <- contactRequestPlan user cReq contactSLinkData_ ov pure (con cReq, plan) where knownLinkPlans = withFastStore $ \db -> @@ -3945,8 +4003,8 @@ processChatCommand vr nm = \case knownLinkPlans >>= \case Just r -> pure r Nothing -> do - (fd, cData@(ContactLinkData _ UserContactData {direct, relays})) <- getShortLinkConnReq nm user l' - let FixedLinkData {linkConnReq = cReq, linkEntityId} = fd + (fd, cData@(ContactLinkData _ UserContactData {direct, owners, relays})) <- getShortLinkConnReq nm user l' + let FixedLinkData {linkConnReq = cReq, linkEntityId, rootKey} = fd linkInfo = GroupShortLinkInfo {direct, groupRelays = relays, publicGroupId = B64UrlByteString <$> linkEntityId} groupSLinkData_ <- liftIO $ decodeLinkUserData cData -- Cross-validate linkEntityId and publicGroupId from profile: @@ -3957,7 +4015,8 @@ processChatCommand vr nm = \case (Just entityId, Just publicGroupId) | entityId == publicGroupId -> pure () (Nothing, Nothing) -> pure () _ -> throwChatError CEInvalidConnReq - plan <- groupJoinRequestPlan user cReq (Just linkInfo) groupSLinkData_ + let ov = verifyLinkOwner rootKey owners l' sig_ + plan <- groupJoinRequestPlan user cReq (Just linkInfo) groupSLinkData_ ov pure (con cReq, plan) where knownLinkPlans = withFastStore $ \db -> @@ -3973,9 +4032,9 @@ processChatCommand vr nm = \case processChatCommand vr nm $ APIConnectContactViaAddress userId incognito contactId _ -> processChatCommand vr nm $ APIConnect userId incognito $ Just ccLink | otherwise = pure $ CRConnectionPlan user ccLink plan - invitationRequestPlan :: User -> ConnReqInvitation -> Maybe ContactShortLinkData -> CM ConnectionPlan - invitationRequestPlan user cReq contactSLinkData_ = do - maybe (CPInvitationLink (ILPOk contactSLinkData_)) (invitationEntityPlan contactSLinkData_) + invitationRequestPlan :: User -> ConnReqInvitation -> Maybe ContactShortLinkData -> Maybe OwnerVerification -> CM ConnectionPlan + invitationRequestPlan user cReq cld ov = do + maybe (CPInvitationLink (ILPOk cld ov)) (invitationEntityPlan cld ov) <$> withFastStore' (\db -> getConnectionEntityByConnReq db vr user $ invCReqSchemas cReq) where invCReqSchemas :: ConnReqInvitation -> (ConnReqInvitation, ConnReqInvitation) @@ -3983,15 +4042,15 @@ processChatCommand vr nm = \case ( CRInvitationUri crData {crScheme = SSSimplex} e2e, CRInvitationUri crData {crScheme = simplexChat} e2e ) - invitationEntityPlan :: Maybe ContactShortLinkData -> ConnectionEntity -> ConnectionPlan - invitationEntityPlan contactSLinkData_ = \case + invitationEntityPlan :: Maybe ContactShortLinkData -> Maybe OwnerVerification -> ConnectionEntity -> ConnectionPlan + invitationEntityPlan cld ov = \case RcvDirectMsgConnection Connection {connStatus, contactConnInitiated} ct_ -> case ct_ of Just ct | contactActive ct -> CPInvitationLink (ILPKnown ct) - | otherwise -> CPInvitationLink (ILPOk contactSLinkData_) + | otherwise -> CPInvitationLink (ILPOk cld ov) Nothing | connStatus == ConnNew && contactConnInitiated -> CPInvitationLink ILPOwnLink - | connStatus == ConnPrepared -> CPInvitationLink (ILPOk contactSLinkData_) + | connStatus == ConnPrepared -> CPInvitationLink (ILPOk cld ov) | otherwise -> CPInvitationLink (ILPConnecting Nothing) _ -> CPError $ ChatError $ CECommandError "found connection entity is not RcvDirectMsgConnection" contactOrGroupRequestPlan :: User -> ConnReqContact -> CM ConnectionPlan @@ -3999,10 +4058,10 @@ processChatCommand vr nm = \case let ConnReqUriData {crClientData} = crData groupLinkId = crClientData >>= decodeJSON >>= \(CRDataGroup gli) -> Just gli case groupLinkId of - Nothing -> contactRequestPlan user cReq Nothing - Just _ -> groupJoinRequestPlan user cReq Nothing Nothing - contactRequestPlan :: User -> ConnReqContact -> Maybe ContactShortLinkData -> CM ConnectionPlan - contactRequestPlan user (CRContactUri crData) contactSLinkData_ = do + Nothing -> contactRequestPlan user cReq Nothing Nothing + Just _ -> groupJoinRequestPlan user cReq Nothing Nothing Nothing + contactRequestPlan :: User -> ConnReqContact -> Maybe ContactShortLinkData -> Maybe OwnerVerification -> CM ConnectionPlan + contactRequestPlan user (CRContactUri crData) cld ov = do let cReqSchemas = contactCReqSchemas crData cReqHashes = bimap contactCReqHash contactCReqHash cReqSchemas withFastStore' (\db -> getUserContactLinkByConnReq db user cReqSchemas) >>= \case @@ -4012,19 +4071,19 @@ processChatCommand vr nm = \case Nothing -> withFastStore' (\db -> getContactWithoutConnViaAddress db vr user cReqSchemas) >>= \case Just ct | not (contactDeleted ct) -> pure $ CPContactAddress (CAPContactViaAddress ct) - _ -> pure $ CPContactAddress (CAPOk contactSLinkData_) + _ -> pure $ CPContactAddress (CAPOk cld ov) Just (RcvDirectMsgConnection Connection {connStatus} Nothing) - | connStatus == ConnPrepared -> pure $ CPContactAddress (CAPOk contactSLinkData_) + | connStatus == ConnPrepared -> pure $ CPContactAddress (CAPOk cld ov) | otherwise -> pure $ CPContactAddress CAPConnectingConfirmReconnect Just (RcvDirectMsgConnection _ (Just ct)) | not (contactReady ct) && contactActive ct -> pure $ CPContactAddress (CAPConnectingProhibit ct) - | contactDeleted ct -> pure $ CPContactAddress (CAPOk contactSLinkData_) + | contactDeleted ct -> pure $ CPContactAddress (CAPOk cld ov) | otherwise -> pure $ CPContactAddress (CAPKnown ct) -- TODO [short links] RcvGroupMsgConnection branch is deprecated? (old group link protocol?) - Just (RcvGroupMsgConnection _ gInfo _) -> groupPlan gInfo Nothing Nothing + Just (RcvGroupMsgConnection _ gInfo _) -> groupPlan gInfo Nothing Nothing Nothing Just _ -> throwCmdError "found connection entity is not RcvDirectMsgConnection or RcvGroupMsgConnection" - groupJoinRequestPlan :: User -> ConnReqContact -> Maybe GroupShortLinkInfo -> Maybe GroupShortLinkData -> CM ConnectionPlan - groupJoinRequestPlan user (CRContactUri crData) groupSLinkInfo_ groupSLinkData_ = do + groupJoinRequestPlan :: User -> ConnReqContact -> Maybe GroupShortLinkInfo -> Maybe GroupShortLinkData -> Maybe OwnerVerification -> CM ConnectionPlan + groupJoinRequestPlan user (CRContactUri crData) linkInfo gld ov = do let cReqSchemas = contactCReqSchemas crData cReqHashes = bimap contactCReqHash contactCReqHash cReqSchemas withFastStore' (\db -> getGroupInfoByUserContactLinkConnReq db vr user cReqSchemas) >>= \case @@ -4033,21 +4092,21 @@ processChatCommand vr nm = \case connEnt_ <- withFastStore' $ \db -> getContactConnEntityByConnReqHash db vr user cReqHashes gInfo_ <- withFastStore' $ \db -> getGroupInfoByGroupLinkHash db vr user cReqHashes case (gInfo_, connEnt_) of - (Nothing, Nothing) -> pure $ CPGroupLink (GLPOk groupSLinkInfo_ groupSLinkData_) + (Nothing, Nothing) -> pure $ CPGroupLink (GLPOk linkInfo gld ov) -- TODO [short links] RcvDirectMsgConnection branches are deprecated? (old group link protocol?) (Nothing, Just (RcvDirectMsgConnection _conn Nothing)) -> pure $ CPGroupLink GLPConnectingConfirmReconnect (Nothing, Just (RcvDirectMsgConnection _ (Just ct))) | not (contactReady ct) && contactActive ct -> pure $ CPGroupLink (GLPConnectingProhibit gInfo_) - | otherwise -> pure $ CPGroupLink (GLPOk groupSLinkInfo_ groupSLinkData_) + | otherwise -> pure $ CPGroupLink (GLPOk linkInfo gld ov) (Nothing, Just _) -> throwCmdError "found connection entity is not RcvDirectMsgConnection" - (Just gInfo, _) -> groupPlan gInfo groupSLinkInfo_ groupSLinkData_ - groupPlan :: GroupInfo -> Maybe GroupShortLinkInfo -> Maybe GroupShortLinkData -> CM ConnectionPlan - groupPlan gInfo@GroupInfo {membership} groupSLinkInfo_ groupSLinkData_ + (Just gInfo, _) -> groupPlan gInfo linkInfo gld ov + groupPlan :: GroupInfo -> Maybe GroupShortLinkInfo -> Maybe GroupShortLinkData -> Maybe OwnerVerification -> CM ConnectionPlan + groupPlan gInfo@GroupInfo {membership} linkInfo gld ov | memberStatus membership == GSMemRejected = pure $ CPGroupLink (GLPKnown gInfo) | not (memberActive membership) && not (memberRemoved membership) = pure $ CPGroupLink (GLPConnectingProhibit $ Just gInfo) | memberActive membership = pure $ CPGroupLink (GLPKnown gInfo) - | otherwise = pure $ CPGroupLink (GLPOk groupSLinkInfo_ groupSLinkData_) + | otherwise = pure $ CPGroupLink (GLPOk linkInfo gld ov) contactCReqSchemas :: ConnReqUriData -> (ConnReqContact, ConnReqContact) contactCReqSchemas crData = ( CRContactUri crData {crScheme = SSSimplex}, @@ -4059,6 +4118,16 @@ processChatCommand vr nm = \case serverShortLink = \case CSLInvitation _ srv lnkId linkKey -> CSLInvitation SLSServer srv lnkId linkKey CSLContact _ ct srv linkKey -> CSLContact SLSServer ct srv linkKey + verifyLinkOwner :: ConnectionModeI m => C.PublicKeyEd25519 -> [OwnerAuth] -> ConnShortLink m -> Maybe LinkOwnerSig -> Maybe OwnerVerification + verifyLinkOwner rootKey owners connLink = + fmap $ \LinkOwnerSig {ownerId, chatBinding = B64UrlByteString bindingBytes, ownerSig} -> + let signedData = bindingBytes <> smpEncode connLink + findOwner (B64UrlByteString oId) = find (\OwnerAuth {ownerId = oId'} -> oId' == oId) owners + in case maybe (Just rootKey) (fmap ownerKey . findOwner) ownerId of + Nothing -> OVFailed "unknown owner" + Just key + | C.verify' key ownerSig signedData -> OVVerified + | otherwise -> OVFailed "signature verification failed" contactShortLinkData :: Profile -> Maybe AddressSettings -> UserLinkData contactShortLinkData p settings = let msg = autoReply =<< settings @@ -4772,6 +4841,7 @@ chatCommandP = "/_reaction members " *> (APIGetReactionMembers <$> A.decimal <* " #" <*> A.decimal <* A.space <*> A.decimal <* A.space <*> (knownReaction <$?> jsonP)), "/_forward plan " *> (APIPlanForwardChatItems <$> chatRefP <*> _strP), "/_forward " *> (APIForwardChatItems <$> chatRefP <*> (" as_group=" *> onOffP <|> pure False) <* A.space <*> chatRefP <*> _strP <*> sendMessageTTLP), + "/_share chat content " *> (APIShareChatMsgContent <$> chatRefP <* A.space <*> sendRefP), "/_read user " *> (APIUserRead <$> A.decimal), "/read user" $> UserRead, "/_read chat " *> (APIChatRead <$> chatRefP), @@ -4943,7 +5013,7 @@ chatCommandP = (">#" <|> "> #") *> (SendGroupMessageQuote <$> displayNameP <* A.space <* char_ '@' <*> (Just <$> displayNameP) <* A.space <*> quotedMsg <*> msgTextP), "/_contacts " *> (APIListContacts <$> A.decimal), "/contacts" $> ListContacts, - "/_connect plan " *> (APIConnectPlan <$> A.decimal <* A.space <*> ((Just <$> strP) <|> A.takeTill (== ' ') $> Nothing)), + "/_connect plan " *> (APIConnectPlan <$> A.decimal <* A.space <*> ((Just <$> strP) <|> A.takeTill (== ' ') $> Nothing) <*> optional (" sig=" *> jsonP)), "/_prepare contact " *> (APIPrepareContact <$> A.decimal <* A.space <*> connLinkP <* A.space <*> jsonP), "/_prepare group " *> (APIPrepareGroup <$> A.decimal <* A.space <*> connLinkP' <*> (" direct=" *> onOffP <|> pure True) <* A.space <*> jsonP), "/_set contact user @" *> (APIChangePreparedContactUser <$> A.decimal <* A.space <*> A.decimal), @@ -4960,6 +5030,7 @@ chatCommandP = ForwardGroupMessage <$> chatNameP <* " <- #" <*> displayNameP <* A.space <* A.char '@' <*> (Just <$> displayNameP) <* A.space <*> msgTextP, ForwardGroupMessage <$> chatNameP <* " <- #" <*> displayNameP <*> pure Nothing <* A.space <*> msgTextP, ForwardLocalMessage <$> chatNameP <* " <- * " <*> msgTextP, + "/share chat #" *> (SharePublicGroup <$> displayNameP <* A.space <*> chatNameP), SendMessage <$> sendNameP <* A.space <*> msgTextP, "@#" *> (SendMemberContactMessage <$> displayNameP <* A.space <* char_ '@' <*> displayNameP <* A.space <*> msgTextP), "/accept_member_contact @" *> (AcceptMemberContact <$> displayNameP), diff --git a/src/Simplex/Chat/Library/Internal.hs b/src/Simplex/Chat/Library/Internal.hs index 871c6c512e..846ff4a7b7 100644 --- a/src/Simplex/Chat/Library/Internal.hs +++ b/src/Simplex/Chat/Library/Internal.hs @@ -341,7 +341,7 @@ prohibitedGroupContent gInfo@GroupInfo {membership = mem@GroupMember {memberRole | isVoice mc && not (groupFeatureMemberAllowed SGFVoice m gInfo) && not hostApprovalVoice = Just GFVoice | isNothing scopeInfo && not (isVoice mc) && isJust file_ && not (groupFeatureMemberAllowed SGFFiles m gInfo) = Just GFFiles | isNothing scopeInfo && isReport mc && (badReportUser || not (groupFeatureAllowed SGFReports gInfo)) = Just GFReports - | isNothing scopeInfo && prohibitedSimplexLinks gInfo m ft = Just GFSimplexLinks + | isNothing scopeInfo && prohibitedSimplexLinks gInfo m mc ft = Just GFSimplexLinks | otherwise = Nothing where hostApprovalVoice @@ -358,10 +358,14 @@ prohibitedGroupContent gInfo@GroupInfo {membership = mem@GroupMember {memberRole | sent = userRole >= GRModerator | otherwise = userRole < GRModerator -prohibitedSimplexLinks :: GroupInfo -> GroupMember -> Maybe MarkdownList -> Bool -prohibitedSimplexLinks gInfo m ft = +prohibitedSimplexLinks :: GroupInfo -> GroupMember -> MsgContent -> Maybe MarkdownList -> Bool +prohibitedSimplexLinks gInfo m mc ft = not (groupFeatureMemberAllowed SGFSimplexLinks m gInfo) - && maybe False (any ftIsSimplexLink) ft + && (isChatLink mc || maybe False (any ftIsSimplexLink) ft) + where + isChatLink = \case + MCChat {} -> True + _ -> False ftIsSimplexLink :: FormattedText -> Bool ftIsSimplexLink FormattedText {format} = maybe False isSimplexLink format diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index e4146fd526..efdd61fb0e 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/src/Simplex/Chat/Library/Subscriber.hs @@ -1726,7 +1726,16 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = newContentMessage :: Contact -> MsgContainer -> RcvMessage -> MsgMeta -> CM () newContentMessage ct mc msg@RcvMessage {sharedMsgId_} msgMeta = do - let MsgContainer {content, file = fInv_} = mc + let MsgContainer {content = c, file = fInv_} = mc + content <- case c of + MCChat {text, chatLink, ownerSig = Just LinkOwnerSig {chatBinding = B64UrlByteString binding}} -> do + keepSig <- case contactConn ct of + Nothing -> pure False + Just conn -> do + adHash <- withAgent (`getConnectionRatchetAdHash` aConnId conn) + pure $ encodeChatBinding CBDirect adHash == binding + pure $ if keepSig then c else MCChat {text, chatLink, ownerSig = Nothing} + _ -> pure c -- Uncomment to test stuck delivery on errors - see test testDirectMessageDelete -- case content of -- MCText "hello 111" -> @@ -1979,7 +1988,16 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = rejected gInfo' m' scopeInfo f = newChatItem gInfo' m' scopeInfo (ciContentNoParse $ CIRcvGroupFeatureRejected f) Nothing Nothing False timed_ gInfo' = if forwarded then rcvCITimed_ (Just Nothing) itemTTL else rcvGroupCITimed gInfo' itemTTL live' = fromMaybe False live_ - MsgContainer {content, mentions = MsgMentions mentions, file = fInv_, ttl = itemTTL, live = live_, scope = msgScope_, asGroup = asGroup_} = mc + MsgContainer {content = c, mentions = MsgMentions mentions, file = fInv_, ttl = itemTTL, live = live_, scope = msgScope_, asGroup = asGroup_} = mc + content = case c of + MCChat {text, chatLink, ownerSig = Just LinkOwnerSig {chatBinding = B64UrlByteString binding}} -> case publicGroup of + Just pgp | maybe False (binding ==) (expectedBinding pgp) -> c + _ -> MCChat {text, chatLink, ownerSig = Nothing} + _ -> c + expectedBinding PublicGroupProfile {publicGroupId} + | sentAsGroup = Just $ encodeChatBinding CBChannel (smpEncode publicGroupId) + | otherwise = (\GroupMember {memberId} -> encodeChatBinding CBGroup (smpEncode (publicGroupId, memberId))) <$> m_ + GroupInfo {groupProfile = GroupProfile {publicGroup}} = gInfo sentAsGroup = asGroup_ == Just True ts@(_, ft_) = msgContentTexts content -- m' is Maybe GroupMember @@ -2030,7 +2048,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = groupMessageUpdate :: GroupInfo -> Maybe GroupMember -> SharedMsgId -> MsgContent -> Map MemberName MsgMention -> Maybe MsgScope -> RcvMessage -> UTCTime -> Maybe Int -> Maybe Bool -> Maybe Bool -> CM (Maybe DeliveryTaskContext) groupMessageUpdate gInfo@GroupInfo {groupId} m_ sharedMsgId mc mentions msgScope_ msg@RcvMessage {msgId} brokerTs ttl_ live_ asGroup_ - | Just m <- m_, prohibitedSimplexLinks gInfo m ft_ = + | Just m <- m_, prohibitedSimplexLinks gInfo m mc ft_ = messageWarning ("x.msg.update ignored: feature not allowed " <> groupFeatureNameText GFSimplexLinks) $> Nothing | otherwise = do updateRcvChatItem `catchCINotFound` \_ -> do diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index db77a2f7b4..b7e838c52b 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -318,7 +318,7 @@ data AChatMessage = forall e. MsgEncodingI e => ACMsg (SMsgEncoding e) (ChatMess data KeyRef = KRMember deriving (Eq, Show) -data ChatBinding = CBGroup +data ChatBinding = CBGroup | CBDirect | CBChannel deriving (Eq, Show) data MsgSignature = MsgSignature KeyRef C.ASignature @@ -381,10 +381,15 @@ instance Encoding KeyRef where c -> fail $ "invalid KeyRef tag: " <> show c instance Encoding ChatBinding where - smpEncode CBGroup = "G" + smpEncode = \case + CBGroup -> "G" + CBDirect -> "D" + CBChannel -> "C" smpP = A.anyChar >>= \case 'G' -> pure CBGroup + 'D' -> pure CBDirect + 'C' -> pure CBChannel c -> fail $ "invalid ChatBinding: " <> show c instance ToField ChatBinding where toField = toField . decodeLatin1 . smpEncode @@ -411,7 +416,8 @@ data MsgSigning = MsgSigning privKey :: C.PrivateKeyEd25519 } - +encodeChatBinding :: ChatBinding -> ByteString -> ByteString +encodeChatBinding cb bindingData = smpEncode cb <> bindingData data ChatMsgEvent (e :: MsgEncoding) where XMsgNew :: MsgContainer -> ChatMsgEvent 'Json @@ -685,7 +691,7 @@ data MsgContent | MCVoice {text :: Text, duration :: Int} | MCFile {text :: Text} | MCReport {text :: Text, reason :: ReportReason} - | MCChat {text :: Text, chatLink :: MsgChatLink} + | MCChat {text :: Text, chatLink :: MsgChatLink, ownerSig :: Maybe LinkOwnerSig} | MCUnknown {tag :: Text, text :: Text, json :: J.Object} deriving (Eq, Show) @@ -695,6 +701,13 @@ data MsgChatLink | MCLGroup {connLink :: ShortLinkContact, groupProfile :: GroupProfile} deriving (Eq, Show) +data LinkOwnerSig = LinkOwnerSig + { ownerId :: Maybe B64UrlByteString, + chatBinding :: B64UrlByteString, + ownerSig :: C.Signature 'C.Ed25519 + } + deriving (Eq, Show) + msgContentText :: MsgContent -> Text msgContentText = \case MCText t -> t @@ -757,6 +770,8 @@ newtype MsgMentions = MsgMentions (Map MemberName MsgMention) $(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "MCL") ''MsgChatLink) +$(JQ.deriveJSON defaultJSON ''LinkOwnerSig) + $(JQ.deriveJSON defaultJSON ''MsgMention) instance FromJSON MsgMentions where @@ -803,7 +818,8 @@ instance FromJSON MsgContent where MCChat_ -> do text <- v .: "text" chatLink <- v .: "chatLink" - pure MCChat {text, chatLink} + ownerSig <- v .:? "ownerSig" + pure MCChat {text, chatLink, ownerSig} MCUnknown_ tag -> do text <- fromMaybe unknownMsgType <$> v .:? "text" pure MCUnknown {tag, text, json = v} @@ -813,6 +829,9 @@ instance FromJSON MsgContent where unknownMsgType :: Text unknownMsgType = "unknown message type" +(.=?) :: ToJSON v => JT.Key -> Maybe v -> [(J.Key, J.Value)] -> [(J.Key, J.Value)] +key .=? value = maybe id ((:) . (key .=)) value + instance ToJSON MsgContent where toJSON = \case MCUnknown {json} -> J.Object json @@ -823,7 +842,7 @@ instance ToJSON MsgContent where MCVoice {text, duration} -> J.object ["type" .= MCVoice_, "text" .= text, "duration" .= duration] MCFile t -> J.object ["type" .= MCFile_, "text" .= t] MCReport {text, reason} -> J.object ["type" .= MCReport_, "text" .= text, "reason" .= reason] - MCChat {text, chatLink} -> J.object ["type" .= MCChat_, "text" .= text, "chatLink" .= chatLink] + MCChat {text, chatLink, ownerSig} -> J.object $ ("ownerSig" .=? ownerSig) ["type" .= MCChat_, "text" .= text, "chatLink" .= chatLink] toEncoding = \case MCUnknown {json} -> JE.value $ J.Object json MCText t -> J.pairs $ "type" .= MCText_ <> "text" .= t @@ -833,7 +852,7 @@ instance ToJSON MsgContent where MCVoice {text, duration} -> J.pairs $ "type" .= MCVoice_ <> "text" .= text <> "duration" .= duration MCFile t -> J.pairs $ "type" .= MCFile_ <> "text" .= t MCReport {text, reason} -> J.pairs $ "type" .= MCReport_ <> "text" .= text <> "reason" .= reason - MCChat {text, chatLink} -> J.pairs $ "type" .= MCChat_ <> "text" .= text <> "chatLink" .= chatLink + MCChat {text, chatLink, ownerSig} -> J.pairs $ "type" .= MCChat_ <> "text" .= text <> "chatLink" .= chatLink <> maybe mempty ("ownerSig" .=) ownerSig $(JQ.deriveJSON defaultJSON ''MsgContainer) @@ -1324,9 +1343,6 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do XOk_ -> pure XOk XUnknown_ t -> pure $ XUnknown t params -(.=?) :: ToJSON v => JT.Key -> Maybe v -> [(J.Key, J.Value)] -> [(J.Key, J.Value)] -key .=? value = maybe id ((:) . (key .=)) value - chatToAppMessage :: forall e. MsgEncodingI e => ChatMessage e -> AppMessage e chatToAppMessage chatMsg@ChatMessage {chatVRange, msgId, chatMsgEvent} = case encoding @e of SBinary -> AMBinary AppMessageBinary {msgId = Nothing, tag = B.head $ strEncode tag, body = chatMsgBinaryToBody chatMsg} diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index eb265ffa2d..5d433088a4 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -229,7 +229,7 @@ createNewSndMessage db gVar connOrGroupId chatMsgEvent msgSigning_ encodeMessage 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) + let sig = C.ASignature C.SEd25519 $ C.sign' privKey (encodeChatBinding bindingTag bindingData <> msgBody) in SignedMsg {chatBinding = bindingTag, signatures = MsgSignature keyRef sig :| [], signedBody = msgBody} createdAt <- getCurrentTime DB.execute @@ -240,7 +240,7 @@ createNewSndMessage db gVar connOrGroupId chatMsgEvent msgSigning_ encodeMessage shared_msg_id, shared_msg_id_user, created_at, updated_at ) VALUES (?,?,?,?,?,?,?,?,?,?,?) |] - ((MDSnd, toCMEventTag chatMsgEvent, DB.Binary msgBody, chatBinding <$> signedMsg_, DB.Binary . smpEncode . signatures <$> signedMsg_, connId_, groupId_) + ((MDSnd, toCMEventTag chatMsgEvent, DB.Binary msgBody, (\SignedMsg {chatBinding} -> chatBinding) <$> signedMsg_, DB.Binary . smpEncode . signatures <$> signedMsg_, connId_, groupId_) :. (DB.Binary sharedMsgId, Just (BI True), createdAt, createdAt)) msgId <- insertedRowId db pure $ Right SndMessage {msgId, sharedMsgId = SharedMsgId sharedMsgId, msgBody, signedMsg_} @@ -327,7 +327,7 @@ createNewRcvMessage db connOrGroupId NewRcvMessage {chatMsgEvent, verifiedMsg, b shared_msg_id, author_group_member_id, forwarded_by_group_member_id) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?) |] - ((MDRcv, toCMEventTag chatMsgEvent, DB.Binary msgBody, chatBinding <$> signedMsg_, DB.Binary . smpEncode . signatures <$> signedMsg_, brokerTs, currentTs, currentTs, connId_, groupId_) + ((MDRcv, toCMEventTag chatMsgEvent, DB.Binary msgBody, (\SignedMsg {chatBinding} -> chatBinding) <$> signedMsg_, DB.Binary . smpEncode . signatures <$> signedMsg_, brokerTs, currentTs, currentTs, connId_, groupId_) :. (sharedMsgId_, authorMember, forwardedByMember)) msgId <- insertedRowId db pure RcvMessage {msgId, chatMsgEvent = ACME (encoding @e) chatMsgEvent, sharedMsgId_, msgSigned, forwardedByMember} diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt b/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt index a6f2d53aec..231b1a73bf 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt +++ b/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt @@ -1842,6 +1842,41 @@ SEARCH group_members USING COVERING INDEX idx_group_members_invited_by_group_mem SEARCH contacts USING COVERING INDEX idx_contacts_grp_direct_inv_from_group_member_id (grp_direct_inv_from_group_member_id=?) SEARCH contacts USING COVERING INDEX idx_contacts_contact_group_member_id (contact_group_member_id=?) +Query: + INSERT INTO group_members + ( group_id, index_in_group, member_id, member_role, member_category, member_status, member_relations_vector, invited_by, + user_id, local_display_name, contact_id, contact_profile_id, member_pub_key, created_at, updated_at, + peer_chat_min_version, peer_chat_max_version) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) + +Plan: +SEARCH group_relays USING COVERING INDEX idx_group_relays_group_member_id (group_member_id=?) +SEARCH delivery_jobs USING COVERING INDEX idx_delivery_jobs_single_sender_group_member_id (single_sender_group_member_id=?) +SEARCH delivery_jobs USING COVERING INDEX idx_delivery_jobs_job_scope_support_gm_id (job_scope_support_gm_id=?) +SEARCH delivery_tasks USING COVERING INDEX idx_delivery_tasks_sender_group_member_id (sender_group_member_id=?) +SEARCH delivery_tasks USING COVERING INDEX idx_delivery_tasks_job_scope_support_gm_id (job_scope_support_gm_id=?) +SEARCH received_probes USING COVERING INDEX idx_received_probes_group_member_id (group_member_id=?) +SEARCH sent_probe_hashes USING COVERING INDEX idx_sent_probe_hashes_group_member_id (group_member_id=?) +SEARCH sent_probes USING COVERING INDEX idx_sent_probes_group_member_id (group_member_id=?) +SEARCH group_snd_item_statuses USING COVERING INDEX idx_group_snd_item_statuses_group_member_id (group_member_id=?) +SEARCH chat_item_moderations USING COVERING INDEX idx_chat_item_moderations_moderator_member_id (moderator_member_id=?) +SEARCH chat_item_reactions USING COVERING INDEX idx_chat_item_reactions_group_member_id (group_member_id=?) +SEARCH chat_items USING COVERING INDEX idx_chat_items_group_scope_group_member_id (group_scope_group_member_id=?) +SEARCH chat_items USING COVERING INDEX idx_chat_items_forwarded_by_group_member_id (forwarded_by_group_member_id=?) +SEARCH chat_items USING COVERING INDEX idx_chat_items_item_deleted_by_group_member_id (item_deleted_by_group_member_id=?) +SEARCH chat_items USING COVERING INDEX idx_chat_items_group_member_id (group_member_id=?) +SEARCH pending_group_messages USING COVERING INDEX idx_pending_group_messages_group_member_id (group_member_id=?) +SEARCH messages USING COVERING INDEX idx_messages_forwarded_by_group_member_id (forwarded_by_group_member_id=?) +SEARCH messages USING COVERING INDEX idx_messages_author_group_member_id (author_group_member_id=?) +SEARCH connections USING COVERING INDEX idx_connections_group_member_id (group_member_id=?) +SEARCH rcv_files USING COVERING INDEX idx_rcv_files_group_member_id (group_member_id=?) +SEARCH snd_files USING COVERING INDEX idx_snd_files_group_member_id (group_member_id=?) +SEARCH group_member_intros USING COVERING INDEX idx_group_member_intros_to_group_member_id (to_group_member_id=?) +SEARCH group_member_intros USING COVERING INDEX idx_group_member_intros_re_group_member_id (re_group_member_id=?) +SEARCH group_members USING COVERING INDEX idx_group_members_invited_by_group_member_id (invited_by_group_member_id=?) +SEARCH contacts USING COVERING INDEX idx_contacts_grp_direct_inv_from_group_member_id (grp_direct_inv_from_group_member_id=?) +SEARCH contacts USING COVERING INDEX idx_contacts_contact_group_member_id (contact_group_member_id=?) + Query: INSERT INTO group_relays (group_id, group_member_id, chat_relay_id, relay_status, created_at, updated_at) @@ -6530,6 +6565,10 @@ Query: SELECT COUNT(1) FROM contacts WHERE user_id = ? AND chat_item_ttl > 0 Plan: SEARCH contacts USING INDEX idx_contacts_chat_ts (user_id=?) +Query: SELECT COUNT(1) FROM group_members WHERE member_role = 'owner' AND member_pub_key IS NOT NULL +Plan: +SCAN group_members + Query: SELECT COUNT(1) FROM groups WHERE user_id = ? AND chat_item_ttl > 0 Plan: SEARCH groups USING INDEX sqlite_autoindex_groups_2 (user_id=?) diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 3afe0ce0ce..80fe4c0b30 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -22,7 +22,7 @@ import qualified Data.ByteString.Lazy.Char8 as LB import Data.Char (isSpace, toUpper) import Data.Function (on) import Data.Int (Int64) -import Data.List (groupBy, intercalate, intersperse, sortOn) +import Data.List (groupBy, intercalate, intersperse, nub, sortOn) import Data.List.NonEmpty (NonEmpty (..)) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M @@ -148,8 +148,8 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, testView} liveIte CRConnectionVerified u verified code -> ttyUser u [plain $ if verified then "connection verified" else "connection not verified, current code is " <> code] CRContactCode u ct code -> ttyUser u $ viewContactCode ct code testView CRGroupMemberCode u g m code -> ttyUser u $ viewGroupMemberCode g m code testView - CRNewChatItems u chatItems -> viewChatItems ttyUser unmuted u chatItems ts tz - CRChatItems u _ chatItems -> ttyUser u $ concatMap (\(AChatItem _ _ chat item) -> viewChatItem chat item True ts tz <> viewItemReactions item) chatItems + CRNewChatItems u chatItems -> viewChatItems ttyUser unmuted u chatItems ts tz testView + CRChatItems u _ chatItems -> ttyUser u $ concatMap (\(AChatItem _ _ chat item) -> viewChatItem chat item True ts tz <> viewItemReactions item <> viewTestInfo testView item) chatItems CRChatItemInfo u ci ciInfo -> ttyUser u $ viewChatItemInfo ci ciInfo tz CRChatItemId u itemId -> ttyUser u [plain $ maybe "no item" show itemId] CRChatItemUpdated u (AChatItem _ _ chat item) -> ttyUser u $ unmuted u chat item $ viewItemUpdate chat item liveItems ts tz @@ -222,6 +222,7 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, testView} liveIte CRLeftMemberUser u g -> ttyUser u $ [ttyGroup' g <> ": you left the group"] <> groupPreserved g 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 + CRChatMsgContent u mc -> ttyUser u $ ttyMsgContent mc <> viewMsgTestInfo testView mc CRRcvFileAccepted u ci -> ttyUser u $ savingFile' ci CRRcvFileAcceptedSndCancelled u ft -> ttyUser u $ viewRcvFileSndCancelled ft CRSndFileCancelled u _ ftm fts -> ttyUser u $ viewSndFileCancelled ftm fts @@ -407,7 +408,7 @@ chatEventToView hu ChatConfig {logLevel, showReactions, showReceipts, testView} CEvtContactRatchetSync u ct progress -> ttyUser u $ viewContactRatchetSync ct progress CEvtGroupMemberRatchetSync u g m progress -> ttyUser u $ viewGroupMemberRatchetSync g m progress CEvtChatInfoUpdated _ _ -> [] - CEvtNewChatItems u chatItems -> viewChatItems ttyUser unmuted u chatItems ts tz + CEvtNewChatItems u chatItems -> viewChatItems ttyUser unmuted u chatItems ts tz testView CEvtChatItemsStatusesUpdated u chatItems | length chatItems <= 20 -> concatMap @@ -646,11 +647,12 @@ viewChatItems :: [AChatItem] -> UTCTime -> TimeZone -> + Bool -> [StyledString] -viewChatItems ttyUser unmuted u chatItems ts tz +viewChatItems ttyUser unmuted u chatItems ts tz testView | length chatItems <= 20 = concatMap - (\(AChatItem _ _ chat item) -> ttyUser u $ unmuted u chat item $ viewChatItem chat item False ts tz <> viewItemReactions item) + (\(AChatItem _ _ chat item) -> ttyUser u $ unmuted u chat item $ viewChatItem chat item False ts tz <> viewItemReactions item <> viewTestInfo testView item) chatItems | all (\aci -> aChatItemDir aci == MDRcv) chatItems = ttyUser u [sShow (length chatItems) <> " new messages"] | all (\aci -> aChatItemDir aci == MDSnd) chatItems = ttyUser u [sShow (length chatItems) <> " messages sent"] @@ -949,6 +951,14 @@ viewItemReactions ChatItem {reactions} = [" " <> viewReactions reactions | viewReaction CIReactionCount {reaction = MREmoji (MREmojiChar emoji), userReacted, totalReacted} = plain [emoji, ' '] <> (if userReacted then styled Italic else plain) (show totalReacted) +viewTestInfo :: Bool -> ChatItem c d -> [StyledString] +viewTestInfo testView ChatItem {content} = maybe [] (viewMsgTestInfo testView) $ ciMsgContent content + +viewMsgTestInfo :: Bool -> MsgContent -> [StyledString] +viewMsgTestInfo testView = \case + MCChat {ownerSig = Just sig} | testView -> [viewJSON sig] + _ -> [] + viewReactionMembers :: [MemberReaction] -> [StyledString] viewReactionMembers memberReactions = [sShow (length memberReactions) <> " member(s) reacted"] @@ -2039,7 +2049,7 @@ viewGroupUserChanged viewConnectionPlan :: ChatConfig -> ACreatedConnLink -> ConnectionPlan -> [StyledString] viewConnectionPlan ChatConfig {logLevel, testView} _connLink = \case CPInvitationLink ilp -> case ilp of - ILPOk contactSLinkData -> [invOrBiz contactSLinkData "ok to connect"] <> [viewJSON contactSLinkData | testView] + ILPOk contactSLinkData ov -> [invOrBiz contactSLinkData "ok to connect"] <> viewSigVerification ov <> [viewJSON contactSLinkData | testView] ILPOwnLink -> [invLink "own link"] ILPConnecting Nothing -> [invLink "connecting"] ILPConnecting (Just ct) -> [invLink ("connecting to contact " <> ttyContact' ct)] @@ -2057,7 +2067,7 @@ viewConnectionPlan ChatConfig {logLevel, testView} _connLink = \case | business -> ("business address: " <>) _ -> ("invitation link: " <>) CPContactAddress cap -> case cap of - CAPOk contactSLinkData -> [addrOrBiz contactSLinkData "ok to connect"] <> [viewJSON contactSLinkData | testView] + CAPOk contactSLinkData ov -> [addrOrBiz contactSLinkData "ok to connect"] <> viewSigVerification ov <> [viewJSON contactSLinkData | testView] CAPOwnLink -> [ctAddr "own address"] CAPConnectingConfirmReconnect -> [ctAddr "connecting, allowed to reconnect"] CAPConnectingProhibit ct -> [ctAddr ("connecting to contact " <> ttyContact' ct)] @@ -2075,9 +2085,10 @@ viewConnectionPlan ChatConfig {logLevel, testView} _connLink = \case | business -> ("business address: " <>) _ -> ("contact address: " <>) CPGroupLink glp -> case glp of - GLPOk groupSLinkInfo_ groupSLinkData -> + GLPOk groupSLinkInfo_ groupSLinkData ov -> let direct = maybe True (\(GroupShortLinkInfo {direct = d}) -> d) groupSLinkInfo_ in [grpLink $ if direct then "ok to connect directly" else "ok to connect via relays"] + <> viewSigVerification ov <> [viewJSON groupSLinkData | testView] GLPOwnLink g -> [grpLink "own link for group " <> ttyGroup' g] GLPConnectingConfirmReconnect -> [grpLink "connecting, allowed to reconnect"] @@ -2113,6 +2124,10 @@ viewConnectionPlan ChatConfig {logLevel, testView} _connLink = \case nextConnectPrepared Contact {preparedContact, activeConn} = case preparedContact of Just _ -> maybe True (\c -> connStatus c == ConnPrepared) activeConn _ -> False + viewSigVerification = \case + Just OVVerified -> ["owner signature: verified"] + Just (OVFailed r) -> ["owner signature: FAILED (" <> plain r <> ")"] + Nothing -> [] viewContactUpdated :: Contact -> Contact -> [StyledString] viewContactUpdated @@ -2212,7 +2227,26 @@ sentWithTime_ ts tz styledMsg CIMeta {itemTs} = prependFirst (ttyMsgTime ts tz itemTs <> " ") styledMsg ttyMsgContent :: MsgContent -> [StyledString] -ttyMsgContent = msgPlain . msgContentText +ttyMsgContent = \case + MCChat {text, chatLink, ownerSig} -> + let (linkInfo, name, links) = viewChatLink chatLink + signed = if isJust ownerSig then " (signed)" else "" + body = if T.null text || text `elem` links then [] else msgPlain text + in [plain $ linkInfo <> viewName name <> signed <> ":"] <> map plain links <> body + mc -> msgPlain $ msgContentText mc + where + viewChatLink = \case + MCLGroup {connLink, groupProfile = GroupProfile {displayName, publicGroup}} -> + let (ref, links) = case publicGroup of + Just PublicGroupProfile {groupType, groupLink} -> (textEncode groupType, nub [enc connLink, enc groupLink]) + Nothing -> ("group", [enc connLink]) + in ("link to join " <> ref <> " #", displayName, links) + MCLContact {connLink, profile = Profile {displayName}} -> + ("contact address of @", displayName, [enc connLink]) + MCLInvitation {invLink, profile = Profile {displayName}} -> + ("one-time link of @", displayName, [enc invLink]) + enc :: StrEncoding a => a -> Text + enc = safeDecodeUtf8 . strEncode prependFirst :: StyledString -> [StyledString] -> [StyledString] prependFirst s [] = [s] diff --git a/tests/ChatTests/ChatRelays.hs b/tests/ChatTests/ChatRelays.hs index 721d71d0e0..58fe1074ef 100644 --- a/tests/ChatTests/ChatRelays.hs +++ b/tests/ChatTests/ChatRelays.hs @@ -1,9 +1,23 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} + module ChatTests.ChatRelays where import ChatClient import ChatTests.DBUtils +import ChatTests.Groups (memberJoinChannel, memberJoinChannel', prepareChannel, prepareChannel', prepareChannel1Relay, setupRelay) import ChatTests.Utils import Control.Concurrent (threadDelay) +import qualified Data.Aeson as J +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LB +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import ProtocolTests (testGroupProfile) +import Simplex.Chat.Protocol (LinkOwnerSig, MsgChatLink (..), MsgContent (..)) +import Simplex.Chat.Types (GroupProfile (..)) +import Simplex.Messaging.Encoding.String (StrEncoding (..)) +import Simplex.Messaging.Util (decodeJSON) import Test.Hspec hiding (it) chatRelayTests :: SpecWith TestParams @@ -14,6 +28,10 @@ chatRelayTests = do it "re-add soft-deleted relay by same name" testReAddRelaySameName it "test chat relay" testChatRelayTest it "relay profile updated in address" testRelayProfileUpdateInAddress + describe "share channel card" $ do + it "share channel card in direct chat" testShareChannelDirect + it "share channel card in group" testShareChannelGroup + it "share channel card in channel" testShareChannelChannel testGetSetChatRelays :: HasCallStack => TestParams -> IO () testGetSetChatRelays ps = @@ -165,6 +183,151 @@ testRelayProfileUpdateInAddress ps = alice ##> ("/relay test " <> bobSLink) alice <## "relay test passed, profile: bob2 (Bob relay)" +testShareChannelDirect :: HasCallStack => TestParams -> IO () +testShareChannelDirect ps = + testChat3 aliceProfile bobProfile cathProfile test ps + where + test alice bob cath = withRelay ps $ \relay -> do + (shortLink, fullLink) <- prepareChannel1Relay "news" alice relay + connectUsers alice bob + -- alice gets ownerSig from share content API (for validation later) + alice ##> "/_share chat content #1 @2" + alice <## "link to join channel #news (signed):" + (_, apiOwnerSig) <- getTermLine2 alice + -- alice sends the card to bob + alice ##> "/share chat #news @bob" + alice <# "@bob link to join channel #news (signed):" + _ <- getTermLine2 alice -- alice's testView ownerSig + bob <# "alice> link to join channel #news (signed):" + -- bob captures the received ownerSig from message view (testView) + (sLink, cSig) <- getTermLine2 bob + sLink `shouldBe` shortLink + cSig `shouldBe` apiOwnerSig + -- bob verifies owner signature via connect plan + bob ##> ("/_connect plan 1 " <> shortLink <> " sig=" <> cSig) + bob <## "group link: ok to connect via relays" + bob <## "owner signature: verified" + _ <- getTermLine bob -- group link data + -- bob joins + memberJoinChannel' "news" 1 0 1 0 [relay] [alice] shortLink fullLink bob + connectUsers bob cath + -- bob (subscriber) shares unsigned - not owner + bob ##> "/share chat #news @cath" + bob <# "@cath link to join channel #news:" + _ <- getTermLine bob + cath <# "bob> link to join channel #news:" + _ <- getTermLine cath + -- bob tries to replay alice's signed card to cath - binding mismatch, sig stripped at receive + let sig = fromMaybe (error "bad sig") (decodeJSON (T.pack cSig) :: Maybe LinkOwnerSig) + cLink = either error id $ strDecode (B.pack sLink) + mc = MCChat (T.pack sLink) (MCLGroup cLink (testGroupProfile {displayName = "news"} :: GroupProfile)) (Just sig) + cm = "{\"msgContent\":" <> LB.unpack (J.encode mc) <> "}" + bob ##> ("/_send @3 json [" <> cm <> "]") + bob <# "@cath link to join group #news (signed):" + _ <- getTermLine2 bob -- bob's testView ownerSig (his sent has the sig data) + -- cath sees it without signature - binding was for alice->bob, not bob->cath, sig stripped + cath <# "bob> link to join group #news:" + _ <- getTermLine cath + -- cath joins anyway + memberJoinChannel "news" [relay] [alice] shortLink fullLink cath + alice #> "#news hello" + relay <# "#news> hello" + [bob, cath] *<# "#news> hello [>>]" + +testShareChannelGroup :: HasCallStack => TestParams -> IO () +testShareChannelGroup ps = + testChat3 aliceProfile bobProfile cathProfile test ps + where + test alice bob cath = withRelay ps $ \relay -> do + (shortLink, fullLink) <- prepareChannel1Relay "news" alice relay + createGroup2 "team" alice bob + alice ##> "/share chat #news #team" + alice <# "#team link to join channel #news:" + _ <- getTermLine alice + bob <# "#team alice> link to join channel #news:" + sLink <- getTermLine bob + sLink `shouldBe` shortLink + memberJoinChannel' "news" 2 0 1 0 [relay] [alice] sLink fullLink bob + createGroup2 "work" bob cath + bob ##> "/share chat #news #work" + bob <# "#work link to join channel #news:" + _ <- getTermLine bob + cath <# "#work bob> link to join channel #news:" + _ <- getTermLine cath + memberJoinChannel' "news" 2 0 0 0 [relay] [alice] shortLink fullLink cath + alice #> "#news hello" + relay <# "#news> hello" + [bob, cath] *<# "#news> hello [>>]" + +testShareChannelChannel :: HasCallStack => TestParams -> IO () +testShareChannelChannel ps = + testChat3 aliceProfile bobProfile cathProfile test ps + where + test alice bob cath = withRelay ps $ \relay -> do + relaySLink <- setupRelay alice relay + (sLink1, fLink1) <- prepareChannel "news" alice relay + (sLink2, fLink2) <- prepareChannel' 2 "updates" alice relay + -- bob joins "updates" first (relay doesn't know bob yet, no suffix) + memberJoinChannel "updates" [relay] [alice] sLink2 fLink2 bob + -- alice (owner) shares "news" to "updates" - signed + alice ##> "/_share chat content #1 #2(as_group=on)" + alice <## "link to join channel #news (signed):" + (apiLink, apiOwnerSig) <- getTermLine2 alice + apiLink `shouldBe` sLink1 + alice ##> "/share chat #news #updates" + alice <# "#updates link to join channel #news (signed):" + _ <- getTermLine2 alice -- link, ownerSig + relay <# "#updates> link to join channel #news (signed):" + _ <- getTermLine2 relay -- link, ownerSig + bob <# "#updates> link to join channel #news (signed): [>>]" + (cLink, cSig) <- getTermLine2 bob + cLink `shouldBe` (sLink1 <> " [>>]") + cSig `shouldBe` apiOwnerSig + -- bob verifies alice's signature via connect plan + bob ##> ("/_connect plan 1 " <> sLink1 <> " sig=" <> cSig) + bob <## "group link: ok to connect via relays" + bob <## "owner signature: verified" + _ <- getTermLine bob -- group link data + -- bob joins "news" (group #2 for bob, relay knows bob from "updates" so sfx=1) + memberJoinChannel' "news" 2 1 1 1 [relay] [alice] sLink1 fLink1 bob + -- bob creates channel "bob_ch" for delivery to cath + bob ##> ("/relays name=relay " <> relaySLink) + bob <## "ok" + (sLink3, fLink3) <- prepareChannel "bob_ch" bob relay + memberJoinChannel "bob_ch" [relay] [bob] sLink3 fLink3 cath + -- bob (subscriber) shares "news" to "bob_ch" - unsigned (not owner) + bob ##> "/share chat #news #bob_ch" + bob <# "#bob_ch link to join channel #news:" + _ <- getTermLine bob + relay <# "#bob_ch> link to join channel #news:" + _ <- getTermLine relay + cath <# "#bob_ch> link to join channel #news: [>>]" + _ <- getTermLine cath + -- bob tries to replay alice's signed card to bob_ch - binding mismatch, sig stripped at receive + let sig = fromMaybe (error "bad sig") (decodeJSON (T.pack cSig) :: Maybe LinkOwnerSig) + cLink' = either error id $ strDecode (B.pack sLink1) + mc = MCChat (T.pack sLink1) (MCLGroup cLink' (testGroupProfile {displayName = "news"} :: GroupProfile)) (Just sig) + cm = "{\"msgContent\":" <> LB.unpack (J.encode mc) <> "}" + bob ##> ("/_send #3 json [" <> cm <> "]") + bob <# "#bob_ch link to join group #news (signed):" + _ <- getTermLine2 bob -- bob's testView ownerSig (his sent has the sig data) + relay <# "#bob_ch bob_2> link to join group #news:" + _ <- getTermLine relay + cath <# "#bob_ch bob> link to join group #news: [>>]" + _ <- getTermLine cath + -- cath joins "news" (group #2 for cath since "bob_ch" is #1) + memberJoinChannel' "news" 2 1 0 1 [relay] [alice] sLink1 fLink1 cath + -- alice sends message, both receive + alice #> "#news hello" + relay <# "#news> hello" + [bob, cath] *<# "#news> hello [>>]" + +getTermLine2 :: TestCC -> IO (String, String) +getTermLine2 c = (,) <$> getTermLine c <*> getTermLine c + +withRelay :: HasCallStack => TestParams -> (TestCC -> IO ()) -> IO () +withRelay ps = withNewTestChatOpts ps relayTestOpts "relay" relayProfile + -- Create a public group with relay=1, wait for relay to join createChannelWithRelay :: HasCallStack => String -> TestCC -> TestCC -> IO () createChannelWithRelay gName owner relay = do diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index 3c6a29c4e3..9e4f54f4df 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -8440,16 +8440,25 @@ createChannel1Relay gName owner relay cath dan eve = do forM_ [cath, dan, eve] $ \member -> memberJoinChannel gName [relay] [owner] shortLink fullLink member -prepareChannel1Relay :: String -> TestCC -> TestCC -> IO (String, String) -prepareChannel1Relay gName owner relay = do +setupRelay :: TestCC -> TestCC -> IO String +setupRelay owner relay = do rName <- userName relay - relay ##> "/ad" (relaySLink, _cLink) <- getContactLinks relay True - owner ##> ("/relays name=" <> rName <> " " <> relaySLink) owner <## "ok" + pure relaySLink +prepareChannel1Relay :: String -> TestCC -> TestCC -> IO (String, String) +prepareChannel1Relay gName owner relay = do + _ <- setupRelay owner relay + prepareChannel gName owner relay + +prepareChannel :: String -> TestCC -> TestCC -> IO (String, String) +prepareChannel = prepareChannel' 1 + +prepareChannel' :: Int -> String -> TestCC -> TestCC -> IO (String, String) +prepareChannel' relayId gName owner relay = do owner ##> ("/public group relays=1 #" <> gName) owner <## ("group #" <> gName <> " is created") owner <## "wait for selected relay(s) to join, then you can invite members via group link" @@ -8457,7 +8466,7 @@ prepareChannel1Relay gName owner relay = do concurrentlyN_ [ do owner <## ("#" <> gName <> ": group link relays updated, current relays:") - owner <## " - relay id 1: active" + owner <## (" - relay id " <> show relayId <> ": active") owner <## "group link:" _ <- getTermLine owner pure (), @@ -8516,10 +8525,17 @@ prepareChannel2Relays gName owner relay1 relay2 = do getGroupLinks owner gName GRMember False memberJoinChannel :: String -> [TestCC] -> [TestCC] -> String -> String -> TestCC -> IO () -memberJoinChannel gName relays owners shortLink fullLink member = do +memberJoinChannel gName = memberJoinChannel' gName 1 0 0 0 + +-- | sfx params: relaySfx - how relay/owner see the member, memberRelaySfx - how member sees relay +memberJoinChannel' :: String -> Int -> Int -> Int -> Int -> [TestCC] -> [TestCC] -> String -> String -> TestCC -> IO () +memberJoinChannel' gName gId relaySfx ownerSfx memberRelaySfx relays owners shortLink fullLink member = do mName <- userName member mFullName <- showName member - relayNames <- mapM userName relays + let sfxMName s = if s == 0 then mName else mName <> "_" <> show s + sfxName s = if s == 0 then mFullName else sfxMName s <> drop (length mName) mFullName + sfxRelayName rn = if memberRelaySfx == 0 then rn else rn <> "_" <> show memberRelaySfx + relayNames <- mapM (\r -> sfxRelayName <$> userName r) relays member ##> ("/_connect plan 1 " <> shortLink) member <## "group link: ok to connect via relays" @@ -8528,7 +8544,7 @@ memberJoinChannel gName relays owners shortLink fullLink member = do member ##> ("/_prepare group 1 " <> fullLink <> " " <> shortLink <> " direct=off " <> groupSLinkData) member <## ("#" <> gName <> ": group is prepared") - member ##> "/_connect group #1" + member ##> ("/_connect group #" <> show gId) member <## ("#" <> gName <> ": connection started") concurrentlyN_ $ [ member @@ -8540,11 +8556,11 @@ memberJoinChannel gName relays owners shortLink fullLink member = do ] ] <> [ do - relay <## (mFullName <> ": accepting request to join group #" <> gName <> "...") - relay <## ("#" <> gName <> ": " <> mName <> " joined the group") + relay <## (sfxName relaySfx <> ": accepting request to join group #" <> gName <> "...") + relay <## ("#" <> gName <> ": " <> sfxMName relaySfx <> " joined the group") | relay <- relays ] - <> [ owner <### [EndsWith ("added " <> mFullName <> " to the group")] + <> [ owner <### [EndsWith ("added " <> sfxName ownerSfx <> " to the group")] | owner <- owners ] diff --git a/tests/ChatTests/Utils.hs b/tests/ChatTests/Utils.hs index 8acdb78b34..ebc9056164 100644 --- a/tests/ChatTests/Utils.hs +++ b/tests/ChatTests/Utils.hs @@ -81,6 +81,9 @@ frankProfile = mkProfile "frank" "Frank" Nothing businessProfile :: Profile businessProfile = mkProfile "biz" "Biz Inc" Nothing +relayProfile :: Profile +relayProfile = mkProfile "relay" "Relay" Nothing + mkProfile :: T.Text -> T.Text -> Maybe ImageData -> Profile mkProfile displayName descr image = Profile {displayName, fullName = "", shortDescr = Just descr, image, contactLink = Nothing, peerType = Nothing, preferences = defaultPrefs}