From 9219e7d2acfd451a84653d9eac5a60150a32e829 Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Mon, 20 Jul 2026 21:35:54 +0000 Subject: [PATCH 01/15] agent: request rejection --- .../2026-07-11-service-rpc-implementation.md | 142 +++++++++--------- src/Simplex/Messaging/Agent.hs | 59 ++++++-- src/Simplex/Messaging/Agent/Protocol.hs | 37 ++++- src/Simplex/Messaging/Agent/Store.hs | 7 + tests/AgentTests/ConnectionRequestTests.hs | 10 ++ tests/AgentTests/FunctionalAPITests.hs | 31 +++- 6 files changed, 204 insertions(+), 82 deletions(-) diff --git a/plans/2026-07-11-service-rpc-implementation.md b/plans/2026-07-11-service-rpc-implementation.md index d3529f141..dc0245bfb 100644 --- a/plans/2026-07-11-service-rpc-implementation.md +++ b/plans/2026-07-11-service-rpc-implementation.md @@ -2,65 +2,72 @@ RFC: [../rfcs/2026-07-11-service-rpc.md](../rfcs/2026-07-11-service-rpc.md) -Depends on: [2026-07-12-address-dr-implementation.md](2026-07-12-address-dr-implementation.md). RPC establishes the double ratchet from the service address exactly as the address-DR plan does; this plan is the RPC layer on top of it. Steps named R2'/O2'/O3' below are from that plan. Constructor, event, table and function names are provisional. +Depends on: [2026-07-12-address-dr-implementation.md](2026-07-12-address-dr-implementation.md). RPC establishes the double ratchet from the address exactly as the address-DR plan does; this plan is the RPC layer on top of it. Steps named R2'/O2'/O3' below are from that plan. Constructor, event, table and function names are provisional. -RPC is a one-directional short-lived DR exchange: the client establishes the ratchet from the address (address-DR requester), sends one request, receives one or more responses on its reply queue, and both sides tear the ratchet down after the final response. Unlike a connection, the service does not send a reply queue back and no persistent connection remains. +**Scope of this pass: transport + rejection.** The request/response/rejection exchange and its teardown, plus communicated rejection of contact and RPC requests. Service-side **idempotency** (single execution by request hash) is **deferred** to a later pass; it stays documented below (the schema and the Idempotency section), marked deferred, but is not built now. + +RPC is a one-directional short-lived DR exchange: the client establishes the ratchet from the address (address-DR requester), sends one request, receives one or more responses on its reply queue, and both sides tear the ratchet down after the final response. Unlike a connection, the service does not send a reply queue back and no persistent connection remains. A service publishes an ordinary DR-advertising contact address - the same address also accepts connection requests, and the owner distinguishes the two by the decrypted inner message (`AgentConnInfoReply` -> a connection, `AgentServiceRequest` -> an RPC). ## Versions -- `VersionSMPA` (agent protocol): the new `AgentServiceRequest`/`AgentServiceResponse` messages and the service address subtype. RPC requires the address-DR agent version, whose ratchet establishment it reuses. +- `VersionSMPA` (agent protocol): the new inner `AgentServiceRequest`/`AgentServiceResponse`/`AgentRejection` messages, and the `AgentInvitationDR` -> `AgentContactRequest` rename. RPC reuses the address-DR ratchet establishment; `AgentInvitationDR` is unreleased (`currentSMPAgentVersion = 7`, Protocol.hs:339), so the rename and the new inner variants need no version gate beyond the address-DR work. `SSND` (SMP protocol) and the hybrid queue header (SMP client) are not used here - they are separate RFCs (combined secure-send; queue-layer PQ). The ratchet provides post-quantum encryption, and the reply queue is secured with `SKEY` as in the address-DR owner path (O3'). -## Service address +## RPC messages -A service address is a DR-advertising contact address (address-DR plan: `linkRatchetKey` in fixed data, `RatchetKeys` in mutable data) with a service subtype. There is no separate `ServiceKeyBundle` - requests are encrypted by establishing the ratchet against the advertised keys. +Two envelope layers, and it matters which is which (the L3/L4 layers of the address-DR plan). RPC and rejection add **no new outer envelope** - they reuse three existing ones; every new type is an **inner** `AgentMessage` variant, under the ratchet. -The subtype distinguishes RPC from a normal connection and drives the owner's handling. Reuse the `ContactConnType` char slot: +**Outer `AgentMsgEnvelope`** (L3, per-queue-e2e; encoding at Protocol.hs:874) - what an SMP queue carries: -```haskell -data ContactConnType = CCTContact | CCTChannel | CCTGroup | CCTRelay | CCTService -ctTypeChar CCTService = 'S' -- 's' in links -ctTypeP 'S' = pure CCTService -``` +- `AgentContactRequest` (renamed from `AgentInvitationDR`, tag `'A'`) - the request sent to the address queue, used for BOTH a contact invitation and an RPC request. Carries `e2eSndParams` (the requester's Snd X3DH parameters), `ratchetKeyId`, and `encConnInfo` (the ratchet-encrypted inner message). A contact invitation and an RPC request are byte-identical on the wire; they differ only in the inner message, which is under the ratchet and invisible to servers - the "same outside double ratchet" property. (`AgentInvitationDR` is unreleased, so the tag was changed freely from `'J'` to `'A'`.) +- `AgentConfirmation` (tag `'C'`, with `e2eEncryption_ = Nothing`) - the first response on the reply queue Q_A. It *confirms Q_A*: establishes Q_A's per-queue e2e and SKEY-secures it, exactly as the first message on any fresh receive queue. `encConnInfo` is the ratchet-encrypted inner message. +- `AgentMsgEnvelope` (tag `'M'`) - every later response on Q_A. `encAgentMessage` is the ratchet-encrypted inner message. -Stored on the address receive queue as `link_contact_type` (NULL means the current contact type). A service address rejects `AgentInvitation` and connection `AgentConfirmation`; a non-service address rejects service requests. - -## RPC messages - -RPC adds two `AgentMessage` variants (Protocol.hs:883-889, parsed by `parseMessage`), parallel to `AgentConnInfoReply`, not new top-level envelopes. They are the decrypted content of the existing per-queue-e2e envelopes: the request is the `encConnInfo` of the address-DR `AgentConfirmation`; each response is the `encConnInfo` of an `AgentConfirmation` (first message to the reply queue) or the `encAgentMessage` of an `AgentMsgEnvelope` (later messages), all double-ratchet-encrypted. Their tags `Q`/`P` are the RFC's `agentRequest`/`agentResponse`. +**Inner `AgentMessage`** (L4, double-ratchet-encrypted; encoding at Protocol.hs:921, parsed by `parseMessage`) - the decrypted content of the outer `encConnInfo`/`encAgentMessage`. RPC and rejection add three variants alongside `AgentConnInfoReply`: ```haskell data AgentMessage - = ... -- AgentConnInfo 'I', AgentConnInfoReply 'D', AgentRatchetInfo 'R', AgentMessage 'M' - | AgentServiceRequest (NonEmpty SMPQueueInfo) MsgBody -- 'Q': reply queue(s) + opaque request payload - | AgentServiceResponse Bool (NonEmpty MsgBody) -- 'P': final flag + one or more response payloads + = ... -- AgentConnInfo 'I', AgentConnInfoReply 'D' (contact invitation: reply queue Q_A + profile), + -- AgentRatchetInfo 'R', AgentMessage APrivHeader AMessage 'M' + | AgentServiceRequest (NonEmpty SMPQueueInfo) MsgBody -- 'A': RPC request - reply queue Q_A + opaque payload + | AgentServiceResponse APrivHeader Bool (NonEmpty MsgBody) -- 'P': RPC response - header + final flag + one or more payloads + | AgentRejection APrivHeader ByteString -- 'J': refusal - header + opaque reason (contact or RPC) -- encoding (extends AgentMessage Encoding) -AgentServiceRequest qs body -> smpEncode ('Q', qs, Tail body) -AgentServiceResponse final bodies -> smpEncode ('P', final) <> smpEncodeList (map Large (L.toList bodies)) +AgentServiceRequest qs body -> smpEncode ('A', qs, Tail body) +AgentServiceResponse hdr final bodies -> smpEncode ('P', hdr, final, fmap Large bodies) +AgentRejection hdr reason -> smpEncode ('J', hdr, Tail reason) ``` -One response message carries one or more response payloads, so responses known together are one message; responses over time are separate messages, each with `final = False` until the last. There is no signature and no previous-message hash: the ratchet, established against the `linkRatchetKey` committed by the link hash (address-DR authentication), authenticates each message and its message numbering detects dropping and reordering. The request payload is opaque application bytes (the chat command); the reply queue fields are outside it. +The owner tells a request apart by its inner variant after decryption: `AgentConnInfoReply` -> a contact request (`REQ`); `AgentServiceRequest` -> an RPC request (`SREQ`). `AgentServiceResponse`/`AgentRejection` are responses on Q_A, delivered to the client's waiting call or callback. -The request hash used for idempotency is `SHA3-256` of the decrypted request payload (the `MsgBody` in `AgentServiceRequest`). +`AgentServiceResponse` carries an `APrivHeader` (`{sndMsgId, prevMsgHash}`, the same header as `AgentMessage 'M'`), so the response stream gets agent-level numbering and a previous-message-hash chain on top of the ratchet - a dropped or reordered response is caught by the chain, not only by the ratchet counters. One message still carries one or more payloads (`NonEmpty MsgBody`): responses known together in one message, responses over time in separate messages, each `final = False` until the last. `AgentServiceRequest` needs no header - a request is a single message. `AgentRejection` carries the header too, because a refusal can be the terminal message of a response stream (after zero or more `AgentServiceResponse`) and must chain with it; for a refused contact request it is the sole message on Q_A, with `sndMsgId = 1` and an empty previous hash. -The `AgentMsgEnvelope` receive path (`agentClientMsg`, Agent.hs:3289) today expects only `AgentMessage APrivHeader aMessage`; it is extended to accept `AgentServiceResponse` for the stream after the first response. +The `AgentMsgEnvelope` receive path (`agentClientMsg`, Agent.hs:3289) today expects only `AgentMessage APrivHeader aMessage`; it is extended to accept `AgentServiceResponse` and `AgentRejection` for the stream after the first response. ## Ratchet establishment - reuse of the address-DR flow Request (client), reusing the address-DR requester path (R2'/R3'): - Retrieve link data, reconstruct and negotiate the advertised `RcvE2ERatchetParamsUri`, create the reply queue Q_A (messaging mode, subscribed), establish the send ratchet (`generateSndE2EParams`, `pqX3dhSnd`, `initSndRatchet`, `createSndRatchet`). -- Send `AgentConfirmation {e2eEncryption_ = Just sndParams, ratchetKeyId = Just ratchetKeyId, encConnInfo = ratchetEncrypt(AgentServiceRequest (Q_A :| []) payload)}` to the address queue, unauthenticated (`agentCbEncryptOnce`). The client connection is `RcvConnection` (Q_A) with the send ratchet. +- Send `AgentContactRequest {e2eSndParams = sndParams, ratchetKeyId, encConnInfo = ratchetEncrypt(AgentServiceRequest (Q_A :| []) payload)}` to the address queue, unauthenticated (`agentCbEncryptOnce`) - the same outer envelope a contact invitation uses, with `AgentServiceRequest` inside instead of `AgentConnInfoReply`. The client connection is `RcvConnection` (Q_A) with the send ratchet. Request (service), reusing the address-DR owner path (O1'/O2'): -- `smpAddressConfirmation` selects the private keys by `ratchetKeyId`, `pqX3dhRcv`, `initRcvRatchet`, and `rcDecrypt` of `encConnInfo`, which also gives the connection its send side. The decrypted message is `AgentServiceRequest` (not `AgentConnInfoReply`), so the owner takes the RPC branch: create a `SndConnection` to Q_A (no Q_B, unidirectional) holding the ratchet, run idempotency (below), and either deliver `SREQ` or replay stored responses. This is receive-time establishment on unauthenticated input - the abuse bound of the address-DR plan ("Receive-time establishment, state, and abuse") applies unchanged. +- The DR-request handler (built as `smpInvitationDR`; renamed to the generic `smpContactRequest`, since it now serves both invitations and RPC) selects the private keys by `ratchetKeyId`, `pqX3dhRcv`, `initRcvRatchet`, and `rcDecrypt` of `encConnInfo`, which also gives the connection its send side. It branches on the decrypted inner message: `AgentConnInfoReply` -> the existing contact-request path (store the request, emit `REQ`); `AgentServiceRequest` -> the RPC path: create a `SndConnection` to Q_A (no Q_B, unidirectional) holding the ratchet and deliver `SREQ` to the bot. This is receive-time establishment on unauthenticated input - the abuse bound of the address-DR plan ("Receive-time establishment, state, and abuse") applies unchanged. + +Response (service): send each response to Q_A under the ratchet. The first message to Q_A is `AgentConfirmation {e2eEncryption_ = Nothing, encConnInfo = ratchetEncrypt(AgentServiceResponse hdr final bodies)}` (per-queue e2e is unestablished on Q_A - it is the confirming first message), securing Q_A with `SKEY` using the service's own key (`agentSecureSndQueue`, Q_A is messaging mode); later messages are `AgentMsgEnvelope {encAgentMessage = ratchetEncrypt(AgentServiceResponse hdr …)}`. After the `final = True` message, delete the send connection and its ratchet. + +Response (client): a message on Q_A (its `snd_service_requests` row marks it an RPC reply queue). The first is `AgentConfirmation … Nothing` and takes the address-DR `RcvConnection … Nothing` branch (R5'), extended to accept `AgentServiceResponse` and `AgentRejection`; later ones are `AgentMsgEnvelope` and take the standard message path, extended the same way. Each `agentRatchetDecrypt` advances the ratchet. The first response returns from the call; later responses go to the callback; an `AgentRejection` ends the exchange like a `final = True` response, surfacing the reason. On `final`, a rejection, the deadline, or `cancelServiceRequest`, delete Q_A (`DEL`) and the reply connection. -Response (service): send each response to Q_A under the ratchet. The first message to Q_A is `AgentConfirmation {e2eEncryption_ = Nothing, encConnInfo = ratchetEncrypt(AgentServiceResponse final bodies)}` (per-queue e2e is unestablished on Q_A - the address-DR first-message constraint), securing Q_A with `SKEY` using the service's own key (`agentSecureSndQueue`, Q_A is messaging mode); later messages are `AgentMsgEnvelope {encAgentMessage = ratchetEncrypt(AgentServiceResponse …)}`. After the `final = True` message, delete the send connection and its ratchet. +## Rejection -Response (client): a message on Q_A (its `snd_service_requests` row marks it an RPC reply queue). The first is `AgentConfirmation … Nothing` and takes the address-DR `RcvConnection … Nothing` branch (R5'), extended to accept `AgentServiceResponse`; later ones are `AgentMsgEnvelope` and take the standard message path, extended to accept `AgentServiceResponse`. Each `agentRatchetDecrypt` advances the ratchet. The first response returns from the call; later responses go to the callback. On `final`, the deadline, or `cancelServiceRequest`, delete Q_A (`DEL`) and the reply connection. +A rejection is the inner `AgentRejection` variant (above): a terminal message carrying an opaque reason, delivered to the requester's Q_A under the ratchet. The same variant refuses an RPC request and a contact request (which today is dropped silently). + +- Delivery: `AgentRejection` is the inner message of an `AgentConfirmation` sent to Q_A - the confirming first message on Q_A, exactly like the first response, but terminal and carrying no reply queue (an acceptance sends `AgentConnInfoReply` with Q_B; a rejection sends `AgentRejection` with nothing). If a rejection instead follows some RPC responses, it is the inner message of an `AgentMsgEnvelope`, chained by its `APrivHeader`. +- Owner/service API: parameterize the current silent drop. `rejectContact` (Agent.hs:1606, today `deleteInvitation` only) gains an optional reason: `Nothing` -> silent drop (unchanged); `Just reason` -> the owner already holds the post-decrypt ratchet in the stored DR request, so it encrypts `AgentRejection` under that ratchet, sends it to Q_A as an `AgentConfirmation`, then deletes the request. Only DR requests can be refused this way (they hold the ratchet); a classic `AgentInvitation` request has no ratchet and can only be dropped. An RPC request is refused the same way from its reply connection (`rejectServiceRequest`). +- Requester side: `AgentRejection` on a contact reply queue surfaces as a rejection event to chat (which maps it to `XReject`/`XGrpReject`, communicating-rejection RFC); on an RPC reply queue it ends `sendServiceRequest` with the reason. ## Reply queue - the requester's DR connection @@ -68,12 +75,9 @@ The reply queue is the address-DR requester connection: an `RcvConnection` whose ## Database schema -One migration (`M20260712_service_rpc`), on top of the address-DR migration. SQLite shown, PostgreSQL mirrors it. +One migration (`M20260712_service_rpc`), on top of the address-DR migration. SQLite shown, PostgreSQL mirrors it. Only `snd_service_requests` (client side) is built this pass; the three `rcv_service_*` tables belong to the deferred idempotency work, kept here so the schema stays in one place. ```sql --- service subtype on the address receive queue (address-DR adds the ratchet key columns) -ALTER TABLE rcv_queues ADD COLUMN link_contact_type TEXT; -- NULL = current contact type - -- client side: one pending request per reply queue connection. CREATE TABLE snd_service_requests( snd_service_request_id INTEGER PRIMARY KEY AUTOINCREMENT, @@ -121,19 +125,23 @@ The service's address ratchet keys are the address-DR `address_ratchet_keys` tab Service side: ```haskell --- Creates a DR-advertising contact address with CCTService subtype (address-DR createServiceAddress --- plus the subtype), generating the link ratchet key and the first RatchetKeys row. -createServiceAddress :: AgentClient -> UserId -> UserLinkData -> AE (ConnId, ConnShortLink 'CMContact) - --- Sends one response message with one or more payloads (final = True ends the exchange). The first --- message to each reply connection secures the reply queue with SKEY; later ones use SEND. Appends to --- rcv_service_responses. -sendServiceReply :: AgentClient -> ServiceRequestRef -> Bool -> NonEmpty MsgBody -> AE () +-- No separate service-address creation: a service publishes an ordinary DR-advertising contact address +-- (address-DR address creation with InitialKeys). The same address accepts both connections and RPC. + +-- Sends one response message with one or more payloads (final = True ends the exchange). The first message +-- to the reply connection secures Q_A with SKEY; later ones use SEND. connId is the reply connection from SREQ. +sendServiceReply :: AgentClient -> ConnId -> Bool -> NonEmpty MsgBody -> AE () + +-- Refuses an RPC request with an opaque reason (AgentRejection to Q_A), terminal; deletes the reply connection. +rejectServiceRequest :: AgentClient -> ConnId -> ByteString -> AE () + +-- Refuses a contact request: Nothing = silent drop (unchanged behaviour); Just reason = AgentRejection to Q_A. +rejectContact :: AgentClient -> ConfirmationId -> Maybe ByteString -> AE () ``` Key rotation and update use the address-DR `rotateRatchetKeys`/link-data update; address deletion is `deleteConnection`. -Client side (name resolution to a link is an existing API; the link must be a `CCTService` DR-advertising address): +Client side (name resolution to a link is an existing API; the link must be a DR-advertising address): ```haskell -- Establishes the ratchet from the address, creates the reply queue, sends the request, and waits for @@ -144,45 +152,43 @@ sendServiceRequest :: cancelServiceRequest :: AgentClient -> ConnId -> AE () -data ServiceResponse = ServiceResponse {bodies :: NonEmpty MsgBody, final :: Bool} +data ServiceResponse + = ServiceResponse {bodies :: NonEmpty MsgBody, final :: Bool} + | ServiceRejected {reason :: ByteString} ``` The waiting call and the callback are held in an in-memory map in `AgentClient`, keyed by the reply queue connection, filled by the receive path; they do not survive a restart. -Service side event (`AEvent`, entity is the service address connection): +Service side event (`AEvent`, entity is the address connection): ```haskell -SREQ :: ServiceRequestRef -> MsgBody -> AEvent AEConn -- request payload for the bot +-- connId = the reply (SndConnection) to Q_A; the bot passes it to sendServiceReply / rejectServiceRequest. +-- MsgBody = the opaque request payload. +SREQ :: ConnId -> MsgBody -> AEvent AEConn ``` -`ServiceRequestRef` identifies the `rcv_service_requests` record; the bot passes it to `sendServiceReply`. - -Rejection reuses `AgentRejection` (communicating-rejection RFC) as an `AgentServiceResponse`-level refusal or a dedicated variant - decided with that RFC. - ## Agent processing Client side: -- `sendServiceRequest`: retrieve link data per request (proxied per config); establish the ratchet and create Q_A (address-DR R2'); write the `snd_service_requests` row; send the `AgentServiceRequest` confirmation (proxied per config); wait on the in-memory sink for the first response until the deadline. -- Response processing in `processSMPTransmissions`: a message on a queue with a `snd_service_requests` row is a response; `agentRatchetDecrypt` (advancing the ratchet), parse `AgentServiceResponse`, deliver to the waiting call or the callback. On `final`/deadline/cancel, delete Q_A and the reply connection. +- `sendServiceRequest`: retrieve link data per request (proxied per config); establish the ratchet and create Q_A (address-DR R2'); write the `snd_service_requests` row; send the `AgentContactRequest` carrying `AgentServiceRequest` (proxied per config); wait on the in-memory sink for the first response until the deadline. +- Response processing in `processSMPTransmissions`: a message on a queue with a `snd_service_requests` row is a response; `agentRatchetDecrypt` (advancing the ratchet), parse `AgentServiceResponse`/`AgentRejection`, deliver to the waiting call or the callback. On `final`/rejection/deadline/cancel, delete Q_A and the reply connection. - `cleanupManager`: delete `snd_service_requests` past the deadline and mark their reply connections deleted; the existing deleted-connections step sends `DEL`. After a restart every row is stale, so this removes reply queues left behind. Service side: -- Address-queue dispatch on `link_contact_type`: a service address routes `AgentConfirmation` with `ratchetKeyId` to the RPC handler (address-DR `smpAddressConfirmation` producing `AgentServiceRequest`); it rejects `AgentInvitation` and connection confirmations. -- On `AgentServiceRequest`: establish the ratchet (address-DR O2'), create the `SndConnection` to Q_A, compute the request hash, look up `rcv_service_requests` by (address conn, hash): - - new: insert the request, insert a `rcv_service_reply_conns` row, deliver `SREQ` to the bot. - - existing: insert a `rcv_service_reply_conns` row and send it every stored `rcv_service_responses` in order, each `AgentServiceResponse` re-encrypted under this connection's ratchet. -- `sendServiceReply`: append a `rcv_service_responses` row, then send `AgentServiceResponse` to every reply connection of the request under its ratchet (`SKEY`+`SEND` for the first message to a connection, `SEND` after); set `ended` on `final`. -- `cleanupManager`: delete `rcv_service_requests` past `expires_at` (cascading to responses and reply connections, and their ratchets/queues). +- Address-queue dispatch: `smpContactRequest` (the renamed `smpInvitationDR`) decrypts `encConnInfo` and branches on the inner message - `AgentConnInfoReply` -> the contact-request path (`REQ`); `AgentServiceRequest` -> the RPC path. +- On `AgentServiceRequest`: establish the ratchet (address-DR O2'), create the `SndConnection` to Q_A, deliver `SREQ connId payload` to the bot (`connId` = the reply connection). No request-hash store this pass, so every request - including a repeat - reaches the bot as a fresh `SREQ` (single execution is the deferred idempotency work). +- `sendServiceReply`: send `AgentServiceResponse hdr final bodies` to Q_A under the ratchet (`SKEY`+`SEND` for the first message, `SEND` after); after `final = True`, delete the reply connection and its ratchet. +- `rejectServiceRequest`: send `AgentRejection hdr reason` to Q_A the same way, terminal; delete the reply connection. -Configuration (`AgentConfig`): default request deadline, request retention period (1 to 24 hours). Ratchet key rotation interval is the address-DR config. +Configuration (`AgentConfig`): default request deadline. (The retention period belongs to the deferred idempotency work.) -Errors reuse `AgentErrorType` (e.g. `CMD PROHIBITED` for a link that is not a service address). +Errors reuse `AgentErrorType`. -## Idempotency +## Idempotency (deferred) -The service identifies a request by its hash and keeps, for the retention period (config, not in link data), the ordered response payloads (`rcv_service_responses`) and the reply connections under that hash (`rcv_service_reply_conns`). A repeat request (same payload, therefore same hash) establishes its own ratchet and reply connection and does not reach the bot: while pending it is added and receives the responses so far and each later one; after completion it receives the whole stored sequence. Responses are stored as plaintext and re-encrypted per reply connection because each request has its own ratchet. This gives single execution over at-least-once delivery, bounded by the retention period. +**Deferred - not built this pass** (see the scope note); documented here for the follow-up. The service identifies a request by its hash and keeps, for the retention period (config, not in link data), the ordered response payloads (`rcv_service_responses`) and the reply connections under that hash (`rcv_service_reply_conns`). A repeat request (same payload, therefore same hash) establishes its own ratchet and reply connection and does not reach the bot: while pending it is added and receives the responses so far and each later one; after completion it receives the whole stored sequence. Responses are stored as plaintext and re-encrypted per reply connection because each request has its own ratchet. This gives single execution over at-least-once delivery, bounded by the retention period. ## Correlation and chat @@ -192,14 +198,16 @@ Both ends are chat bots on the chat library, which serializes a service command ## Tests -- Encoding roundtrips: `AgentServiceRequest`, `AgentServiceResponse` in `AgentMessage` (one and several response bodies); the service subtype in `UserContactData`/link. +- Encoding roundtrips: `AgentServiceRequest`, `AgentServiceResponse` (one and several response bodies), `AgentRejection` in `AgentMessage`; the renamed `AgentContactRequest` (wire unchanged from `AgentInvitationDR`). - End to end (on the address-DR machinery): a request with one response; several responses streamed to the callback; `pqEncryption` on (hybrid) and off (X448-only) per the advertised keys; the request payload never travels under per-queue-only encryption. -- Idempotency: a repeat while pending coalesces onto the same operation; a repeat after completion receives the stored responses without a second `SREQ`; both under fresh ratchets. -- Lifecycle: the reply connection and the service ratchet are deleted after `final`; deadline; cancellation; a restart deletes client reply queues. -- Rejection and rejection of the wrong envelope on a service vs non-service address. +- Rejection: an RPC request refused with `rejectServiceRequest` ends `sendServiceRequest` with the reason; a contact request refused with `rejectContact (Just reason)` reaches the requester as a rejection, vs `Nothing` = silent drop; the same address accepts a connection and an RPC and can refuse either. +- Lifecycle: the reply connection and the service ratchet are deleted after `final` and after a rejection; deadline; cancellation; a restart deletes client reply queues. +- (Idempotency tests are part of the deferred idempotency pass.) ## Phases -1. Service address subtype and dispatch on top of the address-DR flow; `AgentServiceRequest`/`AgentServiceResponse` messages; `createServiceAddress`. -2. Client: `sendServiceRequest`, reply-queue reception and callback, cleanup. -3. Service: request store, `sendServiceReply`, idempotency (coalescing and repeats under fresh ratchets), end-to-end and idempotency tests. +1. Rename `AgentInvitationDR` -> `AgentContactRequest`; add inner `AgentServiceRequest`/`AgentServiceResponse`/`AgentRejection`; generic inner-message dispatch in `smpContactRequest`; `SREQ` event. Encoding roundtrip tests. +2. Client: `sendServiceRequest`, reply-queue reception and callback, `cancelServiceRequest`, `snd_service_requests` + cleanup. Service: `sendServiceReply`. End-to-end request/response tests. +3. Rejection: `rejectContact` optional reason, `rejectServiceRequest`, requester-side surfacing; rejection tests. + +Later, separate pass: idempotency (the deferred schema + Idempotency section). diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 3e85b34b7..545c4415c 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -76,6 +76,7 @@ module Simplex.Messaging.Agent allowConnection, acceptContact, rejectContact, + rejectContactAsync, DatabaseDiff (..), compareConnections, syncConnections, @@ -499,10 +500,14 @@ acceptContact c userId connId enableNtfs = withAgentEnv c .::. acceptContact' c {-# INLINE acceptContact #-} -- | Reject contact (RJCT command) -rejectContact :: AgentClient -> ConfirmationId -> AE () -rejectContact c = withAgentEnv c . rejectContact' c +rejectContact :: AgentClient -> NetworkRequestMode -> UserId -> ConfirmationId -> Maybe ByteString -> AE () +rejectContact c nm userId invId reason = withAgentEnv c $ rejectContact' c nm userId invId reason {-# INLINE rejectContact #-} +rejectContactAsync :: AgentClient -> ACorrId -> UserId -> ConfirmationId -> Maybe ByteString -> AE () +rejectContactAsync c corrId userId invId reason = withAgentEnv c $ rejectContactAsync' c corrId userId invId reason +{-# INLINE rejectContactAsync #-} + data DatabaseDiff a = DatabaseDiff { missingIds :: [a], extraIds :: [a] @@ -1514,7 +1519,7 @@ joinConnSrv c nm userId connId enableNtfs cReqUri@CRContactUri {} cInfo pqSup su liftIO $ setConnPQSupport db connId pqSupport encConnInfo <- fst <$> agentRatchetEncrypt db cData (smpEncode sndReply) e2eEncConnInfoLength (Just $ CR.pqSupportToEnc pqSupport) maxV pure (e2eSndParams, encConnInfo) - pure AgentInvitationDR {agentVersion = v, e2eSndParams, ratchetKeyId, encConnInfo} + pure AgentContactRequest {agentVersion = v, e2eSndParams, ratchetKeyId, encConnInfo} void $ sendInvitation c nm userId connId qInfo envelope pure False where @@ -1602,11 +1607,32 @@ acceptContact' c nm userId connId enableNtfs invId ownConnInfo pqSupport subMode withStore' c $ \db -> acceptInvitation db invId ownConnInfo pure r --- | Reject contact (RJCT command) in Reader monad -rejectContact' :: AgentClient -> InvitationId -> AM () -rejectContact' c invId = +rejectContact' :: AgentClient -> NetworkRequestMode -> UserId -> InvitationId -> Maybe ByteString -> AM () +rejectContact' c nm userId invId reason_ = do + forM_ reason_ $ \reason -> do + (connId, cData, sq) <- prepareRejection c userId invId reason + void $ agentSecureSndQueue c nm cData sq + lift $ submitPendingMsg c sq + deleteConnectionAsync' c True connId + withStore' c $ \db -> deleteInvitation db invId + +rejectContactAsync' :: AgentClient -> ACorrId -> UserId -> InvitationId -> Maybe ByteString -> AM () +rejectContactAsync' c corrId userId invId reason_ = do + forM_ reason_ $ \reason -> do + (connId, _, sq) <- prepareRejection c userId invId reason + enqueueCommand c corrId connId (Just $ qServer sq) $ AInternalCommand ICReject withStore' c $ \db -> deleteInvitation db invId -{-# INLINE rejectContact' #-} + +prepareRejection :: AgentClient -> UserId -> InvitationId -> ByteString -> AM (ConnId, ConnData, SndQueue) +prepareRejection c userId invId reason = do + Invitation {connReq} <- withStore c $ \db -> getInvitation db "prepareRejection" invId + case connReq of + CRInvitation _ -> throwE $ CMD PROHIBITED "rejectContact: connection has no double ratchet to send rejection" + CRInvitationDR dr@DRInvitation {pqSupport} -> do + connId <- newConnToAccept c userId "" True invId pqSupport + (cData, sq) <- startJoinInvitationDR c userId connId Nothing dr + storeConfirmation c cData sq Nothing $ AgentRejection (APrivHeader 1 "") reason + pure (connId, cData, sq) syncConnections' :: AgentClient -> [UserId] -> [ConnId] -> AM (DatabaseDiff UserId, DatabaseDiff ConnId) syncConnections' c userIds connIds = do @@ -2071,6 +2097,13 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do ICDuplexSecure _rId senderKey -> withServer' . tryWithLock "ICDuplexSecure" . withDuplexConn $ \(DuplexConnection cData (rq :| _) (sq :| _)) -> do secure rq senderKey void $ enqueueMessage c cData sq SMP.MsgFlags {notification = True} HELLO + ICReject -> withServer' . tryWithLock "ICReject" $ + withStore c (`getConn` connId) >>= \case + SomeConn _ (SndConnection cData sq) -> do + void $ agentSecureSndQueue c NRMBackground cData sq + lift $ submitPendingMsg c sq + deleteConnectionAsync' c True connId + _ -> throwE $ INTERNAL "ICReject: incorrect connection type" -- ICDeleteConn is no longer used, but it can be present in old client databases ICDeleteConn -> withStore' c (`deleteCommand` cmdId) ICDeleteRcvQueue rId -> withServer $ \srv -> tryWithLock "ICDeleteRcvQueue" $ do @@ -2310,6 +2343,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} sq@SndQueue {userId, connId, server, resp <- tryAllErrors $ case msgType of AM_CONN_INFO -> sendConfirmation c NRMBackground sq msgBody AM_CONN_INFO_REPLY -> sendConfirmation c NRMBackground sq msgBody + AM_RJCT -> sendConfirmation c NRMBackground sq msgBody _ -> case pendingMsgPrepData_ of Nothing -> sendAgentMessage c sq msgFlags msgBody Just PendingMsgPrepData {encryptKey, paddedLen, sndMsgBody} -> do @@ -2356,6 +2390,9 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} sq@SndQueue {userId, connId, server, AM_QUSE_ -> qError msgId "QUSE: AUTH" AM_QTEST_ -> qError msgId "QTEST: AUTH" AM_EREADY_ -> notifyDel msgId err + AM_SRV_REQ -> notifyDel msgId err + AM_SRV_RESP -> notifyDel msgId err + AM_RJCT -> notifyDel msgId err _ -- for other operations BROKER HOST is treated as a permanent error (e.g., when connecting to the server), -- the message sending would be retried @@ -2437,6 +2474,9 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} sq@SndQueue {userId, connId, server, _ -> internalErr msgId "sent QTEST: queue not in connection or not replacing another queue" _ -> internalErr msgId "QTEST sent not in duplex connection" AM_EREADY_ -> pure () + AM_SRV_REQ -> notify $ SENT mId proxySrv_ + AM_SRV_RESP -> notify $ SENT mId proxySrv_ + AM_RJCT -> pure () delMsgKeep (msgType == AM_A_MSG_) msgId where setStatus status = do @@ -3312,7 +3352,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar | otherwise -> prohibited "handshake: missing sender key" >> ack (SMP.PHEmpty, AgentInvitation {connReq, connInfo}) -> smpInvitation srvMsgId conn connReq connInfo >> ack - (SMP.PHEmpty, AgentInvitationDR {agentVersion, e2eSndParams, ratchetKeyId, encConnInfo}) -> + (SMP.PHEmpty, AgentContactRequest {agentVersion, e2eSndParams, ratchetKeyId, encConnInfo}) -> smpInvitationDR srvMsgId conn agentVersion e2eSndParams ratchetKeyId encConnInfo phVer >> ack _ -> prohibited "handshake: incorrect state" >> ack (Just e2eDh, Nothing) -> do @@ -3440,7 +3480,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar decryptClientMessage e2eDh clientMsg >>= \case -- this is a repeated confirmation delivery because ack failed to be sent (_, AgentConfirmation {}) -> ack - (_, AgentInvitationDR {}) -> ack + (_, AgentContactRequest {}) -> ack _ -> prohibited "msg: public header" >> ack (Nothing, Nothing) -> prohibited "msg: no keys" >> ack updateConnVersion :: Connection c -> ConnData -> VersionSMPA -> AM (Connection c) @@ -3555,6 +3595,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar AgentConnInfoReply smpQueues connInfo -> do processConf rc' connInfo SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = L.toList smpQueues, smpClientVersion = phVer} withStore' c $ \db -> updateRcvMsgHash db connId 1 (InternalRcvId 0) (C.sha256Hash agentMsgBody) + AgentRejection _ reason -> notify $ RJCT reason _ -> prohibited "conf: not AgentConnInfoReply" -- including AgentConnInfo, that is prohibited here in v2 Left _ -> prohibited "conf: decrypt error" where diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index cd983407c..62cdba0c6 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -415,6 +415,8 @@ data AEvent (e :: AEntity) where LDATA :: FixedLinkData 'CMContact -> ConnLinkData 'CMContact -> ConnectionRequestUri 'CMContact -> AEvent AEConn CONF :: ConfirmationId -> PQSupport -> [SMPServer] -> ConnInfo -> AEvent AEConn -- ConnInfo is from sender, [SMPServer] will be empty only in v1 handshake REQ :: InvitationId -> PQSupport -> NonEmpty SMPServer -> ConnInfo -> AEvent AEConn -- ConnInfo is from sender + SREQ :: ConnId -> MsgBody -> AEvent AEConn + RJCT :: ConnInfo -> AEvent AEConn INFO :: PQSupport -> ConnInfo -> AEvent AEConn CON :: PQEncryption -> AEvent AEConn -- notification that connection is established END :: AEvent AEConn @@ -496,6 +498,8 @@ data AEventTag (e :: AEntity) where LDATA_ :: AEventTag AEConn CONF_ :: AEventTag AEConn REQ_ :: AEventTag AEConn + SREQ_ :: AEventTag AEConn + RJCT_ :: AEventTag AEConn INFO_ :: AEventTag AEConn CON_ :: AEventTag AEConn END_ :: AEventTag AEConn @@ -559,6 +563,8 @@ aEventTag = \case LDATA {} -> LDATA_ CONF {} -> CONF_ REQ {} -> REQ_ + SREQ {} -> SREQ_ + RJCT {} -> RJCT_ INFO {} -> INFO_ CON _ -> CON_ END -> END_ @@ -858,7 +864,7 @@ data AgentMsgEnvelope connReq :: ConnectionRequestUri 'CMInvitation, connInfo :: ByteString -- this message is only encrypted with per-queue E2E, not with double ratchet, } - | AgentInvitationDR -- invitation establishing double ratchet e2e with the contact address that included DR keys + | AgentContactRequest -- DR request to a contact address that advertised DR keys: a contact invitation or a service (RPC) request { agentVersion :: VersionSMPA, e2eSndParams :: SndE2ERatchetParams 'C.X448, ratchetKeyId :: RatchetKeyId, @@ -879,8 +885,8 @@ instance Encoding AgentMsgEnvelope where smpEncode (agentVersion, 'M', Tail encAgentMessage) AgentInvitation {agentVersion, connReq, connInfo} -> smpEncode (agentVersion, 'I', Large $ strEncode connReq, Tail connInfo) - AgentInvitationDR {agentVersion, e2eSndParams, ratchetKeyId, encConnInfo} -> - smpEncode (agentVersion, 'J', e2eSndParams, ratchetKeyId, Tail encConnInfo) + AgentContactRequest {agentVersion, e2eSndParams, ratchetKeyId, encConnInfo} -> + smpEncode (agentVersion, 'A', e2eSndParams, ratchetKeyId, Tail encConnInfo) AgentRatchetKey {agentVersion, e2eEncryption, info} -> smpEncode (agentVersion, 'R', e2eEncryption, Tail info) smpP = do @@ -896,9 +902,9 @@ instance Encoding AgentMsgEnvelope where connReq <- strDecode . unLarge <$?> smpP Tail connInfo <- smpP pure AgentInvitation {agentVersion, connReq, connInfo} - 'J' -> do + 'A' -> do (e2eSndParams, ratchetKeyId, Tail encConnInfo) <- smpP - pure AgentInvitationDR {agentVersion, e2eSndParams, ratchetKeyId, encConnInfo} + pure AgentContactRequest {agentVersion, e2eSndParams, ratchetKeyId, encConnInfo} 'R' -> do e2eEncryption <- smpP Tail info <- smpP @@ -916,6 +922,9 @@ data AgentMessage AgentConnInfoReply (NonEmpty SMPQueueInfo) ConnInfo | AgentRatchetInfo ByteString | AgentMessage APrivHeader AMessage + | AgentServiceRequest (NonEmpty SMPQueueInfo) MsgBody + | AgentServiceResponse APrivHeader Bool (NonEmpty MsgBody) + | AgentRejection APrivHeader ByteString deriving (Show) instance Encoding AgentMessage where @@ -924,12 +933,18 @@ instance Encoding AgentMessage where AgentConnInfoReply smpQueues cInfo -> smpEncode ('D', smpQueues, Tail cInfo) -- 'D' stands for "duplex" AgentRatchetInfo info -> smpEncode ('R', Tail info) AgentMessage hdr aMsg -> smpEncode ('M', hdr, aMsg) + AgentServiceRequest qs body -> smpEncode ('A', qs, Tail body) + AgentServiceResponse hdr final bodies -> smpEncode ('P', hdr, final, fmap Large bodies) + AgentRejection hdr reason -> smpEncode ('J', hdr, Tail reason) smpP = smpP >>= \case 'I' -> AgentConnInfo . unTail <$> smpP 'D' -> AgentConnInfoReply <$> smpP <*> (unTail <$> smpP) 'R' -> AgentRatchetInfo . unTail <$> smpP 'M' -> AgentMessage <$> smpP <*> smpP + 'A' -> AgentServiceRequest <$> smpP <*> (unTail <$> smpP) + 'P' -> AgentServiceResponse <$> smpP <*> smpP <*> (fmap unLarge <$> smpP) + 'J' -> AgentRejection <$> smpP <*> (unTail <$> smpP) _ -> fail "bad AgentMessage" -- internal type for storing message type in the database @@ -946,6 +961,9 @@ data AgentMessageType | AM_QUSE_ | AM_QTEST_ | AM_EREADY_ + | AM_SRV_REQ + | AM_SRV_RESP + | AM_RJCT deriving (Eq, Show) instance Encoding AgentMessageType where @@ -962,6 +980,9 @@ instance Encoding AgentMessageType where AM_QUSE_ -> "QU" AM_QTEST_ -> "QT" AM_EREADY_ -> "E" + AM_SRV_REQ -> "A" + AM_SRV_RESP -> "P" + AM_RJCT -> "J" smpP = A.anyChar >>= \case 'C' -> pure AM_CONN_INFO @@ -979,6 +1000,9 @@ instance Encoding AgentMessageType where 'T' -> pure AM_QTEST_ _ -> fail "bad AgentMessageType" 'E' -> pure AM_EREADY_ + 'A' -> pure AM_SRV_REQ + 'P' -> pure AM_SRV_RESP + 'J' -> pure AM_RJCT _ -> fail "bad AgentMessageType" agentMessageType :: AgentMessage -> AgentMessageType @@ -987,6 +1011,9 @@ agentMessageType = \case AgentConnInfoReply {} -> AM_CONN_INFO_REPLY AgentRatchetInfo _ -> AM_RATCHET_INFO AgentMessage _ aMsg -> aMessageType aMsg + AgentServiceRequest {} -> AM_SRV_REQ + AgentServiceResponse {} -> AM_SRV_RESP + AgentRejection {} -> AM_RJCT data APrivHeader = APrivHeader { -- | sequential ID assigned by the sending agent diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index 49a842cf0..38d395680 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -537,6 +537,7 @@ data InternalCommand | ICDeleteRcvQueue SMP.RecipientId | ICQSecure SMP.RecipientId SMP.SndPublicAuthKey | ICQDelete SMP.RecipientId + | ICReject data InternalCommandTag = ICAck_ @@ -547,6 +548,7 @@ data InternalCommandTag | ICDeleteRcvQueue_ | ICQSecure_ | ICQDelete_ + | ICReject_ deriving (Show) instance StrEncoding InternalCommand where @@ -559,6 +561,7 @@ instance StrEncoding InternalCommand where ICDeleteRcvQueue rId -> strEncode (ICDeleteRcvQueue_, rId) ICQSecure rId senderKey -> strEncode (ICQSecure_, rId, senderKey) ICQDelete rId -> strEncode (ICQDelete_, rId) + ICReject -> strEncode ICReject_ strP = strP >>= \case ICAck_ -> ICAck <$> _strP <*> _strP @@ -569,6 +572,7 @@ instance StrEncoding InternalCommand where ICDeleteRcvQueue_ -> ICDeleteRcvQueue <$> _strP ICQSecure_ -> ICQSecure <$> _strP <*> _strP ICQDelete_ -> ICQDelete <$> _strP + ICReject_ -> pure ICReject instance StrEncoding InternalCommandTag where strEncode = \case @@ -580,6 +584,7 @@ instance StrEncoding InternalCommandTag where ICDeleteRcvQueue_ -> "DELETE_RCV_QUEUE" ICQSecure_ -> "QSECURE" ICQDelete_ -> "QDELETE" + ICReject_ -> "REJECT" strP = A.takeTill (== ' ') >>= \case "ACK" -> pure ICAck_ @@ -590,6 +595,7 @@ instance StrEncoding InternalCommandTag where "DELETE_RCV_QUEUE" -> pure ICDeleteRcvQueue_ "QSECURE" -> pure ICQSecure_ "QDELETE" -> pure ICQDelete_ + "REJECT" -> pure ICReject_ _ -> fail "bad InternalCommandTag" agentCommandTag :: AgentCommand -> AgentCommandTag @@ -607,6 +613,7 @@ internalCmdTag = \case ICDeleteRcvQueue {} -> ICDeleteRcvQueue_ ICQSecure {} -> ICQSecure_ ICQDelete _ -> ICQDelete_ + ICReject -> ICReject_ -- * Confirmation types diff --git a/tests/AgentTests/ConnectionRequestTests.hs b/tests/AgentTests/ConnectionRequestTests.hs index 7b27feaf8..638a8cff7 100644 --- a/tests/AgentTests/ConnectionRequestTests.hs +++ b/tests/AgentTests/ConnectionRequestTests.hs @@ -353,9 +353,19 @@ connectionRequestTests = Right (inv' :: ConnShortLink 'CMInvitation) <- pure $ strDecode "https://localhost/i#tnUaHYp8saREmyEHR93SBpl8ySHBchOt/LJ1ZQUzxH9Udb0jw5wmJACv5o6oe8e7BsX_hUCUMTSY" shortenShortLink [presetSrv] inv `shouldBe` inv' restoreShortLink [presetSrv] inv' `shouldBe` inv + it "should serialize and parse service RPC agent messages" $ do + let qInfo = SMPQueueInfo currentSMPClientVersion queueAddr + hdr = APrivHeader 3 "previous-message-hash" + roundtripAgentMsg $ AgentServiceRequest [qInfo] "service request payload" + roundtripAgentMsg $ AgentServiceResponse hdr False ["first response"] + roundtripAgentMsg $ AgentServiceResponse hdr True ["r1", "r2", "r3"] + roundtripAgentMsg $ AgentRejection hdr "rejected: not allowed" where smpEncodingTest :: (Encoding a, Eq a, Show a, HasCallStack) => a -> Expectation smpEncodingTest a = smpDecode (smpEncode a) `shouldBe` Right a + roundtripAgentMsg :: HasCallStack => AgentMessage -> Expectation + roundtripAgentMsg msg = + (smpEncode <$> (smpDecode (smpEncode msg) :: Either String AgentMessage)) `shouldBe` Right (smpEncode msg) shortSrv :: SMPServer shortSrv = SMPServer "smp.simplex.im" "" (C.KeyHash "") diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 32750ef58..10d61b79c 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -364,6 +364,10 @@ functionalAPITests ps = do testAcceptContactDRResumeAfterOffline ps it "should support rejecting contact request" $ withSmpServer ps testRejectContactRequest + it "should communicate rejection reason via double ratchet" $ + withSmpServer ps testRejectContactRequestDR + it "should communicate rejection reason via double ratchet (async)" $ + withSmpServer ps testRejectContactRequestDRAsync describe "Changing connection user id" $ do it "should change user id for new connections" $ do withSmpServer ps testUpdateConnectionUserId @@ -1278,9 +1282,34 @@ testRejectContactRequest = sqSecured <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe liftIO $ sqSecured `shouldBe` False -- joining via contact address connection ("", _, A.REQ invId PQSupportOn _ "bob's connInfo") <- get alice - rejectContact alice invId + Left (A.CMD PROHIBITED _) <- tryError $ rejectContact alice NRMInteractive 1 invId (Just "no rejection without double ratchet") + rejectContact alice NRMInteractive 1 invId Nothing liftIO $ noMessages bob "nothing delivered to bob" +testRejectContactRequestDR :: HasCallStack => IO () +testRejectContactRequestDR = + withAgentClients2 $ \alice bob -> runRight_ $ do + let userLinkData = UserContactLinkData UserContactData {direct = True, owners = [], relays = [], userData = UserLinkData "test user data", ratchetKeys = Nothing} + (_addrConnId, CCLink connReq _) <- A.createConnection alice NRMInteractive 1 True True SCMContact (Just userLinkData) Nothing IKPQOn True SMSubscribe + aliceId <- A.prepareConnectionToJoin bob 1 True connReq PQSupportOn + void $ A.joinConnection bob NRMInteractive 1 aliceId True connReq "bob's connInfo" PQSupportOn SMSubscribe + ("", _, A.REQ invId _ _ "bob's connInfo") <- get alice + rejectContact alice NRMInteractive 1 invId (Just "not now") + ("", _, A.RJCT "not now") <- get bob + pure () + +testRejectContactRequestDRAsync :: HasCallStack => IO () +testRejectContactRequestDRAsync = + withAgentClients2 $ \alice bob -> runRight_ $ do + let userLinkData = UserContactLinkData UserContactData {direct = True, owners = [], relays = [], userData = UserLinkData "test user data", ratchetKeys = Nothing} + (_addrConnId, CCLink connReq _) <- A.createConnection alice NRMInteractive 1 True True SCMContact (Just userLinkData) Nothing IKPQOn True SMSubscribe + aliceId <- A.prepareConnectionToJoin bob 1 True connReq PQSupportOn + void $ A.joinConnection bob NRMInteractive 1 aliceId True connReq "bob's connInfo" PQSupportOn SMSubscribe + ("", _, A.REQ invId _ _ "bob's connInfo") <- get alice + rejectContactAsync alice "1" 1 invId (Just "not now") + ("", _, A.RJCT "not now") <- get bob + pure () + testUpdateConnectionUserId :: HasCallStack => IO () testUpdateConnectionUserId = withAgentClients2 $ \alice bob -> runRight_ $ do From 8897b6ebf8a730a94bd4aa6d2897f1fde9844e50 Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Tue, 21 Jul 2026 15:06:56 +0000 Subject: [PATCH 02/15] implement RPC requests/responses --- .../2026-07-11-service-rpc-implementation.md | 222 +++++++----------- simplexmq.cabal | 4 +- src/Simplex/Messaging/Agent.hs | 177 +++++++++++--- src/Simplex/Messaging/Agent/Client.hs | 7 +- src/Simplex/Messaging/Agent/Env/SQLite.hs | 4 + src/Simplex/Messaging/Agent/Protocol.hs | 28 ++- src/Simplex/Messaging/Agent/Store.hs | 24 +- .../Messaging/Agent/Store/AgentStore.hs | 38 ++- .../Agent/Store/Postgres/Migrations/App.hs | 4 +- ...ress_dr.hs => M20260712_address_dr_rpc.hs} | 15 +- .../Agent/Store/SQLite/Migrations/App.hs | 4 +- ...ress_dr.hs => M20260712_address_dr_rpc.hs} | 15 +- .../Store/SQLite/Migrations/agent_schema.sql | 5 +- tests/AgentTests/ConnectionRequestTests.hs | 6 +- tests/AgentTests/FunctionalAPITests.hs | 73 +++++- tests/AgentTests/SQLiteTests.hs | 3 +- 16 files changed, 403 insertions(+), 226 deletions(-) rename src/Simplex/Messaging/Agent/Store/Postgres/Migrations/{M20260712_address_dr.hs => M20260712_address_dr_rpc.hs} (62%) rename src/Simplex/Messaging/Agent/Store/SQLite/Migrations/{M20260712_address_dr.hs => M20260712_address_dr_rpc.hs} (63%) diff --git a/plans/2026-07-11-service-rpc-implementation.md b/plans/2026-07-11-service-rpc-implementation.md index dc0245bfb..b88ab4f7c 100644 --- a/plans/2026-07-11-service-rpc-implementation.md +++ b/plans/2026-07-11-service-rpc-implementation.md @@ -2,212 +2,158 @@ RFC: [../rfcs/2026-07-11-service-rpc.md](../rfcs/2026-07-11-service-rpc.md) -Depends on: [2026-07-12-address-dr-implementation.md](2026-07-12-address-dr-implementation.md). RPC establishes the double ratchet from the address exactly as the address-DR plan does; this plan is the RPC layer on top of it. Steps named R2'/O2'/O3' below are from that plan. Constructor, event, table and function names are provisional. +Depends on: [2026-07-12-address-dr-implementation.md](2026-07-12-address-dr-implementation.md). RPC establishes the double ratchet from the address exactly as the address-DR plan does; this plan is the RPC layer on top of it. Steps named R2'/R5'/O2'/O3' are from that plan. -**Scope of this pass: transport + rejection.** The request/response/rejection exchange and its teardown, plus communicated rejection of contact and RPC requests. Service-side **idempotency** (single execution by request hash) is **deferred** to a later pass; it stays documented below (the schema and the Idempotency section), marked deferred, but is not built now. +**Scope: transport + rejection.** One request, **one** response - no continuation, no streaming. Service-side **idempotency** (single execution by request hash) is deferred. -RPC is a one-directional short-lived DR exchange: the client establishes the ratchet from the address (address-DR requester), sends one request, receives one or more responses on its reply queue, and both sides tear the ratchet down after the final response. Unlike a connection, the service does not send a reply queue back and no persistent connection remains. A service publishes an ordinary DR-advertising contact address - the same address also accepts connection requests, and the owner distinguishes the two by the decrypted inner message (`AgentConnInfoReply` -> a connection, `AgentServiceRequest` -> an RPC). +**HTTP vs WebSocket.** RPC is the HTTP-shaped path: a single request and a single response, no persistent connection. A contact request is the WebSocket-shaped path: it opens a connection over which both sides then exchange messages. One DR-advertising address serves both, and the owner decides which it is per incoming request from the decrypted inner message - `AgentConnInfoReply` opens a connection, `AgentServiceRequest` answers an RPC. This plan builds the HTTP-shaped path (the WebSocket-shaped path is the existing contact/connection flow). -## Versions +**Single-response shape.** A request gets exactly one reply, which is either a response or a rejection; there are no follow-up messages, no `final` flag (the one response is terminal), no callback, and one payload per reply. This makes a response and a rejection the *same operation*: each is the single confirming message on the requester's reply queue Q_A, after which the ephemeral reply connection is torn down. They differ only in the inner message (`AgentServiceResponse` payload vs `AgentRejection` reason) and in the requester's outcome (the call returns the payload vs throws an agent error with the reason). So the reply path is the rejection path already built, parameterized by the inner message. -- `VersionSMPA` (agent protocol): the new inner `AgentServiceRequest`/`AgentServiceResponse`/`AgentRejection` messages, and the `AgentInvitationDR` -> `AgentContactRequest` rename. RPC reuses the address-DR ratchet establishment; `AgentInvitationDR` is unreleased (`currentSMPAgentVersion = 7`, Protocol.hs:339), so the rename and the new inner variants need no version gate beyond the address-DR work. +**Design rule: no parallel flow.** On the receive side an RPC request and a contact invitation are the same message stored the same way - one `smpContactRequest` (renamed from `smpInvitationDR`) writes one `conn_invitations` row, differing only in a kind column (`is_service_request`) and the event (`REQ` vs `SREQ`). The kind makes the APIs exclusive: an invitation can only be accepted, a request only responded to or rejected; the wrong API on the wrong kind is `CMD PROHIBITED`. The reply/reject send is the shared secure -> deliver-one-confirmation -> delete-with-wait-delivery path. -`SSND` (SMP protocol) and the hybrid queue header (SMP client) are not used here - they are separate RFCs (combined secure-send; queue-layer PQ). The ratchet provides post-quantum encryption, and the reply queue is secured with `SKEY` as in the address-DR owner path (O3'). +## Built so far -## RPC messages +Kept: `AgentContactRequest` rename (tag `'A'`); the `SREQ`/`RJCT` events; `SREQ :: InvitationId -> MsgBody`; contact rejection (`rejectContact`/`rejectContactAsync` via the `ICReject` internal command, requester-side `RJCT`, tests green); the `M20260712_service_rpc` migration (now `conn_invitations.is_service_request` + `connections.created_at`), schema tests green. -Two envelope layers, and it matters which is which (the L3/L4 layers of the address-DR plan). RPC and rejection add **no new outer envelope** - they reuse three existing ones; every new type is an **inner** `AgentMessage` variant, under the ratchet. +Small revisions to fit the single-response shape: the inner `AgentServiceResponse`/`AgentRejection` lose their `APrivHeader`, the `Bool final` flag and `NonEmpty` (below) - they are single, headerless confirming messages like `AgentConnInfoReply`; `ICReject` (secure + deliver the pending confirmation + delete) is inner-message-agnostic, so it is reused for responses too (renamed to a neutral `ICReplyDel`). -**Outer `AgentMsgEnvelope`** (L3, per-queue-e2e; encoding at Protocol.hs:874) - what an SMP queue carries: +## RPC messages -- `AgentContactRequest` (renamed from `AgentInvitationDR`, tag `'A'`) - the request sent to the address queue, used for BOTH a contact invitation and an RPC request. Carries `e2eSndParams` (the requester's Snd X3DH parameters), `ratchetKeyId`, and `encConnInfo` (the ratchet-encrypted inner message). A contact invitation and an RPC request are byte-identical on the wire; they differ only in the inner message, which is under the ratchet and invisible to servers - the "same outside double ratchet" property. (`AgentInvitationDR` is unreleased, so the tag was changed freely from `'J'` to `'A'`.) -- `AgentConfirmation` (tag `'C'`, with `e2eEncryption_ = Nothing`) - the first response on the reply queue Q_A. It *confirms Q_A*: establishes Q_A's per-queue e2e and SKEY-secures it, exactly as the first message on any fresh receive queue. `encConnInfo` is the ratchet-encrypted inner message. -- `AgentMsgEnvelope` (tag `'M'`) - every later response on Q_A. `encAgentMessage` is the ratchet-encrypted inner message. +**No new outer envelope.** The request reuses `AgentContactRequest` (to the address queue); the one reply reuses `AgentConfirmation` (the confirming first message on Q_A - the only message, so never `AgentMsgEnvelope`). -**Inner `AgentMessage`** (L4, double-ratchet-encrypted; encoding at Protocol.hs:921, parsed by `parseMessage`) - the decrypted content of the outer `encConnInfo`/`encAgentMessage`. RPC and rejection add three variants alongside `AgentConnInfoReply`: +**Inner `AgentMessage`** (L4, ratchet-encrypted; Protocol.hs:921, `parseMessage`) - three headerless variants, siblings of `AgentConnInfoReply`: ```haskell data AgentMessage - = ... -- AgentConnInfo 'I', AgentConnInfoReply 'D' (contact invitation: reply queue Q_A + profile), - -- AgentRatchetInfo 'R', AgentMessage APrivHeader AMessage 'M' - | AgentServiceRequest (NonEmpty SMPQueueInfo) MsgBody -- 'A': RPC request - reply queue Q_A + opaque payload - | AgentServiceResponse APrivHeader Bool (NonEmpty MsgBody) -- 'P': RPC response - header + final flag + one or more payloads - | AgentRejection APrivHeader ByteString -- 'J': refusal - header + opaque reason (contact or RPC) - --- encoding (extends AgentMessage Encoding) -AgentServiceRequest qs body -> smpEncode ('A', qs, Tail body) -AgentServiceResponse hdr final bodies -> smpEncode ('P', hdr, final, fmap Large bodies) -AgentRejection hdr reason -> smpEncode ('J', hdr, Tail reason) + = ... -- AgentConnInfo 'I', AgentConnInfoReply 'D' (reply queue Q_A + profile), AgentMessage APrivHeader AMessage 'M', ... + | AgentServiceRequest (NonEmpty SMPQueueInfo) MsgBody -- 'A': request - reply queue Q_A + opaque payload + | AgentServiceResponse MsgBody -- 'P': response - opaque payload (single, terminal) + | AgentRejection ByteString -- 'J': refusal - opaque reason (single, terminal) + +AgentServiceRequest qs body -> smpEncode ('A', qs, Tail body) +AgentServiceResponse body -> smpEncode ('P', Tail body) +AgentRejection reason -> smpEncode ('J', Tail reason) ``` -The owner tells a request apart by its inner variant after decryption: `AgentConnInfoReply` -> a contact request (`REQ`); `AgentServiceRequest` -> an RPC request (`SREQ`). `AgentServiceResponse`/`AgentRejection` are responses on Q_A, delivered to the client's waiting call or callback. +`AgentServiceRequest` carries Q_A (as `AgentConnInfoReply` does) so the service knows where to reply; its constructor is the only thing that tells `REQ` from `SREQ`. `AgentServiceResponse`/`AgentRejection` are each the sole message on Q_A - no header (nothing to number or chain), no `final` (terminal), no `NonEmpty` (one payload). `AgentMessageType`: `AM_SRV_RESP` and `AM_RJCT` both route to `sendConfirmation` (the reply is always a confirmation); there is no later-message path for RPC, so `agentClientMsg` is unchanged. -`AgentServiceResponse` carries an `APrivHeader` (`{sndMsgId, prevMsgHash}`, the same header as `AgentMessage 'M'`), so the response stream gets agent-level numbering and a previous-message-hash chain on top of the ratchet - a dropped or reordered response is caught by the chain, not only by the ratchet counters. One message still carries one or more payloads (`NonEmpty MsgBody`): responses known together in one message, responses over time in separate messages, each `final = False` until the last. `AgentServiceRequest` needs no header - a request is a single message. `AgentRejection` carries the header too, because a refusal can be the terminal message of a response stream (after zero or more `AgentServiceResponse`) and must chain with it; for a refused contact request it is the sole message on Q_A, with `sndMsgId = 1` and an empty previous hash. +## Ratchet establishment - reuse of the address-DR flow -The `AgentMsgEnvelope` receive path (`agentClientMsg`, Agent.hs:3289) today expects only `AgentMessage APrivHeader aMessage`; it is extended to accept `AgentServiceResponse` and `AgentRejection` for the stream after the first response. +**Request (client)** - address-DR requester path (R2'/R3'), inner is `AgentServiceRequest`: -## Ratchet establishment - reuse of the address-DR flow +- Negotiate the advertised ratchet params, create Q_A (messaging mode, subscribed), establish the send ratchet. +- Send `AgentContactRequest {e2eSndParams, ratchetKeyId, encConnInfo = ratchetEncrypt(AgentServiceRequest (Q_A :| []) payload)}` to the address, unauthenticated. The client connection is `RcvConnection` (Q_A) with the send ratchet; mark its `created_at` (cleanup below). -Request (client), reusing the address-DR requester path (R2'/R3'): +**Request (service)** - `smpContactRequest` (renamed `smpInvitationDR`, Agent.hs:3792): decrypt `encConnInfo`, then branch on the inner message. **Both branches call the same `storeInvitation` -> `conn_invitations`** (AgentStore.hs:877), writing the kind column; they differ only in the event: -- Retrieve link data, reconstruct and negotiate the advertised `RcvE2ERatchetParamsUri`, create the reply queue Q_A (messaging mode, subscribed), establish the send ratchet (`generateSndE2EParams`, `pqX3dhSnd`, `initSndRatchet`, `createSndRatchet`). -- Send `AgentContactRequest {e2eSndParams = sndParams, ratchetKeyId, encConnInfo = ratchetEncrypt(AgentServiceRequest (Q_A :| []) payload)}` to the address queue, unauthenticated (`agentCbEncryptOnce`) - the same outer envelope a contact invitation uses, with `AgentServiceRequest` inside instead of `AgentConnInfoReply`. The client connection is `RcvConnection` (Q_A) with the send ratchet. +- `AgentConnInfoReply` -> `REQ invId ...` (`is_service_request = 0`, unchanged). +- `AgentServiceRequest _ payload` -> `SREQ invId payload` (`is_service_request = 1`). -Request (service), reusing the address-DR owner path (O1'/O2'): +The service holds the request as an invitation with the payload as `recipient_conn_info`; no connection yet. Receive-time establishment on unauthenticated input - the address-DR abuse bound applies unchanged. -- The DR-request handler (built as `smpInvitationDR`; renamed to the generic `smpContactRequest`, since it now serves both invitations and RPC) selects the private keys by `ratchetKeyId`, `pqX3dhRcv`, `initRcvRatchet`, and `rcDecrypt` of `encConnInfo`, which also gives the connection its send side. It branches on the decrypted inner message: `AgentConnInfoReply` -> the existing contact-request path (store the request, emit `REQ`); `AgentServiceRequest` -> the RPC path: create a `SndConnection` to Q_A (no Q_B, unidirectional) holding the ratchet and deliver `SREQ` to the bot. This is receive-time establishment on unauthenticated input - the abuse bound of the address-DR plan ("Receive-time establishment, state, and abuse") applies unchanged. +**The one reply (service)** - `sendServiceReply c nm invId payload`, the accept-and-tear-down path (the rejection path with a payload). `CMD PROHIBITED` if the invitation is a contact invitation (wrong kind); an answered request is no longer pending, so a repeat just fails to find it: -Response (service): send each response to Q_A under the ratchet. The first message to Q_A is `AgentConfirmation {e2eEncryption_ = Nothing, encConnInfo = ratchetEncrypt(AgentServiceResponse hdr final bodies)}` (per-queue e2e is unestablished on Q_A - it is the confirming first message), securing Q_A with `SKEY` using the service's own key (`agentSecureSndQueue`, Q_A is messaging mode); later messages are `AgentMsgEnvelope {encAgentMessage = ratchetEncrypt(AgentServiceResponse hdr …)}`. After the `final = True` message, delete the send connection and its ratchet. +- `newConnToAccept` (Agent.hs:1359) creates the ephemeral reply connection from the request; `startJoinInvitationDR` builds the `SndQueue` to Q_A and the ratchet - **no reply queue back** (one-directional; the divergence from `acceptContact'`, which sends `AgentConnInfoReply` with its reply queue). +- `storeConfirmation` the pending `AgentServiceResponse payload` (`AM_SRV_RESP` -> `sendConfirmation`); `acceptInvitation`; then secure Q_A + deliver + `deleteConnectionAsync' True` (wait-for-delivery, so the one message is delivered before teardown). Sync `sendServiceReply` secures via `agentSecureSndQueue`; async `sendServiceReplyAsync` defers secure+deliver+delete to `ICReplyDel` (the renamed `ICReject`, retried, never fails client-side). +- Returns `()`. There is no continuation, so no `connId` is handed back. -Response (client): a message on Q_A (its `snd_service_requests` row marks it an RPC reply queue). The first is `AgentConfirmation … Nothing` and takes the address-DR `RcvConnection … Nothing` branch (R5'), extended to accept `AgentServiceResponse` and `AgentRejection`; later ones are `AgentMsgEnvelope` and take the standard message path, extended the same way. Each `agentRatchetDecrypt` advances the ratchet. The first response returns from the call; later responses go to the callback; an `AgentRejection` ends the exchange like a `final = True` response, surfacing the reason. On `final`, a rejection, the deadline, or `cancelServiceRequest`, delete Q_A (`DEL`) and the reply connection. +**The one response (client)** - the single `AgentConfirmation` on Q_A -> `smpConfirmation`'s `RcvConnection … Nothing` branch (R5', Agent.hs:3546, already parsing `AgentConnInfoReply`/`AgentRejection`), extended for `AgentServiceResponse`: an `AgentServiceResponse payload` completes the waiting `sendServiceRequest` with the payload; an `AgentRejection reason` completes it with a thrown agent error. Either way, ack and `deleteConnectionAsync' True` on Q_A. No later-message path. ## Rejection -A rejection is the inner `AgentRejection` variant (above): a terminal message carrying an opaque reason, delivered to the requester's Q_A under the ratchet. The same variant refuses an RPC request and a contact request (which today is dropped silently). +A rejection is `AgentRejection reason` - the same single confirming message on Q_A as a response, always tearing the connection down. It refuses an RPC request and, unchanged from what is built, a contact request. -- Delivery: `AgentRejection` is the inner message of an `AgentConfirmation` sent to Q_A - the confirming first message on Q_A, exactly like the first response, but terminal and carrying no reply queue (an acceptance sends `AgentConnInfoReply` with Q_B; a rejection sends `AgentRejection` with nothing). If a rejection instead follows some RPC responses, it is the inner message of an `AgentMsgEnvelope`, chained by its `APrivHeader`. -- Owner/service API: parameterize the current silent drop. `rejectContact` (Agent.hs:1606, today `deleteInvitation` only) gains an optional reason: `Nothing` -> silent drop (unchanged); `Just reason` -> the owner already holds the post-decrypt ratchet in the stored DR request, so it encrypts `AgentRejection` under that ratchet, sends it to Q_A as an `AgentConfirmation`, then deletes the request. Only DR requests can be refused this way (they hold the ratchet); a classic `AgentInvitation` request has no ratchet and can only be dropped. An RPC request is refused the same way from its reply connection (`rejectServiceRequest`). -- Requester side: `AgentRejection` on a contact reply queue surfaces as a rejection event to chat (which maps it to `XReject`/`XGrpReject`, communicating-rejection RFC); on an RPC reply queue it ends `sendServiceRequest` with the reason. +- **Kind guard:** `rejectContact` only on a contact invitation, `rejectServiceRequest` only on a request; the wrong kind is `CMD PROHIBITED` (read the kind off the pending invitation). An already accepted/responded request is not pending (`getInvitation` filters `accepted = 0`), so the reject fails to find it, as a repeat should. +- `rejectContact`/`rejectContactAsync` / `rejectServiceRequest`/`rejectServiceRequestAsync` take `Maybe ByteString`: `Nothing` -> silent drop (delete the invitation, no message); `Just reason` -> `CMD PROHIBITED` on a classic `CRInvitation` (no ratchet) or the wrong kind; else the reply path above with `AgentRejection` as the inner message. +- Requester side: `AgentRejection` on a contact reply queue -> `RJCT` event to chat (async, mapped to `XReject`/`XGrpReject`); on an RPC reply queue -> a thrown agent error ending `sendServiceRequest` (synchronous; a new `AgentErrorType` carries the reason). -## Reply queue - the requester's DR connection +## Reply connection and cleanup -The reply queue is the address-DR requester connection: an `RcvConnection` whose receive queue is Q_A, with a ratchet. No `reply_kem_priv_key`/`reply_secret` columns (those were the queue-layer hybrid secret, not used here). A `snd_service_requests` row referencing this connection marks it an RPC reply queue for dispatch and cleanup; there is no new connection type. +No reply-queue table and no new connection type - both reply connections are ordinary connections with a ratchet. -## Database schema +- **Client reply queue** (`RcvConnection` on Q_A): routed by the in-memory `serviceRequests :: TMap ConnId (TMVar (Either AgentErrorType MsgBody))` in `AgentClient` (Client.hs) - `sendServiceRequest` inserts a one-shot, the receive path fills it (`Right payload` / `Left rejection`), the call unwraps it. The normal path tears the connection down within the call; only a client restart mid-call orphans it. `connections.created_at` is set when the queue is created; `cleanupManager` (Agent.hs:3162) reaps connections whose `created_at` is older than a config TTL (RPC is short-lived), emitting `DEL`. +- **Service reply connection** (`SndConnection` to Q_A): ephemeral - created, sends the one reply, and is deleted with wait-for-delivery in the same operation, so it never lingers and needs no marker. +- **Service request** (`conn_invitations`, which has `created_at`): an unanswered request is reaped by `created_at` + config TTL. This is the received-side "requests table" - `conn_invitations`, differentiated by kind - not a new table. -One migration (`M20260712_service_rpc`), on top of the address-DR migration. SQLite shown, PostgreSQL mirrors it. Only `snd_service_requests` (client side) is built this pass; the three `rcv_service_*` tables belong to the deferred idempotency work, kept here so the schema stays in one place. +## Database schema (done) + +`M20260712_service_rpc` (SQLite + PostgreSQL), on top of the address-DR migration: ```sql --- client side: one pending request per reply queue connection. -CREATE TABLE snd_service_requests( - snd_service_request_id INTEGER PRIMARY KEY AUTOINCREMENT, - conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE, -- reply queue (RcvConnection) with the ratchet - deadline TEXT NOT NULL, - created_at TEXT NOT NULL -); - --- service side: one record per distinct request hash on a service address. -CREATE TABLE rcv_service_requests( - rcv_service_request_id INTEGER PRIMARY KEY AUTOINCREMENT, - address_conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE, -- the service address connection - request_hash BLOB NOT NULL, - ended INTEGER NOT NULL DEFAULT 0, -- a response with final = True was produced - expires_at TEXT NOT NULL, -- created + retention - created_at TEXT NOT NULL -); -CREATE UNIQUE INDEX idx_rcv_service_requests ON rcv_service_requests(address_conn_id, request_hash); - --- service side: ordered response payloads (plaintext) for a request; re-encrypted per reply --- connection because each request establishes its own ratchet, so ciphertext is not reusable. -CREATE TABLE rcv_service_responses( - rcv_service_response_id INTEGER PRIMARY KEY AUTOINCREMENT, - rcv_service_request_id INTEGER NOT NULL REFERENCES rcv_service_requests ON DELETE CASCADE, - response_seq INTEGER NOT NULL, - final INTEGER NOT NULL, - response_bodies BLOB NOT NULL -- plaintext response payloads for this message (encoded NonEmpty MsgBody) -); -CREATE UNIQUE INDEX idx_rcv_service_responses ON rcv_service_responses(rcv_service_request_id, response_seq); - --- service side: reply connections subscribed under a request (the first, and any repeat while pending --- or after completion). Each is a SndConnection to a reply queue with its own ratchet (in ratchets table). -CREATE TABLE rcv_service_reply_conns( - rcv_service_reply_conn_id INTEGER PRIMARY KEY AUTOINCREMENT, - rcv_service_request_id INTEGER NOT NULL REFERENCES rcv_service_requests ON DELETE CASCADE, - conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE, -- SndConnection to the reply queue, holds the ratchet - last_sent_seq INTEGER NOT NULL DEFAULT 0 -); +ALTER TABLE conn_invitations ADD COLUMN is_service_request INTEGER NOT NULL DEFAULT 0; -- 1 = RPC request, 0 = contact invitation +ALTER TABLE connections ADD COLUMN created_at TEXT; -- set on a client RPC reply queue; cleanup age (nullable) ``` -The service's address ratchet keys are the address-DR `address_ratchet_keys` table - not duplicated here. +The service's address ratchet keys are the address-DR `address_ratchet_keys` table. The deferred idempotency work will add its own tables when built. ## Agent API - `Simplex.Messaging.Agent` -Service side: +Service side (a service publishes an ordinary DR-advertising contact address; the same address accepts both connections and RPC): ```haskell --- No separate service-address creation: a service publishes an ordinary DR-advertising contact address --- (address-DR address creation with InitialKeys). The same address accepts both connections and RPC. - --- Sends one response message with one or more payloads (final = True ends the exchange). The first message --- to the reply connection secures Q_A with SKEY; later ones use SEND. connId is the reply connection from SREQ. -sendServiceReply :: AgentClient -> ConnId -> Bool -> NonEmpty MsgBody -> AE () +-- Sends the one response to the request from SREQ's invitation id, then tears the reply connection down. +sendServiceReply :: AgentClient -> NetworkRequestMode -> InvitationId -> MsgBody -> AE () +sendServiceReplyAsync :: AgentClient -> ACorrId -> InvitationId -> MsgBody -> AE () --- Refuses an RPC request with an opaque reason (AgentRejection to Q_A), terminal; deletes the reply connection. -rejectServiceRequest :: AgentClient -> ConnId -> ByteString -> AE () +-- Refuses a request (Just reason = AgentRejection to Q_A; Nothing = silent drop). PROHIBITED on wrong kind. +rejectServiceRequest :: AgentClient -> NetworkRequestMode -> UserId -> InvitationId -> Maybe ByteString -> AE () +rejectServiceRequestAsync :: AgentClient -> ACorrId -> UserId -> InvitationId -> Maybe ByteString -> AE () --- Refuses a contact request: Nothing = silent drop (unchanged behaviour); Just reason = AgentRejection to Q_A. -rejectContact :: AgentClient -> ConfirmationId -> Maybe ByteString -> AE () +-- contact rejection (built), plus the new kind guard: +rejectContact :: AgentClient -> NetworkRequestMode -> UserId -> ConfirmationId -> Maybe ByteString -> AE () +rejectContactAsync :: AgentClient -> ACorrId -> UserId -> ConfirmationId -> Maybe ByteString -> AE () ``` -Key rotation and update use the address-DR `rotateRatchetKeys`/link-data update; address deletion is `deleteConnection`. - -Client side (name resolution to a link is an existing API; the link must be a DR-advertising address): +Client side: ```haskell --- Establishes the ratchet from the address, creates the reply queue, sends the request, and waits for --- the first response up to the deadline. The callback receives later responses while the process runs. +-- Establishes the ratchet from the address, creates Q_A, sends the request, and waits for the one response up to +-- the client-config timeout. Returns the response payload; a rejection or timeout is a thrown agent error. No callback. sendServiceRequest :: - AgentClient -> UserId -> ConnShortLink 'CMContact -> UTCTime -> - MsgBody -> (ServiceResponse -> IO ()) -> AE ServiceResponse - -cancelServiceRequest :: AgentClient -> ConnId -> AE () - -data ServiceResponse - = ServiceResponse {bodies :: NonEmpty MsgBody, final :: Bool} - | ServiceRejected {reason :: ByteString} + AgentClient -> NetworkRequestMode -> UserId -> ConnectionRequestUri 'CMContact -> MsgBody -> AE MsgBody ``` -The waiting call and the callback are held in an in-memory map in `AgentClient`, keyed by the reply queue connection, filled by the receive path; they do not survive a restart. +`sendServiceRequest`'s address input is the resolved `ConnectionRequestUri 'CMContact` (reuses the address-DR `joinConnSrv` path, testable like the DR tests); short-link resolution can wrap it later. The wait is bounded by an `AgentConfig` timeout, not a per-call deadline. No `cancelServiceRequest` - an aborted call's Q_A is reaped by `created_at`. -Service side event (`AEvent`, entity is the address connection): +Events (`AEvent`, entity is the address connection): ```haskell --- connId = the reply (SndConnection) to Q_A; the bot passes it to sendServiceReply / rejectServiceRequest. --- MsgBody = the opaque request payload. -SREQ :: ConnId -> MsgBody -> AEvent AEConn +SREQ :: InvitationId -> MsgBody -> AEvent AEConn -- mirrors REQ (InvitationId); payload = the request. +RJCT :: ConnInfo -> AEvent AEConn -- built; contact-request rejection reason to chat. ``` ## Agent processing -Client side: - -- `sendServiceRequest`: retrieve link data per request (proxied per config); establish the ratchet and create Q_A (address-DR R2'); write the `snd_service_requests` row; send the `AgentContactRequest` carrying `AgentServiceRequest` (proxied per config); wait on the in-memory sink for the first response until the deadline. -- Response processing in `processSMPTransmissions`: a message on a queue with a `snd_service_requests` row is a response; `agentRatchetDecrypt` (advancing the ratchet), parse `AgentServiceResponse`/`AgentRejection`, deliver to the waiting call or the callback. On `final`/rejection/deadline/cancel, delete Q_A and the reply connection. -- `cleanupManager`: delete `snd_service_requests` past the deadline and mark their reply connections deleted; the existing deleted-connections step sends `DEL`. After a restart every row is stale, so this removes reply queues left behind. +Client: -Service side: +- `sendServiceRequest`: address-DR R2' (ratchet + Q_A) with `AgentServiceRequest` inside; set `created_at`; insert the one-shot `TMVar` keyed by the reply `connId`; send `AgentContactRequest`; block on the `TMVar` until the response or the config timeout; on either, `deleteConnectionAsync' True` on Q_A; return the payload or throw. +- Reception: only `smpConfirmation` R5' is touched (`AgentServiceResponse` -> fill `Right`, `AgentRejection` -> fill `Left`); no later-message path. +- `cleanupManager`: delete connections whose `created_at` is older than the TTL (restart-orphaned reply queues). -- Address-queue dispatch: `smpContactRequest` (the renamed `smpInvitationDR`) decrypts `encConnInfo` and branches on the inner message - `AgentConnInfoReply` -> the contact-request path (`REQ`); `AgentServiceRequest` -> the RPC path. -- On `AgentServiceRequest`: establish the ratchet (address-DR O2'), create the `SndConnection` to Q_A, deliver `SREQ connId payload` to the bot (`connId` = the reply connection). No request-hash store this pass, so every request - including a repeat - reaches the bot as a fresh `SREQ` (single execution is the deferred idempotency work). -- `sendServiceReply`: send `AgentServiceResponse hdr final bodies` to Q_A under the ratchet (`SKEY`+`SEND` for the first message, `SEND` after); after `final = True`, delete the reply connection and its ratchet. -- `rejectServiceRequest`: send `AgentRejection hdr reason` to Q_A the same way, terminal; delete the reply connection. +Service: -Configuration (`AgentConfig`): default request deadline. (The retention period belongs to the deferred idempotency work.) +- `smpContactRequest`: one `storeInvitation` (writing the kind), branch the event `REQ`/`SREQ`. +- `sendServiceReply`: `newConnToAccept` + `startJoinInvitationDR` (no reply queue back) + `storeConfirmation (AgentServiceResponse payload)` + `acceptInvitation` + secure + deliver + `deleteConnectionAsync' True`. Async defers to `ICReplyDel`. +- `rejectServiceRequest`: the same path with `AgentRejection`, guarded by kind. `sendServiceReply`, `rejectServiceRequest`, and `rejectContact` share one helper, parameterized by the inner message and the kind it expects. +- `cleanupManager`: reap `conn_invitations` requests older than the TTL. -Errors reuse `AgentErrorType`. +Config (`AgentConfig`): service-request timeout (the client-side wait bound); RPC cleanup TTL. ## Idempotency (deferred) -**Deferred - not built this pass** (see the scope note); documented here for the follow-up. The service identifies a request by its hash and keeps, for the retention period (config, not in link data), the ordered response payloads (`rcv_service_responses`) and the reply connections under that hash (`rcv_service_reply_conns`). A repeat request (same payload, therefore same hash) establishes its own ratchet and reply connection and does not reach the bot: while pending it is added and receives the responses so far and each later one; after completion it receives the whole stored sequence. Responses are stored as plaintext and re-encrypted per reply connection because each request has its own ratchet. This gives single execution over at-least-once delivery, bounded by the retention period. - -## Correlation and chat - -A response is connected to its request by the reply queue (one request, one reply queue, one ratchet). The request hash is only the idempotency key. The application ID is content inside the request payload, used only by the application to make two requests equal or different; the agent does not read it. - -Both ends are chat bots on the chat library, which serializes a service command into the request payload and deserializes the responses; the agent transports them and correlates by reply queue. The chat framework's `chatServiceCalls` correlation is not used. +Not built. When built, the service will key a request by hash and cache the one response for a retention period, so a repeat request is answered from storage without reaching the bot - single execution over at-least-once delivery, with its own tables. ## Tests -- Encoding roundtrips: `AgentServiceRequest`, `AgentServiceResponse` (one and several response bodies), `AgentRejection` in `AgentMessage`; the renamed `AgentContactRequest` (wire unchanged from `AgentInvitationDR`). -- End to end (on the address-DR machinery): a request with one response; several responses streamed to the callback; `pqEncryption` on (hybrid) and off (X448-only) per the advertised keys; the request payload never travels under per-queue-only encryption. -- Rejection: an RPC request refused with `rejectServiceRequest` ends `sendServiceRequest` with the reason; a contact request refused with `rejectContact (Just reason)` reaches the requester as a rejection, vs `Nothing` = silent drop; the same address accepts a connection and an RPC and can refuse either. -- Lifecycle: the reply connection and the service ratchet are deleted after `final` and after a rejection; deadline; cancellation; a restart deletes client reply queues. -- (Idempotency tests are part of the deferred idempotency pass.) +- Encoding roundtrips: `AgentServiceRequest`, `AgentServiceResponse`, `AgentRejection` in `AgentMessage`; the `AgentContactRequest` rename (wire unchanged). (Revise the built roundtrip for the headerless/single shape.) +- End to end: a request with one response; `pqEncryption` on/off per advertised keys; the payload never travels under per-queue-only encryption. +- Rejection: `rejectServiceRequest (Just reason)` ends `sendServiceRequest` with the reason (thrown); `rejectContact (Just reason)` reaches the requester as `RJCT`, `Nothing` = silent drop; a wrong-kind reject is `CMD PROHIBITED`; the same address serves a connection and an RPC and can refuse either. +- Lifecycle: the reply connection and ratchet are deleted after the response and after a rejection; the config timeout ends a request with no reply; a restart reaps orphaned client reply queues via `created_at`. ## Phases -1. Rename `AgentInvitationDR` -> `AgentContactRequest`; add inner `AgentServiceRequest`/`AgentServiceResponse`/`AgentRejection`; generic inner-message dispatch in `smpContactRequest`; `SREQ` event. Encoding roundtrip tests. -2. Client: `sendServiceRequest`, reply-queue reception and callback, `cancelServiceRequest`, `snd_service_requests` + cleanup. Service: `sendServiceReply`. End-to-end request/response tests. -3. Rejection: `rejectContact` optional reason, `rejectServiceRequest`, requester-side surfacing; rejection tests. +1. **[migration + `SREQ` done]** Message revision: `AgentServiceResponse`/`AgentRejection` -> headerless single (drop `APrivHeader`/`Bool`/`NonEmpty`), update encodings + the built contact-rejection call sites + roundtrip test; rename `ICReject` -> `ICReplyDel`; add the `AgentErrorType` rejection reason; thread `is_service_request` onto `Invitation`/`getInvitation` and add the kind guard to `rejectContact`. +2. `smpContactRequest` dispatch (`AgentServiceRequest` -> `SREQ`, writing the kind); the shared `sendServiceReply`/`rejectServiceRequest` (+ async) reply helper; client `sendServiceRequest` + `smpConfirmation` reception + `serviceRequests` one-shot map; both-sides `cleanupManager` steps. End-to-end and rejection tests. -Later, separate pass: idempotency (the deferred schema + Idempotency section). +Later, separate pass: idempotency. diff --git a/simplexmq.cabal b/simplexmq.cabal index b52bc5e41..cc8b24878 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -190,7 +190,7 @@ library Simplex.Messaging.Agent.Store.Postgres.Migrations.M20251230_strict_tables Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260410_receive_attempts Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260411_service_certs - Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260712_address_dr + Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260712_address_dr_rpc else exposed-modules: Simplex.Messaging.Agent.Store.SQLite @@ -243,7 +243,7 @@ library Simplex.Messaging.Agent.Store.SQLite.Migrations.M20251230_strict_tables Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260410_receive_attempts Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260411_service_certs - Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260712_address_dr + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260712_address_dr_rpc Simplex.Messaging.Agent.Store.SQLite.Util if flag(client_postgres) || flag(server_postgres) exposed-modules: diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 545c4415c..c09e83a95 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -77,6 +77,11 @@ module Simplex.Messaging.Agent acceptContact, rejectContact, rejectContactAsync, + sendServiceRequest, + sendServiceReply, + sendServiceReplyAsync, + rejectServiceRequest, + rejectServiceRequestAsync, DatabaseDiff (..), compareConnections, syncConnections, @@ -508,6 +513,29 @@ rejectContactAsync :: AgentClient -> ACorrId -> UserId -> ConfirmationId -> Mayb rejectContactAsync c corrId userId invId reason = withAgentEnv c $ rejectContactAsync' c corrId userId invId reason {-# INLINE rejectContactAsync #-} +-- | Send the single response to a service (RPC) request (SREQ command) +sendServiceReply :: AgentClient -> NetworkRequestMode -> UserId -> InvitationId -> MsgBody -> AE () +sendServiceReply c nm userId invId payload = withAgentEnv c $ sendServiceReply' c nm userId invId payload +{-# INLINE sendServiceReply #-} + +sendServiceReplyAsync :: AgentClient -> ACorrId -> UserId -> InvitationId -> MsgBody -> AE () +sendServiceReplyAsync c corrId userId invId payload = withAgentEnv c $ sendServiceReplyAsync' c corrId userId invId payload +{-# INLINE sendServiceReplyAsync #-} + +-- | Refuse a service (RPC) request +rejectServiceRequest :: AgentClient -> NetworkRequestMode -> UserId -> InvitationId -> Maybe ByteString -> AE () +rejectServiceRequest c nm userId invId reason = withAgentEnv c $ rejectServiceRequest' c nm userId invId reason +{-# INLINE rejectServiceRequest #-} + +rejectServiceRequestAsync :: AgentClient -> ACorrId -> UserId -> InvitationId -> Maybe ByteString -> AE () +rejectServiceRequestAsync c corrId userId invId reason = withAgentEnv c $ rejectServiceRequestAsync' c corrId userId invId reason +{-# INLINE rejectServiceRequestAsync #-} + +-- | Send a service (RPC) request to an address and wait for the single response +sendServiceRequest :: AgentClient -> NetworkRequestMode -> UserId -> ConnectionRequestUri 'CMContact -> MsgBody -> AE MsgBody +sendServiceRequest c nm userId cReqUri payload = withAgentEnv c $ sendServiceRequest' c nm userId cReqUri payload +{-# INLINE sendServiceRequest #-} + data DatabaseDiff a = DatabaseDiff { missingIds :: [a], extraIds :: [a] @@ -866,7 +894,7 @@ newConnNoQueues :: AgentClient -> UserId -> Bool -> SConnectionMode c -> PQSuppo newConnNoQueues c userId enableNtfs cMode pqSupport = do g <- asks random connAgentVersion <- asks $ maxVersion . smpAgentVRange . config - let cData = ConnData {userId, connId = "", connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport} + let cData = ConnData {userId, connId = "", connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceReply = False} withStore c $ \db -> createNewConn db g cData cMode -- TODO [short links] TBC, but probably we will need async join for contact addresses as the contact will be created after user confirming the connection, @@ -1116,7 +1144,8 @@ getConnShortLinkAsync' c userId corrId connId_ shortLink@(CSLContact _ _ srv _) lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, - pqSupport = PQSupportOff + pqSupport = PQSupportOff, + serviceReply = False } createNewConn db g cData SCMInvitation @@ -1353,7 +1382,7 @@ newConnToJoin c userId connId enableNtfs cReq pqSup = case cReq of create (Compatible connAgentVersion) e2eV_ = do g <- asks random let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ connAgentVersion e2eV_ - cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport} + cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceReply = False} withStore c $ \db -> createNewConn db g cData SCMInvitation newConnToAccept :: AgentClient -> UserId -> ConnId -> Bool -> ConfirmationId -> PQSupport -> AM ConnId @@ -1363,7 +1392,7 @@ newConnToAccept c userId connId enableNtfs invId pqSup = do CRInvitation cReq -> newConnToJoin c userId connId enableNtfs cReq pqSup CRInvitationDR DRInvitation {agentVersion, pqSupport} -> do g <- asks random - let cData = ConnData {userId, connId, connAgentVersion = agentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport} + let cData = ConnData {userId, connId, connAgentVersion = agentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceReply = False} withStore c $ \db -> createNewConn db g cData SCMInvitation joinConn :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM SndQueueSecured @@ -1383,7 +1412,7 @@ startJoinInvitation c userId connId sq_ enableNtfs cReqUri pqSup = let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ connAgentVersion (Just v) g <- asks random maxSupported <- asks $ maxVersion . e2eEncryptVRange . config - let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport} + let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceReply = False} case sq_ of Just sq@SndQueue {e2ePubKey = Just _k} -> do e2eSndParams <- withStore c $ \db -> do @@ -1470,7 +1499,11 @@ addrKeysE2EVersion :: (RatchetKeyId, Compatible (CR.RcvE2ERatchetParams 'C.X448) addrKeysE2EVersion (_, Compatible (CR.E2ERatchetParams e2eV _ _ _)) = e2eV joinConnSrv :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> AM SndQueueSecured -joinConnSrv c nm userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSup subMode srv = +joinConnSrv c nm userId connId enableNtfs cReq cInfo pqSup subMode srv = + joinConnSrv' c nm userId connId enableNtfs cReq cInfo pqSup subMode srv $ \replyQInfo -> AgentConnInfoReply (replyQInfo :| []) cInfo + +joinConnSrv' :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> SMPServerWithAuth -> (SMPQueueInfo -> AgentMessage) -> AM SndQueueSecured +joinConnSrv' c nm userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSup subMode srv _mkInner = withInvLock c (strEncode inv) "joinConnSrv" $ do SomeConn cType conn <- withStore c (`getConn` connId) case conn of @@ -1485,7 +1518,7 @@ joinConnSrv c nm userId connId enableNtfs inv@CRInvitationUri {} cInfo pqSup sub ((cData, sq), e2eSndParams, lnkId_) <- startJoinInvitation c userId connId sq_ enableNtfs inv pqSup secureConfirmQueue c nm cData rq_ sq srv cInfo e2eSndParams subMode >>= (mapM_ (delInvSL c connId srv) lnkId_ $>) -joinConnSrv c nm userId connId enableNtfs cReqUri@CRContactUri {} cInfo pqSup subMode srv = +joinConnSrv' c nm userId connId enableNtfs cReqUri@CRContactUri {} cInfo pqSup subMode srv mkInner = lift (compatibleContactUri cReqUri) >>= \case Just (qInfo, ratchet_, Compatible v) -> withInvLock c (strEncode cReqUri) "joinConnSrv" $ do @@ -1512,7 +1545,7 @@ joinConnSrv c nm userId connId enableNtfs cReqUri@CRContactUri {} cInfo pqSup su let RcvQueue {smpClientVersion = rqV} = rq cData = (toConnData conn) {pqSupport} :: ConnData replyQInfo = SMPQueueInfo rqV (rcvSMPQueueAddress rq) - sndReply = AgentConnInfoReply (replyQInfo :| []) cInfo + sndReply = mkInner replyQInfo (e2eSndParams, encConnInfo) <- withStore c $ \db -> runExceptT $ do liftIO $ lockConnForUpdate db connId e2eSndParams <- liftIO (getSndRatchet db connId e2eV) >>= either (const $ createRatchet_ db g connId maxV pqSupport e2eParams) (pure . snd) @@ -1609,30 +1642,83 @@ acceptContact' c nm userId connId enableNtfs invId ownConnInfo pqSupport subMode rejectContact' :: AgentClient -> NetworkRequestMode -> UserId -> InvitationId -> Maybe ByteString -> AM () rejectContact' c nm userId invId reason_ = do - forM_ reason_ $ \reason -> do - (connId, cData, sq) <- prepareRejection c userId invId reason - void $ agentSecureSndQueue c nm cData sq - lift $ submitPendingMsg c sq - deleteConnectionAsync' c True connId + forM_ reason_ $ \reason -> sendReplySync c nm =<< prepareReply c userId invId False (AgentRejection reason) withStore' c $ \db -> deleteInvitation db invId rejectContactAsync' :: AgentClient -> ACorrId -> UserId -> InvitationId -> Maybe ByteString -> AM () rejectContactAsync' c corrId userId invId reason_ = do - forM_ reason_ $ \reason -> do - (connId, _, sq) <- prepareRejection c userId invId reason - enqueueCommand c corrId connId (Just $ qServer sq) $ AInternalCommand ICReject + forM_ reason_ $ \reason -> sendReplyAsync c corrId =<< prepareReply c userId invId False (AgentRejection reason) + withStore' c $ \db -> deleteInvitation db invId + +rejectServiceRequest' :: AgentClient -> NetworkRequestMode -> UserId -> InvitationId -> Maybe ByteString -> AM () +rejectServiceRequest' c nm userId invId reason_ = do + forM_ reason_ $ \reason -> sendReplySync c nm =<< prepareReply c userId invId True (AgentRejection reason) + withStore' c $ \db -> deleteInvitation db invId + +rejectServiceRequestAsync' :: AgentClient -> ACorrId -> UserId -> InvitationId -> Maybe ByteString -> AM () +rejectServiceRequestAsync' c corrId userId invId reason_ = do + forM_ reason_ $ \reason -> sendReplyAsync c corrId =<< prepareReply c userId invId True (AgentRejection reason) + withStore' c $ \db -> deleteInvitation db invId + +sendServiceReply' :: AgentClient -> NetworkRequestMode -> UserId -> InvitationId -> MsgBody -> AM () +sendServiceReply' c nm userId invId payload = do + sendReplySync c nm =<< prepareReply c userId invId True (AgentServiceResponse payload) + withStore' c $ \db -> deleteInvitation db invId + +sendServiceReplyAsync' :: AgentClient -> ACorrId -> UserId -> InvitationId -> MsgBody -> AM () +sendServiceReplyAsync' c corrId userId invId payload = do + sendReplyAsync c corrId =<< prepareReply c userId invId True (AgentServiceResponse payload) withStore' c $ \db -> deleteInvitation db invId -prepareRejection :: AgentClient -> UserId -> InvitationId -> ByteString -> AM (ConnId, ConnData, SndQueue) -prepareRejection c userId invId reason = do - Invitation {connReq} <- withStore c $ \db -> getInvitation db "prepareRejection" invId +sendReplySync :: AgentClient -> NetworkRequestMode -> (ConnId, ConnData, SndQueue) -> AM () +sendReplySync c nm (connId, cData, sq) = do + void $ agentSecureSndQueue c nm cData sq + lift $ submitPendingMsg c sq + deleteConnectionAsync' c True connId + +sendReplyAsync :: AgentClient -> ACorrId -> (ConnId, ConnData, SndQueue) -> AM () +sendReplyAsync c corrId (connId, _, sq) = enqueueCommand c corrId connId (Just $ qServer sq) $ AInternalCommand ICReplyDel + +prepareReply :: AgentClient -> UserId -> InvitationId -> Bool -> AgentMessage -> AM (ConnId, ConnData, SndQueue) +prepareReply c userId invId expectedServiceRequest innerMsg = do + Invitation {connReq, isServiceRequest, createdAt} <- withStore c $ \db -> getInvitation db "prepareReply" invId + when (isServiceRequest /= expectedServiceRequest) $ throwE $ CMD PROHIBITED kindErr + when expectedServiceRequest $ do + now <- liftIO getCurrentTime + replyTimeout <- asks $ serviceReplyTimeout . config + when (diffUTCTime now createdAt > replyTimeout) $ do + withStore' c $ \db -> deleteInvitation db invId + throwE $ AGENT $ A_SERVICE ASETimeout case connReq of - CRInvitation _ -> throwE $ CMD PROHIBITED "rejectContact: connection has no double ratchet to send rejection" + CRInvitation _ -> throwE $ CMD PROHIBITED "prepareReply: connection has no double ratchet to send reply" CRInvitationDR dr@DRInvitation {pqSupport} -> do connId <- newConnToAccept c userId "" True invId pqSupport (cData, sq) <- startJoinInvitationDR c userId connId Nothing dr - storeConfirmation c cData sq Nothing $ AgentRejection (APrivHeader 1 "") reason + storeConfirmation c cData sq Nothing innerMsg pure (connId, cData, sq) + where + kindErr + | expectedServiceRequest = "reply: not a service request, use rejectContact" + | otherwise = "rejectContact: service request, use rejectServiceRequest" + +-- | Send a service (RPC) request to a DR-advertising address, wait for the single response up to the config timeout. +sendServiceRequest' :: AgentClient -> NetworkRequestMode -> UserId -> ConnectionRequestUri 'CMContact -> MsgBody -> AM MsgBody +sendServiceRequest' c nm userId cReqUri@(CRContactUri crData _) payload = do + connId <- newConnToJoin c userId "" False cReqUri PQSupportOn + ts <- liftIO getCurrentTime + withStore' c $ \db -> setConnServiceReply db connId ts + var <- atomically newEmptyTMVar + atomically $ TM.insert connId var (serviceRequests c) + srv <- getNextSMPServer c userId [qServer $ L.head $ crSmpQueues crData] + reqTimeout <- asks $ serviceRequestTimeout . config + r <- tryError $ do + void $ joinConnSrv' c nm userId connId False cReqUri "" PQSupportOn SMSubscribe srv $ \replyQInfo -> AgentServiceRequest (replyQInfo :| []) payload + liftIO $ do + expired <- registerDelay $ round (reqTimeout * 1000000) + atomically $ takeTMVar var `orElse` (readTVar expired >>= \e -> if e then pure (Left $ AGENT $ A_SERVICE ASETimeout) else retry) + atomically $ TM.delete connId (serviceRequests c) + deleteConnectionAsync' c True connId + liftEither $ join r syncConnections' :: AgentClient -> [UserId] -> [ConnId] -> AM (DatabaseDiff UserId, DatabaseDiff ConnId) syncConnections' c userIds connIds = do @@ -2097,13 +2183,13 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do ICDuplexSecure _rId senderKey -> withServer' . tryWithLock "ICDuplexSecure" . withDuplexConn $ \(DuplexConnection cData (rq :| _) (sq :| _)) -> do secure rq senderKey void $ enqueueMessage c cData sq SMP.MsgFlags {notification = True} HELLO - ICReject -> withServer' . tryWithLock "ICReject" $ + ICReplyDel -> withServer' . tryWithLock "ICReplyDel" $ withStore c (`getConn` connId) >>= \case SomeConn _ (SndConnection cData sq) -> do void $ agentSecureSndQueue c NRMBackground cData sq lift $ submitPendingMsg c sq deleteConnectionAsync' c True connId - _ -> throwE $ INTERNAL "ICReject: incorrect connection type" + _ -> throwE $ INTERNAL "ICReplyDel: incorrect connection type" -- ICDeleteConn is no longer used, but it can be present in old client databases ICDeleteConn -> withStore' c (`deleteCommand` cmdId) ICDeleteRcvQueue rId -> withServer $ \srv -> tryWithLock "ICDeleteRcvQueue" $ do @@ -2344,6 +2430,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} sq@SndQueue {userId, connId, server, AM_CONN_INFO -> sendConfirmation c NRMBackground sq msgBody AM_CONN_INFO_REPLY -> sendConfirmation c NRMBackground sq msgBody AM_RJCT -> sendConfirmation c NRMBackground sq msgBody + AM_SRV_RESP -> sendConfirmation c NRMBackground sq msgBody _ -> case pendingMsgPrepData_ of Nothing -> sendAgentMessage c sq msgFlags msgBody Just PendingMsgPrepData {encryptKey, paddedLen, sndMsgBody} -> do @@ -3177,8 +3264,15 @@ cleanupManager c@AgentClient {subQ} = do run SFERR deleteSndFilesDeleted run SFERR deleteSndFilesPrefixPaths run SFERR deleteExpiredReplicasForDeletion + run ERR deleteExpiredServiceReqs liftIO $ threadDelay' int where + deleteExpiredServiceReqs = do + replyTimeout <- asks $ serviceReplyTimeout . config + expireTs <- addUTCTime (negate replyTimeout) <$> liftIO getCurrentTime + withStore' c $ \db -> deleteExpiredServiceRequests db expireTs + expiredConns <- withStore' c $ \db -> getExpiredServiceReplyConnIds db expireTs + deleteConnectionsAsync' c False expiredConns run :: forall e. AEntityI e => (AgentErrorType -> AEvent e) -> AM () -> AM' () run err a = do waitActive . runExceptT $ a `catchAllErrors` (notify "" . err) @@ -3353,7 +3447,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar (SMP.PHEmpty, AgentInvitation {connReq, connInfo}) -> smpInvitation srvMsgId conn connReq connInfo >> ack (SMP.PHEmpty, AgentContactRequest {agentVersion, e2eSndParams, ratchetKeyId, encConnInfo}) -> - smpInvitationDR srvMsgId conn agentVersion e2eSndParams ratchetKeyId encConnInfo phVer >> ack + smpContactRequest srvMsgId conn agentVersion e2eSndParams ratchetKeyId encConnInfo phVer >> ack _ -> prohibited "handshake: incorrect state" >> ack (Just e2eDh, Nothing) -> do decryptClientMessage e2eDh clientMsg >>= \case @@ -3573,7 +3667,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar smpConfirmation srvMsgId conn' senderKey e2ePubKey e2eEncryption encConnInfo phVer agentVersion = do logServer "<--" c srv rId $ "MSG :" <> logSecret' srvMsgId checkConfVersions agentVersion phVer - let ConnData {pqSupport} = toConnData conn' + let ConnData {pqSupport, serviceReply} = toConnData conn' case status of New -> case conn' of -- party initiating connection @@ -3595,10 +3689,18 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar AgentConnInfoReply smpQueues connInfo -> do processConf rc' connInfo SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = L.toList smpQueues, smpClientVersion = phVer} withStore' c $ \db -> updateRcvMsgHash db connId 1 (InternalRcvId 0) (C.sha256Hash agentMsgBody) - AgentRejection _ reason -> notify $ RJCT reason + AgentServiceResponse payload | serviceReply -> dispatchServiceReply $ Right payload + AgentRejection reason + | serviceReply -> dispatchServiceReply $ Left $ AGENT $ A_SERVICE $ ASERejected $ B.unpack reason + | otherwise -> notify $ RJCT reason _ -> prohibited "conf: not AgentConnInfoReply" -- including AgentConnInfo, that is prohibited here in v2 Left _ -> prohibited "conf: decrypt error" where + dispatchServiceReply result = do + found <- atomically $ TM.lookup connId (serviceRequests c) >>= \case + Just var -> tryPutTMVar var result + Nothing -> pure False + unless found $ notify $ ERR $ AGENT $ A_SERVICE ASENoRequest processConf rc' connInfo senderConf = do let newConfirmation = NewConfirmation {connId, senderConf, ratchetState = rc'} g <- asks random @@ -3810,7 +3912,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar -- show connection request even if invitaion via contact address is not compatible. -- in case invitation not compatible, assume there is no PQ encryption support. pqSupport <- lift $ maybe PQSupportOff pqSupported <$> compatibleInvitationUri connReq - invId <- storeInvitation (CRInvitation connReq) cInfo + invId <- storeInvitation (CRInvitation connReq) cInfo False let srvs = L.map qServer $ crSmpQueues crData notify $ REQ invId pqSupport srvs cInfo _ -> prohibited "inv: sent to message conn" @@ -3818,14 +3920,14 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar pqSupported (_, Compatible (CR.E2ERatchetParams v _ _ _), Compatible agentVersion) = PQSupportOn `CR.pqSupportAnd` versionPQSupport_ agentVersion (Just v) - storeInvitation :: ContactRequest -> ConnInfo -> AM InvitationId - storeInvitation connReq recipientConnInfo = do + storeInvitation :: ContactRequest -> ConnInfo -> Bool -> AM InvitationId + storeInvitation connReq recipientConnInfo isServiceRequest = do g <- asks random - let newInv = NewInvitation {contactConnId = connId, connReq, recipientConnInfo} + let newInv = NewInvitation {contactConnId = connId, connReq, recipientConnInfo, isServiceRequest} withStore c $ \db -> createInvitation db g newInv - smpInvitationDR :: SMP.MsgId -> Connection c -> VersionSMPA -> CR.SndE2ERatchetParams 'C.X448 -> RatchetKeyId -> ByteString -> VersionSMPC -> AM () - smpInvitationDR srvMsgId conn' agentVersion e2eSndParams ratchetKeyId encConnInfo phVer = do + smpContactRequest :: SMP.MsgId -> Connection c -> VersionSMPA -> CR.SndE2ERatchetParams 'C.X448 -> RatchetKeyId -> ByteString -> VersionSMPC -> AM () + smpContactRequest srvMsgId conn' agentVersion e2eSndParams ratchetKeyId encConnInfo phVer = do logServer "<--" c srv rId $ "MSG :" <> logSecret' srvMsgId case conn' of ContactConnection {} -> do @@ -3836,13 +3938,16 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar (rc, connPQSupport) <- initRcvRatchet_ agentVersion pqSupport (pk1, pk2, pKem) e2eSndParams (agentMsgBody_, ratchetState) <- decryptConnInfo rc encConnInfo case agentMsgBody_ of - Right agentMsgBody -> + Right agentMsgBody -> do + let mkDR replyQueue = DRInvitation {ratchetState, replyQueue, agentVersion, pqSupport = connPQSupport} parseMessage agentMsgBody >>= \case AgentConnInfoReply (replyQueue :| _) cInfo -> do - let dr = DRInvitation {ratchetState, replyQueue, agentVersion, pqSupport = connPQSupport} - invId <- storeInvitation (CRInvitationDR dr) cInfo + invId <- storeInvitation (CRInvitationDR $ mkDR replyQueue) cInfo False notify $ REQ invId pqSupported (qServer replyQueue :| []) cInfo - _ -> prohibited "addr inv: not AgentConnInfoReply" + AgentServiceRequest (replyQueue :| _) payload -> do + invId <- storeInvitation (CRInvitationDR $ mkDR replyQueue) payload True + notify $ SREQ invId payload + _ -> prohibited "addr inv: not a contact request" Left _ -> prohibited "addr inv: decrypt error" Left _ -> prohibited "addr inv: unknown ratchetKeyId" _ -> prohibited "inv: sent to message conn" diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 55eac6ba6..959bb114c 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -387,7 +387,8 @@ data AgentClient = AgentClient smpServersStats :: TMap (UserId, SMPServer) AgentSMPServerStats, xftpServersStats :: TMap (UserId, XFTPServer) AgentXFTPServerStats, ntfServersStats :: TMap (UserId, NtfServer) AgentNtfServerStats, - srvStatsStartedAt :: TVar UTCTime + srvStatsStartedAt :: TVar UTCTime, + serviceRequests :: TMap ConnId (TMVar (Either AgentErrorType SMP.MsgBody)) } data SMPConnectedClient = SMPConnectedClient @@ -551,6 +552,7 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg, useServices xftpServersStats <- TM.emptyIO ntfServersStats <- TM.emptyIO srvStatsStartedAt <- newTVarIO currentTs + serviceRequests <- TM.emptyIO return AgentClient { acThread, @@ -595,7 +597,8 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg, useServices smpServersStats, xftpServersStats, ntfServersStats, - srvStatsStartedAt + srvStatsStartedAt, + serviceRequests } slowNetworkConfig :: NetworkConfig -> NetworkConfig diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index 47073f6b4..1de601d25 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -153,6 +153,8 @@ data AgentConfig = AgentConfig userNetworkInterval :: Int, userOfflineDelay :: NominalDiffTime, messageTimeout :: NominalDiffTime, + serviceRequestTimeout :: NominalDiffTime, + serviceReplyTimeout :: NominalDiffTime, connDeleteDeliveryTimeout :: NominalDiffTime, helloTimeout :: NominalDiffTime, quotaExceededTimeout :: NominalDiffTime, @@ -229,6 +231,8 @@ defaultAgentConfig = userNetworkInterval = 1800_000000, -- 30 minutes, should be less than Int32 max value userOfflineDelay = 2, -- if network offline event happens in less than 2 seconds after it was set online, it is ignored messageTimeout = 2 * nominalDay, + serviceRequestTimeout = 30, -- client wait for the response, seconds + serviceReplyTimeout = 180, -- service reply window + cleanup TTL, seconds (must exceed serviceRequestTimeout) connDeleteDeliveryTimeout = 2 * nominalDay, helloTimeout = 2 * nominalDay, quotaExceededTimeout = 7 * nominalDay, diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 62cdba0c6..27b75fd95 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -161,6 +161,7 @@ module Simplex.Messaging.Agent.Protocol ConnectionErrorType (..), BrokerErrorType (..), SMPAgentError (..), + AgentServiceError (..), DroppedMsg (..), AgentCryptoError (..), cryptoErrToSyncState, @@ -415,7 +416,7 @@ data AEvent (e :: AEntity) where LDATA :: FixedLinkData 'CMContact -> ConnLinkData 'CMContact -> ConnectionRequestUri 'CMContact -> AEvent AEConn CONF :: ConfirmationId -> PQSupport -> [SMPServer] -> ConnInfo -> AEvent AEConn -- ConnInfo is from sender, [SMPServer] will be empty only in v1 handshake REQ :: InvitationId -> PQSupport -> NonEmpty SMPServer -> ConnInfo -> AEvent AEConn -- ConnInfo is from sender - SREQ :: ConnId -> MsgBody -> AEvent AEConn + SREQ :: InvitationId -> MsgBody -> AEvent AEConn RJCT :: ConnInfo -> AEvent AEConn INFO :: PQSupport -> ConnInfo -> AEvent AEConn CON :: PQEncryption -> AEvent AEConn -- notification that connection is established @@ -923,8 +924,8 @@ data AgentMessage | AgentRatchetInfo ByteString | AgentMessage APrivHeader AMessage | AgentServiceRequest (NonEmpty SMPQueueInfo) MsgBody - | AgentServiceResponse APrivHeader Bool (NonEmpty MsgBody) - | AgentRejection APrivHeader ByteString + | AgentServiceResponse MsgBody + | AgentRejection ByteString deriving (Show) instance Encoding AgentMessage where @@ -934,8 +935,8 @@ instance Encoding AgentMessage where AgentRatchetInfo info -> smpEncode ('R', Tail info) AgentMessage hdr aMsg -> smpEncode ('M', hdr, aMsg) AgentServiceRequest qs body -> smpEncode ('A', qs, Tail body) - AgentServiceResponse hdr final bodies -> smpEncode ('P', hdr, final, fmap Large bodies) - AgentRejection hdr reason -> smpEncode ('J', hdr, Tail reason) + AgentServiceResponse body -> smpEncode ('P', Tail body) + AgentRejection reason -> smpEncode ('J', Tail reason) smpP = smpP >>= \case 'I' -> AgentConnInfo . unTail <$> smpP @@ -943,8 +944,8 @@ instance Encoding AgentMessage where 'R' -> AgentRatchetInfo . unTail <$> smpP 'M' -> AgentMessage <$> smpP <*> smpP 'A' -> AgentServiceRequest <$> smpP <*> (unTail <$> smpP) - 'P' -> AgentServiceResponse <$> smpP <*> smpP <*> (fmap unLarge <$> smpP) - 'J' -> AgentRejection <$> smpP <*> (unTail <$> smpP) + 'P' -> AgentServiceResponse . unTail <$> smpP + 'J' -> AgentRejection . unTail <$> smpP _ -> fail "bad AgentMessage" -- internal type for storing message type in the database @@ -2197,8 +2198,19 @@ data SMPAgentError A_DUPLICATE {droppedMsg_ :: Maybe DroppedMsg} | -- | error in the message to add/delete/etc queue in connection A_QUEUE {queueErr :: String} + | -- | service (RPC) request error + A_SERVICE {serviceError :: AgentServiceError} deriving (Eq, Show, Exception) +data AgentServiceError + = -- | the service refused the request, with the reason (bytes as latin1 String) + ASERejected {rejectReason :: String} + | -- | no response to the request within the configured timeout + ASETimeout + | -- | response with no pending request (e.g. after a restart) + ASENoRequest + deriving (Eq, Show) + data AgentCryptoError = -- | AES decryption error DECRYPT_AES @@ -2317,6 +2329,8 @@ $(J.deriveJSON (sumTypeJSON id) ''ConnectionErrorType) $(J.deriveJSON (sumTypeJSON id) ''AgentCryptoError) +$(J.deriveJSON (sumTypeJSON id) ''AgentServiceError) + $(J.deriveJSON defaultJSON ''DroppedMsg) $(J.deriveJSON (sumTypeJSON id) ''SMPAgentError) diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index 38d395680..ca4960d04 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -465,7 +465,8 @@ data ConnData = ConnData lastExternalSndId :: PrevExternalSndId, deleted :: Bool, ratchetSyncState :: RatchetSyncState, - pqSupport :: PQSupport + pqSupport :: PQSupport, + serviceReply :: Bool } deriving (Eq, Show) @@ -537,7 +538,7 @@ data InternalCommand | ICDeleteRcvQueue SMP.RecipientId | ICQSecure SMP.RecipientId SMP.SndPublicAuthKey | ICQDelete SMP.RecipientId - | ICReject + | ICReplyDel data InternalCommandTag = ICAck_ @@ -548,7 +549,7 @@ data InternalCommandTag | ICDeleteRcvQueue_ | ICQSecure_ | ICQDelete_ - | ICReject_ + | ICReplyDel_ deriving (Show) instance StrEncoding InternalCommand where @@ -561,7 +562,7 @@ instance StrEncoding InternalCommand where ICDeleteRcvQueue rId -> strEncode (ICDeleteRcvQueue_, rId) ICQSecure rId senderKey -> strEncode (ICQSecure_, rId, senderKey) ICQDelete rId -> strEncode (ICQDelete_, rId) - ICReject -> strEncode ICReject_ + ICReplyDel -> strEncode ICReplyDel_ strP = strP >>= \case ICAck_ -> ICAck <$> _strP <*> _strP @@ -572,7 +573,7 @@ instance StrEncoding InternalCommand where ICDeleteRcvQueue_ -> ICDeleteRcvQueue <$> _strP ICQSecure_ -> ICQSecure <$> _strP <*> _strP ICQDelete_ -> ICQDelete <$> _strP - ICReject_ -> pure ICReject + ICReplyDel_ -> pure ICReplyDel instance StrEncoding InternalCommandTag where strEncode = \case @@ -584,7 +585,7 @@ instance StrEncoding InternalCommandTag where ICDeleteRcvQueue_ -> "DELETE_RCV_QUEUE" ICQSecure_ -> "QSECURE" ICQDelete_ -> "QDELETE" - ICReject_ -> "REJECT" + ICReplyDel_ -> "REPLY_DEL" strP = A.takeTill (== ' ') >>= \case "ACK" -> pure ICAck_ @@ -595,7 +596,7 @@ instance StrEncoding InternalCommandTag where "DELETE_RCV_QUEUE" -> pure ICDeleteRcvQueue_ "QSECURE" -> pure ICQSecure_ "QDELETE" -> pure ICQDelete_ - "REJECT" -> pure ICReject_ + "REPLY_DEL" -> pure ICReplyDel_ _ -> fail "bad InternalCommandTag" agentCommandTag :: AgentCommand -> AgentCommandTag @@ -613,7 +614,7 @@ internalCmdTag = \case ICDeleteRcvQueue {} -> ICDeleteRcvQueue_ ICQSecure {} -> ICQSecure_ ICQDelete _ -> ICQDelete_ - ICReject -> ICReject_ + ICReplyDel -> ICReplyDel_ -- * Confirmation types @@ -636,7 +637,8 @@ data AcceptedConfirmation = AcceptedConfirmation data NewInvitation = NewInvitation { contactConnId :: ConnId, connReq :: ContactRequest, - recipientConnInfo :: ConnInfo + recipientConnInfo :: ConnInfo, + isServiceRequest :: Bool } data Invitation = Invitation @@ -645,7 +647,9 @@ data Invitation = Invitation connReq :: ContactRequest, recipientConnInfo :: ConnInfo, ownConnInfo :: Maybe ConnInfo, - accepted :: Bool + accepted :: Bool, + isServiceRequest :: Bool, + createdAt :: UTCTime } data ContactRequest diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs index da00533dc..c94465df2 100644 --- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -72,8 +72,11 @@ module Simplex.Messaging.Agent.Store.AgentStore setConnUserId, setConnAgentVersion, setConnPQSupport, + setConnServiceReply, updateNewConnJoin, getDeletedConnIds, + getExpiredServiceReplyConnIds, + deleteExpiredServiceRequests, getDeletedWaitingDeliveryConnIds, setConnRatchetSync, addProcessedRatchetKeyHash, @@ -875,15 +878,15 @@ removeConfirmations db connId = (Only connId) createInvitation :: DB.Connection -> TVar ChaChaDRG -> NewInvitation -> IO (Either StoreError InvitationId) -createInvitation db gVar NewInvitation {contactConnId, connReq, recipientConnInfo} = +createInvitation db gVar NewInvitation {contactConnId, connReq, recipientConnInfo, isServiceRequest} = createWithRandomId db gVar $ \invitationId -> DB.execute db [sql| INSERT INTO conn_invitations - (invitation_id, contact_conn_id, cr_invitation, recipient_conn_info, accepted) VALUES (?, ?, ?, ?, 0); + (invitation_id, contact_conn_id, cr_invitation, recipient_conn_info, accepted, is_service_request) VALUES (?, ?, ?, ?, 0, ?); |] - (Binary invitationId, contactConnId, connReq, Binary recipientConnInfo) + (Binary invitationId, contactConnId, connReq, Binary recipientConnInfo, BI isServiceRequest) getInvitation :: DB.Connection -> String -> InvitationId -> IO (Either StoreError Invitation) getInvitation db cxt invitationId = @@ -891,15 +894,15 @@ getInvitation db cxt invitationId = DB.query db [sql| - SELECT contact_conn_id, cr_invitation, recipient_conn_info, own_conn_info, accepted + SELECT contact_conn_id, cr_invitation, recipient_conn_info, own_conn_info, accepted, is_service_request, created_at FROM conn_invitations WHERE invitation_id = ? AND accepted = 0 |] (Only (Binary invitationId)) where - invitation (contactConnId_, connReq, recipientConnInfo, ownConnInfo, BI accepted) = - Invitation {invitationId, contactConnId_, connReq, recipientConnInfo, ownConnInfo, accepted} + invitation (contactConnId_, connReq, recipientConnInfo, ownConnInfo, BI accepted, BI isServiceRequest, createdAt) = + Invitation {invitationId, contactConnId_, connReq, recipientConnInfo, ownConnInfo, accepted, isServiceRequest, createdAt} acceptInvitation :: DB.Connection -> InvitationId -> ConnInfo -> IO () acceptInvitation db invitationId ownConnInfo = @@ -2663,7 +2666,8 @@ getConnData deleted' forUpdate db connId' = db ( [sql| SELECT user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, - last_external_snd_msg_id, deleted, ratchet_sync_state, pq_support + last_external_snd_msg_id, deleted, ratchet_sync_state, pq_support, + CASE WHEN created_at IS NULL THEN 0 ELSE 1 END FROM connections WHERE conn_id = ? AND deleted = ? |] @@ -2680,9 +2684,9 @@ lockConnForUpdate db connId = do #endif pure () -rowToConnData :: (UserId, ConnId, ConnectionMode, VersionSMPA, Maybe BoolInt, PrevExternalSndId, BoolInt, RatchetSyncState, PQSupport) -> (ConnData, ConnectionMode) -rowToConnData (userId, connId, cMode, connAgentVersion, enableNtfs_, lastExternalSndId, BI deleted, ratchetSyncState, pqSupport) = - (ConnData {userId, connId, connAgentVersion, enableNtfs = maybe True unBI enableNtfs_, lastExternalSndId, deleted, ratchetSyncState, pqSupport}, cMode) +rowToConnData :: (UserId, ConnId, ConnectionMode, VersionSMPA, Maybe BoolInt, PrevExternalSndId, BoolInt, RatchetSyncState, PQSupport, BoolInt) -> (ConnData, ConnectionMode) +rowToConnData (userId, connId, cMode, connAgentVersion, enableNtfs_, lastExternalSndId, BI deleted, ratchetSyncState, pqSupport, BI serviceReply) = + (ConnData {userId, connId, connAgentVersion, enableNtfs = maybe True unBI enableNtfs_, lastExternalSndId, deleted, ratchetSyncState, pqSupport, serviceReply}, cMode) setConnDeleted :: DB.Connection -> Bool -> ConnId -> IO () setConnDeleted db waitDelivery connId @@ -2704,6 +2708,10 @@ setConnPQSupport :: DB.Connection -> ConnId -> PQSupport -> IO () setConnPQSupport db connId pqSupport = DB.execute db "UPDATE connections SET pq_support = ? WHERE conn_id = ?" (pqSupport, connId) +setConnServiceReply :: DB.Connection -> ConnId -> UTCTime -> IO () +setConnServiceReply db connId ts = + DB.execute db "UPDATE connections SET created_at = ? WHERE conn_id = ?" (ts, connId) + updateNewConnJoin :: DB.Connection -> ConnId -> VersionSMPA -> PQSupport -> Bool -> IO () updateNewConnJoin db connId aVersion pqSupport enableNtfs = DB.execute db "UPDATE connections SET smp_agent_version = ?, pq_support = ?, enable_ntfs = ? WHERE conn_id = ?" (aVersion, pqSupport, BI enableNtfs, connId) @@ -2711,6 +2719,16 @@ updateNewConnJoin db connId aVersion pqSupport enableNtfs = getDeletedConnIds :: DB.Connection -> IO [ConnId] getDeletedConnIds db = map fromOnly <$> DB.query db "SELECT conn_id FROM connections WHERE deleted = ?" (Only (BI True)) +-- | Client RPC reply-queue connections older than the timeout that were never torn down (e.g. after a restart). +getExpiredServiceReplyConnIds :: DB.Connection -> UTCTime -> IO [ConnId] +getExpiredServiceReplyConnIds db expireTs = + map fromOnly <$> DB.query db "SELECT conn_id FROM connections WHERE created_at IS NOT NULL AND created_at < ? AND deleted = 0" (Only expireTs) + +-- | Service (RPC) requests that were never answered within the timeout. +deleteExpiredServiceRequests :: DB.Connection -> UTCTime -> IO () +deleteExpiredServiceRequests db expireTs = + DB.execute db "DELETE FROM conn_invitations WHERE is_service_request = 1 AND created_at < ?" (Only expireTs) + getDeletedWaitingDeliveryConnIds :: DB.Connection -> IO [ConnId] getDeletedWaitingDeliveryConnIds db = map fromOnly <$> DB.query_ db "SELECT conn_id FROM connections WHERE deleted_at_wait_delivery IS NOT NULL" diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/App.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/App.hs index 12bf3f183..1997b5c2a 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/App.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/App.hs @@ -13,7 +13,7 @@ import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20251010_client_notice import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20251230_strict_tables import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260410_receive_attempts import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260411_service_certs -import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260712_address_dr +import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260712_address_dr_rpc import Simplex.Messaging.Agent.Store.Shared (Migration (..)) schemaMigrations :: [(String, Text, Maybe Text)] @@ -27,7 +27,7 @@ schemaMigrations = ("20251230_strict_tables", m20251230_strict_tables, Just down_m20251230_strict_tables), ("20260410_receive_attempts", m20260410_receive_attempts, Just down_m20260410_receive_attempts), ("20260411_service_certs", m20260411_service_certs, Just down_m20260411_service_certs), - ("20260712_address_dr", m20260712_address_dr, Just down_m20260712_address_dr) + ("20260712_address_dr_rpc", m20260712_address_dr_rpc, Just down_m20260712_address_dr_rpc) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20260712_address_dr.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20260712_address_dr_rpc.hs similarity index 62% rename from src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20260712_address_dr.hs rename to src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20260712_address_dr_rpc.hs index 00506b1d2..33344cbc8 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20260712_address_dr.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20260712_address_dr_rpc.hs @@ -1,13 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} -module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260712_address_dr where +module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260712_address_dr_rpc where import Data.Text (Text) import Text.RawString.QQ (r) -m20260712_address_dr :: Text -m20260712_address_dr = +m20260712_address_dr_rpc :: Text +m20260712_address_dr_rpc = [r| CREATE TABLE address_ratchet_keys( address_ratchet_key_id BIGSERIAL PRIMARY KEY, @@ -20,11 +20,16 @@ CREATE TABLE address_ratchet_keys( ); CREATE UNIQUE INDEX idx_address_ratchet_keys ON address_ratchet_keys(conn_id, ratchet_key_id); + +ALTER TABLE conn_invitations ADD COLUMN is_service_request SMALLINT NOT NULL DEFAULT 0; +ALTER TABLE connections ADD COLUMN created_at TIMESTAMPTZ; |] -down_m20260712_address_dr :: Text -down_m20260712_address_dr = +down_m20260712_address_dr_rpc :: Text +down_m20260712_address_dr_rpc = [r| +ALTER TABLE connections DROP COLUMN created_at; +ALTER TABLE conn_invitations DROP COLUMN is_service_request; DROP INDEX idx_address_ratchet_keys; DROP TABLE address_ratchet_keys; |] diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/App.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/App.hs index c17a191a9..69cc74cfe 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/App.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/App.hs @@ -49,7 +49,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20251010_client_notices import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20251230_strict_tables import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260410_receive_attempts import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260411_service_certs -import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260712_address_dr +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260712_address_dr_rpc import Simplex.Messaging.Agent.Store.Shared (Migration (..)) schemaMigrations :: [(String, Query, Maybe Query)] @@ -99,7 +99,7 @@ schemaMigrations = ("m20251230_strict_tables", m20251230_strict_tables, Just down_m20251230_strict_tables), ("m20260410_receive_attempts", m20260410_receive_attempts, Just down_m20260410_receive_attempts), ("m20260411_service_certs", m20260411_service_certs, Just down_m20260411_service_certs), - ("m20260712_address_dr", m20260712_address_dr, Just down_m20260712_address_dr) + ("m20260712_address_dr_rpc", m20260712_address_dr_rpc, Just down_m20260712_address_dr_rpc) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20260712_address_dr.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20260712_address_dr_rpc.hs similarity index 63% rename from src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20260712_address_dr.hs rename to src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20260712_address_dr_rpc.hs index 2da05ea42..8587ca388 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20260712_address_dr.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20260712_address_dr_rpc.hs @@ -1,12 +1,12 @@ {-# LANGUAGE QuasiQuotes #-} -module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260712_address_dr where +module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260712_address_dr_rpc where import Database.SQLite.Simple (Query) import Database.SQLite.Simple.QQ (sql) -m20260712_address_dr :: Query -m20260712_address_dr = +m20260712_address_dr_rpc :: Query +m20260712_address_dr_rpc = [sql| CREATE TABLE address_ratchet_keys( address_ratchet_key_id INTEGER PRIMARY KEY AUTOINCREMENT, @@ -19,11 +19,16 @@ CREATE TABLE address_ratchet_keys( ) STRICT; CREATE UNIQUE INDEX idx_address_ratchet_keys ON address_ratchet_keys(conn_id, ratchet_key_id); + +ALTER TABLE conn_invitations ADD COLUMN is_service_request INTEGER NOT NULL DEFAULT 0; +ALTER TABLE connections ADD COLUMN created_at TEXT; |] -down_m20260712_address_dr :: Query -down_m20260712_address_dr = +down_m20260712_address_dr_rpc :: Query +down_m20260712_address_dr_rpc = [sql| +ALTER TABLE connections DROP COLUMN created_at; +ALTER TABLE conn_invitations DROP COLUMN is_service_request; DROP INDEX idx_address_ratchet_keys; DROP TABLE address_ratchet_keys; |] diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql index 460600f4c..0679e490f 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql @@ -27,7 +27,8 @@ CREATE TABLE connections( REFERENCES users ON DELETE CASCADE, ratchet_sync_state TEXT NOT NULL DEFAULT 'ok', deleted_at_wait_delivery TEXT, - pq_support INTEGER NOT NULL DEFAULT 0 + pq_support INTEGER NOT NULL DEFAULT 0, + created_at TEXT ) WITHOUT ROWID, STRICT; CREATE TABLE rcv_queues( host TEXT NOT NULL, @@ -164,6 +165,8 @@ CREATE TABLE conn_invitations( accepted INTEGER NOT NULL DEFAULT 0, own_conn_info BLOB, created_at TEXT NOT NULL DEFAULT(datetime('now')) + , + is_service_request INTEGER NOT NULL DEFAULT 0 ) WITHOUT ROWID, STRICT; CREATE TABLE ratchets( conn_id BLOB NOT NULL PRIMARY KEY REFERENCES connections diff --git a/tests/AgentTests/ConnectionRequestTests.hs b/tests/AgentTests/ConnectionRequestTests.hs index 638a8cff7..f72f13b7b 100644 --- a/tests/AgentTests/ConnectionRequestTests.hs +++ b/tests/AgentTests/ConnectionRequestTests.hs @@ -355,11 +355,9 @@ connectionRequestTests = restoreShortLink [presetSrv] inv' `shouldBe` inv it "should serialize and parse service RPC agent messages" $ do let qInfo = SMPQueueInfo currentSMPClientVersion queueAddr - hdr = APrivHeader 3 "previous-message-hash" roundtripAgentMsg $ AgentServiceRequest [qInfo] "service request payload" - roundtripAgentMsg $ AgentServiceResponse hdr False ["first response"] - roundtripAgentMsg $ AgentServiceResponse hdr True ["r1", "r2", "r3"] - roundtripAgentMsg $ AgentRejection hdr "rejected: not allowed" + roundtripAgentMsg $ AgentServiceResponse "service response payload" + roundtripAgentMsg $ AgentRejection "rejected: not allowed" where smpEncodingTest :: (Encoding a, Eq a, Show a, HasCallStack) => a -> Expectation smpEncodingTest a = smpDecode (smpEncode a) `shouldBe` Right a diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 10d61b79c..dddfe4807 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -94,7 +94,7 @@ import Simplex.Messaging.Agent.Store.Common (DBStore (..), withTransaction) import Simplex.Messaging.Agent.Store.Interface import qualified Simplex.Messaging.Agent.Store.DB as DB import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..), MigrationError (..)) -import Simplex.Messaging.Client (pattern NRMInteractive, NetworkConfig (..), ProtocolClientConfig (..), TransportSessionMode (..), defaultClientConfig) +import Simplex.Messaging.Client (pattern NRMBackground, pattern NRMInteractive, NetworkConfig (..), ProtocolClientConfig (..), TransportSessionMode (..), defaultClientConfig) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Ratchet (InitialKeys (..), PQEncryption (..), PQSupport (..), pattern IKPQOff, pattern IKPQOn, pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn) import qualified Simplex.Messaging.Crypto.Ratchet as CR @@ -368,6 +368,14 @@ functionalAPITests ps = do withSmpServer ps testRejectContactRequestDR it "should communicate rejection reason via double ratchet (async)" $ withSmpServer ps testRejectContactRequestDRAsync + it "should send a service request and receive the response" $ + withSmpServer ps testServiceRequestResponse + it "should send a service request and receive the response (async reply)" $ + withSmpServer ps testServiceRequestResponseAsync + it "should reject a service request with a reason" $ + withSmpServer ps testServiceRequestRejected + it "should deliver a service response across server outages" $ + testServiceRequestResilient ps describe "Changing connection user id" $ do it "should change user id for new connections" $ do withSmpServer ps testUpdateConnectionUserId @@ -1310,6 +1318,69 @@ testRejectContactRequestDRAsync = ("", _, A.RJCT "not now") <- get bob pure () +serviceUserLinkData :: UserConnLinkData 'CMContact +serviceUserLinkData = UserContactLinkData UserContactData {direct = True, owners = [], relays = [], userData = UserLinkData "test user data", ratchetKeys = Nothing} + +testServiceRequestResponse :: HasCallStack => IO () +testServiceRequestResponse = + withAgentClients2 $ \service client -> runRight_ $ do + (_addrConnId, CCLink connReq _) <- A.createConnection service NRMInteractive 1 True True SCMContact (Just serviceUserLinkData) Nothing IKPQOn True SMSubscribe + resp <- liftIO $ fst <$> concurrently + (runRight $ sendServiceRequest client NRMInteractive 1 connReq "service request") + (runRight_ $ do + ("", _, SREQ invId "service request") <- get service + sendServiceReply service NRMInteractive 1 invId "service response") + liftIO $ resp `shouldBe` "service response" + liftIO $ threadDelay 250000 -- let the async teardown of the reply queues settle before dispose + +testServiceRequestResponseAsync :: HasCallStack => IO () +testServiceRequestResponseAsync = + withAgentClients2 $ \service client -> runRight_ $ do + (_addrConnId, CCLink connReq _) <- A.createConnection service NRMInteractive 1 True True SCMContact (Just serviceUserLinkData) Nothing IKPQOn True SMSubscribe + resp <- liftIO $ fst <$> concurrently + (runRight $ sendServiceRequest client NRMInteractive 1 connReq "service request") + (runRight_ $ do + ("", _, SREQ invId "service request") <- get service + sendServiceReplyAsync service "1" 1 invId "service response") + liftIO $ resp `shouldBe` "service response" + liftIO $ threadDelay 250000 -- let the async teardown of the reply queues settle before dispose + +testServiceRequestRejected :: HasCallStack => IO () +testServiceRequestRejected = + withAgentClients2 $ \service client -> runRight_ $ do + (_addrConnId, CCLink connReq _) <- A.createConnection service NRMInteractive 1 True True SCMContact (Just serviceUserLinkData) Nothing IKPQOn True SMSubscribe + resp <- liftIO $ fst <$> concurrently + (runExceptT $ sendServiceRequest client NRMInteractive 1 connReq "service request") + (runRight_ $ do + ("", _, SREQ invId "service request") <- get service + rejectServiceRequest service NRMInteractive 1 invId (Just "not allowed")) + liftIO $ resp `shouldBe` Left (AGENT (A_SERVICE (ASERejected "not allowed"))) + liftIO $ threadDelay 250000 -- let the async teardown of the reply queues settle before dispose + +-- server down, send, up, receive, down, reply, up, receive response. +-- The request send retries through the outage (NRMBackground); the reply is queued while the server is +-- down and delivered on reconnect (async reply via ICReplyDel); the requester's blocking call receives it. +testServiceRequestResilient :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testServiceRequestResilient ps = withAgentClients2 $ \service client -> do + -- server up: create the service address + connReq <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do + (_, CCLink connReq _) <- A.createConnection service NRMInteractive 1 True True SCMContact (Just serviceUserLinkData) Nothing IKPQOn True SMSubscribe + pure connReq + ("", "", DOWN _ _) <- nGet service + -- server down: the client sends the request; NRMBackground retries the send until the server is back + reqAsync <- async $ runExceptT $ sendServiceRequest client NRMBackground 1 connReq "resilient request" + -- server up: the request is delivered and the service receives it + invId <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do + ("", "", UP _ _) <- nGet service + ("", _, SREQ invId "resilient request") <- get service + pure invId :: ExceptT AgentErrorType IO InvitationId + ("", "", DOWN _ _) <- nGet service + -- server down: the service replies; the async reply is enqueued and retried until the server is back + runRight_ $ sendServiceReplyAsync service "1" 1 invId "resilient response" + -- server up: the reply is delivered and the requester's blocking call returns the response + resp <- withSmpServerStoreLogOn ps testPort $ \_ -> wait reqAsync + resp `shouldBe` Right "resilient response" + testUpdateConnectionUserId :: HasCallStack => IO () testUpdateConnectionUserId = withAgentClients2 $ \alice bob -> runRight_ $ do diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index c94b1921b..71e2e4952 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -198,7 +198,8 @@ cData1 = lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, - pqSupport = CR.PQSupportOn + pqSupport = CR.PQSupportOn, + serviceReply = False } testPrivateAuthKey :: C.APrivateAuthKey From d448c94ea398d0a85a3f28041bb713005069c2fe Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Tue, 21 Jul 2026 18:30:48 +0000 Subject: [PATCH 03/15] simplify rpc, test, async --- .../2026-07-11-service-rpc-implementation.md | 126 +++++++++--------- src/Simplex/Messaging/Agent.hs | 33 ++++- tests/AgentTests/FunctionalAPITests.hs | 9 +- 3 files changed, 93 insertions(+), 75 deletions(-) diff --git a/plans/2026-07-11-service-rpc-implementation.md b/plans/2026-07-11-service-rpc-implementation.md index b88ab4f7c..9af045a44 100644 --- a/plans/2026-07-11-service-rpc-implementation.md +++ b/plans/2026-07-11-service-rpc-implementation.md @@ -2,27 +2,23 @@ RFC: [../rfcs/2026-07-11-service-rpc.md](../rfcs/2026-07-11-service-rpc.md) -Depends on: [2026-07-12-address-dr-implementation.md](2026-07-12-address-dr-implementation.md). RPC establishes the double ratchet from the address exactly as the address-DR plan does; this plan is the RPC layer on top of it. Steps named R2'/R5'/O2'/O3' are from that plan. +Depends on: [2026-07-12-address-dr-implementation.md](2026-07-12-address-dr-implementation.md). RPC establishes the double ratchet from the address exactly as the address-DR plan does; this is the RPC layer on top of it. Steps named R2'/R5'/O2'/O3' are from that plan. -**Scope: transport + rejection.** One request, **one** response - no continuation, no streaming. Service-side **idempotency** (single execution by request hash) is deferred. +**Status: transport + rejection implemented and tested** (this repo). Service-side **idempotency** (single execution by request hash) is deferred. The `simplex-chat` integration (`RJCT` -> `XReject`/`XGrpReject`, bot consumption of `SREQ`) is a separate repo. -**HTTP vs WebSocket.** RPC is the HTTP-shaped path: a single request and a single response, no persistent connection. A contact request is the WebSocket-shaped path: it opens a connection over which both sides then exchange messages. One DR-advertising address serves both, and the owner decides which it is per incoming request from the decrypted inner message - `AgentConnInfoReply` opens a connection, `AgentServiceRequest` answers an RPC. This plan builds the HTTP-shaped path (the WebSocket-shaped path is the existing contact/connection flow). +**Scope.** One request, **one** response - no continuation, no streaming. -**Single-response shape.** A request gets exactly one reply, which is either a response or a rejection; there are no follow-up messages, no `final` flag (the one response is terminal), no callback, and one payload per reply. This makes a response and a rejection the *same operation*: each is the single confirming message on the requester's reply queue Q_A, after which the ephemeral reply connection is torn down. They differ only in the inner message (`AgentServiceResponse` payload vs `AgentRejection` reason) and in the requester's outcome (the call returns the payload vs throws an agent error with the reason). So the reply path is the rejection path already built, parameterized by the inner message. +**HTTP vs WebSocket.** RPC is the HTTP-shaped path: a single request and a single response, no persistent connection. A contact request is the WebSocket-shaped path: it opens a connection over which both sides then exchange messages. One DR-advertising address serves both, and the owner decides which per incoming request from the decrypted inner message - `AgentConnInfoReply` opens a connection, `AgentServiceRequest` answers an RPC. This is the HTTP-shaped path (the WebSocket-shaped path is the existing contact/connection flow). -**Design rule: no parallel flow.** On the receive side an RPC request and a contact invitation are the same message stored the same way - one `smpContactRequest` (renamed from `smpInvitationDR`) writes one `conn_invitations` row, differing only in a kind column (`is_service_request`) and the event (`REQ` vs `SREQ`). The kind makes the APIs exclusive: an invitation can only be accepted, a request only responded to or rejected; the wrong API on the wrong kind is `CMD PROHIBITED`. The reply/reject send is the shared secure -> deliver-one-confirmation -> delete-with-wait-delivery path. +**Single-response shape.** A request gets exactly one reply, either a response or a rejection; no follow-up messages, no `final` flag, no callback, one payload per reply. So a response and a rejection are the *same operation*: each is the single confirming message on the requester's reply queue Q_A, after which the ephemeral reply connection is torn down. They differ only in the inner message (`AgentServiceResponse` payload vs `AgentRejection` reason) and the requester's outcome (the call returns the payload vs throws an agent error). The reply path is the rejection path, parameterized by the inner message. -## Built so far - -Kept: `AgentContactRequest` rename (tag `'A'`); the `SREQ`/`RJCT` events; `SREQ :: InvitationId -> MsgBody`; contact rejection (`rejectContact`/`rejectContactAsync` via the `ICReject` internal command, requester-side `RJCT`, tests green); the `M20260712_service_rpc` migration (now `conn_invitations.is_service_request` + `connections.created_at`), schema tests green. - -Small revisions to fit the single-response shape: the inner `AgentServiceResponse`/`AgentRejection` lose their `APrivHeader`, the `Bool final` flag and `NonEmpty` (below) - they are single, headerless confirming messages like `AgentConnInfoReply`; `ICReject` (secure + deliver the pending confirmation + delete) is inner-message-agnostic, so it is reused for responses too (renamed to a neutral `ICReplyDel`). +**No parallel flow.** On the receive side an RPC request and a contact invitation are the same message stored the same way - one `smpContactRequest` (renamed from `smpInvitationDR`) writes one `conn_invitations` row, differing only in a kind column (`is_service_request`) and the event (`REQ` vs `SREQ`). The kind makes the APIs exclusive: an invitation is only accepted, a request only responded to / rejected; the wrong API on the wrong kind is `CMD PROHIBITED`. The reply/reject send is the shared secure -> deliver-one-confirmation -> delete-with-wait-delivery path (`prepareReply` + `sendReplySync`/`sendReplyAsync`, the latter via the `ICReplyDel` internal command, renamed from `ICReject`). ## RPC messages -**No new outer envelope.** The request reuses `AgentContactRequest` (to the address queue); the one reply reuses `AgentConfirmation` (the confirming first message on Q_A - the only message, so never `AgentMsgEnvelope`). +**No new outer envelope.** The request reuses `AgentContactRequest` (tag `'A'`, renamed from `AgentInvitationDR`); the one reply reuses `AgentConfirmation` (the confirming first message on Q_A - the only message, so never `AgentMsgEnvelope`). -**Inner `AgentMessage`** (L4, ratchet-encrypted; Protocol.hs:921, `parseMessage`) - three headerless variants, siblings of `AgentConnInfoReply`: +**Inner `AgentMessage`** (L4, ratchet-encrypted; parsed by `parseMessage`) - three headerless variants, siblings of `AgentConnInfoReply`: ```haskell data AgentMessage @@ -36,56 +32,56 @@ AgentServiceResponse body -> smpEncode ('P', Tail body) AgentRejection reason -> smpEncode ('J', Tail reason) ``` -`AgentServiceRequest` carries Q_A (as `AgentConnInfoReply` does) so the service knows where to reply; its constructor is the only thing that tells `REQ` from `SREQ`. `AgentServiceResponse`/`AgentRejection` are each the sole message on Q_A - no header (nothing to number or chain), no `final` (terminal), no `NonEmpty` (one payload). `AgentMessageType`: `AM_SRV_RESP` and `AM_RJCT` both route to `sendConfirmation` (the reply is always a confirmation); there is no later-message path for RPC, so `agentClientMsg` is unchanged. +`AgentServiceRequest` carries Q_A (as `AgentConnInfoReply` does) so the service knows where to reply; its constructor is the only thing that tells `REQ` from `SREQ`. `AgentServiceResponse`/`AgentRejection` are each the sole message on Q_A - no header, no `final`, no `NonEmpty`. `AgentMessageType` `AM_SRV_REQ`/`AM_SRV_RESP`/`AM_RJCT`: **`AM_SRV_RESP` and `AM_RJCT` both route to `sendConfirmation`** in the delivery worker (the reply is always the confirming first message on Q_A); there is no later-message path for RPC, so `agentClientMsg` is unchanged. ## Ratchet establishment - reuse of the address-DR flow -**Request (client)** - address-DR requester path (R2'/R3'), inner is `AgentServiceRequest`: +**Request (client)** - address-DR requester path, inner is `AgentServiceRequest`. The client send reuses `joinConnSrv`, parameterized **in place**: `joinConnSrv'` takes an `mkInner :: SMPQueueInfo -> AgentMessage` and only the `sndReply` line changed; `joinConnSrv = joinConnSrv' … (\rq -> AgentConnInfoReply (rq :| []) cInfo)` is the one-line wrapper, so existing call sites are unchanged. `sendServiceRequest` calls `joinConnSrv' … (\rq -> AgentServiceRequest (rq :| []) payload)`. -- Negotiate the advertised ratchet params, create Q_A (messaging mode, subscribed), establish the send ratchet. -- Send `AgentContactRequest {e2eSndParams, ratchetKeyId, encConnInfo = ratchetEncrypt(AgentServiceRequest (Q_A :| []) payload)}` to the address, unauthenticated. The client connection is `RcvConnection` (Q_A) with the send ratchet; mark its `created_at` (cleanup below). +- Negotiate the advertised ratchet params, create Q_A (messaging mode, subscribed), establish the send ratchet, send `AgentContactRequest {e2eSndParams, ratchetKeyId, encConnInfo = ratchetEncrypt(AgentServiceRequest (Q_A :| []) payload)}` to the address, unauthenticated. The client connection is `RcvConnection` (Q_A) with the send ratchet; its `created_at` is set (`setConnServiceReply`) to mark it a reply queue for cleanup and for the `serviceReply` flag. -**Request (service)** - `smpContactRequest` (renamed `smpInvitationDR`, Agent.hs:3792): decrypt `encConnInfo`, then branch on the inner message. **Both branches call the same `storeInvitation` -> `conn_invitations`** (AgentStore.hs:877), writing the kind column; they differ only in the event: +**Request (service)** - `smpContactRequest` (renamed `smpInvitationDR`): decrypt `encConnInfo`, then branch on the inner message. **Both branches call the same `storeInvitation` -> `conn_invitations`**, writing the kind column; they differ only in the event: - `AgentConnInfoReply` -> `REQ invId ...` (`is_service_request = 0`, unchanged). - `AgentServiceRequest _ payload` -> `SREQ invId payload` (`is_service_request = 1`). -The service holds the request as an invitation with the payload as `recipient_conn_info`; no connection yet. Receive-time establishment on unauthenticated input - the address-DR abuse bound applies unchanged. +The service holds the request as an invitation with the payload as `recipient_conn_info`; no connection yet. Receive-time establishment on unauthenticated input - the address-DR abuse bound applies. -**The one reply (service)** - `sendServiceReply c nm invId payload`, the accept-and-tear-down path (the rejection path with a payload). `CMD PROHIBITED` if the invitation is a contact invitation (wrong kind); an answered request is no longer pending, so a repeat just fails to find it: +**The one reply (service)** - `sendServiceReply c nm userId invId payload` (accept-and-tear-down; the rejection path with a payload). `CMD PROHIBITED` if the invitation is a contact invitation (wrong kind), or `A_SERVICE ASETimeout` (+ delete the invitation) if it is older than `serviceReplyTimeout`; a repeat on an answered request just fails to find a pending record: -- `newConnToAccept` (Agent.hs:1359) creates the ephemeral reply connection from the request; `startJoinInvitationDR` builds the `SndQueue` to Q_A and the ratchet - **no reply queue back** (one-directional; the divergence from `acceptContact'`, which sends `AgentConnInfoReply` with its reply queue). -- `storeConfirmation` the pending `AgentServiceResponse payload` (`AM_SRV_RESP` -> `sendConfirmation`); `acceptInvitation`; then secure Q_A + deliver + `deleteConnectionAsync' True` (wait-for-delivery, so the one message is delivered before teardown). Sync `sendServiceReply` secures via `agentSecureSndQueue`; async `sendServiceReplyAsync` defers secure+deliver+delete to `ICReplyDel` (the renamed `ICReject`, retried, never fails client-side). -- Returns `()`. There is no continuation, so no `connId` is handed back. +- `newConnToAccept` creates the ephemeral reply connection; `startJoinInvitationDR` builds the `SndQueue` to Q_A and the ratchet - **no reply queue back** (one-directional; the divergence from `acceptContact'`). +- `storeConfirmation` the pending `AgentServiceResponse payload` (`AM_SRV_RESP`); `acceptInvitation`; then secure Q_A + deliver + `deleteConnectionAsync' True` (`sendReplySync`). Async `sendServiceReplyAsync` defers secure+deliver+delete to `ICReplyDel` (`sendReplyAsync`, retried, never fails client-side, survives a down server). Returns `()`. -**The one response (client)** - the single `AgentConfirmation` on Q_A -> `smpConfirmation`'s `RcvConnection … Nothing` branch (R5', Agent.hs:3546, already parsing `AgentConnInfoReply`/`AgentRejection`), extended for `AgentServiceResponse`: an `AgentServiceResponse payload` completes the waiting `sendServiceRequest` with the payload; an `AgentRejection reason` completes it with a thrown agent error. Either way, ack and `deleteConnectionAsync' True` on Q_A. No later-message path. +**The one response (client)** - the single `AgentConfirmation` on Q_A -> `smpConfirmation`'s `RcvConnection … Nothing` branch (already parsing `AgentConnInfoReply`/`AgentRejection`), extended, gated on the connection's `serviceReply` flag: `AgentServiceResponse payload` -> the request's `TMVar` gets `Right payload`; `AgentRejection reason` -> `Left (AGENT (A_SERVICE (ASERejected reason)))`; if `serviceReply` is set but there is no `TMVar` (post-restart), an `ERR (AGENT (A_SERVICE ASENoRequest))` event; if `serviceReply` is not set, `AgentRejection` is a contact rejection -> `RJCT`. The waiting `sendServiceRequest` unwraps the `TMVar` and tears Q_A down (`deleteConnectionAsync' True`). No later-message path. ## Rejection -A rejection is `AgentRejection reason` - the same single confirming message on Q_A as a response, always tearing the connection down. It refuses an RPC request and, unchanged from what is built, a contact request. +A rejection is `AgentRejection reason` - the same single confirming message on Q_A as a response, always tearing the connection down. It refuses an RPC request and, unchanged, a contact request. -- **Kind guard:** `rejectContact` only on a contact invitation, `rejectServiceRequest` only on a request; the wrong kind is `CMD PROHIBITED` (read the kind off the pending invitation). An already accepted/responded request is not pending (`getInvitation` filters `accepted = 0`), so the reject fails to find it, as a repeat should. -- `rejectContact`/`rejectContactAsync` / `rejectServiceRequest`/`rejectServiceRequestAsync` take `Maybe ByteString`: `Nothing` -> silent drop (delete the invitation, no message); `Just reason` -> `CMD PROHIBITED` on a classic `CRInvitation` (no ratchet) or the wrong kind; else the reply path above with `AgentRejection` as the inner message. -- Requester side: `AgentRejection` on a contact reply queue -> `RJCT` event to chat (async, mapped to `XReject`/`XGrpReject`); on an RPC reply queue -> a thrown agent error ending `sendServiceRequest` (synchronous; a new `AgentErrorType` carries the reason). +- **Kind guard** (`prepareReply`): `rejectContact` only on a contact invitation, `rejectServiceRequest`/`sendServiceReply` only on a request; the wrong kind is `CMD PROHIBITED`. An accepted/responded request is not pending (`getInvitation` filters `accepted = 0`), so the reject fails to find it, as a repeat should. +- `rejectContact`/`rejectContactAsync` / `rejectServiceRequest`/`rejectServiceRequestAsync` take `Maybe ByteString`: `Nothing` -> silent drop (delete the invitation, no message); `Just reason` -> `CMD PROHIBITED` on a classic `CRInvitation` (no ratchet) or the wrong kind; else the reply path with `AgentRejection` as the inner message. +- Requester side: `AgentRejection` on a contact reply queue -> `RJCT` event to chat (async, mapped to `XReject`/`XGrpReject`); on an RPC reply queue -> a thrown `A_SERVICE (ASERejected reason)` ending `sendServiceRequest` (synchronous). -## Reply connection and cleanup +## Reply connections and cleanup No reply-queue table and no new connection type - both reply connections are ordinary connections with a ratchet. -- **Client reply queue** (`RcvConnection` on Q_A): routed by the in-memory `serviceRequests :: TMap ConnId (TMVar (Either AgentErrorType MsgBody))` in `AgentClient` (Client.hs) - `sendServiceRequest` inserts a one-shot, the receive path fills it (`Right payload` / `Left rejection`), the call unwraps it. The normal path tears the connection down within the call; only a client restart mid-call orphans it. `connections.created_at` is set when the queue is created; `cleanupManager` (Agent.hs:3162) reaps connections whose `created_at` is older than a config TTL (RPC is short-lived), emitting `DEL`. -- **Service reply connection** (`SndConnection` to Q_A): ephemeral - created, sends the one reply, and is deleted with wait-for-delivery in the same operation, so it never lingers and needs no marker. -- **Service request** (`conn_invitations`, which has `created_at`): an unanswered request is reaped by `created_at` + config TTL. This is the received-side "requests table" - `conn_invitations`, differentiated by kind - not a new table. +- **The `serviceReply` flag** is on `ConnData`, loaded by `getConnData` as `created_at IS NOT NULL`; `connections.created_at` is non-null only on a client RPC reply queue (set by `sendServiceRequest`). +- **Client reply queue** (`RcvConnection` on Q_A): routed by the in-memory `serviceRequests :: TMap ConnId (TMVar (Either AgentErrorType MsgBody))` in `AgentClient` - `sendServiceRequest` inserts a one-shot, the receive path fills it. The normal path tears the queue down within the call; only a client restart mid-call orphans it, reaped by `created_at` age. +- **Service reply connection** (`SndConnection` to Q_A): ephemeral - created, sends the one reply, deleted with wait-for-delivery in the same operation. +- **Cleanup** (`cleanupManager`, one added step, using `serviceReplyTimeout` as the TTL): `deleteExpiredServiceRequests` reaps unanswered `conn_invitations` (kind = request) by `created_at`; `getExpiredServiceReplyConnIds` -> `deleteConnectionsAsync'` reaps orphaned client reply queues (`connections.created_at` non-null, not deleted, past the TTL). -## Database schema (done) +## Database schema -`M20260712_service_rpc` (SQLite + PostgreSQL), on top of the address-DR migration: +Combined into the address-DR migration - `M20260712_address_dr_rpc` (SQLite + PostgreSQL) creates `address_ratchet_keys` (address-DR) and adds the two RPC columns: ```sql +-- ... address_ratchet_keys table + index (address-DR) ... ALTER TABLE conn_invitations ADD COLUMN is_service_request INTEGER NOT NULL DEFAULT 0; -- 1 = RPC request, 0 = contact invitation -ALTER TABLE connections ADD COLUMN created_at TEXT; -- set on a client RPC reply queue; cleanup age (nullable) +ALTER TABLE connections ADD COLUMN created_at TEXT; -- non-null on a client RPC reply queue; marker + cleanup age (nullable) ``` -The service's address ratchet keys are the address-DR `address_ratchet_keys` table. The deferred idempotency work will add its own tables when built. +The down migration drops the columns then the table/index. Schema dump tests pass (up, down, STRICT). The deferred idempotency work will add its own tables when built. ## Agent API - `Simplex.Messaging.Agent` @@ -93,14 +89,14 @@ Service side (a service publishes an ordinary DR-advertising contact address; th ```haskell -- Sends the one response to the request from SREQ's invitation id, then tears the reply connection down. -sendServiceReply :: AgentClient -> NetworkRequestMode -> InvitationId -> MsgBody -> AE () -sendServiceReplyAsync :: AgentClient -> ACorrId -> InvitationId -> MsgBody -> AE () +sendServiceReply :: AgentClient -> NetworkRequestMode -> UserId -> InvitationId -> MsgBody -> AE () +sendServiceReplyAsync :: AgentClient -> ACorrId -> UserId -> InvitationId -> MsgBody -> AE () -- Refuses a request (Just reason = AgentRejection to Q_A; Nothing = silent drop). PROHIBITED on wrong kind. rejectServiceRequest :: AgentClient -> NetworkRequestMode -> UserId -> InvitationId -> Maybe ByteString -> AE () rejectServiceRequestAsync :: AgentClient -> ACorrId -> UserId -> InvitationId -> Maybe ByteString -> AE () --- contact rejection (built), plus the new kind guard: +-- contact rejection, now sharing prepareReply + the kind guard: rejectContact :: AgentClient -> NetworkRequestMode -> UserId -> ConfirmationId -> Maybe ByteString -> AE () rejectContactAsync :: AgentClient -> ACorrId -> UserId -> ConfirmationId -> Maybe ByteString -> AE () ``` @@ -108,37 +104,34 @@ rejectContactAsync :: AgentClient -> ACorrId -> UserId -> ConfirmationId -> Mayb Client side: ```haskell --- Establishes the ratchet from the address, creates Q_A, sends the request, and waits for the one response up to --- the client-config timeout. Returns the response payload; a rejection or timeout is a thrown agent error. No callback. -sendServiceRequest :: - AgentClient -> NetworkRequestMode -> UserId -> ConnectionRequestUri 'CMContact -> MsgBody -> AE MsgBody +-- Both establish the ratchet from the address, create Q_A, send the request, and block on the reply TMVar up to +-- serviceRequestTimeout, returning the payload (a rejection or timeout is a thrown agent error). No callback. +-- Sync: the send is direct and fails fast if the server is down. Async: the send is enqueued as a retried command. +sendServiceRequest :: AgentClient -> NetworkRequestMode -> UserId -> ConnectionRequestUri 'CMContact -> MsgBody -> AE MsgBody +sendServiceRequestAsync :: AgentClient -> UserId -> ConnectionRequestUri 'CMContact -> MsgBody -> AE MsgBody ``` -`sendServiceRequest`'s address input is the resolved `ConnectionRequestUri 'CMContact` (reuses the address-DR `joinConnSrv` path, testable like the DR tests); short-link resolution can wrap it later. The wait is bounded by an `AgentConfig` timeout, not a per-call deadline. No `cancelServiceRequest` - an aborted call's Q_A is reaped by `created_at`. +Both share `serviceRequest_` (create Q_A + mark `created_at` + register the `TMVar` + block on it up to `serviceRequestTimeout` + tear down); they differ only in the send. **Sync** calls `joinConnSrv'` directly - it fails fast on `BROKER NETWORK` if the server is down (`NRMBackground` only sets the per-attempt timeout, it does not retry a refused connection). **Async** enqueues an ordinary `JOIN (JRConnReq …)` command, which the command worker runs through `tryCommand` (`withRetryInterval`/`temporaryOrHostError`, the same retry the reply's `ICReplyDel` uses) - so the send survives a server outage. No new command or serialization: the `JOIN` worker branches on the reply queue's `serviceReply` flag (persistent, from `created_at`) to send `AgentServiceRequest` via `joinConnSrv'` instead of `AgentConnInfoReply`, and skips the `JOINED` event. Either way the call blocks on the `TMVar` and returns the response synchronously - no events, so the app has no correlation to do. There is no `cancelServiceRequest` - an aborted call's Q_A is reaped by `created_at`. Events (`AEvent`, entity is the address connection): ```haskell SREQ :: InvitationId -> MsgBody -> AEvent AEConn -- mirrors REQ (InvitationId); payload = the request. -RJCT :: ConnInfo -> AEvent AEConn -- built; contact-request rejection reason to chat. +RJCT :: ConnInfo -> AEvent AEConn -- contact-request rejection reason to chat. ``` -## Agent processing - -Client: - -- `sendServiceRequest`: address-DR R2' (ratchet + Q_A) with `AgentServiceRequest` inside; set `created_at`; insert the one-shot `TMVar` keyed by the reply `connId`; send `AgentContactRequest`; block on the `TMVar` until the response or the config timeout; on either, `deleteConnectionAsync' True` on Q_A; return the payload or throw. -- Reception: only `smpConfirmation` R5' is touched (`AgentServiceResponse` -> fill `Right`, `AgentRejection` -> fill `Left`); no later-message path. -- `cleanupManager`: delete connections whose `created_at` is older than the TTL (restart-orphaned reply queues). +Errors (`SMPAgentError`, mirroring `A_CRYPTO {cryptoErr :: AgentCryptoError}`): -Service: +```haskell +| A_SERVICE {serviceError :: AgentServiceError} -- `smpContactRequest`: one `storeInvitation` (writing the kind), branch the event `REQ`/`SREQ`. -- `sendServiceReply`: `newConnToAccept` + `startJoinInvitationDR` (no reply queue back) + `storeConfirmation (AgentServiceResponse payload)` + `acceptInvitation` + secure + deliver + `deleteConnectionAsync' True`. Async defers to `ICReplyDel`. -- `rejectServiceRequest`: the same path with `AgentRejection`, guarded by kind. `sendServiceReply`, `rejectServiceRequest`, and `rejectContact` share one helper, parameterized by the inner message and the kind it expects. -- `cleanupManager`: reap `conn_invitations` requests older than the TTL. +data AgentServiceError + = ASERejected {rejectReason :: String} -- the service refused, reason as latin1 String (bytes round-trip) + | ASETimeout -- no reply within the timeout (client wait, or a late service reply) + | ASENoRequest -- a reply arrived with no pending request (e.g. post-restart) +``` -Config (`AgentConfig`): service-request timeout (the client-side wait bound); RPC cleanup TTL. +Config (`AgentConfig`): `serviceRequestTimeout` (30 s, the client wait) and `serviceReplyTimeout` (180 s, the service reply window and the cleanup TTL; must exceed `serviceRequestTimeout`). ## Idempotency (deferred) @@ -146,14 +139,17 @@ Not built. When built, the service will key a request by hash and cache the one ## Tests -- Encoding roundtrips: `AgentServiceRequest`, `AgentServiceResponse`, `AgentRejection` in `AgentMessage`; the `AgentContactRequest` rename (wire unchanged). (Revise the built roundtrip for the headerless/single shape.) -- End to end: a request with one response; `pqEncryption` on/off per advertised keys; the payload never travels under per-queue-only encryption. -- Rejection: `rejectServiceRequest (Just reason)` ends `sendServiceRequest` with the reason (thrown); `rejectContact (Just reason)` reaches the requester as `RJCT`, `Nothing` = silent drop; a wrong-kind reject is `CMD PROHIBITED`; the same address serves a connection and an RPC and can refuse either. -- Lifecycle: the reply connection and ratchet are deleted after the response and after a rejection; the config timeout ends a request with no reply; a restart reaps orphaned client reply queues via `created_at`. +Implemented and passing (in `FunctionalAPITests`, plus the encoding roundtrip in `ConnectionRequestTests`): + +- Encoding roundtrip: `AgentServiceRequest`/`AgentServiceResponse`/`AgentRejection` (headerless single) + the `AgentContactRequest` rename. +- Request -> one response (sync `sendServiceReply`). +- Request -> one response (async `sendServiceReplyAsync`). +- Request -> rejection (`rejectServiceRequest (Just reason)` -> thrown `A_SERVICE (ASERejected …)`). +- **Resilience**: `server down -> send -> up -> receive -> down -> reply -> up -> receive response` - the send (`sendServiceRequestAsync`) is enqueued and retried through the outage, the reply (`sendServiceReplyAsync`) is queued and delivered on reconnect; both blocking calls receive their result. +- No regression: the existing rejection + schema tests still pass. -## Phases +Not yet covered (code-complete): the wrong-kind `CMD PROHIBITED` guards; the client timeout (`ASETimeout`); the late-reply timeout (`serviceReplyTimeout`); `cleanupManager` reaping; the `ASENoRequest` post-restart path. A full `simplexmq-test` run and the PostgreSQL migration path are also not yet run here. -1. **[migration + `SREQ` done]** Message revision: `AgentServiceResponse`/`AgentRejection` -> headerless single (drop `APrivHeader`/`Bool`/`NonEmpty`), update encodings + the built contact-rejection call sites + roundtrip test; rename `ICReject` -> `ICReplyDel`; add the `AgentErrorType` rejection reason; thread `is_service_request` onto `Invitation`/`getInvitation` and add the kind guard to `rejectContact`. -2. `smpContactRequest` dispatch (`AgentServiceRequest` -> `SREQ`, writing the kind); the shared `sendServiceReply`/`rejectServiceRequest` (+ async) reply helper; client `sendServiceRequest` + `smpConfirmation` reception + `serviceRequests` one-shot map; both-sides `cleanupManager` steps. End-to-end and rejection tests. +## Status -Later, separate pass: idempotency. +Both implementation phases are done and compile clean. Remaining in this repo: the test gaps above, a full suite run, and the PostgreSQL path. Separate `simplex-chat` repo: `RJCT` -> `XReject`/`XGrpReject`, bot consumption of `SREQ` / `sendServiceReply`, and `sendServiceRequest` on the client. Later, separate pass: idempotency. diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index c09e83a95..fd013a104 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -78,6 +78,7 @@ module Simplex.Messaging.Agent rejectContact, rejectContactAsync, sendServiceRequest, + sendServiceRequestAsync, sendServiceReply, sendServiceReplyAsync, rejectServiceRequest, @@ -531,11 +532,16 @@ rejectServiceRequestAsync :: AgentClient -> ACorrId -> UserId -> InvitationId -> rejectServiceRequestAsync c corrId userId invId reason = withAgentEnv c $ rejectServiceRequestAsync' c corrId userId invId reason {-# INLINE rejectServiceRequestAsync #-} --- | Send a service (RPC) request to an address and wait for the single response +-- | Send a service (RPC) request to an address and wait for the single response. +-- Sync fails fast if the server is down; async enqueues a retried send but still returns the response synchronously. sendServiceRequest :: AgentClient -> NetworkRequestMode -> UserId -> ConnectionRequestUri 'CMContact -> MsgBody -> AE MsgBody sendServiceRequest c nm userId cReqUri payload = withAgentEnv c $ sendServiceRequest' c nm userId cReqUri payload {-# INLINE sendServiceRequest #-} +sendServiceRequestAsync :: AgentClient -> UserId -> ConnectionRequestUri 'CMContact -> MsgBody -> AE MsgBody +sendServiceRequestAsync c userId cReqUri payload = withAgentEnv c $ sendServiceRequestAsync' c userId cReqUri payload +{-# INLINE sendServiceRequestAsync #-} + data DatabaseDiff a = DatabaseDiff { missingIds :: [a], extraIds :: [a] @@ -1702,17 +1708,29 @@ prepareReply c userId invId expectedServiceRequest innerMsg = do | otherwise = "rejectContact: service request, use rejectServiceRequest" -- | Send a service (RPC) request to a DR-advertising address, wait for the single response up to the config timeout. +-- Sync: the send fails fast on a down server. Async: the send is enqueued as a JOIN command retried by the worker. +-- Both block on the reply TMVar and return the response synchronously. sendServiceRequest' :: AgentClient -> NetworkRequestMode -> UserId -> ConnectionRequestUri 'CMContact -> MsgBody -> AM MsgBody -sendServiceRequest' c nm userId cReqUri@(CRContactUri crData _) payload = do +sendServiceRequest' c nm userId cReqUri payload = + serviceRequest_ c userId cReqUri $ \connId srv -> + void $ joinConnSrv' c nm userId connId False cReqUri payload PQSupportOn SMSubscribe srv $ \replyQInfo -> AgentServiceRequest (replyQInfo :| []) payload + +sendServiceRequestAsync' :: AgentClient -> UserId -> ConnectionRequestUri 'CMContact -> MsgBody -> AM MsgBody +sendServiceRequestAsync' c userId cReqUri payload = + serviceRequest_ c userId cReqUri $ \connId _srv -> + enqueueCommand c "" connId Nothing $ AClientCommand $ JOIN (JRConnReq False (ACR SCMContact cReqUri) PQSupportOn) SMSubscribe payload + +serviceRequest_ :: AgentClient -> UserId -> ConnectionRequestUri 'CMContact -> (ConnId -> SMPServerWithAuth -> AM ()) -> AM MsgBody +serviceRequest_ c userId cReqUri@(CRContactUri crData _) doSend = do connId <- newConnToJoin c userId "" False cReqUri PQSupportOn ts <- liftIO getCurrentTime - withStore' c $ \db -> setConnServiceReply db connId ts + withStore' c $ \db -> setConnServiceReply db connId ts -- created_at marks the reply queue; the JOIN worker uses it to send AgentServiceRequest var <- atomically newEmptyTMVar atomically $ TM.insert connId var (serviceRequests c) srv <- getNextSMPServer c userId [qServer $ L.head $ crSmpQueues crData] reqTimeout <- asks $ serviceRequestTimeout . config r <- tryError $ do - void $ joinConnSrv' c nm userId connId False cReqUri "" PQSupportOn SMSubscribe srv $ \replyQInfo -> AgentServiceRequest (replyQInfo :| []) payload + doSend connId srv liftIO $ do expired <- registerDelay $ round (reqTimeout * 1000000) atomically $ takeTMVar var `orElse` (readTVar expired >>= \e -> if e then pure (Left $ AGENT $ A_SERVICE ASETimeout) else retry) @@ -2139,8 +2157,11 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do JOIN (JRConnReq enableNtfs (ACR _ cReq@(CRContactUri ConnReqUriData {crSmpQueues = q :| _} _)) pqEnc) subMode connInfo -> noServer $ do triedHosts <- newTVarIO S.empty tryCommand . withNextSrv c userId storageSrvs triedHosts [qServer q] $ \srv -> do - sqSecured <- joinConnSrv c NRMBackground userId connId enableNtfs cReq connInfo pqEnc subMode srv - notify $ JOINED sqSecured + SomeConn _ conn <- withStore c (`getConn` connId) + -- a service (RPC) request reuses this JOIN command; the reply queue's created_at marks it (serviceReply) + if serviceReply (toConnData conn) + then void $ joinConnSrv' c NRMBackground userId connId enableNtfs cReq connInfo pqEnc subMode srv $ \replyQInfo -> AgentServiceRequest (replyQInfo :| []) connInfo + else joinConnSrv c NRMBackground userId connId enableNtfs cReq connInfo pqEnc subMode srv >>= notify . JOINED LET confId ownCInfo -> withServer' . tryCommand $ allowConnection' c connId confId ownCInfo >> notify OK ACK msgId rcptInfo_ -> withServer' . tryCommand $ ackMessage' c connId msgId rcptInfo_ >> notify OK SWCH -> diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index dddfe4807..0f139f7bc 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -1358,8 +1358,8 @@ testServiceRequestRejected = liftIO $ threadDelay 250000 -- let the async teardown of the reply queues settle before dispose -- server down, send, up, receive, down, reply, up, receive response. --- The request send retries through the outage (NRMBackground); the reply is queued while the server is --- down and delivered on reconnect (async reply via ICReplyDel); the requester's blocking call receives it. +-- The request send retries the outage (bounded by serviceRequestTimeout) until the server is back; the reply is +-- queued while the server is down and delivered on reconnect (async reply via ICReplyDel); the blocking call receives it. testServiceRequestResilient :: HasCallStack => (ASrvTransport, AStoreType) -> IO () testServiceRequestResilient ps = withAgentClients2 $ \service client -> do -- server up: create the service address @@ -1367,8 +1367,9 @@ testServiceRequestResilient ps = withAgentClients2 $ \service client -> do (_, CCLink connReq _) <- A.createConnection service NRMInteractive 1 True True SCMContact (Just serviceUserLinkData) Nothing IKPQOn True SMSubscribe pure connReq ("", "", DOWN _ _) <- nGet service - -- server down: the client sends the request; NRMBackground retries the send until the server is back - reqAsync <- async $ runExceptT $ sendServiceRequest client NRMBackground 1 connReq "resilient request" + -- server down: the async send is enqueued as a retried JOIN command and blocks for the response + reqAsync <- async $ runExceptT $ sendServiceRequestAsync client 1 connReq "resilient request" + threadDelay 500000 -- let the enqueued send retry against the down server before bringing it up -- server up: the request is delivered and the service receives it invId <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do ("", "", UP _ _) <- nGet service From faa2a88b8ce2dd7756cd2f66e761e03e96ac685a Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Tue, 21 Jul 2026 19:46:42 +0000 Subject: [PATCH 04/15] renames --- src/Simplex/Messaging/Agent.hs | 60 +++++++++---------- src/Simplex/Messaging/Agent/Env/SQLite.hs | 6 +- src/Simplex/Messaging/Agent/Protocol.hs | 14 ++--- src/Simplex/Messaging/Agent/Store.hs | 6 +- .../Messaging/Agent/Store/AgentStore.hs | 42 +++++++------ .../Migrations/M20260712_address_dr_rpc.hs | 8 ++- .../Migrations/M20260712_address_dr_rpc.hs | 8 ++- .../Store/SQLite/Migrations/agent_schema.sql | 5 +- tests/AgentTests/SQLiteTests.hs | 2 +- 9 files changed, 74 insertions(+), 77 deletions(-) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index fd013a104..da29ee013 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -514,7 +514,6 @@ rejectContactAsync :: AgentClient -> ACorrId -> UserId -> ConfirmationId -> Mayb rejectContactAsync c corrId userId invId reason = withAgentEnv c $ rejectContactAsync' c corrId userId invId reason {-# INLINE rejectContactAsync #-} --- | Send the single response to a service (RPC) request (SREQ command) sendServiceReply :: AgentClient -> NetworkRequestMode -> UserId -> InvitationId -> MsgBody -> AE () sendServiceReply c nm userId invId payload = withAgentEnv c $ sendServiceReply' c nm userId invId payload {-# INLINE sendServiceReply #-} @@ -523,7 +522,6 @@ sendServiceReplyAsync :: AgentClient -> ACorrId -> UserId -> InvitationId -> Msg sendServiceReplyAsync c corrId userId invId payload = withAgentEnv c $ sendServiceReplyAsync' c corrId userId invId payload {-# INLINE sendServiceReplyAsync #-} --- | Refuse a service (RPC) request rejectServiceRequest :: AgentClient -> NetworkRequestMode -> UserId -> InvitationId -> Maybe ByteString -> AE () rejectServiceRequest c nm userId invId reason = withAgentEnv c $ rejectServiceRequest' c nm userId invId reason {-# INLINE rejectServiceRequest #-} @@ -532,8 +530,6 @@ rejectServiceRequestAsync :: AgentClient -> ACorrId -> UserId -> InvitationId -> rejectServiceRequestAsync c corrId userId invId reason = withAgentEnv c $ rejectServiceRequestAsync' c corrId userId invId reason {-# INLINE rejectServiceRequestAsync #-} --- | Send a service (RPC) request to an address and wait for the single response. --- Sync fails fast if the server is down; async enqueues a retried send but still returns the response synchronously. sendServiceRequest :: AgentClient -> NetworkRequestMode -> UserId -> ConnectionRequestUri 'CMContact -> MsgBody -> AE MsgBody sendServiceRequest c nm userId cReqUri payload = withAgentEnv c $ sendServiceRequest' c nm userId cReqUri payload {-# INLINE sendServiceRequest #-} @@ -900,7 +896,7 @@ newConnNoQueues :: AgentClient -> UserId -> Bool -> SConnectionMode c -> PQSuppo newConnNoQueues c userId enableNtfs cMode pqSupport = do g <- asks random connAgentVersion <- asks $ maxVersion . smpAgentVRange . config - let cData = ConnData {userId, connId = "", connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceReply = False} + let cData = ConnData {userId, connId = "", connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceRequest = False} withStore c $ \db -> createNewConn db g cData cMode -- TODO [short links] TBC, but probably we will need async join for contact addresses as the contact will be created after user confirming the connection, @@ -1151,7 +1147,7 @@ getConnShortLinkAsync' c userId corrId connId_ shortLink@(CSLContact _ _ srv _) deleted = False, ratchetSyncState = RSOk, pqSupport = PQSupportOff, - serviceReply = False + serviceRequest = False } createNewConn db g cData SCMInvitation @@ -1388,7 +1384,7 @@ newConnToJoin c userId connId enableNtfs cReq pqSup = case cReq of create (Compatible connAgentVersion) e2eV_ = do g <- asks random let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ connAgentVersion e2eV_ - cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceReply = False} + cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceRequest = False} withStore c $ \db -> createNewConn db g cData SCMInvitation newConnToAccept :: AgentClient -> UserId -> ConnId -> Bool -> ConfirmationId -> PQSupport -> AM ConnId @@ -1398,7 +1394,7 @@ newConnToAccept c userId connId enableNtfs invId pqSup = do CRInvitation cReq -> newConnToJoin c userId connId enableNtfs cReq pqSup CRInvitationDR DRInvitation {agentVersion, pqSupport} -> do g <- asks random - let cData = ConnData {userId, connId, connAgentVersion = agentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceReply = False} + let cData = ConnData {userId, connId, connAgentVersion = agentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceRequest = False} withStore c $ \db -> createNewConn db g cData SCMInvitation joinConn :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM SndQueueSecured @@ -1418,7 +1414,7 @@ startJoinInvitation c userId connId sq_ enableNtfs cReqUri pqSup = let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ connAgentVersion (Just v) g <- asks random maxSupported <- asks $ maxVersion . e2eEncryptVRange . config - let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceReply = False} + let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceRequest = False} case sq_ of Just sq@SndQueue {e2ePubKey = Just _k} -> do e2eSndParams <- withStore c $ \db -> do @@ -1687,12 +1683,12 @@ sendReplyAsync c corrId (connId, _, sq) = enqueueCommand c corrId connId (Just $ prepareReply :: AgentClient -> UserId -> InvitationId -> Bool -> AgentMessage -> AM (ConnId, ConnData, SndQueue) prepareReply c userId invId expectedServiceRequest innerMsg = do - Invitation {connReq, isServiceRequest, createdAt} <- withStore c $ \db -> getInvitation db "prepareReply" invId - when (isServiceRequest /= expectedServiceRequest) $ throwE $ CMD PROHIBITED kindErr + Invitation {connReq, serviceRequest, createdAt} <- withStore c $ \db -> getInvitation db "prepareReply" invId + when (serviceRequest /= expectedServiceRequest) $ throwE $ CMD PROHIBITED kindErr when expectedServiceRequest $ do now <- liftIO getCurrentTime - replyTimeout <- asks $ serviceReplyTimeout . config - when (diffUTCTime now createdAt > replyTimeout) $ do + responseTimeout <- asks $ serviceResponseTimeout . config + when (diffUTCTime now createdAt > responseTimeout) $ do withStore' c $ \db -> deleteInvitation db invId throwE $ AGENT $ A_SERVICE ASETimeout case connReq of @@ -1707,9 +1703,6 @@ prepareReply c userId invId expectedServiceRequest innerMsg = do | expectedServiceRequest = "reply: not a service request, use rejectContact" | otherwise = "rejectContact: service request, use rejectServiceRequest" --- | Send a service (RPC) request to a DR-advertising address, wait for the single response up to the config timeout. --- Sync: the send fails fast on a down server. Async: the send is enqueued as a JOIN command retried by the worker. --- Both block on the reply TMVar and return the response synchronously. sendServiceRequest' :: AgentClient -> NetworkRequestMode -> UserId -> ConnectionRequestUri 'CMContact -> MsgBody -> AM MsgBody sendServiceRequest' c nm userId cReqUri payload = serviceRequest_ c userId cReqUri $ \connId srv -> @@ -1723,8 +1716,7 @@ sendServiceRequestAsync' c userId cReqUri payload = serviceRequest_ :: AgentClient -> UserId -> ConnectionRequestUri 'CMContact -> (ConnId -> SMPServerWithAuth -> AM ()) -> AM MsgBody serviceRequest_ c userId cReqUri@(CRContactUri crData _) doSend = do connId <- newConnToJoin c userId "" False cReqUri PQSupportOn - ts <- liftIO getCurrentTime - withStore' c $ \db -> setConnServiceReply db connId ts -- created_at marks the reply queue; the JOIN worker uses it to send AgentServiceRequest + withStore' c $ \db -> setConnServiceRequest db connId var <- atomically newEmptyTMVar atomically $ TM.insert connId var (serviceRequests c) srv <- getNextSMPServer c userId [qServer $ L.head $ crSmpQueues crData] @@ -2158,9 +2150,15 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do triedHosts <- newTVarIO S.empty tryCommand . withNextSrv c userId storageSrvs triedHosts [qServer q] $ \srv -> do SomeConn _ conn <- withStore c (`getConn` connId) - -- a service (RPC) request reuses this JOIN command; the reply queue's created_at marks it (serviceReply) - if serviceReply (toConnData conn) - then void $ joinConnSrv' c NRMBackground userId connId enableNtfs cReq connInfo pqEnc subMode srv $ \replyQInfo -> AgentServiceRequest (replyQInfo :| []) connInfo + let ConnData {serviceRequest} = toConnData conn + if serviceRequest + then atomically (TM.lookup connId (serviceRequests c)) >>= \case + Nothing -> pure () -- the caller timed out and removed the waiter, stop retrying the send + Just var -> tryError (void $ joinConnSrv' c NRMBackground userId connId enableNtfs cReq connInfo pqEnc subMode srv $ \replyQInfo -> AgentServiceRequest (replyQInfo :| []) connInfo) >>= \case + Right () -> pure () + Left e -> do + unless (temporaryOrHostError e) $ atomically $ void $ tryPutTMVar var $ Left e + throwE e else joinConnSrv c NRMBackground userId connId enableNtfs cReq connInfo pqEnc subMode srv >>= notify . JOINED LET confId ownCInfo -> withServer' . tryCommand $ allowConnection' c connId confId ownCInfo >> notify OK ACK msgId rcptInfo_ -> withServer' . tryCommand $ ackMessage' c connId msgId rcptInfo_ >> notify OK @@ -3289,10 +3287,10 @@ cleanupManager c@AgentClient {subQ} = do liftIO $ threadDelay' int where deleteExpiredServiceReqs = do - replyTimeout <- asks $ serviceReplyTimeout . config - expireTs <- addUTCTime (negate replyTimeout) <$> liftIO getCurrentTime - withStore' c $ \db -> deleteExpiredServiceRequests db expireTs - expiredConns <- withStore' c $ \db -> getExpiredServiceReplyConnIds db expireTs + AgentConfig {serviceRequestTimeout, serviceResponseTimeout} <- asks config + now <- liftIO getCurrentTime + withStore' c $ \db -> deleteExpiredServiceRequests db $ addUTCTime (negate serviceResponseTimeout) now + expiredConns <- withStore' c $ \db -> getExpiredServiceConns db $ addUTCTime (negate serviceRequestTimeout) now deleteConnectionsAsync' c False expiredConns run :: forall e. AEntityI e => (AgentErrorType -> AEvent e) -> AM () -> AM' () run err a = do @@ -3688,7 +3686,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar smpConfirmation srvMsgId conn' senderKey e2ePubKey e2eEncryption encConnInfo phVer agentVersion = do logServer "<--" c srv rId $ "MSG :" <> logSecret' srvMsgId checkConfVersions agentVersion phVer - let ConnData {pqSupport, serviceReply} = toConnData conn' + let ConnData {pqSupport, serviceRequest} = toConnData conn' case status of New -> case conn' of -- party initiating connection @@ -3710,9 +3708,9 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar AgentConnInfoReply smpQueues connInfo -> do processConf rc' connInfo SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = L.toList smpQueues, smpClientVersion = phVer} withStore' c $ \db -> updateRcvMsgHash db connId 1 (InternalRcvId 0) (C.sha256Hash agentMsgBody) - AgentServiceResponse payload | serviceReply -> dispatchServiceReply $ Right payload + AgentServiceResponse payload | serviceRequest -> dispatchServiceReply $ Right payload AgentRejection reason - | serviceReply -> dispatchServiceReply $ Left $ AGENT $ A_SERVICE $ ASERejected $ B.unpack reason + | serviceRequest -> dispatchServiceReply $ Left $ AGENT $ A_SERVICE $ ASERejected $ B.unpack reason | otherwise -> notify $ RJCT reason _ -> prohibited "conf: not AgentConnInfoReply" -- including AgentConnInfo, that is prohibited here in v2 Left _ -> prohibited "conf: decrypt error" @@ -3721,7 +3719,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar found <- atomically $ TM.lookup connId (serviceRequests c) >>= \case Just var -> tryPutTMVar var result Nothing -> pure False - unless found $ notify $ ERR $ AGENT $ A_SERVICE ASENoRequest + unless found $ notify $ ERR $ AGENT $ A_SERVICE ASENoPendingRequest processConf rc' connInfo senderConf = do let newConfirmation = NewConfirmation {connId, senderConf, ratchetState = rc'} g <- asks random @@ -3942,9 +3940,9 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar PQSupportOn `CR.pqSupportAnd` versionPQSupport_ agentVersion (Just v) storeInvitation :: ContactRequest -> ConnInfo -> Bool -> AM InvitationId - storeInvitation connReq recipientConnInfo isServiceRequest = do + storeInvitation connReq recipientConnInfo serviceRequest = do g <- asks random - let newInv = NewInvitation {contactConnId = connId, connReq, recipientConnInfo, isServiceRequest} + let newInv = NewInvitation {contactConnId = connId, connReq, recipientConnInfo, serviceRequest} withStore c $ \db -> createInvitation db g newInv smpContactRequest :: SMP.MsgId -> Connection c -> VersionSMPA -> CR.SndE2ERatchetParams 'C.X448 -> RatchetKeyId -> ByteString -> VersionSMPC -> AM () diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index 1de601d25..f81f42ab0 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -154,7 +154,7 @@ data AgentConfig = AgentConfig userOfflineDelay :: NominalDiffTime, messageTimeout :: NominalDiffTime, serviceRequestTimeout :: NominalDiffTime, - serviceReplyTimeout :: NominalDiffTime, + serviceResponseTimeout :: NominalDiffTime, connDeleteDeliveryTimeout :: NominalDiffTime, helloTimeout :: NominalDiffTime, quotaExceededTimeout :: NominalDiffTime, @@ -231,8 +231,8 @@ defaultAgentConfig = userNetworkInterval = 1800_000000, -- 30 minutes, should be less than Int32 max value userOfflineDelay = 2, -- if network offline event happens in less than 2 seconds after it was set online, it is ignored messageTimeout = 2 * nominalDay, - serviceRequestTimeout = 30, -- client wait for the response, seconds - serviceReplyTimeout = 180, -- service reply window + cleanup TTL, seconds (must exceed serviceRequestTimeout) + serviceRequestTimeout = 30, + serviceResponseTimeout = 180, connDeleteDeliveryTimeout = 2 * nominalDay, helloTimeout = 2 * nominalDay, quotaExceededTimeout = 7 * nominalDay, diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 27b75fd95..bbe1d1316 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -865,7 +865,7 @@ data AgentMsgEnvelope connReq :: ConnectionRequestUri 'CMInvitation, connInfo :: ByteString -- this message is only encrypted with per-queue E2E, not with double ratchet, } - | AgentContactRequest -- DR request to a contact address that advertised DR keys: a contact invitation or a service (RPC) request + | AgentContactRequest -- DR request to a contact address that published DR keys: a contact invitation or a service (RPC) request { agentVersion :: VersionSMPA, e2eSndParams :: SndE2ERatchetParams 'C.X448, ratchetKeyId :: RatchetKeyId, @@ -2198,17 +2198,13 @@ data SMPAgentError A_DUPLICATE {droppedMsg_ :: Maybe DroppedMsg} | -- | error in the message to add/delete/etc queue in connection A_QUEUE {queueErr :: String} - | -- | service (RPC) request error - A_SERVICE {serviceError :: AgentServiceError} + | A_SERVICE {serviceError :: AgentServiceError} deriving (Eq, Show, Exception) data AgentServiceError - = -- | the service refused the request, with the reason (bytes as latin1 String) - ASERejected {rejectReason :: String} - | -- | no response to the request within the configured timeout - ASETimeout - | -- | response with no pending request (e.g. after a restart) - ASENoRequest + = ASERejected {rejectReason :: String} + | ASETimeout + | ASENoPendingRequest deriving (Eq, Show) data AgentCryptoError diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index ca4960d04..babce1145 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -466,7 +466,7 @@ data ConnData = ConnData deleted :: Bool, ratchetSyncState :: RatchetSyncState, pqSupport :: PQSupport, - serviceReply :: Bool + serviceRequest :: Bool } deriving (Eq, Show) @@ -638,7 +638,7 @@ data NewInvitation = NewInvitation { contactConnId :: ConnId, connReq :: ContactRequest, recipientConnInfo :: ConnInfo, - isServiceRequest :: Bool + serviceRequest :: Bool } data Invitation = Invitation @@ -648,7 +648,7 @@ data Invitation = Invitation recipientConnInfo :: ConnInfo, ownConnInfo :: Maybe ConnInfo, accepted :: Bool, - isServiceRequest :: Bool, + serviceRequest :: Bool, createdAt :: UTCTime } diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs index c94465df2..7f4a86c42 100644 --- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -72,10 +72,10 @@ module Simplex.Messaging.Agent.Store.AgentStore setConnUserId, setConnAgentVersion, setConnPQSupport, - setConnServiceReply, + setConnServiceRequest, updateNewConnJoin, getDeletedConnIds, - getExpiredServiceReplyConnIds, + getExpiredServiceConns, deleteExpiredServiceRequests, getDeletedWaitingDeliveryConnIds, setConnRatchetSync, @@ -573,7 +573,8 @@ createConnRecord db connId ConnData {userId, connAgentVersion, enableNtfs, pqSup db [sql| INSERT INTO connections - (user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, pq_support, duplex_handshake) VALUES (?,?,?,?,?,?,?) + (user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, pq_support, duplex_handshake, created_at) + VALUES (?,?,?,?,?,?,?, CURRENT_TIMESTAMP) |] (userId, connId, cMode, connAgentVersion, BI enableNtfs, pqSupport, BI True) @@ -878,15 +879,15 @@ removeConfirmations db connId = (Only connId) createInvitation :: DB.Connection -> TVar ChaChaDRG -> NewInvitation -> IO (Either StoreError InvitationId) -createInvitation db gVar NewInvitation {contactConnId, connReq, recipientConnInfo, isServiceRequest} = +createInvitation db gVar NewInvitation {contactConnId, connReq, recipientConnInfo, serviceRequest} = createWithRandomId db gVar $ \invitationId -> DB.execute db [sql| INSERT INTO conn_invitations - (invitation_id, contact_conn_id, cr_invitation, recipient_conn_info, accepted, is_service_request) VALUES (?, ?, ?, ?, 0, ?); + (invitation_id, contact_conn_id, cr_invitation, recipient_conn_info, accepted, service_request) VALUES (?, ?, ?, ?, 0, ?); |] - (Binary invitationId, contactConnId, connReq, Binary recipientConnInfo, BI isServiceRequest) + (Binary invitationId, contactConnId, connReq, Binary recipientConnInfo, BI serviceRequest) getInvitation :: DB.Connection -> String -> InvitationId -> IO (Either StoreError Invitation) getInvitation db cxt invitationId = @@ -894,15 +895,15 @@ getInvitation db cxt invitationId = DB.query db [sql| - SELECT contact_conn_id, cr_invitation, recipient_conn_info, own_conn_info, accepted, is_service_request, created_at + SELECT contact_conn_id, cr_invitation, recipient_conn_info, own_conn_info, accepted, service_request, created_at FROM conn_invitations WHERE invitation_id = ? AND accepted = 0 |] (Only (Binary invitationId)) where - invitation (contactConnId_, connReq, recipientConnInfo, ownConnInfo, BI accepted, BI isServiceRequest, createdAt) = - Invitation {invitationId, contactConnId_, connReq, recipientConnInfo, ownConnInfo, accepted, isServiceRequest, createdAt} + invitation (contactConnId_, connReq, recipientConnInfo, ownConnInfo, BI accepted, BI serviceRequest, createdAt) = + Invitation {invitationId, contactConnId_, connReq, recipientConnInfo, ownConnInfo, accepted, serviceRequest, createdAt} acceptInvitation :: DB.Connection -> InvitationId -> ConnInfo -> IO () acceptInvitation db invitationId ownConnInfo = @@ -2666,8 +2667,7 @@ getConnData deleted' forUpdate db connId' = db ( [sql| SELECT user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, - last_external_snd_msg_id, deleted, ratchet_sync_state, pq_support, - CASE WHEN created_at IS NULL THEN 0 ELSE 1 END + last_external_snd_msg_id, deleted, ratchet_sync_state, pq_support, service_request FROM connections WHERE conn_id = ? AND deleted = ? |] @@ -2685,8 +2685,8 @@ lockConnForUpdate db connId = do pure () rowToConnData :: (UserId, ConnId, ConnectionMode, VersionSMPA, Maybe BoolInt, PrevExternalSndId, BoolInt, RatchetSyncState, PQSupport, BoolInt) -> (ConnData, ConnectionMode) -rowToConnData (userId, connId, cMode, connAgentVersion, enableNtfs_, lastExternalSndId, BI deleted, ratchetSyncState, pqSupport, BI serviceReply) = - (ConnData {userId, connId, connAgentVersion, enableNtfs = maybe True unBI enableNtfs_, lastExternalSndId, deleted, ratchetSyncState, pqSupport, serviceReply}, cMode) +rowToConnData (userId, connId, cMode, connAgentVersion, enableNtfs_, lastExternalSndId, BI deleted, ratchetSyncState, pqSupport, BI serviceRequest) = + (ConnData {userId, connId, connAgentVersion, enableNtfs = maybe True unBI enableNtfs_, lastExternalSndId, deleted, ratchetSyncState, pqSupport, serviceRequest}, cMode) setConnDeleted :: DB.Connection -> Bool -> ConnId -> IO () setConnDeleted db waitDelivery connId @@ -2708,9 +2708,9 @@ setConnPQSupport :: DB.Connection -> ConnId -> PQSupport -> IO () setConnPQSupport db connId pqSupport = DB.execute db "UPDATE connections SET pq_support = ? WHERE conn_id = ?" (pqSupport, connId) -setConnServiceReply :: DB.Connection -> ConnId -> UTCTime -> IO () -setConnServiceReply db connId ts = - DB.execute db "UPDATE connections SET created_at = ? WHERE conn_id = ?" (ts, connId) +setConnServiceRequest :: DB.Connection -> ConnId -> IO () +setConnServiceRequest db connId = + DB.execute db "UPDATE connections SET service_request = 1 WHERE conn_id = ?" (Only connId) updateNewConnJoin :: DB.Connection -> ConnId -> VersionSMPA -> PQSupport -> Bool -> IO () updateNewConnJoin db connId aVersion pqSupport enableNtfs = @@ -2719,15 +2719,13 @@ updateNewConnJoin db connId aVersion pqSupport enableNtfs = getDeletedConnIds :: DB.Connection -> IO [ConnId] getDeletedConnIds db = map fromOnly <$> DB.query db "SELECT conn_id FROM connections WHERE deleted = ?" (Only (BI True)) --- | Client RPC reply-queue connections older than the timeout that were never torn down (e.g. after a restart). -getExpiredServiceReplyConnIds :: DB.Connection -> UTCTime -> IO [ConnId] -getExpiredServiceReplyConnIds db expireTs = - map fromOnly <$> DB.query db "SELECT conn_id FROM connections WHERE created_at IS NOT NULL AND created_at < ? AND deleted = 0" (Only expireTs) +getExpiredServiceConns :: DB.Connection -> UTCTime -> IO [ConnId] +getExpiredServiceConns db expireTs = + map fromOnly <$> DB.query db "SELECT conn_id FROM connections WHERE service_request = 1 AND created_at < ? AND deleted = 0 AND deleted_at_wait_delivery IS NULL" (Only expireTs) --- | Service (RPC) requests that were never answered within the timeout. deleteExpiredServiceRequests :: DB.Connection -> UTCTime -> IO () deleteExpiredServiceRequests db expireTs = - DB.execute db "DELETE FROM conn_invitations WHERE is_service_request = 1 AND created_at < ?" (Only expireTs) + DB.execute db "DELETE FROM conn_invitations WHERE service_request = 1 AND created_at < ?" (Only expireTs) getDeletedWaitingDeliveryConnIds :: DB.Connection -> IO [ConnId] getDeletedWaitingDeliveryConnIds db = diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20260712_address_dr_rpc.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20260712_address_dr_rpc.hs index 33344cbc8..4e0e081f7 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20260712_address_dr_rpc.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20260712_address_dr_rpc.hs @@ -21,15 +21,17 @@ CREATE TABLE address_ratchet_keys( CREATE UNIQUE INDEX idx_address_ratchet_keys ON address_ratchet_keys(conn_id, ratchet_key_id); -ALTER TABLE conn_invitations ADD COLUMN is_service_request SMALLINT NOT NULL DEFAULT 0; -ALTER TABLE connections ADD COLUMN created_at TIMESTAMPTZ; +ALTER TABLE conn_invitations ADD COLUMN service_request SMALLINT NOT NULL DEFAULT 0; +ALTER TABLE connections ADD COLUMN created_at TIMESTAMPTZ NOT NULL DEFAULT '1970-01-01 00:00:00'; +ALTER TABLE connections ADD COLUMN service_request SMALLINT NOT NULL DEFAULT 0; |] down_m20260712_address_dr_rpc :: Text down_m20260712_address_dr_rpc = [r| +ALTER TABLE connections DROP COLUMN service_request; ALTER TABLE connections DROP COLUMN created_at; -ALTER TABLE conn_invitations DROP COLUMN is_service_request; +ALTER TABLE conn_invitations DROP COLUMN service_request; DROP INDEX idx_address_ratchet_keys; DROP TABLE address_ratchet_keys; |] diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20260712_address_dr_rpc.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20260712_address_dr_rpc.hs index 8587ca388..f44c68fd6 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20260712_address_dr_rpc.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20260712_address_dr_rpc.hs @@ -20,15 +20,17 @@ CREATE TABLE address_ratchet_keys( CREATE UNIQUE INDEX idx_address_ratchet_keys ON address_ratchet_keys(conn_id, ratchet_key_id); -ALTER TABLE conn_invitations ADD COLUMN is_service_request INTEGER NOT NULL DEFAULT 0; -ALTER TABLE connections ADD COLUMN created_at TEXT; +ALTER TABLE conn_invitations ADD COLUMN service_request INTEGER NOT NULL DEFAULT 0; +ALTER TABLE connections ADD COLUMN created_at TEXT NOT NULL DEFAULT('1970-01-01 00:00:00'); +ALTER TABLE connections ADD COLUMN service_request INTEGER NOT NULL DEFAULT 0; |] down_m20260712_address_dr_rpc :: Query down_m20260712_address_dr_rpc = [sql| +ALTER TABLE connections DROP COLUMN service_request; ALTER TABLE connections DROP COLUMN created_at; -ALTER TABLE conn_invitations DROP COLUMN is_service_request; +ALTER TABLE conn_invitations DROP COLUMN service_request; DROP INDEX idx_address_ratchet_keys; DROP TABLE address_ratchet_keys; |] diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql index 0679e490f..08fb28035 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql @@ -28,7 +28,8 @@ CREATE TABLE connections( ratchet_sync_state TEXT NOT NULL DEFAULT 'ok', deleted_at_wait_delivery TEXT, pq_support INTEGER NOT NULL DEFAULT 0, - created_at TEXT + created_at TEXT NOT NULL DEFAULT('1970-01-01 00:00:00'), + service_request INTEGER NOT NULL DEFAULT 0 ) WITHOUT ROWID, STRICT; CREATE TABLE rcv_queues( host TEXT NOT NULL, @@ -166,7 +167,7 @@ CREATE TABLE conn_invitations( own_conn_info BLOB, created_at TEXT NOT NULL DEFAULT(datetime('now')) , - is_service_request INTEGER NOT NULL DEFAULT 0 + service_request INTEGER NOT NULL DEFAULT 0 ) WITHOUT ROWID, STRICT; CREATE TABLE ratchets( conn_id BLOB NOT NULL PRIMARY KEY REFERENCES connections diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 71e2e4952..6f3324236 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -199,7 +199,7 @@ cData1 = deleted = False, ratchetSyncState = RSOk, pqSupport = CR.PQSupportOn, - serviceReply = False + serviceRequest = False } testPrivateAuthKey :: C.APrivateAuthKey From c7a69681aae136ba4f222a3c248428333d615328 Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Tue, 21 Jul 2026 20:50:30 +0000 Subject: [PATCH 05/15] clean up --- src/Simplex/Messaging/Agent.hs | 81 ++++++++++--------- src/Simplex/Messaging/Agent/Protocol.hs | 5 +- src/Simplex/Messaging/Agent/Store.hs | 2 +- .../Messaging/Agent/Store/AgentStore.hs | 16 ++-- .../Migrations/M20260712_address_dr_rpc.hs | 4 +- .../Migrations/M20260712_address_dr_rpc.hs | 4 +- .../Store/SQLite/Migrations/agent_schema.sql | 2 +- tests/AgentTests/SQLiteTests.hs | 2 +- 8 files changed, 62 insertions(+), 54 deletions(-) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index da29ee013..352da1e06 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -507,35 +507,35 @@ acceptContact c userId connId enableNtfs = withAgentEnv c .::. acceptContact' c -- | Reject contact (RJCT command) rejectContact :: AgentClient -> NetworkRequestMode -> UserId -> ConfirmationId -> Maybe ByteString -> AE () -rejectContact c nm userId invId reason = withAgentEnv c $ rejectContact' c nm userId invId reason +rejectContact c = withAgentEnv c .:: rejectContact' c {-# INLINE rejectContact #-} rejectContactAsync :: AgentClient -> ACorrId -> UserId -> ConfirmationId -> Maybe ByteString -> AE () -rejectContactAsync c corrId userId invId reason = withAgentEnv c $ rejectContactAsync' c corrId userId invId reason +rejectContactAsync c = withAgentEnv c .:: rejectContactAsync' c {-# INLINE rejectContactAsync #-} sendServiceReply :: AgentClient -> NetworkRequestMode -> UserId -> InvitationId -> MsgBody -> AE () -sendServiceReply c nm userId invId payload = withAgentEnv c $ sendServiceReply' c nm userId invId payload +sendServiceReply c = withAgentEnv c .:: sendServiceReply' c {-# INLINE sendServiceReply #-} sendServiceReplyAsync :: AgentClient -> ACorrId -> UserId -> InvitationId -> MsgBody -> AE () -sendServiceReplyAsync c corrId userId invId payload = withAgentEnv c $ sendServiceReplyAsync' c corrId userId invId payload +sendServiceReplyAsync c = withAgentEnv c .:: sendServiceReplyAsync' c {-# INLINE sendServiceReplyAsync #-} rejectServiceRequest :: AgentClient -> NetworkRequestMode -> UserId -> InvitationId -> Maybe ByteString -> AE () -rejectServiceRequest c nm userId invId reason = withAgentEnv c $ rejectServiceRequest' c nm userId invId reason +rejectServiceRequest c = withAgentEnv c .:: rejectServiceRequest' c {-# INLINE rejectServiceRequest #-} rejectServiceRequestAsync :: AgentClient -> ACorrId -> UserId -> InvitationId -> Maybe ByteString -> AE () -rejectServiceRequestAsync c corrId userId invId reason = withAgentEnv c $ rejectServiceRequestAsync' c corrId userId invId reason +rejectServiceRequestAsync c = withAgentEnv c .:: rejectServiceRequestAsync' c {-# INLINE rejectServiceRequestAsync #-} sendServiceRequest :: AgentClient -> NetworkRequestMode -> UserId -> ConnectionRequestUri 'CMContact -> MsgBody -> AE MsgBody -sendServiceRequest c nm userId cReqUri payload = withAgentEnv c $ sendServiceRequest' c nm userId cReqUri payload +sendServiceRequest c = withAgentEnv c .:: sendServiceRequest' c {-# INLINE sendServiceRequest #-} sendServiceRequestAsync :: AgentClient -> UserId -> ConnectionRequestUri 'CMContact -> MsgBody -> AE MsgBody -sendServiceRequestAsync c userId cReqUri payload = withAgentEnv c $ sendServiceRequestAsync' c userId cReqUri payload +sendServiceRequestAsync c = withAgentEnv c .:. sendServiceRequestAsync' c {-# INLINE sendServiceRequestAsync #-} data DatabaseDiff a = DatabaseDiff @@ -896,7 +896,7 @@ newConnNoQueues :: AgentClient -> UserId -> Bool -> SConnectionMode c -> PQSuppo newConnNoQueues c userId enableNtfs cMode pqSupport = do g <- asks random connAgentVersion <- asks $ maxVersion . smpAgentVRange . config - let cData = ConnData {userId, connId = "", connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceRequest = False} + let cData = ConnData {userId, connId = "", connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceResponse = False} withStore c $ \db -> createNewConn db g cData cMode -- TODO [short links] TBC, but probably we will need async join for contact addresses as the contact will be created after user confirming the connection, @@ -1147,7 +1147,7 @@ getConnShortLinkAsync' c userId corrId connId_ shortLink@(CSLContact _ _ srv _) deleted = False, ratchetSyncState = RSOk, pqSupport = PQSupportOff, - serviceRequest = False + serviceResponse = False } createNewConn db g cData SCMInvitation @@ -1384,7 +1384,7 @@ newConnToJoin c userId connId enableNtfs cReq pqSup = case cReq of create (Compatible connAgentVersion) e2eV_ = do g <- asks random let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ connAgentVersion e2eV_ - cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceRequest = False} + cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceResponse = False} withStore c $ \db -> createNewConn db g cData SCMInvitation newConnToAccept :: AgentClient -> UserId -> ConnId -> Bool -> ConfirmationId -> PQSupport -> AM ConnId @@ -1394,7 +1394,7 @@ newConnToAccept c userId connId enableNtfs invId pqSup = do CRInvitation cReq -> newConnToJoin c userId connId enableNtfs cReq pqSup CRInvitationDR DRInvitation {agentVersion, pqSupport} -> do g <- asks random - let cData = ConnData {userId, connId, connAgentVersion = agentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceRequest = False} + let cData = ConnData {userId, connId, connAgentVersion = agentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceResponse = False} withStore c $ \db -> createNewConn db g cData SCMInvitation joinConn :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM SndQueueSecured @@ -1414,7 +1414,7 @@ startJoinInvitation c userId connId sq_ enableNtfs cReqUri pqSup = let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ connAgentVersion (Just v) g <- asks random maxSupported <- asks $ maxVersion . e2eEncryptVRange . config - let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceRequest = False} + let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceResponse = False} case sq_ of Just sq@SndQueue {e2ePubKey = Just _k} -> do e2eSndParams <- withStore c $ \db -> do @@ -1704,25 +1704,25 @@ prepareReply c userId invId expectedServiceRequest innerMsg = do | otherwise = "rejectContact: service request, use rejectServiceRequest" sendServiceRequest' :: AgentClient -> NetworkRequestMode -> UserId -> ConnectionRequestUri 'CMContact -> MsgBody -> AM MsgBody -sendServiceRequest' c nm userId cReqUri payload = - serviceRequest_ c userId cReqUri $ \connId srv -> +sendServiceRequest' c nm userId cReqUri@(CRContactUri crData _) payload = + serviceRequest_ c userId cReqUri $ \connId -> do + srv <- getNextSMPServer c userId [qServer $ L.head $ crSmpQueues crData] void $ joinConnSrv' c nm userId connId False cReqUri payload PQSupportOn SMSubscribe srv $ \replyQInfo -> AgentServiceRequest (replyQInfo :| []) payload sendServiceRequestAsync' :: AgentClient -> UserId -> ConnectionRequestUri 'CMContact -> MsgBody -> AM MsgBody sendServiceRequestAsync' c userId cReqUri payload = - serviceRequest_ c userId cReqUri $ \connId _srv -> - enqueueCommand c "" connId Nothing $ AClientCommand $ JOIN (JRConnReq False (ACR SCMContact cReqUri) PQSupportOn) SMSubscribe payload + serviceRequest_ c userId cReqUri $ \connId -> + enqueueCommand c "" connId Nothing $ AClientCommand $ JOIN (JRServiceRequest (ACR SCMContact cReqUri) PQSupportOn) SMSubscribe payload -serviceRequest_ :: AgentClient -> UserId -> ConnectionRequestUri 'CMContact -> (ConnId -> SMPServerWithAuth -> AM ()) -> AM MsgBody -serviceRequest_ c userId cReqUri@(CRContactUri crData _) doSend = do +serviceRequest_ :: AgentClient -> UserId -> ConnectionRequestUri 'CMContact -> (ConnId -> AM ()) -> AM MsgBody +serviceRequest_ c userId cReqUri doSend = do connId <- newConnToJoin c userId "" False cReqUri PQSupportOn - withStore' c $ \db -> setConnServiceRequest db connId + withStore' c $ \db -> setConnServiceResponse db connId var <- atomically newEmptyTMVar atomically $ TM.insert connId var (serviceRequests c) - srv <- getNextSMPServer c userId [qServer $ L.head $ crSmpQueues crData] reqTimeout <- asks $ serviceRequestTimeout . config r <- tryError $ do - doSend connId srv + doSend connId liftIO $ do expired <- registerDelay $ round (reqTimeout * 1000000) atomically $ takeTMVar var `orElse` (readTVar expired >>= \e -> if e then pure (Left $ AGENT $ A_SERVICE ASETimeout) else retry) @@ -2148,18 +2148,20 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do -- Currently joinConnSrv is used because even joinConnSrvAsync for invitation URIs creates receive queue synchronously. JOIN (JRConnReq enableNtfs (ACR _ cReq@(CRContactUri ConnReqUriData {crSmpQueues = q :| _} _)) pqEnc) subMode connInfo -> noServer $ do triedHosts <- newTVarIO S.empty - tryCommand . withNextSrv c userId storageSrvs triedHosts [qServer q] $ \srv -> do - SomeConn _ conn <- withStore c (`getConn` connId) - let ConnData {serviceRequest} = toConnData conn - if serviceRequest - then atomically (TM.lookup connId (serviceRequests c)) >>= \case - Nothing -> pure () -- the caller timed out and removed the waiter, stop retrying the send - Just var -> tryError (void $ joinConnSrv' c NRMBackground userId connId enableNtfs cReq connInfo pqEnc subMode srv $ \replyQInfo -> AgentServiceRequest (replyQInfo :| []) connInfo) >>= \case + tryCommand . withNextSrv c userId storageSrvs triedHosts [qServer q] $ \srv -> + joinConnSrv c NRMBackground userId connId enableNtfs cReq connInfo pqEnc subMode srv >>= notify . JOINED + JOIN (JRServiceRequest (ACR _ cReq@(CRContactUri ConnReqUriData {crSmpQueues = q :| _} _)) pqEnc) subMode connInfo -> noServer $ do + triedHosts <- newTVarIO S.empty + tryCommand . withNextSrv c userId storageSrvs triedHosts [qServer q] $ \srv -> + atomically (TM.lookup connId (serviceRequests c)) >>= \case + Nothing -> pure () + Just var -> + tryError (void $ joinConnSrv' c NRMBackground userId connId False cReq connInfo pqEnc subMode srv $ \replyQInfo -> AgentServiceRequest (replyQInfo :| []) connInfo) >>= \case Right () -> pure () - Left e -> do - unless (temporaryOrHostError e) $ atomically $ void $ tryPutTMVar var $ Left e - throwE e - else joinConnSrv c NRMBackground userId connId enableNtfs cReq connInfo pqEnc subMode srv >>= notify . JOINED + Left e + | temporaryOrHostError e -> throwE e + | otherwise -> atomically $ void $ tryPutTMVar var $ Left e + JOIN (JRServiceRequest (ACR _ (CRInvitationUri _ _)) _) _ _ -> internalErr "JOIN: service request requires contact address" LET confId ownCInfo -> withServer' . tryCommand $ allowConnection' c connId confId ownCInfo >> notify OK ACK msgId rcptInfo_ -> withServer' . tryCommand $ ackMessage' c connId msgId rcptInfo_ >> notify OK SWCH -> @@ -2430,7 +2432,7 @@ submitPendingMsg c sq = do runSmpQueueMsgDelivery :: AgentClient -> SndQueue -> (Worker, TMVar ()) -> AM () runSmpQueueMsgDelivery c@AgentClient {subQ} sq@SndQueue {userId, connId, server, queueMode} (Worker {doWork}, qLock) = do - AgentConfig {messageRetryInterval = ri, messageTimeout, helloTimeout, quotaExceededTimeout} <- asks config + AgentConfig {messageRetryInterval = ri, messageTimeout, serviceResponseTimeout, helloTimeout, quotaExceededTimeout} <- asks config forever $ do atomically $ endAgentOperation c AOSndNetwork lift $ waitForWork doWork @@ -2503,7 +2505,10 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} sq@SndQueue {userId, connId, server, -- for other operations BROKER HOST is treated as a permanent error (e.g., when connecting to the server), -- the message sending would be retried | temporaryOrHostError e -> do - let msgTimeout = if msgType == AM_HELLO_ then helloTimeout else messageTimeout + let msgTimeout = case msgType of + AM_HELLO_ -> helloTimeout + AM_SRV_RESP -> serviceResponseTimeout + _ -> messageTimeout expireTs <- addUTCTime (-msgTimeout) <$> liftIO getCurrentTime if internalTs < expireTs then notifyDelMsgs msgId e expireTs @@ -3686,7 +3691,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar smpConfirmation srvMsgId conn' senderKey e2ePubKey e2eEncryption encConnInfo phVer agentVersion = do logServer "<--" c srv rId $ "MSG :" <> logSecret' srvMsgId checkConfVersions agentVersion phVer - let ConnData {pqSupport, serviceRequest} = toConnData conn' + let ConnData {pqSupport, serviceResponse} = toConnData conn' case status of New -> case conn' of -- party initiating connection @@ -3708,9 +3713,9 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar AgentConnInfoReply smpQueues connInfo -> do processConf rc' connInfo SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = L.toList smpQueues, smpClientVersion = phVer} withStore' c $ \db -> updateRcvMsgHash db connId 1 (InternalRcvId 0) (C.sha256Hash agentMsgBody) - AgentServiceResponse payload | serviceRequest -> dispatchServiceReply $ Right payload + AgentServiceResponse payload | serviceResponse -> dispatchServiceReply $ Right payload AgentRejection reason - | serviceRequest -> dispatchServiceReply $ Left $ AGENT $ A_SERVICE $ ASERejected $ B.unpack reason + | serviceResponse -> dispatchServiceReply $ Left $ AGENT $ A_SERVICE $ ASERejected $ B.unpack reason | otherwise -> notify $ RJCT reason _ -> prohibited "conf: not AgentConnInfoReply" -- including AgentConnInfo, that is prohibited here in v2 Left _ -> prohibited "conf: decrypt error" diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index bbe1d1316..67d47e473 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -1889,6 +1889,7 @@ data DRInvitation = DRInvitation data JoinRequest = JRConnReq {enableNtfs :: Bool, joinConnReq :: AConnectionRequestUri, joinPQSupport :: PQSupport} | JRInvitationDR DRInvitation + | JRServiceRequest {joinConnReq :: AConnectionRequestUri, joinPQSupport :: PQSupport} deriving (Show) data UserContactData = UserContactData @@ -2238,8 +2239,10 @@ instance StrEncoding JoinRequest where strEncode = \case JRConnReq ntfs cReq pqSup -> strEncode (ntfs, cReq, pqSup) JRInvitationDR dr -> serializeBinary $ LB.toStrict (J'.encode dr) + JRServiceRequest cReq pqSup -> "S " <> strEncode (cReq, pqSup) strP = - (JRConnReq <$> strP <*> _strP <*> (_strP <|> pure PQSupportOff)) + ("S " *> (JRServiceRequest <$> strP <*> (_strP <|> pure PQSupportOff))) + <|> (JRConnReq <$> strP <*> _strP <*> (_strP <|> pure PQSupportOff)) <|> (JRInvitationDR <$> (J'.eitherDecodeStrict' <$?> (A.take =<< (A.decimal <* "\n")))) -- | SMP agent command and response parser for commands stored in db (fully parses binary bodies) diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index babce1145..d76f50b45 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -466,7 +466,7 @@ data ConnData = ConnData deleted :: Bool, ratchetSyncState :: RatchetSyncState, pqSupport :: PQSupport, - serviceRequest :: Bool + serviceResponse :: Bool } deriving (Eq, Show) diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs index 7f4a86c42..2f8667bde 100644 --- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -72,7 +72,7 @@ module Simplex.Messaging.Agent.Store.AgentStore setConnUserId, setConnAgentVersion, setConnPQSupport, - setConnServiceRequest, + setConnServiceResponse, updateNewConnJoin, getDeletedConnIds, getExpiredServiceConns, @@ -2667,7 +2667,7 @@ getConnData deleted' forUpdate db connId' = db ( [sql| SELECT user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, - last_external_snd_msg_id, deleted, ratchet_sync_state, pq_support, service_request + last_external_snd_msg_id, deleted, ratchet_sync_state, pq_support, service_response FROM connections WHERE conn_id = ? AND deleted = ? |] @@ -2685,8 +2685,8 @@ lockConnForUpdate db connId = do pure () rowToConnData :: (UserId, ConnId, ConnectionMode, VersionSMPA, Maybe BoolInt, PrevExternalSndId, BoolInt, RatchetSyncState, PQSupport, BoolInt) -> (ConnData, ConnectionMode) -rowToConnData (userId, connId, cMode, connAgentVersion, enableNtfs_, lastExternalSndId, BI deleted, ratchetSyncState, pqSupport, BI serviceRequest) = - (ConnData {userId, connId, connAgentVersion, enableNtfs = maybe True unBI enableNtfs_, lastExternalSndId, deleted, ratchetSyncState, pqSupport, serviceRequest}, cMode) +rowToConnData (userId, connId, cMode, connAgentVersion, enableNtfs_, lastExternalSndId, BI deleted, ratchetSyncState, pqSupport, BI serviceResponse) = + (ConnData {userId, connId, connAgentVersion, enableNtfs = maybe True unBI enableNtfs_, lastExternalSndId, deleted, ratchetSyncState, pqSupport, serviceResponse}, cMode) setConnDeleted :: DB.Connection -> Bool -> ConnId -> IO () setConnDeleted db waitDelivery connId @@ -2708,9 +2708,9 @@ setConnPQSupport :: DB.Connection -> ConnId -> PQSupport -> IO () setConnPQSupport db connId pqSupport = DB.execute db "UPDATE connections SET pq_support = ? WHERE conn_id = ?" (pqSupport, connId) -setConnServiceRequest :: DB.Connection -> ConnId -> IO () -setConnServiceRequest db connId = - DB.execute db "UPDATE connections SET service_request = 1 WHERE conn_id = ?" (Only connId) +setConnServiceResponse :: DB.Connection -> ConnId -> IO () +setConnServiceResponse db connId = + DB.execute db "UPDATE connections SET service_response = 1 WHERE conn_id = ?" (Only connId) updateNewConnJoin :: DB.Connection -> ConnId -> VersionSMPA -> PQSupport -> Bool -> IO () updateNewConnJoin db connId aVersion pqSupport enableNtfs = @@ -2721,7 +2721,7 @@ getDeletedConnIds db = map fromOnly <$> DB.query db "SELECT conn_id FROM connect getExpiredServiceConns :: DB.Connection -> UTCTime -> IO [ConnId] getExpiredServiceConns db expireTs = - map fromOnly <$> DB.query db "SELECT conn_id FROM connections WHERE service_request = 1 AND created_at < ? AND deleted = 0 AND deleted_at_wait_delivery IS NULL" (Only expireTs) + map fromOnly <$> DB.query db "SELECT conn_id FROM connections WHERE service_response = 1 AND created_at < ? AND deleted = 0 AND deleted_at_wait_delivery IS NULL" (Only expireTs) deleteExpiredServiceRequests :: DB.Connection -> UTCTime -> IO () deleteExpiredServiceRequests db expireTs = diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20260712_address_dr_rpc.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20260712_address_dr_rpc.hs index 4e0e081f7..1d2126f3b 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20260712_address_dr_rpc.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20260712_address_dr_rpc.hs @@ -23,13 +23,13 @@ CREATE UNIQUE INDEX idx_address_ratchet_keys ON address_ratchet_keys(conn_id, ra ALTER TABLE conn_invitations ADD COLUMN service_request SMALLINT NOT NULL DEFAULT 0; ALTER TABLE connections ADD COLUMN created_at TIMESTAMPTZ NOT NULL DEFAULT '1970-01-01 00:00:00'; -ALTER TABLE connections ADD COLUMN service_request SMALLINT NOT NULL DEFAULT 0; +ALTER TABLE connections ADD COLUMN service_response SMALLINT NOT NULL DEFAULT 0; |] down_m20260712_address_dr_rpc :: Text down_m20260712_address_dr_rpc = [r| -ALTER TABLE connections DROP COLUMN service_request; +ALTER TABLE connections DROP COLUMN service_response; ALTER TABLE connections DROP COLUMN created_at; ALTER TABLE conn_invitations DROP COLUMN service_request; DROP INDEX idx_address_ratchet_keys; diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20260712_address_dr_rpc.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20260712_address_dr_rpc.hs index f44c68fd6..06e9a9b78 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20260712_address_dr_rpc.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20260712_address_dr_rpc.hs @@ -22,13 +22,13 @@ CREATE UNIQUE INDEX idx_address_ratchet_keys ON address_ratchet_keys(conn_id, ra ALTER TABLE conn_invitations ADD COLUMN service_request INTEGER NOT NULL DEFAULT 0; ALTER TABLE connections ADD COLUMN created_at TEXT NOT NULL DEFAULT('1970-01-01 00:00:00'); -ALTER TABLE connections ADD COLUMN service_request INTEGER NOT NULL DEFAULT 0; +ALTER TABLE connections ADD COLUMN service_response INTEGER NOT NULL DEFAULT 0; |] down_m20260712_address_dr_rpc :: Query down_m20260712_address_dr_rpc = [sql| -ALTER TABLE connections DROP COLUMN service_request; +ALTER TABLE connections DROP COLUMN service_response; ALTER TABLE connections DROP COLUMN created_at; ALTER TABLE conn_invitations DROP COLUMN service_request; DROP INDEX idx_address_ratchet_keys; diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql index 08fb28035..4479f5cb6 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql @@ -29,7 +29,7 @@ CREATE TABLE connections( deleted_at_wait_delivery TEXT, pq_support INTEGER NOT NULL DEFAULT 0, created_at TEXT NOT NULL DEFAULT('1970-01-01 00:00:00'), - service_request INTEGER NOT NULL DEFAULT 0 + service_response INTEGER NOT NULL DEFAULT 0 ) WITHOUT ROWID, STRICT; CREATE TABLE rcv_queues( host TEXT NOT NULL, diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index 6f3324236..aca0cf879 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -199,7 +199,7 @@ cData1 = deleted = False, ratchetSyncState = RSOk, pqSupport = CR.PQSupportOn, - serviceRequest = False + serviceResponse = False } testPrivateAuthKey :: C.APrivateAuthKey From 0c03e3b41dcabef847d6934a33bece8352c54d83 Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Tue, 21 Jul 2026 21:29:06 +0000 Subject: [PATCH 06/15] fix --- src/Simplex/Messaging/Agent.hs | 8 +++----- src/Simplex/Messaging/Agent/Protocol.hs | 1 + 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 352da1e06..a2d81c908 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -1715,7 +1715,8 @@ sendServiceRequestAsync' c userId cReqUri payload = enqueueCommand c "" connId Nothing $ AClientCommand $ JOIN (JRServiceRequest (ACR SCMContact cReqUri) PQSupportOn) SMSubscribe payload serviceRequest_ :: AgentClient -> UserId -> ConnectionRequestUri 'CMContact -> (ConnId -> AM ()) -> AM MsgBody -serviceRequest_ c userId cReqUri doSend = do +serviceRequest_ c userId cReqUri@(CRContactUri _ addrKeys_) doSend = do + when (isNothing addrKeys_) $ throwE $ AGENT $ A_SERVICE ASENotDRAddress connId <- newConnToJoin c userId "" False cReqUri PQSupportOn withStore' c $ \db -> setConnServiceResponse db connId var <- atomically newEmptyTMVar @@ -2206,10 +2207,7 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do void $ enqueueMessage c cData sq SMP.MsgFlags {notification = True} HELLO ICReplyDel -> withServer' . tryWithLock "ICReplyDel" $ withStore c (`getConn` connId) >>= \case - SomeConn _ (SndConnection cData sq) -> do - void $ agentSecureSndQueue c NRMBackground cData sq - lift $ submitPendingMsg c sq - deleteConnectionAsync' c True connId + SomeConn _ (SndConnection cData sq) -> sendReplySync c NRMBackground (connId, cData, sq) _ -> throwE $ INTERNAL "ICReplyDel: incorrect connection type" -- ICDeleteConn is no longer used, but it can be present in old client databases ICDeleteConn -> withStore' c (`deleteCommand` cmdId) diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 67d47e473..0e056125c 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -2206,6 +2206,7 @@ data AgentServiceError = ASERejected {rejectReason :: String} | ASETimeout | ASENoPendingRequest + | ASENotDRAddress deriving (Eq, Show) data AgentCryptoError From 8e6c29afed0cb06ca105d1b72de13b7cf0a192f1 Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Tue, 21 Jul 2026 21:45:53 +0000 Subject: [PATCH 07/15] fix query --- src/Simplex/Messaging/Agent/Store/AgentStore.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs index 2f8667bde..d07ac397a 100644 --- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -568,15 +568,16 @@ createSndConn db gVar cData q@SndQueue {server} = insertSndQueue_ db connId q serverKeyHash_ createConnRecord :: DB.Connection -> ConnId -> ConnData -> SConnectionMode c -> IO () -createConnRecord db connId ConnData {userId, connAgentVersion, enableNtfs, pqSupport} cMode = +createConnRecord db connId ConnData {userId, connAgentVersion, enableNtfs, pqSupport} cMode = do + createdAt <- getCurrentTime DB.execute db [sql| INSERT INTO connections (user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, pq_support, duplex_handshake, created_at) - VALUES (?,?,?,?,?,?,?, CURRENT_TIMESTAMP) + VALUES (?,?,?,?,?,?,?,?) |] - (userId, connId, cMode, connAgentVersion, BI enableNtfs, pqSupport, BI True) + (userId, connId, cMode, connAgentVersion, BI enableNtfs, pqSupport, BI True, createdAt) deleteConnRecord :: DB.Connection -> ConnId -> IO () deleteConnRecord db connId = DB.execute db "DELETE FROM connections WHERE conn_id = ?" (Only connId) @@ -2629,7 +2630,7 @@ getConnsData_ deleted' db connIds = db [sql| SELECT user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, - last_external_snd_msg_id, deleted, ratchet_sync_state, pq_support + last_external_snd_msg_id, deleted, ratchet_sync_state, pq_support, service_response FROM connections WHERE conn_id IN ? AND deleted = ? |] From c9f81006b1e2074a70e44df5e7e34b929a4c606d Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Wed, 22 Jul 2026 06:36:12 +0000 Subject: [PATCH 08/15] set flag at creation --- src/Simplex/Messaging/Agent.hs | 13 ++++++------- src/Simplex/Messaging/Agent/Store/AgentStore.hs | 13 ++++--------- 2 files changed, 10 insertions(+), 16 deletions(-) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index a2d81c908..f45b10b2e 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -482,7 +482,7 @@ changeConnectionUser c oldUserId connId newUserId = withAgentEnv c $ changeConne -- Instead of it we could send confirmation asynchronously, but then it would be harder to report -- "link deleted" (SMP AUTH) interactively, so this approach is simpler overall. prepareConnectionToJoin :: AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> PQSupport -> AE ConnId -prepareConnectionToJoin c userId enableNtfs = withAgentEnv c .: newConnToJoin c userId "" enableNtfs +prepareConnectionToJoin c userId enableNtfs = withAgentEnv c .: newConnToJoin c userId "" enableNtfs False {-# INLINE prepareConnectionToJoin #-} -- | Create SMP agent connection without queue (to be joined with acceptContact passing invitation ID). @@ -1369,8 +1369,8 @@ newQueueNtfSubscription c RcvQueue {userId, connId, server, clientNtfCreds} ntfS ns <- asks ntfSupervisor liftIO $ sendNtfSubCommand ns (NSCCreate, [connId]) -newConnToJoin :: forall c. AgentClient -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> PQSupport -> AM ConnId -newConnToJoin c userId connId enableNtfs cReq pqSup = case cReq of +newConnToJoin :: forall c. AgentClient -> UserId -> ConnId -> Bool -> Bool -> ConnectionRequestUri c -> PQSupport -> AM ConnId +newConnToJoin c userId connId enableNtfs serviceResponse cReq pqSup = case cReq of CRInvitationUri {} -> lift (compatibleInvitationUri cReq) >>= \case Just (_, Compatible (CR.E2ERatchetParams v _ _ _), aVersion) -> create aVersion (Just v) @@ -1384,14 +1384,14 @@ newConnToJoin c userId connId enableNtfs cReq pqSup = case cReq of create (Compatible connAgentVersion) e2eV_ = do g <- asks random let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ connAgentVersion e2eV_ - cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceResponse = False} + cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceResponse} withStore c $ \db -> createNewConn db g cData SCMInvitation newConnToAccept :: AgentClient -> UserId -> ConnId -> Bool -> ConfirmationId -> PQSupport -> AM ConnId newConnToAccept c userId connId enableNtfs invId pqSup = do Invitation {connReq} <- withStore c $ \db -> getInvitation db "newConnToAccept" invId case connReq of - CRInvitation cReq -> newConnToJoin c userId connId enableNtfs cReq pqSup + CRInvitation cReq -> newConnToJoin c userId connId enableNtfs False cReq pqSup CRInvitationDR DRInvitation {agentVersion, pqSupport} -> do g <- asks random let cData = ConnData {userId, connId, connAgentVersion = agentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceResponse = False} @@ -1717,8 +1717,7 @@ sendServiceRequestAsync' c userId cReqUri payload = serviceRequest_ :: AgentClient -> UserId -> ConnectionRequestUri 'CMContact -> (ConnId -> AM ()) -> AM MsgBody serviceRequest_ c userId cReqUri@(CRContactUri _ addrKeys_) doSend = do when (isNothing addrKeys_) $ throwE $ AGENT $ A_SERVICE ASENotDRAddress - connId <- newConnToJoin c userId "" False cReqUri PQSupportOn - withStore' c $ \db -> setConnServiceResponse db connId + connId <- newConnToJoin c userId "" False True cReqUri PQSupportOn var <- atomically newEmptyTMVar atomically $ TM.insert connId var (serviceRequests c) reqTimeout <- asks $ serviceRequestTimeout . config diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs index d07ac397a..12bc5d5e9 100644 --- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -72,7 +72,6 @@ module Simplex.Messaging.Agent.Store.AgentStore setConnUserId, setConnAgentVersion, setConnPQSupport, - setConnServiceResponse, updateNewConnJoin, getDeletedConnIds, getExpiredServiceConns, @@ -568,16 +567,16 @@ createSndConn db gVar cData q@SndQueue {server} = insertSndQueue_ db connId q serverKeyHash_ createConnRecord :: DB.Connection -> ConnId -> ConnData -> SConnectionMode c -> IO () -createConnRecord db connId ConnData {userId, connAgentVersion, enableNtfs, pqSupport} cMode = do +createConnRecord db connId ConnData {userId, connAgentVersion, enableNtfs, pqSupport, serviceResponse} cMode = do createdAt <- getCurrentTime DB.execute db [sql| INSERT INTO connections - (user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, pq_support, duplex_handshake, created_at) - VALUES (?,?,?,?,?,?,?,?) + (user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, pq_support, service_response, duplex_handshake, created_at) + VALUES (?,?,?,?,?,?,?,?,?) |] - (userId, connId, cMode, connAgentVersion, BI enableNtfs, pqSupport, BI True, createdAt) + (userId, connId, cMode, connAgentVersion, BI enableNtfs, pqSupport, BI serviceResponse, BI True, createdAt) deleteConnRecord :: DB.Connection -> ConnId -> IO () deleteConnRecord db connId = DB.execute db "DELETE FROM connections WHERE conn_id = ?" (Only connId) @@ -2709,10 +2708,6 @@ setConnPQSupport :: DB.Connection -> ConnId -> PQSupport -> IO () setConnPQSupport db connId pqSupport = DB.execute db "UPDATE connections SET pq_support = ? WHERE conn_id = ?" (pqSupport, connId) -setConnServiceResponse :: DB.Connection -> ConnId -> IO () -setConnServiceResponse db connId = - DB.execute db "UPDATE connections SET service_response = 1 WHERE conn_id = ?" (Only connId) - updateNewConnJoin :: DB.Connection -> ConnId -> VersionSMPA -> PQSupport -> Bool -> IO () updateNewConnJoin db connId aVersion pqSupport enableNtfs = DB.execute db "UPDATE connections SET smp_agent_version = ?, pq_support = ?, enable_ntfs = ? WHERE conn_id = ?" (aVersion, pqSupport, BI enableNtfs, connId) From d2eeb0caa3acee09ae3c61fff703e5e403dec16f Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Wed, 22 Jul 2026 07:43:56 +0100 Subject: [PATCH 09/15] move --- src/Simplex/Messaging/Agent/Client.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 959bb114c..dab866a57 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -384,11 +384,11 @@ data AgentClient = AgentClient clientId :: Int, agentEnv :: Env, proxySessTs :: TVar UTCTime, + serviceRequests :: TMap ConnId (TMVar (Either AgentErrorType SMP.MsgBody)), smpServersStats :: TMap (UserId, SMPServer) AgentSMPServerStats, xftpServersStats :: TMap (UserId, XFTPServer) AgentXFTPServerStats, ntfServersStats :: TMap (UserId, NtfServer) AgentNtfServerStats, - srvStatsStartedAt :: TVar UTCTime, - serviceRequests :: TMap ConnId (TMVar (Either AgentErrorType SMP.MsgBody)) + srvStatsStartedAt :: TVar UTCTime } data SMPConnectedClient = SMPConnectedClient @@ -548,11 +548,11 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg, useServices invLocks <- TM.emptyIO deleteLock <- createLockIO smpSubWorkers <- TM.emptyIO + serviceRequests <- TM.emptyIO smpServersStats <- TM.emptyIO xftpServersStats <- TM.emptyIO ntfServersStats <- TM.emptyIO srvStatsStartedAt <- newTVarIO currentTs - serviceRequests <- TM.emptyIO return AgentClient { acThread, @@ -594,11 +594,11 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg, useServices clientId, agentEnv, proxySessTs, + serviceRequests, smpServersStats, xftpServersStats, ntfServersStats, - srvStatsStartedAt, - serviceRequests + srvStatsStartedAt } slowNetworkConfig :: NetworkConfig -> NetworkConfig From 3318a99f70ba6af89699e70c09d0541c8c0e4f88 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Wed, 22 Jul 2026 10:27:55 +0100 Subject: [PATCH 10/15] command type, schema --- src/Simplex/Messaging/Agent.hs | 5 +- src/Simplex/Messaging/Agent/Protocol.hs | 6 +-- .../Migrations/agent_postgres_schema.sql | 50 ++++++++++++++++++- 3 files changed, 53 insertions(+), 8 deletions(-) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index f45b10b2e..b06dc5679 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -1712,7 +1712,7 @@ sendServiceRequest' c nm userId cReqUri@(CRContactUri crData _) payload = sendServiceRequestAsync' :: AgentClient -> UserId -> ConnectionRequestUri 'CMContact -> MsgBody -> AM MsgBody sendServiceRequestAsync' c userId cReqUri payload = serviceRequest_ c userId cReqUri $ \connId -> - enqueueCommand c "" connId Nothing $ AClientCommand $ JOIN (JRServiceRequest (ACR SCMContact cReqUri) PQSupportOn) SMSubscribe payload + enqueueCommand c "" connId Nothing $ AClientCommand $ JOIN (JRServiceReq cReqUri PQSupportOn) SMSubscribe payload serviceRequest_ :: AgentClient -> UserId -> ConnectionRequestUri 'CMContact -> (ConnId -> AM ()) -> AM MsgBody serviceRequest_ c userId cReqUri@(CRContactUri _ addrKeys_) doSend = do @@ -2150,7 +2150,7 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do triedHosts <- newTVarIO S.empty tryCommand . withNextSrv c userId storageSrvs triedHosts [qServer q] $ \srv -> joinConnSrv c NRMBackground userId connId enableNtfs cReq connInfo pqEnc subMode srv >>= notify . JOINED - JOIN (JRServiceRequest (ACR _ cReq@(CRContactUri ConnReqUriData {crSmpQueues = q :| _} _)) pqEnc) subMode connInfo -> noServer $ do + JOIN (JRServiceReq cReq@(CRContactUri ConnReqUriData {crSmpQueues = q :| _} _) pqEnc) subMode connInfo -> noServer $ do triedHosts <- newTVarIO S.empty tryCommand . withNextSrv c userId storageSrvs triedHosts [qServer q] $ \srv -> atomically (TM.lookup connId (serviceRequests c)) >>= \case @@ -2161,7 +2161,6 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do Left e | temporaryOrHostError e -> throwE e | otherwise -> atomically $ void $ tryPutTMVar var $ Left e - JOIN (JRServiceRequest (ACR _ (CRInvitationUri _ _)) _) _ _ -> internalErr "JOIN: service request requires contact address" LET confId ownCInfo -> withServer' . tryCommand $ allowConnection' c connId confId ownCInfo >> notify OK ACK msgId rcptInfo_ -> withServer' . tryCommand $ ackMessage' c connId msgId rcptInfo_ >> notify OK SWCH -> diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 0e056125c..4a97ad770 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -1888,8 +1888,8 @@ data DRInvitation = DRInvitation data JoinRequest = JRConnReq {enableNtfs :: Bool, joinConnReq :: AConnectionRequestUri, joinPQSupport :: PQSupport} + | JRServiceReq {conntactReq :: ConnectionRequestUri 'CMContact, joinPQSupport :: PQSupport} | JRInvitationDR DRInvitation - | JRServiceRequest {joinConnReq :: AConnectionRequestUri, joinPQSupport :: PQSupport} deriving (Show) data UserContactData = UserContactData @@ -2239,10 +2239,10 @@ $(J.deriveJSON defaultJSON ''DRInvitation) instance StrEncoding JoinRequest where strEncode = \case JRConnReq ntfs cReq pqSup -> strEncode (ntfs, cReq, pqSup) + JRServiceReq cReq pqSup -> strEncode ('S', cReq, pqSup) JRInvitationDR dr -> serializeBinary $ LB.toStrict (J'.encode dr) - JRServiceRequest cReq pqSup -> "S " <> strEncode (cReq, pqSup) strP = - ("S " *> (JRServiceRequest <$> strP <*> (_strP <|> pure PQSupportOff))) + (A.char 'S' *> (JRServiceReq <$> _strP <*> _strP)) <|> (JRConnReq <$> strP <*> _strP <*> (_strP <|> pure PQSupportOff)) <|> (JRInvitationDR <$> (J'.eitherDecodeStrict' <$?> (A.take =<< (A.decimal <* "\n")))) diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/agent_postgres_schema.sql b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/agent_postgres_schema.sql index 731a021ee..4220ac024 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/agent_postgres_schema.sql +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/agent_postgres_schema.sql @@ -104,6 +104,31 @@ CREATE AGGREGATE smp_agent_test_protocol_schema.xor_aggregate(bytea) ( SET default_table_access_method = heap; +CREATE TABLE smp_agent_test_protocol_schema.address_ratchet_keys ( + address_ratchet_key_id bigint NOT NULL, + conn_id bytea NOT NULL, + ratchet_key_id bytea NOT NULL, + x3dh_priv_key_1 bytea NOT NULL, + x3dh_priv_key_2 bytea NOT NULL, + pq_priv_kem bytea, + created_at timestamp with time zone DEFAULT now() NOT NULL +); + + + +CREATE SEQUENCE smp_agent_test_protocol_schema.address_ratchet_keys_address_ratchet_key_id_seq + START WITH 1 + INCREMENT BY 1 + NO MINVALUE + NO MAXVALUE + CACHE 1; + + + +ALTER SEQUENCE smp_agent_test_protocol_schema.address_ratchet_keys_address_ratchet_key_id_seq OWNED BY smp_agent_test_protocol_schema.address_ratchet_keys.address_ratchet_key_id; + + + CREATE TABLE smp_agent_test_protocol_schema.client_notices ( client_notice_id bigint NOT NULL, protocol text NOT NULL, @@ -194,7 +219,8 @@ CREATE TABLE smp_agent_test_protocol_schema.conn_invitations ( recipient_conn_info bytea NOT NULL, accepted smallint DEFAULT 0 NOT NULL, own_conn_info bytea, - created_at timestamp with time zone DEFAULT now() NOT NULL + created_at timestamp with time zone DEFAULT now() NOT NULL, + service_request smallint DEFAULT 0 NOT NULL ); @@ -215,7 +241,9 @@ CREATE TABLE smp_agent_test_protocol_schema.connections ( user_id bigint NOT NULL, ratchet_sync_state text DEFAULT 'ok'::text NOT NULL, deleted_at_wait_delivery timestamp with time zone, - pq_support smallint DEFAULT 0 NOT NULL + pq_support smallint DEFAULT 0 NOT NULL, + created_at timestamp with time zone DEFAULT '1970-01-01 00:00:00+01'::timestamp with time zone NOT NULL, + service_response smallint DEFAULT 0 NOT NULL ); @@ -847,6 +875,15 @@ ALTER TABLE smp_agent_test_protocol_schema.xftp_servers ALTER COLUMN xftp_server +ALTER TABLE ONLY smp_agent_test_protocol_schema.address_ratchet_keys ALTER COLUMN address_ratchet_key_id SET DEFAULT nextval('smp_agent_test_protocol_schema.address_ratchet_keys_address_ratchet_key_id_seq'::regclass); + + + +ALTER TABLE ONLY smp_agent_test_protocol_schema.address_ratchet_keys + ADD CONSTRAINT address_ratchet_keys_pkey PRIMARY KEY (address_ratchet_key_id); + + + ALTER TABLE ONLY smp_agent_test_protocol_schema.client_notices ADD CONSTRAINT client_notices_pkey PRIMARY KEY (client_notice_id); @@ -1032,6 +1069,10 @@ ALTER TABLE ONLY smp_agent_test_protocol_schema.xftp_servers +CREATE UNIQUE INDEX idx_address_ratchet_keys ON smp_agent_test_protocol_schema.address_ratchet_keys USING btree (conn_id, ratchet_key_id); + + + CREATE UNIQUE INDEX idx_client_notices_entity ON smp_agent_test_protocol_schema.client_notices USING btree (protocol, host, port, entity_id); @@ -1268,6 +1309,11 @@ CREATE TRIGGER tr_rcv_queue_update AFTER UPDATE ON smp_agent_test_protocol_schem +ALTER TABLE ONLY smp_agent_test_protocol_schema.address_ratchet_keys + ADD CONSTRAINT address_ratchet_keys_conn_id_fkey FOREIGN KEY (conn_id) REFERENCES smp_agent_test_protocol_schema.connections(conn_id) ON DELETE CASCADE; + + + ALTER TABLE ONLY smp_agent_test_protocol_schema.client_services ADD CONSTRAINT client_services_host_port_fkey FOREIGN KEY (host, port) REFERENCES smp_agent_test_protocol_schema.servers(host, port) ON DELETE RESTRICT; From 98caf57775dbf8575c4322472b82b6ef4c9080a9 Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Wed, 22 Jul 2026 09:32:33 +0000 Subject: [PATCH 11/15] rename --- tests/AgentTests/ConnectionRequestTests.hs | 9 +++------ tests/AgentTests/EqInstances.hs | 10 +++++++++- 2 files changed, 12 insertions(+), 7 deletions(-) diff --git a/tests/AgentTests/ConnectionRequestTests.hs b/tests/AgentTests/ConnectionRequestTests.hs index f72f13b7b..df19a1841 100644 --- a/tests/AgentTests/ConnectionRequestTests.hs +++ b/tests/AgentTests/ConnectionRequestTests.hs @@ -355,15 +355,12 @@ connectionRequestTests = restoreShortLink [presetSrv] inv' `shouldBe` inv it "should serialize and parse service RPC agent messages" $ do let qInfo = SMPQueueInfo currentSMPClientVersion queueAddr - roundtripAgentMsg $ AgentServiceRequest [qInfo] "service request payload" - roundtripAgentMsg $ AgentServiceResponse "service response payload" - roundtripAgentMsg $ AgentRejection "rejected: not allowed" + smpEncodingTest $ AgentServiceRequest [qInfo] "service request payload" + smpEncodingTest $ AgentServiceResponse "service response payload" + smpEncodingTest $ AgentRejection "rejected: not allowed" where smpEncodingTest :: (Encoding a, Eq a, Show a, HasCallStack) => a -> Expectation smpEncodingTest a = smpDecode (smpEncode a) `shouldBe` Right a - roundtripAgentMsg :: HasCallStack => AgentMessage -> Expectation - roundtripAgentMsg msg = - (smpEncode <$> (smpDecode (smpEncode msg) :: Either String AgentMessage)) `shouldBe` Right (smpEncode msg) shortSrv :: SMPServer shortSrv = SMPServer "smp.simplex.im" "" (C.KeyHash "") diff --git a/tests/AgentTests/EqInstances.hs b/tests/AgentTests/EqInstances.hs index de83c6df1..cdfb3406b 100644 --- a/tests/AgentTests/EqInstances.hs +++ b/tests/AgentTests/EqInstances.hs @@ -5,7 +5,7 @@ module AgentTests.EqInstances where import Data.Type.Equality -import Simplex.Messaging.Agent.Protocol (ABinaryConnectionRequestUri (..), ShortLinkCreds (..)) +import Simplex.Messaging.Agent.Protocol (ABinaryConnectionRequestUri (..), AMessage (..), AMessageReceipt (..), AgentMessage (..), APrivHeader (..), ShortLinkCreds (..)) import Simplex.Messaging.Agent.Store import Simplex.Messaging.Client (ProxiedRelay (..)) @@ -38,3 +38,11 @@ instance Eq ABinaryConnectionRequestUri where _ -> False deriving instance Show ABinaryConnectionRequestUri + +deriving instance Eq APrivHeader + +deriving instance Eq AMessageReceipt + +deriving instance Eq AMessage + +deriving instance Eq AgentMessage From ccc1d7f8eca529874d315abc4af0d75ac31e24d5 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Wed, 22 Jul 2026 11:29:17 +0100 Subject: [PATCH 12/15] refactor --- src/Simplex/Messaging/Agent.hs | 59 +++++++++++++------------- tests/AgentTests/FunctionalAPITests.hs | 59 +++++++++++++------------- 2 files changed, 59 insertions(+), 59 deletions(-) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index b06dc5679..d1a92b0d5 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -1643,34 +1643,32 @@ acceptContact' c nm userId connId enableNtfs invId ownConnInfo pqSupport subMode pure r rejectContact' :: AgentClient -> NetworkRequestMode -> UserId -> InvitationId -> Maybe ByteString -> AM () -rejectContact' c nm userId invId reason_ = do - forM_ reason_ $ \reason -> sendReplySync c nm =<< prepareReply c userId invId False (AgentRejection reason) - withStore' c $ \db -> deleteInvitation db invId +rejectContact' c = rejectRequest_ c False . sendReplySync c rejectContactAsync' :: AgentClient -> ACorrId -> UserId -> InvitationId -> Maybe ByteString -> AM () -rejectContactAsync' c corrId userId invId reason_ = do - forM_ reason_ $ \reason -> sendReplyAsync c corrId =<< prepareReply c userId invId False (AgentRejection reason) - withStore' c $ \db -> deleteInvitation db invId +rejectContactAsync' c = rejectRequest_ c False . sendReplyAsync c rejectServiceRequest' :: AgentClient -> NetworkRequestMode -> UserId -> InvitationId -> Maybe ByteString -> AM () -rejectServiceRequest' c nm userId invId reason_ = do - forM_ reason_ $ \reason -> sendReplySync c nm =<< prepareReply c userId invId True (AgentRejection reason) - withStore' c $ \db -> deleteInvitation db invId +rejectServiceRequest' c = rejectRequest_ c True . sendReplySync c rejectServiceRequestAsync' :: AgentClient -> ACorrId -> UserId -> InvitationId -> Maybe ByteString -> AM () -rejectServiceRequestAsync' c corrId userId invId reason_ = do - forM_ reason_ $ \reason -> sendReplyAsync c corrId =<< prepareReply c userId invId True (AgentRejection reason) - withStore' c $ \db -> deleteInvitation db invId +rejectServiceRequestAsync' c = rejectRequest_ c True . sendReplyAsync c + +rejectRequest_ :: AgentClient -> Bool -> ((ConnId, ConnData, SndQueue) -> AM ()) -> UserId -> InvitationId -> Maybe ByteString -> AM () +rejectRequest_ c serviceRequest sendReply userId invId reason_ = do + mapM_ ((sendReply =<<) . prepareReply c userId invId serviceRequest . AgentRejection) reason_ + withStore' c (`deleteInvitation` invId) sendServiceReply' :: AgentClient -> NetworkRequestMode -> UserId -> InvitationId -> MsgBody -> AM () -sendServiceReply' c nm userId invId payload = do - sendReplySync c nm =<< prepareReply c userId invId True (AgentServiceResponse payload) - withStore' c $ \db -> deleteInvitation db invId +sendServiceReply' c = replyRequest_ c . sendReplySync c sendServiceReplyAsync' :: AgentClient -> ACorrId -> UserId -> InvitationId -> MsgBody -> AM () -sendServiceReplyAsync' c corrId userId invId payload = do - sendReplyAsync c corrId =<< prepareReply c userId invId True (AgentServiceResponse payload) - withStore' c $ \db -> deleteInvitation db invId +sendServiceReplyAsync' c = replyRequest_ c . sendReplyAsync c + +replyRequest_ :: AgentClient -> ((ConnId, ConnData, SndQueue) -> AM ()) -> UserId -> InvitationId -> MsgBody -> AM () +replyRequest_ c sendReply userId invId resp = do + sendReply =<< prepareReply c userId invId True (AgentServiceResponse resp) + withStore' c (`deleteInvitation` invId) sendReplySync :: AgentClient -> NetworkRequestMode -> (ConnId, ConnData, SndQueue) -> AM () sendReplySync c nm (connId, cData, sq) = do @@ -1682,10 +1680,10 @@ sendReplyAsync :: AgentClient -> ACorrId -> (ConnId, ConnData, SndQueue) -> AM ( sendReplyAsync c corrId (connId, _, sq) = enqueueCommand c corrId connId (Just $ qServer sq) $ AInternalCommand ICReplyDel prepareReply :: AgentClient -> UserId -> InvitationId -> Bool -> AgentMessage -> AM (ConnId, ConnData, SndQueue) -prepareReply c userId invId expectedServiceRequest innerMsg = do +prepareReply c userId invId serviceRequest' innerMsg = do Invitation {connReq, serviceRequest, createdAt} <- withStore c $ \db -> getInvitation db "prepareReply" invId - when (serviceRequest /= expectedServiceRequest) $ throwE $ CMD PROHIBITED kindErr - when expectedServiceRequest $ do + when (serviceRequest /= serviceRequest') $ throwE $ CMD PROHIBITED kindErr + when serviceRequest' $ do now <- liftIO getCurrentTime responseTimeout <- asks $ serviceResponseTimeout . config when (diffUTCTime now createdAt > responseTimeout) $ do @@ -1700,7 +1698,7 @@ prepareReply c userId invId expectedServiceRequest innerMsg = do pure (connId, cData, sq) where kindErr - | expectedServiceRequest = "reply: not a service request, use rejectContact" + | serviceRequest' = "reply: not a service request, use rejectContact" | otherwise = "rejectContact: service request, use rejectServiceRequest" sendServiceRequest' :: AgentClient -> NetworkRequestMode -> UserId -> ConnectionRequestUri 'CMContact -> MsgBody -> AM MsgBody @@ -2148,19 +2146,20 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do -- Currently joinConnSrv is used because even joinConnSrvAsync for invitation URIs creates receive queue synchronously. JOIN (JRConnReq enableNtfs (ACR _ cReq@(CRContactUri ConnReqUriData {crSmpQueues = q :| _} _)) pqEnc) subMode connInfo -> noServer $ do triedHosts <- newTVarIO S.empty - tryCommand . withNextSrv c userId storageSrvs triedHosts [qServer q] $ \srv -> - joinConnSrv c NRMBackground userId connId enableNtfs cReq connInfo pqEnc subMode srv >>= notify . JOINED + tryCommand . withNextSrv c userId storageSrvs triedHosts [qServer q] $ \srv -> do + sqSecured <- joinConnSrv c NRMBackground userId connId enableNtfs cReq connInfo pqEnc subMode srv + notify $ JOINED sqSecured JOIN (JRServiceReq cReq@(CRContactUri ConnReqUriData {crSmpQueues = q :| _} _) pqEnc) subMode connInfo -> noServer $ do triedHosts <- newTVarIO S.empty tryCommand . withNextSrv c userId storageSrvs triedHosts [qServer q] $ \srv -> atomically (TM.lookup connId (serviceRequests c)) >>= \case Nothing -> pure () - Just var -> - tryError (void $ joinConnSrv' c NRMBackground userId connId False cReq connInfo pqEnc subMode srv $ \replyQInfo -> AgentServiceRequest (replyQInfo :| []) connInfo) >>= \case - Right () -> pure () - Left e - | temporaryOrHostError e -> throwE e - | otherwise -> atomically $ void $ tryPutTMVar var $ Left e + Just v -> + void (joinConnSrv' c NRMBackground userId connId False cReq connInfo pqEnc subMode srv $ \replyQInfo -> AgentServiceRequest (replyQInfo :| []) connInfo) + `catchAllErrors` \e -> + if temporaryOrHostError e + then throwE e + else atomically $ void $ tryPutTMVar v $ Left e -- will not overwrite existing result LET confId ownCInfo -> withServer' . tryCommand $ allowConnection' c connId confId ownCInfo >> notify OK ACK msgId rcptInfo_ -> withServer' . tryCommand $ ackMessage' c connId msgId rcptInfo_ >> notify OK SWCH -> diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 0f139f7bc..26b52991b 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -347,35 +347,36 @@ functionalAPITests ps = do testRatchetMatrix2 ps runAgentClientContactTest describe "Establish duplex connection via contact address, different PQ settings" $ do testPQMatrix3 ps $ runAgentClientContactTestPQ3 True - describe "Establish duplex connection via contact address with DR" $ - testContactDRMatrix ps - describe "Establish duplex connection creating contact address with DR" $ do - it "createConnection, IKPQOn" $ runCreateConnectionDRTest_ False IKPQOn PQSupportOn ps - it "createConnection, IKUsePQ" $ runCreateConnectionDRTest_ False IKUsePQ PQSupportOn ps - it "createConnectionAsync, IKPQOn" $ runCreateConnectionDRTest_ True IKPQOn PQSupportOn ps - it "createConnectionAsync, IKUsePQ" $ runCreateConnectionDRTest_ True IKUsePQ PQSupportOn ps - it "should preserve address DR keys when the link data is updated" $ - testAddressUpdatePreservesDRKeys ps - it "should rotate address DR keys, keeping old keys for stale requesters until pruned" $ - testAddressKeyRotation ps - it "should add DR keys to an existing address via setConnShortLink" $ - testAddDRViaSetConnShortLink ps - it "should resume DR accept after a transient failure (reuse the send queue and ratchet)" $ - testAcceptContactDRResumeAfterOffline ps - it "should support rejecting contact request" $ - withSmpServer ps testRejectContactRequest - it "should communicate rejection reason via double ratchet" $ - withSmpServer ps testRejectContactRequestDR - it "should communicate rejection reason via double ratchet (async)" $ - withSmpServer ps testRejectContactRequestDRAsync - it "should send a service request and receive the response" $ - withSmpServer ps testServiceRequestResponse - it "should send a service request and receive the response (async reply)" $ - withSmpServer ps testServiceRequestResponseAsync - it "should reject a service request with a reason" $ - withSmpServer ps testServiceRequestRejected - it "should deliver a service response across server outages" $ - testServiceRequestResilient ps + describe "contact address with DR" $ do + describe "Establish duplex connection via contact address with DR" $ + testContactDRMatrix ps + describe "Establish duplex connection creating contact address with DR" $ do + it "createConnection, IKPQOn" $ runCreateConnectionDRTest_ False IKPQOn PQSupportOn ps + it "createConnection, IKUsePQ" $ runCreateConnectionDRTest_ False IKUsePQ PQSupportOn ps + it "createConnectionAsync, IKPQOn" $ runCreateConnectionDRTest_ True IKPQOn PQSupportOn ps + it "createConnectionAsync, IKUsePQ" $ runCreateConnectionDRTest_ True IKUsePQ PQSupportOn ps + it "should preserve address DR keys when the link data is updated" $ + testAddressUpdatePreservesDRKeys ps + it "should rotate address DR keys, keeping old keys for stale requesters until pruned" $ + testAddressKeyRotation ps + it "should add DR keys to an existing address via setConnShortLink" $ + testAddDRViaSetConnShortLink ps + it "should resume DR accept after a transient failure (reuse the send queue and ratchet)" $ + testAcceptContactDRResumeAfterOffline ps + it "should support rejecting contact request" $ + withSmpServer ps testRejectContactRequest + it "should communicate rejection reason via double ratchet" $ + withSmpServer ps testRejectContactRequestDR + it "should communicate rejection reason via double ratchet (async)" $ + withSmpServer ps testRejectContactRequestDRAsync + it "should send a service request and receive the response" $ + withSmpServer ps testServiceRequestResponse + it "should send a service request and receive the response (async reply)" $ + withSmpServer ps testServiceRequestResponseAsync + it "should reject a service request with a reason" $ + withSmpServer ps testServiceRequestRejected + it "should deliver a service response across server outages" $ + testServiceRequestResilient ps describe "Changing connection user id" $ do it "should change user id for new connections" $ do withSmpServer ps testUpdateConnectionUserId From 900d6a3fcf366b7c3d0922fe48a0279f720361d9 Mon Sep 17 00:00:00 2001 From: Evgeny Date: Wed, 22 Jul 2026 11:40:52 +0100 Subject: [PATCH 13/15] typo Co-authored-by: simplex-chat-agent[bot] <287173099+simplex-chat-agent[bot]@users.noreply.github.com> --- src/Simplex/Messaging/Agent/Protocol.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 4a97ad770..ea99f31ae 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -1888,7 +1888,7 @@ data DRInvitation = DRInvitation data JoinRequest = JRConnReq {enableNtfs :: Bool, joinConnReq :: AConnectionRequestUri, joinPQSupport :: PQSupport} - | JRServiceReq {conntactReq :: ConnectionRequestUri 'CMContact, joinPQSupport :: PQSupport} + | JRServiceReq {contactReq :: ConnectionRequestUri 'CMContact, joinPQSupport :: PQSupport} | JRInvitationDR DRInvitation deriving (Show) From 45ec3790bdbd185876935cecd03689c2e416a54a Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Thu, 23 Jul 2026 15:39:07 +0000 Subject: [PATCH 14/15] allow overriding the service request timeout per request --- src/Simplex/Messaging/Agent.hs | 61 ++++++++++--------- src/Simplex/Messaging/Agent/Env/SQLite.hs | 5 +- src/Simplex/Messaging/Agent/Protocol.hs | 2 +- src/Simplex/Messaging/Agent/Store.hs | 5 +- .../Messaging/Agent/Store/AgentStore.hs | 20 +++--- .../Migrations/M20260712_address_dr_rpc.hs | 6 +- .../Migrations/agent_postgres_schema.sql | 2 +- .../Migrations/M20260712_address_dr_rpc.hs | 6 +- .../Store/SQLite/Migrations/agent_schema.sql | 2 +- tests/AgentTests/FunctionalAPITests.hs | 32 +++++----- tests/AgentTests/SQLiteTests.hs | 2 +- 11 files changed, 74 insertions(+), 69 deletions(-) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index d1a92b0d5..9a4ba192c 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -482,7 +482,7 @@ changeConnectionUser c oldUserId connId newUserId = withAgentEnv c $ changeConne -- Instead of it we could send confirmation asynchronously, but then it would be harder to report -- "link deleted" (SMP AUTH) interactively, so this approach is simpler overall. prepareConnectionToJoin :: AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> PQSupport -> AE ConnId -prepareConnectionToJoin c userId enableNtfs = withAgentEnv c .: newConnToJoin c userId "" enableNtfs False +prepareConnectionToJoin c userId enableNtfs = withAgentEnv c .: newConnToJoin c userId "" enableNtfs Nothing {-# INLINE prepareConnectionToJoin #-} -- | Create SMP agent connection without queue (to be joined with acceptContact passing invitation ID). @@ -530,12 +530,12 @@ rejectServiceRequestAsync :: AgentClient -> ACorrId -> UserId -> InvitationId -> rejectServiceRequestAsync c = withAgentEnv c .:: rejectServiceRequestAsync' c {-# INLINE rejectServiceRequestAsync #-} -sendServiceRequest :: AgentClient -> NetworkRequestMode -> UserId -> ConnectionRequestUri 'CMContact -> MsgBody -> AE MsgBody -sendServiceRequest c = withAgentEnv c .:: sendServiceRequest' c +sendServiceRequest :: AgentClient -> NetworkRequestMode -> UserId -> ConnectionRequestUri 'CMContact -> Maybe NominalDiffTime -> MsgBody -> AE MsgBody +sendServiceRequest c = withAgentEnv c .::. sendServiceRequest' c {-# INLINE sendServiceRequest #-} -sendServiceRequestAsync :: AgentClient -> UserId -> ConnectionRequestUri 'CMContact -> MsgBody -> AE MsgBody -sendServiceRequestAsync c = withAgentEnv c .:. sendServiceRequestAsync' c +sendServiceRequestAsync :: AgentClient -> UserId -> ConnectionRequestUri 'CMContact -> Maybe NominalDiffTime -> MsgBody -> AE MsgBody +sendServiceRequestAsync c = withAgentEnv c .:: sendServiceRequestAsync' c {-# INLINE sendServiceRequestAsync #-} data DatabaseDiff a = DatabaseDiff @@ -896,7 +896,7 @@ newConnNoQueues :: AgentClient -> UserId -> Bool -> SConnectionMode c -> PQSuppo newConnNoQueues c userId enableNtfs cMode pqSupport = do g <- asks random connAgentVersion <- asks $ maxVersion . smpAgentVRange . config - let cData = ConnData {userId, connId = "", connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceResponse = False} + let cData = ConnData {userId, connId = "", connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceRequestExpiresAt = Nothing} withStore c $ \db -> createNewConn db g cData cMode -- TODO [short links] TBC, but probably we will need async join for contact addresses as the contact will be created after user confirming the connection, @@ -1147,7 +1147,7 @@ getConnShortLinkAsync' c userId corrId connId_ shortLink@(CSLContact _ _ srv _) deleted = False, ratchetSyncState = RSOk, pqSupport = PQSupportOff, - serviceResponse = False + serviceRequestExpiresAt = Nothing } createNewConn db g cData SCMInvitation @@ -1369,8 +1369,8 @@ newQueueNtfSubscription c RcvQueue {userId, connId, server, clientNtfCreds} ntfS ns <- asks ntfSupervisor liftIO $ sendNtfSubCommand ns (NSCCreate, [connId]) -newConnToJoin :: forall c. AgentClient -> UserId -> ConnId -> Bool -> Bool -> ConnectionRequestUri c -> PQSupport -> AM ConnId -newConnToJoin c userId connId enableNtfs serviceResponse cReq pqSup = case cReq of +newConnToJoin :: forall c. AgentClient -> UserId -> ConnId -> Bool -> Maybe UTCTime -> ConnectionRequestUri c -> PQSupport -> AM ConnId +newConnToJoin c userId connId enableNtfs serviceRequestExpiresAt cReq pqSup = case cReq of CRInvitationUri {} -> lift (compatibleInvitationUri cReq) >>= \case Just (_, Compatible (CR.E2ERatchetParams v _ _ _), aVersion) -> create aVersion (Just v) @@ -1384,17 +1384,17 @@ newConnToJoin c userId connId enableNtfs serviceResponse cReq pqSup = case cReq create (Compatible connAgentVersion) e2eV_ = do g <- asks random let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ connAgentVersion e2eV_ - cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceResponse} + cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceRequestExpiresAt} withStore c $ \db -> createNewConn db g cData SCMInvitation newConnToAccept :: AgentClient -> UserId -> ConnId -> Bool -> ConfirmationId -> PQSupport -> AM ConnId newConnToAccept c userId connId enableNtfs invId pqSup = do Invitation {connReq} <- withStore c $ \db -> getInvitation db "newConnToAccept" invId case connReq of - CRInvitation cReq -> newConnToJoin c userId connId enableNtfs False cReq pqSup + CRInvitation cReq -> newConnToJoin c userId connId enableNtfs Nothing cReq pqSup CRInvitationDR DRInvitation {agentVersion, pqSupport} -> do g <- asks random - let cData = ConnData {userId, connId, connAgentVersion = agentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceResponse = False} + let cData = ConnData {userId, connId, connAgentVersion = agentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceRequestExpiresAt = Nothing} withStore c $ \db -> createNewConn db g cData SCMInvitation joinConn :: AgentClient -> NetworkRequestMode -> UserId -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> PQSupport -> SubscriptionMode -> AM SndQueueSecured @@ -1414,7 +1414,7 @@ startJoinInvitation c userId connId sq_ enableNtfs cReqUri pqSup = let pqSupport = pqSup `CR.pqSupportAnd` versionPQSupport_ connAgentVersion (Just v) g <- asks random maxSupported <- asks $ maxVersion . e2eEncryptVRange . config - let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceResponse = False} + let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceRequestExpiresAt = Nothing} case sq_ of Just sq@SndQueue {e2ePubKey = Just _k} -> do e2eSndParams <- withStore c $ \db -> do @@ -1701,24 +1701,25 @@ prepareReply c userId invId serviceRequest' innerMsg = do | serviceRequest' = "reply: not a service request, use rejectContact" | otherwise = "rejectContact: service request, use rejectServiceRequest" -sendServiceRequest' :: AgentClient -> NetworkRequestMode -> UserId -> ConnectionRequestUri 'CMContact -> MsgBody -> AM MsgBody -sendServiceRequest' c nm userId cReqUri@(CRContactUri crData _) payload = - serviceRequest_ c userId cReqUri $ \connId -> do +sendServiceRequest' :: AgentClient -> NetworkRequestMode -> UserId -> ConnectionRequestUri 'CMContact -> Maybe NominalDiffTime -> MsgBody -> AM MsgBody +sendServiceRequest' c nm userId cReqUri@(CRContactUri crData _) timeout_ payload = + serviceRequest_ c userId cReqUri timeout_ $ \connId -> do srv <- getNextSMPServer c userId [qServer $ L.head $ crSmpQueues crData] void $ joinConnSrv' c nm userId connId False cReqUri payload PQSupportOn SMSubscribe srv $ \replyQInfo -> AgentServiceRequest (replyQInfo :| []) payload -sendServiceRequestAsync' :: AgentClient -> UserId -> ConnectionRequestUri 'CMContact -> MsgBody -> AM MsgBody -sendServiceRequestAsync' c userId cReqUri payload = - serviceRequest_ c userId cReqUri $ \connId -> +sendServiceRequestAsync' :: AgentClient -> UserId -> ConnectionRequestUri 'CMContact -> Maybe NominalDiffTime -> MsgBody -> AM MsgBody +sendServiceRequestAsync' c userId cReqUri timeout_ payload = + serviceRequest_ c userId cReqUri timeout_ $ \connId -> enqueueCommand c "" connId Nothing $ AClientCommand $ JOIN (JRServiceReq cReqUri PQSupportOn) SMSubscribe payload -serviceRequest_ :: AgentClient -> UserId -> ConnectionRequestUri 'CMContact -> (ConnId -> AM ()) -> AM MsgBody -serviceRequest_ c userId cReqUri@(CRContactUri _ addrKeys_) doSend = do +serviceRequest_ :: AgentClient -> UserId -> ConnectionRequestUri 'CMContact -> Maybe NominalDiffTime -> (ConnId -> AM ()) -> AM MsgBody +serviceRequest_ c userId cReqUri@(CRContactUri _ addrKeys_) timeout_ doSend = do when (isNothing addrKeys_) $ throwE $ AGENT $ A_SERVICE ASENotDRAddress - connId <- newConnToJoin c userId "" False True cReqUri PQSupportOn + reqTimeout <- maybe (asks $ serviceRequestTimeout . config) pure timeout_ + expiresAt <- addUTCTime reqTimeout <$> liftIO getCurrentTime + connId <- newConnToJoin c userId "" False (Just expiresAt) cReqUri PQSupportOn var <- atomically newEmptyTMVar atomically $ TM.insert connId var (serviceRequests c) - reqTimeout <- asks $ serviceRequestTimeout . config r <- tryError $ do doSend connId liftIO $ do @@ -3287,10 +3288,10 @@ cleanupManager c@AgentClient {subQ} = do liftIO $ threadDelay' int where deleteExpiredServiceReqs = do - AgentConfig {serviceRequestTimeout, serviceResponseTimeout} <- asks config + serviceResponseTimeout <- asks $ serviceResponseTimeout . config now <- liftIO getCurrentTime withStore' c $ \db -> deleteExpiredServiceRequests db $ addUTCTime (negate serviceResponseTimeout) now - expiredConns <- withStore' c $ \db -> getExpiredServiceConns db $ addUTCTime (negate serviceRequestTimeout) now + expiredConns <- withStore' c $ \db -> getExpiredServiceConns db now deleteConnectionsAsync' c False expiredConns run :: forall e. AEntityI e => (AgentErrorType -> AEvent e) -> AM () -> AM' () run err a = do @@ -3686,7 +3687,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar smpConfirmation srvMsgId conn' senderKey e2ePubKey e2eEncryption encConnInfo phVer agentVersion = do logServer "<--" c srv rId $ "MSG :" <> logSecret' srvMsgId checkConfVersions agentVersion phVer - let ConnData {pqSupport, serviceResponse} = toConnData conn' + let ConnData {pqSupport, serviceRequestExpiresAt} = toConnData conn' case status of New -> case conn' of -- party initiating connection @@ -3708,9 +3709,9 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar AgentConnInfoReply smpQueues connInfo -> do processConf rc' connInfo SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = L.toList smpQueues, smpClientVersion = phVer} withStore' c $ \db -> updateRcvMsgHash db connId 1 (InternalRcvId 0) (C.sha256Hash agentMsgBody) - AgentServiceResponse payload | serviceResponse -> dispatchServiceReply $ Right payload + AgentServiceResponse payload | isJust serviceRequestExpiresAt -> dispatchServiceReply $ Right payload AgentRejection reason - | serviceResponse -> dispatchServiceReply $ Left $ AGENT $ A_SERVICE $ ASERejected $ B.unpack reason + | isJust serviceRequestExpiresAt -> dispatchServiceReply $ Left $ AGENT $ A_SERVICE $ ASERejected $ B.unpack reason | otherwise -> notify $ RJCT reason _ -> prohibited "conf: not AgentConnInfoReply" -- including AgentConnInfo, that is prohibited here in v2 Left _ -> prohibited "conf: decrypt error" @@ -3933,7 +3934,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar pqSupport <- lift $ maybe PQSupportOff pqSupported <$> compatibleInvitationUri connReq invId <- storeInvitation (CRInvitation connReq) cInfo False let srvs = L.map qServer $ crSmpQueues crData - notify $ REQ invId pqSupport srvs cInfo + notify $ REQ invId pqSupport srvs cInfo False _ -> prohibited "inv: sent to message conn" where pqSupported (_, Compatible (CR.E2ERatchetParams v _ _ _), Compatible agentVersion) = @@ -3962,7 +3963,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar parseMessage agentMsgBody >>= \case AgentConnInfoReply (replyQueue :| _) cInfo -> do invId <- storeInvitation (CRInvitationDR $ mkDR replyQueue) cInfo False - notify $ REQ invId pqSupported (qServer replyQueue :| []) cInfo + notify $ REQ invId pqSupported (qServer replyQueue :| []) cInfo True AgentServiceRequest (replyQueue :| _) payload -> do invId <- storeInvitation (CRInvitationDR $ mkDR replyQueue) payload True notify $ SREQ invId payload diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index f81f42ab0..c234711d6 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -153,8 +153,9 @@ data AgentConfig = AgentConfig userNetworkInterval :: Int, userOfflineDelay :: NominalDiffTime, messageTimeout :: NominalDiffTime, - serviceRequestTimeout :: NominalDiffTime, - serviceResponseTimeout :: NominalDiffTime, + serviceRequestTimeout :: NominalDiffTime, -- client side: default time the client waits for a service response (overridable per request) + serviceResponseTimeout :: NominalDiffTime, -- service side: time a received service request is valid to respond to + connDeleteDeliveryTimeout :: NominalDiffTime, helloTimeout :: NominalDiffTime, quotaExceededTimeout :: NominalDiffTime, diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index ea99f31ae..720c2d683 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -415,7 +415,7 @@ data AEvent (e :: AEntity) where LINK :: ConnShortLink 'CMContact -> UserConnLinkData 'CMContact -> AEvent AEConn LDATA :: FixedLinkData 'CMContact -> ConnLinkData 'CMContact -> ConnectionRequestUri 'CMContact -> AEvent AEConn CONF :: ConfirmationId -> PQSupport -> [SMPServer] -> ConnInfo -> AEvent AEConn -- ConnInfo is from sender, [SMPServer] will be empty only in v1 handshake - REQ :: InvitationId -> PQSupport -> NonEmpty SMPServer -> ConnInfo -> AEvent AEConn -- ConnInfo is from sender + REQ :: InvitationId -> PQSupport -> NonEmpty SMPServer -> ConnInfo -> Bool -> AEvent AEConn -- ConnInfo is from sender; Bool - rejection reason can be sent SREQ :: InvitationId -> MsgBody -> AEvent AEConn RJCT :: ConnInfo -> AEvent AEConn INFO :: PQSupport -> ConnInfo -> AEvent AEConn diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index d76f50b45..abfbe4b47 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -466,7 +466,8 @@ data ConnData = ConnData deleted :: Bool, ratchetSyncState :: RatchetSyncState, pqSupport :: PQSupport, - serviceResponse :: Bool + -- client side: set on the requester's connection for a service request; Nothing otherwise. The time the client stops waiting for the response (created + serviceRequestTimeout or per-call override). + serviceRequestExpiresAt :: Maybe UTCTime } deriving (Eq, Show) @@ -638,6 +639,7 @@ data NewInvitation = NewInvitation { contactConnId :: ConnId, connReq :: ContactRequest, recipientConnInfo :: ConnInfo, + -- service side: the received request is a service request (SREQ) not a contact request (REQ) serviceRequest :: Bool } @@ -648,6 +650,7 @@ data Invitation = Invitation recipientConnInfo :: ConnInfo, ownConnInfo :: Maybe ConnInfo, accepted :: Bool, + -- service side: the received request is a service request (SREQ) not a contact request (REQ) serviceRequest :: Bool, createdAt :: UTCTime } diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs index 12bc5d5e9..4863e402b 100644 --- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -567,16 +567,16 @@ createSndConn db gVar cData q@SndQueue {server} = insertSndQueue_ db connId q serverKeyHash_ createConnRecord :: DB.Connection -> ConnId -> ConnData -> SConnectionMode c -> IO () -createConnRecord db connId ConnData {userId, connAgentVersion, enableNtfs, pqSupport, serviceResponse} cMode = do +createConnRecord db connId ConnData {userId, connAgentVersion, enableNtfs, pqSupport, serviceRequestExpiresAt} cMode = do createdAt <- getCurrentTime DB.execute db [sql| INSERT INTO connections - (user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, pq_support, service_response, duplex_handshake, created_at) + (user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, pq_support, service_request_expires_at, duplex_handshake, created_at) VALUES (?,?,?,?,?,?,?,?,?) |] - (userId, connId, cMode, connAgentVersion, BI enableNtfs, pqSupport, BI serviceResponse, BI True, createdAt) + (userId, connId, cMode, connAgentVersion, BI enableNtfs, pqSupport, serviceRequestExpiresAt, BI True, createdAt) deleteConnRecord :: DB.Connection -> ConnId -> IO () deleteConnRecord db connId = DB.execute db "DELETE FROM connections WHERE conn_id = ?" (Only connId) @@ -2629,7 +2629,7 @@ getConnsData_ deleted' db connIds = db [sql| SELECT user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, - last_external_snd_msg_id, deleted, ratchet_sync_state, pq_support, service_response + last_external_snd_msg_id, deleted, ratchet_sync_state, pq_support, service_request_expires_at FROM connections WHERE conn_id IN ? AND deleted = ? |] @@ -2667,7 +2667,7 @@ getConnData deleted' forUpdate db connId' = db ( [sql| SELECT user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, - last_external_snd_msg_id, deleted, ratchet_sync_state, pq_support, service_response + last_external_snd_msg_id, deleted, ratchet_sync_state, pq_support, service_request_expires_at FROM connections WHERE conn_id = ? AND deleted = ? |] @@ -2684,9 +2684,9 @@ lockConnForUpdate db connId = do #endif pure () -rowToConnData :: (UserId, ConnId, ConnectionMode, VersionSMPA, Maybe BoolInt, PrevExternalSndId, BoolInt, RatchetSyncState, PQSupport, BoolInt) -> (ConnData, ConnectionMode) -rowToConnData (userId, connId, cMode, connAgentVersion, enableNtfs_, lastExternalSndId, BI deleted, ratchetSyncState, pqSupport, BI serviceResponse) = - (ConnData {userId, connId, connAgentVersion, enableNtfs = maybe True unBI enableNtfs_, lastExternalSndId, deleted, ratchetSyncState, pqSupport, serviceResponse}, cMode) +rowToConnData :: (UserId, ConnId, ConnectionMode, VersionSMPA, Maybe BoolInt, PrevExternalSndId, BoolInt, RatchetSyncState, PQSupport, Maybe UTCTime) -> (ConnData, ConnectionMode) +rowToConnData (userId, connId, cMode, connAgentVersion, enableNtfs_, lastExternalSndId, BI deleted, ratchetSyncState, pqSupport, serviceRequestExpiresAt) = + (ConnData {userId, connId, connAgentVersion, enableNtfs = maybe True unBI enableNtfs_, lastExternalSndId, deleted, ratchetSyncState, pqSupport, serviceRequestExpiresAt}, cMode) setConnDeleted :: DB.Connection -> Bool -> ConnId -> IO () setConnDeleted db waitDelivery connId @@ -2716,8 +2716,8 @@ getDeletedConnIds :: DB.Connection -> IO [ConnId] getDeletedConnIds db = map fromOnly <$> DB.query db "SELECT conn_id FROM connections WHERE deleted = ?" (Only (BI True)) getExpiredServiceConns :: DB.Connection -> UTCTime -> IO [ConnId] -getExpiredServiceConns db expireTs = - map fromOnly <$> DB.query db "SELECT conn_id FROM connections WHERE service_response = 1 AND created_at < ? AND deleted = 0 AND deleted_at_wait_delivery IS NULL" (Only expireTs) +getExpiredServiceConns db now = + map fromOnly <$> DB.query db "SELECT conn_id FROM connections WHERE service_request_expires_at < ? AND deleted = 0 AND deleted_at_wait_delivery IS NULL" (Only now) deleteExpiredServiceRequests :: DB.Connection -> UTCTime -> IO () deleteExpiredServiceRequests db expireTs = diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20260712_address_dr_rpc.hs b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20260712_address_dr_rpc.hs index 1d2126f3b..5a3b12b5d 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20260712_address_dr_rpc.hs +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20260712_address_dr_rpc.hs @@ -21,15 +21,15 @@ CREATE TABLE address_ratchet_keys( CREATE UNIQUE INDEX idx_address_ratchet_keys ON address_ratchet_keys(conn_id, ratchet_key_id); -ALTER TABLE conn_invitations ADD COLUMN service_request SMALLINT NOT NULL DEFAULT 0; +ALTER TABLE conn_invitations ADD COLUMN service_request SMALLINT NOT NULL DEFAULT 0; -- service side: received request is a service request (SREQ) not a contact request (REQ) ALTER TABLE connections ADD COLUMN created_at TIMESTAMPTZ NOT NULL DEFAULT '1970-01-01 00:00:00'; -ALTER TABLE connections ADD COLUMN service_response SMALLINT NOT NULL DEFAULT 0; +ALTER TABLE connections ADD COLUMN service_request_expires_at TIMESTAMPTZ; -- client side: requester's outstanding service request; the time the client stops waiting for the response |] down_m20260712_address_dr_rpc :: Text down_m20260712_address_dr_rpc = [r| -ALTER TABLE connections DROP COLUMN service_response; +ALTER TABLE connections DROP COLUMN service_request_expires_at; ALTER TABLE connections DROP COLUMN created_at; ALTER TABLE conn_invitations DROP COLUMN service_request; DROP INDEX idx_address_ratchet_keys; diff --git a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/agent_postgres_schema.sql b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/agent_postgres_schema.sql index 4220ac024..b593b2b3b 100644 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/agent_postgres_schema.sql +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/agent_postgres_schema.sql @@ -243,7 +243,7 @@ CREATE TABLE smp_agent_test_protocol_schema.connections ( deleted_at_wait_delivery timestamp with time zone, pq_support smallint DEFAULT 0 NOT NULL, created_at timestamp with time zone DEFAULT '1970-01-01 00:00:00+01'::timestamp with time zone NOT NULL, - service_response smallint DEFAULT 0 NOT NULL + service_request_expires_at timestamp with time zone ); diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20260712_address_dr_rpc.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20260712_address_dr_rpc.hs index 06e9a9b78..aa5aab1a4 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20260712_address_dr_rpc.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20260712_address_dr_rpc.hs @@ -20,15 +20,15 @@ CREATE TABLE address_ratchet_keys( CREATE UNIQUE INDEX idx_address_ratchet_keys ON address_ratchet_keys(conn_id, ratchet_key_id); -ALTER TABLE conn_invitations ADD COLUMN service_request INTEGER NOT NULL DEFAULT 0; +ALTER TABLE conn_invitations ADD COLUMN service_request INTEGER NOT NULL DEFAULT 0; -- service side: received request is a service request (SREQ) not a contact request (REQ) ALTER TABLE connections ADD COLUMN created_at TEXT NOT NULL DEFAULT('1970-01-01 00:00:00'); -ALTER TABLE connections ADD COLUMN service_response INTEGER NOT NULL DEFAULT 0; +ALTER TABLE connections ADD COLUMN service_request_expires_at TEXT; -- client side: requester's outstanding service request; the time the client stops waiting for the response |] down_m20260712_address_dr_rpc :: Query down_m20260712_address_dr_rpc = [sql| -ALTER TABLE connections DROP COLUMN service_response; +ALTER TABLE connections DROP COLUMN service_request_expires_at; ALTER TABLE connections DROP COLUMN created_at; ALTER TABLE conn_invitations DROP COLUMN service_request; DROP INDEX idx_address_ratchet_keys; diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql index 4479f5cb6..5281f0dbe 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql @@ -29,7 +29,7 @@ CREATE TABLE connections( deleted_at_wait_delivery TEXT, pq_support INTEGER NOT NULL DEFAULT 0, created_at TEXT NOT NULL DEFAULT('1970-01-01 00:00:00'), - service_response INTEGER NOT NULL DEFAULT 0 + service_request_expires_at TEXT ) WITHOUT ROWID, STRICT; CREATE TABLE rcv_queues( host TEXT NOT NULL, diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 26b52991b..f2b1ff3fb 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -201,7 +201,7 @@ pattern INFO :: ConnInfo -> AEvent 'AEConn pattern INFO connInfo = A.INFO PQSupportOn connInfo pattern REQ :: InvitationId -> NonEmpty SMPServer -> ConnInfo -> AEvent e -pattern REQ invId srvs connInfo <- A.REQ invId PQSupportOn srvs connInfo +pattern REQ invId srvs connInfo <- A.REQ invId PQSupportOn srvs connInfo _ pattern CON :: AEvent 'AEConn pattern CON = A.CON PQEncOn @@ -984,7 +984,7 @@ runAgentClientContactTestPQ sqSecured viaProxy reqPQSupport (alice, aPQ) (bob, b aliceId <- A.prepareConnectionToJoin bob 1 True qInfo bPQ sqSecuredJoin <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe liftIO $ sqSecuredJoin `shouldBe` False -- joining via contact address connection - ("", _, A.REQ invId pqSup' _ "bob's connInfo") <- get alice + ("", _, A.REQ invId pqSup' _ "bob's connInfo" _) <- get alice liftIO $ pqSup' `shouldBe` reqPQSupport bobId <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption aPQ) sqSecured' <- acceptContact alice 1 bobId True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe @@ -1058,7 +1058,7 @@ runAgentClientContactDRTest_ asyncAccept asyncJoin addrIK useDR bPQ ps = withSmp else do sqSecuredJoin <- A.joinConnection bob NRMInteractive 1 aliceId True connReqJoin "bob's connInfo" bPQ SMSubscribe liftIO $ sqSecuredJoin `shouldBe` False - ("", _, A.REQ invId reqPQ _ "bob's connInfo") <- get alice + ("", _, A.REQ invId reqPQ _ "bob's connInfo" _) <- get alice liftIO $ reqPQ `shouldBe` PQSupportOn bobId <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption addrIK) if asyncAccept @@ -1092,7 +1092,7 @@ runCreateConnectionDRTest_ asyncNew addrIK bPQ ps = withSmpServer ps $ withAgent Nothing -> expectationFailure "createConnection must advertise DR ratchet keys" aliceId <- A.prepareConnectionToJoin bob 1 True connReq bPQ void $ A.joinConnection bob NRMInteractive 1 aliceId True connReq "bob's connInfo" bPQ SMSubscribe - ("", _, A.REQ invId _ _ "bob's connInfo") <- get alice + ("", _, A.REQ invId _ _ "bob's connInfo" _) <- get alice bobId <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption addrIK) void $ acceptContact alice 1 bobId True invId "alice's connInfo" (CR.connPQEncryption addrIK) SMSubscribe ("", _, A.CONF confId _ _ "alice's connInfo") <- get bob @@ -1117,7 +1117,7 @@ joinContactDR :: HasCallStack => AgentClient -> AgentClient -> ConnectionRequest joinContactDR alice requester connReq addrIK pqEnc = do aliceId <- A.prepareConnectionToJoin requester 1 True connReq PQSupportOn void $ A.joinConnection requester NRMInteractive 1 aliceId True connReq "bob's connInfo" PQSupportOn SMSubscribe - ("", _, A.REQ invId _ _ "bob's connInfo") <- get alice + ("", _, A.REQ invId _ _ "bob's connInfo" _) <- get alice reqId <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption addrIK) void $ acceptContact alice 1 reqId True invId "alice's connInfo" (CR.connPQEncryption addrIK) SMSubscribe ("", _, A.CONF confId _ _ "alice's connInfo") <- get requester @@ -1192,7 +1192,7 @@ testAddressUpdatePreservesDRKeys ps = withSmpServer ps $ withAgentClients2 $ \al aliceId <- A.prepareConnectionToJoin bob 1 True connReq' bPQ sqSecuredJoin <- A.joinConnection bob NRMInteractive 1 aliceId True connReq' "bob's connInfo" bPQ SMSubscribe liftIO $ sqSecuredJoin `shouldBe` False - ("", _, A.REQ invId _ _ "bob's connInfo") <- get alice + ("", _, A.REQ invId _ _ "bob's connInfo" _) <- get alice bobId <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption addrIK) _ <- acceptContact alice 1 bobId True invId "alice's connInfo" (CR.connPQEncryption addrIK) SMSubscribe ("", _, A.CONF confId _ _ "alice's connInfo") <- get bob @@ -1215,7 +1215,7 @@ testAcceptContactDRResumeAfterOffline ps = withAgentClients2 $ \alice bob -> do (_, _, connReq') <- getConnShortLink bob 1 shortLink aId <- A.prepareConnectionToJoin bob 1 True connReq' PQSupportOn _ <- A.joinConnection bob NRMInteractive 1 aId True connReq' "bob's connInfo" PQSupportOn SMSubscribe - ("", _, A.REQ invId _ _ "bob's connInfo") <- get alice + ("", _, A.REQ invId _ _ "bob's connInfo" _) <- get alice bId <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption addrIK) pure (bId, invId, aId) ("", "", DOWN _ _) <- nGet alice @@ -1244,7 +1244,7 @@ runAgentClientContactTestPQ3 viaProxy (alice, aPQ) (bob, bPQ) (tom, tPQ) baseId aId <- A.prepareConnectionToJoin b 1 True qInfo pq sqSecuredJoin <- A.joinConnection b NRMInteractive 1 aId True qInfo "bob's connInfo" pq SMSubscribe liftIO $ sqSecuredJoin `shouldBe` False -- joining via contact address connection - ("", _, A.REQ invId pqSup' _ "bob's connInfo") <- get alice + ("", _, A.REQ invId pqSup' _ "bob's connInfo" _) <- get alice liftIO $ pqSup' `shouldBe` PQSupportOn bId <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption aPQ) sqSecuredAccept <- acceptContact alice 1 bId True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe @@ -1290,7 +1290,7 @@ testRejectContactRequest = aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn sqSecured <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe liftIO $ sqSecured `shouldBe` False -- joining via contact address connection - ("", _, A.REQ invId PQSupportOn _ "bob's connInfo") <- get alice + ("", _, A.REQ invId PQSupportOn _ "bob's connInfo" _) <- get alice Left (A.CMD PROHIBITED _) <- tryError $ rejectContact alice NRMInteractive 1 invId (Just "no rejection without double ratchet") rejectContact alice NRMInteractive 1 invId Nothing liftIO $ noMessages bob "nothing delivered to bob" @@ -1302,7 +1302,7 @@ testRejectContactRequestDR = (_addrConnId, CCLink connReq _) <- A.createConnection alice NRMInteractive 1 True True SCMContact (Just userLinkData) Nothing IKPQOn True SMSubscribe aliceId <- A.prepareConnectionToJoin bob 1 True connReq PQSupportOn void $ A.joinConnection bob NRMInteractive 1 aliceId True connReq "bob's connInfo" PQSupportOn SMSubscribe - ("", _, A.REQ invId _ _ "bob's connInfo") <- get alice + ("", _, A.REQ invId _ _ "bob's connInfo" _) <- get alice rejectContact alice NRMInteractive 1 invId (Just "not now") ("", _, A.RJCT "not now") <- get bob pure () @@ -1314,7 +1314,7 @@ testRejectContactRequestDRAsync = (_addrConnId, CCLink connReq _) <- A.createConnection alice NRMInteractive 1 True True SCMContact (Just userLinkData) Nothing IKPQOn True SMSubscribe aliceId <- A.prepareConnectionToJoin bob 1 True connReq PQSupportOn void $ A.joinConnection bob NRMInteractive 1 aliceId True connReq "bob's connInfo" PQSupportOn SMSubscribe - ("", _, A.REQ invId _ _ "bob's connInfo") <- get alice + ("", _, A.REQ invId _ _ "bob's connInfo" _) <- get alice rejectContactAsync alice "1" 1 invId (Just "not now") ("", _, A.RJCT "not now") <- get bob pure () @@ -1327,7 +1327,7 @@ testServiceRequestResponse = withAgentClients2 $ \service client -> runRight_ $ do (_addrConnId, CCLink connReq _) <- A.createConnection service NRMInteractive 1 True True SCMContact (Just serviceUserLinkData) Nothing IKPQOn True SMSubscribe resp <- liftIO $ fst <$> concurrently - (runRight $ sendServiceRequest client NRMInteractive 1 connReq "service request") + (runRight $ sendServiceRequest client NRMInteractive 1 connReq Nothing "service request") (runRight_ $ do ("", _, SREQ invId "service request") <- get service sendServiceReply service NRMInteractive 1 invId "service response") @@ -1339,7 +1339,7 @@ testServiceRequestResponseAsync = withAgentClients2 $ \service client -> runRight_ $ do (_addrConnId, CCLink connReq _) <- A.createConnection service NRMInteractive 1 True True SCMContact (Just serviceUserLinkData) Nothing IKPQOn True SMSubscribe resp <- liftIO $ fst <$> concurrently - (runRight $ sendServiceRequest client NRMInteractive 1 connReq "service request") + (runRight $ sendServiceRequest client NRMInteractive 1 connReq Nothing "service request") (runRight_ $ do ("", _, SREQ invId "service request") <- get service sendServiceReplyAsync service "1" 1 invId "service response") @@ -1351,7 +1351,7 @@ testServiceRequestRejected = withAgentClients2 $ \service client -> runRight_ $ do (_addrConnId, CCLink connReq _) <- A.createConnection service NRMInteractive 1 True True SCMContact (Just serviceUserLinkData) Nothing IKPQOn True SMSubscribe resp <- liftIO $ fst <$> concurrently - (runExceptT $ sendServiceRequest client NRMInteractive 1 connReq "service request") + (runExceptT $ sendServiceRequest client NRMInteractive 1 connReq Nothing "service request") (runRight_ $ do ("", _, SREQ invId "service request") <- get service rejectServiceRequest service NRMInteractive 1 invId (Just "not allowed")) @@ -1369,7 +1369,7 @@ testServiceRequestResilient ps = withAgentClients2 $ \service client -> do pure connReq ("", "", DOWN _ _) <- nGet service -- server down: the async send is enqueued as a retried JOIN command and blocks for the response - reqAsync <- async $ runExceptT $ sendServiceRequestAsync client 1 connReq "resilient request" + reqAsync <- async $ runExceptT $ sendServiceRequestAsync client 1 connReq Nothing "resilient request" threadDelay 500000 -- let the enqueued send retry against the down server before bringing it up -- server up: the request is delivered and the service receives it invId <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do @@ -1640,7 +1640,7 @@ testContactErrors ps restart = do Right r -> error $ "unexpected result " <> show r Left _ -> putStrLn "retrying send" >> threadDelay 200000 >> loopSend loopSend - ("", _, A.REQ invId PQSupportOn _ "bob's connInfo") <- get a + ("", _, A.REQ invId PQSupportOn _ "bob's connInfo" _) <- get a pure invId ("", "", DOWN _ [_]) <- nGet a bId <- runRight $ A.prepareConnectionToAccept a 1 True invId PQSupportOn diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index aca0cf879..6aea60ff3 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -199,7 +199,7 @@ cData1 = deleted = False, ratchetSyncState = RSOk, pqSupport = CR.PQSupportOn, - serviceResponse = False + serviceRequestExpiresAt = Nothing } testPrivateAuthKey :: C.APrivateAuthKey From 95cc1668ccb7124bed460785dee1ef623f339a2b Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Thu, 23 Jul 2026 22:10:20 +0000 Subject: [PATCH 15/15] fixes --- .../2026-07-11-service-rpc-implementation.md | 148 ++++++++---------- src/Simplex/Messaging/Agent.hs | 102 +++++++----- src/Simplex/Messaging/Agent/Protocol.hs | 2 +- tests/AgentTests/FunctionalAPITests.hs | 18 ++- 4 files changed, 139 insertions(+), 131 deletions(-) diff --git a/plans/2026-07-11-service-rpc-implementation.md b/plans/2026-07-11-service-rpc-implementation.md index 9af045a44..d757bcf37 100644 --- a/plans/2026-07-11-service-rpc-implementation.md +++ b/plans/2026-07-11-service-rpc-implementation.md @@ -2,154 +2,134 @@ RFC: [../rfcs/2026-07-11-service-rpc.md](../rfcs/2026-07-11-service-rpc.md) -Depends on: [2026-07-12-address-dr-implementation.md](2026-07-12-address-dr-implementation.md). RPC establishes the double ratchet from the address exactly as the address-DR plan does; this is the RPC layer on top of it. Steps named R2'/R5'/O2'/O3' are from that plan. +Depends on: [2026-07-12-address-dr-implementation.md](2026-07-12-address-dr-implementation.md). RPC establishes the double ratchet from the address exactly as address-DR does; this is the RPC layer on top of it. -**Status: transport + rejection implemented and tested** (this repo). Service-side **idempotency** (single execution by request hash) is deferred. The `simplex-chat` integration (`RJCT` -> `XReject`/`XGrpReject`, bot consumption of `SREQ`) is a separate repo. +**Status: implemented and tested in this repo.** Service-side idempotency (single execution by request hash) is deferred. The `simplex-chat` integration is a separate repo. -**Scope.** One request, **one** response - no continuation, no streaming. +**Scope.** One request, one response — no continuation, no streaming. -**HTTP vs WebSocket.** RPC is the HTTP-shaped path: a single request and a single response, no persistent connection. A contact request is the WebSocket-shaped path: it opens a connection over which both sides then exchange messages. One DR-advertising address serves both, and the owner decides which per incoming request from the decrypted inner message - `AgentConnInfoReply` opens a connection, `AgentServiceRequest` answers an RPC. This is the HTTP-shaped path (the WebSocket-shaped path is the existing contact/connection flow). - -**Single-response shape.** A request gets exactly one reply, either a response or a rejection; no follow-up messages, no `final` flag, no callback, one payload per reply. So a response and a rejection are the *same operation*: each is the single confirming message on the requester's reply queue Q_A, after which the ephemeral reply connection is torn down. They differ only in the inner message (`AgentServiceResponse` payload vs `AgentRejection` reason) and the requester's outcome (the call returns the payload vs throws an agent error). The reply path is the rejection path, parameterized by the inner message. - -**No parallel flow.** On the receive side an RPC request and a contact invitation are the same message stored the same way - one `smpContactRequest` (renamed from `smpInvitationDR`) writes one `conn_invitations` row, differing only in a kind column (`is_service_request`) and the event (`REQ` vs `SREQ`). The kind makes the APIs exclusive: an invitation is only accepted, a request only responded to / rejected; the wrong API on the wrong kind is `CMD PROHIBITED`. The reply/reject send is the shared secure -> deliver-one-confirmation -> delete-with-wait-delivery path (`prepareReply` + `sendReplySync`/`sendReplyAsync`, the latter via the `ICReplyDel` internal command, renamed from `ICReject`). +One DR-advertising contact address serves both flows: the owner branches per incoming request on the decrypted inner message — `AgentConnInfoReply` opens a connection (`REQ`), `AgentServiceRequest` answers an RPC (`SREQ`). A request gets exactly one reply, a response or a rejection; both are the single confirming message on the requester's reply queue Q_A, after which the ephemeral reply connection is torn down. Response and rejection are the same operation parameterized by the inner message (`AgentServiceResponse` payload vs `AgentRejection` reason) and outcome (the call returns the payload vs throws an agent error). ## RPC messages -**No new outer envelope.** The request reuses `AgentContactRequest` (tag `'A'`, renamed from `AgentInvitationDR`); the one reply reuses `AgentConfirmation` (the confirming first message on Q_A - the only message, so never `AgentMsgEnvelope`). +No new outer envelope: the request reuses `AgentContactRequest` (tag `'A'`); the reply reuses `AgentConfirmation` (the only message on Q_A). -**Inner `AgentMessage`** (L4, ratchet-encrypted; parsed by `parseMessage`) - three headerless variants, siblings of `AgentConnInfoReply`: +Inner `AgentMessage` (ratchet-encrypted, parsed by `parseMessage`), siblings of `AgentConnInfoReply`: ```haskell -data AgentMessage - = ... -- AgentConnInfo 'I', AgentConnInfoReply 'D' (reply queue Q_A + profile), AgentMessage APrivHeader AMessage 'M', ... - | AgentServiceRequest (NonEmpty SMPQueueInfo) MsgBody -- 'A': request - reply queue Q_A + opaque payload - | AgentServiceResponse MsgBody -- 'P': response - opaque payload (single, terminal) - | AgentRejection ByteString -- 'J': refusal - opaque reason (single, terminal) - -AgentServiceRequest qs body -> smpEncode ('A', qs, Tail body) -AgentServiceResponse body -> smpEncode ('P', Tail body) -AgentRejection reason -> smpEncode ('J', Tail reason) + | AgentServiceRequest (NonEmpty SMPQueueInfo) MsgBody -- 'A': reply queue Q_A + opaque payload + | AgentServiceResponse MsgBody -- 'P': response payload (single, terminal) + | AgentRejection ByteString -- 'J': refusal reason (single, terminal) ``` -`AgentServiceRequest` carries Q_A (as `AgentConnInfoReply` does) so the service knows where to reply; its constructor is the only thing that tells `REQ` from `SREQ`. `AgentServiceResponse`/`AgentRejection` are each the sole message on Q_A - no header, no `final`, no `NonEmpty`. `AgentMessageType` `AM_SRV_REQ`/`AM_SRV_RESP`/`AM_RJCT`: **`AM_SRV_RESP` and `AM_RJCT` both route to `sendConfirmation`** in the delivery worker (the reply is always the confirming first message on Q_A); there is no later-message path for RPC, so `agentClientMsg` is unchanged. +`AgentServiceRequest` carries Q_A (as `AgentConnInfoReply` does); its constructor is the only thing that distinguishes `REQ` from `SREQ`. Delivery `msgType`: `AM_SRV_RESP` routes to `sendConfirmation` (the reply is the confirming first message on Q_A). `AM_SRV_REQ` is never stored — the request is sent synchronously inside `joinConnSrv'` via `sendInvitation`, so its arms in the delivery worker are unreachable and assert (`logError`). + +## Ratchet establishment — reuse of the address-DR flow -## Ratchet establishment - reuse of the address-DR flow +`joinConnSrv'` takes `mkInner :: SMPQueueInfo -> AgentMessage`; `joinConnSrv` is the one-line wrapper passing `AgentConnInfoReply`. `sendServiceRequest'` passes `AgentServiceRequest`. -**Request (client)** - address-DR requester path, inner is `AgentServiceRequest`. The client send reuses `joinConnSrv`, parameterized **in place**: `joinConnSrv'` takes an `mkInner :: SMPQueueInfo -> AgentMessage` and only the `sndReply` line changed; `joinConnSrv = joinConnSrv' … (\rq -> AgentConnInfoReply (rq :| []) cInfo)` is the one-line wrapper, so existing call sites are unchanged. `sendServiceRequest` calls `joinConnSrv' … (\rq -> AgentServiceRequest (rq :| []) payload)`. +**Request (client).** `serviceRequest_` fails fast with `A_SERVICE ASENotDRAddress` if the address carries no ratchet keys, then creates the client connection via `newConnToJoin` with `serviceRequestExpiresAt = Just (now + reqTimeout)` (the persisted per-request deadline), registers a one-shot `TMVar` in `serviceRequests`, sends the request, and blocks on the `TMVar` up to `reqTimeout`. The connection is `RcvConnection` (Q_A) with the send ratchet. -- Negotiate the advertised ratchet params, create Q_A (messaging mode, subscribed), establish the send ratchet, send `AgentContactRequest {e2eSndParams, ratchetKeyId, encConnInfo = ratchetEncrypt(AgentServiceRequest (Q_A :| []) payload)}` to the address, unauthenticated. The client connection is `RcvConnection` (Q_A) with the send ratchet; its `created_at` is set (`setConnServiceReply`) to mark it a reply queue for cleanup and for the `serviceReply` flag. +**Request (service).** `smpContactRequest` decrypts `encConnInfo` and branches on the inner message; both branches call the same `storeInvitation` → `conn_invitations`, differing only in the kind column and event: -**Request (service)** - `smpContactRequest` (renamed `smpInvitationDR`): decrypt `encConnInfo`, then branch on the inner message. **Both branches call the same `storeInvitation` -> `conn_invitations`**, writing the kind column; they differ only in the event: +- `AgentConnInfoReply` → `REQ` (`service_request = 0`). +- `AgentServiceRequest _ payload` → `SREQ invId payload` (`service_request = 1`). -- `AgentConnInfoReply` -> `REQ invId ...` (`is_service_request = 0`, unchanged). -- `AgentServiceRequest _ payload` -> `SREQ invId payload` (`is_service_request = 1`). +Before storing, it **deduplicates** by the sender's ratchet-key hash (`checkRatchetKeyHashExists`/`addProcessedRatchetKeyHash`, the mechanism `newRatchetKey` uses): a redelivered/retried request reuses the same Q_A and the same `e2eSndParams`, so the hash matches and the duplicate is dropped — one invitation and one `REQ`/`SREQ` per request. Receive-time establishment on unauthenticated input — the address-DR abuse bound applies. -The service holds the request as an invitation with the payload as `recipient_conn_info`; no connection yet. Receive-time establishment on unauthenticated input - the address-DR abuse bound applies. +**The reply (service).** `prepareReply` fetches the invitation, enforces the kind (`CMD PROHIBITED` on the wrong one), and rejects a stale request (`A_SERVICE ASETimeout` + delete) older than `serviceResponseTimeout`; then `newConnToAccept` + `startJoinInvitationDR` build the one-directional `SndQueue` to Q_A (no reply queue back), and `storeConfirmation` queues the inner message. `sendReplySync` secures Q_A, submits the message, and deletes the connection with wait-for-delivery — **deleting the connection on failure too** (`catchAllErrors`), so a failed secure/submit does not orphan it. `sendServiceReplyAsync` defers secure+deliver+delete to the `ICReplyDel` command (retried, survives a down server). `sendServiceReply`/`Async` and `replyRequest_` return the reply `ConnId` so the caller can correlate the `SENT` event on that throwaway connection. -**The one reply (service)** - `sendServiceReply c nm userId invId payload` (accept-and-tear-down; the rejection path with a payload). `CMD PROHIBITED` if the invitation is a contact invitation (wrong kind), or `A_SERVICE ASETimeout` (+ delete the invitation) if it is older than `serviceReplyTimeout`; a repeat on an answered request just fails to find a pending record: +**The response (client).** The single `AgentConfirmation` on Q_A reaches `processConnInfo` (the `RcvConnection … New` branch). Dispatch is gated on `serviceRequestExpiresAt` and the kinds are mutually exclusive: -- `newConnToAccept` creates the ephemeral reply connection; `startJoinInvitationDR` builds the `SndQueue` to Q_A and the ratchet - **no reply queue back** (one-directional; the divergence from `acceptContact'`). -- `storeConfirmation` the pending `AgentServiceResponse payload` (`AM_SRV_RESP`); `acceptInvitation`; then secure Q_A + deliver + `deleteConnectionAsync' True` (`sendReplySync`). Async `sendServiceReplyAsync` defers secure+deliver+delete to `ICReplyDel` (`sendReplyAsync`, retried, never fails client-side, survives a down server). Returns `()`. +- `AgentConnInfoReply` **only when `isNothing serviceRequestExpiresAt`** (a contact connection) → `processConf`. +- `AgentServiceResponse` only when `isJust` → the request `TMVar` gets `Right payload`. +- `AgentRejection` when `isJust` → `Left (A_SERVICE (ASERejected reason))`; when `isNothing` → contact `RJCT`. +- anything else → `prohibited`. -**The one response (client)** - the single `AgentConfirmation` on Q_A -> `smpConfirmation`'s `RcvConnection … Nothing` branch (already parsing `AgentConnInfoReply`/`AgentRejection`), extended, gated on the connection's `serviceReply` flag: `AgentServiceResponse payload` -> the request's `TMVar` gets `Right payload`; `AgentRejection reason` -> `Left (AGENT (A_SERVICE (ASERejected reason)))`; if `serviceReply` is set but there is no `TMVar` (post-restart), an `ERR (AGENT (A_SERVICE ASENoRequest))` event; if `serviceReply` is not set, `AgentRejection` is a contact rejection -> `RJCT`. The waiting `sendServiceRequest` unwraps the `TMVar` and tears Q_A down (`deleteConnectionAsync' True`). No later-message path. +The `isNothing` guard on `AgentConnInfoReply` is a security boundary: without it a malicious service could send `AgentConnInfoReply` on an RPC reply queue and drive it into the contact-`CONF` path. `dispatchServiceReply` puts the result into the `serviceRequests` `TMVar`; a reply with no pending request (e.g. post-restart) is `ERR (A_SERVICE ASENoPendingRequest)`. ## Rejection -A rejection is `AgentRejection reason` - the same single confirming message on Q_A as a response, always tearing the connection down. It refuses an RPC request and, unchanged, a contact request. +A rejection is `AgentRejection reason` — the same single confirming message on Q_A as a response. -- **Kind guard** (`prepareReply`): `rejectContact` only on a contact invitation, `rejectServiceRequest`/`sendServiceReply` only on a request; the wrong kind is `CMD PROHIBITED`. An accepted/responded request is not pending (`getInvitation` filters `accepted = 0`), so the reject fails to find it, as a repeat should. -- `rejectContact`/`rejectContactAsync` / `rejectServiceRequest`/`rejectServiceRequestAsync` take `Maybe ByteString`: `Nothing` -> silent drop (delete the invitation, no message); `Just reason` -> `CMD PROHIBITED` on a classic `CRInvitation` (no ratchet) or the wrong kind; else the reply path with `AgentRejection` as the inner message. -- Requester side: `AgentRejection` on a contact reply queue -> `RJCT` event to chat (async, mapped to `XReject`/`XGrpReject`); on an RPC reply queue -> a thrown `A_SERVICE (ASERejected reason)` ending `sendServiceRequest` (synchronous). +- **Kind guard.** `rejectContact` only on a contact invitation, `rejectServiceRequest`/`sendServiceReply` only on a request; wrong kind is `CMD PROHIBITED`. `rejectRequest_` enforces the kind **even on a `Nothing` (silent-drop) reject** — it fetches the invitation and checks before deleting, so `rejectContact … Nothing` cannot delete a service request (or vice versa). +- `reject*` take `Maybe ByteString`: `Nothing` → delete the invitation, send nothing (the requester times out); `Just reason` → the reply path with `AgentRejection`. +- Requester side: `AgentRejection` on a contact reply queue → `RJCT`; on an RPC reply queue → a thrown `A_SERVICE (ASERejected reason)`. ## Reply connections and cleanup -No reply-queue table and no new connection type - both reply connections are ordinary connections with a ratchet. +No reply-queue table and no new connection type. -- **The `serviceReply` flag** is on `ConnData`, loaded by `getConnData` as `created_at IS NOT NULL`; `connections.created_at` is non-null only on a client RPC reply queue (set by `sendServiceRequest`). -- **Client reply queue** (`RcvConnection` on Q_A): routed by the in-memory `serviceRequests :: TMap ConnId (TMVar (Either AgentErrorType MsgBody))` in `AgentClient` - `sendServiceRequest` inserts a one-shot, the receive path fills it. The normal path tears the queue down within the call; only a client restart mid-call orphans it, reaped by `created_at` age. -- **Service reply connection** (`SndConnection` to Q_A): ephemeral - created, sends the one reply, deleted with wait-for-delivery in the same operation. -- **Cleanup** (`cleanupManager`, one added step, using `serviceReplyTimeout` as the TTL): `deleteExpiredServiceRequests` reaps unanswered `conn_invitations` (kind = request) by `created_at`; `getExpiredServiceReplyConnIds` -> `deleteConnectionsAsync'` reaps orphaned client reply queues (`connections.created_at` non-null, not deleted, past the TTL). +- **Requester reply queue** (`RcvConnection` on Q_A): `connections.service_request_expires_at` is non-null only here; it is the persisted request deadline, used both to gate CONF dispatch and to reap the connection. In-memory routing is `serviceRequests :: TMap ConnId (TMVar (Either AgentErrorType MsgBody))`. +- **Timeout race.** The async `JOIN` worker holds `withConnLock c connId` around `joinConnSrv'`, and `serviceRequest_`'s cleanup holds the same lock around `TM.delete` + `deleteConnectionAsync'`. This serializes the send with the timeout teardown, so a timing-out call cannot delete the connection mid-send; after cleanup the worker's re-check of `serviceRequests` finds nothing and skips. +- **Service reply connection** (`SndConnection` to Q_A): ephemeral — created, sends the one reply, deleted with wait-for-delivery in the same operation. +- **Cleanup** (`cleanupManager`, `deleteExpiredServiceReqs`): `deleteExpiredServiceRequests` reaps unanswered `conn_invitations` (service side) older than `serviceResponseTimeout`; `getExpiredServiceConns` (`service_request_expires_at < now`) → `deleteConnectionsAsync'` reaps orphaned requester reply queues. ## Database schema -Combined into the address-DR migration - `M20260712_address_dr_rpc` (SQLite + PostgreSQL) creates `address_ratchet_keys` (address-DR) and adds the two RPC columns: +`M20260712_address_dr_rpc` (SQLite + PostgreSQL) creates `address_ratchet_keys` (address-DR) and adds: ```sql --- ... address_ratchet_keys table + index (address-DR) ... -ALTER TABLE conn_invitations ADD COLUMN is_service_request INTEGER NOT NULL DEFAULT 0; -- 1 = RPC request, 0 = contact invitation -ALTER TABLE connections ADD COLUMN created_at TEXT; -- non-null on a client RPC reply queue; marker + cleanup age (nullable) +ALTER TABLE conn_invitations ADD COLUMN service_request INTEGER NOT NULL DEFAULT 0; -- service side: 1 = RPC request +ALTER TABLE connections ADD COLUMN service_request_expires_at TEXT; -- client side: request deadline; gating + cleanup (nullable) ``` -The down migration drops the columns then the table/index. Schema dump tests pass (up, down, STRICT). The deferred idempotency work will add its own tables when built. +The down migration drops the columns then the table/index. Schema dump tests pass (up, down, STRICT). -## Agent API - `Simplex.Messaging.Agent` - -Service side (a service publishes an ordinary DR-advertising contact address; the same address accepts both connections and RPC): +## Agent API — `Simplex.Messaging.Agent` ```haskell --- Sends the one response to the request from SREQ's invitation id, then tears the reply connection down. -sendServiceReply :: AgentClient -> NetworkRequestMode -> UserId -> InvitationId -> MsgBody -> AE () -sendServiceReplyAsync :: AgentClient -> ACorrId -> UserId -> InvitationId -> MsgBody -> AE () +-- service: send the one response, return the reply ConnId, then tear the reply connection down. +sendServiceReply :: AgentClient -> NetworkRequestMode -> UserId -> InvitationId -> MsgBody -> AE ConnId +sendServiceReplyAsync :: AgentClient -> ACorrId -> UserId -> InvitationId -> MsgBody -> AE ConnId --- Refuses a request (Just reason = AgentRejection to Q_A; Nothing = silent drop). PROHIBITED on wrong kind. +-- refuse a request (Just reason = AgentRejection; Nothing = silent drop). PROHIBITED on wrong kind. rejectServiceRequest :: AgentClient -> NetworkRequestMode -> UserId -> InvitationId -> Maybe ByteString -> AE () rejectServiceRequestAsync :: AgentClient -> ACorrId -> UserId -> InvitationId -> Maybe ByteString -> AE () - --- contact rejection, now sharing prepareReply + the kind guard: rejectContact :: AgentClient -> NetworkRequestMode -> UserId -> ConfirmationId -> Maybe ByteString -> AE () rejectContactAsync :: AgentClient -> ACorrId -> UserId -> ConfirmationId -> Maybe ByteString -> AE () -``` - -Client side: -```haskell --- Both establish the ratchet from the address, create Q_A, send the request, and block on the reply TMVar up to --- serviceRequestTimeout, returning the payload (a rejection or timeout is a thrown agent error). No callback. --- Sync: the send is direct and fails fast if the server is down. Async: the send is enqueued as a retried command. -sendServiceRequest :: AgentClient -> NetworkRequestMode -> UserId -> ConnectionRequestUri 'CMContact -> MsgBody -> AE MsgBody -sendServiceRequestAsync :: AgentClient -> UserId -> ConnectionRequestUri 'CMContact -> MsgBody -> AE MsgBody +-- client: establish the ratchet from the address, send the request, block on the reply TMVar up to the timeout +-- (Nothing = serviceRequestTimeout; Just t overrides per request), returning the payload. Sync fails fast if the +-- server is down; async enqueues a retried JOIN command that survives an outage. +sendServiceRequest :: AgentClient -> NetworkRequestMode -> UserId -> ConnectionRequestUri 'CMContact -> Maybe NominalDiffTime -> MsgBody -> AE MsgBody +sendServiceRequestAsync :: AgentClient -> UserId -> ConnectionRequestUri 'CMContact -> Maybe NominalDiffTime -> MsgBody -> AE MsgBody ``` -Both share `serviceRequest_` (create Q_A + mark `created_at` + register the `TMVar` + block on it up to `serviceRequestTimeout` + tear down); they differ only in the send. **Sync** calls `joinConnSrv'` directly - it fails fast on `BROKER NETWORK` if the server is down (`NRMBackground` only sets the per-attempt timeout, it does not retry a refused connection). **Async** enqueues an ordinary `JOIN (JRConnReq …)` command, which the command worker runs through `tryCommand` (`withRetryInterval`/`temporaryOrHostError`, the same retry the reply's `ICReplyDel` uses) - so the send survives a server outage. No new command or serialization: the `JOIN` worker branches on the reply queue's `serviceReply` flag (persistent, from `created_at`) to send `AgentServiceRequest` via `joinConnSrv'` instead of `AgentConnInfoReply`, and skips the `JOINED` event. Either way the call blocks on the `TMVar` and returns the response synchronously - no events, so the app has no correlation to do. There is no `cancelServiceRequest` - an aborted call's Q_A is reaped by `created_at`. +Both client calls share `serviceRequest_`; the async `JOIN` worker branches on the `JRServiceReq` command to send `AgentServiceRequest`. The call blocks on the `TMVar` and returns synchronously — no events, no correlation for the app. Events (`AEvent`, entity is the address connection): ```haskell -SREQ :: InvitationId -> MsgBody -> AEvent AEConn -- mirrors REQ (InvitationId); payload = the request. -RJCT :: ConnInfo -> AEvent AEConn -- contact-request rejection reason to chat. +SREQ :: InvitationId -> MsgBody -> AEvent AEConn -- payload = the request; mirrors REQ. +RJCT :: ConnInfo -> AEvent AEConn -- contact-request rejection reason. ``` -Errors (`SMPAgentError`, mirroring `A_CRYPTO {cryptoErr :: AgentCryptoError}`): +Errors (`SMPAgentError`): ```haskell | A_SERVICE {serviceError :: AgentServiceError} data AgentServiceError - = ASERejected {rejectReason :: String} -- the service refused, reason as latin1 String (bytes round-trip) - | ASETimeout -- no reply within the timeout (client wait, or a late service reply) - | ASENoRequest -- a reply arrived with no pending request (e.g. post-restart) + = ASERejected {rejectReason :: Text} -- service refused (Text: JSON-serializable, UTF-8-decoded from the reason bytes) + | ASETimeout -- no reply within the timeout + | ASENoPendingRequest -- a reply arrived with no pending request (e.g. post-restart) + | ASENotDRAddress -- the target address advertises no ratchet keys (fail fast, no send) ``` -Config (`AgentConfig`): `serviceRequestTimeout` (30 s, the client wait) and `serviceReplyTimeout` (180 s, the service reply window and the cleanup TTL; must exceed `serviceRequestTimeout`). +Config (`AgentConfig`): `serviceRequestTimeout` (30 s, client wait, overridable per request) and `serviceResponseTimeout` (180 s, service reply window and cleanup TTL; must exceed `serviceRequestTimeout`). ## Idempotency (deferred) -Not built. When built, the service will key a request by hash and cache the one response for a retention period, so a repeat request is answered from storage without reaching the bot - single execution over at-least-once delivery, with its own tables. +Not built. When built, the service will key a request by hash and cache the one response for a retention period, answering a repeat from storage without reaching the bot — single execution over at-least-once delivery, with its own tables. ## Tests -Implemented and passing (in `FunctionalAPITests`, plus the encoding roundtrip in `ConnectionRequestTests`): - -- Encoding roundtrip: `AgentServiceRequest`/`AgentServiceResponse`/`AgentRejection` (headerless single) + the `AgentContactRequest` rename. -- Request -> one response (sync `sendServiceReply`). -- Request -> one response (async `sendServiceReplyAsync`). -- Request -> rejection (`rejectServiceRequest (Just reason)` -> thrown `A_SERVICE (ASERejected …)`). -- **Resilience**: `server down -> send -> up -> receive -> down -> reply -> up -> receive response` - the send (`sendServiceRequestAsync`) is enqueued and retried through the outage, the reply (`sendServiceReplyAsync`) is queued and delivered on reconnect; both blocking calls receive their result. -- No regression: the existing rejection + schema tests still pass. - -Not yet covered (code-complete): the wrong-kind `CMD PROHIBITED` guards; the client timeout (`ASETimeout`); the late-reply timeout (`serviceReplyTimeout`); `cleanupManager` reaping; the `ASENoRequest` post-restart path. A full `simplexmq-test` run and the PostgreSQL migration path are also not yet run here. +In `FunctionalAPITests` (plus the encoding roundtrip in `ConnectionRequestTests`), passing with `-O0`: -## Status +- Request → one response, sync (`sendServiceReply`) and async (`sendServiceReplyAsync`). +- Request → rejection (`rejectServiceRequest (Just reason)` → thrown `A_SERVICE (ASERejected …)`). +- Resilience: `server down → send → up → receive → down → reply → up → receive response`. +- No regression: the contact rejection and DR-join suites still pass. -Both implementation phases are done and compile clean. Remaining in this repo: the test gaps above, a full suite run, and the PostgreSQL path. Separate `simplex-chat` repo: `RJCT` -> `XReject`/`XGrpReject`, bot consumption of `SREQ` / `sendServiceReply`, and `sendServiceRequest` on the client. Later, separate pass: idempotency. +The `simplex-chat` end-to-end tests (happy path, drop-when-off, non-DR fail-fast) live in that repo. diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 9a4ba192c..2565a7a5e 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -514,11 +514,11 @@ rejectContactAsync :: AgentClient -> ACorrId -> UserId -> ConfirmationId -> Mayb rejectContactAsync c = withAgentEnv c .:: rejectContactAsync' c {-# INLINE rejectContactAsync #-} -sendServiceReply :: AgentClient -> NetworkRequestMode -> UserId -> InvitationId -> MsgBody -> AE () +sendServiceReply :: AgentClient -> NetworkRequestMode -> UserId -> InvitationId -> MsgBody -> AE ConnId sendServiceReply c = withAgentEnv c .:: sendServiceReply' c {-# INLINE sendServiceReply #-} -sendServiceReplyAsync :: AgentClient -> ACorrId -> UserId -> InvitationId -> MsgBody -> AE () +sendServiceReplyAsync :: AgentClient -> ACorrId -> UserId -> InvitationId -> MsgBody -> AE ConnId sendServiceReplyAsync c = withAgentEnv c .:: sendServiceReplyAsync' c {-# INLINE sendServiceReplyAsync #-} @@ -1656,24 +1656,34 @@ rejectServiceRequestAsync' c = rejectRequest_ c True . sendReplyAsync c rejectRequest_ :: AgentClient -> Bool -> ((ConnId, ConnData, SndQueue) -> AM ()) -> UserId -> InvitationId -> Maybe ByteString -> AM () rejectRequest_ c serviceRequest sendReply userId invId reason_ = do - mapM_ ((sendReply =<<) . prepareReply c userId invId serviceRequest . AgentRejection) reason_ + case reason_ of + Just reason -> sendReply =<< prepareReply c userId invId serviceRequest (AgentRejection reason) + Nothing -> do + Invitation {serviceRequest = isServiceRequest} <- withStore c $ \db -> getInvitation db "rejectRequest_" invId + when (isServiceRequest /= serviceRequest) $ throwE $ CMD PROHIBITED kindErr withStore' c (`deleteInvitation` invId) + where + kindErr + | serviceRequest = "rejectServiceRequest: not a service request, use rejectContact" + | otherwise = "rejectContact: service request, use rejectServiceRequest" -sendServiceReply' :: AgentClient -> NetworkRequestMode -> UserId -> InvitationId -> MsgBody -> AM () +sendServiceReply' :: AgentClient -> NetworkRequestMode -> UserId -> InvitationId -> MsgBody -> AM ConnId sendServiceReply' c = replyRequest_ c . sendReplySync c -sendServiceReplyAsync' :: AgentClient -> ACorrId -> UserId -> InvitationId -> MsgBody -> AM () +sendServiceReplyAsync' :: AgentClient -> ACorrId -> UserId -> InvitationId -> MsgBody -> AM ConnId sendServiceReplyAsync' c = replyRequest_ c . sendReplyAsync c -replyRequest_ :: AgentClient -> ((ConnId, ConnData, SndQueue) -> AM ()) -> UserId -> InvitationId -> MsgBody -> AM () +replyRequest_ :: AgentClient -> ((ConnId, ConnData, SndQueue) -> AM ()) -> UserId -> InvitationId -> MsgBody -> AM ConnId replyRequest_ c sendReply userId invId resp = do - sendReply =<< prepareReply c userId invId True (AgentServiceResponse resp) + reply@(connId, _, _) <- prepareReply c userId invId True (AgentServiceResponse resp) + sendReply reply withStore' c (`deleteInvitation` invId) + pure connId sendReplySync :: AgentClient -> NetworkRequestMode -> (ConnId, ConnData, SndQueue) -> AM () sendReplySync c nm (connId, cData, sq) = do - void $ agentSecureSndQueue c nm cData sq - lift $ submitPendingMsg c sq + (void (agentSecureSndQueue c nm cData sq) >> lift (submitPendingMsg c sq)) + `catchAllErrors` \e -> deleteConnectionAsync' c True connId >> throwE e deleteConnectionAsync' c True connId sendReplyAsync :: AgentClient -> ACorrId -> (ConnId, ConnData, SndQueue) -> AM () @@ -1725,8 +1735,9 @@ serviceRequest_ c userId cReqUri@(CRContactUri _ addrKeys_) timeout_ doSend = do liftIO $ do expired <- registerDelay $ round (reqTimeout * 1000000) atomically $ takeTMVar var `orElse` (readTVar expired >>= \e -> if e then pure (Left $ AGENT $ A_SERVICE ASETimeout) else retry) - atomically $ TM.delete connId (serviceRequests c) - deleteConnectionAsync' c True connId + withConnLock c connId "serviceRequest_" $ do + atomically $ TM.delete connId (serviceRequests c) + deleteConnectionAsync' c True connId liftEither $ join r syncConnections' :: AgentClient -> [UserId] -> [ConnId] -> AM (DatabaseDiff UserId, DatabaseDiff ConnId) @@ -2153,14 +2164,15 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do JOIN (JRServiceReq cReq@(CRContactUri ConnReqUriData {crSmpQueues = q :| _} _) pqEnc) subMode connInfo -> noServer $ do triedHosts <- newTVarIO S.empty tryCommand . withNextSrv c userId storageSrvs triedHosts [qServer q] $ \srv -> - atomically (TM.lookup connId (serviceRequests c)) >>= \case - Nothing -> pure () - Just v -> - void (joinConnSrv' c NRMBackground userId connId False cReq connInfo pqEnc subMode srv $ \replyQInfo -> AgentServiceRequest (replyQInfo :| []) connInfo) - `catchAllErrors` \e -> - if temporaryOrHostError e - then throwE e - else atomically $ void $ tryPutTMVar v $ Left e -- will not overwrite existing result + withConnLock c connId "JOIN service request" $ + atomically (TM.lookup connId (serviceRequests c)) >>= \case + Nothing -> pure () + Just v -> + void (joinConnSrv' c NRMBackground userId connId False cReq connInfo pqEnc subMode srv $ \replyQInfo -> AgentServiceRequest (replyQInfo :| []) connInfo) + `catchAllErrors` \e -> + if temporaryOrHostError e + then throwE e + else atomically $ void $ tryPutTMVar v $ Left e -- will not overwrite existing result LET confId ownCInfo -> withServer' . tryCommand $ allowConnection' c connId confId ownCInfo >> notify OK ACK msgId rcptInfo_ -> withServer' . tryCommand $ ackMessage' c connId msgId rcptInfo_ >> notify OK SWCH -> @@ -2494,7 +2506,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} sq@SndQueue {userId, connId, server, AM_QUSE_ -> qError msgId "QUSE: AUTH" AM_QTEST_ -> qError msgId "QTEST: AUTH" AM_EREADY_ -> notifyDel msgId err - AM_SRV_REQ -> notifyDel msgId err + AM_SRV_REQ -> logError "AM_SRV_REQ: unexpected stored message" >> delMsg msgId AM_SRV_RESP -> notifyDel msgId err AM_RJCT -> notifyDel msgId err _ @@ -2581,7 +2593,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} sq@SndQueue {userId, connId, server, _ -> internalErr msgId "sent QTEST: queue not in connection or not replacing another queue" _ -> internalErr msgId "QTEST sent not in duplex connection" AM_EREADY_ -> pure () - AM_SRV_REQ -> notify $ SENT mId proxySrv_ + AM_SRV_REQ -> logError "AM_SRV_REQ: unexpected stored message" AM_SRV_RESP -> notify $ SENT mId proxySrv_ AM_RJCT -> pure () delMsgKeep (msgType == AM_A_MSG_) msgId @@ -3706,14 +3718,14 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar (agentMsgBody_, rc') <- decryptConnInfo rc encConnInfo case agentMsgBody_ of Right agentMsgBody -> parseMessage agentMsgBody >>= \case - AgentConnInfoReply smpQueues connInfo -> do + AgentConnInfoReply smpQueues connInfo | isNothing serviceRequestExpiresAt -> do processConf rc' connInfo SMPConfirmation {senderKey, e2ePubKey, connInfo, smpReplyQueues = L.toList smpQueues, smpClientVersion = phVer} withStore' c $ \db -> updateRcvMsgHash db connId 1 (InternalRcvId 0) (C.sha256Hash agentMsgBody) AgentServiceResponse payload | isJust serviceRequestExpiresAt -> dispatchServiceReply $ Right payload AgentRejection reason - | isJust serviceRequestExpiresAt -> dispatchServiceReply $ Left $ AGENT $ A_SERVICE $ ASERejected $ B.unpack reason + | isJust serviceRequestExpiresAt -> dispatchServiceReply $ Left $ AGENT $ A_SERVICE $ ASERejected $ safeDecodeUtf8 reason | otherwise -> notify $ RJCT reason - _ -> prohibited "conf: not AgentConnInfoReply" -- including AgentConnInfo, that is prohibited here in v2 + _ -> prohibited "conf: unexpected message for connection kind" Left _ -> prohibited "conf: decrypt error" where dispatchServiceReply result = do @@ -3953,28 +3965,36 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar ContactConnection {} -> do checkConfVersions agentVersion phVer let ConnData {pqSupport} = toConnData conn' - withStore' c (\db -> getAddressRatchetKeys db connId ratchetKeyId) >>= \case - Right (pk1, pk2, pKem) -> do - (rc, connPQSupport) <- initRcvRatchet_ agentVersion pqSupport (pk1, pk2, pKem) e2eSndParams - (agentMsgBody_, ratchetState) <- decryptConnInfo rc encConnInfo - case agentMsgBody_ of - Right agentMsgBody -> do - let mkDR replyQueue = DRInvitation {ratchetState, replyQueue, agentVersion, pqSupport = connPQSupport} - parseMessage agentMsgBody >>= \case - AgentConnInfoReply (replyQueue :| _) cInfo -> do - invId <- storeInvitation (CRInvitationDR $ mkDR replyQueue) cInfo False - notify $ REQ invId pqSupported (qServer replyQueue :| []) cInfo True - AgentServiceRequest (replyQueue :| _) payload -> do - invId <- storeInvitation (CRInvitationDR $ mkDR replyQueue) payload True - notify $ SREQ invId payload - _ -> prohibited "addr inv: not a contact request" - Left _ -> prohibited "addr inv: decrypt error" - Left _ -> prohibited "addr inv: unknown ratchetKeyId" + unlessM duplicateRequest $ + withStore' c (\db -> getAddressRatchetKeys db connId ratchetKeyId) >>= \case + Right (pk1, pk2, pKem) -> do + (rc, connPQSupport) <- initRcvRatchet_ agentVersion pqSupport (pk1, pk2, pKem) e2eSndParams + (agentMsgBody_, ratchetState) <- decryptConnInfo rc encConnInfo + case agentMsgBody_ of + Right agentMsgBody -> do + let mkDR replyQueue = DRInvitation {ratchetState, replyQueue, agentVersion, pqSupport = connPQSupport} + parseMessage agentMsgBody >>= \case + AgentConnInfoReply (replyQueue :| _) cInfo -> do + invId <- storeInvitation (CRInvitationDR $ mkDR replyQueue) cInfo False + notify $ REQ invId pqSupported (qServer replyQueue :| []) cInfo True + AgentServiceRequest (replyQueue :| _) payload -> do + invId <- storeInvitation (CRInvitationDR $ mkDR replyQueue) payload True + notify $ SREQ invId payload + _ -> prohibited "addr inv: not a contact request" + Left _ -> prohibited "addr inv: decrypt error" + Left _ -> prohibited "addr inv: unknown ratchetKeyId" _ -> prohibited "inv: sent to message conn" where pqSupported = case e2eSndParams of CR.AE2ERatchetParams _ (CR.E2ERatchetParams e2eVersion _ _ _) -> PQSupportOn `CR.pqSupportAnd` versionPQSupport_ agentVersion (Just e2eVersion) + duplicateRequest = case e2eSndParams of + CR.AE2ERatchetParams _ (CR.E2ERatchetParams _ k1 k2 _) -> do + let rkHash = C.sha256Hash $ C.pubKeyBytes k1 <> C.pubKeyBytes k2 + withStore' c $ \db -> do + exists <- checkRatchetKeyHashExists db connId rkHash + unless exists $ addProcessedRatchetKeyHash db connId rkHash + pure exists qDuplex :: Connection c -> String -> (Connection 'CDuplex -> AM a) -> AM a qDuplex conn' name action = case conn' of diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 720c2d683..c0ebce302 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -2203,7 +2203,7 @@ data SMPAgentError deriving (Eq, Show, Exception) data AgentServiceError - = ASERejected {rejectReason :: String} + = ASERejected {rejectReason :: Text} | ASETimeout | ASENoPendingRequest | ASENotDRAddress diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index f2b1ff3fb..ddef61eed 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -1330,7 +1330,9 @@ testServiceRequestResponse = (runRight $ sendServiceRequest client NRMInteractive 1 connReq Nothing "service request") (runRight_ $ do ("", _, SREQ invId "service request") <- get service - sendServiceReply service NRMInteractive 1 invId "service response") + replyConnId <- sendServiceReply service NRMInteractive 1 invId "service response" + ("", sentConnId, A.SENT _ _) <- get service + liftIO $ sentConnId `shouldBe` replyConnId) liftIO $ resp `shouldBe` "service response" liftIO $ threadDelay 250000 -- let the async teardown of the reply queues settle before dispose @@ -1342,7 +1344,9 @@ testServiceRequestResponseAsync = (runRight $ sendServiceRequest client NRMInteractive 1 connReq Nothing "service request") (runRight_ $ do ("", _, SREQ invId "service request") <- get service - sendServiceReplyAsync service "1" 1 invId "service response") + replyConnId <- sendServiceReplyAsync service "1" 1 invId "service response" + ("", sentConnId, A.SENT _ _) <- get service + liftIO $ sentConnId `shouldBe` replyConnId) liftIO $ resp `shouldBe` "service response" liftIO $ threadDelay 250000 -- let the async teardown of the reply queues settle before dispose @@ -1378,9 +1382,13 @@ testServiceRequestResilient ps = withAgentClients2 $ \service client -> do pure invId :: ExceptT AgentErrorType IO InvitationId ("", "", DOWN _ _) <- nGet service -- server down: the service replies; the async reply is enqueued and retried until the server is back - runRight_ $ sendServiceReplyAsync service "1" 1 invId "resilient response" - -- server up: the reply is delivered and the requester's blocking call returns the response - resp <- withSmpServerStoreLogOn ps testPort $ \_ -> wait reqAsync + replyConnId <- runRight $ sendServiceReplyAsync service "1" 1 invId "resilient response" + -- server up: the reply is delivered, the requester's blocking call returns the response, the service gets SENT + resp <- withSmpServerStoreLogOn ps testPort $ \_ -> do + ("", "", UP _ _) <- nGet service + ("", sentConnId, A.SENT _ _) <- get service + sentConnId `shouldBe` replyConnId + wait reqAsync resp `shouldBe` Right "resilient response" testUpdateConnectionUserId :: HasCallStack => IO ()