From f6e7f4fe173acf0549d7dafa945e0457c3fafb9c Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Fri, 25 Sep 2026 10:22:06 +0000 Subject: [PATCH] badge presentations in profiles --- .../Chat/ChatItem/CIChatLinkHeader.swift | 9 +- .../views/chat/item/CIChatLinkHeader.kt | 17 +- cabal.project | 10 +- docs/protocol/simplex-chat.md | 2 +- docs/protocol/simplex-chat.schema.json | 3 + ...026-09-04-badge-binding-and-file-limits.md | 298 +++++++++++++--- simplex-chat.cabal | 2 + src/Simplex/Chat/Badges.hs | 31 +- src/Simplex/Chat/Library/Commands.hs | 157 ++++---- src/Simplex/Chat/Library/Internal.hs | 107 +++--- src/Simplex/Chat/Library/Subscriber.hs | 168 +++++---- src/Simplex/Chat/Protocol.hs | 10 +- src/Simplex/Chat/Store/ContactRequest.hs | 12 +- src/Simplex/Chat/Store/Direct.hs | 40 +-- src/Simplex/Chat/Store/Groups.hs | 104 +++--- src/Simplex/Chat/Store/Postgres/Migrations.hs | 4 +- .../Migrations/M20260924_conn_pres_header.hs | 19 + .../Store/Postgres/Migrations/chat_schema.sql | 3 +- src/Simplex/Chat/Store/SQLite/Migrations.hs | 4 +- .../Migrations/M20260924_conn_pres_header.hs | 18 + .../SQLite/Migrations/chat_query_plans.txt | 14 +- .../Store/SQLite/Migrations/chat_schema.sql | 1 + src/Simplex/Chat/Store/Shared.hs | 16 +- src/Simplex/Chat/Types.hs | 25 +- tests/BadgeTests.hs | 28 +- tests/ChatTests/Profiles.hs | 334 +++++++++++++++++- tests/ChatTests/Utils.hs | 48 ++- tests/ProtocolTests.hs | 5 +- 28 files changed, 1130 insertions(+), 359 deletions(-) create mode 100644 src/Simplex/Chat/Store/Postgres/Migrations/M20260924_conn_pres_header.hs create mode 100644 src/Simplex/Chat/Store/SQLite/Migrations/M20260924_conn_pres_header.hs diff --git a/apps/ios/Shared/Views/Chat/ChatItem/CIChatLinkHeader.swift b/apps/ios/Shared/Views/Chat/ChatItem/CIChatLinkHeader.swift index aaaa29929d..34768f5d0f 100644 --- a/apps/ios/Shared/Views/Chat/ChatItem/CIChatLinkHeader.swift +++ b/apps/ios/Shared/Views/Chat/ChatItem/CIChatLinkHeader.swift @@ -56,7 +56,7 @@ struct CIChatLinkHeader: View { ) .padding(.trailing, 4) VStack(alignment: .leading) { - Text(chatLink.displayName).font(.headline).lineLimit(2) + NameWithBadge(Text(chatLink.displayName).font(.headline), linkBadge, .headline).lineLimit(2) let fn = chatLink.fullName if fn != "" && fn != chatLink.displayName { Text(fn).font(.subheadline).lineLimit(2) @@ -65,4 +65,11 @@ struct CIChatLinkHeader: View { .frame(minHeight: 44) } } + + private var linkBadge: LocalBadge? { + guard case let .contact(_, profile, _) = chatLink, let b = profile.badge else { return nil } + let expired = Date.now.timeIntervalSince(b.badgeInfo.badgeExpiry) + let status: BadgeStatus = expired > 38 * 86400 ? .expiredOld : expired > 7 * 86400 ? .expired : .active + return LocalBadge(badge: b.badgeInfo, status: status) + } } diff --git a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/chat/item/CIChatLinkHeader.kt b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/chat/item/CIChatLinkHeader.kt index 3c3e4baf49..77ede9e76e 100644 --- a/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/chat/item/CIChatLinkHeader.kt +++ b/apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/chat/item/CIChatLinkHeader.kt @@ -10,9 +10,12 @@ import androidx.compose.ui.unit.dp import androidx.compose.ui.unit.sp import chat.simplex.common.model.* import chat.simplex.common.ui.theme.* +import chat.simplex.common.views.helpers.NameWithBadge import chat.simplex.common.views.helpers.ProfileImage import chat.simplex.res.MR import dev.icerock.moko.resources.compose.stringResource +import kotlinx.datetime.Clock +import kotlin.time.Duration.Companion.days @Composable fun CIChatLinkHeader( @@ -39,8 +42,9 @@ fun CIChatLinkHeader( Modifier.defaultMinSize(minHeight = 54.dp), verticalArrangement = Arrangement.Center ) { - Text( + NameWithBadge( chatLink.displayName, + linkBadge(chatLink), style = MaterialTheme.typography.caption, fontWeight = FontWeight.Medium, maxLines = 2, @@ -77,3 +81,14 @@ fun CIChatLinkHeader( } } } + +private fun linkBadge(chatLink: MsgChatLink): LocalBadge? { + val b = (chatLink as? MsgChatLink.Contact)?.profile?.badge ?: return null + val expired = Clock.System.now() - b.badgeInfo.badgeExpiry + val status = when { + expired > 38.days -> BadgeStatus.ExpiredOld + expired > 7.days -> BadgeStatus.Expired + else -> BadgeStatus.Active + } + return LocalBadge(b.badgeInfo, status) +} diff --git a/cabal.project b/cabal.project index b8c73b14cf..665522da49 100644 --- a/cabal.project +++ b/cabal.project @@ -1,4 +1,4 @@ -packages: . +packages: . ../simplexmq-4 -- packages: . ../simplexmq -- packages: . ../simplexmq ../direct-sqlcipher ../sqlcipher-simple @@ -18,10 +18,10 @@ package cryptostore constraints: zip +disable-bzip2 +disable-zstd -source-repository-package - type: git - location: https://github.com/simplex-chat/simplexmq.git - tag: 5294b7d8b7285a887b849b738e29bec207e5dde8 +-- source-repository-package +-- type: git +-- location: https://github.com/simplex-chat/simplexmq.git +-- tag: 5294b7d8b7285a887b849b738e29bec207e5dde8 source-repository-package type: git diff --git a/docs/protocol/simplex-chat.md b/docs/protocol/simplex-chat.md index 040064864c..19fcaa5025 100644 --- a/docs/protocol/simplex-chat.md +++ b/docs/protocol/simplex-chat.md @@ -232,7 +232,7 @@ Currently members can have one of four roles - `owner`, `admin`, `member` and `o `x.grp.inv` message is sent to invite contact to the group via contact's direct connection and includes group member connection address. This message MUST only be sent by members with `admin` or `owner` role. Optional `groupLinkId` is included when this message is sent to contacts connected via the user's group link. This identifier is a random byte sequence, with no global or even local uniqueness - it is only used for the user's invitations to a given group to provide confirmation to the contact that the group invitation is for the same group the contact was connecting to via the group link, so that the invitation can be automatically accepted by the contact - the contact compares it with the group link id contained in the group link uri's data field. -`x.grp.acpt` message is sent as part of group member connection handshake, only to the inviting user. +`x.grp.acpt` message is sent as part of group member connection handshake, only to the inviting user. It optionally includes the invited member's group profile. The inviting user replies with `x.grp.mem.info` that includes the inviting member's group profile. `x.grp.link.inv` message is sent as part of connection handshake to member joining via group link, and contains group profile and initial information about inviting and joining member. diff --git a/docs/protocol/simplex-chat.schema.json b/docs/protocol/simplex-chat.schema.json index 4614ba6929..c76c7d8816 100644 --- a/docs/protocol/simplex-chat.schema.json +++ b/docs/protocol/simplex-chat.schema.json @@ -564,6 +564,9 @@ "params": { "properties": { "memberId": {"ref": "base64url"} + }, + "optionalProperties": { + "profile": {"ref": "profile"} } } } diff --git a/plans/2026-09-04-badge-binding-and-file-limits.md b/plans/2026-09-04-badge-binding-and-file-limits.md index 4120720fd3..d5ba67385b 100644 --- a/plans/2026-09-04-badge-binding-and-file-limits.md +++ b/plans/2026-09-04-badge-binding-and-file-limits.md @@ -11,14 +11,14 @@ The same badge raises the size limit for files the user sends. Today each app de The changes: -1. Three new presentation headers: one for a profile shown in a chat, one for a file invitation, one for a file description. The random header stays valid where there is no chat yet, and for the profile in direct chats until the direct binding reaches the handshake. -2. In p2p groups a badge is accepted only from a message signed by the member. The member connection handshake is signed in both directions, and the profile sent in it is stored, so the badge appears when two members connect. -3. In channels a badge is accepted from any profile message, because member keys there come from the roster, the member list signed by the channel owner. +1. Four new presentation headers: a profile shown in a chat, a file invitation, a file description, and a contact request. The random header of released clients stays accepted. +2. Every profile badge is bound to the chat it is shown in: a direct chat, a contact request, a link, or a group membership (section 14). A proof bound to another chat is ignored. +3. In p2p groups a badge is accepted from a message signed by the member, from an introduction under the key it introduces, and from a join request under the request header. In channels it is accepted from any profile message. 4. Files above the default limit include a proof in the invitation and a proof in the description, in every chat type. The core library verifies both. The decision is stored on the file and shown by the apps from one field. 5. Forwarding a file above the forwarder's limit is refused with an alert before the forwarding sheet opens, and again, for the chosen destination, before anything is uploaded. 6. A received file keeps its two proofs, so a file re-sent to a new member as part of history keeps them; the sender's own files get fresh proofs from the credential. -Two new columns on `files`, and a new table `file_badge_proofs` holding the invitation proof and the description proof of a file, kept for history. One new function in simplexmq, the hash of the fields shared by all descriptions of one upload. +Two new columns on `files`, and a new table `file_badge_proofs` holding the invitation proof and the description proof of a file, kept for history. A new column on `connections`, the request header of a prepared connection. In simplexmq: the hash of the fields shared by all descriptions of one upload, the verification codes of a connection, links and invitations before link data is signed, and the request code of an invitation. ## Terms @@ -46,7 +46,7 @@ Two new columns on `files`, and a new table `file_badge_proofs` holding the invi **Presentation header.** A byte string that is an input to proof generation and to proof verification. A proof verifies only with the header it was generated with. Type `ProofPresHeader` in `Badges.hs`. `PHTest` is a random nonce. -**Chat binding.** The byte string that identifies the sender in one conversation, produced by `encodeChatBinding` (`Protocol.hs:444`). Message signatures and shared contact cards are computed over it. For a direct chat it is `encodeChatBinding CBDirect adHash`, where `adHash` is the hash of the connection's ratchet data, which both sides obtain with `getConnectionRatchetAdHash`. For a p2p group it is `encodeChatBinding CBGroup (smpEncode (memberId, memberKey))`. For a channel it is `encodeChatBinding CBGroup (smpEncode (publicGroupId, memberId))`. `groupBindingData` (`Internal.hs:2261`) computes the inner part for groups. +**Chat binding.** The byte string that identifies the sender in one conversation, produced by `encodeChatBinding` (`Protocol.hs:444`). Message signatures and shared contact cards are computed over it. For a direct chat it is `encodeChatBinding CBDirect codeAD`, where `codeAD` is the hash of the connection's ratchet data, which both sides obtain with `getConnectionVerifyCodes`. For a p2p group it is `encodeChatBinding CBGroup (smpEncode (memberId, memberKey))`. For a channel it is `encodeChatBinding CBGroup (smpEncode (publicGroupId, memberId))`. For a link it is `encodeChatBinding CBLink linkKey`. `groupBindingData` (`Internal.hs:2322`) computes the inner part for groups. **Member key.** The Ed25519 key a member holds for one group. It is created when first needed — at group creation on this branch, or by `createUserMemberKey` before the first signed message — and the public key is sent in introductions and in `XInfo`. @@ -64,10 +64,12 @@ data ProofPresHeader | PHChat ByteString | PHFileInv ByteString String Integer | PHFileDescr ByteString String Integer ByteString (Maybe UTCTime) + | PHRequest ByteString | PHUnknown Char ByteString ``` - `PHChat` holds the chat binding. +- `PHRequest` holds the request code (section 14.1). - `PHFileInv` holds the chat binding and the file size from the invitation. - `PHFileDescr` holds the same two values, then the shared description hash (section 8) and the file expiration. @@ -77,49 +79,50 @@ One constructor serves every chat type, because the chat binding already encodes `verifyBadgeWith` today verifies a proof with whatever header the proof contains. After this change the receiver first checks that the header names the sender as the receiver knows them, and only then runs BBS verification with that header. `proofPresHeaderAccepted` is removed; `verifyBadge` runs BBS verification only, and the header rule is applied by its callers: -- A contact request, link data, and the profile in a direct chat: the header must be `PHTest` until direct chats are bound (section 14). -- A file in a direct chat: the receiver has the contact's connection and obtains its ratchet hash from the agent, as `newContentMessage` does for a contact card (`Subscriber.hs:1883`). The binding in the header must equal `encodeChatBinding CBDirect adHash`. +- A contact request, link data, and the profile in a direct chat: the header of section 14. +- A file in a direct chat: the receiver has the contact's connection and obtains its ratchet hash from the agent, as `newContentMessage` does for a contact card (`Subscriber.hs:1883`). The binding in the header must equal `encodeChatBinding CBDirect codeAD`. - A profile or a file in a group: the receiver has the `GroupInfo` and the sender's `GroupMember`. The binding in the header must equal `groupBindingData` for that member — for a channel the group's public id and the member id; for a p2p group the member id and the member key. **The key in a p2p binding.** For a file the receiver may not know the sender's key yet; if it knows one and it differs from the key in the header, the proof fails, otherwise the key in the header is used for this verification and never stored (`proofMemberKey`). For a profile the key is the one the message signature was verified under, section 3; a header key is never used. The file headers are checked the same way and then further: `PHFileInv` must also name the file size as received; `PHFileDescr` must also hold the hash of the received description and the expiration received with it. -`PHUnknown` fails every check. A proof from a released client, which presents `PHTest` in groups, fails in groups; no badge has been issued yet, so nothing in use is affected. A released client that receives one of the new headers verifies it, because its `proofPresHeaderAccepted` admits unknown tags and BBS verification runs with the header bytes as sent. No protocol version change is needed. +`PHUnknown` fails every check. `PHTest`, presented by released clients, is accepted in every chat. A released client that receives one of the new headers verifies it, because its `proofPresHeaderAccepted` admits unknown tags and BBS verification runs with the header bytes as sent. No protocol version change is needed. -The chat layer computes the expected binding and passes it to the store, so `groupBindingData` and `profileBadgeVerified` stay where they are. `Badges.hs` holds the two header predicates: `unboundProof`, true for a `PHTest` header, and `boundProof binding_`, true when the header equals `PHChat` of the given binding and false when there is none. `verifyBadge_` and `profileBadgeVerified` take the predicate as their first argument. +The expected header is computed in the chat layer and passed to the store, so `groupBindingData` and `profileBadgeVerified` stay where they are. One predicate is defined in `Badges.hs`: `acceptedProof`, true for `PHTest` and for a header equal to the expected one (section 14.3). `SimplexDomainProof` (`Names.hs:37`) also uses `ProofPresHeader`, as an opaque value. Its verification is unchanged. ## 2. Presenting the profile badge -File: `src/Simplex/Chat/Library/Internal.hs`, `presentUserBadge` (`:2237`). +File: `src/Simplex/Chat/Library/Internal.hs`, `presentUserBadge` (`:2238`). -The function generates the proof for an outgoing profile. It takes a new argument, `Maybe GroupInfo`. With `Nothing` it generates `PHTest` as today. With `Just gInfo` it generates `PHChat` of `sndGroupChatBinding gInfo False`, the user's own member binding in that group; the membership key is stored by `mkGroupKeys` when the group is read with its keys, and a membership with no stored public key presents no badge. The proof is generated by `sndBadgeProof`, as file proofs are. +The proof for an outgoing profile is generated with `sndBadgeProof`, as file proofs are. The header, `Maybe ProofPresHeader`, is a parameter; with `Nothing`, no badge is presented. For a send into a group the header is `groupPresHeader`, `PHChat` of `sndGroupChatBinding gInfo False`, the user's own member binding in that group. The membership key is stored by `mkGroupKeys` when the group is read with its keys; for a membership without a stored public key, no badge is presented. The header of every call site is listed in section 14.3. -Call sites that send a profile into a group pass the group: `Commands.hs:3976` (join via group link, the relay case), `:4315` (the owner's profile to a relay); `Subscriber.hs:505` (the group case), `:637`, `:826`, `:840`, `:967`, `:1249`, `:3335`; `Internal.hs:2652` (`sendGroupProfileUpdate`). All other call sites send a direct profile and pass `Nothing`. - -A join by `XContact` (`Commands.hs:3976`, a p2p group or a group not yet known) sends the profile without a badge, since section 3 does not accept one there. The two handshake sends (section 4) present the badge only when the peer version is at least `relayWebCapVersion`. +The two handshake sends (section 4) present the badge only when the peer version is at least `relayWebCapVersion`. ## 3. Accepting the profile badge A received badge is verified today at seven places in the store layer, each verifying the proof with no knowledge of the sender: `profileBadgeVerified` (`Types.hs:851`), `createContact_` (`Store/Shared.hs:421`), `createJoiningMember` (`Store/Groups.hs:2085`), `createNewMemberProfile_` (`Store/Groups.hs:2440`), two contact request sites (`Store/ContactRequest.hs:170, 237`), and `linkDataBadge` (`Internal.hs:2253`). -The direct sites verify with `unboundProof`. The group store functions take the expected binding, `Maybe ByteString`, and verify with `boundProof`: `updateMemberProfile`, `updateContactMemberProfile` (`Store/Groups.hs:3411, 3434`), `createJoiningMember`, `createNewGroupMember`, `createIntroReMember`, and the functions that call `updateMemberProfile` inside the store — `updateUnknownMemberAnnounced`, `updateRosterMemberAnnounced`, `updatePreparedChannelMember`, `setRelayLinkAccepted`, `updateRelayMemberData`; the callers that build a profile from a name alone pass `Nothing`. A badge with no binding, or with a header that names another binding, is stored as failed, as a proof that fails BBS verification is today. +The expected header, `Maybe ProofPresHeader`, is a parameter of the store functions and is checked with `acceptedProof` (section 14.3); `Nothing` is passed where a profile is built from a name alone. A proof rejected by `acceptedProof` is ignored: at creation no badge is stored, at update the stored badge is kept. A proof that fails BBS verification is stored as failed. -The chat layer computes the binding with `memberChatBinding gInfo memberId key_` (`Internal.hs`): for a channel `encodeChatBinding CBGroup (publicGroupId, memberId)`, whatever the key; for a p2p group `encodeChatBinding CBGroup (memberId, key)`, or `Nothing` without a key. `rcvGroupChatBinding` uses it for its member alternatives. The key passed is the one the message was verified under: +The chat layer computes the binding with `memberChatBinding gInfo memberId key_` (`Internal.hs`): for a channel `encodeChatBinding CBGroup (publicGroupId, memberId)`, whatever the key; for a p2p group `encodeChatBinding CBGroup (memberId, key)`, or `Nothing` without a key. `rcvGroupChatBinding` uses it for its member alternatives. The key passed at each site: -- `xInfoMember` (`Subscriber.hs:2798`) and `xGrpLinkMem` (`:2804`): the stored key when `RcvMessage.msgSigned` is `MSSVerified`; otherwise the key the message delivers, when `storeMemberKey` verified the signature with it and stored it — `storeMemberKey` returns that key; otherwise none. +- `xInfoMember` (`Subscriber.hs:2801`) and `xGrpLinkMem` (`:2807`): the stored key when `RcvMessage.msgSigned` is `MSSVerified`; otherwise the key the message delivers, when `storeMemberKey` verified the signature with it and stored it — `storeMemberKey` returns that key; otherwise none. - The member connection handshake, section 4: the stored key when it verifies the signature. -- `createJoiningMember`, `createNewGroupMember`, `createIntroReMember`, `updateUnknownMemberAnnounced`, `updateRosterMemberAnnounced`, `updatePreparedChannelMember`, and `updateMemberProfile` in `acceptGroupJoinRequestAsync`: no key. In a channel the binding is complete without it; in a p2p group a join by `XContact` (unsigned JSON) or an introduction (the key is asserted by the introducer) yields no binding, and the member's badge arrives at the handshake. A relay's profile, from its link data, passes `Nothing`. +- Introductions — `createNewGroupMember`, `createIntroReMember`, `updateUnknownMemberAnnounced`: the key in the `MemberInfo`. +- Channel sites — `updateRosterMemberAnnounced`, `updatePreparedChannelMember`, a join via a relay (`createJoiningMember`, `updateMemberProfile`): no key; the channel binding is complete without it. +- A join by `XContact` to a p2p group: the request header (section 14.3). +- A relay's profile, from its link data: `Nothing`. -So in a channel a badge is accepted from any profile message: from `XMember` when the member joins, from the introduction by a relay, and from `XInfo`. The binding names the member id and the group only, and a proof can be replayed only for the member who made it. In a p2p group a badge is accepted only from a message whose signature was verified under the member's key; `withVerifiedMsg` treats signatures as optional there, so the check is made at the three sites above. +In a channel a badge is accepted from any profile message: from `XMember` when the member joins, from the introduction by a relay, and from `XInfo`. In a p2p group a badge is accepted from a message whose signature was verified under the member's key, from an introduction under the key it introduces, and from a join request under the request header. ## 4. The member connection handshake When two p2p members connect, each sends `XGrpMemInfo` with its group profile. It is sent from two places: the reply on the member connection (`Subscriber.hs:843`) and the join of the member connection and of the direct connection to the same member (`:3336`, both joined with the same message at `:3345-3347`). The four receiving sites — `:615, 647` on the direct connection, `:837, 850` on the member connection — each have a "TODO update member profile" comment. -`XGrpMemInfo` is not in `requiresSignature`: the recipient enforces that list only in channels, where the handshake does not occur, and a signature needs the binary encoding, which the peer version decides. Instead `groupMsgSigning` signs `XGrpMemInfo` when its profile carries a badge, and the badge is presented only when the peer version is at least `relayWebCapVersion`, so a presented badge is always signed. The recipient keeps a badge only from a verified signature, so a profile without a badge needs none. +`XGrpMemInfo` is not in `requiresSignature`: the recipient enforces that list only in channels, where the handshake does not occur, and a signature needs the binary encoding, which the peer version decides. Instead `groupMsgSigning` signs `XGrpMemInfo` when its profile includes a badge, and the badge is presented only when the peer version is at least `relayWebCapVersion`, so a presented badge is always signed. The recipient keeps a badge only from a verified signature, so a profile without a badge needs none. - **Sign the join side.** `xGrpMemFwd` sends `encodeConnInfo $ XGrpMemInfo ...` (`:3336`), plain JSON. It takes `GroupInfoKeys` from the dispatch and encodes with `encodeSignedConnInfo` when `groupMsgSigning` returns a signing. The agreed version is computed below the send, as `chatV`; that computation moves above it, and the badge is presented when `chatV` is at least `relayWebCapVersion`. - **The reply side** (`:843`) presents the badge when `peerChatVRange` of the connection allows, and `allowAgentConnectionAsync` signs by the same rule. @@ -256,55 +259,266 @@ The six proof columns are the fields of `BadgeProof` — the proof, the presenta ## 13. Tests - `BadgeTests.hs`: each header encodes and decodes; a proof generated with one header fails with another; the key check accepts an unknown key, accepts an equal key, rejects a different one. -- `ChatTests/Profiles.hs`, beside the seven badge tests: a badge in a p2p group appears at the other member after the connection handshake and not before; a proof presented under another member's binding is rejected; a badge in a channel appears on presentation. Existing tests that assert a badge at introduction time are updated. +- `ChatTests/Profiles.hs`, beside the seven badge tests: a badge in a p2p group is shown at the other member from the introduction and from the connection handshake; a proof presented under another member's binding is ignored; a badge in a channel is shown on presentation. The tests of section 14.3 follow. - `ChatTests/Files.hs`, beside `testXFTPGroupFileTransfer`: a file above the default limit from a badge holder is received in a group and in a direct chat; an invitation whose proof was made for another member is refused; a description with a changed hash fails before download; a file above the limit received as history is received by the new member; a forward into an incognito membership above the default limit fails the command before any upload. - `ProtocolTests.hs`: the new fields in `FileInvitation` and `XMsgFileDescr`. -## 14. Direct chats +## 14. Bindings in every chat -The binding of a direct chat is the ratchet associated data, `rcAD = k1_snd ‖ k1_rcv` (simplexmq `Ratchet.hs:498`), hashed: the value `getConnectionRatchetAdHash` returns, already the `CBDirect` payload of file proofs and shared contact cards. A contact request to an address without ratchet keys has no ratchet yet; its binding is the request itself. Both are made available by the agent before the chat composes the message, so every profile message is bound and nothing is sent after connection. Implementation starts in simplexmq, in `/code/simplexmq-4`; the chat then builds against it. +Every profile badge is bound to the chat it is shown in. The sender presents the proof under the header of that chat; the receiver computes the expected header and accepts the proof only under it. Implementation starts in simplexmq, in `/code/simplexmq-4`; the chat then builds against it. -### 14.1 Agent +Rules: -**Second verification code.** `RatchetInitParams` gains `rcVerifyCodePQ` and `Ratchet` gains `rcVCPQ :: Maybe Str`. `pqX3dh` expands the KDF to 128 bytes with `hkdf4` and takes the last 32 as the code; the first 96 bytes are the same output as today, so peers on either version derive the same keys, and `rcAD` stays the AEAD associated data. It is not associated data itself — it is exported keying material, the fourth of the paper's mitigations, and it covers every handshake input, the KEM included. A ratchet created before this change decodes with `rcVCPQ = Nothing`, and the value cannot be computed for it afterwards — the handshake secrets are gone — so it appears at the next ratchet resync or not at all. For that reason the chat keeps using the AD code, `codeAD`, for the security code and for badge bindings; `codePQ` is stored now and used when connections have it. +1. A ratchet held by both sides: the ratchet code. +2. A connection request before the ratchet: the request code — the proposing party's X448 keys and the id of the queue the joining party sends to. +3. A link shown to anyone who holds it: the link key. +4. A group: the member identity. -**Columns.** Migration `M20260919_ratchet_ad`, SQLite and Postgres, both schema dumps: `ratchets` gains `ratchet_ad BLOB` and `ratchet_ad_pq BLOB` (`BYTEA` on Postgres). `createRatchet` and `createSndRatchet` write both, also through their `ON CONFLICT` update, which is how a resync recreates the ratchet. +| Context | Received by | Header | +|---|---|---| +| Direct chat: `XInfo`, `CONF` and `INFO` replies, accept, one-time link join, member contacts | contact | `PHChat (encodeChatBinding CBDirect codeAD)` | +| Request to an address with ratchet keys | address owner | `PHChat (encodeChatBinding CBDirect codeAD)` | +| Request to an address without ratchet keys | address owner, group host | `PHRequest code` — the joining party's keys, the address queue | +| One-time invitation link data | joining party | `PHRequest code` — the inviter's keys, the invitation queue | +| Address link data, shared address card | anyone with the link | `PHChat (encodeChatBinding CBLink linkKey)` | +| P2p group | members | `PHChat (encodeChatBinding CBGroup (smpEncode (memberId, memberKey)))` | +| Channel | subscribers | `PHChat (encodeChatBinding CBGroup (smpEncode (publicGroupId, memberId)))` | -One store function, `getRatchetADs :: DB.Connection -> [ConnId] -> IO (Map ConnId (ByteString, Maybe ByteString))`, serves one id or many, with one SELECT and at most one batched UPDATE: +An address is a contact address, a business address, or a group link. The link key is part of the link: `sha3_256` of the fixed link data — the root key, the entity id, and the connection request with its server and queue id (`ShortLink.hs:61-64`). + +### 14.1 Agent: verification codes + +Merged in simplexmq `5294b7d8`. + +**Second verification code.** `RatchetInitParams` gains `rcVerifyCodePQ` and `Ratchet` gains `rcVCPQ :: Maybe Str`. `pqX3dh` derives the code with a separate HKDF over the same inputs, info `SimpleXVerifyCode`, 32 bytes; the ratchet keys and `rcAD` are unchanged. It is not associated data itself — it is exported keying material, the fourth of the paper's mitigations, and it covers every handshake input, the KEM included. A ratchet created before this change decodes with `rcVCPQ = Nothing`, and the value cannot be computed for it afterwards — the handshake secrets are gone — so it appears at the next ratchet resync or not at all. For that reason the chat keeps using the AD code, `codeAD`, for the security code and for badge bindings; `codePQ` is stored now and used when connections have it. + +**Columns.** Migration `M20260919_ratchet_verify_codes`, SQLite and Postgres, both schema dumps: ```sql -SELECT conn_id, ratchet_ad, ratchet_ad_pq, CASE WHEN ratchet_ad IS NULL THEN ratchet_state END -FROM ratchets -WHERE conn_id IN (?, ?, ...) +ALTER TABLE ratchets ADD COLUMN rc_verify_code_ad BLOB; +ALTER TABLE ratchets ADD COLUMN rc_verify_code_pq BLOB; ``` -The blob column is NULL in every row that has `ratchet_ad`, so an established connection costs one small row and no JSON decoding. Rows are `(ConnId, Maybe ByteString, Maybe ByteString, Maybe RatchetX448)`; a row with the AD is used as is; a row with the blob is decoded for `rcAD` and `rcADPQ` and collected; a row with neither (a ratchet row holding only x3dh keys, before CONF) is skipped. The collected rows are written back with one `executeMany "UPDATE ratchets SET ratchet_ad = ?, ratchet_ad_pq = ? WHERE conn_id = ?"`. On Postgres the list is `In connIds`; on SQLite the placeholder list is built from the id count, in chunks of 500 to stay under the variable limit. Only a NULL `ratchet_ad` selects the blob: `ratchet_ad_pq` stays NULL for a ratchet created before the change and never causes a second read. +`BYTEA` on Postgres. `createRatchet` and `createSndRatchet` write both, also through their `ON CONFLICT` update, which is how a resync recreates the ratchet. -`getConnectionVerifyCodes` uses it with one id, `getConnectionsVerifyCodes` with many; both return `ConnVerifyCodes {codeAD, codePQ}`, defined in `Agent/Protocol.hs`, where `codeAD = sha256 rcAD` and `codePQ` is the PQ code as derived. +One store function, `getRatchetVerifyCodes :: DB.Connection -> [ConnId] -> IO (Map ConnId ConnVerifyCodes)`, serves one id or many: -**Prepare step.** `prepareConnectionToJoin` returns `(ConnId, ConnVerifyCodes)`, the binding for the message the chat composes next: +```sql +SELECT conn_id, rc_verify_code_ad, rc_verify_code_pq, CASE WHEN rc_verify_code_ad IS NULL THEN ratchet_state END +FROM ratchets +``` -- `CRInvitationUri`: creates the sender ratchet (`createRatchet_`, local — the link's keys and a fresh keypair) and returns its codes. +- A row with `rc_verify_code_ad` is used as is. +- A row with the ratchet state is decoded, and its codes are computed and saved. +- A row with x3dh keys only is skipped. +- SQLite: one SELECT per id; the computed codes are saved with one `executeMany` UPDATE. +- Postgres: one SELECT with `In connIds`; the computed codes are saved with one `UPDATE ... FROM (VALUES ...) RETURNING`; codes saved by a concurrent read are kept. + +It is used by `getConnectionVerifyCodes` with one id, with `CONN NOT_FOUND` for a connection without codes, and by `getConnectionsVerifyCodes` with many. The result is `ConnVerifyCodes {codeAD, codePQ}`, defined in `Agent/Protocol.hs`, where `codeAD = sha256 rcAD` and `codePQ` is the PQ code as derived. + +**Prepare step.** The result of `prepareConnectionToJoin` is `(ConnId, ContactRequestBinding)`, the binding for the message the chat composes next: + +```haskell +data ContactRequestBinding = CRBRatchet ConnVerifyCodes | CRBRequest ByteString +``` + +- `CRInvitationUri`: the sender ratchet is created (`createRatchet_`, local — the link's keys and a fresh keypair); the binding is `CRBRatchet` of its codes. - `CRContactUri` with ratchet keys: the same, from the address keys. -- `CRContactUri` without keys: generates the x3dh keys (`generateRcvE2EParams`, `createRatchetX3dhKeys`) and returns `codeAD = sha256 (k1 ‖ k2 ‖ kem ‖ senderId)` with no `codePQ` — the request's public keys and the queue id from the link's `SMPQueueUri`. +- `CRContactUri` without keys: the x3dh keys are generated and stored (`generateRcvE2EParams`, `createRatchetX3dhKeys`); the binding is `CRBRequest (sha256 (smpEncode (k1, k2, kem, senderId)))` — the request's public keys and the queue id from the link's `SMPQueueUri`. The PQ key is removed from this code in section 14.2. `prepareConnectionToAccept` returns the same pair: for `CRInvitation` it creates the ratchet from the invitation's keys, for `CRInvitationDR` it takes the ratchet stored in the invitation. `startJoinInvitation` reads the ratchet before creating one, as the contact path and its retry branch already do; `createConnReq` reads the x3dh keys before generating them, as `mkJoinInvitation` does. Async joins and accepts then find the ratchet in place. Nothing in the prepare step touches the network. -**Events.** `REQ` gains a `ConnVerifyCodes` field: `smpInvitation` computes `codeAD` from the received `CRInvitationUri` and the queue it arrived on; `smpContactRequest` passes the codes of the ratchet it initialised. `CONF` and `INFO` are unchanged: the receiver's ratchet is stored before the notification, so the getter serves. A request without a ratchet proves no key possession; X448 keys cannot sign, and a forged request with copied public keys shows the badge in the request list and then fails to connect — accepted. +**Events.** A `ContactRequestBinding` field in `REQ`: `CRBRequest` in `smpInvitation`, computed from the received `CRInvitationUri` and the queue of the request; `CRBRatchet` in `smpContactRequest`, from the ratchet initialised there. `CONF` and `INFO` are unchanged: the receiver's ratchet is stored before the notification, so its codes are available to `getConnectionVerifyCodes`. **Tests.** `DoubleRatchetTests`: the parties agree on `rcVerifyCodePQ`, a substituted KEM key makes it differ while `assocData` matches, and a ratchet stored before the change decodes with `rcVCPQ = Nothing`. `FunctionalAPITests`: both peers get the same codes, and codes cleared from a row are recomputed and saved on the next read. -### 14.2 Chat +### 14.2 Agent: links before link data -The chat uses `codeAD` — for the security code it shows today and for every badge binding. `codePQ` is stored by the agent and used later, once connections have it on both sides; a ratchet created before the change never does without a resync. +Files: `Agent.hs`, `Agent/Protocol.hs`, `tests/AgentTests/FunctionalAPITests.hs`. -`presentUserBadge` takes the binding, `Maybe ByteString`, for both chat kinds — `sndGroupChatBinding gInfo False` for a group, `codeAD` for a direct chat — and generates `PHChat`; the `PHTest` branch, `unboundProof` and the `PHTest` acceptance go. +Every link, and every invitation, is available to the chat before its link data is signed; each creation makes one network request. -Sending: a join via one-time link (`Commands.hs:3826`, member contact `:3408`, `Subscriber.hs:3933`) and a request (`joinContact`, `Commands.hs:3980`) use the value from `prepareConnectionToJoin`; accepting (`Internal.hs:998, 1010`) the value from `prepareConnectionToAccept`; INFO (`Subscriber.hs:505` direct case, `:624`) the getter on the connection; `XInfo` to contacts (`Commands.hs:4062, 4095`, `presentUserBadgeToContacts`) the bulk getter, once per command. +**New links.** The link, and for an invitation the invitation, are returned by `prepareConnectionLink` before the user data is signed, in both connection modes: -Receiving: `updateContactProfile` (`Direct.hs:566`), `createContact_` (`Shared.hs:419`), the request sites (`ContactRequest.hs:170, 237`) and `linkDataBadge` take `Maybe ByteString` and verify with `boundProof`; `processContactProfileUpdate` (`Subscriber.hs:2758`) and the contact creation at CONF (`:3173`) pass the getter's value, the request sites the `REQ` field. After a resync the value changes on both sides; a badge received under the old one fails and is re-verified with the next update, which `badgeNeedsReverify` already does. +```haskell +prepareConnectionLink :: ConnectionModeI c => AgentClient -> UserId -> SConnectionMode c -> C.KeyPairEd25519 -> Maybe ByteString -> Bool -> Maybe CRClientData -> CR.InitialKeys -> UseRatchetKeys -> Maybe SMPServerWithAuth -> AE (CreatedConnLink c, PreparedLinkParams) -Link data: bound to the link key with a new `ChatBinding` constructor, `CBLink`, payload `strEncode linkKey` from `CSLContact` or `CSLInvitation`, which both the owner and anyone with the link hold. The key is derived from local data (`encodeSignLinkData`), so `prepareConnectionLink` is generalised to addresses and invitation links and the badge is bound before `createConnectionForLink` uploads the data; updates (`setMyAddressData`, `updatePCCShortLinkData`) already hold the link. +createConnectionForLink :: ConnectionModeI c => AgentClient -> NetworkRequestMode -> UserId -> Bool -> CreatedConnLink c -> PreparedLinkParams -> UserConnLinkData c -> SubscriptionMode -> AE (ConnId, CreatedConnLink c) +``` + +- The link entity id is optional; `Nothing` for an invitation. +- A new field in `PreparedLinkParams`: + + ```haskell + plpInvitationKeys :: Maybe (RcvE2EPrivRatchetParams 'C.X448) + ``` + +- Contact mode is unchanged; the link given to `createConnectionForLink` is returned. +- Invitation mode, prepare: + - x3dh keys from `CR.generateRcvE2EParams`, PQ support from `CR.initialPQEncryption True pqInitKeys` + - `connReq = CRInvitationUri crData e2eRcvParams`, queue mode `QMMessaging` + - the returned link is `CCLink connReq Nothing`; the key is `plpLinkKey` + - `useDR` is ignored +- Invitation mode, create: + - `plpInvitationKeys` are stored with `createRatchetX3dhKeys` + - link data: `SL.encodeSignUserData SCMInvitation`, encrypted with `SL.invShortLinkKdf plpLinkKey` + - queue request: `CQRMessaging (Just CQRData {linkKey, privSigKey, srvReq = (sndId, srvData)})` + - the returned link: from `connReqWithShortLink`, moved from `newRcvConnSrv` to top level — `CSLInvitation` with the link id from the server, PQ keys removed from the full link for `IKPQOn` +- Tests: a connection via an invitation made by prepare and create; its link data is read by the joining party; `plpLinkKey` equals the key in the returned `CSLInvitation`. The six existing test calls are updated for the mode and the pair. + +**Existing connections.** The link of a connection is returned without a network call: + +```haskell +prepareConnShortLink :: AgentClient -> ConnId -> Maybe CRClientData -> Maybe CR.InitialKeys -> AE (ConnShortLink 'CMContact) +``` + +- A stored link is returned as is. +- Otherwise the address ratchet keys are chosen from `InitialKeys` (`addressRatchetKeys`), and the credentials are created and stored (`newContactLinkCreds`): the signing key pair is generated, the fixed data is built, signed and encrypted (`SL.encryptFixedData`), and `ShortLinkCreds` are stored. +- `setConnShortLink` uses the same two functions for a connection without stored credentials, and then encrypts and uploads the user data with one `LSET`. +- Tests: for an address without a short link, the link is the same from two `prepareConnShortLink` calls and from `setConnShortLink`; a requester connects via it. + +**Invitation code.** Exported: + +```haskell +invitationRequestCode :: ConnectionRequestUri 'CMInvitation -> ByteString +``` + +- `requestCode` (`Agent.hs:1423-1424`) of the invitation's X448 keys and the sender id of its first queue. +- The PQ key is removed from `requestCode`: `sha256 (smpEncode (k1, k2, sndId))`, for requests and invitations alike, so the full link of an invitation created with `IKPQOn`, which is stored without the PQ key, gives the same code as its link data. +- Tests: the code of a prepared invitation equals the code of the invitation read from its link data and the code of its full link. + +### 14.3 Chat + +Todo, in implementation order. At every send, a `Nothing` from a header helper is replaced by `unboundPresHeader`. + +**1. Headers** — `Badges.hs`, `Protocol.hs` + +- `PHRequest ByteString` in `ProofPresHeader`, tag `'R'`. +- `CBLink` in `ChatBinding`, tag `'L'`; payload: the link key bytes. +- `acceptedProof :: Maybe ProofPresHeader -> BadgeProof -> Bool`: true for `PHTest`, and for a header equal to `strEncode` of the expected one. `unboundProof` and `boundProof` are replaced by it. +- `ToField` and `FromField` for `ProofPresHeader`: the `strEncode` bytes as a blob. + +**2. Ignored proofs** — `Types.hs`, store modules + +- A proof rejected by `acceptedProof` is ignored. +- At creation no badge is stored: `createContact_`, `createContactRequest` (`ContactRequest.hs:170`), `createJoiningMember`, `createNewMemberProfile_`. +- At update the stored badge is kept: the badge to store and its verification are returned by `profileBadgeVerified` — for a rejected proof, the stored proof and its stored verification. Used in `updateContactProfile`, `updateMemberProfile`, `updateContactMemberProfile`, and the request update (`ContactRequest.hs:237`). +- The predicate is removed from `verifyBadge_`. `BSFailed` is stored only for a failed BBS verification. + +**3. Expected header in the store** + +The expected header, `Maybe ProofPresHeader`, is a parameter of: + +- `updateContactProfile` +- `createDirectContact` +- `createPreparedContact` +- `createOrUpdateContactRequest` +- `updateMemberProfile` +- `updateContactMemberProfile` +- `createJoiningMember` +- `createNewGroupMember` +- `createIntroReMember` +- `updateUnknownMemberAnnounced` +- `updateRosterMemberAnnounced` +- `updatePreparedChannelMember` +- `setRelayLinkAccepted` +- `updateRelayMemberData` + +`Nothing` for `createContact`, the preset contact card. The same parameter in `processMemberProfileUpdate`. In group callers the bindings computed today are wrapped with `PHChat <$>`. + +**4. Presenting** — `Internal.hs` + +```haskell +presentUserBadge :: User -> Maybe i -> Maybe ProofPresHeader -> Profile -> CM Profile +``` + +With `Nothing`, no badge is presented. Header helpers: + +- `groupPresHeader :: GroupInfo -> Maybe ProofPresHeader` — `PHChat <$> sndGroupChatBinding gInfo False` +- `directPresHeader :: ContactRequestBinding -> ProofPresHeader` — `PHChat (encodeChatBinding CBDirect codeAD)` for `CRBRatchet`, `PHRequest code` for `CRBRequest` +- `linkPresHeader :: LinkKey -> ProofPresHeader` — `PHChat (encodeChatBinding CBLink key)` +- a one-time invitation's header: `PHRequest (invitationRequestCode connReq)` +- `unboundPresHeader :: CM ProofPresHeader` — `PHTest` of 16 random bytes +- `connPresHeader :: Connection -> CM (Maybe ProofPresHeader)` — `directPresHeader . CRBRatchet` of `getConnectionVerifyCodes`; `Nothing` on error +- `connsPresHeaders :: [Connection] -> CM (Map ConnId ProofPresHeader)` — the same from `getConnectionsVerifyCodes` + +**5. The binding from prepare steps** + +- `prepareContact :: User -> ConnReqContact -> PQSupport -> CM (ConnId, VersionChat, ContactRequestBinding)` +- `prepareAgentJoin :: User -> Maybe Connection -> Bool -> ConnectionRequestUri c -> CM ((CommandId, ConnId), Maybe ContactRequestBinding)` — `Nothing` for an existing connection +- `prepareAgentAccept :: User -> Bool -> InvitationId -> PQSupport -> CM ((CommandId, ConnId), ContactRequestBinding)` + +**6. Stored request header** + +Migration `M20260924_conn_pres_header`, SQLite and Postgres: + +```sql +ALTER TABLE connections ADD COLUMN pres_header BLOB; +``` + +`BYTEA` on Postgres. Both schema dumps and `chat_query_plans.txt` are updated. + +- `createConnReqConnection`: the request header is a parameter, written to `pres_header`. +- `getConnReqContact`: the result is `(ConnReqContact, Maybe ProofPresHeader)`, read from `via_contact_uri` and `pres_header`. + +**7. Direct sends** + +- `joinContact` (`Commands.hs:3973`): the header, `Maybe ProofPresHeader`, is a parameter, set in `connect'`, `joinPreparedConn'` and `connectContactViaAddress`: + - a relay group: `groupPresHeader` + - every other join: `directPresHeader` of the `prepareContact` binding for a new connection, the stored header for a retry +- The branch on `gInfo_` for the badge (`Commands.hs:3976-3982`) is removed; the profile is still chosen by `gInfo_`. +- `connectViaInvitation` (`Commands.hs:3819-3832`) and `connectMemberContact` (`:3398-3413`): the prepare binding for a new connection; `connPresHeader` for a prepared one. +- `joinMemberContactAsync` (`Subscriber.hs:3931`): the header is a parameter, set in `xGrpDirectInv` to `directPresHeader` of the `prepareAgentJoin` binding. +- `acceptContactRequest` (`Internal.hs:970-1000`): the prepare binding for a new connection; `connPresHeader` for an existing one. +- `acceptContactRequestAsync` (`Internal.hs:1002-1021`): the profile is built after `prepareAgentAccept`, from its binding. +- `CONF` replies (`Subscriber.hs:505` direct case, `:624`) and `updateContactPrefs` (`Commands.hs:4099`): `connPresHeader`. +- `sendUpdateToContacts` (`Commands.hs:4033-4071`) and `presentUserBadgeToContacts` (`:5200-5216`): one `connsPresHeaders` call per command. + +**8. Direct receipts** + +- `REQ` (`Subscriber.hs:1396`): `directPresHeader` of the `REQ` binding is a parameter of `profileContactRequest`, passed to `createOrUpdateContactRequest` and to `acceptGroupJoinRequestAsync`. +- `processContactProfileUpdate` (`Subscriber.hs:2758`): `connPresHeader` of the contact's connection, read in the update branch. +- `saveConnInfo` (`Subscriber.hs:3173`): `connPresHeader` of the connection, for `createDirectContact`. + +**9. Groups** + +- `groupPresHeader` at every send into a group: `Commands.hs:4319`; `Subscriber.hs:505` group case, `:637`, `:826`, `:843`, `:970`, `:1252`, `:3356`; `Internal.hs:2656`. +- `acceptGroupJoinRequestAsync`: the expected header is a parameter, in place of `binding_` (`Internal.hs:1044`) — `PHChat <$> memberChatBinding gInfo joiningMemberId Nothing` in `memberJoinRequestViaRelay`. `Nothing` in `acceptGroupJoinSendRejectAsync`. +- Host `INFO` with `XInfo` (`Subscriber.hs:859-864`): after `storeMemberKey`, the profile is stored by `processMemberProfileUpdate` with `PHChat <$> signedMemberBinding`, under the member's key. +- The profile is also stored by `processMemberProfileUpdate` when the new proof is accepted and its header differs from the stored proof's header. +- Introductions: + - In `memberInfo` (`Internal.hs:1330`) the stored proof is included when `acceptedProof (PHChat <$> memberChatBinding g memberId memberPubKey)` holds, and omitted otherwise. + - In `xGrpMemNew`, `xGrpMemIntro` and `xGrpMemFwd` (`Subscriber.hs:3197, 3279, 3341`): `PHChat <$> memberChatBinding gInfo memId key`, with `key` from the `MemberInfo`. +- Invitation via contact: + - `profile :: Maybe Profile` in `XGrpAcpt`, the optional JSON field `profile`. + - The invitee (`Commands.hs:2845`, `Subscriber.hs:2697`) includes its group profile, with `groupPresHeader`, when the maximum of the contact connection's `peerChatVRange` is at least `relayWebCapVersion`; the message is encoded with `encodeSignedConnInfo` when a signing is returned by `groupMsgSigning`. + - `XGrpAcpt` with a badge in its profile is signed by `groupMsgSigning` (`Internal.hs:2316-2319`). + - The host (`Subscriber.hs:786`) stores the key, then the profile with `PHChat <$> signedMemberBinding`. + - The host replies with `XGrpMemInfo` and its group profile in place of `XOk` (`Subscriber.hs:791`); the badge is presented when the invitee's version is at least `relayWebCapVersion`, as at `:840-846`. + +**10. Link data** + +- Invitation links (`APIAddContact`, `recreateConn`): the chat generates the root key pair and calls `prepareConnectionLink SCMInvitation`; the badge is presented with the header of the prepared invitation; then `createConnectionForLink` is called. +- Invitation updates (`updatePCCShortLinkData`, `APISetConnectionIncognito`): the header of the stored invitation. +- Address (`APICreateMyAddress`): `linkPresHeader` of the key in the prepared `CSLContact`. +- Address updates (`setMyAddressData`): the key of the stored short link. For an address without a short link, the key is taken from `prepareConnShortLink`, then `setConnShortLink` is called once. +- Receipts: + - `linkDataBadge` (`Internal.hs:2251`): the expected header is a parameter — the header of the invitation read with the link data for an invitation (`Commands.hs:4403-4404`), `linkPresHeader` of the link key for an address (`:4457-4458`). + - `createPreparedContact` (`Commands.hs:2203`): the same headers, from `accLink`; `Nothing` for an address without a short link. + - `updateContactFromLinkData` (`Internal.hs:1637`): the header of the address link is a parameter. +- Shared address card: + - `APIShareMyAddress` (`Commands.hs:1243-1255`): the badge is presented with `linkPresHeader` of `connLink`. + - Receipts (`Subscriber.hs:1910-1916`, `:2217-2221`): the proof in `MCLContact.profile` is kept when accepted under `linkPresHeader` of `connLink` and verified, and removed otherwise. + - The badge from `profile.badge` is shown in `CIChatLinkHeader`, on iOS and in the multiplatform app. + +**11. Tests** — `ChatTests/Profiles.hs` + +- Direct: the badge is shown after a request to an address with and without ratchet keys, after accepting, after joining a one-time link, after a retried join, and after a profile update. +- A proof bound to another chat is ignored, and the stored badge is kept. +- P2p group: the joiner's badge is shown at the host at the request and after `INFO`; an introduced member's badge is shown at introduction; the badge is shown on both sides of an invitation via contact. +- Link data: the badge is shown from an invitation link, an address, an address that gets its first short link, and a shared address card. + +`PHTest` is still sent by released clients and, through `unboundPresHeader`, on a retry of a connection prepared before this change. ## Out of scope diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 153bef02ea..f50a5eef2f 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -168,6 +168,7 @@ library Simplex.Chat.Store.Postgres.Migrations.M20260915_user_badges Simplex.Chat.Store.Postgres.Migrations.M20260918_badge_issue_errors Simplex.Chat.Store.Postgres.Migrations.M20260923_preferences_json + Simplex.Chat.Store.Postgres.Migrations.M20260924_conn_pres_header else exposed-modules: Simplex.Chat.Archive @@ -345,6 +346,7 @@ library Simplex.Chat.Store.SQLite.Migrations.M20260915_user_badges Simplex.Chat.Store.SQLite.Migrations.M20260918_badge_issue_errors Simplex.Chat.Store.SQLite.Migrations.M20260923_preferences_json + Simplex.Chat.Store.SQLite.Migrations.M20260924_conn_pres_header other-modules: Paths_simplex_chat hs-source-dirs: diff --git a/src/Simplex/Chat/Badges.hs b/src/Simplex/Chat/Badges.hs index 74f35bb9b9..c1bb390466 100644 --- a/src/Simplex/Chat/Badges.hs +++ b/src/Simplex/Chat/Badges.hs @@ -47,9 +47,7 @@ module Simplex.Chat.Badges generateBadgeProof, badgeProof, verifyBadge, - verifyBadge_, - unboundProof, - boundProof, + acceptedProof, mkBadgeStatus, BadgeRow, BadgeProofKind (..), @@ -78,7 +76,7 @@ import Data.Text.Encoding (encodeUtf8) import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, nominalDay) import Data.Time.Clock.System (systemToUTCTime, utcToSystemTime) import Simplex.FileTransfer.Description (gb, maxFileSize) -import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..), fromTextField_) +import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..), blobFieldDecoder, fromTextField_) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.BBS import Simplex.Messaging.Crypto.Entitlement (Entitlement (Entitlement), EntitlementCredential (EntitlementCredential), MasterKey (MasterKey), entitlementBBSHeader) @@ -272,7 +270,7 @@ maxSndXFTPFileSize lims now = \case -- presentation, not bound to any context; the 'T' tag marks it so master rejects it. -- PHUnknown is the forward-compat catch-all for tags this version does not interpret. -data ProofPresHeaderTag = PHTestTag | PHChatTag | PHFileInvTag | PHFileDescrTag | PHUnknownTag Char +data ProofPresHeaderTag = PHTestTag | PHChatTag | PHFileInvTag | PHFileDescrTag | PHRequestTag | PHUnknownTag Char instance StrEncoding ProofPresHeaderTag where strEncode = B.singleton . \case @@ -280,6 +278,7 @@ instance StrEncoding ProofPresHeaderTag where PHChatTag -> 'C' PHFileInvTag -> 'F' PHFileDescrTag -> 'D' + PHRequestTag -> 'R' PHUnknownTag c -> c strP = tag <$> A.anyChar where @@ -288,6 +287,7 @@ instance StrEncoding ProofPresHeaderTag where 'C' -> PHChatTag 'F' -> PHFileInvTag 'D' -> PHFileDescrTag + 'R' -> PHRequestTag c -> PHUnknownTag c data ProofPresHeader @@ -295,6 +295,7 @@ data ProofPresHeader | PHChat ByteString | PHFileInv {chatBinding :: ByteString, fileSize :: Int64} | PHFileDescr {chatBinding :: ByteString, fileSize :: Int64, descrHash :: ByteString, fileExpires :: Maybe UTCTime} + | PHRequest ByteString | PHUnknown Char ByteString deriving (Eq, Show) deriving (ToJSON, FromJSON) via (StrJSON "ProofPresHeader" ProofPresHeader) @@ -307,6 +308,7 @@ instance StrEncoding ProofPresHeader where strEncode PHFileInvTag <> smpEncode (chatBinding, fileSize) PHFileDescr {chatBinding, fileSize, descrHash, fileExpires} -> strEncode PHFileDescrTag <> smpEncode (chatBinding, fileSize, descrHash, utcToSystemTime <$> fileExpires) + PHRequest code -> strEncode PHRequestTag <> code PHUnknown c b -> strEncode (PHUnknownTag c) <> b strP = strP >>= \case @@ -318,15 +320,13 @@ instance StrEncoding ProofPresHeader where PHFileDescrTag -> do (chatBinding, fileSize, descrHash, expires_) <- smpP pure PHFileDescr {chatBinding, fileSize, descrHash, fileExpires = systemToUTCTime <$> expires_} + PHRequestTag -> PHRequest <$> A.takeByteString PHUnknownTag c -> PHUnknown c <$> A.takeByteString -unboundProof :: BadgeProof -> Bool -unboundProof BadgeProof {presHeader = BBSPresHeader ph} = case strDecode ph of +acceptedProof :: Maybe ProofPresHeader -> BadgeProof -> Bool +acceptedProof expected_ BadgeProof {presHeader = BBSPresHeader ph} = case strDecode ph of Right (PHTest _) -> True - _ -> False - -boundProof :: Maybe ByteString -> BadgeProof -> Bool -boundProof binding_ BadgeProof {presHeader} = maybe False (\b -> presHeader == BBSPresHeader (strEncode (PHChat b))) binding_ + _ -> maybe False ((ph ==) . strEncode) expected_ -- Payment proof @@ -423,13 +423,12 @@ verifyBadgeWith :: BBSPublicKey -> BadgeProof -> IO Bool verifyBadgeWith pk (BadgeProof _ ph proof badgeInfo) = bbsProofVerify pk proof bbsBadgeHeader ph bbsBadgeDisclosedIndexes bbsBadgeMessageCount (badgeInfoMessages badgeInfo) -verifyBadge_ :: (BadgeProof -> Bool) -> Map Int BBSPublicKey -> Maybe BadgeProof -> IO (Maybe Bool) -verifyBadge_ accepted keys = \case - Just b | accepted b -> verifyBadge keys b - _ -> pure (Just False) - -- DB +instance FromField ProofPresHeader where fromField = blobFieldDecoder strDecode + +instance ToField ProofPresHeader where toField = toField . Binary . strEncode + instance FromField BadgeType where fromField = fromTextField_ textDecode instance ToField BadgeType where toField = toField . textEncode diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 4632fe727e..ffed89cd3d 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -59,7 +59,7 @@ import qualified Data.UUID.V4 as V4 import Simplex.Chat.Library.Subscriber import Crypto.Random (ChaChaDRG) import Simplex.Messaging.Session (SessionVar (..), withGetSessVar') -import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey, BadgeType, LocalBadge (..), badgeServerCredential, mkBadgeStatus, maxSndXFTPFileSize, verifyCredential) +import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey, BadgeType, LocalBadge (..), ProofPresHeader, badgeServerCredential, mkBadgeStatus, maxSndXFTPFileSize, verifyCredential) import qualified Simplex.Chat.Badges.Ledger as L import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeAlertKind (..), BadgeIssueError (..), BadgeIssueFailure (..), BadgeState (..)) import Simplex.Chat.Badges.Code (badgeCodeText, parseBadgeCode) @@ -1244,13 +1244,13 @@ processChatCommand cxt nm = \case UserContactLink {connLinkContact = CCLink _ sl_, addressSettings} <- withFastStore (`getUserAddress` user) case sl_ of Nothing -> throwCmdError "your address has no short link to share" - Just connLink -> do + Just connLink@(CSLContact _ _ _ linkKey) -> do conn <- withFastStore $ \db -> getUserAddressConnection db cxt user ownerSig <- withAgent (`getConnLinkPrivKey` aConnId conn) $>>= \privKey -> mkLinkOwnerSig privKey connLink Nothing <$$> shareChatBinding user toSendRef + profile <- presentUserBadge user Nothing (Just $ linkPresHeader linkKey) $ userProfileDirect user Nothing Nothing True let business = businessAddress addressSettings - profile = userProfileDirect user Nothing Nothing True text = safeDecodeUtf8 $ strEncode connLink pure $ CRChatMsgContent user MCChat {text, chatLink = MCLContact {connLink, profile, business}, ownerSig} APIUserRead userId -> withUserId userId $ \user -> withFastStore' (`setUserChatsRead` user) >> ok user @@ -2118,11 +2118,12 @@ processChatCommand cxt nm = \case -- [incognito] generate profile for connection incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing subMode <- chatReadVar subscriptionMode - -- TODO [badges] bind link and badge to handshake context - linkProfile <- presentUserBadge user incognitoProfile Nothing $ userProfileDirect user incognitoProfile Nothing True + rootKey <- atomically . C.generateKeyPair =<< asks random + (preparedLink@(CCLink preparedReq _), preparedParams) <- withAgent $ \a -> prepareConnectionLink a (aUserId user) SCMInvitation rootKey Nothing False Nothing IKUsePQ False Nothing + linkProfile <- presentUserBadge user incognitoProfile (Just $ invitationPresHeader preparedReq) $ userProfileDirect user incognitoProfile Nothing True let userData = contactShortLinkData linkProfile {contactDomain = Nothing} Nothing userLinkData = UserInvLinkData userData - (connId, ccLink) <- withAgent $ \a -> createConnection a nm (aUserId user) True False SCMInvitation (Just userLinkData) Nothing IKUsePQ True subMode + (connId, ccLink) <- withAgent $ \a -> createConnectionForLink a nm (aUserId user) True preparedLink preparedParams userLinkData subMode ccLink' <- shortenCreatedLink ccLink -- TODO PQ pass minVersion from the current range conn <- withFastStore' $ \db -> createDirectConnection db user connId ccLink' Nothing ConnNew incognitoProfile subMode initialChatVersion PQSupportOn @@ -2131,7 +2132,7 @@ processChatCommand cxt nm = \case processChatCommand cxt nm $ APIAddContact userId incognito APISetConnectionIncognito connId incognito -> withUser $ \user@User {userId} -> do conn <- withFastStore $ \db -> getPendingContactConnection db userId connId - let PendingContactConnection {pccConnStatus, customUserProfileId} = conn + let PendingContactConnection {pccConnStatus, customUserProfileId, connLinkInv} = conn case (pccConnStatus, customUserProfileId, incognito) of (ConnNew, Nothing, True) -> do incognitoProfile <- liftIO generateRandomProfile @@ -2141,7 +2142,7 @@ processChatCommand cxt nm = \case updatePCCIncognito db user conn (Just pId) sLnk pure $ CRConnectionIncognitoUpdated user conn' (Just incognitoProfile) (ConnNew, Just pId, False) -> do - sLnk <- updatePCCShortLinkData conn =<< presentUserBadge user Nothing Nothing (userProfileDirect user Nothing Nothing True) + sLnk <- updatePCCShortLinkData conn =<< presentUserBadge user Nothing (invitationPresHeader . connFullLink <$> connLinkInv) (userProfileDirect user Nothing Nothing True) conn' <- withFastStore' $ \db -> do deletePCCIncognitoProfile db user pId updatePCCIncognito db user conn Nothing sLnk @@ -2159,12 +2160,14 @@ processChatCommand cxt nm = \case where recreateConn user conn@PendingContactConnection {customUserProfileId, connLinkInv} newUser = do subMode <- chatReadVar subscriptionMode - let short = isJust $ connShortLink' =<< connLinkInv - userLinkData_ <- - if short - then Just . UserInvLinkData . (`contactShortLinkData` Nothing) <$> presentUserBadge newUser Nothing Nothing (userProfileDirect newUser Nothing Nothing True) - else pure Nothing - (agConnId, ccLink) <- withAgent $ \a -> createConnection a nm (aUserId newUser) True False SCMInvitation userLinkData_ Nothing IKPQOn True subMode + (agConnId, ccLink) <- + if isJust $ connShortLink' =<< connLinkInv + then do + rootKey <- atomically . C.generateKeyPair =<< asks random + (preparedLink@(CCLink preparedReq _), preparedParams) <- withAgent $ \a -> prepareConnectionLink a (aUserId newUser) SCMInvitation rootKey Nothing False Nothing IKPQOn False Nothing + userLinkData <- UserInvLinkData . (`contactShortLinkData` Nothing) <$> presentUserBadge newUser Nothing (Just $ invitationPresHeader preparedReq) (userProfileDirect newUser Nothing Nothing True) + withAgent $ \a -> createConnectionForLink a nm (aUserId newUser) True preparedLink preparedParams userLinkData subMode + else withAgent $ \a -> createConnection a nm (aUserId newUser) True False SCMInvitation Nothing Nothing IKPQOn True subMode ccLink' <- shortenCreatedLink ccLink conn' <- withFastStore' $ \db -> do deleteConnectionRecord db user connId @@ -2199,8 +2202,11 @@ processChatCommand cxt nm = \case Just (AChatItem SCTGroup dir _ ci) -> Chat cInfo [CChatItem dir ci] emptyChatStats {unreadCount = 1, minUnreadItemId = chatItemId' ci} _ -> Chat cInfo [] emptyChatStats pure $ CRNewPreparedChat user $ AChat SCTGroup chat - ACCL _ (CCLink cReq _) -> do - ct <- withStore $ \db -> createPreparedContact db cxt user profile accLink welcomeSharedMsgId (True <$ verifiedDomain) + ACCL cMode (CCLink cReq sLnk) -> do + let presHeader_ = case cMode of + SCMInvitation -> Just $ invitationPresHeader cReq + SCMContact -> (\(CSLContact _ _ _ linkKey) -> linkPresHeader linkKey) <$> sLnk + ct <- withStore $ \db -> createPreparedContact db cxt user presHeader_ profile accLink welcomeSharedMsgId (True <$ verifiedDomain) void $ createChatItem user (CDDirectSnd ct) False CIChatBanner Nothing Nothing (Just epochStart) let cd = CDDirectRcv ct createItem sharedMsgId content = createChatItem user cd False content sharedMsgId Nothing Nothing @@ -2462,15 +2468,15 @@ processChatCommand cxt nm = \case Just True -> (IKUsePQ, True) Just False -> (IKPQOn, True) Nothing -> (IKPQOn, False) - (ccLink, preparedParams) <- withAgent $ \a -> prepareConnectionLink a (aUserId user) rootKey entityId True Nothing pqInitKeys useDR server_ + (ccLink, preparedParams@PreparedLinkParams {plpLinkKey}) <- withAgent $ \a -> prepareConnectionLink a (aUserId user) SCMContact rootKey (Just entityId) True Nothing pqInitKeys useDR server_ ccLink' <- shortenCreatedLink ccLink -- TODO [relays] relay: add identity, key to link data? userData <- if isTrue userChatRelay then pure $ relayShortLinkData (userProfileDirect user Nothing Nothing True) - else (`contactShortLinkData` Nothing) <$> presentUserBadge user Nothing Nothing (userProfileDirect user Nothing Nothing True) + else (`contactShortLinkData` Nothing) <$> presentUserBadge user Nothing (Just $ linkPresHeader plpLinkKey) (userProfileDirect user Nothing Nothing True) let userLinkData = UserContactLinkData UserContactData {direct = True, owners = [], relays = [], userData, ratchetKeys = Nothing} - connId <- withAgent $ \a -> createConnectionForLink a nm (aUserId user) True ccLink preparedParams userLinkData subMode + (connId, _) <- withAgent $ \a -> createConnectionForLink a nm (aUserId user) True ccLink preparedParams userLinkData subMode let ccLink'' = if isTrue userChatRelay then setShortLinkType CCTRelay ccLink' else ccLink' withFastStore $ \db -> createUserContactLink db user connId ccLink'' subMode rootPrivKey pure $ CRUserContactLinkCreated user ccLink'' @@ -2739,7 +2745,7 @@ processChatCommand cxt nm = \case let entityId = C.sha256Hash $ C.pubKeyBytes rootPubKey crClientData = encodeJSON $ CRDataGroup groupLinkId -- prepare link with entityId as linkEntityId (no server request) - (ccLink, preparedParams) <- withAgent $ \a -> prepareConnectionLink a (aUserId user) rootKey entityId True (Just crClientData) IKPQOff False Nothing + (ccLink, preparedParams) <- withAgent $ \a -> prepareConnectionLink a (aUserId user) SCMContact rootKey (Just entityId) True (Just crClientData) IKPQOff False Nothing ccLink' <- setShortLinkType CCTChannel <$> shortenCreatedLink ccLink sLnk <- case connShortLink' ccLink' of Just sl -> pure sl @@ -2752,7 +2758,7 @@ processChatCommand cxt nm = \case userData = encodeShortLinkData $ GroupShortLinkData {groupProfile = groupProfile', publicGroupData = Just (PublicGroupData 1)} userLinkData = UserContactLinkData UserContactData {direct = False, owners = [ownerAuth], relays = [], userData, ratchetKeys = Nothing} -- create connection with prepared link (single network call) - connId <- withAgent $ \a -> createConnectionForLink a nm (aUserId user) True ccLink preparedParams userLinkData subMode + (connId, _) <- withAgent $ \a -> createConnectionForLink a nm (aUserId user) True ccLink preparedParams userLinkData subMode let groupKeys = GKPublicGroup {groupRootKey = GRKPrivate rootPrivKey, memberPrivKey} setupLink gInfo = do -- TODO [relays] starting role should be communicated in protocol from owner to relays @@ -2842,7 +2848,13 @@ processChatCommand cxt nm = \case case activeConn of Just Connection {peerChatVRange} -> do subMode <- chatReadVar subscriptionMode - dm <- encodeConnInfo $ XGrpAcpt membershipMemId (Just $ groupMemberKey gks) + let incognitoProfile = incognitoMembershipProfile g + profile_ <- + if maxVersion peerChatVRange >= relayWebCapVersion + then Just <$> presentUserBadge user incognitoProfile (groupPresHeader g) (userProfileInGroup user g $ fromLocalProfile <$> incognitoProfile) + else pure Nothing + let msg = XGrpAcpt membershipMemId (Just $ groupMemberKey gks) profile_ + dm <- maybe (encodeConnInfo msg) (`encodeSignedConnInfo` msg) (groupMsgSigning False (GIK g gks) msg) agentConnId <- case memberConn fromMember of Nothing -> do (agentConnId, _) <- withAgent $ \a -> prepareConnectionToJoin a (aUserId user) True connRequest PQSupportOff @@ -3392,21 +3404,21 @@ processChatCommand cxt nm = \case -- so incognito profile can be attached to it and be visible in UI before accepting Nothing -> joinNewConn subMode Just conn@Connection {connStatus} -> case connStatus of - ConnPrepared -> joinPreparedConn subMode conn + ConnPrepared -> joinPreparedConn subMode conn =<< maybe unboundPresHeader pure =<< connPresHeader conn _ -> throwChatError $ CEException "connection already started (past prepared status)" where joinNewConn subMode = do -- possible improvement: use agent connRequestAgentVersion to determine pqSupport here; -- for joinPreparedConn below - same + encodeConnInfoPQ; -- same for auto-accept on xGrpDirectInv - (acId, _) <- withAgent $ \a -> prepareConnectionToJoin a (aUserId user) True cReq PQSupportOff + (acId, binding) <- withAgent $ \a -> prepareConnectionToJoin a (aUserId user) True cReq PQSupportOff conn <- withStore $ \db -> do connId <- liftIO $ createMemberContactConn db user acId Nothing gInfo mConn ConnPrepared contactId subMode getConnectionById db cxt user connId - joinPreparedConn subMode conn - joinPreparedConn subMode conn = do + joinPreparedConn subMode conn $ directPresHeader binding + joinPreparedConn subMode conn presHeader = do -- [incognito] send membership incognito profile - p <- presentUserBadge user (incognitoMembershipProfile gInfo) Nothing $ userProfileDirect user (fromLocalProfile <$> incognitoMembershipProfile gInfo) Nothing True + p <- presentUserBadge user (incognitoMembershipProfile gInfo) (Just presHeader) $ userProfileDirect user (fromLocalProfile <$> incognitoMembershipProfile gInfo) Nothing True dm <- encodeConnInfo $ XInfo p Nothing sqSecured <- withAgent $ \a -> joinConnection a nm (aUserId user) (aConnId conn) True cReq dm PQSupportOff subMode let newStatus = if sqSecured then ConnSndReady else ConnJoined @@ -3811,7 +3823,8 @@ processChatCommand cxt nm = \case | connStatus == ConnNew && contactConnInitiated -> joinNewConn chatV -- own connection link | connStatus == ConnPrepared -> do -- retrying join after error localIncognitoProfile <- forM customUserProfileId $ \pId -> withFastStore $ \db -> getProfileById db userId pId - joinPreparedConn conn (fromLocalProfile <$> localIncognitoProfile) + presHeader <- maybe unboundPresHeader pure =<< connPresHeader conn + joinPreparedConn conn (fromLocalProfile <$> localIncognitoProfile) presHeader Just ent -> throwCmdError $ "connection is not RcvDirectMsgConnection: " <> show (connEntityInfo ent) where -- all supported versions support PQ encryption @@ -3819,12 +3832,12 @@ processChatCommand cxt nm = \case joinNewConn chatV = do -- [incognito] generate profile to send incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing - (connId, _) <- withAgent $ \a -> prepareConnectionToJoin a (aUserId user) True cReq pqSup' + (connId, binding) <- withAgent $ \a -> prepareConnectionToJoin a (aUserId user) True cReq pqSup' let ccLink = CCLink cReq $ serverShortLink <$> sLnk_ conn <- withFastStore' $ \db -> createDirectConnection' db userId connId ccLink contactId_ ConnPrepared incognitoProfile subMode chatV pqSup' - joinPreparedConn conn incognitoProfile - joinPreparedConn conn incognitoProfile = do - profileToSend <- presentUserBadge user incognitoProfile Nothing $ userProfileDirect user incognitoProfile Nothing True + joinPreparedConn conn incognitoProfile $ directPresHeader binding + joinPreparedConn conn incognitoProfile presHeader = do + profileToSend <- presentUserBadge user incognitoProfile (Just presHeader) $ userProfileDirect user incognitoProfile Nothing True dm <- encodeConnInfoPQ pqSup' $ XInfo profileToSend Nothing sqSecured <- withAgent $ \a -> joinConnection a nm (aUserId user) (aConnId conn) True cReq dm pqSup' subMode let newStatus = if sqSecured then ConnSndReady else ConnJoined @@ -3874,28 +3887,33 @@ processChatCommand cxt nm = \case relayMemberId_ = case preparedEntity_ of Just (PCEGroup (GIK gInfo _) m) | useRelays' gInfo -> Just (memberId' m) _ -> Nothing + joinPresHeader gInfo_ reqHeader = case gInfo_ of + Just (Just (GIK gInfo _)) | useRelays' gInfo -> groupPresHeader gInfo + _ -> Just reqHeader joinPreparedConn' xContactId_ conn@Connection {connId, customUserProfileId} gInfo_ = do when (incognito /= isJust customUserProfileId) $ throwCmdError "incognito mode is different from prepared connection" -- TODO [relays] member: refactor joinContact and up avoiding parallel ifs, xContactId is not used xContactId <- mkXContactId xContactId_ - (cReq', localIncognitoProfile) <- withFastStore $ \db -> (,) <$> getConnReqContact db connId <*> forM customUserProfileId (getProfileById db userId) + ((cReq', reqHeader_), localIncognitoProfile) <- withFastStore $ \db -> (,) <$> getConnReqContact db connId <*> forM customUserProfileId (getProfileById db userId) + reqHeader <- maybe unboundPresHeader pure reqHeader_ let incognitoProfile = fromLocalProfile <$> localIncognitoProfile - conn' <- joinContact user conn cReq' incognitoProfile xContactId welcomeSharedMsgId msg_ gInfo_ relayMemberId_ PQSupportOn + conn' <- joinContact user conn cReq' incognitoProfile (joinPresHeader gInfo_ reqHeader) xContactId welcomeSharedMsgId msg_ gInfo_ relayMemberId_ PQSupportOn pure $ CVRSentInvitation conn' incognitoProfile connect' groupLinkId xContactId_ gInfo_ = do let inGroup = isJust groupLinkId pqSup = if inGroup then PQSupportOff else PQSupportOn - (connId, chatV) <- prepareContact user cReq pqSup + (connId, chatV, binding) <- prepareContact user cReq pqSup xContactId <- mkXContactId xContactId_ -- [incognito] generate profile to send, or use membership profile for relay groups incognitoProfile_ <- case gInfo_ of Just (Just (GIK gInfo _)) | useRelays' gInfo -> pure $ ExistingIncognito <$> incognitoMembershipProfile gInfo _ -> if incognito then Just . NewIncognito <$> liftIO generateRandomProfile else pure Nothing let incognitoProfile = fromIncognitoProfile <$> incognitoProfile_ + reqHeader = directPresHeader binding subMode <- chatReadVar subscriptionMode let sLnk' = serverShortLink <$> sLnk - conn <- withFastStore' $ \db -> createConnReqConnection db userId connId preparedEntity_ cReq cReqHash1 sLnk' xContactId incognitoProfile_ groupLinkId subMode chatV pqSup - conn' <- joinContact user conn cReq incognitoProfile xContactId welcomeSharedMsgId msg_ gInfo_ relayMemberId_ pqSup + conn <- withFastStore' $ \db -> createConnReqConnection db userId connId preparedEntity_ cReq reqHeader cReqHash1 sLnk' xContactId incognitoProfile_ groupLinkId subMode chatV pqSup + conn' <- joinContact user conn cReq incognitoProfile (joinPresHeader gInfo_ reqHeader) xContactId welcomeSharedMsgId msg_ gInfo_ relayMemberId_ pqSup pure $ CVRSentInvitation conn' incognitoProfile connectContactViaAddress :: User -> IncognitoEnabled -> Contact -> CreatedLinkContact -> CM ChatResponse connectContactViaAddress user@User {userId} incognito ct@Contact {contactId, activeConn} (CCLink cReq shortLink) = @@ -3903,23 +3921,25 @@ processChatCommand cxt nm = \case case activeConn of Nothing -> do let pqSup = PQSupportOn - (connId, chatV) <- prepareContact user cReq pqSup + (connId, chatV, binding) <- prepareContact user cReq pqSup newXContactId <- XContactId <$> drgRandomBytes 16 -- [incognito] generate profile to send incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing subMode <- chatReadVar subscriptionMode let cReqHash = contactCReqHash cReq - conn <- withFastStore' $ \db -> createConnReqConnection db userId connId (Just $ PCEContact ct) cReq cReqHash shortLink newXContactId (NewIncognito <$> incognitoProfile) Nothing subMode chatV pqSup - void $ joinContact user conn cReq incognitoProfile newXContactId Nothing Nothing Nothing Nothing pqSup + reqHeader = directPresHeader binding + conn <- withFastStore' $ \db -> createConnReqConnection db userId connId (Just $ PCEContact ct) cReq reqHeader cReqHash shortLink newXContactId (NewIncognito <$> incognitoProfile) Nothing subMode chatV pqSup + void $ joinContact user conn cReq incognitoProfile (Just reqHeader) newXContactId Nothing Nothing Nothing Nothing pqSup ct' <- withStore $ \db -> getContact db cxt user contactId pure $ CRSentInvitationToContact user ct' incognitoProfile Just conn@Connection {connId, connStatus, xContactId = xContactId_, customUserProfileId} -> case connStatus of ConnPrepared -> do when (incognito /= isJust customUserProfileId) $ throwCmdError "incognito mode is different from prepared connection" xContactId <- mkXContactId xContactId_ - (cReq', localIncognitoProfile) <- withFastStore $ \db -> (,) <$> getConnReqContact db connId <*> forM customUserProfileId (getProfileById db userId) + ((cReq', reqHeader_), localIncognitoProfile) <- withFastStore $ \db -> (,) <$> getConnReqContact db connId <*> forM customUserProfileId (getProfileById db userId) + reqHeader <- maybe unboundPresHeader pure reqHeader_ let incognitoProfile = fromLocalProfile <$> localIncognitoProfile - void $ joinContact user conn cReq' incognitoProfile xContactId Nothing Nothing Nothing Nothing PQSupportOn + void $ joinContact user conn cReq' incognitoProfile (Just reqHeader) xContactId Nothing Nothing Nothing Nothing PQSupportOn ct' <- withStore $ \db -> getContact db cxt user contactId pure $ CRSentInvitationToContact user ct' incognitoProfile _ -> throwCmdError "contact already has connection" @@ -3960,26 +3980,22 @@ processChatCommand cxt nm = \case deleteMemberConnection m deleteOrUpdateMemberRecord user gInfo m _ -> pure () - prepareContact :: User -> ConnReqContact -> PQSupport -> CM (ConnId, VersionChat) + prepareContact :: User -> ConnReqContact -> PQSupport -> CM (ConnId, VersionChat, ContactRequestBinding) prepareContact user cReq pqSup = do lift (withAgent' (`connRequestAgentVersion` cReq)) >>= \case Nothing -> throwChatError CEInvalidConnReq Just _ -> do let chatV = initialChatVersion - (connId, _) <- withAgent $ \a -> prepareConnectionToJoin a (aUserId user) True cReq pqSup - pure (connId, chatV) + (connId, binding) <- withAgent $ \a -> prepareConnectionToJoin a (aUserId user) True cReq pqSup + pure (connId, chatV, binding) mkXContactId :: Maybe XContactId -> CM XContactId mkXContactId = maybe (XContactId <$> drgRandomBytes 16) pure - joinContact :: User -> Connection -> ConnReqContact -> Maybe Profile -> XContactId -> Maybe SharedMsgId -> Maybe (SharedMsgId, MsgContent) -> Maybe (Maybe GroupInfoKeys) -> Maybe MemberId -> PQSupport -> CM Connection - joinContact user conn cReq incognitoProfile xContactId welcomeSharedMsgId msg_ gInfo_ relayMemberId_ pqSup = do + joinContact :: User -> Connection -> ConnReqContact -> Maybe Profile -> Maybe ProofPresHeader -> XContactId -> Maybe SharedMsgId -> Maybe (SharedMsgId, MsgContent) -> Maybe (Maybe GroupInfoKeys) -> Maybe MemberId -> PQSupport -> CM Connection + joinContact user conn cReq incognitoProfile presHeader_ xContactId welcomeSharedMsgId msg_ gInfo_ relayMemberId_ pqSup = do -- gInfo_ is Maybe (Maybe GroupInfo), where Just Nothing means "some unknown group", e.g. when joining via link without profile - profileToSend <- case gInfo_ of - Just gInfo_' -> do - let p = userProfileInGroup' user ((\(GIK g _) -> g) <$> gInfo_') incognitoProfile - case gInfo_' of - Just (GIK g _) | useRelays' g -> presentUserBadge user incognitoProfile (Just g) p - _ -> pure p - Nothing -> presentUserBadge user incognitoProfile Nothing $ userProfileDirect user incognitoProfile Nothing True + profileToSend <- presentUserBadge user incognitoProfile presHeader_ $ case gInfo_ of + Just gInfo_' -> userProfileInGroup' user ((\(GIK g _) -> g) <$> gInfo_') incognitoProfile + Nothing -> userProfileDirect user incognitoProfile Nothing True dm <- case gInfo_ of Just (Just gInfo@(GIK g gks)) | useRelays' g -> case relayMemberId_ of @@ -4036,7 +4052,8 @@ processChatCommand cxt nm = \case case changedCts_ of Nothing -> pure $ UserProfileUpdateSummary 0 0 [] Just changedCts -> do - idsEvts <- mapM ctSndEvent changedCts + presHeaders <- connsPresHeaders $ map (\ChangedProfileContact {conn} -> conn) $ L.toList changedCts + idsEvts <- mapM (ctSndEvent presHeaders) changedCts msgReqs_ <- lift $ L.zipWith ctMsgReq changedCts <$> createSndMessages idsEvts (errs, cts) <- partitionEithers . L.toList . L.zipWith (second . const) changedCts <$> deliverMessagesB msgReqs_ unless (null errs) $ toView $ CEvtChatErrors errs @@ -4061,18 +4078,20 @@ processChatCommand cxt nm = \case ct' = updateMergedPreferences user' ct mergedProfile' = userProfileDirect user' Nothing (Just ct') False -- non-incognito (filtered above), so the user's badge is presented; a profile update keeps the badge instead of clearing it - ctSndEvent :: ChangedProfileContact -> CM (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent 'Json) - ctSndEvent ChangedProfileContact {mergedProfile', conn = Connection {connId}} = do - p'' <- presentUserBadge user' Nothing Nothing mergedProfile' + ctSndEvent :: Map ConnId ProofPresHeader -> ChangedProfileContact -> CM (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent 'Json) + ctSndEvent presHeaders ChangedProfileContact {mergedProfile', conn = conn@Connection {connId}} = do + presHeader <- maybe unboundPresHeader pure $ M.lookup (aConnId conn) presHeaders + p'' <- presentUserBadge user' Nothing (Just presHeader) mergedProfile' pure (ConnectionId connId, Nothing, XInfo p'' Nothing) ctMsgReq :: ChangedProfileContact -> Either ChatError SndMessage -> Either ChatError ChatMsgReq ctMsgReq ChangedProfileContact {conn} = fmap $ \SndMessage {msgId, msgBody} -> (conn, MsgFlags {notification = hasNotification XInfo_}, (vrValue msgBody, [msgId])) setMyAddressData :: Bool -> Maybe InitialKeys -> User -> UserContactLink -> CM UserContactLink - setMyAddressData rotateKeys pqInitKeys user@User {userChatRelay} ucl@UserContactLink {userContactLinkId, connLinkContact = CCLink connFullLink _, addressSettings} = do + setMyAddressData rotateKeys pqInitKeys user@User {userChatRelay} ucl@UserContactLink {userContactLinkId, connLinkContact = CCLink connFullLink sLnk_, addressSettings} = do conn <- withFastStore $ \db -> getUserAddressConnection db cxt user - shortLinkProfile <- presentUserBadge user Nothing Nothing (userProfileDirect user Nothing Nothing True) + linkKey <- (\(CSLContact _ _ _ k) -> k) <$> maybe (withAgent $ \a -> prepareConnShortLink a (aConnId conn) Nothing) pure sLnk_ + shortLinkProfile <- presentUserBadge user Nothing (Just $ linkPresHeader linkKey) (userProfileDirect user Nothing Nothing True) -- TODO [short links] do not save address to server if data did not change, spinners, error handling let userData | isTrue userChatRelay = relayShortLinkData shortLinkProfile @@ -4086,7 +4105,7 @@ processChatCommand cxt nm = \case pure ucl' updateContactPrefs :: User -> Contact -> Preferences -> CM ChatResponse updateContactPrefs _ ct@Contact {activeConn = Nothing} _ = throwChatError $ CEContactNotActive ct - updateContactPrefs user@User {userId} ct@Contact {activeConn = Just Connection {customUserProfileId}, userPreferences = contactUserPrefs} contactUserPrefs' + updateContactPrefs user@User {userId} ct@Contact {activeConn = Just conn@Connection {customUserProfileId}, userPreferences = contactUserPrefs} contactUserPrefs' | contactUserPrefs == contactUserPrefs' = pure $ CRContactPrefsUpdated user ct ct | otherwise = do assertDirectAllowed user MDSnd ct XInfo_ @@ -4096,7 +4115,8 @@ processChatCommand cxt nm = \case mergedProfile' = userProfileDirect user (fromLocalProfile <$> incognitoProfile) (Just ct') False when (mergedProfile' /= mergedProfile) $ withContactLock "updateContactPrefs" (contactId' ct) $ do - p <- presentUserBadge user incognitoProfile Nothing mergedProfile' + presHeader <- maybe unboundPresHeader pure =<< connPresHeader conn + p <- presentUserBadge user incognitoProfile (Just presHeader) mergedProfile' void (sendDirectContactMessage user ct' $ XInfo p Nothing) `catchAllErrors` eToView lift . when (directOrUsed ct') $ createSndFeatureItems user ct ct' pure $ CRContactPrefsUpdated user ct ct' @@ -4316,7 +4336,7 @@ processChatCommand cxt nm = \case pure (relayMember, conn, groupRelay) let GroupMember {memberRole = userRole, memberId = userMemberId} = membership GroupMember {memberId = relayMemberId} = relayMember - membershipProfile <- presentUserBadge user (incognitoMembershipProfile gInfo) (Just gInfo) $ redactedMemberProfile gInfo membership $ fromLocalProfile $ memberProfile membership + membershipProfile <- presentUserBadge user (incognitoMembershipProfile gInfo) (groupPresHeader gInfo) $ redactedMemberProfile gInfo membership $ fromLocalProfile $ memberProfile membership let relayInv = GroupRelayInvitation { fromMember = MemberIdRole userMemberId userRole, fromMemberProfile = membershipProfile, @@ -4401,7 +4421,7 @@ processChatCommand cxt nm = \case Just (createdLink, p) -> pure (createdLink, Nothing, Nothing, p) Nothing -> do (FixedLinkData {rootKey}, cData, cReq) <- getShortLinkConnReq nm user l' - contactSLinkData_ <- mapM linkDataBadge =<< liftIO (decodeLinkUserData cData) + contactSLinkData_ <- mapM (linkDataBadge $ invitationPresHeader cReq) =<< liftIO (decodeLinkUserData cData) let ov = verifyLinkOwner rootKey [] l sig_ invitationReqAndPlan cReq (Just l') contactSLinkData_ ov where @@ -4455,12 +4475,13 @@ processChatCommand cxt nm = \case when (resolveMode == PRMNever) $ throwChatError CENotResolvedLocally l' <- resolveSLink (FixedLinkData {rootKey}, cData, cReq) <- getShortLinkConnReq nm user l' - contactSLinkData_ <- mapM linkDataBadge =<< liftIO (decodeLinkUserData cData) + let presHeader = linkPresHeader $ (\(CSLContact _ _ _ linkKey) -> linkKey) l' + contactSLinkData_ <- mapM (linkDataBadge presHeader) =<< liftIO (decodeLinkUserData cData) let linkProfile_ = (\ContactShortLinkData {profile} -> profile) <$> contactSLinkData_ linkDomain_ = linkProfile_ >>= \Profile {contactDomain} -> claimDomain <$> contactDomain planDomain = case nl of CTName ni -> Just (nameDomain ni); _ -> Nothing refreshContact ct' = case (planDomain, linkProfile_) of - (Just _, Just p) -> updateContactFromLinkData user ct' p + (Just _, Just p) -> updateContactFromLinkData user ct' presHeader p _ -> pure ct' forM_ planDomain $ \nameDomain -> unless (linkDomain_ == Just nameDomain) $ throwChatError $ CESimplexDomainNotReady nameDomain SDEUnknownDomain @@ -5207,12 +5228,14 @@ presentUserBadgeToContacts user'@User {userId, profile = LocalProfile {localBadg lift $ withAgent' $ \a -> setUserEntitlement a (aUserId user') (badgeServerCredential localBadge) cxt <- chatStoreCxt contacts <- withFastStore' $ \db -> getUserContacts db cxt user' + presHeaders <- connsPresHeaders [conn | Right conn <- map contactSendConn_ contacts, not (connIncognito conn)] withChatLock "presentUserBadge" $ forM_ contacts $ \ct -> case contactSendConn_ ct of Right conn | not (connIncognito conn) -> do let ct' = updateMergedPreferences user' ct - p <- presentUserBadge user' Nothing Nothing $ userProfileDirect user' Nothing (Just ct') False + presHeader <- maybe unboundPresHeader pure $ M.lookup (aConnId conn) presHeaders + p <- presentUserBadge user' Nothing (Just presHeader) $ userProfileDirect user' Nothing (Just ct') False void (sendDirectContactMessage user' ct' (XInfo p Nothing)) `catchAllErrors` eToView _ -> pure () diff --git a/src/Simplex/Chat/Library/Internal.hs b/src/Simplex/Chat/Library/Internal.hs index 796ec0ef93..367d131246 100644 --- a/src/Simplex/Chat/Library/Internal.hs +++ b/src/Simplex/Chat/Library/Internal.hs @@ -28,7 +28,7 @@ import Control.Monad.IO.Unlift import Control.Monad.Reader import Crypto.Random (ChaChaDRG) import qualified Data.Aeson as J -import Data.Bifunctor (first) +import Data.Bifunctor (first, second) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB @@ -53,7 +53,7 @@ import Data.Text.Encoding (encodeUtf8) import Data.Time (addUTCTime) import Data.Time.Calendar (fromGregorian) import Data.Time.Clock (UTCTime (..), diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds, secondsToDiffTime) -import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), ProofPresHeader (..), BadgeProof (..), BadgeProofKind (..), BadgeStatus (..), FileSizeLimits (..), LocalBadge (..), badgeSndGraceInterval, generateBadgeProof, localBadgeStatus, maxXFTPFileSize, mkBadgeStatus, unboundProof, verifyBadge, verifyBadge_) +import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), ProofPresHeader (..), BadgeProof (..), BadgeProofKind (..), BadgeStatus (..), FileSizeLimits (..), LocalBadge (..), acceptedProof, badgeSndGraceInterval, generateBadgeProof, localBadgeStatus, maxXFTPFileSize, mkBadgeStatus, verifyBadge) import Simplex.Chat.Names (SimplexDomainClaim (..), claimDomain) import Simplex.Chat.Call import Simplex.Chat.Controller @@ -974,28 +974,29 @@ acceptContactRequest nm user@User {userId} UserContactRequest {agentInvitationId pqSup' = pqSup `CR.pqSupportAnd` pqSupport cxt <- chatStoreCxt let chatV = vr cxt `peerConnChatVersion` cReqChatVRange - (ct, conn, incognitoProfile) <- case contactId_ of + (ct, conn, incognitoProfile, presHeader) <- case contactId_ of Nothing -> do incognitoProfile <- if incognito then Just . NewIncognito <$> liftIO generateRandomProfile else pure Nothing - (connId, _) <- withAgent $ \a -> prepareConnectionToAccept a (aUserId user) True invId pqSup' + (connId, binding) <- withAgent $ \a -> prepareConnectionToAccept a (aUserId user) True invId pqSup' (ct, conn) <- withStore' $ \db -> createContactFromRequest db user userContactLinkId_ connId chatV cReqChatVRange cName profileId cp xContactId incognitoProfile subMode pqSup' False - pure (ct, conn, incognitoProfile) + pure (ct, conn, incognitoProfile, directPresHeader binding) Just contactId -> do ct <- withFastStore $ \db -> getContact db cxt user contactId case contactConn ct of Nothing -> do incognitoProfile <- if incognito then Just . NewIncognito <$> liftIO generateRandomProfile else pure Nothing - (connId, _) <- withAgent $ \a -> prepareConnectionToAccept a (aUserId user) True invId pqSup' + (connId, binding) <- withAgent $ \a -> prepareConnectionToAccept a (aUserId user) True invId pqSup' currentTs <- liftIO getCurrentTime conn <- withStore' $ \db -> do forM_ xContactId $ \xcId -> setContactAcceptedXContactId db ct xcId createAcceptedContactConn db user userContactLinkId_ contactId connId chatV cReqChatVRange pqSup' incognitoProfile subMode currentTs - pure (ct {activeConn = Just conn} :: Contact, conn, incognitoProfile) + pure (ct {activeConn = Just conn} :: Contact, conn, incognitoProfile, directPresHeader binding) Just conn@Connection {customUserProfileId} -> do incognitoProfile <- forM customUserProfileId $ \pId -> withFastStore $ \db -> getProfileById db userId pId - pure (ct, conn, ExistingIncognito <$> incognitoProfile) - profileToSend <- presentUserBadge user incognitoProfile Nothing $ userProfileDirect user (fromIncognitoProfile <$> incognitoProfile) (Just ct) True + presHeader <- maybe unboundPresHeader pure =<< connPresHeader conn + pure (ct, conn, ExistingIncognito <$> incognitoProfile, presHeader) + profileToSend <- presentUserBadge user incognitoProfile (Just presHeader) $ userProfileDirect user (fromIncognitoProfile <$> incognitoProfile) (Just ct) True dm <- encodeConnInfoPQ pqSup' $ XInfo profileToSend Nothing (ct,conn,) <$> withAgent (\a -> acceptContact a nm (aUserId user) (aConnId conn) True invId dm pqSup' subMode) @@ -1007,10 +1008,10 @@ acceptContactRequestAsync UserContactRequest {agentInvitationId = AgentInvId cReqInvId, cReqChatVRange, xContactId, pqSupport = cReqPQSup} incognitoProfile = do subMode <- chatReadVar subscriptionMode - profileToSend <- presentUserBadge user incognitoProfile Nothing $ userProfileDirect user (fromIncognitoProfile <$> incognitoProfile) (Just ct) True cxt <- chatStoreCxt let chatV = vr cxt `peerConnChatVersion` cReqChatVRange - (cmdId, acId) <- prepareAgentAccept user True cReqInvId cReqPQSup + ((cmdId, acId), binding) <- prepareAgentAccept user True cReqInvId cReqPQSup + profileToSend <- presentUserBadge user incognitoProfile (Just $ directPresHeader binding) $ userProfileDirect user (fromIncognitoProfile <$> incognitoProfile) (Just ct) True currentTs <- liftIO getCurrentTime ct' <- withStore $ \db -> do forM_ xContactId $ \xcId -> liftIO $ setContactAcceptedXContactId db ct xcId @@ -1020,7 +1021,7 @@ acceptContactRequestAsync agentAcceptContactAsync cmdId acId True cReqInvId (XInfo profileToSend Nothing) cReqPQSup subMode pure ct' -acceptGroupJoinRequestAsync :: User -> Int64 -> GroupInfoKeys -> InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> Maybe MemberId -> Maybe SharedMsgId -> GroupAcceptance -> GroupMemberRole -> Maybe IncognitoProfile -> Maybe MemberKey -> Maybe GroupMember -> CM GroupMember +acceptGroupJoinRequestAsync :: User -> Int64 -> GroupInfoKeys -> InvitationId -> VersionRangeChat -> Profile -> Maybe ProofPresHeader -> Maybe XContactId -> Maybe MemberId -> Maybe SharedMsgId -> GroupAcceptance -> GroupMemberRole -> Maybe IncognitoProfile -> Maybe MemberKey -> Maybe GroupMember -> CM GroupMember acceptGroupJoinRequestAsync user@User {userId} uclId @@ -1028,6 +1029,7 @@ acceptGroupJoinRequestAsync cReqInvId cReqChatVRange cReqProfile + presHeader_ cReqXContactId_ cReqMemberId_ welcomeMsgId_ @@ -1041,16 +1043,15 @@ acceptGroupJoinRequestAsync -- a roster-established privileged member attaches a connection to its existing record (keeping -- owner-authoritative role + key); everyone else is created fresh with the group-link role cxt <- chatStoreCxt - let binding_ = (\mId -> memberChatBinding gInfo mId Nothing) =<< cReqMemberId_ (groupMemberId, memberId) <- case existingMem_ of Just m -> do -- refresh the hash placeholder name from the authenticated join profile; role + key stay roster-authoritative withStore $ \db -> do liftIO $ updateGroupMemberStatus db userId m initialStatus - void $ updateMemberProfile db cxt user m binding_ cReqProfile + void $ updateMemberProfile db cxt user m presHeader_ cReqProfile pure (groupMemberId' m, memberId' m) Nothing -> withStore $ \db -> - createJoiningMember db cxt gVar user gInfo cReqChatVRange cReqProfile binding_ cReqXContactId_ cReqMemberId_ welcomeMsgId_ gLinkMemRole initialStatus memberKey_ + createJoiningMember db cxt gVar user gInfo cReqChatVRange cReqProfile presHeader_ cReqXContactId_ cReqMemberId_ welcomeMsgId_ gLinkMemRole initialStatus memberKey_ let currentMemCount = fromIntegral $ currentMembers $ groupSummary gInfo let Profile {displayName} = userProfileInGroup user gInfo (fromIncognitoProfile <$> incognitoProfile) GroupMember {memberRole = userRole, memberId = userMemberId} = membership @@ -1068,7 +1069,7 @@ acceptGroupJoinRequestAsync } subMode <- chatReadVar subscriptionMode let chatV = vr cxt `peerConnChatVersion` cReqChatVRange - (cmdId, acId) <- prepareAgentAccept user True cReqInvId PQSupportOff + ((cmdId, acId), _) <- prepareAgentAccept user True cReqInvId PQSupportOff m <- withStore $ \db -> do liftIO $ createJoiningMemberConnection db user uclId (cmdId, acId) chatV cReqChatVRange groupMemberId subMode getGroupMemberById db cxt user groupMemberId @@ -1100,7 +1101,7 @@ acceptGroupJoinSendRejectAsync } subMode <- chatReadVar subscriptionMode let chatV = vr cxt `peerConnChatVersion` cReqChatVRange - (cmdId, acId) <- prepareAgentAccept user False cReqInvId PQSupportOff + ((cmdId, acId), _) <- prepareAgentAccept user False cReqInvId PQSupportOff m <- withStore $ \db -> do liftIO $ createJoiningMemberConnection db user uclId (cmdId, acId) chatV cReqChatVRange groupMemberId subMode getGroupMemberById db cxt user groupMemberId @@ -1135,7 +1136,7 @@ acceptBusinessJoinRequestAsync } subMode <- chatReadVar subscriptionMode let chatV = vr cxt `peerConnChatVersion` cReqChatVRange - (cmdId, acId) <- prepareAgentAccept user True cReqInvId PQSupportOff + ((cmdId, acId), _) <- prepareAgentAccept user True cReqInvId PQSupportOff withStore' $ \db -> do forM_ xContactId $ \xcId -> setBusinessChatAcceptedXContactId db gInfo xcId createJoiningMemberConnection db user uclId (cmdId, acId) chatV cReqChatVRange groupMemberId subMode @@ -1162,7 +1163,7 @@ acceptRelayJoinRequestAsync subMode <- chatReadVar subscriptionMode cxt <- chatStoreCxt let chatV = vr cxt `peerConnChatVersion` cReqChatVRange - (cmdId, acId) <- prepareAgentAccept user True cReqInvId PQSupportOff + ((cmdId, acId), _) <- prepareAgentAccept user True cReqInvId PQSupportOff r <- withStore $ \db -> do liftIO $ createJoiningMemberConnection db user uclId (cmdId, acId) chatV cReqChatVRange groupMemberId subMode gInfo' <- liftIO $ updateRelayOwnStatusFromTo db gInfo RSInvited RSAccepted @@ -1189,7 +1190,7 @@ rejectRelayInvitationAsync user uclId cxt groupRelayInv invId reqChatVRange init subMode <- chatReadVar subscriptionMode chatVR <- chatVersionRange let chatV = chatVR `peerConnChatVersion` reqChatVRange - (cmdId, acId) <- prepareAgentAccept user False invId PQSupportOff + ((cmdId, acId), _) <- prepareAgentAccept user False invId PQSupportOff withStore' $ \db -> createJoiningMemberConnection db user uclId (cmdId, acId) chatV reqChatVRange groupMemberId subMode agentAcceptContactAsync cmdId acId False invId msg PQSupportOff subMode @@ -1333,9 +1334,11 @@ memberInfo g m@GroupMember {memberId, memberRole, memberProfile, memberPubKey, a { memberId, memberRole, v = ChatVersionRange . peerChatVRange <$> activeConn, - profile = redactedMemberProfile g m $ fromLocalProfile memberProfile, + profile = (p :: Profile) {badge = mfilter (acceptedProof $ PHChat <$> memberChatBinding g memberId memberPubKey) badge}, memberKey = MemberKey <$> memberPubKey } + where + p@Profile {badge} = redactedMemberProfile g m $ fromLocalProfile memberProfile redactedMemberProfile :: GroupInfo -> GroupMember -> Profile -> Profile redactedMemberProfile g m Profile {displayName, fullName, shortDescr, description, image, contactLink = lnk, peerType, badge, contactDomain} = @@ -1634,12 +1637,12 @@ updateGroupFromLinkData user gInfo@GroupInfo {groupProfile = p, groupSummary = G newClaim = groupClaim groupProfile verifyResolved = isJust resolvedDomain_ && resolvedDomain_ == newClaim -updateContactFromLinkData :: User -> Contact -> Profile -> CM Contact -updateContactFromLinkData user ct@Contact {profile = profile@LocalProfile {contactDomain = prevClaim, contactDomainVerified}} linkProfile@Profile {contactDomain = newClaim} +updateContactFromLinkData :: User -> Contact -> ProofPresHeader -> Profile -> CM Contact +updateContactFromLinkData user ct@Contact {profile = profile@LocalProfile {contactDomain = prevClaim, contactDomainVerified}} presHeader linkProfile@Profile {contactDomain = newClaim} | profileChanged || verifyChanged = do cxt <- chatStoreCxt withFastStore $ \db -> do - ct' <- updateContactProfile db cxt user ct linkProfile + ct' <- updateContactProfile db cxt user ct (Just presHeader) linkProfile if verifyChanged then liftIO $ setContactDomainVerified db user ct' True else pure ct' | otherwise = pure ct where @@ -2235,25 +2238,44 @@ sendDirectContactMessages user ct events = do -- present the user's own badge on an outgoing profile: a fresh, single-use proof from the stored credential. -- the send's incognito profile (when set) suppresses it - an incognito identity must never carry the badge. -- a long-expired badge is not presented at all (receivers would hide it anyway). -presentUserBadge :: User -> Maybe i -> Maybe GroupInfo -> Profile -> CM Profile -presentUserBadge user@User {profile = LocalProfile {localBadge}} incognitoProfile gInfo_ p = case (incognitoProfile, localBadge) of +presentUserBadge :: User -> Maybe i -> Maybe ProofPresHeader -> Profile -> CM Profile +presentUserBadge user@User {profile = LocalProfile {localBadge}} incognitoProfile presHeader_ p = case (incognitoProfile, localBadge) of (Nothing, Just (OwnBadge _ st)) | st == BSActive || st == BSExpired -> do - ph_ <- case gInfo_ of - Nothing -> Just . PHTest <$> drgRandomBytes 16 - Just gInfo -> pure $ PHChat <$> sndGroupChatBinding gInfo False - badge <- join <$> mapM (sndBadgeProof user) ph_ + badge <- join <$> mapM (sndBadgeProof user) presHeader_ pure p {badge} _ -> pure p +groupPresHeader :: GroupInfo -> Maybe ProofPresHeader +groupPresHeader gInfo = PHChat <$> sndGroupChatBinding gInfo False + +directPresHeader :: ContactRequestBinding -> ProofPresHeader +directPresHeader = \case + CRBRatchet ConnVerifyCodes {codeAD} -> PHChat $ encodeChatBinding CBDirect codeAD + CRBRequest code -> PHRequest code + +linkPresHeader :: LinkKey -> ProofPresHeader +linkPresHeader (LinkKey key) = PHChat $ encodeChatBinding CBLink key + +invitationPresHeader :: ConnReqInvitation -> ProofPresHeader +invitationPresHeader = PHRequest . invitationRequestCode + +unboundPresHeader :: CM ProofPresHeader +unboundPresHeader = PHTest <$> drgRandomBytes 16 + +connPresHeader :: Connection -> CM (Maybe ProofPresHeader) +connPresHeader conn = eitherToMaybe <$> tryAllErrors (directPresHeader . CRBRatchet <$> withAgent (`getConnectionVerifyCodes` aConnId conn)) + +connsPresHeaders :: [Connection] -> CM (Map ConnId ProofPresHeader) +connsPresHeaders conns = either (const M.empty) (M.map (directPresHeader . CRBRatchet)) <$> tryAllErrors (withAgent (`getConnectionsVerifyCodes` map aConnId conns)) -- receiving side of contact/invitation link data: verify the badge proof from the link profile -- and set the crypto-free display badge for the UI (the raw proof stays in profile for APIPrepareContact) -linkDataBadge :: ContactShortLinkData -> CM ContactShortLinkData -linkDataBadge cld@ContactShortLinkData {profile = Profile {badge}} = case badge of +linkDataBadge :: ProofPresHeader -> ContactShortLinkData -> CM ContactShortLinkData +linkDataBadge presHeader cld@ContactShortLinkData {profile = Profile {badge}} = case mfilter (acceptedProof (Just presHeader)) badge of Nothing -> pure cld Just b@(BadgeProof _ _ _ info) -> do keys <- asks $ badgePublicKeys . config - verified <- liftIO $ verifyBadge_ unboundProof keys badge + verified <- liftIO $ verifyBadge keys b now <- liftIO getCurrentTime pure (cld :: ContactShortLinkData) {localBadge = Just $ ShownBadge info (mkBadgeStatus now verified info)} @@ -2316,6 +2338,7 @@ groupMsgSigning sign (GIK gInfo@GroupInfo {membership = GroupMember {memberId}} shouldSign = requiresSignature tag || (sign && signableContent tag) || badgePresented badgePresented = case evt of XGrpMemInfo _ Profile {badge} -> isJust badge + XGrpAcpt _ _ (Just Profile {badge}) -> isJust badge _ -> False bindingData = groupBindingData gInfo memberId (C.publicKey memberPrivKey') @@ -2653,7 +2676,7 @@ sendGroupProfileUpdate user g@(GIK gInfo gks) scope asGroup members = _ -> False sendProfileUpdate = do -- shouldSendProfileUpdate excludes incognito membership, so the badge is presented - profileUpdate <- presentUserBadge user Nothing (Just gInfo) $ redactedMemberProfile gInfo (membership gInfo) $ fromLocalProfile p + profileUpdate <- presentUserBadge user Nothing (groupPresHeader gInfo) $ redactedMemberProfile gInfo (membership gInfo) $ fromLocalProfile p void $ sendGroupMessage' user g members $ XInfo profileUpdate (Just $ groupMemberKey gks) currentTs <- liftIO getCurrentTime withStore' $ \db -> updateUserMemberProfileSentAt db user gInfo currentTs @@ -3027,13 +3050,13 @@ prepareAgentCreation user cmdFunction enableNtfs cMode = do connId <- withAgent $ \a -> prepareConnectionToCreate a (aUserId user) enableNtfs cMode PQSupportOff pure (cmdId, connId) -prepareAgentJoin :: User -> Maybe Connection -> Bool -> ConnectionRequestUri c -> CM (CommandId, ConnId) +prepareAgentJoin :: User -> Maybe Connection -> Bool -> ConnectionRequestUri c -> CM ((CommandId, ConnId), Maybe ContactRequestBinding) prepareAgentJoin user conn_ enableNtfs cReqUri = do cmdId <- withStore' $ \db -> createCommand db user (dbConnId <$> conn_) CFJoinConn - connId <- case conn_ of - Just conn -> pure $ aConnId conn - Nothing -> fst <$> withAgent (\a -> prepareConnectionToJoin a (aUserId user) enableNtfs cReqUri PQSupportOff) - pure (cmdId, connId) + (connId, binding_) <- case conn_ of + Just conn -> pure (aConnId conn, Nothing) + Nothing -> second Just <$> withAgent (\a -> prepareConnectionToJoin a (aUserId user) enableNtfs cReqUri PQSupportOff) + pure ((cmdId, connId), binding_) joinAgentConnectionAsync :: CommandId -> Bool -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> CM () joinAgentConnectionAsync cmdId updateConn connId enableNtfs cReqUri cInfo subMode = @@ -3055,11 +3078,11 @@ allowAgentConnectionInfo user conn@Connection {connId} confId dm = do withAgent $ \a -> allowConnectionAsync a (aCorrId cmdId) (aConnId conn) confId dm withStore' $ \db -> updateConnectionStatus db conn ConnAccepted -prepareAgentAccept :: User -> Bool -> InvitationId -> PQSupport -> CM (CommandId, ConnId) +prepareAgentAccept :: User -> Bool -> InvitationId -> PQSupport -> CM ((CommandId, ConnId), ContactRequestBinding) prepareAgentAccept user enableNtfs invId pqSup = do cmdId <- withStore' $ \db -> createCommand db user Nothing CFAcceptContact - (connId, _) <- withAgent $ \a -> prepareConnectionToAccept a (aUserId user) enableNtfs invId pqSup - pure (cmdId, connId) + (connId, binding) <- withAgent $ \a -> prepareConnectionToAccept a (aUserId user) enableNtfs invId pqSup + pure ((cmdId, connId), binding) agentAcceptContactAsync :: MsgEncodingI e => CommandId -> ConnId -> Bool -> InvitationId -> ChatMsgEvent e -> PQSupport -> SubscriptionMode -> CM () agentAcceptContactAsync cmdId connId enableNtfs invId msg pqSup subMode = do diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index 6022114a52..60cb3b992d 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/src/Simplex/Chat/Library/Subscriber.hs @@ -46,7 +46,7 @@ import Data.Time.Format (defaultTimeLocale, formatTime) import qualified Data.UUID as UUID import qualified Data.UUID.V4 as V4 import Data.Word (Word32) -import Simplex.Chat.Badges (BadgeProof, BadgeProofKind (..), BadgeStatus (..), FileSizeLimits (..), ProofPresHeader (..)) +import Simplex.Chat.Badges (BadgeProof (..), BadgeProofKind (..), BadgeStatus (..), FileSizeLimits (..), LocalBadge (..), ProofPresHeader (..), acceptedProof, verifyBadge) import Simplex.Chat.Call import Simplex.Chat.Controller import Simplex.Chat.Delivery @@ -501,10 +501,11 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag -- [incognito] send saved profile (conn'', gInfo_) <- saveConnInfo conn' connInfo incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId) - profileToSend <- - presentUserBadge user incognitoProfile ((\(GIK gInfo _) -> gInfo) <$> gInfo_) $ case gInfo_ of - Just (GIK gInfo _) -> userProfileInGroup user gInfo (fromLocalProfile <$> incognitoProfile) - Nothing -> userProfileDirect user (fromLocalProfile <$> incognitoProfile) Nothing True + profileToSend <- case gInfo_ of + Just (GIK gInfo _) -> presentUserBadge user incognitoProfile (groupPresHeader gInfo) $ userProfileInGroup user gInfo (fromLocalProfile <$> incognitoProfile) + Nothing -> do + presHeader <- maybe unboundPresHeader pure =<< connPresHeader conn'' + presentUserBadge user incognitoProfile (Just presHeader) $ userProfileDirect user (fromLocalProfile <$> incognitoProfile) Nothing True -- [async agent commands] no continuation needed, but command should be asynchronous for stability allowAgentConnectionAsync user conn'' confId gInfo_ $ XInfo profileToSend ((\(GIK _ gks) -> groupMemberKey gks) <$> gInfo_) INFO pqSupport connInfo -> do @@ -621,7 +622,8 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag ct' <- processContactProfileUpdate ct profile False `catchAllErrors` const (pure ct) -- [incognito] send incognito profile incognitoProfile <- forM customUserProfileId $ \profileId -> withStore $ \db -> getProfileById db userId profileId - p <- presentUserBadge user incognitoProfile Nothing $ userProfileDirect user (fromLocalProfile <$> incognitoProfile) (Just ct') True + presHeader <- maybe unboundPresHeader pure =<< connPresHeader conn'' + p <- presentUserBadge user incognitoProfile (Just presHeader) $ userProfileDirect user (fromLocalProfile <$> incognitoProfile) (Just ct') True allowAgentConnectionAsync user conn'' confId Nothing $ XInfo p Nothing void $ withStore' $ \db -> resetMemberContactFields db ct' XGrpLinkInv glInv -> do @@ -634,7 +636,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing Nothing (Just epochStart) -- [incognito] send saved profile incognitoProfile <- forM customUserProfileId $ \pId -> withStore (\db -> getProfileById db userId pId) - profileToSend <- presentUserBadge user incognitoProfile (Just gInfo) $ userProfileInGroup user gInfo (fromLocalProfile <$> incognitoProfile) + profileToSend <- presentUserBadge user incognitoProfile (groupPresHeader gInfo) $ userProfileInGroup user gInfo (fromLocalProfile <$> incognitoProfile) let gks = GKGroup {memberPrivKey = snd memberKeys} allowAgentConnectionAsync user conn'' confId (Just $ GIK gInfo gks) $ XInfo profileToSend (Just $ groupMemberKey gks) toView $ CEvtBusinessLinkConnecting user gInfo host ct @@ -783,12 +785,20 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag case memberCategory m of GCInviteeMember -> case chatMsgEvent of - XGrpAcpt memId mKey + XGrpAcpt memId mKey memProfile_ | sameMemberId memId m -> do withStore $ \db -> liftIO $ updateGroupMemberStatus db userId m GSMemAccepted forM_ mKey $ \(MemberKey k) -> withStore' $ \db -> setMemberPubKey db (groupMemberId' m) k + let m' = maybe m (\(MemberKey k) -> m {memberPubKey = Just k}) mKey + forM_ memProfile_ $ \memProfile -> processMemberProfileUpdate gInfo m' (PHChat <$> signedMemberBinding gInfo m' signedMsg_) memProfile Nothing + let GroupMember {memberId = membershipMemId} = membership + p = redactedMemberProfile gInfo membership $ fromLocalProfile $ memberProfile membership + membershipProfile <- + if maxVersion (peerChatVRange conn') >= relayWebCapVersion + then presentUserBadge user (incognitoMembershipProfile gInfo) (groupPresHeader gInfo) p + else pure p -- [async agent commands] no continuation needed, but command should be asynchronous for stability - allowAgentConnectionAsync user conn' confId (Just g) XOk + allowAgentConnectionAsync user conn' confId (Just g) $ XGrpMemInfo membershipMemId membershipProfile | otherwise -> messageError "x.grp.acpt: memberId is different from expected" XGrpRelayAcpt relayLink relayCap | memberRole' membership == GROwner && isRelay m -> do @@ -823,7 +833,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag (gInfo', m') <- withStore $ \db -> updatePreparedUserAndHostMembersInvited db cxt user gInfo m glInv -- [incognito] send saved profile incognitoProfile <- forM customUserProfileId $ \pId -> withStore (\db -> getProfileById db userId pId) - profileToSend <- presentUserBadge user incognitoProfile (Just gInfo') $ userProfileInGroup user gInfo' (fromLocalProfile <$> incognitoProfile) + profileToSend <- presentUserBadge user incognitoProfile (groupPresHeader gInfo') $ userProfileInGroup user gInfo' (fromLocalProfile <$> incognitoProfile) allowAgentConnectionAsync user conn' confId (Just $ GIK gInfo' gks) $ XInfo profileToSend (Just $ groupMemberKey gks) toView $ CEvtGroupLinkConnecting user gInfo' m' | otherwise -> messageError "x.grp.link.inv: publicGroupId mismatch" @@ -840,11 +850,11 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag p = redactedMemberProfile gInfo membership $ fromLocalProfile $ memberProfile membership membershipProfile <- if maxVersion (peerChatVRange conn') >= relayWebCapVersion - then presentUserBadge user (incognitoMembershipProfile gInfo) (Just gInfo) p + then presentUserBadge user (incognitoMembershipProfile gInfo) (groupPresHeader gInfo) p else pure p -- [async agent commands] no continuation needed, but command should be asynchronous for stability allowAgentConnectionAsync user conn' confId (Just g) $ XGrpMemInfo membershipMemId membershipProfile - void $ processMemberProfileUpdate gInfo m (signedMemberBinding gInfo m signedMsg_) memProfile Nothing + void $ processMemberProfileUpdate gInfo m (PHChat <$> signedMemberBinding gInfo m signedMsg_) memProfile Nothing | otherwise -> messageError "x.grp.mem.info: memberId is different from expected" _ -> messageError "CONF from member must have x.grp.mem.info" INFO _pqSupport connInfo -> do @@ -853,15 +863,18 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag case chatMsgEvent of XGrpMemInfo memId memProfile | sameMemberId memId m -> - void $ processMemberProfileUpdate gInfo m (signedMemberBinding gInfo m signedMsg_) memProfile Nothing + void $ processMemberProfileUpdate gInfo m (PHChat <$> signedMemberBinding gInfo m signedMsg_) memProfile Nothing | otherwise -> messageError "x.grp.mem.info: memberId is different from expected" -- sent when connecting via group link - XInfo _ mKey + XInfo memProfile mKey -- TODO Keep rejected member to allow them to appeal against rejection. | memberStatus m == GSMemRejected -> do deleteMemberConnection' m True withStore' $ \db -> deleteGroupMember db user m - | otherwise -> mapM_ (storeMemberKey gInfo m signedMsg_) mKey + | otherwise -> do + storedKey_ <- join <$> mapM (storeMemberKey gInfo m signedMsg_) mKey + let m' = maybe m (\k -> m {memberPubKey = Just k}) storedKey_ + void $ processMemberProfileUpdate gInfo m' (PHChat <$> signedMemberBinding gInfo m' signedMsg_) memProfile Nothing XOk -> -- transient relay-reject row cleanup after the rejection handshake completes when (memberCategory m == GCHostMember && not (relayServesGroup gInfo)) $ do @@ -967,7 +980,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag where sendXGrpLinkMem gInfo'' m' = do let incognitoProfile = ExistingIncognito <$> incognitoMembershipProfile gInfo'' - profileToSend <- presentUserBadge user incognitoProfile (Just gInfo'') $ userProfileInGroup user gInfo'' (fromIncognitoProfile <$> incognitoProfile) + profileToSend <- presentUserBadge user incognitoProfile (groupPresHeader gInfo'') $ userProfileInGroup user gInfo'' (fromIncognitoProfile <$> incognitoProfile) sendGroupMemberMessages user (GIK gInfo'' gks) conn [XGrpLinkMem profileToSend (Just $ groupMemberKey gks)] _ -> do unless (memberPending m) $ withStore' $ \db -> updateGroupMemberStatus db userId m GSMemConnected @@ -1249,10 +1262,10 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag -- Update connection with data derived from cReq, now available after getConnShortLinkAsync withStore' $ \db -> updateConnLinkData db user conn cReq cReqHash groupLinkId chatV pqSup let incognitoProfile = fromLocalProfile <$> incognitoMembershipProfile gInfo - profileToSend <- presentUserBadge user incognitoProfile (Just gInfo) $ userProfileInGroup user gInfo incognitoProfile + profileToSend <- presentUserBadge user incognitoProfile (groupPresHeader gInfo) $ userProfileInGroup user gInfo incognitoProfile dm <- encodeXMemberConnInfo g relayMemberId profileToSend subMode <- chatReadVar subscriptionMode - (cmdId, connId') <- prepareAgentJoin user (Just conn) True cReq + ((cmdId, connId'), _) <- prepareAgentJoin user (Just conn) True cReq joinAgentConnectionAsync cmdId True connId' True cReq dm subMode CFGetRelayDataAccept -> do let GroupMember {memberId = MemberId expectedMemberId} = m @@ -1393,12 +1406,13 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag processContactConnMessage :: AEvent e -> ConnectionEntity -> Connection -> UserContact -> CM () processContactConnMessage agentMsg connEntity conn UserContact {userContactLinkId = uclId, groupId = ucGroupId_} = case agentMsg of - REQ invId pqSupport _ connInfo _ rejectionSupported -> do + REQ invId pqSupport _ connInfo binding rejectionSupported -> do (signedMsg_, ChatMessage {chatVRange, chatMsgEvent}) <- parseChatMessage' conn connInfo + let reqHeader = directPresHeader binding case chatMsgEvent of - XContact p memberKey_ xContactId_ welcomeMsgId_ requestMsg_ -> profileContactRequest invId chatVRange p memberKey_ xContactId_ welcomeMsgId_ requestMsg_ pqSupport rejectionSupported + XContact p memberKey_ xContactId_ welcomeMsgId_ requestMsg_ -> profileContactRequest invId chatVRange reqHeader p memberKey_ xContactId_ welcomeMsgId_ requestMsg_ pqSupport rejectionSupported XMember p joiningMemberId joiningMemberKey viaRelay -> memberJoinRequestViaRelay invId chatVRange signedMsg_ p joiningMemberId joiningMemberKey viaRelay - XInfo p _ -> profileContactRequest invId chatVRange p Nothing Nothing Nothing Nothing pqSupport rejectionSupported + XInfo p _ -> profileContactRequest invId chatVRange reqHeader p Nothing Nothing Nothing Nothing pqSupport rejectionSupported XGrpRelayInv groupRelayInv -> xGrpRelayInv invId chatVRange groupRelayInv XGrpRelayTest challenge _ -> xGrpRelayTest invId chatVRange challenge -- TODO show/log error, other events in contact request @@ -1472,8 +1486,8 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag -- TODO add debugging output _ -> pure () where - profileContactRequest :: InvitationId -> VersionRangeChat -> Profile -> Maybe MemberKey -> Maybe XContactId -> Maybe SharedMsgId -> Maybe (SharedMsgId, MsgContent) -> PQSupport -> Bool -> CM () - profileContactRequest invId chatVRange p@Profile {displayName} memberKey_ xContactId_ welcomeMsgId_ requestMsg_ reqPQSup rejectionSupported = do + profileContactRequest :: InvitationId -> VersionRangeChat -> ProofPresHeader -> Profile -> Maybe MemberKey -> Maybe XContactId -> Maybe SharedMsgId -> Maybe (SharedMsgId, MsgContent) -> PQSupport -> Bool -> CM () + profileContactRequest invId chatVRange reqHeader p@Profile {displayName} memberKey_ xContactId_ welcomeMsgId_ requestMsg_ reqPQSup rejectionSupported = do (ucl, gLinkInfo_) <- withStore $ \db -> getUserContactLinkById db userId uclId let v = maxVersion chatVRange case gLinkInfo_ of @@ -1483,7 +1497,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag AddressSettings {autoAccept} = addressSettings isSimplexTeam = sameConnReqContact connReq adminContactReq gVar <- asks random - withStore (\db -> createOrUpdateContactRequest db gVar cxt user uclId ucl isSimplexTeam invId chatVRange p xContactId_ welcomeMsgId_ requestMsg_ reqPQSup rejectionSupported) >>= \case + withStore (\db -> createOrUpdateContactRequest db gVar cxt user uclId ucl isSimplexTeam invId chatVRange (Just reqHeader) p xContactId_ welcomeMsgId_ requestMsg_ reqPQSup rejectionSupported) >>= \case RSAcceptedRequest _ucr re -> case re of REContact ct -> -- TODO [short links] update request msg @@ -1626,7 +1640,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag maybe (pure $ Right (GAAccepted, gLinkMemRole)) (\am -> liftIO $ am gInfo gli p) acceptMember_ >>= \case Right (acceptance, useRole) -> do let profileMode = ExistingIncognito <$> incognitoMembershipProfile gInfo - mem <- acceptGroupJoinRequestAsync user uclId g invId chatVRange p xContactId_ Nothing welcomeMsgId_ acceptance useRole profileMode memberKey_ Nothing + mem <- acceptGroupJoinRequestAsync user uclId g invId chatVRange p (Just reqHeader) xContactId_ Nothing welcomeMsgId_ acceptance useRole profileMode memberKey_ Nothing (gInfo', mem', scopeInfo) <- mkGroupChatScope gInfo mem createInternalChatItem user (CDGroupRcv gInfo' scopeInfo mem') (CIRcvGroupEvent RGEInvitedViaGroupLink) Nothing toView $ CEvtAcceptingGroupJoinRequestMember user gInfo' mem' @@ -1656,7 +1670,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag msg = XGrpRelayTest challenge (Just sig) subMode <- chatReadVar subscriptionMode let chatV = vr cxt `peerConnChatVersion` chatVRange - (cmdId, acId) <- prepareAgentAccept user True invId PQSupportOff + ((cmdId, acId), _) <- prepareAgentAccept user True invId PQSupportOff withStore $ \db -> do Connection {connId = testCId} <- createRelayTestConnection db cxt user acId ConnAccepted chatV subMode liftIO $ setCommandConnId db user cmdId testCId @@ -1692,7 +1706,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag && viaRelay == Just (memberId' (membership gInfo)) _ -> False acceptJoin g@(GIK gInfo _) existingMem_ acceptRole = do - mem <- acceptGroupJoinRequestAsync user uclId g invId chatVRange p Nothing (Just joiningMemberId) Nothing GAAccepted acceptRole Nothing (Just joiningMemberKey) existingMem_ + mem <- acceptGroupJoinRequestAsync user uclId g invId chatVRange p (PHChat <$> memberChatBinding gInfo joiningMemberId Nothing) Nothing (Just joiningMemberId) Nothing GAAccepted acceptRole Nothing (Just joiningMemberKey) existingMem_ (gInfo', mem', scopeInfo) <- mkGroupChatScope gInfo mem createInternalChatItem user (CDGroupRcv gInfo' scopeInfo mem') (CIRcvGroupEvent RGEInvitedViaGroupLink) Nothing toView $ CEvtAcceptingGroupJoinRequestMember user gInfo' mem' @@ -1906,7 +1920,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag newContentMessage :: Contact -> MsgContainer -> RcvMessage -> MsgMeta -> CM () newContentMessage ct mc msg@RcvMessage {sharedMsgId_} msgMeta = do let MsgContainer {content = c, file = fInv_} = mc - content <- case c of + content <- chatLinkBadge =<< case c of MCChat {text, chatLink, ownerSig = Just LinkOwnerSig {chatBinding = B64UrlByteString binding}} -> do keepSig <- case contactConn ct of Nothing -> pure False @@ -1938,6 +1952,14 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getDirectCIReactions db ct sharedMsgId) sharedMsgId_ toView $ CEvtNewChatItems user [AChatItem SCTDirect SMDRcv cInfo ci {reactions}] + chatLinkBadge :: MsgContent -> CM MsgContent + chatLinkBadge = \case + MCChat {text, chatLink = chatLink@MCLContact {connLink = CSLContact _ _ _ linkKey, profile = p@Profile {badge = Just b}}, ownerSig} -> do + keys <- asks $ badgePublicKeys . config + verified <- if acceptedProof (Just $ linkPresHeader linkKey) b then liftIO (verifyBadge keys b) else pure Nothing + pure MCChat {text, chatLink = if verified == Just True then chatLink else (chatLink :: MsgChatLink) {profile = (p :: Profile) {badge = Nothing}}, ownerSig} + c -> pure c + autoAcceptFile :: Maybe (RcvFileTransfer, CIFile 'MDRcv) -> CM () autoAcceptFile = mapM_ $ \(ft, CIFile {fileSize}) -> do -- ! autoAcceptFileSize is only used in tests @@ -2256,10 +2278,12 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag -- m' is Maybe GroupMember createNonLive gInfo' m' scopeInfo file_ = do let mentions' = if maybe False memberBlocked m' then M.empty else mentions - saveRcvCI gInfo' m' scopeInfo (CIRcvMsgContent content, ts) (snd <$> file_) (timed_ gInfo') False mentions' + content' <- chatLinkBadge content + saveRcvCI gInfo' m' scopeInfo (CIRcvMsgContent content', ts) (snd <$> file_) (timed_ gInfo') False mentions' createContentItem gInfo' m' scopeInfo = do file_ <- processFileInv gInfo' m' - newChatItem gInfo' m' scopeInfo (CIRcvMsgContent content, ts) (snd <$> file_) (timed_ gInfo') live' + content' <- chatLinkBadge content + newChatItem gInfo' m' scopeInfo (CIRcvMsgContent content', ts) (snd <$> file_) (timed_ gInfo') live' unless (maybe False memberBlocked m') $ autoAcceptFile file_ processFileInv gInfo' m' = let fileMember_ = if sentAsGroup then Nothing else m' @@ -2694,8 +2718,14 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag -- the transient host connection view with the group and removes its chat joinGroupAsync hostContact_ sameLink = do subMode <- chatReadVar subscriptionMode - dm <- encodeConnInfo $ XGrpAcpt membershipMemId (Just $ groupMemberKey gks) - connIds@(cmdId, acId) <- prepareAgentJoin user Nothing True connRequest + let incognitoProfile = incognitoMembershipProfile gInfo + profile_ <- + if maxVersion peerChatVRange >= relayWebCapVersion + then Just <$> presentUserBadge user incognitoProfile (groupPresHeader gInfo) (userProfileInGroup user gInfo $ fromLocalProfile <$> incognitoProfile) + else pure Nothing + let acptMsg = XGrpAcpt membershipMemId (Just $ groupMemberKey gks) profile_ + dm <- maybe (encodeConnInfo acptMsg) (`encodeSignedConnInfo` acptMsg) (groupMsgSigning False (GIK gInfo gks) acptMsg) + (connIds@(cmdId, acId), _) <- prepareAgentJoin user Nothing True connRequest withStore' $ \db -> do when sameLink $ setViaGroupLinkUri db groupId connId createMemberConnectionAsync db user hostId connIds connChatVersion peerChatVRange subMode @@ -2759,12 +2789,13 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag processContactProfileUpdate c@Contact {profile = lp} p' createItems -- a failed/unknown-key badge is re-verified even when content is unchanged, so it heals after an app update adds the key | contentChanged || badgeNeedsReverify lp = do + presHeader_ <- maybe (pure Nothing) connPresHeader $ contactConn c c' <- withStore $ \db -> if userTTL == rcvTTL - then updateContactProfile db cxt user c p' + then updateContactProfile db cxt user c presHeader_ p' else do c' <- liftIO $ updateContactUserPreferences db user c ctUserPrefs' - updateContactProfile db cxt user c' p' + updateContactProfile db cxt user c' presHeader_ p' when (contentChanged && directOrUsed c' && createItems) $ do createProfileUpdatedItem c' lift $ createRcvFeatureItems user c c' @@ -2801,7 +2832,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag xInfoMember :: GroupInfo -> GroupMember -> Profile -> Maybe MemberKey -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope) xInfoMember gInfo m p' mKey msg brokerTs = do binding_ <- verifiedMemberBinding gInfo m mKey msg - void $ processMemberProfileUpdate gInfo m binding_ p' (Just (msg, brokerTs)) + void $ processMemberProfileUpdate gInfo m (PHChat <$> binding_) p' (Just (msg, brokerTs)) pure $ memberEventDeliveryScope m xGrpLinkMem :: GroupInfo -> GroupMember -> Connection -> Profile -> Maybe MemberKey -> RcvMessage -> CM () @@ -2810,7 +2841,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag if (viaGroupLink || isJust businessChat) && isNothing (memberContactId m) && memberCategory == GCHostMember && not xGrpLinkMemReceived then do binding_ <- verifiedMemberBinding gInfo m mKey msg - m' <- processMemberProfileUpdate gInfo m binding_ p' Nothing + m' <- processMemberProfileUpdate gInfo m (PHChat <$> binding_) p' Nothing withStore' $ \db -> setXGrpLinkMemReceived db groupMemberId True let connectedIncognito = memberIncognito membership probeMatchingMemberContact m' connectedIncognito @@ -2896,14 +2927,14 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag unless (groupFeatureAllowed SGFHistory gInfo) $ forM_ description $ \descr -> createInternalChatItem user (CDGroupRcv gInfo Nothing m) (CIRcvMsgContent $ MCText descr) Nothing - processMemberProfileUpdate :: GroupInfo -> GroupMember -> Maybe ByteString -> Profile -> Maybe (RcvMessage, UTCTime) -> CM GroupMember - processMemberProfileUpdate gInfo m@GroupMember {memberProfile = p, memberContactId} binding_ p' msgTs_ + processMemberProfileUpdate :: GroupInfo -> GroupMember -> Maybe ProofPresHeader -> Profile -> Maybe (RcvMessage, UTCTime) -> CM GroupMember + processMemberProfileUpdate gInfo m@GroupMember {memberProfile = p, memberContactId} presHeader_ rcvProfile msgTs_ -- a failed/unknown-key badge is re-verified even when content is unchanged, so it heals after an app update adds the key - | contentChanged || badgeNeedsReverify p = do + | contentChanged || badgeNeedsReverify p || proofHeaderChanged = do when contentChanged $ updateBusinessChatProfile gInfo case memberContactId of Nothing -> do - m' <- withStore $ \db -> updateMemberProfile db cxt user m binding_ p'' + m' <- withStore $ \db -> updateMemberProfile db cxt user m presHeader_ p'' unless (muteEventInChannel gInfo m') $ do when contentChanged $ forM_ msgTs_ $ createProfileUpdatedItem m' toView $ CEvtGroupMemberUpdated user gInfo m m' @@ -2912,7 +2943,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag mCt <- withStore $ \db -> getContact db cxt user mContactId if canUpdateProfile mCt then do - (m', ct') <- withStore $ \db -> updateContactMemberProfile db cxt user m mCt binding_ p' + (m', ct') <- withStore $ \db -> updateContactMemberProfile db cxt user m mCt presHeader_ p' unless (muteEventInChannel gInfo m') $ do when contentChanged $ forM_ msgTs_ $ createProfileUpdatedItem m' toView $ CEvtGroupMemberUpdated user gInfo m m' @@ -2928,8 +2959,16 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag | otherwise = pure m where + p' = case rcvProfile of + Profile {badge = Just b} | not (acceptedProof presHeader_ b) -> rcvProfile {badge = storedProof} + _ -> rcvProfile + Profile {badge = storedProof} = fromLocalProfile p p'' = redactedMemberProfile gInfo m p' contentChanged = not (sameProfileContent (redactedMemberProfile gInfo m (fromLocalProfile p)) p'') + proofHeaderChanged = case (p', p) of + (Profile {badge = Just BadgeProof {presHeader}}, LocalProfile {localBadge = Just (PeerBadge BadgeProof {presHeader = storedHeader} _)}) -> + presHeader /= storedHeader + _ -> False updateBusinessChatProfile g@GroupInfo {businessChat} = case businessChat of Just bc | isMainBusinessMember bc m -> do g' <- withStore $ \db -> updateGroupProfileFromMember db user g p' @@ -3170,7 +3209,8 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag conn' <- updatePeerChatVRange activeConn chatVRange case chatMsgEvent of XInfo p _ -> do - ct <- withStore $ \db -> createDirectContact db cxt user conn' p + presHeader_ <- connPresHeader conn' + ct <- withStore $ \db -> createDirectContact db cxt user conn' presHeader_ p toView $ CEvtContactConnecting user ct pure (conn', Nothing) XGrpLinkInv glInv -> do @@ -3194,7 +3234,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag xGrpMemNew :: GroupInfoKeys -> GroupMember -> MemberInfo -> Maybe MsgScope -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope) xGrpMemNew (GIK gInfo gks) m memInfo@(MemberInfo memId memRole _ _ assertedKey_) msgScope_ msg brokerTs = do unless (useRelays' gInfo) $ checkHostRole m memRole - let binding_ = memberChatBinding gInfo memId Nothing + let presHeader_ = PHChat <$> memberChatBinding gInfo memId ((\(MemberKey k) -> k) <$> assertedKey_) if sameMemberId memId (membership gInfo) then pure Nothing else @@ -3211,7 +3251,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag -- TODO [relays] member: surface relay-key-mismatch as a dedicated event / chat item / relay state when (assertedKey /= memberPubKey unknownMember) $ messageWarning $ "x.grp.mem.new: relay asserted key differs from roster-established key, keeping roster key, memberId=" <> safeDecodeUtf8 (strEncode memId) - updatedMember <- withStore $ \db -> updateRosterMemberAnnounced db cxt user m unknownMember memInfo binding_ initialStatus + updatedMember <- withStore $ \db -> updateRosterMemberAnnounced db cxt user m unknownMember memInfo presHeader_ initialStatus -- roster members can't be pending, so no members-require-attention update gInfo' <- updatePublicGroupData user gInfo gks toView $ CEvtUnknownMemberAnnounced user gInfo' m unknownMember updatedMember @@ -3222,7 +3262,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag messageError "x.grp.mem.new: privileged role not established by roster" $> Nothing | otherwise -> do (updatedMember, gInfo') <- withStore $ \db -> do - updatedMember <- updateUnknownMemberAnnounced db cxt user m unknownMember memInfo binding_ initialStatus + updatedMember <- updateUnknownMemberAnnounced db cxt user m unknownMember memInfo presHeader_ initialStatus gInfo' <- if memberPending updatedMember then liftIO $ increaseGroupMembersRequireAttention db user gInfo @@ -3240,7 +3280,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag | useRelays' gInfo && isPrivilegedRole memRole -> messageError "x.grp.mem.new: privileged member not established by roster" $> Nothing | otherwise -> do (newMember, gInfo') <- withStore $ \db -> do - newMember <- createNewGroupMember db cxt user gInfo m memInfo binding_ GCPostMember initialStatus + newMember <- createNewGroupMember db cxt user gInfo m memInfo presHeader_ GCPostMember initialStatus gInfo' <- if memberPending newMember then liftIO $ increaseGroupMembersRequireAttention db user gInfo @@ -3275,14 +3315,14 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag 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 - let binding_ = memberChatBinding gInfo memId Nothing + xGrpMemIntro gInfo@GroupInfo {chatSettings} m@GroupMember {memberRole, localDisplayName = c} memInfo@(MemberInfo memId _ memChatVRange _ introKey_) memRestrictions = do + let presHeader_ = PHChat <$> memberChatBinding gInfo memId ((\(MemberKey k) -> k) <$> introKey_) case memberCategory m of GCHostMember -> withStore' (\db -> runExceptT $ getGroupMemberByMemberId db cxt user gInfo memId) >>= \case Right existingMember | useRelays' gInfo -> do - updatedMember <- withStore $ \db -> updatePreparedChannelMember db cxt user existingMember memInfo binding_ + updatedMember <- withStore $ \db -> updatePreparedChannelMember db cxt user existingMember memInfo presHeader_ toView $ CEvtGroupMemberUpdated user gInfo existingMember updatedMember | otherwise -> messageError "x.grp.mem.intro ignored: member already exists" @@ -3295,7 +3335,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag MemberInfo mId mRole v p _ | mRole >= GRMember -> MemberInfo mId defaultRole v p Nothing _ -> memInfo - void $ withStore $ \db -> createIntroReMember db cxt user gInfo memInfo' binding_ memRestrictions + void $ withStore $ \db -> createIntroReMember db cxt user gInfo memInfo' presHeader_ memRestrictions | otherwise -> do when (memberRole < GRAdmin) $ throwChatError (CEGroupContactRole c) case memChatVRange of @@ -3305,7 +3345,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag groupConnIds@(cmdId, connId) <- prepareAgentCreation user CFCreateConnGrpMemInv (chatHasNtfs chatSettings) SCMInvitation let chatV = maybe (minVersion (vr cxt)) (\peerVR -> vr cxt `peerConnChatVersion` fromChatVRange peerVR) memChatVRange void $ withStore $ \db -> do - reMember <- createIntroReMember db cxt user gInfo memInfo binding_ memRestrictions + reMember <- createIntroReMember db cxt user gInfo memInfo presHeader_ memRestrictions createIntroReMemberConn db user m reMember chatV memInfo groupConnIds subMode withAgent $ \a -> createConnectionAsync a (aCorrId cmdId) connId (chatHasNtfs chatSettings) SCMInvitation CR.IKPQOff True subMode _ -> messageError "x.grp.mem.intro can be only sent by host member" @@ -3327,7 +3367,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag _ -> messageError "x.grp.mem.inv can be only sent by invitee member" xGrpMemFwd :: GroupInfoKeys -> GroupMember -> MemberInfo -> IntroInvitation -> CM () - xGrpMemFwd g@(GIK gInfo@GroupInfo {membership, chatSettings} _) m memInfo@(MemberInfo memId memRole memChatVRange _ _) IntroInvitation {groupConnReq, directConnReq} = do + xGrpMemFwd g@(GIK gInfo@GroupInfo {membership, chatSettings} _) m memInfo@(MemberInfo memId memRole memChatVRange _ introKey_) IntroInvitation {groupConnReq, directConnReq} = do let GroupMember {memberId = membershipMemId} = membership checkHostRole m memRole toMember <- withStore $ \db -> do @@ -3338,7 +3378,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag -- member receiving x.grp.mem.fwd should have also received x.grp.mem.new prior to that. -- For now, this branch compensates for the lack of delayed message delivery. `catchError` \case - SEGroupMemberNotFoundByMemberId _ -> createNewGroupMember db cxt user gInfo m memInfo (memberChatBinding gInfo memId Nothing) GCPostMember GSMemAnnounced + SEGroupMemberNotFoundByMemberId _ -> createNewGroupMember db cxt user gInfo m memInfo (PHChat <$> memberChatBinding gInfo memId ((\(MemberKey k) -> k) <$> introKey_)) GCPostMember GSMemAnnounced e -> throwError e -- TODO [knocking] separate pending statuses from GroupMemberStatus? -- TODO add GSMemIntroInvitedPending, GSMemConnectedPending, etc.? @@ -3353,14 +3393,14 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag -- [incognito] send membership incognito profile, create direct connection as incognito membershipProfile <- if chatV >= relayWebCapVersion - then presentUserBadge user (incognitoMembershipProfile gInfo) (Just gInfo) p + then presentUserBadge user (incognitoMembershipProfile gInfo) (groupPresHeader gInfo) p else pure p let msg = XGrpMemInfo membershipMemId membershipProfile dm <- maybe (encodeConnInfo msg) (`encodeSignedConnInfo` msg) (groupMsgSigning False g msg) -- [async agent commands] no continuation needed, but commands should be asynchronous for stability let enableNtfsGrp = chatHasNtfs chatSettings - groupConnIds@(gCmdId, gAcId) <- prepareAgentJoin user Nothing enableNtfsGrp groupConnReq - directConnIds <- mapM (prepareAgentJoin user Nothing True) directConnReq + (groupConnIds@(gCmdId, gAcId), _) <- prepareAgentJoin user Nothing enableNtfsGrp groupConnReq + directConnIds <- mapM (fmap fst . prepareAgentJoin user Nothing True) directConnReq let customUserProfileId = localProfileId <$> incognitoMembershipProfile gInfo withStore' $ \db -> createIntroToMemberContact db user m toMember chatV mcvr groupConnIds directConnIds customUserProfileId subMode joinAgentConnectionAsync gCmdId False gAcId enableNtfsGrp groupConnReq dm subMode @@ -3889,12 +3929,12 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag } joinExistingContact subMode mCt@Contact {contactId = mContactId} | autoAcceptMemberContacts user = do - (cmdId, acId) <- prepareAgentJoin user Nothing True connReq + ((cmdId, acId), binding_) <- prepareAgentJoin user Nothing True connReq mCt' <- withStore $ \db -> do updateMemberContactInvited db user mCt groupDirectInv void $ liftIO $ createMemberContactConn db user acId (Just cmdId) g mConn ConnJoined mContactId subMode getContact db cxt user mContactId - joinMemberContactAsync cmdId acId subMode + joinMemberContactAsync cmdId acId (directPresHeader <$> binding_) subMode securityCodeChanged mCt' createItems mCt' m | otherwise = do @@ -3908,14 +3948,14 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag createItems mCt' m createNewContact subMode | autoAcceptMemberContacts user = do - (cmdId, acId) <- prepareAgentJoin user Nothing True connReq + ((cmdId, acId), binding_) <- prepareAgentJoin user Nothing True connReq -- [incognito] reuse membership incognito profile (mCt, m') <- withStore $ \db -> do (mContactId, m') <- liftIO $ createMemberContactInvited db user g m groupDirectInv void $ liftIO $ createMemberContactConn db user acId (Just cmdId) g mConn ConnJoined mContactId subMode mCt <- getContact db cxt user mContactId pure (mCt, m') - joinMemberContactAsync cmdId acId subMode + joinMemberContactAsync cmdId acId (directPresHeader <$> binding_) subMode createInternalChatItem user (CDDirectSnd mCt) CIChatBanner (Just epochStart) createItems mCt m' | otherwise = do @@ -3928,9 +3968,9 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag createInternalChatItem user (CDDirectSnd mCt) CIChatBanner (Just epochStart) createInternalChatItem user (CDDirectRcv mCt) (CIRcvDirectEvent $ RDEGroupInvLinkReceived gp) Nothing createItems mCt m' - joinMemberContactAsync cmdId acId subMode = do + joinMemberContactAsync cmdId acId presHeader_ subMode = do -- [incognito] send membership incognito profile - p <- presentUserBadge user (incognitoMembershipProfile g) Nothing $ userProfileDirect user (fromLocalProfile <$> incognitoMembershipProfile g) Nothing True + p <- presentUserBadge user (incognitoMembershipProfile g) presHeader_ $ userProfileDirect user (fromLocalProfile <$> incognitoMembershipProfile g) Nothing True -- TODO PQ should negotitate contact connection with PQSupportOn? (use encodeConnInfoPQ) dm <- encodeConnInfo $ XInfo p Nothing joinAgentConnectionAsync cmdId False acId True connReq dm subMode @@ -4555,7 +4595,7 @@ runRelayRequestWorker a Worker {doWork} = do subMode <- chatReadVar subscriptionMode let crClientData = encodeJSON $ CRDataGroup groupLinkId -- prepare link with relayMemId as linkEntityId (no server request) - (ccLink, preparedParams) <- withAgent $ \a' -> prepareConnectionLink a' (aUserId user) sigKeys relayMemId True (Just crClientData) CR.IKPQOff False Nothing + (ccLink, preparedParams) <- withAgent $ \a' -> prepareConnectionLink a' (aUserId user) SCMContact sigKeys (Just relayMemId) True (Just crClientData) CR.IKPQOff False Nothing ccLink' <- setShortLinkType CCTGroup <$> shortenCreatedLink ccLink sLnk <- case connShortLink' ccLink' of Just sl -> pure sl @@ -4563,7 +4603,7 @@ runRelayRequestWorker a Worker {doWork} = do let userData = encodeShortLinkData $ RelayShortLinkData {relayProfile = fromLocalProfile p} userLinkData = UserContactLinkData UserContactData {direct = True, owners = [], relays = [], userData, ratchetKeys = Nothing} -- create connection with prepared link (single network call) - connId <- withAgent $ \a' -> createConnectionForLink a' NRMBackground (aUserId user) True ccLink preparedParams userLinkData subMode + (connId, _) <- withAgent $ \a' -> createConnectionForLink a' NRMBackground (aUserId user) True ccLink preparedParams userLinkData subMode -- TODO [relays] starting role should be communicated in protocol from owner to relays subRole <- asks $ channelSubscriberRole . config void $ withFastStore $ \db -> createGroupLink db gVar user gi connId ccLink' groupLinkId subRole subMode diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 4671a927d1..f73b713a9d 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -313,7 +313,7 @@ data AChatMessage = forall e. MsgEncodingI e => ACMsg (SMsgEncoding e) (ChatMess data KeyRef = KRMember deriving (Eq, Show) -data ChatBinding = CBGroup | CBDirect | CBChannel +data ChatBinding = CBGroup | CBDirect | CBChannel | CBLink deriving (Eq, Show) data MsgSignature = MsgSignature KeyRef C.ASignature @@ -410,11 +410,13 @@ instance Encoding ChatBinding where CBGroup -> "G" CBDirect -> "D" CBChannel -> "C" + CBLink -> "L" smpP = A.anyChar >>= \case 'G' -> pure CBGroup 'D' -> pure CBDirect 'C' -> pure CBChannel + 'L' -> pure CBLink c -> fail $ "invalid ChatBinding: " <> show c instance ToField ChatBinding where toField = toField . decodeLatin1 . smpEncode @@ -465,7 +467,7 @@ data ChatMsgEvent (e :: MsgEncoding) where XMember :: {profile :: Profile, newMemberId :: MemberId, newMemberKey :: MemberKey, viaRelay :: Maybe MemberId} -> ChatMsgEvent 'Json XDirectDel :: ChatMsgEvent 'Json XGrpInv :: GroupInvitation -> ChatMsgEvent 'Json - XGrpAcpt :: MemberId -> Maybe MemberKey -> ChatMsgEvent 'Json + XGrpAcpt :: MemberId -> Maybe MemberKey -> Maybe Profile -> ChatMsgEvent 'Json XGrpLinkInv :: GroupLinkInvitation -> ChatMsgEvent 'Json XGrpLinkReject :: GroupLinkRejection -> ChatMsgEvent 'Json XGrpLinkMem :: Profile -> Maybe MemberKey -> ChatMsgEvent 'Json @@ -1427,7 +1429,7 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do XMember_ -> XMember <$> p "profile" <*> p "newMemberId" <*> p "newMemberKey" <*> opt "viaRelay" XDirectDel_ -> pure XDirectDel XGrpInv_ -> XGrpInv <$> p "groupInvitation" - XGrpAcpt_ -> XGrpAcpt <$> p "memberId" <*> opt "memberKey" + XGrpAcpt_ -> XGrpAcpt <$> p "memberId" <*> opt "memberKey" <*> opt "profile" XGrpLinkInv_ -> XGrpLinkInv <$> p "groupLinkInvitation" XGrpLinkReject_ -> XGrpLinkReject <$> p "groupLinkRejection" XGrpLinkMem_ -> XGrpLinkMem <$> p "profile" <*> opt "memberKey" @@ -1503,7 +1505,7 @@ chatToAppMessage chatMsg@ChatMessage {chatVRange, msgId, chatMsgEvent} = case en XMember {profile, newMemberId, newMemberKey, viaRelay} -> o $ ("viaRelay" .=? viaRelay) ["profile" .= profile, "newMemberId" .= newMemberId, "newMemberKey" .= newMemberKey] XDirectDel -> JM.empty XGrpInv groupInv -> o ["groupInvitation" .= groupInv] - XGrpAcpt memId memberKey -> o $ ("memberKey" .=? memberKey) ["memberId" .= memId] + XGrpAcpt memId memberKey profile -> o $ ("profile" .=? profile) $ ("memberKey" .=? memberKey) ["memberId" .= memId] XGrpLinkInv groupLinkInv -> o ["groupLinkInvitation" .= groupLinkInv] XGrpLinkReject groupLinkRjct -> o ["groupLinkRejection" .= groupLinkRjct] XGrpLinkMem profile memberKey -> o $ ("memberKey" .=? memberKey) ["profile" .= profile] diff --git a/src/Simplex/Chat/Store/ContactRequest.hs b/src/Simplex/Chat/Store/ContactRequest.hs index 518d988106..12616a7d0a 100644 --- a/src/Simplex/Chat/Store/ContactRequest.hs +++ b/src/Simplex/Chat/Store/ContactRequest.hs @@ -24,7 +24,7 @@ import Control.Monad.IO.Class import Crypto.Random (ChaChaDRG) import Data.Int (Int64) import Data.Time.Clock (getCurrentTime) -import Simplex.Chat.Badges (badgeToRow, unboundProof, verifyBadge_) +import Simplex.Chat.Badges (ProofPresHeader, badgeToRow) import Simplex.Chat.Protocol (MsgContent, businessChatsVersion) import Simplex.Chat.Store.Direct import Simplex.Chat.Store.Groups @@ -57,6 +57,7 @@ createOrUpdateContactRequest :: Bool -> InvitationId -> VersionRangeChat -> + Maybe ProofPresHeader -> Profile -> Maybe XContactId -> Maybe SharedMsgId -> @@ -74,7 +75,8 @@ createOrUpdateContactRequest isSimplexTeam invId cReqChatVRange@(VersionRange minV maxV) - profile@Profile {displayName, fullName, shortDescr, description, image, contactLink, badge, preferences} + presHeader_ + profile@Profile {displayName, fullName, shortDescr, description, image, contactLink, preferences} xContactId_ welcomeMsgId_ requestMsg_ @@ -167,7 +169,7 @@ createOrUpdateContactRequest createContactRequest :: ExceptT StoreError IO RequestStage createContactRequest = do currentTs <- liftIO $ getCurrentTime - badgeVerified <- liftIO $ verifyBadge_ unboundProof (badgeKeys cxt) badge + (Profile {badge}, badgeVerified) <- liftIO $ profileBadgeVerified presHeader_ (badgeKeys cxt) Nothing profile ExceptT $ withLocalDisplayName db userId displayName $ \ldn -> runExceptT $ do liftIO $ DB.execute @@ -225,7 +227,7 @@ createOrUpdateContactRequest ucr <- getContactRequest db user contactRequestId pure $ RSCurrentRequest Nothing ucr (Just $ REBusinessChat gInfo clientMember) updateContactRequest :: UserContactRequest -> ExceptT StoreError IO RequestStage - updateContactRequest ucr@UserContactRequest {contactRequestId, contactId_, localDisplayName = oldLdn, profile = LocalProfile {displayName = oldDisplayName}} = do + updateContactRequest ucr@UserContactRequest {contactRequestId, contactId_, localDisplayName = oldLdn, profile = oldProfile@LocalProfile {displayName = oldDisplayName}} = do currentTs <- liftIO getCurrentTime liftIO $ updateProfile currentTs updateRequest currentTs @@ -234,7 +236,7 @@ createOrUpdateContactRequest pure $ RSCurrentRequest (Just ucr) ucr' re_ where updateProfile currentTs = do - badgeVerified <- liftIO $ verifyBadge_ unboundProof (badgeKeys cxt) badge + (Profile {badge}, badgeVerified) <- profileBadgeVerified presHeader_ (badgeKeys cxt) (Just oldProfile) profile DB.execute db [sql| diff --git a/src/Simplex/Chat/Store/Direct.hs b/src/Simplex/Chat/Store/Direct.hs index 20e9a37eed..b1cf98a9ce 100644 --- a/src/Simplex/Chat/Store/Direct.hs +++ b/src/Simplex/Chat/Store/Direct.hs @@ -108,7 +108,7 @@ import Data.Maybe (fromMaybe, isJust, isNothing) import Data.Text (Text) import Data.Time.Clock (UTCTime (..), getCurrentTime) import Data.Type.Equality -import Simplex.Chat.Badges (badgeToRow, unboundProof) +import Simplex.Chat.Badges (ProofPresHeader, badgeToRow) import Simplex.Chat.Messages import Simplex.Chat.Store.Shared import Simplex.Chat.Names (SimplexDomainClaim (..)) @@ -163,8 +163,8 @@ deletePendingContactConnection db userId connId = |] (userId, connId, ConnContact) -createConnReqConnection :: DB.Connection -> UserId -> ConnId -> Maybe PreparedChatEntity -> ConnReqContact -> ConnReqUriHash -> Maybe ShortLinkContact -> XContactId -> Maybe IncognitoProfile -> Maybe GroupLinkId -> SubscriptionMode -> VersionChat -> PQSupport -> IO Connection -createConnReqConnection db userId acId preparedEntity_ cReq cReqHash sLnk xContactId incognitoProfile groupLinkId subMode chatV pqSup = do +createConnReqConnection :: DB.Connection -> UserId -> ConnId -> Maybe PreparedChatEntity -> ConnReqContact -> ProofPresHeader -> ConnReqUriHash -> Maybe ShortLinkContact -> XContactId -> Maybe IncognitoProfile -> Maybe GroupLinkId -> SubscriptionMode -> VersionChat -> PQSupport -> IO Connection +createConnReqConnection db userId acId preparedEntity_ cReq presHeader cReqHash sLnk xContactId incognitoProfile groupLinkId subMode chatV pqSup = do currentTs <- getCurrentTime customUserProfileId <- forM incognitoProfile $ \case NewIncognito p -> createIncognitoProfile_ db userId currentTs p @@ -175,13 +175,13 @@ createConnReqConnection db userId acId preparedEntity_ cReq cReqHash sLnk xConta [sql| INSERT INTO connections ( user_id, agent_conn_id, conn_status, conn_type, contact_conn_initiated, - via_contact_uri, via_contact_uri_hash, via_short_link_contact, contact_id, group_member_id, + via_contact_uri, pres_header, via_contact_uri_hash, via_short_link_contact, contact_id, group_member_id, xcontact_id, custom_user_profile_id, via_group_link, group_link_id, created_at, updated_at, to_subscribe, conn_chat_version, pq_support, pq_encryption - ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) + ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) |] ( (userId, acId, connStatus, connType, BI True) - :. (cReq, cReqHash, sLnk, contactId_, groupMemberId_) + :. (cReq, presHeader, cReqHash, sLnk, contactId_, groupMemberId_) :. (xContactId, customUserProfileId, BI (isJust groupLinkId), groupLinkId) :. (currentTs, currentTs, BI (subMode == SMOnlyCreate), chatV, pqSup, pqSup) ) @@ -404,12 +404,12 @@ createIncognitoProfile db User {userId} p = do createdAt <- getCurrentTime createIncognitoProfile_ db userId createdAt p -createPreparedContact :: DB.Connection -> StoreCxt -> User -> Profile -> ACreatedConnLink -> Maybe SharedMsgId -> Maybe Bool -> ExceptT StoreError IO Contact -createPreparedContact db cxt user p connLinkToConnect welcomeSharedMsgId verified_ = do +createPreparedContact :: DB.Connection -> StoreCxt -> User -> Maybe ProofPresHeader -> Profile -> ACreatedConnLink -> Maybe SharedMsgId -> Maybe Bool -> ExceptT StoreError IO Contact +createPreparedContact db cxt user presHeader_ p connLinkToConnect welcomeSharedMsgId verified_ = do currentTs <- liftIO getCurrentTime let prepared = Just (connLinkToConnect, welcomeSharedMsgId) ctUserPreferences = newContactUserPrefs user p - ct <- getContact db cxt user =<< createContact_ db cxt user p ctUserPreferences prepared "" currentTs + ct <- getContact db cxt user =<< createContact_ db cxt user presHeader_ p ctUserPreferences prepared "" currentTs liftIO $ maybe (pure ct) (setContactDomainVerified db user ct) verified_ updatePreparedContactUser :: DB.Connection -> StoreCxt -> User -> Contact -> User -> ExceptT StoreError IO Contact @@ -450,11 +450,11 @@ updatePreparedContactUser safeDeleteLDN db user oldLDN getContact db cxt newUser contactId -createDirectContact :: DB.Connection -> StoreCxt -> User -> Connection -> Profile -> ExceptT StoreError IO Contact -createDirectContact db cxt user Connection {connId, localAlias} p = do +createDirectContact :: DB.Connection -> StoreCxt -> User -> Connection -> Maybe ProofPresHeader -> Profile -> ExceptT StoreError IO Contact +createDirectContact db cxt user Connection {connId, localAlias} presHeader_ p = do currentTs <- liftIO getCurrentTime let ctUserPreferences = newContactUserPrefs user p - contactId <- createContact_ db cxt user p ctUserPreferences Nothing localAlias currentTs + contactId <- createContact_ db cxt user presHeader_ p ctUserPreferences Nothing localAlias currentTs liftIO $ DB.execute db "UPDATE connections SET contact_id = ?, updated_at = ? WHERE connection_id = ?" (contactId, currentTs, connId) getContact db cxt user contactId @@ -562,13 +562,13 @@ deleteUnusedProfile_ db userId profileId = :. (userId, profileId, userId, profileId, profileId) ) -updateContactProfile :: DB.Connection -> StoreCxt -> User -> Contact -> Profile -> ExceptT StoreError IO Contact -updateContactProfile db cxt user@User {userId} c p' = do +updateContactProfile :: DB.Connection -> StoreCxt -> User -> Contact -> Maybe ProofPresHeader -> Profile -> ExceptT StoreError IO Contact +updateContactProfile db cxt user@User {userId} c presHeader_ p' = do currentTs <- liftIO getCurrentTime - badgeVerified <- liftIO $ profileBadgeVerified unboundProof (badgeKeys cxt) lp p' + (p''', badgeVerified) <- liftIO $ profileBadgeVerified presHeader_ (badgeKeys cxt) (Just lp) p'' let nameVerified = if claimChanged then Nothing else prevVerification - profile = toLocalProfile profileId p'' localAlias currentTs badgeVerified nameVerified - updateContactProfile' currentTs badgeVerified profile + profile = toLocalProfile profileId p''' localAlias currentTs badgeVerified nameVerified + updateContactProfile' currentTs p''' badgeVerified profile where Contact {contactId, localDisplayName, profile = lp@LocalProfile {profileId, displayName, localAlias, contactDomain = prevClaim, contactDomainVerified = prevVerification}, userPreferences} = c Profile {displayName = newName, contactDomain, preferences} = p' @@ -578,14 +578,14 @@ updateContactProfile db cxt user@User {userId} c p' = do clearVerificationIfClaimChanged = when claimChanged $ DB.execute db "UPDATE contact_profiles SET contact_domain_verified = NULL WHERE user_id = ? AND contact_profile_id = ?" (userId, profileId) - updateContactProfile' currentTs badgeVerified profile + updateContactProfile' currentTs p''' badgeVerified profile | displayName == newName = do - liftIO $ updateContactProfile_' db userId profileId p'' badgeVerified currentTs + liftIO $ updateContactProfile_' db userId profileId p''' badgeVerified currentTs liftIO clearVerificationIfClaimChanged pure c {profile, mergedPreferences} | otherwise = ExceptT . withLocalDisplayName db userId newName $ \ldn -> do - updateContactProfile_' db userId profileId p'' badgeVerified currentTs + updateContactProfile_' db userId profileId p''' badgeVerified currentTs updateContactLDN_ db user contactId localDisplayName ldn currentTs clearVerificationIfClaimChanged pure $ Right c {localDisplayName = ldn, profile, mergedPreferences} diff --git a/src/Simplex/Chat/Store/Groups.hs b/src/Simplex/Chat/Store/Groups.hs index 99cbd379a6..d7465a8aac 100644 --- a/src/Simplex/Chat/Store/Groups.hs +++ b/src/Simplex/Chat/Store/Groups.hs @@ -230,7 +230,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (NominalDiffTime, UTCTime (..), addUTCTime, getCurrentTime) import Data.Text.Encoding (encodeUtf8) -import Simplex.Chat.Badges (BadgeRow, badgeToRow, boundProof, verifyBadge_) +import Simplex.Chat.Badges (BadgeRow, ProofPresHeader, badgeToRow) import Simplex.Chat.Names (SimplexDomainClaim (..)) import Simplex.Chat.Messages import Simplex.Chat.Operators @@ -677,7 +677,7 @@ createPreparedGroup db gVar cxt user@User {userId, userContactId} groupProfile b randHostId <- liftIO $ encodedRandomBytes gVar 12 let memberId = MemberId $ encodeUtf8 groupLDN <> "_unknown_host_" <> randHostId hostProfile = profileFromName $ nameFromBS randHostId - (localDisplayName, profileId, _) <- createNewMemberProfile_ db cxt user hostProfile Nothing currentTs + (localDisplayName, profileId, _, _) <- createNewMemberProfile_ db cxt user hostProfile Nothing currentTs indexInGroup <- getUpdateNextIndexInGroup_ db groupId liftIO $ do DB.execute @@ -885,7 +885,7 @@ createGroupViaLink' (,) <$> getGroupInfo db cxt user groupId <*> getGroupMemberById db cxt user hostMemberId where insertHost_ currentTs groupId = do - (localDisplayName, profileId, _) <- createNewMemberProfile_ db cxt user fromMemberProfile Nothing currentTs + (localDisplayName, profileId, _, _) <- createNewMemberProfile_ db cxt user fromMemberProfile Nothing currentTs let MemberIdRole {memberId, memberRole} = fromMember indexInGroup <- getUpdateNextIndexInGroup_ db groupId liftIO $ do @@ -1713,7 +1713,7 @@ createRelayForOwner :: DB.Connection -> StoreCxt -> TVar ChaChaDRG -> User -> Gr createRelayForOwner db cxt gVar user@User {userId, userContactId} GroupInfo {groupId, membership} UserChatRelay {relayProfile = RelayProfile {displayName}} = do currentTs <- liftIO getCurrentTime let relayProfile = profileFromName displayName - (localDisplayName, memProfileId, _) <- createNewMemberProfile_ db cxt user relayProfile Nothing currentTs + (localDisplayName, memProfileId, _, _) <- createNewMemberProfile_ db cxt user relayProfile Nothing currentTs groupMemberId <- createWithRandomId' db gVar $ \memId -> runExceptT $ do indexInGroup <- getUpdateNextIndexInGroup_ db groupId liftIO $ @@ -1752,7 +1752,7 @@ getCreateRelayForMember db cxt gVar user@User {userId, userContactId} GroupInfo randRelayId <- liftIO $ encodedRandomBytes gVar 12 let memberId = MemberId $ encodeUtf8 groupLDN <> "_unknown_relay_" <> randRelayId relayProfile = profileFromName $ nameFromBS randRelayId - (localDisplayName, profileId, _) <- createNewMemberProfile_ db cxt user relayProfile Nothing currentTs + (localDisplayName, profileId, _, _) <- createNewMemberProfile_ db cxt user relayProfile Nothing currentTs indexInGroup <- getUpdateNextIndexInGroup_ db groupId groupMemberId <- liftIO $ do DB.execute @@ -1805,8 +1805,8 @@ updateRelayStatus_ db relayId relayStatus = do currentTs <- getCurrentTime DB.execute db "UPDATE group_relays SET relay_status = ?, updated_at = ? WHERE group_relay_id = ?" (relayStatus, currentTs, relayId) -setRelayLinkAccepted :: DB.Connection -> StoreCxt -> User -> GroupMember -> MemberKey -> Maybe ByteString -> Profile -> ExceptT StoreError IO (GroupMember, GroupRelay) -setRelayLinkAccepted db cxt user m (MemberKey relayKey) binding_ profile = do +setRelayLinkAccepted :: DB.Connection -> StoreCxt -> User -> GroupMember -> MemberKey -> Maybe ProofPresHeader -> Profile -> ExceptT StoreError IO (GroupMember, GroupRelay) +setRelayLinkAccepted db cxt user m (MemberKey relayKey) presHeader_ profile = do let gmId = groupMemberId' m currentTs <- liftIO getCurrentTime liftIO $ DB.execute @@ -1825,7 +1825,7 @@ setRelayLinkAccepted db cxt user m (MemberKey relayKey) binding_ profile = do WHERE group_member_id = ? |] (relayKey, currentTs, gmId) - void $ updateMemberProfile db cxt user m binding_ profile + void $ updateMemberProfile db cxt user m presHeader_ profile (,) <$> getGroupMemberById db cxt user gmId <*> getGroupRelayByGMId db gmId setRelayLinkConfId :: DB.Connection -> GroupMember -> ConfirmationId -> ShortLinkContact -> IO () @@ -1872,8 +1872,8 @@ getRelayConfId db m = |] (Only (groupMemberId' m)) -updateRelayMemberData :: DB.Connection -> StoreCxt -> User -> GroupMember -> MemberId -> MemberKey -> Maybe ByteString -> Profile -> ExceptT StoreError IO () -updateRelayMemberData db cxt user m memberId (MemberKey relayKey) binding_ profile = do +updateRelayMemberData :: DB.Connection -> StoreCxt -> User -> GroupMember -> MemberId -> MemberKey -> Maybe ProofPresHeader -> Profile -> ExceptT StoreError IO () +updateRelayMemberData db cxt user m memberId (MemberKey relayKey) presHeader_ profile = do currentTs <- liftIO getCurrentTime liftIO $ DB.execute @@ -1884,7 +1884,7 @@ updateRelayMemberData db cxt user m memberId (MemberKey relayKey) binding_ profi WHERE group_member_id = ? |] (memberId, relayKey, currentTs, groupMemberId' m) - void $ updateMemberProfile db cxt user m binding_ profile + void $ updateMemberProfile db cxt user m presHeader_ profile setGroupInProgressDone :: DB.Connection -> GroupInfo -> IO () setGroupInProgressDone db GroupInfo {groupId} = do @@ -1937,7 +1937,7 @@ createRelayRequestGroup db cxt user@User {userId} GroupRelayInvitation {fromMemb insertOwner_ currentTs groupId = do let MemberIdRole {memberId, memberRole} = fromMember VersionRange minV maxV = reqChatVRange - (localDisplayName, profileId, _) <- createNewMemberProfile_ db cxt user fromMemberProfile Nothing currentTs + (localDisplayName, profileId, _, _) <- createNewMemberProfile_ db cxt user fromMemberProfile Nothing currentTs indexInGroup <- getUpdateNextIndexInGroup_ db groupId liftIO $ do DB.execute @@ -2066,7 +2066,7 @@ getRelayInactiveGroups db cxt User {userId, userContactId} ttl = do ) (userId, userContactId, RSInactive, cutoffTs) -createJoiningMember :: DB.Connection -> StoreCxt -> TVar ChaChaDRG -> User -> GroupInfo -> VersionRangeChat -> Profile -> Maybe ByteString -> Maybe XContactId -> Maybe MemberId -> Maybe SharedMsgId -> GroupMemberRole -> GroupMemberStatus -> Maybe MemberKey -> ExceptT StoreError IO (GroupMemberId, MemberId) +createJoiningMember :: DB.Connection -> StoreCxt -> TVar ChaChaDRG -> User -> GroupInfo -> VersionRangeChat -> Profile -> Maybe ProofPresHeader -> Maybe XContactId -> Maybe MemberId -> Maybe SharedMsgId -> GroupMemberRole -> GroupMemberStatus -> Maybe MemberKey -> ExceptT StoreError IO (GroupMemberId, MemberId) createJoiningMember db cxt @@ -2074,8 +2074,8 @@ createJoiningMember User {userId, userContactId} GroupInfo {groupId, membership} cReqChatVRange - Profile {displayName, fullName, shortDescr, description, image, contactLink, badge, preferences} - binding_ + p@Profile {displayName, fullName, shortDescr, description, image, contactLink, preferences} + presHeader_ cReqXContactId_ cReqMemberId_ welcomeMsgId_ @@ -2083,7 +2083,7 @@ createJoiningMember memberStatus memberKey_ = do currentTs <- liftIO getCurrentTime - badgeVerified <- liftIO $ verifyBadge_ (boundProof binding_) (badgeKeys cxt) badge + (Profile {badge}, badgeVerified) <- liftIO $ profileBadgeVerified presHeader_ (badgeKeys cxt) Nothing p ExceptT . withLocalDisplayName db userId displayName $ \ldn -> runExceptT $ do liftIO $ DB.execute @@ -2417,13 +2417,13 @@ increaseGroupMembersRequireAttention db User {userId} g@GroupInfo {groupId, memb pure g {membersRequireAttention = membersRequireAttention + 1} -- | add new member with profile -createNewGroupMember :: DB.Connection -> StoreCxt -> User -> GroupInfo -> GroupMember -> MemberInfo -> Maybe ByteString -> GroupMemberCategory -> GroupMemberStatus -> ExceptT StoreError IO GroupMember -createNewGroupMember db cxt user gInfo invitingMember memInfo@MemberInfo {profile} binding_ memCategory memStatus = do +createNewGroupMember :: DB.Connection -> StoreCxt -> User -> GroupInfo -> GroupMember -> MemberInfo -> Maybe ProofPresHeader -> GroupMemberCategory -> GroupMemberStatus -> ExceptT StoreError IO GroupMember +createNewGroupMember db cxt user gInfo invitingMember memInfo@MemberInfo {profile} presHeader_ memCategory memStatus = do currentTs <- liftIO getCurrentTime - (localDisplayName, memProfileId, badgeVerified) <- createNewMemberProfile_ db cxt user profile binding_ currentTs + (localDisplayName, memProfileId, memProfile, badgeVerified) <- createNewMemberProfile_ db cxt user profile presHeader_ currentTs let newMember = NewGroupMember - { memInfo, + { memInfo = (memInfo :: MemberInfo) {profile = memProfile}, memCategory, memStatus, memRestriction = Nothing, @@ -2435,16 +2435,16 @@ createNewGroupMember db cxt user gInfo invitingMember memInfo@MemberInfo {profil } createNewMember_ db user gInfo newMember badgeVerified currentTs -createNewMemberProfile_ :: DB.Connection -> StoreCxt -> User -> Profile -> Maybe ByteString -> UTCTime -> ExceptT StoreError IO (Text, ProfileId, Maybe Bool) -createNewMemberProfile_ db cxt User {userId} Profile {displayName, fullName, shortDescr, description, image, contactLink, badge, preferences} binding_ createdAt = +createNewMemberProfile_ :: DB.Connection -> StoreCxt -> User -> Profile -> Maybe ProofPresHeader -> UTCTime -> ExceptT StoreError IO (Text, ProfileId, Profile, Maybe Bool) +createNewMemberProfile_ db cxt User {userId} p@Profile {displayName, fullName, shortDescr, description, image, contactLink, preferences} presHeader_ createdAt = ExceptT . withLocalDisplayName db userId displayName $ \ldn -> do - badgeVerified <- verifyBadge_ (boundProof binding_) (badgeKeys cxt) badge + (p'@Profile {badge}, badgeVerified) <- profileBadgeVerified presHeader_ (badgeKeys cxt) Nothing p DB.execute db "INSERT INTO contact_profiles (display_name, full_name, short_descr, description, image, contact_link, user_id, created_at, updated_at, badge_proof, badge_pres_header, badge_expiry, badge_type, badge_verified, badge_extra, badge_master_key, badge_signature, badge_key_idx, preferences, preferences_json) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)" ((displayName, fullName, shortDescr, description, image, contactLink, userId, createdAt, createdAt) :. badgeToRow badge badgeVerified :. prefsToRow preferences) profileId <- insertedRowId db - pure $ Right (ldn, profileId, badgeVerified) + pure $ Right (ldn, profileId, p', badgeVerified) createNewMember_ :: DB.Connection -> User -> GroupInfo -> NewGroupMember -> Maybe Bool -> UTCTime -> ExceptT StoreError IO GroupMember createNewMember_ @@ -2615,19 +2615,19 @@ getMemberRelationsVector db GroupMember {groupMemberId} = "SELECT member_relations_vector FROM group_members WHERE group_member_id = ?" (Only groupMemberId) -createIntroReMember :: DB.Connection -> StoreCxt -> User -> GroupInfo -> MemberInfo -> Maybe ByteString -> Maybe MemberRestrictions -> ExceptT StoreError IO GroupMember +createIntroReMember :: DB.Connection -> StoreCxt -> User -> GroupInfo -> MemberInfo -> Maybe ProofPresHeader -> Maybe MemberRestrictions -> ExceptT StoreError IO GroupMember createIntroReMember db cxt user gInfo - memInfo@(MemberInfo _ _ _ memberProfile _) - binding_ + (MemberInfo memId memRole memChatVRange memberProfile memKey) + presHeader_ memRestrictions_ = do currentTs <- liftIO getCurrentTime - (localDisplayName, memProfileId, badgeVerified) <- createNewMemberProfile_ db cxt user memberProfile binding_ currentTs + (localDisplayName, memProfileId, memberProfile', badgeVerified) <- createNewMemberProfile_ db cxt user memberProfile presHeader_ currentTs let memRestriction = restriction <$> memRestrictions_ - newMember = NewGroupMember {memInfo, memCategory = GCPreMember, memStatus = GSMemIntroduced, memRestriction, memInvitedBy = IBUnknown, memInvitedByGroupMemberId = Nothing, localDisplayName, memContactId = Nothing, memProfileId} + newMember = NewGroupMember {memInfo = MemberInfo memId memRole memChatVRange memberProfile' memKey, memCategory = GCPreMember, memStatus = GSMemIntroduced, memRestriction, memInvitedBy = IBUnknown, memInvitedByGroupMemberId = Nothing, localDisplayName, memContactId = Nothing, memProfileId} createNewMember_ db user gInfo newMember badgeVerified currentTs createIntroReMemberConn :: DB.Connection -> User -> GroupMember -> GroupMember -> VersionChat -> MemberInfo -> (CommandId, ConnId) -> SubscriptionMode -> ExceptT StoreError IO GroupMember @@ -3413,16 +3413,16 @@ setMemberContactStartedConnection db Contact {contactId} = do "UPDATE contacts SET grp_direct_inv_started_connection = ?, updated_at = ? WHERE contact_id = ?" (BI True, currentTs, contactId) -updateMemberProfile :: DB.Connection -> StoreCxt -> User -> GroupMember -> Maybe ByteString -> Profile -> ExceptT StoreError IO GroupMember -updateMemberProfile db cxt user@User {userId} m binding_ p' = do +updateMemberProfile :: DB.Connection -> StoreCxt -> User -> GroupMember -> Maybe ProofPresHeader -> Profile -> ExceptT StoreError IO GroupMember +updateMemberProfile db cxt user@User {userId} m presHeader_ p = do currentTs <- liftIO getCurrentTime - badgeVerified <- liftIO $ profileBadgeVerified (boundProof binding_) (badgeKeys cxt) (memberProfile m) p' + (p', badgeVerified) <- liftIO $ profileBadgeVerified presHeader_ (badgeKeys cxt) (Just $ memberProfile m) p let memberProfile = toLocalProfile profileId p' localAlias currentTs badgeVerified Nothing - updateMemberProfile' currentTs badgeVerified memberProfile + updateMemberProfile' currentTs p' badgeVerified memberProfile where GroupMember {groupMemberId, localDisplayName, memberProfile = LocalProfile {profileId, displayName, localAlias}} = m - Profile {displayName = newName} = p' - updateMemberProfile' currentTs badgeVerified memberProfile + Profile {displayName = newName} = p + updateMemberProfile' currentTs p' badgeVerified memberProfile | displayName == newName = do liftIO $ updateMemberContactProfileReset_' db userId profileId p' badgeVerified currentTs pure m {memberProfile} @@ -3436,16 +3436,16 @@ updateMemberProfile db cxt user@User {userId} m binding_ p' = do safeDeleteLDN db user localDisplayName pure $ Right m {localDisplayName = ldn, memberProfile} -updateContactMemberProfile :: DB.Connection -> StoreCxt -> User -> GroupMember -> Contact -> Maybe ByteString -> Profile -> ExceptT StoreError IO (GroupMember, Contact) -updateContactMemberProfile db cxt user@User {userId} m ct@Contact {contactId} binding_ p' = do +updateContactMemberProfile :: DB.Connection -> StoreCxt -> User -> GroupMember -> Contact -> Maybe ProofPresHeader -> Profile -> ExceptT StoreError IO (GroupMember, Contact) +updateContactMemberProfile db cxt user@User {userId} m ct@Contact {contactId} presHeader_ p = do currentTs <- liftIO getCurrentTime - badgeVerified <- liftIO $ profileBadgeVerified (boundProof binding_) (badgeKeys cxt) (memberProfile m) p' + (p', badgeVerified) <- liftIO $ profileBadgeVerified presHeader_ (badgeKeys cxt) (Just $ memberProfile m) p let profile = toLocalProfile profileId p' localAlias currentTs badgeVerified Nothing - updateContactMemberProfile' currentTs badgeVerified profile + updateContactMemberProfile' currentTs p' badgeVerified profile where GroupMember {localDisplayName, memberProfile = LocalProfile {profileId, displayName, localAlias}} = m - Profile {displayName = newName} = p' - updateContactMemberProfile' currentTs badgeVerified profile + Profile {displayName = newName} = p + updateContactMemberProfile' currentTs p' badgeVerified profile | displayName == newName = do liftIO $ updateMemberContactProfile_' db userId profileId p' badgeVerified currentTs pure (m {memberProfile = profile}, ct {profile} :: Contact) @@ -3472,7 +3472,7 @@ createNewUnknownGroupMember :: DB.Connection -> StoreCxt -> User -> GroupInfo -> createNewUnknownGroupMember db cxt user@User {userId, userContactId} GroupInfo {groupId} memberId memberName unknownMemberRole = do currentTs <- liftIO getCurrentTime let memberProfile = profileFromName memberName - (localDisplayName, profileId, _) <- createNewMemberProfile_ db cxt user memberProfile Nothing currentTs + (localDisplayName, profileId, _, _) <- createNewMemberProfile_ db cxt user memberProfile Nothing currentTs indexInGroup <- getUpdateNextIndexInGroup_ db groupId liftIO $ DB.execute @@ -3497,7 +3497,7 @@ createLinkOwnerMember :: DB.Connection -> StoreCxt -> User -> GroupInfo -> Maybe createLinkOwnerMember db cxt user@User {userId, userContactId} GroupInfo {groupId} contactId_ memberId ownerKey = do currentTs <- liftIO getCurrentTime let memberProfile = profileFromName $ nameFromMemberId memberId - (localDisplayName, profileId, _) <- createNewMemberProfile_ db cxt user memberProfile Nothing currentTs + (localDisplayName, profileId, _, _) <- createNewMemberProfile_ db cxt user memberProfile Nothing currentTs indexInGroup <- getUpdateNextIndexInGroup_ db groupId liftIO $ DB.execute @@ -3521,9 +3521,9 @@ createLinkOwnerMember db cxt user@User {userId, userContactId} GroupInfo {groupI -- Intro refreshes only profile / status / peer version. Role and key stay owner-authoritative -- (the owner-signed roster for members/moderators/admins, link data for owners), so taking either from -- an in-band relayed intro would let a compromised relay substitute them. -updatePreparedChannelMember :: DB.Connection -> StoreCxt -> User -> GroupMember -> MemberInfo -> Maybe ByteString -> ExceptT StoreError IO GroupMember -updatePreparedChannelMember db cxt user@User {userId} member@GroupMember {groupMemberId, memberChatVRange} MemberInfo {v, profile} binding_ = do - _ <- updateMemberProfile db cxt user member binding_ profile +updatePreparedChannelMember :: DB.Connection -> StoreCxt -> User -> GroupMember -> MemberInfo -> Maybe ProofPresHeader -> ExceptT StoreError IO GroupMember +updatePreparedChannelMember db cxt user@User {userId} member@GroupMember {groupMemberId, memberChatVRange} MemberInfo {v, profile} presHeader_ = do + _ <- updateMemberProfile db cxt user member presHeader_ profile currentTs <- liftIO getCurrentTime liftIO $ DB.execute @@ -3541,9 +3541,9 @@ updatePreparedChannelMember db cxt user@User {userId} member@GroupMember {groupM where VersionRange minV maxV = maybe memberChatVRange fromChatVRange v -updateUnknownMemberAnnounced :: DB.Connection -> StoreCxt -> User -> GroupMember -> GroupMember -> MemberInfo -> Maybe ByteString -> GroupMemberStatus -> ExceptT StoreError IO GroupMember -updateUnknownMemberAnnounced db cxt user@User {userId} invitingMember unknownMember@GroupMember {groupMemberId, memberChatVRange} MemberInfo {memberRole, v, profile, memberKey} binding_ status = do - _ <- updateMemberProfile db cxt user unknownMember binding_ profile +updateUnknownMemberAnnounced :: DB.Connection -> StoreCxt -> User -> GroupMember -> GroupMember -> MemberInfo -> Maybe ProofPresHeader -> GroupMemberStatus -> ExceptT StoreError IO GroupMember +updateUnknownMemberAnnounced db cxt user@User {userId} invitingMember unknownMember@GroupMember {groupMemberId, memberChatVRange} MemberInfo {memberRole, v, profile, memberKey} presHeader_ status = do + _ <- updateMemberProfile db cxt user unknownMember presHeader_ profile currentTs <- liftIO getCurrentTime liftIO $ DB.execute @@ -3570,9 +3570,9 @@ updateUnknownMemberAnnounced db cxt user@User {userId} invitingMember unknownMem -- Like updateUnknownMemberAnnounced but preserves member_role and member_pub_key -- (roster-established for moderators/admins; the dissemination carries only the profile). -updateRosterMemberAnnounced :: DB.Connection -> StoreCxt -> User -> GroupMember -> GroupMember -> MemberInfo -> Maybe ByteString -> GroupMemberStatus -> ExceptT StoreError IO GroupMember -updateRosterMemberAnnounced db cxt user@User {userId} invitingMember unknownMember@GroupMember {groupMemberId, memberChatVRange} MemberInfo {v, profile} binding_ status = do - _ <- updateMemberProfile db cxt user unknownMember binding_ profile +updateRosterMemberAnnounced :: DB.Connection -> StoreCxt -> User -> GroupMember -> GroupMember -> MemberInfo -> Maybe ProofPresHeader -> GroupMemberStatus -> ExceptT StoreError IO GroupMember +updateRosterMemberAnnounced db cxt user@User {userId} invitingMember unknownMember@GroupMember {groupMemberId, memberChatVRange} MemberInfo {v, profile} presHeader_ status = do + _ <- updateMemberProfile db cxt user unknownMember presHeader_ profile currentTs <- liftIO getCurrentTime liftIO $ DB.execute diff --git a/src/Simplex/Chat/Store/Postgres/Migrations.hs b/src/Simplex/Chat/Store/Postgres/Migrations.hs index 24ed45c9a9..392d499dde 100644 --- a/src/Simplex/Chat/Store/Postgres/Migrations.hs +++ b/src/Simplex/Chat/Store/Postgres/Migrations.hs @@ -53,6 +53,7 @@ import Simplex.Chat.Store.Postgres.Migrations.M20260904_file_badges import Simplex.Chat.Store.Postgres.Migrations.M20260915_user_badges import Simplex.Chat.Store.Postgres.Migrations.M20260918_badge_issue_errors import Simplex.Chat.Store.Postgres.Migrations.M20260923_preferences_json +import Simplex.Chat.Store.Postgres.Migrations.M20260924_conn_pres_header import Simplex.Messaging.Agent.Store.Shared (Migration (..)) schemaMigrations :: [(String, Text, Maybe Text)] @@ -105,7 +106,8 @@ schemaMigrations = ("20260904_file_badges", m20260904_file_badges, Just down_m20260904_file_badges), ("20260915_user_badges", m20260915_user_badges, Just down_m20260915_user_badges), ("20260918_badge_issue_errors", m20260918_badge_issue_errors, Just down_m20260918_badge_issue_errors), - ("20260923_preferences_json", m20260923_preferences_json, Just down_m20260923_preferences_json) + ("20260923_preferences_json", m20260923_preferences_json, Just down_m20260923_preferences_json), + ("20260924_conn_pres_header", m20260924_conn_pres_header, Just down_m20260924_conn_pres_header) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Chat/Store/Postgres/Migrations/M20260924_conn_pres_header.hs b/src/Simplex/Chat/Store/Postgres/Migrations/M20260924_conn_pres_header.hs new file mode 100644 index 0000000000..906947417f --- /dev/null +++ b/src/Simplex/Chat/Store/Postgres/Migrations/M20260924_conn_pres_header.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Store.Postgres.Migrations.M20260924_conn_pres_header where + +import Data.Text (Text) +import Text.RawString.QQ (r) + +m20260924_conn_pres_header :: Text +m20260924_conn_pres_header = + [r| +ALTER TABLE connections ADD COLUMN pres_header BYTEA; +|] + +down_m20260924_conn_pres_header :: Text +down_m20260924_conn_pres_header = + [r| +ALTER TABLE connections DROP COLUMN pres_header; +|] diff --git a/src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql b/src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql index ad975874db..78f41ae410 100644 --- a/src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql @@ -618,7 +618,8 @@ CREATE TABLE test_chat_schema.connections ( short_link_inv bytea, via_short_link_contact bytea, via_contact_uri bytea, - relay_test smallint DEFAULT 0 NOT NULL + relay_test smallint DEFAULT 0 NOT NULL, + pres_header bytea ); diff --git a/src/Simplex/Chat/Store/SQLite/Migrations.hs b/src/Simplex/Chat/Store/SQLite/Migrations.hs index 4dcefa1598..1bb05c4e94 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations.hs +++ b/src/Simplex/Chat/Store/SQLite/Migrations.hs @@ -176,6 +176,7 @@ import Simplex.Chat.Store.SQLite.Migrations.M20260904_file_badges import Simplex.Chat.Store.SQLite.Migrations.M20260915_user_badges import Simplex.Chat.Store.SQLite.Migrations.M20260918_badge_issue_errors import Simplex.Chat.Store.SQLite.Migrations.M20260923_preferences_json +import Simplex.Chat.Store.SQLite.Migrations.M20260924_conn_pres_header import Simplex.Messaging.Agent.Store.Shared (Migration (..)) schemaMigrations :: [(String, Query, Maybe Query)] @@ -351,7 +352,8 @@ schemaMigrations = ("20260904_file_badges", m20260904_file_badges, Just down_m20260904_file_badges), ("20260915_user_badges", m20260915_user_badges, Just down_m20260915_user_badges), ("20260918_badge_issue_errors", m20260918_badge_issue_errors, Just down_m20260918_badge_issue_errors), - ("20260923_preferences_json", m20260923_preferences_json, Just down_m20260923_preferences_json) + ("20260923_preferences_json", m20260923_preferences_json, Just down_m20260923_preferences_json), + ("20260924_conn_pres_header", m20260924_conn_pres_header, Just down_m20260924_conn_pres_header) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/M20260924_conn_pres_header.hs b/src/Simplex/Chat/Store/SQLite/Migrations/M20260924_conn_pres_header.hs new file mode 100644 index 0000000000..1fe55dc3cc --- /dev/null +++ b/src/Simplex/Chat/Store/SQLite/Migrations/M20260924_conn_pres_header.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Store.SQLite.Migrations.M20260924_conn_pres_header where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20260924_conn_pres_header :: Query +m20260924_conn_pres_header = + [sql| +ALTER TABLE connections ADD COLUMN pres_header BLOB; +|] + +down_m20260924_conn_pres_header :: Query +down_m20260924_conn_pres_header = + [sql| +ALTER TABLE connections DROP COLUMN pres_header; +|] 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 152d6c0c8d..b3fc1569b8 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt +++ b/src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt @@ -5006,10 +5006,10 @@ Plan: Query: INSERT INTO connections ( user_id, agent_conn_id, conn_status, conn_type, contact_conn_initiated, - via_contact_uri, via_contact_uri_hash, via_short_link_contact, contact_id, group_member_id, + via_contact_uri, pres_header, via_contact_uri_hash, via_short_link_contact, contact_id, group_member_id, xcontact_id, custom_user_profile_id, via_group_link, group_link_id, created_at, updated_at, to_subscribe, conn_chat_version, pq_support, pq_encryption - ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) + ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) Plan: @@ -7592,6 +7592,10 @@ Query: SELECT issue_failed_since, issue_error FROM badge_purchases Plan: SCAN badge_purchases +Query: SELECT item_content FROM chat_items ORDER BY chat_item_id DESC LIMIT 1 +Plan: +SCAN chat_items + Query: SELECT last_insert_rowid() Plan: SCAN CONSTANT ROW @@ -7768,7 +7772,7 @@ Query: SELECT user_id FROM users WHERE local_display_name = ? Plan: SEARCH users USING COVERING INDEX sqlite_autoindex_users_2 (local_display_name=?) -Query: SELECT via_contact_uri FROM connections WHERE connection_id = ? +Query: SELECT via_contact_uri, pres_header FROM connections WHERE connection_id = ? Plan: SEARCH connections USING INTEGER PRIMARY KEY (rowid=?) @@ -8220,6 +8224,10 @@ Query: UPDATE usage_conditions SET notified_at = ? WHERE usage_conditions_id = ? Plan: SEARCH usage_conditions USING INTEGER PRIMARY KEY (rowid=?) +Query: UPDATE user_contact_links SET short_link_contact = NULL +Plan: +SCAN user_contact_links + Query: UPDATE users SET active_user = 0 Plan: SCAN users diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql b/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql index 995497d5ee..d66848e42a 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql @@ -390,6 +390,7 @@ CREATE TABLE connections( via_short_link_contact BLOB, via_contact_uri BLOB, relay_test INTEGER NOT NULL DEFAULT 0, + pres_header BLOB, FOREIGN KEY(snd_file_id, connection_id) REFERENCES snd_files(file_id, connection_id) ON DELETE CASCADE diff --git a/src/Simplex/Chat/Store/Shared.hs b/src/Simplex/Chat/Store/Shared.hs index aa8029ab4e..4f0c0b6589 100644 --- a/src/Simplex/Chat/Store/Shared.hs +++ b/src/Simplex/Chat/Store/Shared.hs @@ -32,7 +32,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (UTCTime (..), getCurrentTime) import Data.Type.Equality -import Simplex.Chat.Badges (BadgeRow, badgeToRow, rowToBadge, unboundProof, verifyBadge_) +import Simplex.Chat.Badges (BadgeRow, ProofPresHeader, badgeToRow, rowToBadge) import Simplex.Chat.Names (SimplexDomainProof, SimplexDomainClaim (..), claimDomain) import Simplex.Chat.Messages import Simplex.Chat.Remote.Types @@ -413,12 +413,12 @@ setCommandConnId db User {userId} cmdId connId = do createContact :: DB.Connection -> StoreCxt -> User -> Profile -> ExceptT StoreError IO () createContact db cxt user profile = do currentTs <- liftIO getCurrentTime - void $ createContact_ db cxt user profile emptyChatPrefs Nothing "" currentTs + void $ createContact_ db cxt user Nothing profile emptyChatPrefs Nothing "" currentTs -createContact_ :: DB.Connection -> StoreCxt -> User -> Profile -> Preferences -> Maybe (ACreatedConnLink, Maybe SharedMsgId) -> LocalAlias -> UTCTime -> ExceptT StoreError IO ContactId -createContact_ db cxt User {userId} Profile {displayName, fullName, shortDescr, description, image, contactLink, contactDomain, peerType, badge, preferences} ctUserPreferences prepared localAlias currentTs = +createContact_ :: DB.Connection -> StoreCxt -> User -> Maybe ProofPresHeader -> Profile -> Preferences -> Maybe (ACreatedConnLink, Maybe SharedMsgId) -> LocalAlias -> UTCTime -> ExceptT StoreError IO ContactId +createContact_ db cxt User {userId} presHeader_ p@Profile {displayName, fullName, shortDescr, description, image, contactLink, contactDomain, peerType, preferences} ctUserPreferences prepared localAlias currentTs = ExceptT . withLocalDisplayName db userId displayName $ \ldn -> do - badgeVerified <- verifyBadge_ unboundProof (badgeKeys cxt) badge + (Profile {badge}, badgeVerified) <- profileBadgeVerified presHeader_ (badgeKeys cxt) Nothing p DB.execute db "INSERT INTO contact_profiles (display_name, full_name, short_descr, description, image, contact_link, chat_peer_type, user_id, local_alias, created_at, updated_at, badge_proof, badge_pres_header, badge_expiry, badge_type, badge_verified, badge_extra, badge_master_key, badge_signature, badge_key_idx, contact_domain, contact_domain_proof, preferences, preferences_json) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)" @@ -588,12 +588,12 @@ getConnReqInv db connId = "SELECT conn_req_inv FROM connections WHERE connection_id = ?" (Only connId) -getConnReqContact :: DB.Connection -> Int64 -> ExceptT StoreError IO ConnReqContact +getConnReqContact :: DB.Connection -> Int64 -> ExceptT StoreError IO (ConnReqContact, Maybe ProofPresHeader) getConnReqContact db connId = - ExceptT . firstRow fromOnly (SEConnectionNotFoundById connId) $ + ExceptT . firstRow id (SEConnectionNotFoundById connId) $ DB.query db - "SELECT via_contact_uri FROM connections WHERE connection_id = ?" + "SELECT via_contact_uri, pres_header FROM connections WHERE connection_id = ?" (Only connId) -- | Saves unique local display name based on passed displayName, suffixed with _N if required. diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 085fd9fef7..6734789911 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -54,7 +54,7 @@ import Data.Time.Clock (UTCTime) import Data.Type.Equality (testEquality, (:~:) (Refl)) import Data.Typeable (Typeable) import Data.Word (Word16) -import Simplex.Chat.Badges (BadgeInfo (..), BadgeProof (..), BadgeStatus (..), LocalBadge (..), localBadgeInfo, localBadgeStatus, mkBadgeStatus, verifyBadge) +import Simplex.Chat.Badges (BadgeInfo (..), BadgeProof (..), BadgeStatus (..), LocalBadge (..), ProofPresHeader, acceptedProof, localBadgeInfo, localBadgeStatus, mkBadgeStatus, verifyBadge) import Simplex.Chat.Names (SimplexDomainClaim (..)) import Simplex.Messaging.Crypto.BBS (BBSPublicKey) import Simplex.Chat.Types.Preferences @@ -848,16 +848,23 @@ fromLocalProfile LocalProfile {displayName, fullName, shortDescr, description, i OwnBadge _ _ -> Nothing -- the own credential is not sent, proof is generated on send ShownBadge _ _ -> Nothing -- a display-only badge is not sent -profileBadgeVerified :: (BadgeProof -> Bool) -> Map Int BBSPublicKey -> LocalProfile -> Profile -> IO (Maybe Bool) -profileBadgeVerified accepted keys LocalProfile {localBadge} Profile {badge = newBadge} = - case (localBadge, newBadge) of - (_, Nothing) -> pure (Just False) - (_, Just newB) | not (accepted newB) -> pure (Just False) +profileBadgeVerified :: Maybe ProofPresHeader -> Map Int BBSPublicKey -> Maybe LocalProfile -> Profile -> IO (Profile, Maybe Bool) +profileBadgeVerified expected keys lp_ p@Profile {badge = newBadge} = case newBadge of + Nothing -> pure (p, Just False) + Just newB@(BadgeProof _ _ _ newInfo) + | not (acceptedProof expected newB) -> pure (p {badge = storedProof}, storedVerified) -- an unchanged badge that verified before stays verified; failed or unknown-key badges -- are re-verified, so an unknown key heals once an app update adds it - (Just lb, Just (BadgeProof _ _ _ newInfo)) - | localBadgeInfo lb == newInfo && localBadgeStatus lb `notElem` [BSFailed, BSUnknownKey] -> pure (Just True) - (_, Just newB) -> verifyBadge keys newB + | Just lb <- storedBadge, localBadgeInfo lb == newInfo && localBadgeStatus lb `notElem` [BSFailed, BSUnknownKey] -> pure (p, Just True) + | otherwise -> (,) p <$> verifyBadge keys newB + where + storedBadge = (\LocalProfile {localBadge} -> localBadge) =<< lp_ + Profile {badge = storedProof} = maybe p {badge = Nothing} fromLocalProfile lp_ + storedVerified = case localBadgeStatus <$> storedBadge of + Nothing -> Just False + Just BSFailed -> Just False + Just BSUnknownKey -> Nothing + Just _ -> Just True -- a failed or unknown-key badge is re-verified on the next profile update even when its disclosed content -- is unchanged, so it heals once an app update adds the issuer key diff --git a/tests/BadgeTests.hs b/tests/BadgeTests.hs index 08e8f155d2..7cd65efa5e 100644 --- a/tests/BadgeTests.hs +++ b/tests/BadgeTests.hs @@ -207,6 +207,7 @@ testPresHeaderEncoding = PHFileInv {chatBinding = aliceBinding, fileSize = 139737}, PHFileDescr {chatBinding = aliceBinding, fileSize = 139737, descrHash = "descr-hash", fileExpires = Nothing}, PHFileDescr {chatBinding = aliceBinding, fileSize = 139737, descrHash = "descr-hash", fileExpires = Just futureTime}, + PHRequest requestCode, PHUnknown 'Z' "payload" ] @@ -222,17 +223,19 @@ testProfileProofHeader :: IO () testProfileProofHeader = do (pk, unbound) <- issueBadgeProof BTSupporter futureTime (pk', bound) <- issueBadgeProofHeader BTSupporter futureTime (PHChat aliceBinding) - unboundProof unbound `shouldBe` True - unboundProof bound `shouldBe` False - boundProof (Just aliceBinding) bound `shouldBe` True - boundProof (Just bobBinding) bound `shouldBe` False - boundProof Nothing bound `shouldBe` False - boundProof (Just aliceBinding) unbound `shouldBe` False - verifyBadge_ unboundProof (keysFor pk) (Just unbound) >>= (`shouldBe` Just True) - verifyBadge_ unboundProof (keysFor pk') (Just bound) >>= (`shouldBe` Just False) - verifyBadge_ (boundProof (Just aliceBinding)) (keysFor pk') (Just bound) >>= (`shouldBe` Just True) - verifyBadge_ (boundProof (Just aliceBinding)) (keysFor pk) (Just unbound) >>= (`shouldBe` Just False) - verifyBadge_ (boundProof (Just aliceBinding)) (keysFor pk') Nothing >>= (`shouldBe` Just False) + (pk'', requested) <- issueBadgeProofHeader BTSupporter futureTime (PHRequest requestCode) + acceptedProof Nothing unbound `shouldBe` True + acceptedProof (Just $ PHChat aliceBinding) unbound `shouldBe` True + acceptedProof (Just $ PHChat aliceBinding) bound `shouldBe` True + acceptedProof (Just $ PHChat bobBinding) bound `shouldBe` False + acceptedProof (Just $ PHRequest aliceBinding) bound `shouldBe` False + acceptedProof Nothing bound `shouldBe` False + acceptedProof (Just $ PHRequest requestCode) requested `shouldBe` True + acceptedProof (Just $ PHRequest "other-request-code") requested `shouldBe` False + acceptedProof (Just $ PHChat requestCode) requested `shouldBe` False + verifyBadge (keysFor pk) unbound >>= (`shouldBe` Just True) + verifyBadge (keysFor pk') bound >>= (`shouldBe` Just True) + verifyBadge (keysFor pk'') requested >>= (`shouldBe` Just True) aliceBinding :: ByteString aliceBinding = "Galice-member-id" @@ -240,6 +243,9 @@ aliceBinding = "Galice-member-id" bobBinding :: ByteString bobBinding = "Gbob-member-id" +requestCode :: ByteString +requestCode = "request-code" + issueBadgeProof :: BadgeType -> UTCTime -> IO (BBSPublicKey, BadgeProof) issueBadgeProof bt expiry = issueBadgeProofHeader bt expiry (PHTest "test-nonce") diff --git a/tests/ChatTests/Profiles.hs b/tests/ChatTests/Profiles.hs index 65c36d3e48..0ea16d8089 100644 --- a/tests/ChatTests/Profiles.hs +++ b/tests/ChatTests/Profiles.hs @@ -16,6 +16,7 @@ import Control.Concurrent (threadDelay) import Control.Concurrent.Async (concurrently_) import Control.Monad import Control.Monad.Except +import Control.Monad.Reader (runReaderT) import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Char8 as B import Data.List (isSuffixOf) @@ -24,18 +25,20 @@ import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime, nominalDay) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Time.Format (defaultTimeLocale, formatTime) import qualified Data.Map.Strict as M -import Simplex.Chat.Badges (BadgeCredential, BadgeInfo (..), BadgePurchase (..), BadgeRequest (..), BadgeType (..), generateMasterKey, issueBadge, verifyPayment) +import Simplex.Chat.Badges (BadgeCredential, BadgeInfo (..), BadgePurchase (..), BadgeRequest (..), BadgeStatus (..), BadgeType (..), ProofPresHeader (..), badgeProof, generateMasterKey, issueBadge, verifyPayment) import Simplex.Chat.Controller (ChatConfig (..), ChatHooks (..), defaultChatHooks, storeCxt) +import Simplex.Chat.Library.Internal (sendDirectContactMessage) import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..)) -import Simplex.Chat.Protocol (LinkOwnerSig, MsgChatLink (..), MsgContent (..)) +import Simplex.Chat.Protocol (ChatBinding (..), ChatMsgEvent (XInfo), LinkOwnerSig, MsgChatLink (..), MsgContent (..), encodeChatBinding) import Simplex.Chat.Store.Shared (createContact) -import Simplex.Chat.Types (ConnStatus (..), Profile (..), GroupRejectionReason (..), profileFromName) +import Simplex.Chat.Types (ConnStatus (..), Profile (..), GroupRejectionReason (..), profileFromName, userProfileDirect) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.BBS (BBSPublicKey, BBSSecretKey, bbsKeyGen) import Simplex.Chat.Types.Shared (GroupMemberRole (..)) import Simplex.Chat.Types.UITheme import Simplex.Messaging.Agent.Env.SQLite import Simplex.Messaging.Agent.RetryInterval +import qualified Simplex.Messaging.Agent.Store.DB as DB import Simplex.Messaging.Encoding.String (StrEncoding (..)) import Simplex.Messaging.Server.Env.STM hiding (subscriptions) import Simplex.Messaging.Transport @@ -65,6 +68,17 @@ chatProfileTests = do it "long-expired supporter badge is not presented" testUserBadgeExpiredOld it "incognito connection does not carry supporter badge" testUserBadgeIncognito it "supporter badge sent to contact connecting via address" testUserBadgeContactAddress + it "supporter badge in a request to an address" testUserBadgeAddressRequest + it "supporter badge in a request to an address with ratchet keys" testUserBadgeAddressRequestRatchet + it "supporter badge sent joining a one-time link" testUserBadgeInvitationJoin + it "supporter badge sent in a retried request to an address" testUserBadgeAddressConnectRetry + it "supporter badge sent in a retried join of a one-time link" testUserBadgeInvitationConnectRetry + it "supporter badge bound to another chat is ignored, stored badge is kept" testUserBadgeOtherBinding + it "supporter badge of member joining via group link, at request and after handshake" testUserBadgeGroupLinkJoiner + it "supporter badge of introduced member" testUserBadgeIntroduced + it "supporter badge in one-time link data" testUserBadgeInvitationLinkData + it "supporter badge in data of address getting its first short link" testUserBadgeAddressFirstShortLink + it "supporter badge in shared address card" testUserBadgeAddressCard describe "user contact link" $ do it "create and connect via contact link" testUserContactLink it "rotate address ratchet keys" testRotateAddressRatchetKeys @@ -539,6 +553,320 @@ testUserBadgeIncognito ps = do bob <## "quantum resistant end-to-end encryption" bob <## currentChatVRangeInfo +testUserBadgeAddressRequest :: HasCallStack => TestParams -> IO () +testUserBadgeAddressRequest ps = do + Right (pk, sk) <- bbsKeyGen + testChatCfg2 (testCfg {badgePublicKeys = testBadgeKeys pk}) aliceProfile bobProfile (test sk) ps + where + test sk alice bob = do + addTestBadge bob =<< issueTestBadge sk futureDate + alice ##> "/ad" + cLink <- getContactLink alice True + bob ##> ("/c " <> cLink) + alice <#? bob + requestBadgeHeader alice "bob" `shouldReturn` Just ("R", BSActive) + alice ##> "/ac bob" + alice <## "bob (Bob, * supporter): accepting contact request, you can send messages to contact" + concurrently_ + (bob <## "alice (Alice): contact is connected") + (alice <## "bob (Bob, * supporter): contact is connected") + fmap snd <$> contactBadgeHeader alice "bob" `shouldReturn` Just BSActive + +testUserBadgeAddressRequestRatchet :: HasCallStack => TestParams -> IO () +testUserBadgeAddressRequestRatchet ps = do + Right (pk, sk) <- bbsKeyGen + testChatCfg2 (testCfg {badgePublicKeys = testBadgeKeys pk}) aliceProfile bobProfile (test sk) ps + where + test sk alice bob = do + addTestBadge bob =<< issueTestBadge sk futureDate + alice ##> "/ad pq_ratchet=on" + (sLink, _) <- getContactLinks alice True + bob ##> ("/c " <> sLink) + alice <#? bob + requestBadgeHeader alice "bob" `shouldReturn` Just ("CD", BSActive) + alice ##> "/ac bob" + alice <## "bob (Bob, * supporter): accepting contact request, you can send messages to contact" + concurrently_ + (bob <## "alice (Alice): contact is connected") + (alice <## "bob (Bob, * supporter): contact is connected") + fmap snd <$> contactBadgeHeader alice "bob" `shouldReturn` Just BSActive + +testUserBadgeInvitationJoin :: HasCallStack => TestParams -> IO () +testUserBadgeInvitationJoin ps = do + Right (pk, sk) <- bbsKeyGen + testChatCfg2 (testCfg {badgePublicKeys = testBadgeKeys pk}) aliceProfile bobProfile (test sk) ps + where + test sk alice bob = do + addTestBadge bob =<< issueTestBadge sk futureDate + alice ##> "/c" + inv <- getInvitation alice + bob ##> ("/c " <> inv) + bob <## "confirmation sent!" + concurrently_ + (bob <## "alice (Alice): contact is connected") + (alice <## "bob (Bob, * supporter): contact is connected") + contactBadgeHeader alice "bob" `shouldReturn` Just ("CD", BSActive) + +testUserBadgeAddressConnectRetry :: HasCallStack => TestParams -> IO () +testUserBadgeAddressConnectRetry ps = do + Right (pk, sk) <- bbsKeyGen + let cfg' = testCfg {badgePublicKeys = testBadgeKeys pk, agentConfig = testAgentCfg {persistErrorInterval = 0}} + withNewTestChatCfgOpts ps cfg' opts' "alice" aliceProfile $ \alice -> + withNewTestChatCfgOpts ps cfg' opts' "bob" bobProfile $ \bob -> do + addTestBadge bob =<< issueTestBadge sk futureDate + withSmpServer' serverCfg' $ do + alice ##> "/ad" + (shortLink, fullLink) <- getContactLinks alice True + bob ##> ("/_connect plan 1 " <> shortLink) + bob <## "contact address: ok to connect" + contactSLinkData <- getTermLine bob + bob ##> ("/_prepare contact 1 " <> fullLink <> " " <> shortLink <> " " <> contactSLinkData) + bob <## "alice: contact is prepared" + alice <## "disconnected 1 connections on server localhost" + bob ##> "/_connect contact @2" + bob <##. "smp agent error: BROKER" + withSmpServer' serverCfg' $ do + alice <## "subscribed 1 connections on server localhost" + threadDelay 250000 + bob ##> "/_connect contact @2" + bob <## "alice: connection started" + alice <## "bob (Bob) wants to connect to you!" + alice <## "to accept: /ac bob" + alice <## "to reject: /rc bob (the sender will NOT be notified)" + requestBadgeHeader alice "bob" `shouldReturn` Just ("R", BSActive) + alice ##> "/ac bob" + alice <## "bob (Bob, * supporter): accepting contact request, you can send messages to contact" + concurrently_ + (bob <## "alice (Alice): contact is connected") + (alice <## "bob (Bob, * supporter): contact is connected") + alice <## "disconnected 2 connections on server localhost" + bob <## "disconnected 1 connections on server localhost" + where + serverCfg' = + smpServerCfg + { transports = [("7003", transport @TLS, False)], + serverStoreCfg = persistentServerStoreCfg (tmpPath ps) + } + opts' = + testOpts + { coreOptions = + testCoreOpts + { smpServers = ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7003"] + } + } + +testUserBadgeInvitationConnectRetry :: HasCallStack => TestParams -> IO () +testUserBadgeInvitationConnectRetry ps = do + Right (pk, sk) <- bbsKeyGen + let cfg' = testCfg {badgePublicKeys = testBadgeKeys pk, agentConfig = testAgentCfg {persistErrorInterval = 0}} + withNewTestChatCfgOpts ps cfg' opts' "alice" aliceProfile $ \alice -> + withNewTestChatCfgOpts ps cfg' opts' "bob" bobProfile $ \bob -> do + addTestBadge bob =<< issueTestBadge sk futureDate + withSmpServer' serverCfg' $ do + alice ##> "/_connect 1" + (shortLink, fullLink) <- getInvitations alice + bob ##> ("/_connect plan 1 " <> shortLink) + bob <## "invitation link: ok to connect" + contactSLinkData <- getTermLine bob + bob ##> ("/_prepare contact 1 " <> fullLink <> " " <> shortLink <> " " <> contactSLinkData) + bob <## "alice: contact is prepared" + alice <## "disconnected 1 connections on server localhost" + bob ##> "/_connect contact @2" + bob <##. "smp agent error: BROKER" + withSmpServer' serverCfg' $ do + alice <## "subscribed 1 connections on server localhost" + threadDelay 250000 + bob ##> "/_connect contact @2" + bob <## "alice: connection started" + concurrently_ + (bob <## "alice (Alice): contact is connected") + (alice <## "bob (Bob, * supporter): contact is connected") + contactBadgeHeader alice "bob" `shouldReturn` Just ("CD", BSActive) + alice <## "disconnected 1 connections on server localhost" + bob <## "disconnected 1 connections on server localhost" + where + serverCfg' = + smpServerCfg + { transports = [("7003", transport @TLS, False)], + serverStoreCfg = persistentServerStoreCfg (tmpPath ps) + } + opts' = + testOpts + { coreOptions = + testCoreOpts + { smpServers = ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7003"] + } + } + +testUserBadgeOtherBinding :: HasCallStack => TestParams -> IO () +testUserBadgeOtherBinding ps = do + Right (pk, sk) <- bbsKeyGen + testChatCfg2 (testCfg {badgePublicKeys = testBadgeKeys pk}) aliceProfile bobProfile (test pk sk) ps + where + test pk sk alice bob = do + addTestBadge alice =<< issueTestBadge sk futureDate + alice ##> "/c" + inv <- getInvitation alice + bob ##> ("/c " <> inv) + bob <## "confirmation sent!" + concurrently_ + (bob <## "alice (Alice, * supporter): contact is connected") + (alice <## "bob (Bob): contact is connected") + contactBadgeHeader bob "alice" `shouldReturn` Just ("CD", BSActive) + legend <- issueTestBadgeType sk BTLegend futureDate + Right otherProof <- badgeProof pk legend (PHChat $ encodeChatBinding CBDirect "other chat") + withCCUser alice $ \user -> do + ct <- getTestCCContact alice 2 + let p = (userProfileDirect user Nothing (Just ct) True) {badge = Just otherProof} + runExceptT (sendDirectContactMessage user ct (XInfo p Nothing)) `runReaderT` chatController alice + >>= either (fail . show) (\_ -> pure ()) + alice #> "@bob hi" + bob <# "alice *> hi" + contactBadgeHeader bob "alice" `shouldReturn` Just ("CD", BSActive) + bob ##> "/i alice" + bob <## "contact ID: 2" + bob <## "supporter badge - active" + bob <## "expires 2100-01-01" + bob <## "receiving messages via: localhost" + bob <## "sending messages via: localhost" + bob <## "you've shared main profile with this contact" + bob <## "connection not verified, use /code command to see security code" + bob <## "quantum resistant end-to-end encryption" + bob <## currentChatVRangeInfo + +testUserBadgeGroupLinkJoiner :: HasCallStack => TestParams -> IO () +testUserBadgeGroupLinkJoiner ps = do + Right (pk, sk) <- bbsKeyGen + testChatCfg2 (testCfg {badgePublicKeys = testBadgeKeys pk}) aliceProfile bobProfile (test sk) ps + where + test sk alice bob = do + addTestBadge bob =<< issueTestBadge sk futureDate + alice ##> "/g team" + alice <## "group #team is created" + alice <## "to add members use /a team or /create link #team" + alice ##> "/create link #team" + gLink <- getGroupLink alice "team" GRMember True + bob ##> ("/c " <> gLink) + bob <## "connection request sent!" + bob ##> "/_stop" + bob <## "chat stopped" + alice <## "bob (Bob): accepting request to join group #team..." + memberBadgeHeader alice "team" "bob" `shouldReturn` Just ("R", BSActive) + bob ##> "/_start" + bob <## "chat started" + bob <## "subscribed 1 connections on server localhost" + concurrentlyN_ + [ alice <## "#team: bob joined the group", + do + bob <## "#team: joining the group..." + bob <## "#team: you joined the group" + ] + memberBadgeHeader alice "team" "bob" `shouldReturn` Just ("CG", BSActive) + +testUserBadgeIntroduced :: HasCallStack => TestParams -> IO () +testUserBadgeIntroduced ps = do + Right (pk, sk) <- bbsKeyGen + testChatCfg3 (testCfg {badgePublicKeys = testBadgeKeys pk}) aliceProfile bobProfile cathProfile (test sk) ps + where + test sk alice bob cath = do + addTestBadge bob =<< issueTestBadge sk futureDate + alice ##> "/g team" + alice <## "group #team is created" + alice <## "to add members use /a team or /create link #team" + alice ##> "/create link #team" + gLink <- getGroupLink alice "team" GRMember True + bob ##> ("/c " <> gLink) + bob <## "connection request sent!" + alice <## "bob (Bob): accepting request to join group #team..." + concurrentlyN_ + [ alice <## "#team: bob joined the group", + do + bob <## "#team: joining the group..." + bob <## "#team: you joined the group" + ] + memberBadgeHeader alice "team" "bob" `shouldReturn` Just ("CG", BSActive) + bob ##> "/_stop" + bob <## "chat stopped" + cath ##> ("/c " <> gLink) + cath <## "connection request sent!" + alice <## "cath (Catherine): accepting request to join group #team..." + concurrentlyN_ + [ alice <## "#team: cath joined the group", + do + cath <## "#team: joining the group..." + cath <## "#team: you joined the group" + ] + alice #> "#team hello" + cath <# "#team alice> hello" + memberBadgeHeader cath "team" "bob" `shouldReturn` Just ("CG", BSActive) + +testUserBadgeInvitationLinkData :: HasCallStack => TestParams -> IO () +testUserBadgeInvitationLinkData ps = do + Right (pk, sk) <- bbsKeyGen + testChatCfg2 (testCfg {badgePublicKeys = testBadgeKeys pk}) aliceProfile bobProfile (test sk) ps + where + test sk alice bob = do + addTestBadge alice =<< issueTestBadge sk futureDate + alice ##> "/_connect 1" + (shortLink, fullLink) <- getInvitations alice + bob ##> ("/_connect plan 1 " <> shortLink) + bob <## "invitation link: ok to connect" + sLinkData <- getTermLine bob + sLinkData `shouldContain` "\"localBadge\":{\"badge\":{\"badgeType\":\"supporter\"" + sLinkData `shouldContain` "\"status\":\"active\"" + bob ##> ("/_prepare contact 1 " <> fullLink <> " " <> shortLink <> " " <> sLinkData) + bob <## "alice: contact is prepared" + contactBadgeHeader bob "alice" `shouldReturn` Just ("R", BSActive) + +testUserBadgeAddressFirstShortLink :: HasCallStack => TestParams -> IO () +testUserBadgeAddressFirstShortLink ps = do + Right (pk, sk) <- bbsKeyGen + testChatCfg2 (testCfg {badgePublicKeys = testBadgeKeys pk}) aliceProfile bobProfile (test sk) ps + where + test sk alice bob = do + addTestBadge alice =<< issueTestBadge sk futureDate + alice ##> "/ad" + _ <- getContactLinks alice True + withCCTransaction alice $ \db -> DB.execute_ db "UPDATE user_contact_links SET short_link_contact = NULL" + alice ##> "/_short_link_address 1" + (shortLink, _) <- getContactLinks alice False + alice <## "auto_accept off" + bob ##> ("/_connect plan 1 " <> shortLink) + bob <## "contact address: ok to connect" + sLinkData <- getTermLine bob + sLinkData `shouldContain` "\"localBadge\":{\"badge\":{\"badgeType\":\"supporter\"" + sLinkData `shouldContain` "\"status\":\"active\"" + +testUserBadgeAddressCard :: HasCallStack => TestParams -> IO () +testUserBadgeAddressCard ps = do + Right (pk, sk) <- bbsKeyGen + testChatCfg3 (testCfg {badgePublicKeys = testBadgeKeys pk}) aliceProfile bobProfile cathProfile (test pk sk) ps + where + test pk sk alice bob cath = do + alice ##> "/ad" + _ <- getContactLinks alice True + connectUsers alice bob + connectUsers bob cath + addTestBadge alice =<< issueTestBadge sk futureDate + alice ##> "/share address @bob" + alice <# "@bob contact address of @alice (signed):" + _ <- getTermLine alice + _ <- getTermLine alice + bob <# "alice *> contact address of @alice (signed):" + bLink <- getTermLine bob + _ <- getTermLine bob + lastItemContent bob >>= (`shouldContain` "\"badgeType\":\"supporter\"") + cred <- issueTestBadge sk futureDate + Right otherProof <- badgeProof pk cred (PHChat $ encodeChatBinding CBLink "other link") + let cLink = either error id $ strDecode (B.pack bLink) + mc = MCChat (T.pack bLink) (MCLContact cLink (profileFromName "alice") {badge = Just otherProof} False) Nothing + bob ##> ("/_send @3 json [{\"msgContent\":" <> T.unpack (encodeJSON mc) <> "}]") + bob <# "@cath contact address of @alice:" + _ <- getTermLine bob + cath <# "bob> contact address of @alice:" + _ <- getTermLine cath + lastItemContent cath >>= (`shouldNotContain` "\"badge\"") + testUpdateProfileImage :: HasCallStack => TestParams -> IO () testUpdateProfileImage = testChat2 aliceProfile bobProfile $ diff --git a/tests/ChatTests/Utils.hs b/tests/ChatTests/Utils.hs index 9586957281..5ab04bceca 100644 --- a/tests/ChatTests/Utils.hs +++ b/tests/ChatTests/Utils.hs @@ -23,12 +23,14 @@ import Data.List (isPrefixOf, isSuffixOf) import Data.Maybe (fromMaybe) import Data.String import qualified Data.Text as T +import Simplex.Chat.Badges (BadgeProof (..), BadgeStatus, LocalBadge (..), ProofPresHeader (..)) import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), storeCxt) import Simplex.Chat.Library.Commands (maxProfileImageSize) import Simplex.Chat.Markdown (viewName) import Simplex.Chat.Messages.CIContent (e2eInfoNoPQText, e2eInfoPQText) import Simplex.Chat.Protocol -import Simplex.Chat.Store.Direct (getContact) +import Simplex.Chat.Store.Direct (getContact, getContactIdByName, getContactRequest, getContactRequestIdByName) +import Simplex.Chat.Store.Groups (getGroupIdByName, getGroupMember, getGroupMemberIdByName) import Simplex.Chat.Store.NoteFolders (createNoteFolder) import Simplex.Chat.Store.Profiles (getUserContactProfiles) import Simplex.Chat.Types @@ -39,6 +41,7 @@ import Simplex.Messaging.Agent.Client (agentClientStore) import Simplex.Messaging.Agent.Store.AgentStore (maybeFirstRow, withTransaction) import qualified Simplex.Messaging.Agent.Store.DB as DB import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.BBS (BBSPresHeader (..)) import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport, pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Version @@ -714,6 +717,49 @@ getTestCCContact cc contactId = do withCCUser cc $ \user -> runExceptT (getContact db (storeCxt chatController) user contactId) >>= either (fail . show) pure +contactBadgeHeader :: TestCC -> ContactName -> IO (Maybe (String, BadgeStatus)) +contactBadgeHeader cc cName = + withCCTransaction cc $ \db -> + withCCUser cc $ \user -> + runExceptT (getContact db (storeCxt $ chatController cc) user =<< getContactIdByName db user cName) + >>= either (fail . show) (pure . storedBadgeHeader . profile') + +requestBadgeHeader :: TestCC -> ContactName -> IO (Maybe (String, BadgeStatus)) +requestBadgeHeader cc cName = + withCCTransaction cc $ \db -> + withCCUser cc $ \user@User {userId} -> + runExceptT (getContactRequest db user =<< getContactRequestIdByName db userId cName) + >>= either (fail . show) (\UserContactRequest {profile} -> pure $ storedBadgeHeader profile) + +memberBadgeHeader :: TestCC -> GroupName -> ContactName -> IO (Maybe (String, BadgeStatus)) +memberBadgeHeader cc gName mName = + withCCTransaction cc $ \db -> + withCCUser cc $ \user -> + runExceptT + ( do + gId <- getGroupIdByName db user gName + getGroupMember db (storeCxt $ chatController cc) user gId =<< getGroupMemberIdByName db user gId mName + ) + >>= either (fail . show) (\GroupMember {memberProfile} -> pure $ storedBadgeHeader memberProfile) + +lastItemContent :: TestCC -> IO String +lastItemContent cc = + withCCTransaction cc $ \db -> + DB.query_ db "SELECT item_content FROM chat_items ORDER BY chat_item_id DESC LIMIT 1" >>= \case + [Only c] -> pure $ T.unpack c + _ -> fail "no chat items" + +storedBadgeHeader :: LocalProfile -> Maybe (String, BadgeStatus) +storedBadgeHeader LocalProfile {localBadge} = case localBadge of + Just (PeerBadge (BadgeProof _ (BBSPresHeader ph) _ _) st) -> Just (headerTag $ strDecode ph, st) + _ -> Nothing + where + headerTag = \case + Right (PHChat b) -> 'C' : take 1 (B.unpack b) + Right (PHRequest _) -> "R" + Right (PHTest _) -> "T" + _ -> "?" + lastItemId :: HasCallStack => TestCC -> IO String lastItemId cc = do cc ##> "/last_item_id" diff --git a/tests/ProtocolTests.hs b/tests/ProtocolTests.hs index 554398520e..f05650143d 100644 --- a/tests/ProtocolTests.hs +++ b/tests/ProtocolTests.hs @@ -337,7 +337,10 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do #==# XGrpInv GroupInvitation {fromMember = MemberIdRole (MemberId "\1\2\3\4") GRAdmin, fromMemberKey = Nothing, invitedMember = MemberIdRole (MemberId "\5\6\7\8") GRMember, connRequest = testConnReq, groupProfile = testGroupProfile, business = Nothing, groupLinkId = Just $ GroupLinkId "\1\2\3\4", groupSize = Nothing} it "x.grp.acpt without incognito profile" $ "{\"v\":\"9\",\"event\":\"x.grp.acpt\",\"params\":{\"memberId\":\"AQIDBA==\"}}" - #==# XGrpAcpt (MemberId "\1\2\3\4") Nothing + #==# XGrpAcpt (MemberId "\1\2\3\4") Nothing Nothing + it "x.grp.acpt with profile" $ + "{\"v\":\"9\",\"event\":\"x.grp.acpt\",\"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\"}}}}}" + #==# XGrpAcpt (MemberId "\1\2\3\4") Nothing (Just testProfile) it "x.grp.mem.new" $ "{\"v\":\"9\",\"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, memberKey = Nothing} Nothing