dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-09-27 17:58:47 +00:00
Code Issues Packages Projects Releases Wiki Activity

improvements

Browse Source
This commit is contained in:
Evgeny @ SimpleX Chat
2026-09-27 12:42:45 +00:00
parent a15b817c59
commit 867949d2aa
13 changed files with 308 additions and 296 deletions
Download Patch File Download Diff File Expand all files Collapse all files
apps/ios/Shared/Views/Chat/ChatItem/CIChatLinkHeader.swift
+1 -1
View File
@@ -69,7 +69,7 @@ struct CIChatLinkHeader: View {
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
let status: BadgeStatus = expired > BADGE_OLD_INTERVAL ? .expiredOld : expired > BADGE_GRACE_INTERVAL ? .expired : .active
return LocalBadge(badge: b.badgeInfo, status: status)
}
}
apps/ios/SimpleXChat/FileUtils.swift
+3
View File
@@ -36,6 +36,9 @@ public let MAX_FILE_SIZE_XFTP_LEGEND: Int64 = 5_368_709_120 // 5GB
// a badge raises the limit at send for this long after its expiry, shorter than the receiver's grace
public let BADGE_SND_GRACE_INTERVAL = TimeInterval(86400)
public let BADGE_GRACE_INTERVAL = TimeInterval(7 * 86400)
public let BADGE_OLD_INTERVAL = TimeInterval(38 * 86400)
public let MAX_FILE_SIZE_LOCAL: Int64 = Int64.max
public let MAX_FILE_SIZE_SMP: Int64 = 8000000
apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/chat/item/CIChatLinkHeader.kt
+4 -3
View File
@@ -10,12 +10,13 @@ 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.BADGE_GRACE_INTERVAL
import chat.simplex.common.views.helpers.BADGE_OLD_INTERVAL
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(
@@ -86,8 +87,8 @@ 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
expired > BADGE_OLD_INTERVAL -> BadgeStatus.ExpiredOld
expired > BADGE_GRACE_INTERVAL -> BadgeStatus.Expired
else -> BadgeStatus.Active
}
return LocalBadge(b.badgeInfo, status)
apps/multiplatform/common/src/commonMain/kotlin/chat/simplex/common/views/helpers/Utils.kt
+3
View File
@@ -133,6 +133,9 @@ const val MAX_FILE_SIZE_XFTP_LEGEND: Long = 5_368_709_120 // 5GB
// a badge raises the limit at send for this long after its expiry, shorter than the receiver's grace
val BADGE_SND_GRACE_INTERVAL: Duration = 1.days
val BADGE_GRACE_INTERVAL: Duration = 7.days
val BADGE_OLD_INTERVAL: Duration = 38.days
const val MAX_FILE_SIZE_LOCAL: Long = Long.MAX_VALUE
expect fun getAppFileUri(fileName: String): URI
cabal.project
+5 -5
View File
@@ -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: 965ac7b1e339d8c172e70685a845c62cb6b0ec87
-- source-repository-package
-- type: git
-- location: https://github.com/simplex-chat/simplexmq.git
-- tag: 965ac7b1e339d8c172e70685a845c62cb6b0ec87
source-repository-package
type: git
plans/2026-09-04-badge-binding-and-file-limits.md
+52 -56
View File
@@ -11,14 +11,14 @@ The same badge raises the size limit for files the user sends. Today each app de
The changes:
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.
1. Five new presentation headers: a profile shown in a chat, a file invitation, a file description, a contact request, and a link. The random header of released clients stays accepted, except in a shared address card.
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. The same table holds the proof of a group member, forwarded in introductions. A new column on `connections`, the request header of a prepared connection. The relay invitation includes the channel's public group id. 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.
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. The same table holds the proof of a group member, forwarded in introductions. A new column on `connections`, the request header of a prepared connection. The relay invitation includes the channel's public group id. 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 minimum SMP version raised to 15.
## Terms
@@ -89,7 +89,7 @@ One constructor serves every chat type, because the chat binding already encodes
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. `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.
`PHUnknown` fails every check. `PHTest`, presented by released clients, is accepted everywhere except in a shared address card. 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 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).
@@ -111,7 +111,7 @@ The expected header, `Maybe ProofPresHeader`, is a parameter of the store functi
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: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.
- `xInfoMember` (`Subscriber.hs:2814`) and `xGrpLinkMem` (`:2820`): the stored key when it verifies the message signature, otherwise none. A key delivered by the message is stored first by `storeMemberKey` when it verifies the signature; `storeMemberKey` returns the member with the key.
- The member connection handshake, section 4: the stored key when it verifies the signature.
- 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.
@@ -129,7 +129,7 @@ When two p2p members connect, each sends `XGrpMemInfo` with its group profile. I
- **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.
- **Parse the signature on CONF.** The member CONF site parses with `parseChatMessage` (`:781`), which discards the signature. Change it to `parseChatMessage'`, as INFO already does (`:850`).
- **Verify and store.** At `:837` and `:850` the signature is verified with the member's stored key, as `storeMemberKey` does; `XGrpMemInfo` names no key, and the handshake follows the introduction, which stored the key. `processMemberProfileUpdate` stores the profile with the binding from the verified key, or with no binding.
- **Verify and store.** At `:853` and `:862` the signed message is passed to `processMemberProfileUpdate`, and the signature is verified with the member's stored key by `signedMemberPresHeader`; `XGrpMemInfo` names no key, and the handshake follows the introduction, which stored the key. The profile is stored with the binding from the verified key, or with no binding.
- `:615` and `:647` stay as they are. The profile there is the same group profile, received over the direct connection to the member. The contact for a member shares the member's profile row (`createIntroToMemberContact`), so storing it once, on the member connection, updates both.
A member whose key was never introduced shows no badge until a signed `XInfo` that delivers the key arrives.
@@ -272,7 +272,7 @@ Every profile badge is bound to the chat it is shown in. The sender presents the
Rules:
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.
2. A connection request before the ratchet: the request code — the proposing party's X448 keys, its PQ key when present, 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.
@@ -281,12 +281,12 @@ Rules:
| 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 |
| One-time invitation link data | joining party | `PHLink linkKey` |
| Address link data, shared address card | anyone with the link | `PHLink linkKey` |
| P2p group | members | `PHChat (encodeChatBinding CBGroup (smpEncode (memberId, memberKey)))` |
| Channel | subscribers | `PHChat (encodeChatBinding CBGroup (smpEncode (publicGroupId, memberId)))` |
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`).
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 agent version range, the root key, the connection request with its server and queue id, and the entity id of an address (`encodeSignFixedData`, `ShortLink.hs`).
### 14.1 Agent: verification codes
@@ -326,7 +326,7 @@ 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: 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.
- `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`.
`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.
@@ -336,9 +336,9 @@ data ContactRequestBinding = CRBRatchet ConnVerifyCodes | CRBRequest ByteString
### 14.2 Agent: links before link data
Files: `Agent.hs`, `Agent/Protocol.hs`, `tests/AgentTests/FunctionalAPITests.hs`.
Files: `Agent.hs`, `Agent/Client.hs`, `Agent/Protocol.hs`, `Crypto/ShortLink.hs`, `Protocol.hs`, `Transport.hs`, `tests/AgentTests/FunctionalAPITests.hs`.
Committed in simplexmq `25b27342`. The chat pins it in `cabal.project` and `scripts/nix/sha256map.nix`.
The chat pins the simplexmq commit in `cabal.project` and `scripts/nix/sha256map.nix`.
Every link, and every invitation, is available to the chat before its link data is signed; each creation makes one network request.
@@ -366,14 +366,14 @@ createConnectionForLink :: AgentClient -> NetworkRequestMode -> UserId -> Bool -
- the returned link is `CCLink connReq Nothing`; the key is `plpLinkKey`
- `useDR` is ignored
- Invitation mode, create:
- the `PRKInvitation` keys are stored with `createRatchetX3dhKeys`
- link data: `SL.encodeSignUserData SCMInvitation`, encrypted by `encryptInvLinkData` with `SL.invShortLinkKdf plpLinkKey`; `newRcvConnSrv` uses the same function
- then the connection is created and the `PRKInvitation` keys are stored with `createRatchetX3dhKeys`; the connection is deleted when storing fails
- queue request: `CQRMessaging (Just CQRData {linkKey, privSigKey, srvReq = (sndId, srvData)})`
- Both modes create the queue with the local `createLinkQueue`:
- `createRcvQueue`
- the sender id check of `createConnectionForLink'` on master, error `sender ID mismatch`
- the returned link from `connReqWithShortLink`, moved from `newRcvConnSrv` to top level with its body unchanged — `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.
- 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`; link data above the size limit fails with `CMD LARGE` and leaves no connection. 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:
@@ -386,19 +386,17 @@ prepareConnShortLink :: AgentClient -> ConnId -> Maybe CRClientData -> AE (ConnS
- `setConnShortLink` uses `newContactLinkCreds` 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:
**SMP versions below 15.** The minimum SMP version of clients and servers is 15, and the code for older versions is removed:
```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.
- `NEW` and `IDS` (`Protocol.hs`): the encodings and parsers for versions below 15, with `qReq` and `qm`.
- `mkShortLinkCreds` (`Agent/Client.hs`): link data without a link id in the response is an error; the `THandleParams` parameter is removed.
- `connReqWithShortLink`: absent short link credentials are an `INTERNAL` error.
- `Transport.hs`: `shortLinksSMPVersion` is renamed `_shortLinksSMPVersion` and is not exported; `_proxyServerHandshakeSMPVersion` is removed.
- Tests: `testInvitationShortLinkPrev` and `testProxyMatrixWithPrev` are removed.
### 14.3 Chat
Todo, in implementation order. At every direct send, a `Nothing` from `connPresHeader` or `connsPresHeaders`, and a retry without a stored request header, get `unboundPresHeader`. At a send into a group, a `Nothing` from `groupPresHeader` presents no badge.
Todo, in implementation order. At every direct send, a `Nothing` from `connPresHeader` or `connsPresHeaders`, and a retry without a stored request header, are replaced with `PHTest` by `sndPresHeader`. At a send into a group, a `Nothing` from `groupPresHeader` presents no badge.
**1. Headers** — `Badges.hs`
@@ -430,10 +428,8 @@ The expected header, `Maybe ProofPresHeader`, is a parameter of:
- `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 <$>`.
`Nothing` is passed by `createContact`, the preset contact card, and by `setRelayLinkAccepted` and `updateRelayMemberData`. `processMemberProfileUpdate` takes the signed message and computes the header with `signedMemberPresHeader`. Group callers compute the header with `memberPresHeader` or `memberInfoPresHeader`.
**4. Presenting** — `Internal.hs`
@@ -441,21 +437,24 @@ The expected header, `Maybe ProofPresHeader`, is a parameter of:
presentUserBadge :: User -> Maybe i -> Maybe ProofPresHeader -> Profile -> CM Profile
```
With `Nothing`, no badge is presented. Header helpers:
With `Nothing`, no badge is presented. A badge is presented only when `presentsUserBadge :: User -> Bool` holds: the user's own badge is active or expired. 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` — `PHLink key`
- `invitationPresHeader :: ConnReqInvitation -> ProofPresHeader` — `PHRequest (invitationRequestCode connReq)`
- `unboundPresHeader :: CM ProofPresHeader` — `PHTest` of 16 random bytes
- `linkPresHeader :: ConnShortLink c -> ProofPresHeader` — `PHLink` of the link key
- `memberPresHeader :: GroupInfo -> MemberId -> Maybe C.PublicKeyEd25519 -> Maybe ProofPresHeader` — `PHChat <$> memberChatBinding`
- `memberInfoPresHeader :: GroupInfo -> MemberInfo -> Maybe ProofPresHeader` — `memberPresHeader` of the id and key in the `MemberInfo`
- `sndPresHeader :: Maybe ProofPresHeader -> CM ProofPresHeader` — the header, or `PHTest` of 16 random bytes for `Nothing`
- `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)`
Each returns `directPresHeader` of the agent binding:
- `prepareContact :: User -> ConnReqContact -> PQSupport -> CM (ConnId, VersionChat, ProofPresHeader)`
- `prepareAgentJoin :: User -> Bool -> ConnectionRequestUri c -> CM ((CommandId, ConnId), ProofPresHeader)`
- `prepareAgentAccept :: User -> Bool -> InvitationId -> PQSupport -> CM ((CommandId, ConnId), ProofPresHeader)`
**6. Stored request header**
@@ -472,52 +471,48 @@ ALTER TABLE connections ADD COLUMN pres_header BLOB;
**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_`.
- `joinContact` (`Commands.hs:3979`): the request header, `ProofPresHeader`, is a parameter, set in `connect'`, `joinPreparedConn'` and `connectContactViaAddress` — the `prepareContact` header for a new connection, the stored header for a retry. The badge is presented with `groupPresHeader` in a relay group, and with the request header otherwise.
- `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.
- `joinMemberContactAsync` (`Subscriber.hs:3947`): the header is a parameter, set in `xGrpDirectInv` to the `prepareAgentJoin` header.
- `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.
- `acceptContactRequestAsync` (`Internal.hs:1007-1026`): the profile is built after `prepareAgentAccept`, from its header.
- `CONF` replies (`Subscriber.hs:509` direct case, `:628`) and `updateContactPrefs` (`Commands.hs:4108`): `connPresHeader`.
- `sendUpdateToContacts` (`Commands.hs:4039-4077`) and `presentUserBadgeToContacts` (`:5212-5228`): one `connsPresHeaders` call per command, when `presentsUserBadge` holds.
**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`.
- `processContactProfileUpdate` (`Subscriber.hs:2771`) and `saveConnInfo` (`:3180`, for `createDirectContact`): the header is a parameter, `connPresHeader` of the connection, read by the caller. A `CONF` reply is presented with the same header.
**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.
- `acceptGroupJoinRequestAsync`: the expected header is a parameter, in place of `binding_` (`Internal.hs:1028`) — `memberPresHeader gInfo joiningMemberId Nothing` in `memberJoinRequestViaRelay`. `Nothing` in `acceptGroupJoinSendRejectAsync`.
- Host `INFO` with `XInfo` (`Subscriber.hs:865-872`): after `storeMemberKey`, the profile is stored by `processMemberProfileUpdate` with `signedMemberPresHeader`, under the member's key.
- The profile is also stored by `processMemberProfileUpdate` when the received proof is accepted and differs from the stored member proof in its header or its disclosed information, and when a profile without a proof arrives for a member with a stored proof.
- Introductions:
- In `memberInfo` (`Internal.hs:1331`) the stored proof (item 11) 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`.
- In `memberInfo` (`Internal.hs:1335`) the stored proof (item 11) is included when `acceptedProof (memberPresHeader g memberId memberPubKey)` holds, and omitted otherwise.
- In `xGrpMemNew`, `xGrpMemIntro` and `xGrpMemFwd` (`Subscriber.hs:3207, 3290, 3342`): `memberInfoPresHeader`, with the member id and 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`. For an invitee whose contact is active, the profile row is kept by `canUpdateProfile` and the proof is stored on the membership (item 11).
- The host (`Subscriber.hs:792-798`) stores the key, then the profile, by `processMemberProfileUpdate` with the signed message. For an invitee whose contact is active, the profile row is kept by `canUpdateProfile` and the proof is stored on the membership (item 11).
- 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.
- Invitation links (`APIAddContact`, `recreateConn`): the chat generates the root key pair and calls `prepareConnectionLink SCMInvitation`; the badge is presented with `PHLink` of `plpLinkKey`; then `createConnectionForLink` is called.
- Invitation updates (`updatePCCShortLinkData`, `APISetConnectionIncognito`): `linkPresHeader` of the stored invitation short link.
- 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.
- `linkDataBadge` (`Internal.hs:2285`): the expected header is a parameter — `linkPresHeader` of the short link, for an invitation (`Commands.hs:4415`) and for an address (`:4469-4470`). For a rejected proof the display badge, `localBadge`, is cleared.
- `createPreparedContact` (`Commands.hs:2206`): `linkPresHeader` of the short link in `accLink`; `Nothing` without a short link.
- `updateContactFromLinkData` (`Internal.hs:1644`): 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.
- Receipts, by `chatLinkBadge` (`Internal.hs:2294`): new messages and updates in direct chats and groups, the message of a contact request, a member contact invitation, and the welcome message of a prepared chat. The proof in `MCLContact.profile` is kept when its header equals `linkPresHeader` of `connLink` and it verifies, and removed otherwise; `PHTest` is not accepted.
- The badge from `profile.badge` is shown in `CIChatLinkHeader`, on iOS and in the multiplatform app. Its status is computed by the app from the expiry: active until seven days past it, expired until 38 days past it, hidden after.
**11. Member proofs** — `Badges.hs`, `Types.hs`, `Types/Preferences.hs`, `Store/Shared.hs`, `Store/Groups.hs`, `Store/Connections.hs`, `Internal.hs`, `Subscriber.hs`
@@ -596,8 +591,9 @@ The down migration deletes member rows before `file_id` is `NOT NULL` again. Bot
- Invitation via contact: the invitee's badge, stored on the membership at the host, is shown at a member introduced after the invitee joins.
- Channel: the owner's badge is shown at a subscriber, forwarded by the relay (`testChannelMemberBadges`).
- 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.
- A shared address card with a proof bound to another link, or with `PHTest`, is received without the badge, in a new message and in an update.
`PHTest` is still sent by released clients and, through `unboundPresHeader`, on a retry of a connection prepared before this change.
`PHTest` is still sent by released clients and, through `sndPresHeader`, on a retry of a connection prepared before this change.
## Out of scope
src/Simplex/Chat/Badges.hs
+1 -1
View File
@@ -271,7 +271,7 @@ maxSndXFTPFileSize lims now = \case
_ -> noBadge lims
-- Presentation header: a tag char + payload. PHTest is unbound - a fresh random nonce per
-- presentation, not bound to any context; the 'T' tag marks it so master rejects it.
-- presentation, not bound to any context.
-- PHUnknown is the forward-compat catch-all for tags this version does not interpret.
data ProofPresHeaderTag = PHTestTag | PHChatTag | PHFileInvTag | PHFileDescrTag | PHRequestTag | PHLinkTag | PHUnknownTag Char
src/Simplex/Chat/Library/Commands.hs
+52 -65
View File
@@ -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 (..), ProofPresHeader, 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,12 +1244,12 @@ 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@(CSLContact _ _ _ linkKey) -> do
Just connLink -> 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
profile <- presentUserBadge user Nothing (Just $ linkPresHeader connLink) $ userProfileDirect user Nothing Nothing True
let business = businessAddress addressSettings
text = safeDecodeUtf8 $ strEncode connLink
pure $ CRChatMsgContent user MCChat {text, chatLink = MCLContact {connLink, profile, business}, ownerSig}
@@ -2119,8 +2119,8 @@ processChatCommand cxt nm = \case
incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing
subMode <- chatReadVar subscriptionMode
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
(preparedLink, preparedParams@PreparedLinkParams {plpLinkKey = LinkKey linkKey}) <- withAgent $ \a -> prepareConnectionLink a (aUserId user) SCMInvitation rootKey Nothing False Nothing IKUsePQ False Nothing
linkProfile <- presentUserBadge user incognitoProfile (Just $ PHLink linkKey) $ userProfileDirect user incognitoProfile Nothing True
let userData = contactShortLinkData linkProfile {contactDomain = Nothing} Nothing
userLinkData = UserInvLinkData userData
(connId, ccLink) <- withAgent $ \a -> createConnectionForLink a nm (aUserId user) True preparedLink preparedParams userLinkData subMode
@@ -2142,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 (invitationPresHeader . connFullLink <$> connLinkInv) (userProfileDirect user Nothing Nothing True)
sLnk <- updatePCCShortLinkData conn =<< presentUserBadge user Nothing (linkPresHeader <$> (connShortLink' =<< connLinkInv)) (userProfileDirect user Nothing Nothing True)
conn' <- withFastStore' $ \db -> do
deletePCCIncognitoProfile db user pId
updatePCCIncognito db user conn Nothing sLnk
@@ -2164,8 +2164,8 @@ processChatCommand cxt nm = \case
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)
(preparedLink, preparedParams@PreparedLinkParams {plpLinkKey = LinkKey linkKey}) <- withAgent $ \a -> prepareConnectionLink a (aUserId newUser) SCMInvitation rootKey Nothing False Nothing IKPQOn False Nothing
userLinkData <- UserInvLinkData . (`contactShortLinkData` Nothing) <$> presentUserBadge newUser Nothing (Just $ PHLink linkKey) (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
@@ -2197,23 +2197,20 @@ processChatCommand cxt nm = \case
createItem sharedMsgId content = createChatItem user cd True content sharedMsgId Nothing Nothing
cInfo = GroupChat gInfo Nothing
void $ createGroupFeatureItems_ user cd True CIRcvGroupFeature gInfo
aci <- mapM (createItem welcomeSharedMsgId . CIRcvMsgContent) message
aci <- mapM (createItem welcomeSharedMsgId . CIRcvMsgContent <=< chatLinkBadge) message
let chat = case aci of
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 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)
ACCL _ (CCLink cReq sLnk) -> do
ct <- withStore $ \db -> createPreparedContact db cxt user (linkPresHeader <$> sLnk) 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
cInfo = DirectChat ct
void $ createItem Nothing $ CIRcvDirectE2EEInfo $ e2eInfoEncrypted $ connRequestPQEncryption cReq
void $ createFeatureEnabledItems_ user ct
aci <- mapM (createItem welcomeSharedMsgId . CIRcvMsgContent) message
aci <- mapM (createItem welcomeSharedMsgId . CIRcvMsgContent <=< chatLinkBadge) message
let chat = case aci of
Just (AChatItem SCTDirect dir _ ci) -> Chat cInfo [CChatItem dir ci] emptyChatStats {unreadCount = 1, minUnreadItemId = chatItemId' ci}
_ -> Chat cInfo [] emptyChatStats
@@ -2468,13 +2465,13 @@ processChatCommand cxt nm = \case
Just True -> (IKUsePQ, True)
Just False -> (IKPQOn, True)
Nothing -> (IKPQOn, False)
(ccLink, preparedParams@PreparedLinkParams {plpLinkKey}) <- withAgent $ \a -> prepareConnectionLink a (aUserId user) SCMContact rootKey (Just entityId) True Nothing pqInitKeys useDR server_
(ccLink, preparedParams) <- 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 (Just $ linkPresHeader plpLinkKey) (userProfileDirect user Nothing Nothing True)
else (`contactShortLinkData` Nothing) <$> presentUserBadge user Nothing (linkPresHeader <$> connShortLink' ccLink) (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
let ccLink'' = if isTrue userChatRelay then setShortLinkType CCTRelay ccLink' else ccLink'
@@ -2843,18 +2840,11 @@ processChatCommand cxt nm = \case
inv@ReceivedGroupInvitation {fromMember} <- getGroupInvitation db cxt user groupId
(inv,) <$> getContactViaMember db cxt user fromMember
let ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g@GroupInfo {membership, chatSettings}, groupKeys = gks} = invitation
GroupMember {memberId = membershipMemId} = membership
Contact {activeConn} = ct
case activeConn of
Just Connection {peerChatVRange} -> do
subMode <- chatReadVar subscriptionMode
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)
dm <- encodeXGrpAcpt user (GIK g gks) peerChatVRange
agentConnId <- case memberConn fromMember of
Nothing -> do
(agentConnId, _) <- withAgent $ \a -> prepareConnectionToJoin a (aUserId user) True connRequest PQSupportOff
@@ -3404,7 +3394,7 @@ 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 =<< maybe unboundPresHeader pure =<< connPresHeader conn
ConnPrepared -> joinPreparedConn subMode conn =<< sndPresHeader =<< connPresHeader conn
_ -> throwChatError $ CEException "connection already started (past prepared status)"
where
joinNewConn subMode = do
@@ -3823,7 +3813,7 @@ 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
presHeader <- maybe unboundPresHeader pure =<< connPresHeader conn
presHeader <- sndPresHeader =<< connPresHeader conn
joinPreparedConn conn (fromLocalProfile <$> localIncognitoProfile) presHeader
Just ent -> throwCmdError $ "connection is not RcvDirectMsgConnection: " <> show (connEntityInfo ent)
where
@@ -3887,33 +3877,29 @@ 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', reqHeader_), localIncognitoProfile) <- withFastStore $ \db -> (,) <$> getConnReqContact db connId <*> forM customUserProfileId (getProfileById db userId)
reqHeader <- maybe unboundPresHeader pure reqHeader_
reqHeader <- sndPresHeader reqHeader_
let incognitoProfile = fromLocalProfile <$> localIncognitoProfile
conn' <- joinContact user conn cReq' incognitoProfile (joinPresHeader gInfo_ reqHeader) xContactId welcomeSharedMsgId msg_ gInfo_ relayMemberId_ PQSupportOn
conn' <- joinContact user conn cReq' incognitoProfile 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, binding) <- prepareContact user cReq pqSup
(connId, chatV, reqHeader) <- 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 reqHeader cReqHash1 sLnk' xContactId incognitoProfile_ groupLinkId subMode chatV pqSup
conn' <- joinContact user conn cReq incognitoProfile (joinPresHeader gInfo_ reqHeader) xContactId welcomeSharedMsgId msg_ gInfo_ relayMemberId_ pqSup
conn' <- joinContact user conn cReq incognitoProfile 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) =
@@ -3921,15 +3907,14 @@ processChatCommand cxt nm = \case
case activeConn of
Nothing -> do
let pqSup = PQSupportOn
(connId, chatV, binding) <- prepareContact user cReq pqSup
(connId, chatV, reqHeader) <- 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
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
void $ joinContact user conn cReq incognitoProfile 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
@@ -3937,9 +3922,9 @@ processChatCommand cxt nm = \case
when (incognito /= isJust customUserProfileId) $ throwCmdError "incognito mode is different from prepared connection"
xContactId <- mkXContactId xContactId_
((cReq', reqHeader_), localIncognitoProfile) <- withFastStore $ \db -> (,) <$> getConnReqContact db connId <*> forM customUserProfileId (getProfileById db userId)
reqHeader <- maybe unboundPresHeader pure reqHeader_
reqHeader <- sndPresHeader reqHeader_
let incognitoProfile = fromLocalProfile <$> localIncognitoProfile
void $ joinContact user conn cReq' incognitoProfile (Just reqHeader) xContactId Nothing Nothing Nothing Nothing PQSupportOn
void $ joinContact user conn cReq' incognitoProfile 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"
@@ -3953,7 +3938,7 @@ processChatCommand cxt nm = \case
relayLinkData_ <- liftIO $ decodeLinkUserData cData
relayMemberId <- case (relayLinkData_, linkEntityId) of
(Just RelayShortLinkData {relayProfile = p}, Just entityId) -> do
withFastStore $ \db -> updateRelayMemberData db cxt user relayMember (MemberId entityId) (MemberKey relayKey) Nothing p
withFastStore $ \db -> updateRelayMemberData db cxt user relayMember (MemberId entityId) (MemberKey relayKey) p
pure $ MemberId entityId
_ -> throwChatError $ CEException "relay link: no relay link data or entity id"
let relayLinkToConnect = CCLink cReq (Just relayLink)
@@ -3980,22 +3965,23 @@ processChatCommand cxt nm = \case
deleteMemberConnection m
deleteOrUpdateMemberRecord user gInfo m
_ -> pure ()
prepareContact :: User -> ConnReqContact -> PQSupport -> CM (ConnId, VersionChat, ContactRequestBinding)
prepareContact :: User -> ConnReqContact -> PQSupport -> CM (ConnId, VersionChat, ProofPresHeader)
prepareContact user cReq pqSup = do
lift (withAgent' (`connRequestAgentVersion` cReq)) >>= \case
Nothing -> throwChatError CEInvalidConnReq
Just _ -> do
let chatV = initialChatVersion
(connId, binding) <- withAgent $ \a -> prepareConnectionToJoin a (aUserId user) True cReq pqSup
pure (connId, chatV, binding)
pure (connId, chatV, directPresHeader binding)
mkXContactId :: Maybe XContactId -> CM XContactId
mkXContactId = maybe (XContactId <$> drgRandomBytes 16) pure
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
joinContact :: User -> Connection -> ConnReqContact -> Maybe Profile -> ProofPresHeader -> XContactId -> Maybe SharedMsgId -> Maybe (SharedMsgId, MsgContent) -> Maybe (Maybe GroupInfoKeys) -> Maybe MemberId -> PQSupport -> CM Connection
joinContact user conn cReq incognitoProfile reqHeader 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 <- presentUserBadge user incognitoProfile presHeader_ $ case gInfo_ of
Just gInfo_' -> userProfileInGroup' user ((\(GIK g _) -> g) <$> gInfo_') 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
@@ -4007,6 +3993,10 @@ processChatCommand cxt nm = \case
subMode <- chatReadVar subscriptionMode
void $ withAgent $ \a -> joinConnection a nm (aUserId user) (aConnId conn) True cReq dm pqSup subMode
withFastStore' $ \db -> updateConnectionStatusFromTo db conn ConnPrepared ConnJoined
where
presHeader_ = case gInfo_ of
Just (Just (GIK g _)) | useRelays' g -> groupPresHeader g
_ -> Just reqHeader
contactMember :: Contact -> [GroupMember] -> Maybe GroupMember
contactMember Contact {contactId} =
find $ \GroupMember {memberContactId = cId, memberStatus = s} ->
@@ -4052,7 +4042,7 @@ processChatCommand cxt nm = \case
case changedCts_ of
Nothing -> pure $ UserProfileUpdateSummary 0 0 []
Just changedCts -> do
presHeaders <- connsPresHeaders $ map (\ChangedProfileContact {conn} -> conn) $ L.toList changedCts
presHeaders <- if presentsUserBadge user' then connsPresHeaders $ map (\ChangedProfileContact {conn} -> conn) $ L.toList changedCts else pure M.empty
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_
@@ -4080,7 +4070,7 @@ processChatCommand cxt nm = \case
-- non-incognito (filtered above), so the user's badge is presented; a profile update keeps the badge instead of clearing it
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
presHeader <- sndPresHeader $ 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
@@ -4090,8 +4080,8 @@ processChatCommand cxt nm = \case
setMyAddressData :: Bool -> Maybe InitialKeys -> User -> UserContactLink -> CM UserContactLink
setMyAddressData rotateKeys pqInitKeys user@User {userChatRelay} ucl@UserContactLink {userContactLinkId, connLinkContact = CCLink connFullLink sLnk_, addressSettings} = do
conn <- withFastStore $ \db -> getUserAddressConnection db cxt user
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)
presHeader <- linkPresHeader <$> maybe (withAgent $ \a -> prepareConnShortLink a (aConnId conn) Nothing) pure sLnk_
shortLinkProfile <- presentUserBadge user Nothing (Just presHeader) (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
@@ -4115,7 +4105,7 @@ processChatCommand cxt nm = \case
mergedProfile' = userProfileDirect user (fromLocalProfile <$> incognitoProfile) (Just ct') False
when (mergedProfile' /= mergedProfile) $
withContactLock "updateContactPrefs" (contactId' ct) $ do
presHeader <- maybe unboundPresHeader pure =<< connPresHeader conn
presHeader <- sndPresHeader =<< 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'
@@ -4422,7 +4412,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 $ invitationPresHeader cReq) =<< liftIO (decodeLinkUserData cData)
contactSLinkData_ <- mapM (linkDataBadge $ linkPresHeader l') =<< liftIO (decodeLinkUserData cData)
let ov = verifyLinkOwner rootKey [] l sig_
invitationReqAndPlan cReq (Just l') contactSLinkData_ ov
where
@@ -4476,7 +4466,7 @@ processChatCommand cxt nm = \case
when (resolveMode == PRMNever) $ throwChatError CENotResolvedLocally
l' <- resolveSLink
(FixedLinkData {rootKey}, cData, cReq) <- getShortLinkConnReq nm user l'
let presHeader = linkPresHeader $ (\(CSLContact _ _ _ linkKey) -> linkKey) l'
let presHeader = linkPresHeader l'
contactSLinkData_ <- mapM (linkDataBadge presHeader) =<< liftIO (decodeLinkUserData cData)
let linkProfile_ = (\ContactShortLinkData {profile} -> profile) <$> contactSLinkData_
linkDomain_ = linkProfile_ >>= \Profile {contactDomain} -> claimDomain <$> contactDomain
@@ -5229,16 +5219,13 @@ 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
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 ()
let sendConns = [(ct, conn) | ct <- contacts, Right conn <- [contactSendConn_ ct], not (connIncognito conn)]
presHeaders <- if presentsUserBadge user' then connsPresHeaders $ map snd sendConns else pure M.empty
withChatLock "presentUserBadge" $ forM_ sendConns $ \(ct, conn) -> do
let ct' = updateMergedPreferences user' ct
presHeader <- sndPresHeader $ 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
-- | The check character is verified before anything leaves the device, and the signing keys are
-- stashed before the request is sent, so a retry reaches the service as the same signer.
src/Simplex/Chat/Library/Internal.hs
+54 -28
View File
@@ -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, second)
import Data.Bifunctor (first)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB
@@ -265,7 +265,7 @@ rcvForwardedFrom db user chatDirection RcvMessage {chatMsgEvent} = case chatMsgE
forwardLinkCIFF :: DB.Connection -> User -> ForwardLink -> IO CIForwardedFrom
forwardLinkCIFF db user ForwardLink {displayName, groupLink, publicGroupId, memberId, msgId} =
getGroupViaPublicGroupId db user publicGroupId >>= \case
Just (gId, Just storedLink)
Just (gId, storedLink)
| sameShortLinkContact groupLink storedLink -> do
ciId_ <- itemId_ gId
pure $ CIFFGroup displayName MDRcv (Just gId) ciId_ memberId (Just msgId) linkGroupType
@@ -998,7 +998,7 @@ acceptContactRequest nm user@User {userId} UserContactRequest {agentInvitationId
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
presHeader <- maybe unboundPresHeader pure =<< connPresHeader conn
presHeader <- sndPresHeader =<< 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
@@ -1014,8 +1014,8 @@ acceptContactRequestAsync
subMode <- chatReadVar subscriptionMode
cxt <- chatStoreCxt
let chatV = vr cxt `peerConnChatVersion` cReqChatVRange
((cmdId, acId), binding) <- prepareAgentAccept user True cReqInvId cReqPQSup
profileToSend <- presentUserBadge user incognitoProfile (Just $ directPresHeader binding) $ userProfileDirect user (fromIncognitoProfile <$> incognitoProfile) (Just ct) True
((cmdId, acId), presHeader) <- prepareAgentAccept user True cReqInvId cReqPQSup
profileToSend <- presentUserBadge user incognitoProfile (Just presHeader) $ userProfileDirect user (fromIncognitoProfile <$> incognitoProfile) (Just ct) True
currentTs <- liftIO getCurrentTime
ct' <- withStore $ \db -> do
forM_ xContactId $ \xcId -> liftIO $ setContactAcceptedXContactId db ct xcId
@@ -1338,7 +1338,7 @@ memberInfo g m@GroupMember {memberId, memberRole, memberProfile, memberPubKey, a
{ memberId,
memberRole,
v = ChatVersionRange . peerChatVRange <$> activeConn,
profile = (p :: Profile) {badge = mfilter (acceptedProof $ PHChat <$> memberChatBinding g memberId memberPubKey) (unNoJSON memberBadgeProof <|> badge)},
profile = (p :: Profile) {badge = mfilter (acceptedProof $ memberPresHeader g memberId memberPubKey) (unNoJSON memberBadgeProof <|> badge)},
memberKey = MemberKey <$> memberPubKey
}
where
@@ -2243,11 +2243,16 @@ sendDirectContactMessages user ct events = do
-- 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 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
badge <- join <$> mapM (sndBadgeProof user) presHeader_
pure p {badge}
_ -> pure p
presentUserBadge user incognitoProfile presHeader_ p
| isNothing incognitoProfile && presentsUserBadge user = do
badge <- pure presHeader_ $>>= sndBadgeProof user
pure p {badge}
| otherwise = pure p
presentsUserBadge :: User -> Bool
presentsUserBadge User {profile = LocalProfile {localBadge}} = case localBadge of
Just (OwnBadge _ st) -> st == BSActive || st == BSExpired
_ -> False
groupPresHeader :: GroupInfo -> Maybe ProofPresHeader
groupPresHeader gInfo = PHChat <$> sndGroupChatBinding gInfo False
@@ -2257,18 +2262,17 @@ directPresHeader = \case
CRBRatchet ConnVerifyCodes {codeAD} -> PHChat $ encodeChatBinding CBDirect codeAD
CRBRequest code -> PHRequest code
linkPresHeader :: LinkKey -> ProofPresHeader
linkPresHeader (LinkKey key) = PHLink key
invitationPresHeader :: ConnReqInvitation -> ProofPresHeader
invitationPresHeader = PHRequest . invitationRequestCode
linkPresHeader :: ConnShortLink c -> ProofPresHeader
linkPresHeader = \case
CSLInvitation _ _ _ (LinkKey key) -> PHLink key
CSLContact _ _ _ (LinkKey key) -> PHLink key
relayInvPresHeader :: GroupRelayInvitation -> Maybe ProofPresHeader
relayInvPresHeader GroupRelayInvitation {fromMember = MemberIdRole {memberId}, publicGroupId} =
(\gId -> PHChat $ encodeChatBinding CBGroup $ smpEncode (gId, memberId)) <$> publicGroupId
unboundPresHeader :: CM ProofPresHeader
unboundPresHeader = PHTest <$> drgRandomBytes 16
sndPresHeader :: Maybe ProofPresHeader -> CM ProofPresHeader
sndPresHeader = maybe (PHTest <$> drgRandomBytes 16) pure
connPresHeader :: Connection -> CM (Maybe ProofPresHeader)
connPresHeader conn = eitherToMaybe <$> tryAllErrors (directPresHeader . CRBRatchet <$> withAgent (`getConnectionVerifyCodes` aConnId conn))
@@ -2280,13 +2284,21 @@ connsPresHeaders conns = either (const M.empty) (M.map (directPresHeader . CRBRa
-- and set the crypto-free display badge for the UI (the raw proof stays in profile for APIPrepareContact)
linkDataBadge :: ProofPresHeader -> ContactShortLinkData -> CM ContactShortLinkData
linkDataBadge presHeader cld@ContactShortLinkData {profile = Profile {badge}} = case mfilter (acceptedProof (Just presHeader)) badge of
Nothing -> pure cld
Nothing -> pure (cld :: ContactShortLinkData) {localBadge = Nothing}
Just b@(BadgeProof _ _ _ info) -> do
keys <- asks $ badgePublicKeys . config
verified <- liftIO $ verifyBadge keys b
now <- liftIO getCurrentTime
pure (cld :: ContactShortLinkData) {localBadge = Just $ ShownBadge info (mkBadgeStatus now verified info)}
chatLinkBadge :: MsgContent -> CM MsgContent
chatLinkBadge = \case
MCChat {text, chatLink = chatLink@MCLContact {connLink, profile = p@Profile {badge = Just b@BadgeProof {presHeader = BBSPresHeader ph}}}, ownerSig} -> do
keys <- asks $ badgePublicKeys . config
verified <- if ph == strEncode (linkPresHeader connLink) 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
sendDirectContactMessage :: MsgEncodingI e => User -> Contact -> ChatMsgEvent e -> CM (SndMessage, Int64)
sendDirectContactMessage user ct chatMsgEvent = do
conn@Connection {connId} <- liftEither $ contactSendConn_ ct
@@ -2376,6 +2388,12 @@ memberChatBinding gInfo memberId key_ = case publicGroup' gInfo of
Just PublicGroupProfile {publicGroupId} -> Just $ encodeChatBinding CBGroup $ smpEncode (publicGroupId, memberId)
Nothing -> (\k -> encodeChatBinding CBGroup $ smpEncode (memberId, k)) <$> key_
memberPresHeader :: GroupInfo -> MemberId -> Maybe C.PublicKeyEd25519 -> Maybe ProofPresHeader
memberPresHeader gInfo memberId = fmap PHChat . memberChatBinding gInfo memberId
memberInfoPresHeader :: GroupInfo -> MemberInfo -> Maybe ProofPresHeader
memberInfoPresHeader gInfo MemberInfo {memberId, memberKey} = memberPresHeader gInfo memberId ((\(MemberKey k) -> k) <$> memberKey)
proofMemberKey :: MemberId -> Maybe BadgeProof -> Maybe C.PublicKeyEd25519
proofMemberKey memberId badge_ = do
BadgeProof _ (BBSPresHeader phBytes) _ _ <- badge_
@@ -2504,6 +2522,16 @@ encodeXMemberConnInfo (GIK gInfo@GroupInfo {membership = GroupMember {memberId}}
signing = MsgSigning CBGroup bindingData KRMember memberPrivKey'
in encodeSignedConnInfo signing xMemberEvt
encodeXGrpAcpt :: User -> GroupInfoKeys -> VersionRangeChat -> CM ByteString
encodeXGrpAcpt user g@(GIK gInfo@GroupInfo {membership = GroupMember {memberId}} gks) peerVRange = do
let incognitoProfile = incognitoMembershipProfile gInfo
profile_ <-
if maxVersion peerVRange >= relayWebCapVersion
then Just <$> presentUserBadge user incognitoProfile (groupPresHeader gInfo) (userProfileInGroup user gInfo $ fromLocalProfile <$> incognitoProfile)
else pure Nothing
let msg = XGrpAcpt memberId (Just $ groupMemberKey gks) profile_
maybe (encodeConnInfo msg) (`encodeSignedConnInfo` msg) (groupMsgSigning False g msg)
deliverMessage :: Connection -> CMEventTag e -> MsgBody -> MessageId -> CM (Int64, PQEncryption)
deliverMessage conn cmEventTag msgBody msgId = do
let msgFlags = MsgFlags {notification = hasNotification cmEventTag}
@@ -3058,13 +3086,11 @@ 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), Maybe ContactRequestBinding)
prepareAgentJoin user conn_ enableNtfs cReqUri = do
cmdId <- withStore' $ \db -> createCommand db user (dbConnId <$> conn_) CFJoinConn
(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_)
prepareAgentJoin :: User -> Bool -> ConnectionRequestUri c -> CM ((CommandId, ConnId), ProofPresHeader)
prepareAgentJoin user enableNtfs cReqUri = do
cmdId <- withStore' $ \db -> createCommand db user Nothing CFJoinConn
(connId, binding) <- withAgent $ \a -> prepareConnectionToJoin a (aUserId user) enableNtfs cReqUri PQSupportOff
pure ((cmdId, connId), directPresHeader binding)
joinAgentConnectionAsync :: CommandId -> Bool -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> CM ()
joinAgentConnectionAsync cmdId updateConn connId enableNtfs cReqUri cInfo subMode =
@@ -3086,11 +3112,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), ContactRequestBinding)
prepareAgentAccept :: User -> Bool -> InvitationId -> PQSupport -> CM ((CommandId, ConnId), ProofPresHeader)
prepareAgentAccept user enableNtfs invId pqSup = do
cmdId <- withStore' $ \db -> createCommand db user Nothing CFAcceptContact
(connId, binding) <- withAgent $ \a -> prepareConnectionToAccept a (aUserId user) enableNtfs invId pqSup
pure ((cmdId, connId), binding)
pure ((cmdId, connId), directPresHeader binding)
agentAcceptContactAsync :: MsgEncodingI e => CommandId -> ConnId -> Bool -> InvitationId -> ChatMsgEvent e -> PQSupport -> SubscriptionMode -> CM ()
agentAcceptContactAsync cmdId connId enableNtfs invId msg pqSup subMode = do
src/Simplex/Chat/Library/Subscriber.hs
+86 -110
View File
@@ -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 (..), LocalBadge (..), ProofPresHeader (..), acceptedProof, verifyBadge)
import Simplex.Chat.Badges (BadgeProof (..), BadgeProofKind (..), BadgeStatus (..), FileSizeLimits (..), ProofPresHeader (..), acceptedProof)
import Simplex.Chat.Call
import Simplex.Chat.Controller
import Simplex.Chat.Delivery
@@ -498,19 +498,21 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
Right () -> pure ()
Nothing -> do
conn' <- processCONFpqSupport conn pqSupport
presHeader_ <- connPresHeader conn'
-- [incognito] send saved profile
(conn'', gInfo_) <- saveConnInfo conn' connInfo
(conn'', gInfo_) <- saveConnInfo conn' presHeader_ connInfo
incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId)
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''
presHeader <- sndPresHeader presHeader_
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
processINFOpqSupport conn pqSupport
void $ saveConnInfo conn connInfo
presHeader_ <- connPresHeader conn
void $ saveConnInfo conn presHeader_ connInfo
MSG meta _msgFlags _msgBody ->
-- We are not saving message (saveDirectRcvMSG) as contact hasn't been created yet,
-- chat item is also not created here
@@ -577,7 +579,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
case event of
XMsgNew mc -> newContentMessage ct'' mc msg msgMeta
XMsgFileDescr sharedMsgId fileDescr fileExpires fileBadge -> messageFileDescription ct'' sharedMsgId fileDescr fileExpires fileBadge
XMsgUpdate sharedMsgId mContent _ ttl live _msgScope _ -> messageUpdate ct'' sharedMsgId mContent msg msgMeta ttl live
XMsgUpdate sharedMsgId mContent _ ttl live _msgScope _ -> chatLinkBadge mContent >>= \mc -> messageUpdate ct'' sharedMsgId mc msg msgMeta ttl live
XMsgDel sharedMsgId _ _ _ -> messageDelete ct'' sharedMsgId msg msgMeta
XMsgReact sharedMsgId _ _ reaction add -> directMsgReaction ct'' sharedMsgId reaction add msg msgMeta
-- TODO discontinue XFile
@@ -619,10 +621,11 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
allowAgentConnectionAsync user conn'' confId Nothing XOk
XInfo profile _ -> do
ct' <- processContactProfileUpdate ct profile False `catchAllErrors` const (pure ct)
presHeader_ <- connPresHeader conn''
ct' <- processContactProfileUpdate ct presHeader_ profile False `catchAllErrors` const (pure ct)
-- [incognito] send incognito profile
incognitoProfile <- forM customUserProfileId $ \profileId -> withStore $ \db -> getProfileById db userId profileId
presHeader <- maybe unboundPresHeader pure =<< connPresHeader conn''
presHeader <- sndPresHeader presHeader_
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'
@@ -652,7 +655,8 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
pure ()
XInfo profile _ -> do
let prepared = isJust (preparedContact ct) || isJust (contactRequestId' ct)
void $ processContactProfileUpdate ct profile prepared
presHeader_ <- connPresHeader conn
void $ processContactProfileUpdate ct presHeader_ profile prepared
XOk -> pure ()
_ -> messageError "INFO for existing contact must have x.grp.mem.info, x.info or x.ok"
CON pqEnc -> do
@@ -788,17 +792,13 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
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
m' <- case mKey of
Just (MemberKey k) -> m {memberPubKey = Just k} <$ withStore' (\db -> setMemberPubKey db (groupMemberId' m) k)
Nothing -> pure m
forM_ memProfile_ $ \memProfile -> processMemberProfileUpdate gInfo m' signedMsg_ memProfile Nothing
membershipProfile <- membershipHandshakeProfile gInfo $ maxVersion (peerChatVRange conn')
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
allowAgentConnectionAsync user conn' confId (Just g) $ XGrpMemInfo membershipMemId membershipProfile
allowAgentConnectionAsync user conn' confId (Just g) $ XGrpMemInfo (memberId' membership) membershipProfile
| otherwise -> messageError "x.grp.acpt: memberId is different from expected"
XGrpRelayAcpt relayLink relayCap
| memberRole' membership == GROwner && isRelay m -> do
@@ -847,14 +847,10 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
XGrpMemInfo memId memProfile
| sameMemberId memId m -> do
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
membershipProfile <- membershipHandshakeProfile gInfo $ maxVersion (peerChatVRange conn')
-- [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 (PHChat <$> signedMemberBinding gInfo m signedMsg_) memProfile Nothing
void $ processMemberProfileUpdate 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
@@ -863,7 +859,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
case chatMsgEvent of
XGrpMemInfo memId memProfile
| sameMemberId memId m ->
void $ processMemberProfileUpdate gInfo m (PHChat <$> signedMemberBinding gInfo m signedMsg_) memProfile Nothing
void $ processMemberProfileUpdate gInfo m signedMsg_ memProfile Nothing
| otherwise -> messageError "x.grp.mem.info: memberId is different from expected"
-- sent when connecting via group link
XInfo memProfile mKey
@@ -872,9 +868,8 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
deleteMemberConnection' m True
withStore' $ \db -> deleteGroupMember db user m
| 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
m' <- maybe (pure m) (storeMemberKey gInfo m signedMsg_) mKey
void $ processMemberProfileUpdate gInfo m' signedMsg_ memProfile Nothing
XOk ->
-- transient relay-reject row cleanup after the rejection handshake completes
when (memberCategory m == GCHostMember && not (relayServesGroup gInfo)) $ do
@@ -1086,7 +1081,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
XMsgUpdate sharedMsgId mContent mentions ttl live msgScope asGroup_ ->
checkSendAsGroup asGroup_ $
memberCanSend (Just m'') msgScope $
groupMessageUpdate gInfo' (Just m'') sharedMsgId mContent mentions msgScope msg brokerTs ttl live asGroup_
chatLinkBadge mContent >>= \mc -> groupMessageUpdate gInfo' (Just m'') sharedMsgId mc mentions msgScope msg brokerTs ttl live asGroup_
XMsgDel sharedMsgId memberId_ scope_ onlyHistory ->
groupMessageDelete gInfo' (Just m'') sharedMsgId memberId_ scope_ onlyHistory msg brokerTs
XMsgReact sharedMsgId memberId scope_ reaction add -> groupMsgReaction gInfo' m'' sharedMsgId memberId scope_ reaction add msg brokerTs
@@ -1247,7 +1242,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
relayLinkData_ <- liftIO $ decodeLinkUserData cData
relayMemberId <- case (relayLinkData_, linkEntityId) of
(Just RelayShortLinkData {relayProfile = p}, Just entityId) -> do
withStore $ \db -> updateRelayMemberData db cxt user m (MemberId entityId) (MemberKey relayKey) Nothing p
withStore $ \db -> updateRelayMemberData db cxt user m (MemberId entityId) (MemberKey relayKey) p
pure $ MemberId entityId
_ -> throwChatError $ CEException "relay link: no relay link data or entity id"
case cReq of
@@ -1265,8 +1260,8 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
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
joinAgentConnectionAsync cmdId True connId' True cReq dm subMode
cmdId <- withStore' $ \db -> createCommand db user (Just $ dbConnId conn) CFJoinConn
joinAgentConnectionAsync cmdId True (aConnId conn) True cReq dm subMode
CFGetRelayDataAccept -> do
let GroupMember {memberId = MemberId expectedMemberId} = m
if linkEntityId == Just expectedMemberId
@@ -1277,7 +1272,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
(confId, m', relay) <- withStore $ \db -> do
confId <- getRelayConfId db m
liftIO $ updateGroupMemberStatus db userId m GSMemAccepted
(m', relay) <- setRelayLinkAccepted db cxt user m (MemberKey relayKey) Nothing relayProfile
(m', relay) <- setRelayLinkAccepted db cxt user m (MemberKey relayKey) relayProfile
pure (confId, m', relay)
allowAgentConnectionAsync user conn confId (Just g) XOk
toView $ CEvtGroupRelayUpdated user gInfo m' relay
@@ -1410,7 +1405,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
(signedMsg_, ChatMessage {chatVRange, chatMsgEvent}) <- parseChatMessage' conn connInfo
let reqHeader = directPresHeader binding
case chatMsgEvent of
XContact p memberKey_ xContactId_ welcomeMsgId_ requestMsg_ -> profileContactRequest invId chatVRange reqHeader p memberKey_ xContactId_ welcomeMsgId_ requestMsg_ pqSupport rejectionSupported
XContact p memberKey_ xContactId_ welcomeMsgId_ requestMsg_ -> mapM (traverse chatLinkBadge) requestMsg_ >>= \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 reqHeader p Nothing Nothing Nothing Nothing pqSupport rejectionSupported
XGrpRelayInv groupRelayInv -> xGrpRelayInv invId chatVRange groupRelayInv
@@ -1706,7 +1701,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 (PHChat <$> memberChatBinding gInfo joiningMemberId Nothing) Nothing (Just joiningMemberId) Nothing GAAccepted acceptRole Nothing (Just joiningMemberKey) existingMem_
mem <- acceptGroupJoinRequestAsync user uclId g invId chatVRange p (memberPresHeader 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'
@@ -1952,14 +1947,6 @@ 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
@@ -2713,19 +2700,13 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
memberKeys <- atomically . C.generateKeyPair =<< asks random
(GIK gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership} gks, hostId) <- withStore $ \db -> createGroupInvitation db cxt user ct inv customUserProfileId memberKeys
void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing Nothing (Just epochStart)
let GroupMember {groupMemberId, memberId = membershipMemId} = membership
let GroupMember {groupMemberId} = membership
-- hostContact is only reported for group links, where the client replaces
-- the transient host connection view with the group and removes its chat
joinGroupAsync hostContact_ sameLink = do
subMode <- chatReadVar subscriptionMode
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
dm <- encodeXGrpAcpt user (GIK gInfo gks) peerChatVRange
(connIds@(cmdId, acId), _) <- prepareAgentJoin user True connRequest
withStore' $ \db -> do
when sameLink $ setViaGroupLinkUri db groupId connId
createMemberConnectionAsync db user hostId connIds connChatVersion peerChatVRange subMode
@@ -2762,7 +2743,9 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
MsgError e -> createInternalChatItem user cd (CIRcvIntegrityError e) (Just brokerTs)
xInfo :: Contact -> Profile -> CM ()
xInfo c p' = void $ processContactProfileUpdate c p' True
xInfo c p' = do
presHeader_ <- pure (contactConn c) $>>= connPresHeader
void $ processContactProfileUpdate c presHeader_ p' True
xDirectDel :: Contact -> RcvMessage -> MsgMeta -> CM ()
xDirectDel c msg msgMeta =
@@ -2785,11 +2768,10 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
where
brokerTs = metaBrokerTs msgMeta
processContactProfileUpdate :: Contact -> Profile -> Bool -> CM Contact
processContactProfileUpdate c@Contact {profile = lp} p' createItems
processContactProfileUpdate :: Contact -> Maybe ProofPresHeader -> Profile -> Bool -> CM Contact
processContactProfileUpdate c@Contact {profile = lp} presHeader_ 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 presHeader_ p'
@@ -2830,44 +2812,38 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
Profile {displayName = n', fullName = fn', shortDescr = sd', image = i', contactLink = cl'} = p'
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 (PHChat <$> binding_) p' (Just (msg, brokerTs))
xInfoMember gInfo m p' mKey msg@RcvMessage {signedMsg_} brokerTs = do
m' <- maybe (pure m) (storeMemberKey gInfo m signedMsg_) mKey
void $ processMemberProfileUpdate gInfo m' signedMsg_ p' (Just (msg, brokerTs))
pure $ memberEventDeliveryScope m
xGrpLinkMem :: GroupInfo -> GroupMember -> Connection -> Profile -> Maybe MemberKey -> RcvMessage -> CM ()
xGrpLinkMem gInfo@GroupInfo {membership, businessChat} m@GroupMember {groupMemberId, memberCategory} Connection {viaGroupLink} p' mKey msg = do
xGrpLinkMem gInfo@GroupInfo {membership, businessChat} m@GroupMember {groupMemberId, memberCategory} Connection {viaGroupLink} p' mKey RcvMessage {signedMsg_} = do
xGrpLinkMemReceived <- withStore $ \db -> getXGrpLinkMemReceived db groupMemberId
if (viaGroupLink || isJust businessChat) && isNothing (memberContactId m) && memberCategory == GCHostMember && not xGrpLinkMemReceived
then do
binding_ <- verifiedMemberBinding gInfo m mKey msg
m' <- processMemberProfileUpdate gInfo m (PHChat <$> binding_) p' Nothing
m' <- maybe (pure m) (storeMemberKey gInfo m signedMsg_) mKey
m'' <- processMemberProfileUpdate gInfo m' signedMsg_ p' Nothing
withStore' $ \db -> setXGrpLinkMemReceived db groupMemberId True
let connectedIncognito = memberIncognito membership
probeMatchingMemberContact m' connectedIncognito
probeMatchingMemberContact m'' connectedIncognito
else messageError "x.grp.link.mem error: invalid group link host profile update"
verifiedMemberBinding :: GroupInfo -> GroupMember -> Maybe MemberKey -> RcvMessage -> CM (Maybe ByteString)
verifiedMemberBinding gInfo m@GroupMember {memberId, memberPubKey} mKey RcvMessage {msgSigned, signedMsg_} = do
storedKey_ <- maybe (pure Nothing) (storeMemberKey gInfo m signedMsg_) mKey
let key_ = if msgSigned == Just MSSVerified then memberPubKey else storedKey_
pure $ memberChatBinding gInfo memberId key_
signedMemberBinding :: GroupInfo -> GroupMember -> Maybe SignedMsg -> Maybe ByteString
signedMemberBinding gInfo GroupMember {memberId, memberPubKey} signedMsg_ =
memberChatBinding gInfo memberId $ mfilter (\k -> memberSigned gInfo memberId k signedMsg_) memberPubKey
signedMemberPresHeader :: GroupInfo -> GroupMember -> Maybe SignedMsg -> Maybe ProofPresHeader
signedMemberPresHeader gInfo GroupMember {memberId, memberPubKey} signedMsg_ =
memberPresHeader gInfo memberId $ mfilter (\k -> memberSigned gInfo memberId k signedMsg_) memberPubKey
memberSigned :: GroupInfo -> MemberId -> C.PublicKeyEd25519 -> Maybe SignedMsg -> Bool
memberSigned gInfo memberId k = \case
Just SignedMsg {chatBinding = CBGroup, signatures, signedBody} -> verifyGroupSig k gInfo memberId signatures signedBody
_ -> False
storeMemberKey :: GroupInfo -> GroupMember -> Maybe SignedMsg -> MemberKey -> CM (Maybe C.PublicKeyEd25519)
storeMemberKey gInfo GroupMember {groupMemberId, memberPubKey, memberId} signedMsg_ (MemberKey k) = case memberPubKey of
Just k0 -> Nothing <$ when (k /= k0) (messageError "member key change rejected, keeping current key")
storeMemberKey :: GroupInfo -> GroupMember -> Maybe SignedMsg -> MemberKey -> CM GroupMember
storeMemberKey gInfo m@GroupMember {groupMemberId, memberPubKey, memberId} signedMsg_ (MemberKey k) = case memberPubKey of
Just k0 -> m <$ when (k /= k0) (messageError "member key change rejected, keeping current key")
Nothing
| memberSigned gInfo memberId k signedMsg_ -> Just k <$ withStore' (\db -> setMemberPubKey db groupMemberId k)
| otherwise -> Nothing <$ messageError "member key not signed by that key, ignored"
| memberSigned gInfo memberId k signedMsg_ -> m {memberPubKey = Just k} <$ withStore' (\db -> setMemberPubKey db groupMemberId k)
| otherwise -> m <$ messageError "member key not signed by that key, ignored"
xGrpLinkAcpt :: GroupInfoKeys -> GroupMember -> GroupAcceptance -> GroupMemberRole -> MemberId -> RcvMessage -> UTCTime -> CM ()
xGrpLinkAcpt g@(GIK gInfo@GroupInfo {membership} _) m acceptance role memberId msg brokerTs
@@ -2927,10 +2903,10 @@ 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 ProofPresHeader -> Profile -> Maybe (RcvMessage, UTCTime) -> CM GroupMember
processMemberProfileUpdate gInfo m@GroupMember {memberProfile = p, memberContactId} presHeader_ rcvProfile msgTs_
processMemberProfileUpdate :: GroupInfo -> GroupMember -> Maybe SignedMsg -> Profile -> Maybe (RcvMessage, UTCTime) -> CM GroupMember
processMemberProfileUpdate gInfo m@GroupMember {memberProfile = p, memberContactId, memberBadgeProof} signedMsg_ 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 || proofHeaderChanged = do
| contentChanged || badgeNeedsReverify p || memberProofChanged = do
when contentChanged $ updateBusinessChatProfile gInfo
case memberContactId of
Nothing -> do
@@ -2959,16 +2935,14 @@ 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
presHeader_ = signedMemberPresHeader gInfo m signedMsg_
(p', memberProofChanged) = case rcvProfile of
Profile {badge = Just b} | not (acceptedProof presHeader_ b) -> (rcvProfile {badge = storedProof}, False)
Profile {badge} -> (rcvProfile, (proofContent <$> badge) /= (proofContent <$> unNoJSON memberBadgeProof))
proofContent BadgeProof {presHeader, badgeInfo} = (presHeader, badgeInfo)
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'
@@ -3203,13 +3177,12 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
toView $ CEvtContactAndMemberAssociated user c2 g m1 c2'
pure c2'
saveConnInfo :: Connection -> ConnInfo -> CM (Connection, Maybe GroupInfoKeys)
saveConnInfo activeConn connInfo = do
saveConnInfo :: Connection -> Maybe ProofPresHeader -> ConnInfo -> CM (Connection, Maybe GroupInfoKeys)
saveConnInfo activeConn presHeader_ connInfo = do
ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage activeConn connInfo
conn' <- updatePeerChatVRange activeConn chatVRange
case chatMsgEvent of
XInfo p _ -> do
presHeader_ <- connPresHeader conn'
ct <- withStore $ \db -> createDirectContact db cxt user conn' presHeader_ p
toView $ CEvtContactConnecting user ct
pure (conn', Nothing)
@@ -3234,7 +3207,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 presHeader_ = PHChat <$> memberChatBinding gInfo memId ((\(MemberKey k) -> k) <$> assertedKey_)
let presHeader_ = memberInfoPresHeader gInfo memInfo
if sameMemberId memId (membership gInfo)
then pure Nothing
else
@@ -3315,8 +3288,8 @@ 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 _ introKey_) memRestrictions = do
let presHeader_ = PHChat <$> memberChatBinding gInfo memId ((\(MemberKey k) -> k) <$> introKey_)
xGrpMemIntro gInfo@GroupInfo {chatSettings} m@GroupMember {memberRole, localDisplayName = c} memInfo@(MemberInfo memId _ memChatVRange _ _) memRestrictions = do
let presHeader_ = memberInfoPresHeader gInfo memInfo
case memberCategory m of
GCHostMember ->
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db cxt user gInfo memId) >>= \case
@@ -3367,7 +3340,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 _ introKey_) IntroInvitation {groupConnReq, directConnReq} = do
xGrpMemFwd g@(GIK gInfo@GroupInfo {membership, chatSettings} _) m memInfo@(MemberInfo memId memRole memChatVRange _ _) IntroInvitation {groupConnReq, directConnReq} = do
let GroupMember {memberId = membershipMemId} = membership
checkHostRole m memRole
toMember <- withStore $ \db -> do
@@ -3378,7 +3351,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 (PHChat <$> memberChatBinding gInfo memId ((\(MemberKey k) -> k) <$> introKey_)) GCPostMember GSMemAnnounced
SEGroupMemberNotFoundByMemberId _ -> createNewGroupMember db cxt user gInfo m memInfo (memberInfoPresHeader gInfo memInfo) GCPostMember GSMemAnnounced
e -> throwError e
-- TODO [knocking] separate pending statuses from GroupMemberStatus?
-- TODO add GSMemIntroInvitedPending, GSMemConnectedPending, etc.?
@@ -3389,24 +3362,27 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
subMode <- chatReadVar subscriptionMode
let mcvr = maybe chatInitialVRange fromChatVRange memChatVRange
chatV = vr cxt `peerConnChatVersion` mcvr
p = redactedMemberProfile gInfo membership $ fromLocalProfile $ memberProfile membership
-- [incognito] send membership incognito profile, create direct connection as incognito
membershipProfile <-
if chatV >= relayWebCapVersion
then presentUserBadge user (incognitoMembershipProfile gInfo) (groupPresHeader gInfo) p
else pure p
membershipProfile <- membershipHandshakeProfile gInfo chatV
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 (fmap fst . prepareAgentJoin user Nothing True) directConnReq
(groupConnIds@(gCmdId, gAcId), _) <- prepareAgentJoin user enableNtfsGrp groupConnReq
directConnIds <- mapM (fmap fst . prepareAgentJoin user 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
forM_ ((,) <$> directConnIds <*> directConnReq) $ \((dCmdId, dAcId), dcr) ->
joinAgentConnectionAsync dCmdId False dAcId True dcr dm subMode
membershipHandshakeProfile :: GroupInfo -> VersionChat -> CM Profile
membershipHandshakeProfile gInfo@GroupInfo {membership} v
| v >= relayWebCapVersion = presentUserBadge user (incognitoMembershipProfile gInfo) (groupPresHeader gInfo) p
| otherwise = pure p
where
p = redactedMemberProfile gInfo membership $ fromLocalProfile $ memberProfile membership
-- rollback defense (channels): apply an owner-signed role/removal only at a version >= the persisted
-- roster_version (not the batch-constant gInfo, which a relay can stale by reordering events in one
-- batch), then advance it in the same transaction; a strictly lower version is a replay and is ignored.
@@ -3929,12 +3905,12 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
}
joinExistingContact subMode mCt@Contact {contactId = mContactId}
| autoAcceptMemberContacts user = do
((cmdId, acId), binding_) <- prepareAgentJoin user Nothing True connReq
((cmdId, acId), presHeader) <- prepareAgentJoin user 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 (directPresHeader <$> binding_) subMode
joinMemberContactAsync cmdId acId presHeader subMode
securityCodeChanged mCt'
createItems mCt' m
| otherwise = do
@@ -3948,14 +3924,14 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
createItems mCt' m
createNewContact subMode
| autoAcceptMemberContacts user = do
((cmdId, acId), binding_) <- prepareAgentJoin user Nothing True connReq
((cmdId, acId), presHeader) <- prepareAgentJoin user 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 (directPresHeader <$> binding_) subMode
joinMemberContactAsync cmdId acId presHeader subMode
createInternalChatItem user (CDDirectSnd mCt) CIChatBanner (Just epochStart)
createItems mCt m'
| otherwise = do
@@ -3968,9 +3944,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 presHeader_ subMode = do
joinMemberContactAsync cmdId acId presHeader subMode = do
-- [incognito] send membership incognito profile
p <- presentUserBadge user (incognitoMembershipProfile g) presHeader_ $ userProfileDirect user (fromLocalProfile <$> incognitoMembershipProfile g) Nothing True
p <- presentUserBadge user (incognitoMembershipProfile g) (Just 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
@@ -3978,7 +3954,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
(g', m'', scopeInfo) <- mkGroupChatScope g m'
createInternalChatItem user (CDGroupRcv g' scopeInfo m'') (CIRcvGroupEvent RGEMemberCreatedContact) Nothing
toView $ CEvtNewMemberContactReceivedInv user mCt' g' m''
forM_ mContent_ $ \mc -> do
forM_ mContent_ $ chatLinkBadge >=> \mc -> do
(ci, cInfo) <- saveRcvChatItem user (CDDirectRcv mCt') msg brokerTs (CIRcvMsgContent mc, msgContentTexts mc)
toView $ CEvtNewChatItems user [AChatItem SCTDirect SMDRcv cInfo ci]
@@ -4026,7 +4002,7 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
-- file description is always allowed, to allow sending files to support scope
XMsgFileDescr sharedMsgId fileDescr fileExpires fileBadge -> void $ groupMessageFileDescription gInfo author_ sharedMsgId fileDescr fileExpires fileBadge
XMsgUpdate sharedMsgId mContent mentions ttl live msgScope asGroup_ ->
void $ memberCanSend author_ msgScope $ groupMessageUpdate gInfo author_ sharedMsgId mContent mentions msgScope rcvMsg msgTs ttl live asGroup_
void $ memberCanSend author_ msgScope $ chatLinkBadge mContent >>= \mc -> groupMessageUpdate gInfo author_ sharedMsgId mc mentions msgScope rcvMsg msgTs ttl live asGroup_
XMsgDel sharedMsgId memId scope_ _ -> void $ groupMessageDelete gInfo author_ sharedMsgId memId scope_ False rcvMsg msgTs
XMsgReact sharedMsgId memId scope_ reaction add -> withAuthor XMsgReact_ $ \author -> void $ groupMsgReaction gInfo author sharedMsgId memId scope_ reaction add rcvMsg msgTs
XFileCancel sharedMsgId -> void $ xFileCancelGroup gInfo author_ sharedMsgId
src/Simplex/Chat/Store/Groups.hs
+9 -9
View File
@@ -1808,8 +1808,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 ProofPresHeader -> Profile -> ExceptT StoreError IO (GroupMember, GroupRelay)
setRelayLinkAccepted db cxt user m (MemberKey relayKey) presHeader_ profile = do
setRelayLinkAccepted :: DB.Connection -> StoreCxt -> User -> GroupMember -> MemberKey -> Profile -> ExceptT StoreError IO (GroupMember, GroupRelay)
setRelayLinkAccepted db cxt user m (MemberKey relayKey) profile = do
let gmId = groupMemberId' m
currentTs <- liftIO getCurrentTime
liftIO $ DB.execute
@@ -1828,7 +1828,7 @@ setRelayLinkAccepted db cxt user m (MemberKey relayKey) presHeader_ profile = do
WHERE group_member_id = ?
|]
(relayKey, currentTs, gmId)
void $ updateMemberProfile db cxt user m presHeader_ profile
void $ updateMemberProfile db cxt user m Nothing profile
(,) <$> getGroupMemberById db cxt user gmId <*> getGroupRelayByGMId db gmId
setRelayLinkConfId :: DB.Connection -> GroupMember -> ConfirmationId -> ShortLinkContact -> IO ()
@@ -1875,8 +1875,8 @@ getRelayConfId db m =
|]
(Only (groupMemberId' m))
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
updateRelayMemberData :: DB.Connection -> StoreCxt -> User -> GroupMember -> MemberId -> MemberKey -> Profile -> ExceptT StoreError IO ()
updateRelayMemberData db cxt user m memberId (MemberKey relayKey) profile = do
currentTs <- liftIO getCurrentTime
liftIO $
DB.execute
@@ -1887,7 +1887,7 @@ updateRelayMemberData db cxt user m memberId (MemberKey relayKey) presHeader_ pr
WHERE group_member_id = ?
|]
(memberId, relayKey, currentTs, groupMemberId' m)
void $ updateMemberProfile db cxt user m presHeader_ profile
void $ updateMemberProfile db cxt user m Nothing profile
setGroupInProgressDone :: DB.Connection -> GroupInfo -> IO ()
setGroupInProgressDone db GroupInfo {groupId} = do
@@ -2050,7 +2050,7 @@ getRelayPublishableGroups db User {userId, userContactId} =
where
toRow ((gId, pgId) :. accessRow) = (gId, pgId, toPublicGroupAccess accessRow)
getGroupViaPublicGroupId :: DB.Connection -> User -> B64UrlByteString -> IO (Maybe (GroupId, Maybe ShortLinkContact))
getGroupViaPublicGroupId :: DB.Connection -> User -> B64UrlByteString -> IO (Maybe (GroupId, ShortLinkContact))
getGroupViaPublicGroupId db User {userId} publicGroupId =
maybeFirstRow id $
DB.query
@@ -2635,13 +2635,13 @@ createIntroReMember
cxt
user
gInfo
(MemberInfo memId memRole memChatVRange memberProfile memKey)
memInfo@(MemberInfo _ _ _ memberProfile _)
presHeader_
memRestrictions_ = do
currentTs <- liftIO getCurrentTime
(localDisplayName, memProfileId, memberProfile', badgeVerified) <- createNewMemberProfile_ db cxt user memberProfile presHeader_ currentTs
let memRestriction = restriction <$> memRestrictions_
newMember = NewGroupMember {memInfo = MemberInfo memId memRole memChatVRange memberProfile' memKey, memCategory = GCPreMember, memStatus = GSMemIntroduced, memRestriction, memInvitedBy = IBUnknown, memInvitedByGroupMemberId = Nothing, localDisplayName, memContactId = Nothing, memProfileId}
newMember = NewGroupMember {memInfo = (memInfo :: MemberInfo) {profile = memberProfile'}, 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
src/Simplex/Chat/Types.hs
+9 -12
View File
@@ -850,22 +850,19 @@ fromLocalProfile LocalProfile {displayName, fullName, shortDescr, description, i
ShownBadge _ _ -> Nothing -- a display-only badge is not sent
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)
profileBadgeVerified expected keys lp_ p@Profile {badge = rcvBadge} =
(,) p {badge = newBadge} <$> case (storedBadge, newBadge) of
(_, Nothing) -> pure (Just False)
-- 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 <- storedBadge, localBadgeInfo lb == newInfo && localBadgeStatus lb `notElem` [BSFailed, BSUnknownKey] -> pure (p, Just True)
| otherwise -> (,) p <$> verifyBadge keys newB
(Just lb, Just (BadgeProof _ _ _ newInfo))
| localBadgeInfo lb == newInfo && localBadgeStatus lb `notElem` [BSFailed, BSUnknownKey] -> pure (Just True)
(_, Just newB) -> 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
newBadge
| all (acceptedProof expected) rcvBadge = rcvBadge
| otherwise = (\Profile {badge} -> badge) . fromLocalProfile =<< lp_
-- 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
tests/ChatTests/Profiles.hs
+29 -6
View File
@@ -77,6 +77,7 @@ chatProfileTests = do
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 of member invited via contact, forwarded to introduced member" testUserBadgeInvitedIntroduced
it "supporter badge of inviting host in the reply to the invited contact" testUserBadgeInvitingHost
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
@@ -415,7 +416,6 @@ testUserBadgeGroupHandshake ps = do
bob <## "#team: alice added cath (Catherine) to the group (connecting...)"
bob <## "#team: new member cath is connected"
]
-- bob sent nothing to the group, so the badge reached cath in the member connection handshake
cath ##> "/i #team bob"
cath <## "group ID: 1"
cath <##. "member ID: "
@@ -434,7 +434,6 @@ testUserBadgeGroupUpdate ps = do
test sk alice bob cath = do
createGroup3 "team" alice bob cath
addTestBadge bob =<< issueTestBadge sk futureDate
-- the profile with the badge is sent to the group with the next message
bob #> "#team hello"
alice <# "#team bob> hello"
cath <# "#team bob> hello"
@@ -715,7 +714,7 @@ testUserBadgeOtherBinding ps = do
(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")
Right otherProof <- badgeProof pk legend (PHChat $ encodeChatBinding CBGroup "other chat")
withCCUser alice $ \user -> do
ct <- getTestCCContact alice 2
let p = (userProfileDirect user Nothing (Just ct) True) {badge = Just otherProof}
@@ -829,6 +828,20 @@ testUserBadgeInvitedIntroduced ps = do
cath <## "#team: alice added bob (Bob) to the group (connecting...)"
memberBadgeHeader cath "team" "bob" `shouldReturn` Just ("CG", BSActive)
testUserBadgeInvitingHost :: HasCallStack => TestParams -> IO ()
testUserBadgeInvitingHost ps = do
Right (pk, sk) <- bbsKeyGen
testChatCfg2 (testCfg {badgePublicKeys = testBadgeKeys pk}) aliceProfile bobProfile (test sk) ps
where
test sk alice bob = do
connectUsers alice bob
addTestBadge alice =<< issueTestBadge sk futureDate
alice #> "@bob hi"
bob <# "alice *> hi"
createGroup2' "team" alice (bob, GRAdmin) False
memberBadgeHeader bob "team" "alice" `shouldReturn` Just ("CD", BSActive)
memberProofHeader bob "team" "alice" `shouldReturn` Just "CG"
testUserBadgeInvitationLinkData :: HasCallStack => TestParams -> IO ()
testUserBadgeInvitationLinkData ps = do
Right (pk, sk) <- bbsKeyGen
@@ -845,7 +858,7 @@ testUserBadgeInvitationLinkData ps = do
sLinkData `shouldContain` "\"status\":\"active\""
bob ##> ("/_prepare contact 1 " <> fullLink <> " " <> shortLink <> " " <> sLinkData)
bob <## "alice: contact is prepared"
contactBadgeHeader bob "alice" `shouldReturn` Just ("R", BSActive)
contactBadgeHeader bob "alice" `shouldReturn` Just ("L", BSActive)
testUserBadgeAddressFirstShortLink :: HasCallStack => TestParams -> IO ()
testUserBadgeAddressFirstShortLink ps = do
@@ -887,14 +900,24 @@ testUserBadgeAddressCard ps = do
lastItemContent bob >>= (`shouldContain` "\"badgeType\":\"supporter\"")
cred <- issueTestBadge sk futureDate
Right otherProof <- badgeProof pk cred (PHLink "other link")
Right testProof <- badgeProof pk cred (PHTest "nonce")
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) <> "}]")
card proof = MCChat (T.pack bLink) (MCLContact cLink (profileFromName "alice") {badge = Just proof} False) Nothing
bob ##> ("/_send @3 json [{\"msgContent\":" <> T.unpack (encodeJSON $ card otherProof) <> "}]")
bob <# "@cath contact address of @alice:"
_ <- getTermLine bob
cath <# "bob> contact address of @alice:"
_ <- getTermLine cath
lastItemContent cath >>= (`shouldNotContain` "\"badge\"")
bob #> "@cath hi"
cath <# "bob> hi"
msgId <- lastItemId bob
bob ##> ("/_update item @3 " <> msgId <> " json {\"msgContent\":" <> T.unpack (encodeJSON $ card testProof) <> ",\"mentions\":{}}")
bob <# "@cath [edited] contact address of @alice:"
_ <- getTermLine bob
cath <# "bob> [edited] contact address of @alice:"
_ <- getTermLine cath
lastItemContent cath >>= (`shouldNotContain` "\"badge\"")
testUpdateProfileImage :: HasCallStack => TestParams -> IO ()
testUpdateProfileImage =