diff --git a/plans/2026-07-11-service-rpc-implementation.md b/plans/2026-07-11-service-rpc-implementation.md index d3529f141..d757bcf37 100644 --- a/plans/2026-07-11-service-rpc-implementation.md +++ b/plans/2026-07-11-service-rpc-implementation.md @@ -2,204 +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 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 address-DR does; this is the RPC layer on top of it. -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. +**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. -## Versions +**Scope.** One request, one response — no continuation, no streaming. -- `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. +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). -`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. +No new outer envelope: the request reuses `AgentContactRequest` (tag `'A'`); the reply reuses `AgentConfirmation` (the only message on Q_A). -The subtype distinguishes RPC from a normal connection and drives the owner's handling. Reuse the `ContactConnType` char slot: +Inner `AgentMessage` (ratchet-encrypted, parsed by `parseMessage`), siblings of `AgentConnInfoReply`: ```haskell -data ContactConnType = CCTContact | CCTChannel | CCTGroup | CCTRelay | CCTService -ctTypeChar CCTService = 'S' -- 's' in links -ctTypeP 'S' = pure CCTService + | 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) ``` -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. +`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`). -## RPC messages +## Ratchet establishment — reuse of the address-DR flow -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`. +`joinConnSrv'` takes `mkInner :: SMPQueueInfo -> AgentMessage`; `joinConnSrv` is the one-line wrapper passing `AgentConnInfoReply`. `sendServiceRequest'` passes `AgentServiceRequest`. -```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 - --- encoding (extends AgentMessage Encoding) -AgentServiceRequest qs body -> smpEncode ('Q', qs, Tail body) -AgentServiceResponse final bodies -> smpEncode ('P', final) <> smpEncodeList (map Large (L.toList bodies)) -``` +**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. + +**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: -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. +- `AgentConnInfoReply` → `REQ` (`service_request = 0`). +- `AgentServiceRequest _ payload` → `SREQ invId payload` (`service_request = 1`). -The request hash used for idempotency is `SHA3-256` of the decrypted request payload (the `MsgBody` in `AgentServiceRequest`). +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 `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 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. -## Ratchet establishment - reuse of the address-DR flow +**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: -Request (client), reusing the address-DR requester path (R2'/R3'): +- `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`. -- 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. +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)`. -Request (service), reusing the address-DR owner path (O1'/O2'): +## Rejection -- `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. +A rejection is `AgentRejection reason` — the same single confirming message on Q_A as a response. -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. +- **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)`. -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. +## Reply connections and cleanup -## Reply queue - the requester's DR connection +No reply-queue table and no new connection type. -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. +- **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 -One migration (`M20260712_service_rpc`), on top of the address-DR migration. SQLite shown, PostgreSQL mirrors it. +`M20260712_address_dr_rpc` (SQLite + PostgreSQL) creates `address_ratchet_keys` (address-DR) and adds: ```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, - 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 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 service's address ratchet keys are the address-DR `address_ratchet_keys` table - not duplicated here. +The down migration drops the columns then the table/index. Schema dump tests pass (up, down, STRICT). -## Agent API - `Simplex.Messaging.Agent` - -Service side: +## Agent API — `Simplex.Messaging.Agent` ```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 () +-- 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 + +-- 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 () +rejectContact :: AgentClient -> NetworkRequestMode -> UserId -> ConfirmationId -> Maybe ByteString -> AE () +rejectContactAsync :: AgentClient -> ACorrId -> UserId -> ConfirmationId -> Maybe ByteString -> AE () + +-- 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 ``` -Key rotation and update use the address-DR `rotateRatchetKeys`/link-data update; address deletion is `deleteConnection`. +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. -Client side (name resolution to a link is an existing API; the link must be a `CCTService` DR-advertising address): +Events (`AEvent`, entity is the address connection): ```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. -sendServiceRequest :: - AgentClient -> UserId -> ConnShortLink 'CMContact -> UTCTime -> - MsgBody -> (ServiceResponse -> IO ()) -> AE ServiceResponse - -cancelServiceRequest :: AgentClient -> ConnId -> AE () - -data ServiceResponse = ServiceResponse {bodies :: NonEmpty MsgBody, final :: Bool} +SREQ :: InvitationId -> MsgBody -> AEvent AEConn -- payload = the request; mirrors REQ. +RJCT :: ConnInfo -> AEvent AEConn -- contact-request rejection reason. ``` -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): +Errors (`SMPAgentError`): ```haskell -SREQ :: ServiceRequestRef -> MsgBody -> AEvent AEConn -- request payload for the bot -``` +| A_SERVICE {serviceError :: AgentServiceError} -`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. -- `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). - -Configuration (`AgentConfig`): default request deadline, request retention period (1 to 24 hours). Ratchet key rotation interval is the address-DR config. - -Errors reuse `AgentErrorType` (e.g. `CMD PROHIBITED` for a link that is not a service address). - -## Idempotency - -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. +data AgentServiceError + = 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) +``` -## Correlation and chat +Config (`AgentConfig`): `serviceRequestTimeout` (30 s, client wait, overridable per request) and `serviceResponseTimeout` (180 s, service reply window and cleanup TTL; must exceed `serviceRequestTimeout`). -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. +## Idempotency (deferred) -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, answering a repeat from storage without reaching the bot — single execution over at-least-once delivery, with its own tables. ## Tests -- Encoding roundtrips: `AgentServiceRequest`, `AgentServiceResponse` in `AgentMessage` (one and several response bodies); the service subtype in `UserContactData`/link. -- 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. +In `FunctionalAPITests` (plus the encoding roundtrip in `ConnectionRequestTests`), passing with `-O0`: -## Phases +- 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. -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. +The `simplex-chat` end-to-end tests (happy path, drop-when-off, non-DR fail-fast) live in that repo. 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 3e85b34b7..2565a7a5e 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -76,6 +76,13 @@ module Simplex.Messaging.Agent allowConnection, acceptContact, rejectContact, + rejectContactAsync, + sendServiceRequest, + sendServiceRequestAsync, + sendServiceReply, + sendServiceReplyAsync, + rejectServiceRequest, + rejectServiceRequestAsync, DatabaseDiff (..), compareConnections, syncConnections, @@ -475,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 Nothing {-# INLINE prepareConnectionToJoin #-} -- | Create SMP agent connection without queue (to be joined with acceptContact passing invitation ID). @@ -499,10 +506,38 @@ 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 = withAgentEnv c .:: rejectContact' c {-# INLINE rejectContact #-} +rejectContactAsync :: AgentClient -> ACorrId -> UserId -> ConfirmationId -> Maybe ByteString -> AE () +rejectContactAsync c = withAgentEnv c .:: rejectContactAsync' c +{-# INLINE rejectContactAsync #-} + +sendServiceReply :: AgentClient -> NetworkRequestMode -> UserId -> InvitationId -> MsgBody -> AE ConnId +sendServiceReply c = withAgentEnv c .:: sendServiceReply' c +{-# INLINE sendServiceReply #-} + +sendServiceReplyAsync :: AgentClient -> ACorrId -> UserId -> InvitationId -> MsgBody -> AE ConnId +sendServiceReplyAsync c = withAgentEnv c .:: sendServiceReplyAsync' c +{-# INLINE sendServiceReplyAsync #-} + +rejectServiceRequest :: AgentClient -> NetworkRequestMode -> UserId -> InvitationId -> Maybe ByteString -> AE () +rejectServiceRequest c = withAgentEnv c .:: rejectServiceRequest' c +{-# INLINE rejectServiceRequest #-} + +rejectServiceRequestAsync :: AgentClient -> ACorrId -> UserId -> InvitationId -> Maybe ByteString -> AE () +rejectServiceRequestAsync c = withAgentEnv c .:: rejectServiceRequestAsync' c +{-# INLINE rejectServiceRequestAsync #-} + +sendServiceRequest :: AgentClient -> NetworkRequestMode -> UserId -> ConnectionRequestUri 'CMContact -> Maybe NominalDiffTime -> MsgBody -> AE MsgBody +sendServiceRequest c = withAgentEnv c .::. sendServiceRequest' c +{-# INLINE sendServiceRequest #-} + +sendServiceRequestAsync :: AgentClient -> UserId -> ConnectionRequestUri 'CMContact -> Maybe NominalDiffTime -> MsgBody -> AE MsgBody +sendServiceRequestAsync c = withAgentEnv c .:: sendServiceRequestAsync' c +{-# INLINE sendServiceRequestAsync #-} + data DatabaseDiff a = DatabaseDiff { missingIds :: [a], extraIds :: [a] @@ -861,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} + 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, @@ -1111,7 +1146,8 @@ getConnShortLinkAsync' c userId corrId connId_ shortLink@(CSLContact _ _ srv _) lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, - pqSupport = PQSupportOff + pqSupport = PQSupportOff, + serviceRequestExpiresAt = Nothing } createNewConn db g cData SCMInvitation @@ -1333,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 -> 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) @@ -1348,17 +1384,17 @@ 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, 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 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} + 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 @@ -1378,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} + 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 @@ -1465,7 +1501,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 @@ -1480,7 +1520,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 @@ -1507,14 +1547,14 @@ 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) 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 +1642,103 @@ 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 = - withStore' c $ \db -> deleteInvitation db invId -{-# INLINE rejectContact' #-} +rejectContact' :: AgentClient -> NetworkRequestMode -> UserId -> InvitationId -> Maybe ByteString -> AM () +rejectContact' c = rejectRequest_ c False . sendReplySync c + +rejectContactAsync' :: AgentClient -> ACorrId -> UserId -> InvitationId -> Maybe ByteString -> AM () +rejectContactAsync' c = rejectRequest_ c False . sendReplyAsync c + +rejectServiceRequest' :: AgentClient -> NetworkRequestMode -> UserId -> InvitationId -> Maybe ByteString -> AM () +rejectServiceRequest' c = rejectRequest_ c True . sendReplySync c + +rejectServiceRequestAsync' :: AgentClient -> ACorrId -> UserId -> InvitationId -> Maybe ByteString -> AM () +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 + 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 ConnId +sendServiceReply' c = replyRequest_ c . sendReplySync c + +sendServiceReplyAsync' :: AgentClient -> ACorrId -> UserId -> InvitationId -> MsgBody -> AM ConnId +sendServiceReplyAsync' c = replyRequest_ c . sendReplyAsync c + +replyRequest_ :: AgentClient -> ((ConnId, ConnData, SndQueue) -> AM ()) -> UserId -> InvitationId -> MsgBody -> AM ConnId +replyRequest_ c sendReply userId invId resp = do + 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)) + `catchAllErrors` \e -> deleteConnectionAsync' c True connId >> throwE e + 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 serviceRequest' innerMsg = do + Invitation {connReq, serviceRequest, createdAt} <- withStore c $ \db -> getInvitation db "prepareReply" invId + when (serviceRequest /= serviceRequest') $ throwE $ CMD PROHIBITED kindErr + when serviceRequest' $ do + now <- liftIO getCurrentTime + responseTimeout <- asks $ serviceResponseTimeout . config + when (diffUTCTime now createdAt > responseTimeout) $ do + withStore' c $ \db -> deleteInvitation db invId + throwE $ AGENT $ A_SERVICE ASETimeout + case connReq of + 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 innerMsg + pure (connId, cData, sq) + where + kindErr + | serviceRequest' = "reply: not a service request, use rejectContact" + | otherwise = "rejectContact: service request, use rejectServiceRequest" + +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 -> 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 -> Maybe NominalDiffTime -> (ConnId -> AM ()) -> AM MsgBody +serviceRequest_ c userId cReqUri@(CRContactUri _ addrKeys_) timeout_ doSend = do + when (isNothing addrKeys_) $ throwE $ AGENT $ A_SERVICE ASENotDRAddress + 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) + r <- tryError $ do + 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) + 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) syncConnections' c userIds connIds = do @@ -2029,6 +2161,18 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do 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 -> + 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 -> @@ -2071,6 +2215,10 @@ 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 + ICReplyDel -> withServer' . tryWithLock "ICReplyDel" $ + withStore c (`getConn` connId) >>= \case + 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) ICDeleteRcvQueue rId -> withServer $ \srv -> tryWithLock "ICDeleteRcvQueue" $ do @@ -2292,7 +2440,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 @@ -2310,6 +2458,8 @@ 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 + AM_SRV_RESP -> sendConfirmation c NRMBackground sq msgBody _ -> case pendingMsgPrepData_ of Nothing -> sendAgentMessage c sq msgFlags msgBody Just PendingMsgPrepData {encryptKey, paddedLen, sndMsgBody} -> do @@ -2356,11 +2506,17 @@ 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 -> logError "AM_SRV_REQ: unexpected stored message" >> delMsg msgId + 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 | 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 @@ -2437,6 +2593,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 -> logError "AM_SRV_REQ: unexpected stored message" + AM_SRV_RESP -> notify $ SENT mId proxySrv_ + AM_RJCT -> pure () delMsgKeep (msgType == AM_A_MSG_) msgId where setStatus status = do @@ -3137,8 +3296,15 @@ cleanupManager c@AgentClient {subQ} = do run SFERR deleteSndFilesDeleted run SFERR deleteSndFilesPrefixPaths run SFERR deleteExpiredReplicasForDeletion + run ERR deleteExpiredServiceReqs liftIO $ threadDelay' int where + deleteExpiredServiceReqs = do + serviceResponseTimeout <- asks $ serviceResponseTimeout . config + now <- liftIO getCurrentTime + withStore' c $ \db -> deleteExpiredServiceRequests db $ addUTCTime (negate serviceResponseTimeout) 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 waitActive . runExceptT $ a `catchAllErrors` (notify "" . err) @@ -3312,8 +3478,8 @@ 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}) -> - smpInvitationDR srvMsgId conn agentVersion e2eSndParams ratchetKeyId encConnInfo phVer >> ack + (SMP.PHEmpty, AgentContactRequest {agentVersion, e2eSndParams, ratchetKeyId, encConnInfo}) -> + smpContactRequest srvMsgId conn agentVersion e2eSndParams ratchetKeyId encConnInfo phVer >> ack _ -> prohibited "handshake: incorrect state" >> ack (Just e2eDh, Nothing) -> do decryptClientMessage e2eDh clientMsg >>= \case @@ -3440,7 +3606,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) @@ -3533,7 +3699,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, serviceRequestExpiresAt} = toConnData conn' case status of New -> case conn' of -- party initiating connection @@ -3552,12 +3718,21 @@ 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) - _ -> prohibited "conf: not AgentConnInfoReply" -- including AgentConnInfo, that is prohibited here in v2 + AgentServiceResponse payload | isJust serviceRequestExpiresAt -> dispatchServiceReply $ Right payload + AgentRejection reason + | isJust serviceRequestExpiresAt -> dispatchServiceReply $ Left $ AGENT $ A_SERVICE $ ASERejected $ safeDecodeUtf8 reason + | otherwise -> notify $ RJCT reason + _ -> prohibited "conf: unexpected message for connection kind" 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 ASENoPendingRequest processConf rc' connInfo senderConf = do let newConfirmation = NewConfirmation {connId, senderConf, ratchetState = rc'} g <- asks random @@ -3769,46 +3944,57 @@ 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 + notify $ REQ invId pqSupport srvs cInfo False _ -> prohibited "inv: sent to message conn" where 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 serviceRequest = do g <- asks random - let newInv = NewInvitation {contactConnId = connId, connReq, recipientConnInfo} + let newInv = NewInvitation {contactConnId = connId, connReq, recipientConnInfo, serviceRequest} 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 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 -> - parseMessage agentMsgBody >>= \case - AgentConnInfoReply (replyQueue :| _) cInfo -> do - let dr = DRInvitation {ratchetState, replyQueue, agentVersion, pqSupport = connPQSupport} - invId <- storeInvitation (CRInvitationDR dr) cInfo - notify $ REQ invId pqSupported (qServer replyQueue :| []) cInfo - _ -> prohibited "addr inv: not AgentConnInfoReply" - 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/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 55eac6ba6..dab866a57 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -384,6 +384,7 @@ 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, @@ -547,6 +548,7 @@ 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 @@ -592,6 +594,7 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg, useServices clientId, agentEnv, proxySessTs, + serviceRequests, smpServersStats, xftpServersStats, ntfServersStats, diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index 47073f6b4..c234711d6 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -153,6 +153,9 @@ data AgentConfig = AgentConfig userNetworkInterval :: Int, userOfflineDelay :: NominalDiffTime, messageTimeout :: 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, @@ -229,6 +232,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, + 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 cd983407c..c0ebce302 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, @@ -414,7 +415,9 @@ 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 CON :: PQEncryption -> AEvent AEConn -- notification that connection is established END :: AEvent AEConn @@ -496,6 +499,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 +564,8 @@ aEventTag = \case LDATA {} -> LDATA_ CONF {} -> CONF_ REQ {} -> REQ_ + SREQ {} -> SREQ_ + RJCT {} -> RJCT_ INFO {} -> INFO_ CON _ -> CON_ END -> END_ @@ -858,7 +865,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 published DR keys: a contact invitation or a service (RPC) request { agentVersion :: VersionSMPA, e2eSndParams :: SndE2ERatchetParams 'C.X448, ratchetKeyId :: RatchetKeyId, @@ -879,8 +886,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 +903,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 +923,9 @@ data AgentMessage AgentConnInfoReply (NonEmpty SMPQueueInfo) ConnInfo | AgentRatchetInfo ByteString | AgentMessage APrivHeader AMessage + | AgentServiceRequest (NonEmpty SMPQueueInfo) MsgBody + | AgentServiceResponse MsgBody + | AgentRejection ByteString deriving (Show) instance Encoding AgentMessage where @@ -924,12 +934,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 body -> smpEncode ('P', Tail body) + AgentRejection reason -> smpEncode ('J', 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 . unTail <$> smpP + 'J' -> AgentRejection . unTail <$> smpP _ -> fail "bad AgentMessage" -- internal type for storing message type in the database @@ -946,6 +962,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 +981,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 +1001,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 +1012,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 @@ -1860,6 +1888,7 @@ data DRInvitation = DRInvitation data JoinRequest = JRConnReq {enableNtfs :: Bool, joinConnReq :: AConnectionRequestUri, joinPQSupport :: PQSupport} + | JRServiceReq {contactReq :: ConnectionRequestUri 'CMContact, joinPQSupport :: PQSupport} | JRInvitationDR DRInvitation deriving (Show) @@ -2170,8 +2199,16 @@ data SMPAgentError A_DUPLICATE {droppedMsg_ :: Maybe DroppedMsg} | -- | error in the message to add/delete/etc queue in connection A_QUEUE {queueErr :: String} + | A_SERVICE {serviceError :: AgentServiceError} deriving (Eq, Show, Exception) +data AgentServiceError + = ASERejected {rejectReason :: Text} + | ASETimeout + | ASENoPendingRequest + | ASENotDRAddress + deriving (Eq, Show) + data AgentCryptoError = -- | AES decryption error DECRYPT_AES @@ -2202,9 +2239,11 @@ $(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) strP = - (JRConnReq <$> strP <*> _strP <*> (_strP <|> pure PQSupportOff)) + (A.char 'S' *> (JRServiceReq <$> _strP <*> _strP)) + <|> (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) @@ -2290,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 49a842cf0..abfbe4b47 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -465,7 +465,9 @@ data ConnData = ConnData lastExternalSndId :: PrevExternalSndId, deleted :: Bool, ratchetSyncState :: RatchetSyncState, - pqSupport :: PQSupport + pqSupport :: PQSupport, + -- 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) @@ -537,6 +539,7 @@ data InternalCommand | ICDeleteRcvQueue SMP.RecipientId | ICQSecure SMP.RecipientId SMP.SndPublicAuthKey | ICQDelete SMP.RecipientId + | ICReplyDel data InternalCommandTag = ICAck_ @@ -547,6 +550,7 @@ data InternalCommandTag | ICDeleteRcvQueue_ | ICQSecure_ | ICQDelete_ + | ICReplyDel_ deriving (Show) instance StrEncoding InternalCommand where @@ -559,6 +563,7 @@ instance StrEncoding InternalCommand where ICDeleteRcvQueue rId -> strEncode (ICDeleteRcvQueue_, rId) ICQSecure rId senderKey -> strEncode (ICQSecure_, rId, senderKey) ICQDelete rId -> strEncode (ICQDelete_, rId) + ICReplyDel -> strEncode ICReplyDel_ strP = strP >>= \case ICAck_ -> ICAck <$> _strP <*> _strP @@ -569,6 +574,7 @@ instance StrEncoding InternalCommand where ICDeleteRcvQueue_ -> ICDeleteRcvQueue <$> _strP ICQSecure_ -> ICQSecure <$> _strP <*> _strP ICQDelete_ -> ICQDelete <$> _strP + ICReplyDel_ -> pure ICReplyDel instance StrEncoding InternalCommandTag where strEncode = \case @@ -580,6 +586,7 @@ instance StrEncoding InternalCommandTag where ICDeleteRcvQueue_ -> "DELETE_RCV_QUEUE" ICQSecure_ -> "QSECURE" ICQDelete_ -> "QDELETE" + ICReplyDel_ -> "REPLY_DEL" strP = A.takeTill (== ' ') >>= \case "ACK" -> pure ICAck_ @@ -590,6 +597,7 @@ instance StrEncoding InternalCommandTag where "DELETE_RCV_QUEUE" -> pure ICDeleteRcvQueue_ "QSECURE" -> pure ICQSecure_ "QDELETE" -> pure ICQDelete_ + "REPLY_DEL" -> pure ICReplyDel_ _ -> fail "bad InternalCommandTag" agentCommandTag :: AgentCommand -> AgentCommandTag @@ -607,6 +615,7 @@ internalCmdTag = \case ICDeleteRcvQueue {} -> ICDeleteRcvQueue_ ICQSecure {} -> ICQSecure_ ICQDelete _ -> ICQDelete_ + ICReplyDel -> ICReplyDel_ -- * Confirmation types @@ -629,7 +638,9 @@ data AcceptedConfirmation = AcceptedConfirmation data NewInvitation = NewInvitation { contactConnId :: ConnId, connReq :: ContactRequest, - recipientConnInfo :: ConnInfo + recipientConnInfo :: ConnInfo, + -- service side: the received request is a service request (SREQ) not a contact request (REQ) + serviceRequest :: Bool } data Invitation = Invitation @@ -638,7 +649,10 @@ data Invitation = Invitation connReq :: ContactRequest, recipientConnInfo :: ConnInfo, ownConnInfo :: Maybe ConnInfo, - accepted :: Bool + accepted :: Bool, + -- service side: the received request is a service request (SREQ) not a contact request (REQ) + serviceRequest :: 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..4863e402b 100644 --- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -74,6 +74,8 @@ module Simplex.Messaging.Agent.Store.AgentStore setConnPQSupport, updateNewConnJoin, getDeletedConnIds, + getExpiredServiceConns, + deleteExpiredServiceRequests, getDeletedWaitingDeliveryConnIds, setConnRatchetSync, addProcessedRatchetKeyHash, @@ -565,14 +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 = +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, duplex_handshake) VALUES (?,?,?,?,?,?,?) + (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 True) + (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) @@ -875,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} = +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) VALUES (?, ?, ?, ?, 0); + (invitation_id, contact_conn_id, cr_invitation, recipient_conn_info, accepted, service_request) VALUES (?, ?, ?, ?, 0, ?); |] - (Binary invitationId, contactConnId, connReq, Binary recipientConnInfo) + (Binary invitationId, contactConnId, connReq, Binary recipientConnInfo, BI serviceRequest) getInvitation :: DB.Connection -> String -> InvitationId -> IO (Either StoreError Invitation) getInvitation db cxt invitationId = @@ -891,15 +895,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, 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 serviceRequest, createdAt) = + Invitation {invitationId, contactConnId_, connReq, recipientConnInfo, ownConnInfo, accepted, serviceRequest, createdAt} acceptInvitation :: DB.Connection -> InvitationId -> ConnInfo -> IO () acceptInvitation db invitationId ownConnInfo = @@ -2625,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 + last_external_snd_msg_id, deleted, ratchet_sync_state, pq_support, service_request_expires_at FROM connections WHERE conn_id IN ? AND deleted = ? |] @@ -2663,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 + last_external_snd_msg_id, deleted, ratchet_sync_state, pq_support, service_request_expires_at 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, 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 @@ -2711,6 +2715,14 @@ 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)) +getExpiredServiceConns :: DB.Connection -> UTCTime -> IO [ConnId] +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 = + DB.execute db "DELETE FROM conn_invitations WHERE 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.hs deleted file mode 100644 index 00506b1d2..000000000 --- a/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20260712_address_dr.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} - -module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260712_address_dr where - -import Data.Text (Text) -import Text.RawString.QQ (r) - -m20260712_address_dr :: Text -m20260712_address_dr = - [r| -CREATE TABLE address_ratchet_keys( - address_ratchet_key_id BIGSERIAL PRIMARY KEY, - conn_id BYTEA NOT NULL REFERENCES connections ON DELETE CASCADE, - 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 TIMESTAMPTZ NOT NULL DEFAULT (now()) -); - -CREATE UNIQUE INDEX idx_address_ratchet_keys ON address_ratchet_keys(conn_id, ratchet_key_id); - |] - -down_m20260712_address_dr :: Text -down_m20260712_address_dr = - [r| -DROP INDEX idx_address_ratchet_keys; -DROP TABLE address_ratchet_keys; - |] 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 new file mode 100644 index 000000000..5a3b12b5d --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20260712_address_dr_rpc.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260712_address_dr_rpc where + +import Data.Text (Text) +import Text.RawString.QQ (r) + +m20260712_address_dr_rpc :: Text +m20260712_address_dr_rpc = + [r| +CREATE TABLE address_ratchet_keys( + address_ratchet_key_id BIGSERIAL PRIMARY KEY, + conn_id BYTEA NOT NULL REFERENCES connections ON DELETE CASCADE, + 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 TIMESTAMPTZ NOT NULL DEFAULT (now()) +); + +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; -- 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_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_request_expires_at; +ALTER TABLE connections DROP COLUMN created_at; +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/Postgres/Migrations/agent_postgres_schema.sql b/src/Simplex/Messaging/Agent/Store/Postgres/Migrations/agent_postgres_schema.sql index 731a021ee..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 @@ -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_request_expires_at timestamp with time zone ); @@ -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; 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.hs deleted file mode 100644 index 2da05ea42..000000000 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20260712_address_dr.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} - -module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260712_address_dr where - -import Database.SQLite.Simple (Query) -import Database.SQLite.Simple.QQ (sql) - -m20260712_address_dr :: Query -m20260712_address_dr = - [sql| -CREATE TABLE address_ratchet_keys( - address_ratchet_key_id INTEGER PRIMARY KEY AUTOINCREMENT, - conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE, - ratchet_key_id BLOB NOT NULL, - x3dh_priv_key_1 BLOB NOT NULL, - x3dh_priv_key_2 BLOB NOT NULL, - pq_priv_kem BLOB, - created_at TEXT NOT NULL DEFAULT(datetime('now')) -) STRICT; - -CREATE UNIQUE INDEX idx_address_ratchet_keys ON address_ratchet_keys(conn_id, ratchet_key_id); - |] - -down_m20260712_address_dr :: Query -down_m20260712_address_dr = - [sql| -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 new file mode 100644 index 000000000..aa5aab1a4 --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20260712_address_dr_rpc.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE QuasiQuotes #-} + +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_rpc :: Query +m20260712_address_dr_rpc = + [sql| +CREATE TABLE address_ratchet_keys( + address_ratchet_key_id INTEGER PRIMARY KEY AUTOINCREMENT, + conn_id BLOB NOT NULL REFERENCES connections ON DELETE CASCADE, + ratchet_key_id BLOB NOT NULL, + x3dh_priv_key_1 BLOB NOT NULL, + x3dh_priv_key_2 BLOB NOT NULL, + pq_priv_kem BLOB, + created_at TEXT NOT NULL DEFAULT(datetime('now')) +) STRICT; + +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; -- 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_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_request_expires_at; +ALTER TABLE connections DROP COLUMN created_at; +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 460600f4c..5281f0dbe 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,9 @@ 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 NOT NULL DEFAULT('1970-01-01 00:00:00'), + service_request_expires_at TEXT ) WITHOUT ROWID, STRICT; CREATE TABLE rcv_queues( host TEXT NOT NULL, @@ -164,6 +166,8 @@ CREATE TABLE conn_invitations( accepted INTEGER NOT NULL DEFAULT 0, own_conn_info BLOB, created_at TEXT NOT NULL DEFAULT(datetime('now')) + , + 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 7b27feaf8..df19a1841 100644 --- a/tests/AgentTests/ConnectionRequestTests.hs +++ b/tests/AgentTests/ConnectionRequestTests.hs @@ -353,6 +353,11 @@ 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 + 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 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 diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 32750ef58..ddef61eed 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 @@ -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 @@ -347,23 +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 + 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 @@ -971,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 @@ -1045,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 @@ -1079,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 @@ -1104,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 @@ -1179,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 @@ -1202,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 @@ -1231,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 @@ -1277,10 +1290,107 @@ 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 - rejectContact alice invId + ("", _, 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" +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 () + +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 Nothing "service request") + (runRight_ $ do + ("", _, SREQ invId "service request") <- get service + 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 + +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 Nothing "service request") + (runRight_ $ do + ("", _, SREQ invId "service request") <- get service + 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 + +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 Nothing "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 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 + 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 async send is enqueued as a retried JOIN command and blocks for the response + 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 + ("", "", 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 + 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 () testUpdateConnectionUserId = withAgentClients2 $ \alice bob -> runRight_ $ do @@ -1538,7 +1648,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 c94b1921b..6aea60ff3 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, + serviceRequestExpiresAt = Nothing } testPrivateAuthKey :: C.APrivateAuthKey