stats, tests

* agent: make QUOTA error temporary for async commands

* retry commands on quota

---------

Co-authored-by: Evgeny @ SimpleX Chat <[email protected]>

.github/workflows/build.yml

@@ -9,6 +9,10 @@ on:
       - "v*"
   pull_request:
 
+concurrency:
+  group: ${{ github.workflow }}-${{ github.ref }}
+  cancel-in-progress: ${{ !startsWith(github.ref, 'refs/tags/v') }}
+
 jobs:
 
 # =============================
@@ -301,3 +305,30 @@ jobs:
             echo "All "$attempts" attempts failed."
             exit 1
           fi
+
+# =============================
+#      Resolver test job
+# =============================
+
+# The SNRC resolver is Python, so this job needs none of the Haskell toolchain
+# above and runs independently of it.
+
+  resolver-test:
+    name: "resolver (python)"
+    runs-on: ubuntu-latest
+    steps:
+      - name: Clone project
+        uses: actions/checkout@v3
+
+      - name: Set up Python
+        # Matches the runtime stage of scripts/resolver/service/Dockerfile.
+        uses: actions/setup-python@v5
+        with:
+          python-version: "3.13"
+
+      - name: Install resolver dependencies
+        # Must match scripts/resolver/service/pyproject.toml.
+        run: python -m pip install "eth-hash[pycryptodome]>=0.7"
+
+      - name: Test
+        run: python -m unittest discover -s scripts/resolver/service -v

.gitignore

@@ -12,3 +12,4 @@ cabal.project.local~
 *.tix
 .coverage
 
+__pycache__/

apps/xftp-server/XFTPWeb.hs

@@ -58,7 +58,7 @@ xftpSubsts XFTPServerConfig {fileExpiration, logStatsInterval, allowNewFiles, ne
   [("smpConfig", Nothing), ("xftpConfig", Just "y")] <> substConfig <> serverInfoSubsts simplexmqSource information <> [("onionHost", strEncode <$> onionHost), ("iniFileName", Just "file-server.ini")]
   where
     substConfig =
-      [ ("fileExpiration", Just $ maybe "Never" (fromString . timedTTLText . ttl) fileExpiration),
+      [ ("fileExpiration", Just . fromString . timedTTLText . ttl $ fileExpiration),
         ("statsEnabled", Just . yesNo $ isJust logStatsInterval),
         ("newUploadsAllowed", Just . yesNo $ allowNewFiles),
         ("basicAuthEnabled", Just . yesNo $ isJust newFileBasicAuth)

docs/smp-server-db-load.md

@@ -0,0 +1,200 @@
+# SMP server database load: root causes and fixes
+
+## Summary
+
+The recurring `pMsgFwdsOwn_pErrorsOther` spikes are a symptom of chronic disk saturation of the
+`smp_server` PostgreSQL database, not a proxy or forwarding bug. The baseline read load is the
+Prometheus scrape running whole-table `COUNT` scans of `msg_queues` (48.5M rows) every 30 seconds,
+compounded by the message-expiration sweep. The write load comes from indexing `updated_at`:
+`updateQueueTime` stamps it on the first send to each active queue per UTC day, and these non-HOT
+updates bloat the indexes to 104 GB and amplify WAL to about 425 GB per day (37% full-page images,
+~31% from `updateQueueTime`). Because the stamp is day-granular, this write burst clusters at 00:00 UTC,
+tipping the saturated disk into the observed spike and loading the pgBackRest backup repository.
+
+Code fixes replace the largest metric scan with an estimate and index the sweep and notifier counts.
+Reclaiming the index bloat, which also clears the remaining metric scan, and keeping it down are
+operator actions, because PostgreSQL never shrinks indexes automatically.
+
+## Environment
+
+The affected deployment runs the pure PostgreSQL backend (`store_queues: database`,
+`store_messages: database`), schema `smp_server`, `db_pool_size 20`, `prometheus_interval 30`,
+`[NAMES]` enabled, own-server proxying enabled, and forwards routed over a SOCKS proxy.
+
+`msg_queues`: 48.5M live rows, 12.3% dead tuples, 14 GB heap, 104 GB indexes, 118 GB total.
+
+## Evidence
+
+`pg_stat_statements` over a 5 minute window, ordered by disk reads (`track_io_timing` was off, so
+`shared_blks_read` is the disk proxy; the two `EXPLAIN ANALYZE` rows are manual and excluded):
+
+| query | calls | mean ms | reads | share of all reads |
+| --- | --- | --- | --- | --- |
+| `getEntityCounts` (the six-`COUNT` metric query) | 30 | 111,456 | 990 GB | 70.7% |
+| queue-record load (`SELECT recipient_id, …`) | 47,027 | 121 | 89 GB | 6.3% |
+| expiration sweep batch (`array_agg` in `expire_old_messages`) | 13 | 233,143 | 62 GB | 4.5% |
+| message peek (`DISTINCT ON (recipient_id)`) | 46,932 | 76 | 43 GB | 3.0% |
+| `updateQueueTime` (`UPDATE msg_queues SET updated_at`) | 172,885 | 4 | 7.7 GB | 0.5% |
+| `write_message` | 110,911 | 5 | 7.0 GB | 0.5% |
+
+`EXPLAIN (ANALYZE, BUFFERS)` of each `msg_queues` count inside `getEntityCounts`:
+
+| count | plan | time |
+| --- | --- | --- |
+| `queue_count` (`deleted_at IS NULL`) | Parallel Seq Scan | 30 s |
+| `notifier_count` (`deleted_at IS NULL AND notifier_id IS NOT NULL`) | Parallel Seq Scan | 32.6 s |
+| `ntf_service_queues_count` (`ntf_service_id IS NOT NULL AND deleted_at IS NULL`) | Parallel Seq Scan | 30.2 s |
+| `rcv_service_queues_count` (`rcv_service_id IS NOT NULL AND deleted_at IS NULL`) | Index Only Scan | 1.4 ms |
+
+The expiration sweep batch: 229 s for one 10,000-row batch, walking `msg_queues_pkey` and discarding
+809,729 rows by filter to find 10,000 expirable ones.
+
+`pg_stat_wal` over the measurement window: 27 TB of WAL accumulated, 37.2% of records full-page
+images, averaging about 425 GB per day; recent days reach ~470 GB (from the `archive-push` log) as
+the queue count grows.
+
+Per-statement WAL from `pg_stat_statements` (`wal_bytes`), leaf statements only (this instance runs
+`pg_stat_statements.track = all`, so the `write_message` wrapper double-counts the `INSERT` and
+`UPDATE` it runs, and is excluded):
+
+| category | share of WAL | main statements |
+| --- | --- | --- |
+| `msg_queues` updates | ~42% | `updateQueueTime` ~31%, `msg_can_write` flags ~9%, insert/delete ~2% |
+| `messages` insert and delete | ~34% | message `INSERT`, `DELETE` by `message_id` and `recipient_id` |
+| read path (hint bits, FPIs on SELECT) | ~24% | message peek ~15%, `msg_queue_size`, `getEntityCounts` |
+
+## Root causes
+
+1. Prometheus scrape. `getEntityCounts` (`QueueStore/Postgres.hs:154`) runs six `COUNT(1)` subqueries
+   every `prometheus_interval` (30 s), called from the metrics path (`Server.hs:698`). Four count
+   `msg_queues`; three of those seq-scan the 48.5M-row heap. At 70.7% of all reads it is the dominant
+   disk consumer, and it runs continuously (mean 111 s per scrape exceeds the 30 s interval).
+
+2. Message-expiration sweep. `expireMessagesThread` (`Server.hs:477`) calls the `expire_old_messages`
+   procedure (`server_schema.sql`), whose inner batch query selects expirable queues ordered by
+   `recipient_id`. With `oldQueue = 0` the `updated_at` filter matches everything, so the planner
+   walks the primary key and filters `msg_queue_expire`, discarding ~99% of rows per batch.
+
+3. Index bloat. 104 GB of indexes on a 14 GB table. `updated_at` is part of
+   `idx_msg_queues_updated_at_recipient_id` (`server_schema.sql:526`) and `updateQueueTime`
+   (`QueueStore/Postgres.hs:443`) updates it on the day's first send per queue (172,885 times in the
+   window above). Updating an indexed column prevents HOT updates, so every update writes a new row
+   version plus new entries in every index on the table, and the old index entries accumulate as bloat.
+
+4. WAL amplification. Only 15.6% of `msg_queues` updates are HOT, because its composite index covers
+   `updated_at` and `msg_queue_expire`, both changed on the hot path (cause 3); the rest rewrite every
+   index on the table. With the 104 GB of bloated indexes and frequent checkpoints (`max_wal_size 4GB`,
+   `checkpoint_timeout 5min`, `wal_compression off`), 37% of WAL records are full-page images, and the
+   server generates about 425 GB of WAL per day (27 TB accumulated; recent days near 470 GB).
+   `updateQueueTime`, stamping `updated_at` on the ~5.3M daily-active queues, is the single largest
+   statement at ~31% of WAL (see Evidence). pgBackRest `archive-push` ships all of it, loading the
+   primary disk and the backup repository. The load peaks
+   at 00:00 UTC because `getSystemDate` rounds `updated_at` to the UTC day, so the first send to each
+   active queue after midnight runs `updateQueueTime`, clustering these writes and the `archive-push`
+   volume in the 00h hour.
+
+## Index bloat and autovacuum
+
+Autovacuum is running (60 runs on this table) and is not misconfigured, but two limits apply.
+
+Autovacuum reclaims heap dead tuples and refreshes planner statistics; it does not shrink indexes.
+Only `REINDEX` or `pg_repack` rebuilds a bloated B-tree. Index bloat therefore has no automatic
+remedy.
+
+Default autovacuum pacing assumes moderate churn. `autovacuum_vacuum_scale_factor = 0.2` waits until
+20% of the table is dead (about 9.7M rows here) before vacuuming, and cost-based throttling caps its
+I/O, so a hot table stays around 12% dead. Per-table tuning makes it run sooner and faster.
+
+The amplifier is indexing `updated_at`, a column updated on every send, which the fixes and operator
+actions below address.
+
+## Implemented fixes (batch 1)
+
+Branch `sh/leaks-batch-1`, two commits.
+
+| commit | change | effect |
+| --- | --- | --- |
+| `88673eee` | migration `20260916_prometheus_indexes` adds partial indexes `idx_msg_queues_expire (recipient_id) WHERE deleted_at IS NULL AND msg_queue_expire` and `idx_msg_queues_notifier_active (notifier_id) WHERE deleted_at IS NULL AND notifier_id IS NOT NULL` | the sweep batch and `notifier_count` become index scans |
+| `2912be1e` | `getEntityCounts.queue_count` uses `pg_class.reltuples` (`QueueStore/Postgres.hs:154`) | removes the 30 s, 990 GB whole-table `COUNT` on every scrape |
+
+Verified: both indexes are created and used as index-only scans, the schema-dump test passes, and
+`smp-server` builds. `queueCount` is consumed only by metrics, logs, and display
+(`Server.hs:528,698,815,2369`), so an estimate is safe.
+
+Not fixed by new indexes:
+
+- `ntf_service_queues_count` seq-scans only because of index bloat; `idx_msg_queues_ntf_service_id`
+  already covers it. `REINDEX` restores the index-only scan, as proven by `rcv_service_queues_count`.
+- `rcv_service_queues_count` and the two `services` counts are already cheap.
+
+## Implemented fixes (batch 2)
+
+Migration `20260917_msg_queues_hot` and `MsgStore/Postgres.hs`.
+
+| change | effect |
+| --- | --- |
+| drop `idx_msg_queues_updated_at_recipient_id`, set `msg_queues` `fillfactor = 80` | `updateQueueTime` updates become HOT, so they rewrite no index entries; removes its index bloat and cuts its WAL |
+| remove the dead `updated_at > p_old_queue` filter and its parameter from `expire_old_messages`, matching the `CALL` (`MsgStore/Postgres.hs:113`) | the sweep query runs as an index-only scan on `idx_msg_queues_expire`; `updated_at` is no longer read on the hot path |
+| autovacuum reloptions on `msg_queues`, `messages` (and its TOAST), and `services` | keeps dead tuples and bloat low per table (see the table below) |
+
+Verified on PostgreSQL 16 with the daily-active pattern (~11% of queues updated per day): `updateQueueTime`
+goes from 0% HOT (indexed `updated_at`) to 100% HOT at `fillfactor = 80` (96.7% at 90), and per-update
+WAL drops about 4x. The HOT ratio depends on how many rows per page change before autovacuum reclaims
+space, so it is workload-dependent; `fillfactor = 80` reached 100% for this fraction, and updating a much
+larger share of queues at once would need a lower value. `fillfactor` applies to pages rewritten after
+the change, so the ratio ramps up as the heap turns over, or immediately after `pg_repack`.
+
+Dropping the index regresses the deprecated journal message store's expiration (`foldRecentQueueRecs`,
+`Journal.hs:434`) to a sequential scan; this is accepted because that store is being retired. The
+Postgres message store does not read `updated_at`.
+
+Autovacuum reloptions applied by the migration:
+
+| table | reloptions | reason |
+| --- | --- | --- |
+| `msg_queues` | `fillfactor 80`, `autovacuum_vacuum_scale_factor 0.02`, `autovacuum_analyze_scale_factor 0.01`, `autovacuum_vacuum_cost_limit 1000` | HOT headroom; vacuum/analyze at ~2%/1% churn instead of 20%/10%; faster vacuum |
+| `messages` (and TOAST) | `autovacuum_vacuum_scale_factor 0.02`, `autovacuum_analyze_scale_factor 0.01`, `toast.autovacuum_vacuum_scale_factor 0.02` | high insert and delete churn; 152 GB, mostly TOASTed message bodies |
+| `services` | `fillfactor 70`, `autovacuum_vacuum_threshold 1000`, `autovacuum_vacuum_scale_factor 0` | tiny, very hot table was autovacuumed tens of thousands of times; make updates HOT and vacuum it far less |
+
+## Operator actions
+
+1. Reclaim index bloat (online, no lock; needs free disk near the index size; run largest first):
+   ```
+   REINDEX INDEX CONCURRENTLY smp_server.idx_msg_queues_updated_at_recipient_id;
+   REINDEX INDEX CONCURRENTLY smp_server.idx_msg_queues_notifier_id;
+   REINDEX INDEX CONCURRENTLY smp_server.idx_msg_queues_ntf_service_id;
+   REINDEX INDEX CONCURRENTLY smp_server.idx_msg_queues_rcv_service_id;
+   REINDEX INDEX CONCURRENTLY smp_server.idx_msg_queues_sender_id;
+   REINDEX INDEX CONCURRENTLY smp_server.idx_msg_queues_link_id;
+   ANALYZE smp_server.msg_queues;
+   ```
+   Expect `pg_indexes_size('smp_server.msg_queues')` to drop from 104 GB to roughly 12 GB (measured
+   after reindexing). `ANALYZE` restores the index-only scan for `ntf_service_queues_count`. With the
+   batch-2 `fillfactor` the index bloat no longer rebuilds, so this is a one-time reclaim.
+
+2. Autovacuum reloptions are applied by the batch-2 migration (`msg_queues`, `messages` and its TOAST,
+   `services`), so no manual `ALTER TABLE` is needed. Reclaim the current `messages` bloat once with
+   `pg_repack smp_server.messages` (152 GB heap and TOAST, roughly 30-50 GB reclaimable); running
+   `pg_repack` on `msg_queues` also makes `fillfactor = 80` effective immediately rather than as pages
+   turn over. With `fillfactor = 80` the `msg_queues` index bloat no longer rebuilds, so scheduled
+   reindexing is rarely needed. To automate it anyway, run `reindexdb --concurrently` or `pg_repack`
+   from a scheduler; `pg_cron` runs each job inside a transaction and cannot execute
+   `REINDEX ... CONCURRENTLY`, so use `pg_cron` only for `VACUUM`/`ANALYZE` or a non-concurrent
+   maintenance-window `REINDEX`.
+
+3. Cut WAL and checkpoint pressure (all reloadable, no restart):
+   ```
+   ALTER SYSTEM SET wal_compression = 'lz4';
+   ALTER SYSTEM SET max_wal_size = '32GB';
+   ALTER SYSTEM SET checkpoint_timeout = '30min';
+   SELECT pg_reload_conf();
+   ```
+   Fewer checkpoints produce fewer full-page images; `wal_compression` shrinks those that remain.
+   Together these reduce the WAL written on the primary and shipped by `archive-push`. The message
+   insert and delete volume itself is fixed by traffic, but most of its WAL cost is amplification
+   (full-page images and hint-bit writes on bloated pages), which these settings and `REINDEX` reduce.
+   This is separate from pgBackRest repo-side compression, which does not reduce WAL on the primary.
+   Verify with `pg_stat_reset_shared('wal')`, wait, then re-check `wal_fpi` and `wal_bytes` in
+   `pg_stat_wal`.
+
+4. Enable `track_io_timing = on` so disk wait time is measurable in `pg_stat_statements`.

plans/2026-08-22-xftp-file-storage-time.md

@@ -0,0 +1,168 @@
+# Implementation plan: XFTP variable file storage time
+
+Proposal: `../rfcs/2026-08-22-xftp-file-storage-time.md`.
+
+## simplexmq: entitlement crypto
+
+New module `Simplex.Messaging.Crypto.Entitlement`, over `Simplex.Messaging.Crypto.BBS`:
+
+Types:
+
+```
+newtype MasterKey = MasterKey ByteString
+
+data Entitlement = Entitlement
+  { expiresAt :: UTCTime,
+    entitlementName :: Text,
+    extraInfo :: Text
+  }
+
+data EntitlementCredential = EntitlementCredential
+  { issuerKeyIdx :: Word16,
+    masterKey :: MasterKey,
+    entitlement :: Entitlement,
+    issuerSignature :: BBSSignature
+  }
+
+data EntitlementProof = EntitlementProof
+  { issuerKeyIdx :: Word16,
+    entitlement :: Entitlement,
+    entProof :: BBSProof
+  }
+```
+
+Functions and constants:
+
+- the disclosed-message encoding: the master key is message 0 and stays undisclosed; `expiresAt`, `entitlementName`, and `extraInfo` are messages 1 to 3 and are disclosed. The protocol encoding of `Entitlement` and its field order follow the same order
+- the BBS header string `"SimpleX badges v1"` (shared with chat's badges, which sign under it), the message count, and the disclosed indexes
+- `generateEntitlementProof :: Map Word16 BBSPublicKey -> EntitlementCredential -> BBSPresHeader -> IO (Either String EntitlementProof)` (the issuer key is looked up by the credential's index; an absent index is `Left`)
+- `verifyEntitlement :: Map Word16 BBSPublicKey -> BBSPresHeader -> EntitlementProof -> IO EntitlementVerification`, where `data EntitlementVerification = EVValid | EVInvalid | EVUnknownIssuer` (the caller supplies the presentation header; the server reconstructs it, the proof never includes it)
+- the issuer public keys constant `Map Word16 BBSPublicKey`
+
+## simplexmq: protocol, new XFTP version
+
+In `Simplex.FileTransfer.Transport`:
+
+- add the next `VersionXFTP` and set `currentXFTPVersion` to 4
+- add `entitlementProof :: Maybe EntitlementProof` to `XFTPClientHandshake`, encoded before the `Tail` and only from this version
+- the presentation header is the session id alone
+
+In `Simplex.FileTransfer.Protocol`:
+
+- add `GrantedStorageTime` and its encoding; retain the one-character sum prefix for future variants:
+
+```
+data GrantedStorageTime = GSTExpires {epochSeconds :: Int64}
+```
+
+- add the storage time (`Maybe Word32`: `Nothing` and `Just 0` request the server maximum, a value above zero requests that number of hours) to `FNEW`
+- add the granted storage to `FRSndIds` as `Maybe GrantedStorageTime` (`Nothing` when decoding a response from a server below this version)
+
+## simplexmq: server configuration
+
+In `Simplex.FileTransfer.Server.Env` and `Simplex.FileTransfer.Server.Main`:
+
+- make `fileExpiration` non-optional (`ExpirationConfig`, no longer `Maybe`); the server always expires files, so the server maximum is always a concrete number of seconds
+- read a maximum storage time (a number of hours) for each entitlement name from the `[STORE_LOG]` INI section, from the keys `expire_files_hours_for_supporter` and `expire_files_hours_for_legend`, into `fileStorageEntitlements :: Map Text EntitlementConfig`, where `newtype EntitlementConfig = EntitlementConfig {storageTime :: Int64}` holds seconds; an absent key is skipped (that name gets the default), a present but malformed value fails startup
+- exit at startup if any name's maximum is below the default file expiration
+- add `entitlementKeys :: Map Word16 BBSPublicKey` to the server config (default = the shared constant, set from `Main`); the handshake verifies the proof against it, so the trusted keys never come from the sender
+
+## simplexmq: server session
+
+In `Simplex.FileTransfer.Server`:
+
+- `processClientHandshake` verifies the proof from the handshake, once per session, and resolves the maximum storage time for the entitlement name. `HandshakeSent` carries `EntitlementChecked`, so the first handshake verifies and every later one on that connection reuses the result, including after `processHello` returns the session to `HandshakeSent`
+- verify only when the answer can change: the name is configured (startup rejects a maximum below the default), and the entitlement expired less than 24 hours ago. A proof that fails these checks gets no verification; a proof that fails to verify is logged. In both cases the session gets the default maximum
+- a verified proof becomes `peerEntitlement :: Maybe SessionEntitlement` in `THAuthServer`, where `data SessionEntitlement = SessionEntitlement {expiresAt :: SystemSeconds, entConfig :: EntitlementConfig}`; `processXFTPRequest` takes it from there, so no proof is verified while a command is processed
+- `createFile` caps the requested storage time by the session maximum, which is the entitlement's storage time when the entitlement is still valid, and the default otherwise
+
+## simplexmq: server store and expiration
+
+The `files` table gets a nullable `expires_at`. Every new file stores a concrete `expires_at`. It is NULL only for pre-feature rows, which the migration must not re-date (it has no access to the operator's configured TTL); those are expired at query time as `created_at + ttl`.
+
+Common to both stores, in `Simplex.FileTransfer.Server.Store`:
+
+- add `expiresAt :: Maybe RoundedFileTime` to `FileRec`
+- in `createFile`, cap the requested hours at the session maximum, round the expiry up to the hour, store it, and return that same value as the granted storage
+- `expiredFiles` receives `now` and `old` (= `now - ttl`). A stored expiry is deleted when `expires_at < now` (no grace — it is already rounded up); a legacy row (no `expires_at`) is deleted when `created_at + fileTimePrecision < old` (the grace covers `created_at` being floored to the hour)
+- retain `created_at` for statistics, export, and the legacy fallback
+
+STM store:
+
+- in `expiredFiles`, expire a new file when `roundedSeconds expiresAt < now`, and a legacy file (no `expiresAt`) when `created_at + fileTimePrecision < old`
+
+PostgreSQL store, in `Simplex.FileTransfer.Server.Store.Postgres` and its migrations:
+
+- add the nullable column `expires_at BIGINT` (no backfill)
+- add one composite index `idx_files_expiry ON files (expires_at, created_at)`
+- `expiredFiles` query: `(SELECT ... WHERE expires_at < ? LIMIT ?) UNION ALL (SELECT ... WHERE expires_at IS NULL AND created_at < ? LIMIT ?)` with `(now, limit, old - fileTimePrecision, limit)`. The first arm deletes stored (already rounded-up) expiries; the second drains legacy rows, with the grace folded into `old - fileTimePrecision` so the columns stay bare and sargable. Each arm is one range over the composite index and stops at its own limit; a single `OR` predicate builds a bitmap of every match before the limit applies. A `COALESCE(expires_at, created_at + ttl)` predicate is avoided (not sargable, would force a sequential scan). No `ORDER BY` — the batch loop deletes all expired rows regardless of order. New files always store an expiry, so the second arm drains permanently once the legacy rows expire, and is then removed.
+
+Store log, in `Simplex.FileTransfer.Server.StoreLog`:
+
+- add the optional expiration to the `AddFile` record; a record without it parses to `Nothing` (the configured default), never a hardcoded value
+
+## simplexmq: agent
+
+The credential belongs to the user, so the agent holds it the way it holds the user's servers: in memory, supplied when the agent is created and replaced through an API. It is not stored by the agent.
+
+Per-user state in `Simplex.Messaging.Agent.Env.SQLite` and `Simplex.Messaging.Agent.Client`:
+
+- add `entitlements :: Map UserId EntitlementCredential` to `InitialAgentServers`, beside the servers
+- add `userEntitlements :: TMap UserId EntitlementCredential` to `AgentClient`, filled from it by `newAgentClient`
+- add `entitlementKeys :: Map Word16 BBSPublicKey` to `AgentConfig` (default = the shared constant), for the issuer key that proof generation needs
+
+Public API in `Simplex.Messaging.Agent`:
+
+- add storage time (`Maybe Word32` hours) to `xftpSendFile`
+- add `setUserEntitlement :: AgentClient -> UserId -> Maybe EntitlementCredential -> IO ()`, in the shape of `setProtocolServers`: it replaces the entry, and when the credential changed it closes that user's XFTP clients, so the next upload presents the new credential
+
+Store, in both the SQLite and PostgreSQL agent stores:
+
+- add a nullable storage time column (integer hours; NULL means the server maximum) to `snd_files`
+- add the migration to both stores
+- in `createSndFile`, store the storage time
+
+Upload, in `Simplex.Messaging.Agent.Client` and `Simplex.FileTransfer.Client`:
+
+- `getXFTPClient` takes a proof for the session as a parameter, `SessionId -> IO (Maybe EntitlementProof)`, beside the callback it already takes for a closed client. The client config holds no credential and no keys
+- `getXFTPServerClient` passes a function that generates the proof over the session id from the configured issuer keys, and only for a server of this user, matched by the key hash that TLS pins, so a file description of the sender cannot direct the entitlement to another server. A server that is not the user's, a missing credential, or a failure to generate gives `Nothing`, with the failure logged
+- `xftpClientHandshakeV1` calls it with the session id from the connection, and sends the result in the handshake
+- `agentXFTPNewChunk` reads the storage time from the send record and sends FNEW with it
+- `createXFTPChunk` returns the granted expiry (epoch seconds); `agentXFTPNewChunk` stores it on `NewSndChunkReplica`
+
+Completion:
+
+- `createXFTPChunk` returns the granted expiry as `Maybe GrantedStorageTime`; `SndFileChunkReplica` and `NewSndChunkReplica` carry `expiresAt :: Maybe GrantedStorageTime`
+- persist it in a nullable `replica_expires_at` column on `snd_file_chunk_replicas` (added to the entitlement migration): `createSndFileReplica` stores `epochSeconds`, `getSndFile` and `getNextSndChunkToUpload` read it back into `GSTExpires`
+- on `SFDONE`, report the file expiry: a chunk expires when its last replica expires (`max` over replicas, absent replicas ignored, `Nothing` only if none report); the file expires when its first chunk expires (`min` over chunks, `Nothing` if any chunk is unknown). `GrantedStorageTime` derives `Ord`
+- `SFDONE` gains a trailing `Maybe GrantedStorageTime` (not str-encoded); chat consumes it (wired later)
+
+Testing:
+
+- e2e test in `tests/XFTPAgent.hs`: generate a BBS keypair, sign a supporter credential (issuer key index 1), run the server with `entitlementKeys = {1: testPk}` and a supporter maximum above the default, run the sender agent with the same `entitlementKeys` and the credential for the user, send a file requesting a number of hours above the default and below that maximum, and assert `SFDONE`'s granted expiry rounds up `now + requested` (proof of the entitlement raising the max above the default)
+- the same upload without the credential is capped at the default maximum
+- the expiry is written before the status, because `BlockingInfo`'s notice parser is terminal (`A.takeByteString`), so any field after the blocking info makes the record unparseable and the file is dropped on restart. Every field added to `AddFile` must go before the status
+- store log round trip in `tests/CoreTests/StoreLogTests.hs`, in the shape of the SMP store log test: a file record survives a write, a read into the store, and compaction, with and without the expiry, including a file blocked with a notice in both cases
+
+## simplex-chat
+
+- remove lifetime badges: make `badgeExpiry` a `UTCTime`, drop the `"lifetime"` encoding, and remove the lifetime option from the UI and the CLI
+- map `BadgeInfo` to `Entitlement` (`entitlementName = textEncode badgeType`, `expiresAt = badgeExpiry`, `extraInfo = badgeExtra`) when calling the agent
+- pass the user's credential to the agent when it is created, and through `setUserEntitlement` when the badge changes, in the same places that pass and update the user's servers
+- pass the storage time to `xftpSendFile`
+- retain the `maxXFTPFileSize` size limit
+- reuse `verifyEntitlement` for peer-badge verification
+- import the issuer public keys from the shared simplexmq constant
+
+## State
+
+Steps 2 to 5 are implemented in simplexmq. Step 1 and step 6 belong to the chat branch that carries badges.
+
+## Order
+
+1. Add the entitlement crypto module; move chat's badge verification onto it and remove lifetime badges.
+2. Add the new XFTP version, the FNEW storage time, and the response.
+3. Change the server configuration, store, expiration, and store log.
+4. Move the proof to the handshake: the handshake field, the session state on the server, and the proof for the session on the client.
+5. Hold the credential per user in the agent, and add the API to replace it.
+6. Wire chat to pass the credential and the storage time.

plans/2026-09-26-client-address-stats.md

@@ -0,0 +1,309 @@
+# Implementation plan: client address statistics
+
+Scope:
+
+- SMP server
+- XFTP server
+- NTF server
+
+## Rules
+
+- Counters per address are kept in memory only.
+- Counters are neither saved nor restored.
+- Prometheus receives aggregates across addresses only.
+- Addresses are not logged.
+- Addresses are shown only by a control port command.
+
+## Address key
+
+```
+data AddrKey
+  = AKIPv4 Word32
+  | AKIPv6 Word64
+```
+
+Key of a socket address:
+
+- IPv4 address: `AKIPv4`.
+- IPv6 address in `::ffff:0:0/96`: `AKIPv4` of its last 32 bits.
+- Other IPv6 address: `AKIPv6` of its first 64 bits.
+- Other address types: not counted.
+
+Text of a key:
+
+- `AKIPv4`: `a.b.c.d`.
+- `AKIPv6`: `xxxx:xxxx:xxxx:xxxx::/64`.
+
+## Counters
+
+Each server has a fixed set of counters:
+
+```
+class (Ord c, Enum c, Bounded c) => AddrCounter c where
+  counterName :: c -> Text
+  counterBounds :: c -> [Int]
+  connectionsCounter :: c
+```
+
+`counterName` is the Prometheus label value and the control port argument.
+
+Counters of every server:
+
+- `connections`: connections passed to the protocol handler, after TLS setup.
+- One counter per command tag, named by the tag: an attempt is counted, failed ones included.
+- `errors`: parse failures and authorization failures.
+
+Command tag types:
+
+- SMP: `CommandTag` in `Simplex.Messaging.Protocol`.
+- XFTP: `FileCommandTag` in `Simplex.FileTransfer.Protocol`.
+- NTF: `NtfCommandTag` in `Simplex.Messaging.Notifications.Protocol`.
+
+A function from a command to its counter is added for each server.
+
+SMP proxy counters, by result of `PRXY`:
+
+- `PRXY_own`: own server.
+- `PRXY_connected`: other server with an existing connection.
+- `PRXY_new`: other server with a new connection.
+- `PRXY_onion`: server with onion hosts only.
+- `PRXY_failed`: error.
+
+SMP proxy counters, by result of `PFWD`:
+
+- `PFWD_own`: own server.
+- `PFWD_other`: other server.
+- `PFWD_onion`: server with onion hosts only.
+- `PFWD_failed`: error other than a protocol error, or no session.
+
+Class precedence: `failed`, then `own`, then `onion`.
+
+XFTP counters:
+
+- `upload_kb`: kilobytes of chunks stored by successful `FPUT`.
+- `download_kb`: kilobytes of chunks sent for `FGET`.
+- `recipients`: recipient keys added by successful `FNEW` and `FADD`.
+
+## Periods
+
+- A period is a fixed interval of `period` seconds. The first period starts at server start.
+- Counts of the current period are accumulated as events occur.
+- Counts of the previous period are the counts of the last closed period.
+- Histograms use the counts of closed periods.
+- The control port command shows the previous and the current counts, sorted by their sum.
+
+## Module `Simplex.Messaging.Server.AddressStats`
+
+```
+data AddrStats c = AddrStats
+  { connectionsCount :: TVar Int,
+    current :: Map c (IORef Int),
+    previous :: Map c (IORef Int)
+  }
+
+type AddrStatsMap c = TMap AddrKey (AddrStats c)
+
+data AddrHistogram = AddrHistogram
+  { bucketCounts :: [Int],
+    countSum :: Int,
+    addressCount :: Int,
+    periodMax :: Int
+  }
+
+newtype AddressStatsConfig = AddressStatsConfig
+  { period :: Int64
+  }
+```
+
+- `current` and `previous` contain one cell per counter, created when the address is inserted.
+- `bucketCounts` are cumulative counts per bound, from server start.
+
+Bounds:
+
+- `countBounds`: 1 to 9, then R10 values times powers of 10, rounded half up to integers, up to 1,000,000: 60 bounds.
+- `kilobyteBounds`: the same, up to 100,000,000: 80 bounds.
+- R10 values: 1, 1.25, 1.6, 2, 2.5, 3.15, 4, 5, 6.3, 8.
+
+Functions:
+
+- `addrKey :: SockAddr -> Maybe AddrKey`
+- `addrKeyText :: AddrKey -> Text`
+- `counterByName :: AddrCounter c => Text -> Maybe c`
+- `withAddrStats :: AddrCounter c => Maybe (AddrStatsMap c) -> Socket -> (Maybe (AddrStats c) -> IO a) -> IO a`:
+  1. The peer address is read with `getPeerName`. On an exception, the connection is not counted.
+  2. In one transaction, the entry is looked up or inserted, and `connectionsCount` is incremented.
+  3. `connectionsCounter` is incremented.
+  4. The action is run. `connectionsCount` is decremented in `finally`.
+- `incAddrCounter :: AddrCounter c => AddrStats c -> c -> IO ()`
+- `addAddrCounter :: AddrCounter c => AddrStats c -> c -> Int -> IO ()`
+- `rolloverAddrStats :: AddrCounter c => AddrStatsMap c -> IORef (Map c AddrHistogram) -> IO ()`, in one pass over the entries, per counter:
+  1. The `current` cell is set to 0. Its value is the closing count.
+  2. A non-zero closing count is added to the histogram: to each bucket with a bound at or above it, to `countSum`, and to `addressCount`.
+  3. `periodMax` is the largest closing count.
+  4. The `previous` cell is set to the closing count.
+  
+  After the pass, an entry is deleted when `connectionsCount` is 0 and every closing count is 0. `connectionsCount` is read in the deleting transaction.
+- `addressStatsThread :: AddrCounter c => AddressStatsConfig -> AddrStatsMap c -> IORef (Map c AddrHistogram) -> IO ()`: `rolloverAddrStats` every `period` seconds.
+- `topAddresses :: AddrCounter c => AddrStatsMap c -> c -> Int -> IO [(AddrKey, Int, Int)]`: the key, previous count and current count of the counter, for up to the given number of entries, sorted by the sum of both counts, largest first. Entries with both counts 0 are excluded.
+- `addrHistogramMetrics :: AddrCounter c => Text -> Map c AddrHistogram -> Text`: Prometheus text for a metric name prefix.
+
+## Prometheus
+
+Written with the other metrics of each server, when both `addressStats` and `prometheus_interval` are set:
+
+```
+# TYPE <prefix>_client_address_period_count histogram
+<prefix>_client_address_period_count_bucket{counter="<name>",le="<bound>"} <addresses>
+<prefix>_client_address_period_count_bucket{counter="<name>",le="+Inf"} <addresses>
+<prefix>_client_address_period_count_sum{counter="<name>"} <sum>
+<prefix>_client_address_period_count_count{counter="<name>"} <addresses>
+# TYPE <prefix>_client_address_period_max gauge
+<prefix>_client_address_period_max{counter="<name>"} <max>
+```
+
+Prefixes:
+
+- `simplex_smp`
+- `simplex_xftp`
+- `simplex_ntf`
+
+In scrape jobs, `convert_classic_histograms_to_nhcb: true` is set.
+
+## Configuration
+
+The same INI section in `smp-server.ini`, `file-server.ini` and `ntf-server.ini`:
+
+```
+[ADDRESS_STATS]
+enable = off
+period = 300
+```
+
+- `enable = off` or an absent section: statistics are off.
+- `period`: seconds.
+
+`iniAddressStats :: Ini -> Maybe AddressStatsConfig` is added to `Simplex.Messaging.Server.CLI`.
+
+Added to `ServerConfig`, `XFTPServerConfig` and `NtfServerConfig`:
+
+```
+addressStats :: Maybe AddressStatsConfig
+```
+
+The section is written by the `init` command of each server with `enable = off`.
+
+With `addressStats` set:
+
+- an `AddrStatsMap` and a histogram reference are added to the server env
+- `addressStatsThread` is added to the server threads
+
+## Control port
+
+Command of the SMP, XFTP and NTF control ports:
+
+```
+addresses <counter> [<n>]
+```
+
+- User role.
+- `<counter>`: a counter name.
+- `<n>`: number of addresses, 10 when absent.
+
+Output of `topAddresses`:
+
+```
+address,previous,current
+<key>,<count>,<count>
+```
+
+Errors:
+
+- Unknown counter name: `error: unknown counter`.
+- Statistics off: `error: address statistics are off`.
+
+Changes:
+
+- `CPAddresses Text (Maybe Int)` is added to `ControlProtocol` in `Simplex.Messaging.Server.Control`, `Simplex.FileTransfer.Server.Control` and `Simplex.Messaging.Notifications.Server.Control`.
+- `addresses` is added to the `help` output of each control port.
+
+## SMP server
+
+In `Simplex.Messaging.Server`:
+
+- `runServer`: in the branch without HTTP, `runTransportServerState_` is called with `TLSServerCredential {credential = smpCreds, sniCredential = Nothing}`. In both branches, the socket is passed to `runClient`.
+- `runClient` is run in `withAddrStats`. The `AddrStats` is passed to `runClientTransport`.
+- `clientAddrStats :: Maybe (AddrStats SMPAddrCounter)` is added to `Client`, as a parameter of `newClient`.
+- `receive`:
+  - The counter of each parsed transmission is incremented.
+  - `errors` is incremented for each parse error and each failed verification.
+- `processProxiedCmd`: the proxy counter is incremented when the result of `PRXY` or `PFWD` is known.
+
+## NTF server
+
+In `Simplex.Messaging.Notifications.Server`:
+
+- `runServer`: `runTransportServerState_` is called with a new `SocketState` and `TLSServerCredential {credential = srvCreds, sniCredential = Nothing}`. The socket is passed to `runClient`.
+- `runClient` is run in `withAddrStats`. The `AddrStats` is passed to `runNtfClientTransport`.
+- `ntfClientAddrStats :: Maybe (AddrStats NtfAddrCounter)` is added to `NtfServerClient`, as a parameter of `newNtfServerClient`.
+- `receive`: counting as in the SMP server.
+
+## XFTP server
+
+In `Simplex.Messaging.Transport.HTTP2.Server`:
+
+- A parameter `Socket -> SessionId -> IO () -> IO ()` is added to `runHTTP2Server`. The handler of each connection is run inside it, after TLS setup.
+- In `getHTTP2Server`, the wrapper only runs the handler.
+
+In `Simplex.FileTransfer.Server`:
+
+- `TMap SessionId (AddrStats XFTPAddrCounter)` is created in `runServer`.
+- In the connection wrapper, the handler is run in `withAddrStats`. The `AddrStats` is inserted in the map before the handler, and deleted in `finally`.
+- `addrStats :: Maybe (AddrStats XFTPAddrCounter)` is added to `XFTPTransportRequest`. It is looked up by session ID for each request.
+- `processRequest`:
+  - The counter of each decoded command is incremented.
+  - `errors` is incremented for each decoding error and each failed verification.
+- `upload_kb` is increased by the chunk size, rounded up to kilobytes, after a successful `FPUT`.
+- `download_kb` is increased by the chunk size, rounded up to kilobytes, when an `FGET` response with the file is sent.
+- `recipients` is increased by the number of recipient keys after a successful `FNEW` or `FADD`.
+
+## Tests
+
+`CoreTests.AddressStatsTests`:
+
+- `addrKey`:
+  - IPv4 address
+  - IPv4-mapped IPv6 address
+  - two IPv6 addresses in one /64: one key
+  - two IPv6 addresses in different /64: two keys
+- bounds:
+  - `countBounds` values
+  - `kilobyteBounds` values
+- `counterByName` of each counter name
+- `rolloverAddrStats`:
+  - histogram buckets, sum, address count, and max
+  - zero counts not added to histograms
+  - previous counts set to closing counts
+  - entry with an open connection kept
+  - entry with closing counts kept
+  - entry without connections and closing counts deleted
+- `topAddresses`:
+  - order by the sum of previous and current counts
+  - number of entries limited
+  - entries with both counts 0 excluded
+- `addrHistogramMetrics` output
+- command to counter function of each server
+
+Server tests, with `addressStats` set and `period` 1:
+
+- SMP basic queue tests
+- SMP proxy tests
+- XFTP basic file tests
+- NTF basic token tests
+
+Control port test, SMP server with `addressStats` and a control port set:
+
+- after messages are sent, `addresses SEND` lists the test client address
+- `addresses` without authentication returns `AUTH`
+- `addresses` with an unknown counter returns `error: unknown counter`
+
+`CLITests`: `enable = off` is checked in `[ADDRESS_STATS]` of each generated INI.

protocol/push-notifications.md

@@ -1,11 +1,12 @@
-Version 3, 2025-01-24
+Version 4, 2026-09-11
 
 # Overview of push notifications for SimpleX Messaging Routers
 
-This document describes Notification Router protocol version 3. Version history:
+This document describes Notification Router protocol version 4. Version history:
 - v1: initial version
 - v2: authenticated commands, command batching
 - v3: detailed invalid token reason
+- v4: entitlement proof in client handshake
 
 ## Table of contents
 
@@ -94,7 +95,7 @@ This diagram shows the process of subscription to notifications, notification de
 
 To manage notification subscriptions to SMP routers, SimpleX Notification Router provides an RPC protocol with a similar design to SimpleX Messaging Protocol router.
 
-This protocol sends requests and responses in a fixed size blocks of 512 bytes over TLS, uses the same [syntax of protocol transmissions](./simplex-messaging.md#smp-transmission-and-transport-block-structure) as SMP protocol, and has the same transport [handshake syntax](./simplex-messaging.md#transport-handshake) (except the router certificate is not included in the handshake).
+This protocol sends requests and responses in a fixed size blocks of 512 bytes over TLS, uses the same [syntax of protocol transmissions](./simplex-messaging.md#smp-transmission-and-transport-block-structure) as SMP protocol, and has the same transport [handshake syntax](./simplex-messaging.md#transport-handshake) (except the router certificate is not included in the handshake). The client handshake carries the protocol version, the router key hash and, from v4, the optional `entitlementProof` with the same syntax and session binding as in SMP.
 
 The client and router use ALPN extension with `ntf/1` protocol name to agree handshake version.
 

protocol/simplex-messaging.md

@@ -86,7 +86,7 @@ It's designed with the focus on communication security and integrity, under the
 
 It is designed as a low level protocol for other application protocols to solve the problem of secure and private message transmission, making [MITM attack][1] very difficult at any part of the message transmission system.
 
-This document describes SMP protocol version 20. Versions 1-5 are discontinued. The version history:
+This document describes SMP protocol version 23. Versions 1-5 are discontinued. The version history:
 
 - v1: binary protocol encoding
 - v2: message flags (used to control notifications)
@@ -108,6 +108,8 @@ This document describes SMP protocol version 20. Versions 1-5 are discontinued.
 - v19: service subscriptions to messages (SUBS, NSUBS, SOKS, ENDS, ALLS commands)
 - v20: public namespaces resolver (RSLV command, RNAME response) — direct or forwarded via PFWD
 - v21: server public information in handshake
+- v22: `RNAME` says whether a name can be registered, not only what it resolves to
+- v23: entitlement proof in client handshake
 
 ## Introduction
 
@@ -1451,53 +1453,150 @@ reads `NameRecord` from. The reference implementation forwards each RSLV to a
 companion REST resolver process (`scripts/resolver/snrc-resolve.py`) that
 queries the SNRC contract on Ethereum; alternative backings (different chains,
 DHT, etc.) are valid as long as they expose the documented HTTP shape (`GET
-/resolve/<name>` returning a `NameRecord` on 200, 404 / 400 for unknown names
-or TLDs, 502 for upstream RPC failures) or substitute a different transport
-while still returning a `NameRecord` matching the encoding below.
+/v2/resolve/<query>` returning a `NameRegistration` on 200 for every
+registration shape, 400 for unknown TLDs, 502 for upstream failures) or
+substitute a different transport returning the same JSON. The resolver API is
+versioned separately from this protocol: `/v1/resolve/<name>` returns a bare
+`NameRecord` and is what relays before v22 call as `/resolve/<name>`.
 
 #### Resolve name command
 
-The `RSLV` command carries the canonical fully-qualified name directly as the
-payload (not JSON):
+The `RSLV` command carries the query as text, not JSON. A client sends the
+hashed form only from v22, and the name itself below it:
 
 ```abnf
-rslv = %s"RSLV" SP domain   ; domain = canonical name as non-space bytes, consuming the remainder of the transmission
+rslv   = %s"RSLV" SP query
+query  = domain / hashed        ; hashed only from v22
+domain = 1*253 OCTET            ; the name as text
+hashed = "[" 64HEXDIG "]" tld   ; keccak-256 of the second-level label
+tld    = %s".simplex" / %s".testing"
 ```
 
 `domain` is the UTF-8 canonical fully-qualified name with the TLD always
 explicit (e.g. `privacy.simplex`, `test.testing`, `example.com`), bounded to
 253 bytes.
 
+**Hashed labels.** The query is a name, or the keccak-256 of a second-level
+label in ENS's bracketed form. A label can only be letters, digits and hyphens,
+so `[` tells the two apart and no tag is needed.
+
+Only a second-level name may be hashed. A name with subnames is sent as text: it
+is resolved rather than priced, and its record names it anyway. A web TLD has no
+registry to key a hash on.
+
+From v22 a client MUST send the hash. Older routers can only read the name, so a
+client on an older session sends the name. A router answering a hashed query
+does not know the label's length, so it cannot check a minimum-length policy
+either: the client does that, from the pricing it is sent.
+
+The same form reaches the backing resolver, which is what its HTTP API takes, so
+the query is one string end to end.
+
+A hashed query still answers with the name. The registrar records the plaintext
+label when a name is registered, keyed by the hash of that label, so a router can
+look up what the hash stands for without ever being told. The router is not
+trusted for it: a client MUST check that the record names the name it asked
+about, and reject the answer otherwise. A registry that does not record the
+label cannot answer a hashed query at all, and the router answers `ERR NAME
+RESOLVER` rather than a record it knows the client will reject. An unregistered
+name has no recorded label, so it cannot be looked up either.
+
 **Server-side validation.** The names router parses `domain` as a
 fully-qualified name (TLD required — bare labels are rejected) and forwards it
 to the configured backing resolver, which is the source of truth for which
 on-chain registry maps to each TLD.
 
-The names router responds with either an `RNAME` response carrying the resolved
-record, or an `ERR NAME` error whose subcode a client iterating across several
-configured servers can act on distinctly:
+The names router responds with either an `RNAME` response saying what it knows
+about the name, or an `ERR NAME` error whose subcode a client iterating across
+several configured servers can act on distinctly:
 
 | Response | Condition | Client action |
 |---|---|---|
-| `RNAME` | record resolved | use it |
-| `ERR NAME NOT_FOUND` | name not registered, unknown TLD, or malformed name | authoritative "no such name" — stop |
+| `RNAME` | the router read the registry | use it |
+| `ERR NAME NOT_FOUND` | below v22 only: every name that does not resolve. From v22 a router never sends it | stop, and do not read it as registrable |
 | `ERR NAME NO_RESOLVER` | this router has no resolver (names role not enabled) | skip this server, try the next |
-| `ERR NAME RESOLVER <detail>` | transient failure: backing resolver error (upstream 5xx, transport, timeout, decode) | transient — retry or surface, do not treat as "not found" |
+| `ERR NAME RESOLVER <detail>` | the router cannot state an answer completely: no registrar or price oracle for the TLD, an unreachable chain, a transport failure, a timeout, a registration it could not date or resolve | surface `<detail>`; retry only if it reads as transient |
 
 A client SHOULD NOT broadcast a `name` to further servers after a name-capable
 router has answered (`NOT_FOUND` or `RESOLVER`), since that router has already
 seen the lookup key; `NO_RESOLVER` discloses nothing about the name beyond the
 fact that this router cannot resolve, so iterating past it is safe.
 
-#### Name record response
+#### Name response
 
-The `RNAME` response carries a JSON-encoded record as the payload:
+`RNAME` answers both what a name resolves to and whether it can be registered.
 
 ```abnf
-rname = %s"RNAME" SP json-bytes   ; json-bytes consumes the remainder of the transmission
+rname = %s"RNAME" SP nameResponse
 ```
 
-`json-bytes` MUST be a UTF-8 JSON object with the following schema:
+`nameResponse` is a UTF-8 JSON object consuming the remainder of the
+transmission: the `registration` below, and `lastBlockTs`, the block timestamp the
+registry was read at. Money is US cents, times are seconds since the Unix epoch, and lengths are
+characters.
+
+| Field | JSON type | Constraints |
+|---|---|---|
+| `lastBlockTs` | number | block timestamp the answer was read at. Absent only from a v20/v21 router, which sent the record alone |
+| `registration` | object | below |
+
+A router reads the registry through a node of its own, which can lag. A name
+registered or changed after `lastBlockTs` still reads as it did before, so a client
+MUST NOT treat an answer as current without checking it.
+
+`registration`'s `type` selects which of the three answers it is.
+
+| `type` | Meaning |
+|---|---|
+| `registered` | held by someone until `expires`, renewable by its owner alone until `graceUntil`. It always carries `nameRecord`: where the owner set none, every field is unset and the resolver address is zero |
+| `available` | held by nobody and registrable now, at `pricing` |
+| `reserved` | held back by the registry and not registered. It carries no price, and a router MUST NOT quote one |
+
+| Field | On | JSON type | Constraints |
+|---|---|---|---|
+| `expires` | `registered` | number | absent only from a v20/v21 router, which sent the record alone |
+| `graceUntil` | `registered` | number | after `expires`; until here only the owner may renew. Absent on the same condition as `expires` |
+| `reservedReason_` | `registered` | string | a reason word, present only when the name is held back as well |
+| `nameRecord` | `registered` | object | the record, schema below |
+| `pricing` | `available` | object | `registrationPrices`, `basePrice` and `minLabelLength`, below |
+| `reservedReason` | `reserved` | string | a reason word |
+
+| `pricing` field | JSON type | Constraints |
+|---|---|---|
+| `registrationPrices` | object | label length, as a decimal string, to US cents per year, for the lengths the registry prices specially |
+| `basePrice` | number | US cents per year for every other length |
+| `minLabelLength` | number | characters; the registry refuses shorter labels |
+
+A reason word is `internal`, `trademark`, `community`, or a word a later version
+reserves under, at most 32 printable ASCII characters. A router truncates an
+unknown word to that and otherwise passes it through unchanged. A client MUST
+read a word it does not know as unknown and still treat the name as reserved.
+
+**Computing the price.** In US cents, for a duration in seconds:
+
+```
+price len duration = tier len * duration / 31536000
+tier len = the entry for len in registrationPrices, or basePrice when there is none
+```
+
+The registry's minimum registration is 730 days, a contract constant, so it is
+specified here rather than sent. `registrationPrices` omits any length below
+`minLabelLength`. A client MUST NOT show a quote for a label the registry
+refuses: a hashed query carries no length, so only the client can check it.
+
+Below v22, `RNAME` carries the bare record and nothing else, and every answer
+without one is `ERR NAME NOT_FOUND`. A v22 client reads such an answer as
+`registered` with no expiry, grace or reservation.
+
+From v22 a client MUST NOT read `ERR NAME NOT_FOUND` as "registrable": only
+`available` says that.
+
+A router that cannot state an answer completely MUST send `ERR NAME RESOLVER
+<detail>` rather than answer partially or guess. That covers a TLD with no
+registrar or price oracle, an unreachable chain, a timeout, a registration it
+could not date or resolve, and any status word it does not recognise.
+
+`nameRecord` MUST be a UTF-8 JSON object with the following schema:
 
 | Field | JSON type | Constraints |
 |---|---|---|
@@ -1514,34 +1613,16 @@ rname = %s"RNAME" SP json-bytes   ; json-bytes consumes the remainder of the tra
 | `owner` | string | `"0x"` followed by 40 lowercase hex characters (20 raw bytes) |
 | `resolver` | string | `"0x"` followed by 40 lowercase hex characters; the resolver contract address that produced the record |
 
-Text fields (`nickname`, `website`, `location`) use the empty string `""` as
-the "unset" sentinel: a backing resolver with no value for the field MUST emit
-an empty string, not JSON `null` and not an absent key. Link fields
-(`simplexContact`, `simplexChannel`) are arrays, primary link first, and use the
-empty array `[]` when unset. Coin fields (`eth`, `btc`, `xmr`, `dot`) use JSON
-`null` as the "unset" sentinel and MAY also be absent from the object entirely.
+Testnet-vs-mainnet status is derived from the queried TLD, not from the record.
 
-The backing resolver filters records that are expired or otherwise unavailable
-(the names router then returns `ERR NAME NOT_FOUND` to the client), so the wire
-format carries no expiry field. Testnet-vs-mainnet status is derived from the
-queried TLD rather than an in-record flag.
+Receivers MUST tolerate extra unknown fields; adding a required field is a
+breaking change requiring an SMP version bump. Receivers parse by key name, so
+peers MUST NOT rely on a byte-canonical form.
 
-Receivers MUST tolerate extra unknown fields (forward-compatibility for future
-field additions). Adding a required field is a breaking change requiring an
-SMP version bump.
-
-**Field order is not significant.** Receivers parse JSON by key name, so object
-key order, insignificant whitespace, and number formatting carry no meaning;
-records are interpreted by decoded value, never compared byte-for-byte. Peers
-MUST NOT rely on a byte-canonical form — a different resolver or server may emit
-the same record with different key order or spacing. This order-independence is
-what makes the format forward-compatible (see the unknown-field rule above).
-
-**Wire-size budget.** The names router caps the resolver response it will
-accept (`resolver_max_response_bytes`, ≤ 16000 bytes, the default) so the
-re-encoded `RNAME` stays within the SMP proxied transmission budget of 16224
-bytes; a response over the cap is rejected as `ERR NAME RESOLVER`. The link
-arrays are bounded by this overall budget rather than a fixed per-field count.
+The names router caps the resolver response it will accept
+(`resolver_max_response_bytes`, at most 16000 bytes) so the re-encoded `RNAME`
+stays within the SMP proxied transmission budget of 16224 bytes; a response over
+the cap is `ERR NAME RESOLVER`.
 
 ## Transport connection with the SMP router
 
@@ -1633,7 +1714,7 @@ cert = originalLength x509encoded
 signedRouterKey = originalLength x509encoded ; X25519 key signed by router certificate
 
 paddedClientHello = <padded(clientHello, 16384)>
-clientHello = smpVersion keyHash [clientKey] proxyRouter optClientService ignoredPart
+clientHello = smpVersion keyHash [clientKey] proxyRouter optClientService optEntitlementProof ignoredPart
 ; chosen SMP protocol version - it must be the maximum supported version
 ; within the range offered by the router
 keyHash = shortString ; router identity - CA certificate fingerprint
@@ -1645,7 +1726,21 @@ serviceRole = %s"M" / %s"N" / %s"P" ; Messaging / Notifier / Proxy
 serviceCertKey = certChain signedServiceKey
 signedServiceKey = originalLength x509encoded ; Ed25519 key signed by service certificate
 
+optEntitlementProof = %s"0" / (%s"1" entitlementProof)
+; proof of the user entitlement, encoded from v23, bound to sessionIdentifier
+entitlementProof = issuerKeyIndex bbsProof entitlement
+issuerKeyIndex = 2*2OCTET ; Word16 index of the issuer public key
+bbsProof = largeString
+entitlement = entExpires entName entExtra
+entExpires = shortString ; expiration as an ISO8601 UTC timestamp
+entName = shortString ; e.g. "supporter", "legend"
+entExtra = largeString ; opaque to the router
+
 smpVersion = 2*2OCTET ; Word16 version number
+shortString = length *OCTET
+largeString = length2 *OCTET
+length = 1*1OCTET
+length2 = 2*2OCTET ; Word16, network byte order
 originalLength = 2*2OCTET
 count = 1*1OCTET
 ignoredPart = *OCTET
@@ -1667,6 +1762,8 @@ serviceId = shortString
 handshakeError = transportError
 ```
 
+`entitlementProof` (v23+) presents the entitlement of the user - its name, expiration and an opaque extra string - as the disclosed content of a BBS proof over the presentation header `sessionIdentifier`, so a proof presented on another session does not verify. The holder secret and the issuer signature remain with the client. Clients send it only to their own routers, identified by the key hash pinned in TLS.
+
 `ignoredPart` in handshake allows to add additional parameters in handshake without changing protocol version - the client and routers must ignore any extra bytes within the original block length.
 
 For TLS transport client should assert that `sessionIdentifier` is equal to `tls-unique` channel binding defined in [RFC 5929][14] (TLS Finished message struct); we pass it in `routerHello` block to allow communication over some other transport protocol (possibly, with another channel binding).

protocol/xftp.md

@@ -1,4 +1,4 @@
-Version 3, 2025-01-24
+Version 4, 2026-08-08
 
 # SimpleX File Transfer Protocol
 
@@ -50,11 +50,12 @@ The objective of SimpleX File Transfer Protocol (XFTP) is to facilitate the secu
 
 XFTP is implemented as an application level protocol on top of HTTP2 and TLS.
 
-This document describes XFTP protocol version 3. The version history:
+This document describes XFTP protocol version 4. The version history:
 
 - v1: initial version
 - v2: authenticated commands - added basic auth support for commands
 - v3: blocked files - added BLOCKED error type for policy violations
+- v4: server public information and entitlement proof in handshake, file storage time in FNEW and SIDS
 
 The protocol describes the set of commands that senders and recipients can send to XFTP routers to create, upload, download and delete data packets of several pre-defined sizes. XFTP routers SHOULD support packets of 4 sizes: 64KB, 256KB, 1MB and 4MB (1KB = 1024 bytes, 1MB = 1024KB).
 
@@ -329,7 +330,7 @@ Once TLS handshake is complete, client and router will exchange blocks of fixed
 
 ```abnf
 paddedRouterHello = <padded(routerHello, 16384)>
-routerHello = xftpVersionRange sessionIdentifier routerCerts signedRouterKey ignoredPart
+routerHello = xftpVersionRange sessionIdentifier routerCerts signedRouterKey webIdentityProof serverInfo ignoredPart
 xftpVersionRange = minXftpVersion maxXftpVersion
 minXftpVersion = xftpVersion
 maxXftpVersion = xftpVersion
@@ -338,15 +339,27 @@ sessionIdentifier = shortString
 routerCerts = length 1*routerCert ; NonEmpty list of certificates in chain
 routerCert = originalLength <x509encoded>
 signedRouterKey = originalLength <x509encoded> ; signed by router certificate
+webIdentityProof = shortString ; signature over the web client challenge and sessionIdentifier, empty when the client sent no challenge
+serverInfo = %s"0" / (%s"1" largeString) ; JSON server public information, sent when maxXftpVersion is 4 or above
 
 paddedClientHello = <padded(clientHello, 16384)>
-clientHello = xftpVersion keyHash ignoredPart
+clientHello = xftpVersion keyHash entitlementProof ignoredPart
 ; chosen XFTP protocol version - must be the maximum supported version
 ; within the range offered by the router
 
+entitlementProof = %s"0" / (%s"1" issuerKeyIndex bbsProof entitlement)
+; proof of the user entitlement, encoded from v4, bound to sessionIdentifier
+issuerKeyIndex = 2*2OCTET ; Word16 index of the issuer public key
+bbsProof = largeString
+entitlement = entExpires entName entExtra
+entExpires = shortString ; expiration as an ISO8601 UTC timestamp
+entName = shortString ; e.g. "supporter", "legend"
+entExtra = largeString ; opaque to the router
+
 xftpVersion = 2*2OCTET ; Word16 version number
 keyHash = shortString
 shortString = length length*OCTET
+largeString = originalLength *OCTET
 length = 1*1OCTET
 originalLength = 2*2OCTET
 ignoredPart = *OCTET
@@ -432,7 +445,7 @@ Routers SHOULD support basic auth with this command, to allow only router owners
 The syntax is:
 
 ```abnf
-register = %s"FNEW " fileInfo rcvPublicAuthKeys basicAuth
+register = %s"FNEW " fileInfo rcvPublicAuthKeys basicAuth fileStorageTime
 fileInfo = sndKey size digest
 sndKey = length x509encoded
 size = 4*4 OCTET ; Word32 big-endian
@@ -440,19 +453,27 @@ digest = length *OCTET
 rcvPublicAuthKeys = length 1*rcvPublicAuthKey
 rcvPublicAuthKey = length x509encoded
 basicAuth = "0" / "1" length *OCTET
+fileStorageTime = %s"0" / (%s"1" storageHours)
+; encoded from v4; absent or zero requests the maximum the router allows
+storageHours = 4*4 OCTET ; Word32 big-endian
 
 x509encoded = <binary X509 key encoding>
 
 length = 1*1 OCTET
 ```
 
+`fileStorageTime` requests how long the router stores the data packet. The router grants the smaller of the request and the maximum it allows for the entitlement presented in the handshake, and returns the granted expiration in `sndIds`.
+
 If the data packet is registered successfully, the router must send `sndIds` response with the sender's and recipients' data packet IDs:
 
 ```abnf
-sndIds = %s"SIDS " senderId recipientIds
+sndIds = %s"SIDS " senderId recipientIds grantedStorageTime
 senderId = length *OCTET
 recipientIds = length 1*recipientId
 recipientId = length *OCTET
+grantedStorageTime = %s"0" / (%s"1" grantedExpires) ; encoded from v4
+grantedExpires = %s"T" expiresAt
+expiresAt = 8*8 OCTET ; Int64 big-endian, seconds since epoch
 ```
 
 #### Add data packet recipients

rfcs/2026-08-22-xftp-file-storage-time.md

@@ -0,0 +1,109 @@
+# XFTP variable file storage time
+
+## Summary
+
+The server stores a storage time for each file. The sender sets it in the FNEW command. The client may present a proof of an entitlement in the handshake to raise the maximum storage time the server allows. The proof is bound to the TLS session, so it cannot be reused for another session.
+
+An entitlement belongs to the user, not to a file: the client presents it once per connection, and the server applies it to everything the client does in that session. The server can also vary other limits, such as throttling, by the entitlement.
+
+## Entitlement
+
+An entitlement is a name, an expiration, and an extra string. It is the disclosed content of a BBS proof: the holder's secret remains undisclosed, and the three fields are revealed. The server reads `entName` to select a maximum storage time, checks `entExpires`, and ignores `entExtra`; the interpretation of `entExtra` is out of scope here. The protocol references only the entitlement, never a badge; chat maps its own badge to an entitlement before it asks the agent to send.
+
+The proof discloses the entitlement and includes the issuer key index and the BBS proof. The holder's secret and the BBS signature remain with the sender and are never transmitted. The origin of the sender's signed entitlement, from the entitlement service, is out of scope here.
+
+```
+entitlement = entExpires entName entExtra
+entExpires = shortString     ; expiration as a UTCTime ISO8601 string
+entName = shortString        ; e.g. "supporter", "legend"
+entExtra = largeString       ; opaque, interpretation out of scope
+
+entitlementProof = issuerKeyIndex bbsProof entitlement
+issuerKeyIndex = 2*2 OCTET   ; Word16, network byte order
+bbsProof = largeString       ; BBS proof bytes
+```
+
+The presentation header that the BBS proof is generated over is not transmitted; the server takes it from the session (see [Binding](#binding)), which is what binds the proof.
+
+### Issuer keys
+
+Client apps and servers share one list of issuer public keys, indexed by `issuerKeyIndex`. The secret key for the current index is held by the service that issues entitlements, on conditions that are out of scope here, such as payment.
+
+The list holds eight keys so that the issuing service can rotate its current key without an app or server release: the next index is already known to every app and server. Each rotation consumes one index, so a new key has to be added to client apps and servers eventually, and released before the list is exhausted.
+
+## Storage time
+
+```
+fileStorageTime = %s"0" / (%s"1" storageHours)
+storageHours = 4*4 OCTET     ; Word32, network byte order
+```
+
+The storage time is an optional number of hours. Absent (`%s"0"`), or present as zero hours, requests the maximum the server allows for the presented entitlement, or the default maximum when no proof is present. A value above zero requests that number of hours, and the server grants the smaller of it and the maximum.
+
+## Handshake, new XFTP version
+
+The client handshake carries the entitlement proof.
+
+```
+clientHandshake = xftpVersion keyHash optEntitlementProof
+optEntitlementProof = %s"0" / (%s"1" entitlementProof)
+```
+
+`xftpVersion` and `keyHash` are defined by the current XFTP protocol. Version 3 and earlier encode no proof.
+
+The server verifies the proof when it accepts the handshake and keeps the result for the session; further handshakes on the same connection keep that result and verify nothing, so a session costs one verification however many handshakes it makes. A proof that names an entitlement the server does not configure, or one whose expiration passed 24 hours ago or more, is ignored without verification; a proof that fails to verify is logged. In each case the session gets the default maximum. The response is the same in every case, but only a configured, unlapsed name costs a verification, so the handshake latency tells the client which names the server configures.
+
+## Commands
+
+The new protocol version extends FNEW with the storage time.
+
+```
+fnew = %s"FNEW " fileInfo rcvKeys optBasicAuth fileStorageTime
+```
+
+`fileInfo`, `rcvKeys`, and `optBasicAuth` are defined by the current XFTP protocol. Version 3 and earlier encode no `fileStorageTime`, and the server applies the default storage time.
+
+## Responses
+
+FNEW extends the SIDS response with the granted storage.
+
+```
+sndIds = %s"SIDS " senderId rcvIds optGrantedStorageTime
+optGrantedStorageTime = %s"0" / (%s"1" grantedStorageTime)
+grantedStorageTime = grantedExpires
+grantedExpires = %s"T" expiresAt
+expiresAt = 8*8 OCTET        ; Int64, seconds since epoch (absolute UTC instant), network byte order
+```
+
+`grantedExpires` returns the absolute expiration — the same value stored for the file. The sum encoding retains a one-character prefix so further variants can be added. Version 3 and earlier omit `optGrantedStorageTime` entirely; a client decoding such a response reads it as absent. `senderId` and `rcvIds` are defined by the current XFTP protocol.
+
+## Binding
+
+The presentation header binds the proof to the TLS session, so a proof presented on any other session fails to verify.
+
+```
+presHeader = sessionId
+```
+
+`sessionId` is the TLS session identifier, the TLS unique channel binding. Both sides take it from the connection: the client has it once TLS is established, and the client checks that the identifier the server sends in its handshake matches.
+
+Binding to the session is what stops a proof being replayed by another client. A proof is not bound to a file, because the entitlement belongs to the user and authorises everything the client does in that session.
+
+BBS proofs of one credential are unlinkable, but every proof discloses the same `entExpires`, `entName` and `entExtra`, so a server can link the sessions of one holder by that triple, and two servers can correlate them. The issuing service decides how identifying it is: `entExpires` set to the same instant for everyone who buys in the same period, and an `entExtra` that carries nothing per-holder, make the holders of that period indistinguishable.
+
+## Maximum storage time
+
+The server configures a maximum storage time for each entitlement name, and a default maximum for requests with no proof. Each maximum is a number of hours. The server exits at startup if any name's maximum is below the default, so a proof never reduces the allowed time. The server honours an entitlement for 24 hours after its expiration; past that grace it is treated as no proof.
+
+If the requested time exceeds the maximum, the server stores the file for the maximum and does not reject the request. The expiration is rounded up to the hour, stored, and returned as `grantedExpires`.
+
+## Encoding primitives
+
+```
+shortString = length *OCTET   ; 0-255 bytes
+largeString = length2 *OCTET
+length = 1*1 OCTET
+length2 = 2*2 OCTET           ; Word16, network byte order
+```
+
+`senderId`, `rcvIds`, `fileInfo`, `sndKey`, `digest`, `rcvKeys`, `optBasicAuth`, and `sessionId` are defined by the current XFTP and SMP protocols.

rfcs/2026-09-11-proof-of-work.md

@@ -0,0 +1,422 @@
+# Proof of work for resource creation
+
+## Summary
+
+A client presents a proof of work when it asks a server to create a resource: an SMP queue, an XFTP file chunk, a notification token. The required effort is the price of the resource: its cost in units multiplied by the price per unit.
+
+The server sets one price per unit for each tier: sessions without an entitlement, and sessions of each entitlement name. The prices are independent, so a flood in one tier raises the price of that tier alone.
+
+The proof is bound to the transport session, so it is valid on one connection to one server, and single use within it.
+
+## Interaction
+
+The exchange adds no round trip. The server handshake states the prices and the server time, the session id is the challenge input that both sides already hold, and the client attaches a proof to the command that creates the resource.
+
+Nothing is sent back for the price alone: it rides the messages that already exist.
+
+## Freshness
+
+A proof states the minute it was made for, and expires after a few minutes.
+
+Without an expiry a client mints proofs for as long as a session lasts and spends the stock in one burst. The stock is minted at the idle price, so a rising price reaches the burst after it lands, and an hour of one machine arrives in seconds. The expiry bounds the stock to the work of one window.
+
+```
+powEpoch = 4*4 OCTET    ; Word32, minutes of server time
+```
+
+The server sends its current epoch in the handshake, and the client counts minutes from it with a monotonic clock, so the clock of the device takes no part. A proof verifies while `serverEpoch - powEpoch` is within the advertised window, and one epoch ahead of the server is admitted for rounding.
+
+The window is the burst a client may prepare: a stock of `window * mint rate`. At 5 minutes and a price of 16, one desktop core holds about 2800 queue proofs.
+
+A price increase cuts the stock a second way. A proof states the effort it was made for, so every proof below the new price is rejected, and the stock of an attacker survives an increase only at the effort it paid for in advance. The two bounds compose: the stock is worth the smaller of one window of minting and the time until the next increase.
+
+## What Tor does
+
+Tor proposal 327 and the [hspow specification](https://spec.torproject.org/hspow-spec/) define a client puzzle for onion service introduction.
+
+- Function: Equi-X (Equihash(60,3) over HashX) with a Blake2b target check. Solution 16 bytes, solver memory 1.8 MiB, verification 50-120 microseconds.
+- Effort: a 32-bit number `E`. The solution passes when `R * E <= UINT32_MAX`, where `R` is the first 32 bits of `blake2b_32(challenge || S)`. `E` is the expected number of candidate solutions tested, so cost is linear in `E`.
+- Challenge: `P || ID || C || N || htonl(E)` - personalisation, service identity, a 32-byte seed from the service descriptor, a 16-byte nonce, effort.
+- Freshness: the service publishes a seed in its descriptor and rotates it every 105-120 minutes, keeps the previous seed, and holds a replay cache of used `(seed, nonce)` pairs.
+- Selection: verified requests enter a priority queue ordered by effort. Overfull queues discard the lower-effort half.
+- Adaptation: every 300 seconds the service updates `suggested-effort` by additive increase and multiplicative decrease. Increase to `max(previous + 1, TOTAL_EFFORT / REND_HANDLED)` when the queue was congested or when a trimmed request exceeded the current effort; multiply by `2/3` when the queue stays short. The value is published in the descriptor.
+- Client retry: on timeout, refetch the descriptor, then double the effort below 1000, multiply by 1.5 above it, within [8, 10000].
+
+Tor solves a reachability problem: many clients compete for one bottleneck, so they bid and the service serves the highest bids.
+
+## What we change
+
+Our problem is the price of a stored resource, so the auction is replaced by a price list.
+
+1. Threshold, not bidding. The server states the required effort; the client sends exactly that. The priority queue and its trimming are dropped. A faster device gains no priority, so the effort value describes the request rather than the device.
+2. Session binding, not seeds. The challenge includes the hash of the transport session id, which both sides already hold. This removes seed generation, seed rotation, seed publication, and the two-seed overlap.
+3. Single use by a counter, not by a replay cache. Each proof carries a session counter, and the server keeps the highest counter it accepted plus a 64-bit window of the counters below it. Per-session state is 16 bytes, against 16 bytes per accepted proof for a set of nonces. Tor needs the set because one seed spans many connections; a proof here is valid on one connection only.
+4. An expiry of minutes, against the seed window of two hours in Tor. A stock of proofs is worth one window of minting, so a price increase reaches a burst that was prepared under the old price.
+5. Prices set by the operator. Effort is the resource cost in units multiplied by the price per unit, and the operator sets the price. The estimator of Tor is deferred.
+6. One price per tier. The server knows the tier of every session, so a flood shows in its tier, and raising that price leaves the other tiers unchanged. An attacker without a badge leaves the price of badge holders where it was; an attacker with a supporter badge leaves the price of legend holders where it was.
+7. An entitlement lowers the price, and neither raises it nor removes it. A credential presents on any number of sessions without linking them, so a free tier would sell an attacker unlimited creation for the price of one badge; and a badge that could cost more than no badge would break the promise it was sold with, the promise the XFTP server keeps for storage time.
+8. A budget for clients of earlier versions, where Tor serves them at the lowest priority. They cannot pay, so they share a number of creations per minute.
+
+Kept from Tor: the Equi-X function, the linear effort scale, the verification formula, and the exact byte definitions of the target check.
+
+## Cost units
+
+Each protocol defines the unit of its own price list. The server advertises the price per unit; the client computes the effort of its request.
+
+```
+SMP:  1 unit per new queue
+      1 unit per queue link data record (in NEW, or in LSET on a queue without one)
+XFTP: 1 unit per 64 KB stored for 24 hours
+      chunkUnits = ceil(size / 65536 * storageHours / 24)
+      storageHours = min(requested hours, maximum hours of the tier); absent or 0 = the maximum
+NTF:  1 unit per token registration
+```
+
+`effort = price * units`, capped at 2^32 - 1.
+
+64 KB is the smallest chunk. The server takes chunks of 64 KB, 256 KB, 1 MB and 4 MB, and the test configuration adds 128 KB; each is a whole number of units.
+
+## Handshake parameters
+
+Each protocol adds one optional field to the server handshake, encoded from the version that introduces proof of work.
+
+```
+powParams = %s"0" / (%s"1" powScheme defaultPrice entPrices serverEpoch epochWindow)
+powScheme = 1*1 OCTET        ; 1 = Equi-X and Blake2b
+defaultPrice = tierPrice     ; without an entitlement; price 0 = proof not required
+entPrices = count *entPrice
+entPrice = entName tierPrice
+entName = shortString        ; entitlement name, as in the entitlement proof
+serverEpoch = 4*4 OCTET      ; Word32, current minute of server time
+epochWindow = 1*1 OCTET      ; minutes a proof stays valid
+
+SMP, NTF:  tierPrice = price
+XFTP:      tierPrice = price storageHours
+price = 4*4 OCTET            ; Word32, effort per unit
+storageHours = 4*4 OCTET     ; Word32, maximum storage time of the tier
+```
+
+The server handshake precedes the client handshake that carries the entitlement proof, so every price is sent. The client applies the price of its entitlement name, and the default price when it presented no entitlement or when its name is absent from the list.
+
+The XFTP client learns the maximum storage time of its tier from the same entry, so it computes the units of a chunk that asks for the maximum. The grant in `SIDS` stays as it is.
+
+## Algorithm
+
+Equi-X, by tevador, is Equihash(60,3) with two changes: the hash is HashX, and the indices are summed modulo 2^60 rather than xored.
+
+HashX takes a seed - here the challenge - and generates a short program of integer instructions over eight 64-bit registers, which maps a 64-bit input to a 64-bit output. The program differs for every seed, so hardware built for one program serves no other. That is where the resistance to an ASIC comes from, and what narrows the distance to a GPU.
+
+HashX runs the program in one of two modes. Compiled, it writes machine code for x86-64 or arm64 into executable memory, and hashes in under 100 nanoseconds. Interpreted, it hashes in 1-2 microseconds. Our clients take the interpreter on every platform: iOS refuses executable memory to App Store apps, GrapheneOS stops an Android app that loads code at run time, and desktop clients follow the phones. An attacker enables the compiler with one flag, `EQUIX_CTX_COMPILE`, or runs the benchmark of tevador as it is.
+
+Solving finds eight 16-bit indices `i0..i7` with `HX(i0) + ... + HX(i7) = 0 (mod 2^60)`, under the tree conditions of Wagner's algorithm - 15 trailing zero bits on each pair, 30 on each quadruple, 60 on the sum - and an ordering condition that makes the solution canonical. The solver holds tables over 2^16 items, which is the 1.8 MiB. A solution is `8 * uint16`, so 16 bytes, and one call returns about two of them.
+
+Verification recomputes the eight HashX values and checks the three sums. It takes 50-120 microseconds and a few kilobytes.
+
+The protocol layer above it is the target check: a solution counts when `blake2b_32(challenge || solution) * effort <= 2^32 - 1`. Finding a solution is the constant cost; landing one in a slice of `1/effort` is the price. Expected solver calls are `effort / 2`, and expected tested solutions are `effort`.
+
+## Code
+
+```
+C, the reference:  https://github.com/tevador/equix   LGPL-3.0, hashx as its submodule
+                   https://github.com/tevador/hashx   LGPL-3.0
+Rust, the port:    arti crates equix 0.7.1, hashx 0.9.1, LGPL-3.0-only
+Tor, in use:       src/ext/equix (vendored), src/feature/hs/hs_pow.c and hs_pow.h
+```
+
+The library is a git submodule at `cbits/equix`, from a fork under simplex-chat, as `cbits/libbbs` is today; hashx comes in as its nested submodule. The fork starts from tevador's repository, after a comparison with the copy in Tor for fixes. The C sources are listed in `c-sources`, and the Haskell side is a foreign import of the four calls below.
+
+```c
+equix_ctx* equix_alloc(equix_ctx_flags flags);  /* EQUIX_CTX_SOLVE | EQUIX_CTX_COMPILE, or EQUIX_CTX_VERIFY */
+int equix_solve(equix_ctx* ctx, const void* challenge, size_t size, equix_solution out[8]);
+equix_result equix_verify(equix_ctx* ctx, const void* challenge, size_t size, const equix_solution* sol);
+void equix_free(equix_ctx* ctx);
+```
+
+A context holds the program generated for the current challenge, so each thread allocates its own: one per solver thread on the client, a small pool on the server. Clients allocate without `EQUIX_CTX_COMPILE`.
+
+`hs_pow.c` is the closest model for our code: `build_equix_challenge` and `validate_equix_challenge` are the two functions we reimplement with our own challenge, `hs_pow_solve` is the search loop, `hs_pow_verify` is the order of checks, and `hs_pow_queue_work` runs solving on the worker pool at low priority.
+
+The licence is LGPL-3.0 for both implementations. Our library is AGPL-3.0, so linking asks nothing new of us, while a closed-source consumer of the library acquires the obligations of the LGPL for that part.
+
+## Proof
+
+```
+proofOfWork = powEffort powEpoch powNonce powSolution
+powEffort = 4*4 OCTET      ; Word32, the effort this proof was made for
+powEpoch = 4*4 OCTET       ; Word32, the minute of server time this proof was made for
+powNonce = powCounter powSearch
+powCounter = 4*4 OCTET     ; Word32, the counter of this proof in the session
+powSearch = 12*12 OCTET    ; the value the solver varies
+powSolution = 16*16 OCTET  ; Equi-X solution
+```
+
+40 bytes.
+
+```
+challenge = personalisation sessionHash htonl(powEffort) htonl(powEpoch) powNonce
+personalisation = 16*16 OCTET  ; "SimpleX PoW v1 " and one of %s"S" / %s"X" / %s"N"
+sessionHash = 32*32 OCTET      ; sha256 of the transport session id
+```
+
+The client picks the next counter and a random search value, calls `equix_solve(challenge)`, computes `R = ntohl(blake2b_32(challenge || S))`, and accepts the solution when `R * E <= 2^32 - 1`, computed in 64 bits. Otherwise it increments the search value as a little-endian integer and repeats.
+
+```
+S = packed solution         ; 8 indices, each a little-endian uint16, 16 bytes
+blake2b_32 = BLAKE2b initialised with a 4-byte output length
+R = the 4 bytes of blake2b_32, read big-endian
+```
+
+BLAKE2b with a 4-byte output length differs from the first 4 bytes of BLAKE2b-512, because the length is a parameter of the initial state. Both definitions follow `validate_equix_challenge` and `pack_equix_solution` in `hs_pow.c`.
+
+Counters are assigned in order and spent in order. A client that solves on several cores gives each core its own counter.
+
+A proof verifies only under the protocol letter and the session hash it was made for, so it fails on another protocol, another server, and another connection.
+
+## Commands
+
+The proof is an optional field of the commands that create resources.
+
+```
+smpNew = %s"NEW " rcvAuthKey rcvDhKey optBasicAuth subMode optQueueReqData optNtfCreds optProofOfWork
+smpLSet = %s"LSET " linkId queueLinkData optProofOfWork
+fnew = %s"FNEW " fileInfo rcvKeys optBasicAuth fileStorageTime optProofOfWork
+tnew = %s"TNEW " newNtfTkn optProofOfWork
+optProofOfWork = %s"0" / (%s"1" proofOfWork)
+```
+
+`LSET` is priced when the queue holds no link data; on a queue that holds some, it replaces the data and carries no proof. `NKEY`, `FADD` and `SNEW` are not priced. The first message to an unknown queue is out of scope.
+
+A batch of transmissions carries one proof per command. Creation commands are sent to the servers of the user over a direct session, so the proxy carries none of them.
+
+## Verification
+
+The server checks, in this order:
+
+1. `powEffort >= price of the tier of the session * units of the request` - integer comparison.
+2. `powEpoch` within the epoch window of the server, and at most one epoch ahead.
+3. `powCounter` is above the window of the session, or inside it and unused.
+4. `R * powEffort <= 2^32 - 1` - one Blake2b of 88 bytes.
+5. `equix_verify(challenge, S) == EQUIX_OK` - 50-120 microseconds.
+6. The counter is marked, and the resource is created.
+
+The counter is marked on every verified proof, including one whose command then fails, so a proof pays for one attempt.
+
+The window holds the last 64 counters, which admits proofs that arrive out of order, from commands sent concurrently on one session. A counter below the window is rejected, and the client that skipped ahead loses the proofs it left behind.
+
+Steps 1 to 3 cost less than a microsecond. Step 4 costs an attacker about `effort` Blake2b calls to pass with a random solution, so the Equi-X call in step 5 is what a forged proof buys. The server closes a session after 3 consecutive proofs that fail step 4 or step 5. An honest client checks its proof before sending it, so it never fails these steps; a stale proof or one below the price fails steps 1 to 3, which can happen to an honest client after a change of price or epoch, and closes nothing.
+
+## Entitlement
+
+SMP and NTF servers verify the entitlement proof in the handshake, as the XFTP server does. A name the server prices is verified once per session; a name it does not price is ignored without verification, and the session pays the default price. A proof that fails to verify leaves the session at the default price too.
+
+The tier of the session is fixed at the handshake, so every command in it is priced without further work.
+
+An entitlement lowers the price, and neither raises it nor removes it:
+
+```
+min(1, price) <= price_for_<name> <= price
+```
+
+The server exits at startup when a configured price breaks this rule, and logs each name that breaks it, as the XFTP server does when an entitlement storage time is below the default. An entitlement price equal to the default is allowed, as an equal storage time is on XFTP.
+
+The control port sets the three prices in one command, and refuses a triple that breaks the rule. The triple is checked as a whole, so the order in which prices change plays no part.
+
+This gives the badge a function on SMP and NTF, where it grants nothing today: the holder pays less CPU time, and a flood outside its tier leaves its price where it was.
+
+## Services
+
+A service session creates resources without a proof when the SMP server records its service as created before a configured date. `serviceCreatedAt` of the service record holds that date, so the services that presented certificates before the release are exempt, and the rule needs no migration.
+
+```
+[PROOF_OF_WORK]
+exempt_services_created_before = 2026-10-15
+```
+
+A service registered after that date pays the default price. Exempt sessions are a tier of their own in the statistics.
+
+The date is a transition. The follow-up work gives services a certificate signed by an operator, an online certificate under an offline one as SMP servers have, issued on a certificate request from each partner; a server recognises the operators in its configuration and exempts their services. It is out of scope here.
+
+## Clients of earlier versions
+
+A session below the version that introduces proof of work cannot present a proof. Its creation commands draw on one budget, shared by all such sessions: a number of creations per minute, set on the control port, unlimited at first.
+
+While an attacker uses a client of the proof-of-work version, the budget goes to clients of earlier versions and none of them notices it. When an attacker uses an earlier client, the damage is the budget. A budget of zero refuses them all; the generic lever against earlier versions stays the version range, set without a release.
+
+A command over the budget receives a new error, `BUSY`:
+
+```
+SMP:  ERR BUSY
+XFTP: FRErr BUSY
+NTF:  NRErr BUSY
+```
+
+The serializer sends `BUSY` to a session of the proof-of-work version as it is, and maps it for a session of an earlier version, as it maps `BLOCKED` for sessions below `clientNoticesSMPVersion` today:
+
+```
+SMP:  BUSY -> STORE busy
+NTF:  BUSY -> STORE busy
+XFTP: BUSY -> TIMEOUT
+```
+
+SMP and NTF share `ErrorType`, which has no `TIMEOUT`. Among the errors an SMP or NTF server sends, agents from simplexmq 7.0.0 retry only `STORE`; that release introduced SMP version 19 and ships in the apps from 7.0.0. An asynchronous `NEW` or `JOIN` of these agents retries with a growing interval and takes the next server of the user on each attempt, so a refused client moves to a server that has budget left. The XFTP agent retries `FNEW` on `TIMEOUT` from simplexmq 5.8.0. `TNEW` returns the error to the app that called `registerNtfToken`, and the agent holds no retry loop for it. An interactive command shows the error once, and the deployed apps show `STORE busy` in their generic error alert.
+
+Agents below SMP version 19 retry no error that a server sends. They end an asynchronous command on `STORE`, and the app of these versions shows the error without retrying the command, so a refused connection to a group member is lost.
+
+The other errors mislead or stop the client: `QUOTA` is shown as a connection that reached its limit of undelivered messages, `AUTH` as a connection error of authorisation, and in the deployed agents both end an asynchronous command. A budget of zero keeps the retries of clients from version 19 running at the longest interval, and a raised budget lets them through without an update.
+
+A client of the proof-of-work version shows `BUSY` to the user: an interactive command shows it at once, and a background command shows it when its retries expire on the client.
+
+## Learning the price
+
+The price reaches the client three ways, and each of them is a message the protocol already sends.
+
+1. The server handshake, at the start of the session. It states the price of every tier, because the entitlement proof arrives in the client handshake that follows.
+2. The response to a priced command. It states the price of the tier of the session, so a client that paid the old price learns the new one while its command succeeds.
+3. The error below, when the proof was absent, stale, or below the price. A client whose entitlement failed to verify learns here that it pays the default price.
+
+```
+powPrice = price serverEpoch  ; 8 bytes, appended to the response of a priced command
+```
+
+An increase costs one rejected command and the proof spent on it. A decrease costs nothing: the client over-pays until its next response, which states the lower price. A client that has been idle for longer than the epoch window solves at the last price it read, and pays one retry when the price moved meanwhile.
+
+The prices are public, as the suggested effort is in Tor, and the list of priced entitlement names is public with them.
+
+## Errors and retry
+
+A new error carries the price and the time of the server.
+
+```
+SMP:  ERR POW price epoch
+XFTP: FRErr (POW price epoch)
+NTF:  NRErr (POW price epoch)
+```
+
+The client resets its price and epoch from the error, solves at the stated price, and retries. Two retries are allowed for one command, which covers a price that moves again while the client solves; past that it reports that the server is busy, as it does when the effort exceeds its own maximum.
+
+A proof made for a higher effort than required is accepted, so a proof that outlives a decrease stays usable while its epoch holds.
+
+## Setting prices
+
+The operator sets the prices: the configuration holds the values the server starts with, and the control port reads and changes them while it runs.
+
+```
+[PROOF_OF_WORK]
+price = 16                  ; effort per unit without an entitlement, 0 = proof not required
+price_for_supporter = 4     ; effort per unit with the supporter entitlement, at least 1 and at most price
+price_for_legend = 2        ; effort per unit with the legend entitlement, at least 1 and at most price
+epoch_window_minutes = 5
+exempt_services_created_before = 2026-10-15
+```
+
+The keys follow `expire_files_hours_for_<name>` of the XFTP server, and on the XFTP server both keys name the same entitlements.
+
+Control port commands, on SMP, XFTP and NTF servers:
+
+```
+pow                    ; user role: prices, budget of earlier versions, epoch window, counts of the current period per tier
+pow p0 p1 p2           ; admin role: set the prices - p0 without an entitlement, p1 supporter, p2 legend
+pow old <n>            ; admin role: set the budget of earlier versions, creations per minute
+pow old unlimited      ; admin role: remove the budget
+```
+
+A change reaches new sessions through the handshake, and sessions in progress through their next response or error.
+
+Prices and the budget set on the control port are saved with the server state and restored at start, so a change made during an attack survives a restart that the attack outlasts. While they differ from the configuration, the server logs a warning at stop and at start, and `pow` shows both values.
+
+The XFTP and NTF control ports gain the admin role check that the SMP control port already has; both check the user role today.
+
+The estimator of Tor is deferred. If prices set by hand prove too slow, it runs per tier on the creations of that tier, between bounds set on the control port.
+
+## Statistics
+
+The server counts per tier, so a flood shows in its tier, and the use of each entitlement is accounted for. Sessions without an entitlement are counted under `default`, exempt services under `service`, and sessions of earlier versions under `old`.
+
+```
+sessions            ; sessions of the tier
+entFailed           ; entitlement proofs that failed to verify
+proofsAccepted
+effortAccepted      ; sum of the effort of accepted proofs
+proofsAbsent
+proofsBelowPrice
+proofsStale         ; epoch outside the window
+proofsReused        ; counter below the window or already marked
+proofsInvalid       ; Blake2b target or Equi-X check failed
+sessionsClosed      ; sessions closed after invalid proofs
+overBudget          ; creations of earlier versions refused by the budget
+created             ; queues, chunks or tokens created
+```
+
+The counts appear in `pow` for the current period, in the stats log, and in the Prometheus metrics. They name a tier, never a session.
+
+## Costs
+
+The rates below are estimates to be replaced by measurement on devices.
+
+A solver call hashes 2^16 indices. Compiled, a desktop core makes about 150 candidate solutions per second, measured by tevador. Interpreted at 1-2 microseconds per hash, a call spends about 100 milliseconds hashing, so the same core makes about 15-25, and a phone core, about three times slower, about 5-8.
+
+```
+effort   desktop, compiled   phone, interpreted
+     4              0.03 s                0.6 s
+    16              0.1 s                 2.5 s
+    64              0.4 s                10 s
+   256              1.7 s                40 s
+```
+
+A queue at a price of 4 costs a phone about 0.6 seconds, and a queue at 16 about 2.5 seconds. A 4 MB chunk stored for 48 hours is 128 units; at an XFTP price of 1 it costs a phone about 20 seconds, while the upload of the same chunk takes seconds to minutes. The prices of the configuration examples assume compiled solving, and fall with this table.
+
+The client maximum is one effort value: the largest that an iPhone 8 solves in 45-60 seconds and a current iPhone in 30 seconds. A benchmark on both devices sets it; by the table above it is about 200. A client reports a request priced above it as busy, so it bounds the prices an operator can set: the price of a queue, and the units of an XFTP chunk multiplied by the price per unit.
+
+Verification at 100 microseconds allows about 10000 proofs per second per core, which exceeds the rate at which queues are created and written to the store.
+
+## Attacker cost
+
+An attacker solves on desktops with the compiler, at 150 candidate solutions per second per core:
+
+```
+price    1 core      64 cores    1000 machines
+    4    37/s        2400/s      37000/s
+   16    9/s         600/s       9000/s
+  256    0.6/s       38/s        600/s
+```
+
+A desktop core of the attacker solves 20-30 times faster than a phone core of a user: three times from the hardware, and the rest from the compiler. The gap sets how high a price can rise before users feel it.
+
+The idle price is a speed bump. The defence is the increase in the tier the flood uses, and the statistics show which tier that is.
+
+An attacker without a badge floods the default tier. Its price rises, and badge holders keep their prices.
+
+An attacker who bought a badge presents it on every machine: at a price of 2, one badge on 1000 machines creates 75000 queues per second until the price of that tier is raised. The raise is paid by the holders of that badge while the flood lasts, and by no one else.
+
+The price of a badge tier rises at most to the default price. A flood in a badge tier that the default price does not hold back needs the default raised too, so users without a badge pay that raise as well; the other badge tiers keep their prices.
+
+## Client implementation
+
+The agent solves on demand, in one solver ordered by `NetworkRequestMode`: `NRMInteractive` work first, then `NRMBackground`. A solver call takes about 100 milliseconds on a phone, so background work yields between calls when interactive work arrives.
+
+Creation outside the actions of the user - connections to the members of a group - is background work, and background solving has a budget of CPU time per hour. Past it, background creations wait, and the asynchronous commands that carry them retry them later. A group of many members cannot turn the device into a miner.
+
+The solver keeps no stock. A proof is discarded when its epoch passes or its session ends.
+
+## Deployment
+
+Proof of work comes in the same version as the entitlement proof in the handshake: SMP version 23 and NTF version 4. XFTP carries the entitlement proof from version 4, which is released, so proof of work comes in XFTP version 5. Servers start with every price at zero, which asks for nothing, and operators raise them. The existing controls - `allowNewQueues`, `allowNewFiles`, the basic auth of the server - stay as they are.
+
+## Limits
+
+- Proof of work prices bulk creation; it stops no one who is willing to pay. Tor states the same conclusion: the defence covers a single machine and a small botnet, and a large botnet needs another mechanism.
+- Prices change by hand, so a flood runs at the old price until an operator raises it. The expiry bounds the stock prepared before the flood; the flood that follows is priced at the new value from the next response.
+- Phones solve with the interpreter and attackers with the compiler, which gives an attacker 20-30 times a phone per core. Equi-X narrows the gap between a CPU and a GPU, which published measurements leave open; a hash-based puzzle would give one GPU a factor of about a thousand over a phone.
+- Proofs are bound to a session, so a reconnection discards the unspent ones.
+- The cost falls on the device of the user: battery and heat, most visible when a group of many members is created at once.
+- Proof of work replaces no rate limit, and the servers limit neither creations nor commands per session today. A cap on creations per session is out of scope.
+
+## Open questions
+
+1. HashX against a fixed hash. Our clients interpret and an attacker compiles, which the estimates put at about 8 times on one core. A fixed hash - Equihash(60,3) over SipHash - removes that factor, and gives a GPU the same program for every challenge, so it runs thousands of instances in step, as the Equihash miners do; that factor is unmeasured. The measurements that decide it: interpreted solving on a mid-range Android phone and an iPhone, compiled against interpreted on one desktop core, and an estimate of a GPU solver for the fixed hash.
+2. The budget of background solving, in CPU seconds per hour.
+3. Sessions below SMP version 19: whether the budget of earlier versions applies to them, where a refusal ends their asynchronous creations, or they stay outside it and the version range is the lever against them.
+
+## Follow-up
+
+Certificates for services signed by an operator, with the requests of partners, as described under Services.

scripts/resolver/README.md

@@ -62,15 +62,26 @@ curl -s -X POST http://127.0.0.1:8545 \
 **2. resolver is healthy:**
 ```sh
 curl -s http://127.0.0.1:8000/health | jq
-# → {"ok": true, "rpc": "http://reth:8545", "registries": {"testing": "0x…", "simplex": ""}}
+# → {"ok": true, "rpc": "http://reth:8545", "registries": {"testing": "0x…", "simplex": ""},
+#    "blockNumber": 23400000, "chainLagSeconds": 12}
 ```
 
+`chainLagSeconds` is how far the node is behind the wall clock. A resolver that
+is reachable and answering can still be hours behind, and every name it reports
+is that stale. `null` means the node could not be reached.
+
 **3. resolver resolves a live name** (`foobar.testing` is a populated test name):
 ```sh
 curl -s http://127.0.0.1:8000/resolve/foobar.testing | jq
 # → {"name":"foobar.testing","nickname":"Foo","simplexContact":["https://smp16.simplex.im/a#…"], … }
 ```
 
+**4. the route your router will call** (check 3 passes on an older resolver too):
+```sh
+curl -s http://127.0.0.1:8000/v2/resolve/foobar.testing | jq
+# → {"type":"registered","expires":1780000000,"graceUntil":…,"nameRecord":{…}}
+```
+
 **Wire your smp-server:** in its `[NAMES]` section set
 `resolver_endpoint: http://127.0.0.1:8000` (no auth needed for loopback).
 
@@ -82,7 +93,7 @@ curl -s http://127.0.0.1:8000/resolve/foobar.testing | jq
 | reth p2p | `:30303` tcp/udp | Ethereum sync (open on firewall) |
 | nimbus p2p | `:9000` tcp/udp | beacon sync (open on firewall) |
 | nimbus REST | `127.0.0.1:5052` | beacon API |
-| **resolver** | `127.0.0.1:8000` | SNRC REST (`/resolve`, `/health`) |
+| **resolver** | `127.0.0.1:8000` | SNRC REST (`/v2/resolve`, `/resolve`, `/health`) |
 
 ## Caveats
 
@@ -110,7 +121,57 @@ standalone for local dev (no Docker), via [`uv`](https://docs.astral.sh/uv/):
 uv run scripts/resolver/service/snrc-resolve.py  # defaults to local reth + mainnet .testing
 ```
 
-### Response shape
+Three routes, versioned separately from the protocol so each only changes when
+its own shape does:
+
+| Route | Called by | Answers |
+|---|---|---|
+| `/v2/resolve/<query>` | routers from SMP v22 | a `NameRegistration` |
+| `/resolve/<name>` | routers before SMP v22 | a name record, flat |
+| `/health` | anyone | readiness |
+
+`/v1/resolve/<name>` is an alias for `/resolve/<name>`.
+
+### v2: `/v2/resolve/<query>`
+
+The body is the SMP protocol's `NameResponse`, which the router decodes as is
+and forwards; translating the registry's model to it is this resolver's job. It
+is the registration below, plus `lastBlockTs`, the timestamp of the block it was read
+at: a node that lags answers with names it has not seen registered yet.
+Its `type` is `registered`, `available` or `reserved`, and the fields each one
+carries are specified once, in the **Name response** section of
+[`protocol/simplex-messaging.md`](../../protocol/simplex-messaging.md). It is
+the wire format, so it is documented with the wire.
+
+Two things follow from that and are worth stating here. Expiry and grace belong
+to the registration, not to the record: `expires` and `graceUntil` sit beside
+`nameRecord`, not inside it. And a name nobody holds is not an error: it
+answers 200 with `type: available` and its price, so no status code from this
+route means "not registered".
+
+| Status | Meaning |
+|---|---|
+| 200 | a registration: `registered`, `available` or `reserved` |
+| 400 | `tldNotConfigured`, `notFullyQualified` |
+| 502 | `noPriceOracle`, `labelNotRecorded`, an unreadable status, or `upstreamError` |
+
+Error bodies carry `name` and a fixed `error` code to branch on. Only
+`upstreamError` adds a `message`; the v1 route always adds one.
+
+`labelNotRecorded` means the registrar holds the name but never recorded its
+label, so a hashed query cannot be answered with a name. See
+[Querying by labelhash](#querying-by-labelhash).
+
+A subname reports the expiry and grace of the 2LD above it, since that is what
+bounds its lifetime. A subname nobody created reports as not registered.
+
+### v1: `/resolve/<name>`
+
+What routers before SMP v22 call. Its shape is unrelated to v2's: the record is
+flat, and `status`, `expires`, `graceEnds`, `reasonCode` and `reason` sit
+alongside its fields.
+
+#### v1 response shape
 
 ```jsonc
 {
@@ -119,28 +180,197 @@ uv run scripts/resolver/service/snrc-resolve.py  # defaults to local reth + main
   "simplexContact": ["https://smp16.simplex.im/a#…", "https://smp11…"],  // primary first, fallbacks after
   "simplexChannel": [],
   "eth": null, "btc": "bc1q…", "xmr": "4ANz…", "dot": "139G…",
-  "owner": "0xd83b…", "resolver": "0x80fa…"
+  "owner": "0xd83b…", "resolver": "0x80fa…",
+  "status": "registered",      // registered | grace | expired | unregistered | unknown
+  "expires": 1780000000,       // Unix seconds; when the registration ends
+  "graceEnds": 1787776000,     // expires + GRACE_PERIOD; last moment the owner can renew
+  "reasonCode": null,          // set when the name is held back as well
+  "reason": null               // set when the name is held back as well
 }
 ```
 
 `simplexContact`/`simplexChannel` are arrays (a name can advertise multiple SMP
-servers; clients try them in order). On-chain they're a single comma-separated
+servers; clients try them in order). On-chain they're a single `;`-separated
 text record; the resolver splits/trims/drops-empties. Address encodings are
 canonical per chain (EIP-55 / bech32 / SS58 / Monero-base58). Subnames work
 identically (`bar.foobar.testing`).
 
-### Status codes
+#### v1 registration status and expiry
+
+A response carries `status`, `expires` and `graceEnds` whenever the resolver
+read them, a successful resolve included, so a client that has just resolved a
+name already knows when it expires. Both timestamps are Unix seconds, and
+`null` when they could not be read.
+
+| `status` | Meaning |
+|---|---|
+| `registered` | live; `expires` is when that ends |
+| `grace` | lapsed, but only the previous owner may renew it, until `graceEnds` |
+| `expired` | lapsed and past grace; anyone may register it |
+| `unregistered` | never registered, and free to take |
+| `unknown` | no `SNRC_REGISTRAR_<TLD>` configured, so status could not be read |
+
+A reservation is orthogonal to the status: a name held back by the registry
+carries `reasonCode` and `reason` whether or not it is registered.
+
+`grace` and `expired` are told apart by the registrar's own `available(id)`
+rule, `expires + GRACE_PERIOD < now`. `GRACE_PERIOD` is read from the contract
+rather than assumed, and `now` is the latest block's timestamp rather than the
+host clock, which the registrar compares against too, so a machine with a wrong
+clock cannot misreport a registration. That rule alone is not enough: it also
+holds for a name nobody ever registered (`0 + GRACE_PERIOD < now`), so a zero
+expiry is what separates *never registered* from *registered and since
+released*.
+
+A subname reports the status of the 2LD above it, which is only as good as the
+name it sits under. A subname nobody created answers 404 `unregistered`.
+
+#### v1 errors
+
+Every non-2xx body carries two fields: `error` is a fixed code to branch on,
+and `message` is a sentence for a human. Match on `error`, never on `message`,
+which is free to change.
+
+```jsonc
+{"name": "nope.testing", "error": "unregistered",
+ "message": "this name has never been registered",
+ "status": "unregistered", "expires": null, "graceEnds": null}
+```
+
+The codes are `tldNotConfigured`, `notFullyQualified`, `unregistered`,
+`expired`, `noSuchRoute` and `upstreamError`. When the registration is what went
+wrong, `error` and `status` hold the same value, so one field is enough to read.
+
+`upstreamError` says only which exception type the RPC call raised. The text
+goes to the resolver's log instead, because `SNRC_RPC` can carry a provider key
+and urlopen puts the URL it failed on into the message. It is also the answer
+when a registrar, controller or oracle address has no contract behind it: the
+empty reply is refused rather than read as zero, which would make every name
+look free.
+
+#### v1 status codes
 
 | Status | Meaning |
 |---|---|
-| 200 | resolved |
+| 200 | resolved (`status` is `registered` or `grace`, or `unknown` when no registrar is configured) |
 | 400 | TLD not configured, or not a fully-qualified name |
-| 404 | name has no resolver set on the registry |
+| 404 | `unregistered` |
+| 410 | `expired`: lapsed and past grace, so anyone may take it |
 | 502 | upstream RPC error / reth not synced |
 
-### Configuring registries
+### Querying by labelhash
 
-Defaults to mainnet `.testing` (`0x03f438…`); `.simplex` is unset until
-deployed. Override per TLD via env on the `resolver` service in
-`docker-compose.yml` (`SNRC_REGISTRY_TESTING` / `SNRC_REGISTRY_SIMPLEX`), or as
-env vars for the standalone script.
+A client asking whether a name is free is usually about to register it, and
+whoever runs the resolver could register it first. To avoid that, send the
+keccak hash of the label in ENS's `[<64 hex>]` form instead of the label:
+
+```sh
+# instead of /resolve/acme.testing
+curl -s "http://127.0.0.1:8000/resolve/[$(printf acme | keccak-256sum | cut -d' ' -f1)].testing"
+```
+
+namehash is `keccak(parent || keccak(label))`, so this reaches the same node and
+returns the same record. The registrar keys `nameExpires` and `reservedNames` on
+the labelhash too, so the status fields do not need the label either. The
+resolver learns the name only by guessing the label and hashing it.
+
+Only the second-level label is a registry key, and `status` decodes a bracket
+there at any depth. The record does not: a bracket is decoded only in a
+two-label name, so `sub.[<hash>].testing` is not a supported query. Subname
+labels stay text; a bracket label left of the 2LD is an ordinary label. Routers
+from v22 send every 2LD this way, so a registrable name normally never reaches
+this service.
+
+On v2, read `type`: only `available` means the name is free. On v1, read
+`status`: a name is free on `unregistered` (404) and on `expired` (410), every
+other status means somebody holds it, and a `reasonCode` means the registry will
+refuse it whatever the status says.
+
+The hash must be keccak-256. `openssl dgst -sha3-256` and `sha3sum` compute
+SHA3-256, a different function that returns 64 valid-looking hex characters
+pointing at the wrong node.
+
+The resolver lowercases the query before matching, so uppercase hex works too.
+Clients that refuse raw brackets in a path can percent-encode them as `%5B` and
+`%5D`.
+
+Brackets cannot collide with a real name: they are invalid in a normalised ENS
+name, and a `[<64 hex>]` label is 66 bytes against the registrar's
+`maxLabelLength` of 63. A plain `0x…` label is not treated as a hash, since that
+is an ordinary, registrable name.
+
+Only 2LDs can be queried this way, as only a 2LD can be raced for: subnames are
+created by the 2LD's owner. A bracket label in a subname is hashed as written,
+so it points at a node nobody can own. ENS tooling accepts the bracketed form at
+any depth; this resolver does not, on purpose.
+
+This hides interest in a name and nothing else: the registration itself is
+public, and commit-reveal covers that step. A short or well-known label is easy
+to guess by hashing candidates, and the reveal publishes the labelhash, so an
+operator who logged the query can match it to the name afterwards.
+
+### What a name costs
+
+The controller's `prices()` names the price oracle, so no extra configuration is
+needed beyond `SNRC_CONTROLLER_<TLD>`. A `SimplexPriceOracle` exposes its curve
+through `prices()`, in US cents per year, which is the unit this API carries.
+
+An ENS-shaped oracle exposes only `price1Letter()`..`price6Letter()`, in attoUSD
+per second, and charges a premium on a lapsed name that it does not expose. A
+quote from one is therefore only safe for a name that was never registered: an
+`expired` name gets no price rather than one below what the registrar charges.
+
+**Set `SNRC_CONTROLLER_<TLD>` wherever `SNRC_REGISTRAR_<TLD>` is.** Without a
+controller there is no oracle, so no name can be priced.
+
+**Upgrade this service before the routers that query it.** Routers from SMP v22
+call `/v2/resolve`, which an older resolver does not serve. Every name then
+answers `ERR NAME RESOLVER "HTTP 404"` until this service is upgraded, while
+`/health` still reports it as ready.
+
+### Why a name is reserved
+
+v2 carries the controller's reason as `reservedReason`. v1 carries the same word
+as `reasonCode`, plus `reason`, an English sentence for a human reading this API.
+Clients should branch on the word and phrase it themselves, in the user's
+language.
+
+| `reasonCode` | Meaning |
+|---|---|
+| `internal` | reserved for SimpleX |
+| `trademark` | reserved to protect a trademark |
+| `community` | reserved for the community |
+| `unknown` | a reason added to the contract after this resolver; still reserved |
+
+These are `SimplexController.Reason`, where 0 means not reserved. A controller
+from before the enum stores a boolean, whose `true` decodes as 1, which is why
+1 reads as `internal`, so nothing needs migrating.
+
+### Configuring addresses
+
+The resolver reads three contracts, each configured per TLD.
+
+The **registry** answers who owns a node, and `/resolve` reads the records from
+it. The **registrar** (ERC-721) holds `nameExpires` and `GRACE_PERIOD`, which
+is where every expiry field comes from, and `labelOf`, which is how a hashed
+query is answered with a name. A name registered without recording its label
+cannot answer one, and `/v2/resolve` refuses it rather than answer with a name
+the client will reject. With no registrar for a TLD, `/resolve` still works and
+reports `"status": "unknown"`. The **controller** holds
+`reservedNames`, which is where `reasonCode` comes from. With no controller a
+held-back name reads as not reserved, and no name can be priced.
+
+All three default to the mainnet `.testing` deployment. `.simplex` is unset
+until it is deployed.
+
+The controller default is the **proxy**, not `SimplexControllerImpl`. Storage
+lives in the proxy, so the implementation address answers nothing. The two
+deployment files use different names for that proxy:
+`deployments.mainnet.testing.json` records it under the ENS role name
+`ETHRegistrarController`, and `verification.mainnet.testing.json` calls it
+`SimplexControllerProxy`. Both are the same address, and it is the one used
+here.
+
+To override any of them, set `SNRC_REGISTRY_<TLD>`, `SNRC_REGISTRAR_<TLD>` or
+`SNRC_CONTROLLER_<TLD>` on the `resolver` service in `docker-compose.yml`, or
+as env vars when you run the script directly.

scripts/resolver/docker-compose.yml

@@ -150,6 +150,12 @@ services:
       # only if you're deploying against a different network or contract.
       # SNRC_REGISTRY_TESTING: 0x...
       # SNRC_REGISTRY_SIMPLEX: 0x...
+      # Registrar and controller, same cascade. Without the registrar `status`
+      # is "unknown"; without the controller a reserved name is "unregistered".
+      # SNRC_REGISTRAR_TESTING: 0x...
+      # SNRC_REGISTRAR_SIMPLEX: 0x...
+      # SNRC_CONTROLLER_TESTING: 0x...
+      # SNRC_CONTROLLER_SIMPLEX: 0x...
     ports:
       - "127.0.0.1:8000:8000"
     restart: unless-stopped

scripts/resolver/service/snrc-resolve.py

@@ -29,6 +29,7 @@ Usage:
   ./snrc-resolve.py                    # serve on :8000
 
   curl -s http://127.0.0.1:8000/resolve/foobar.testing | jq .
+  curl -s 'http://127.0.0.1:8000/resolve/[<64-hex labelhash>].testing' | jq .
   curl -s http://127.0.0.1:8000/health
 
 Environment:
@@ -38,6 +39,11 @@ Environment:
                           0x58fc46996d975c57883564648bda5206d1a0102b)
   SNRC_REGISTRY_SIMPLEX  ENSRegistry for the .simplex deployment
                          (default: empty — TLD not yet deployed)
+  SNRC_REGISTRAR_<TLD>   BaseRegistrar (ERC-721) for the TLD; expiry and status
+                         (default: mainnet for .testing, empty for .simplex)
+  SNRC_CONTROLLER_<TLD>  SimplexController (proxy) for the TLD; reservations,
+                         and through its `prices()` oracle what registering costs
+                         (default: mainnet for .testing, empty for .simplex)
   SNRC_PORT              Listen port (default: 8000)
   SNRC_BIND              Bind address (default: 0.0.0.0)
 
@@ -61,6 +67,7 @@ import hashlib
 import json
 import os
 import sys
+import time
 from http.server import BaseHTTPRequestHandler, ThreadingHTTPServer
 from urllib.parse import unquote, urlparse
 from urllib.request import Request, urlopen
@@ -84,6 +91,31 @@ REGISTRIES = {
     "simplex": os.environ.get("SNRC_REGISTRY_SIMPLEX", ""),  # not deployed yet
 }
 
+REGISTRARS = {
+    "testing": os.environ.get("SNRC_REGISTRAR_TESTING", "")
+    or "0xef47eb4384b46c89e4482a677c2cbcbd2a6fd85a",  # mainnet .testing
+    "simplex": os.environ.get("SNRC_REGISTRAR_SIMPLEX", ""),  # not deployed yet
+}
+
+CONTROLLERS = {
+    "testing": os.environ.get("SNRC_CONTROLLER_TESTING", "")
+    # Proxy address, not SimplexControllerImpl: storage is held by the proxy.
+    # Recorded in deployments.json as ETHRegistrarController.
+    or "0xeeb9b6bf5fb68fb726005f7ba549c2f4b32f2dad",  # mainnet .testing
+    "simplex": os.environ.get("SNRC_CONTROLLER_SIMPLEX", ""),  # not deployed yet
+}
+
+# `reservedNames` holds a SimplexController.Reason; 0 means not reserved. A
+# controller from before the enum stores a bool, whose `true` decodes as 1,
+# which is why 1 reads as "internal".
+RESERVED_REASONS = {
+    1: ("internal", "reserved for SimpleX"),
+    2: ("trademark", "reserved to protect a trademark"),
+    3: ("community", "reserved for the community"),
+}
+# a Reason added to the contract after this resolver: still reserved, unworded
+UNKNOWN_REASON = ("unknown", "reserved")
+
 # SLIP-44 coin types (https://github.com/satoshilabs/slips/blob/master/slip-0044.md)
 COIN_ETH = 60
 COIN_BTC = 0
@@ -92,6 +124,8 @@ COIN_DOT = 354
 
 ZERO_ADDR = "0x0000000000000000000000000000000000000000"
 
+# The registry prices in attoUSD (1e-18 USD); the protocol carries US cents.
+
 
 # ---------- RPC + ABI helpers (mirrors ens-lookup.py shape) ----------
 
@@ -123,12 +157,216 @@ def namehash(name: str) -> bytes:
     return node
 
 
+# ENS's encoding for a label whose preimage is unknown. Brackets are outside
+# the normalised character set, so it cannot collide with a registrable name.
+ENCODED_LABELHASH_LEN = 66  # "[" + 64 hex + "]"
+
+
+def is_encoded_labelhash(label: str) -> bool:
+    return (
+        len(label) == ENCODED_LABELHASH_LEN
+        and label.startswith("[")
+        and label.endswith("]")
+        and all(c in "0123456789abcdef" for c in label[1:-1])
+    )
+
+
+def node_of(name: str) -> bytes:
+    """namehash, decoding a second-level labelhash so `[hash].tld` reaches the
+    node its name does. Only a second-level name is ever hashed; a bracket
+    anywhere else is hashed as written."""
+    labels = name.split(".")
+    if len(labels) != 2 or not is_encoded_labelhash(labels[0]):
+        return namehash(name)
+    return keccak(namehash(labels[1]) + bytes.fromhex(labels[0][1:-1]))
+
+
+# ---------- Registration status ----------
+
+
+def head_block():
+    """How far behind the node is. Unlike expiry, this is the one thing that has
+    to be measured against the host clock: a node that stops still has a block."""
+    try:
+        block = rpc("eth_getBlockByNumber", ["latest", False])
+        return {
+            "blockNumber": decode_uint(block["number"]),
+            "chainLagSeconds": int(time.time()) - decode_uint(block["timestamp"]),
+        }
+    except Exception:
+        return {"blockNumber": None, "chainLagSeconds": None}
+
+
+def chain_now() -> int:
+    """Expiry is compared against the block timestamp, never the host clock."""
+    block = rpc("eth_getBlockByNumber", ["latest", False])
+    return decode_uint(block["timestamp"])
+
+
+def grace_period(registrar: str) -> int:
+    """A deployment can configure a different window, so it is read on chain."""
+    return decode_uint(eth_call(registrar, selector("GRACE_PERIOD()")))
+
+
+def expiry_status(expires: int, grace: int, now: int) -> str:
+    """The registrar's `available(id)` is not enough on its own: it is also
+    true for a name nobody registered, since 0 + GRACE_PERIOD < now."""
+    if expires == 0:
+        return "unregistered"
+    if expires > now:
+        return "registered"
+    if expires + grace >= now:
+        return "grace"
+    return "expired"
+
+
+def reservation_reason(tld: str, token: int) -> int:
+    """The SimplexController.Reason held for the name, 0 when not reserved."""
+    controller = CONTROLLERS.get(tld)
+    if not controller:
+        return 0
+    raw = eth_call(controller, selector("reservedNames(bytes32)") + encode_uint(token))
+    return decode_uint(raw)
+
+
+def pricing_params(tld: str):
+    """What it costs to register a name under this TLD, in US cents, or None
+    when no controller or price oracle is configured."""
+    controller = CONTROLLERS.get(tld)
+    if not controller:
+        return None
+    oracle = decode_address(eth_call(controller, selector("prices()")))
+    if oracle == ZERO_ADDR:
+        return None
+    try:
+        return read_oracle_prices(controller, oracle)
+    except RuntimeError:
+        # An oracle that does not expose its curve cannot be quoted from. The
+        # name is still registrable; the price is simply not ours to state.
+        return None
+
+
+SECONDS_PER_YEAR = 31536000
+ATTO_PER_CENT = 10**16
+
+
+def read_oracle_prices(controller: str, oracle: str):
+    """SimplexPriceOracle keeps the curve in US cents per year, the unit the SMP
+    protocol carries. An ENS-shaped oracle prices in attoUSD per second and
+    charges a premium on lapsed names that it does not expose, so a quote from
+    it is only safe for a name that was never registered."""
+    try:
+        base, tiers = decode_prices(eth_call(oracle, selector("prices()")))
+        premium_unknown = False
+    except RuntimeError:
+        base, tiers = decode_letter_prices(oracle)
+        premium_unknown = True
+    min_len = decode_uint(eth_call(controller, selector("minCharLength()")))
+    return {
+        # lengths the registry refuses are left out rather than priced at zero
+        "registrationPrices": {n: c for n, c in tiers.items() if n >= min_len},
+        "basePrice": base,
+        "minLabelLength": min_len,
+        "_premiumUnknown": premium_unknown,
+    }
+
+
+def decode_letter_prices(oracle: str):
+    """`price1Letter()`..`price6Letter()`, in attoUSD per second. Quotes round
+    up, so one is never below what the registry charges. An oracle built before
+    the six-letter tier stops at five, and charges its highest tier for anything
+    longer, which is what basePrice means here."""
+    tiers = {}
+    for n in range(1, 7):
+        try:
+            rate = decode_uint(eth_call(oracle, selector(f"price{n}Letter()")))
+        except RuntimeError:
+            if n <= 5:
+                raise
+            break
+        tiers[n] = ceil_div(rate * SECONDS_PER_YEAR, ATTO_PER_CENT)
+    return tiers.pop(max(tiers)), tiers
+
+
+def ceil_div(a: int, b: int) -> int:
+    return -(-a // b)
+
+
+def decode_prices(hex_data: str):
+    """`prices()` returns the base price and the lengths priced differently."""
+    raw = bytes.fromhex(hex_data[2:] if hex_data.startswith("0x") else hex_data)
+    # a short answer is not a curve: decoding it would quote every name as free
+    if len(raw) < 96:
+        raise RuntimeError("prices(): short response")
+    base = int.from_bytes(raw[:32], "big")
+    at = int.from_bytes(raw[32:64], "big")
+    count = int.from_bytes(raw[at:at + 32], "big")
+    tiers = {}
+    for i in range(count):
+        item = at + 32 + i * 64
+        length = int.from_bytes(raw[item:item + 32], "big")
+        tiers[length] = int.from_bytes(raw[item + 32:item + 64], "big")
+    return base, tiers
+
+
+def name_status(name: str):
+    labels = name.split(".")
+    tld = labels[-1]
+    registrar = REGISTRARS.get(tld)
+    if not registrar or len(labels) < 2:
+        return {
+            "status": "unknown",
+            # nothing was read, so there is no block to report
+            "lastBlockTs": None,
+            "expires": None,
+            "graceEnds": None,
+            "reasonCode": None,
+            "reason": None,
+        }
+
+    # nameExpires and reservedNames are keyed on uint256(keccak(label)).
+    # The 2LD's label is that key at any depth. node_of decodes a bracket only
+    # in a two-label name, so a bracket subname gets a status but no record.
+    token = label_token(labels[-2])
+    expires = decode_uint(
+        eth_call(registrar, selector("nameExpires(uint256)") + encode_uint(token))
+    )
+    grace = grace_period(registrar) if expires else 0
+    now = chain_now()
+    status = expiry_status(expires, grace, now)
+
+    # A reservation is orthogonal to the registration: a registered name can be
+    # held back too.
+    code = reservation_reason(tld, token)
+    reason = RESERVED_REASONS.get(code, UNKNOWN_REASON) if code else None
+
+    out = {
+        "status": status,
+        # the block this was read at
+        "lastBlockTs": now,
+        "expires": expires or None,
+        "graceEnds": (expires + grace) if expires else None,
+        "reasonCode": reason[0] if reason else None,
+        "reason": reason[1] if reason else None,
+    }
+    if status in ("unregistered", "expired"):
+        pricing = pricing_params(tld)
+        # a lapsed name may carry a premium this resolver cannot read, and a
+        # quote without it would be below what the registry charges
+        if pricing and not (status == "expired" and pricing["_premiumUnknown"]):
+            out.update({k: v for k, v in pricing.items() if not k.startswith("_")})
+    return out
+
+
 def selector(signature: str) -> str:
     return "0x" + keccak(signature.encode())[:4].hex()
 
 
 def eth_call(to: str, data: str) -> str:
-    return rpc("eth_call", [{"to": to, "data": data}, "latest"])
+    result = rpc("eth_call", [{"to": to, "data": data}, "latest"])
+    if result == "0x":
+        raise RuntimeError(f"empty return from {to}: no contract at that address?")
+    return result
 
 
 def decode_address(hex_data: str) -> str:
@@ -143,6 +381,42 @@ def decode_bytes(hex_data: str) -> bytes:
     return raw[64:64 + length]
 
 
+def registered_label(registrar: str, token: int):
+    """The plaintext label the registrar recorded at registration, keyed by the
+    hash of that label. None when the name was registered without
+    registerWithLabel, so the registrar cannot name it."""
+    raw = decode_bytes(eth_call(registrar, selector("labelOf(uint256)") + encode_uint(token)))
+    return raw.decode("utf-8", errors="replace") if raw else None
+
+
+def canonical_name(name: str):
+    """The name to answer with: a hashed query does not carry one, so the
+    registrar's record of the label fills it in. None when it recorded none."""
+    labels = name.split(".")
+    registrar = REGISTRARS.get(labels[-1])
+    if not registrar or len(labels) != 2 or not is_encoded_labelhash(labels[0]):
+        return name
+    label = registered_label(registrar, label_token(labels[0]))
+    return label + "." + labels[1] if label else None
+
+
+def label_token(label: str) -> int:
+    """The registry key for a second-level label, whether it arrived as text or
+    already hashed."""
+    if is_encoded_labelhash(label):
+        return int(label[1:-1], 16)
+    return int.from_bytes(keccak(label.encode()), "big")
+
+
+def decode_uint(hex_data: str) -> int:
+    raw = hex_data[2:] if hex_data.startswith("0x") else hex_data
+    return int(raw[-64:], 16) if raw else 0
+
+
+def encode_uint(value: int) -> str:
+    return value.to_bytes(32, "big").hex()
+
+
 def encode_text_call(node: bytes, key: str) -> str:
     sel = selector("text(bytes32,string)")
     head = node.hex() + (0x40).to_bytes(32, "big").hex()
@@ -390,6 +664,117 @@ def split_links(value: str) -> list:
     return [item.strip() for item in value.split(LINK_SEPARATOR) if item.strip()]
 
 
+def upstream_error(subject: dict, e: Exception) -> dict:
+    """urlopen puts the failing URL into its message and SNRC_RPC can carry a
+    provider key, so the text goes to the log and only the type to the caller."""
+    print(f"upstream error: {type(e).__name__}: {e}", file=sys.stderr)
+    return {
+        **subject,
+        "error": "upstreamError",
+        "message": f"upstream RPC failed ({type(e).__name__})",
+    }
+
+
+def name_record(name: str):
+    """The NameRecord for a registered name. A name with no resolver set still
+    has one, with every field unset."""
+    registry = REGISTRIES[name.rsplit(".", 1)[-1]]
+    node = node_of(name)
+    node_hex = node.hex()
+    resolver_addr = decode_address(eth_call(registry, selector("resolver(bytes32)") + node_hex))
+    owner = decode_address(eth_call(registry, selector("owner(bytes32)") + node_hex))
+    rec = {
+        "name": canonical_name(name),
+        "nickname": "",
+        "website": "",
+        "location": "",
+        "simplexContact": [],
+        "simplexChannel": [],
+        "eth": None,
+        "btc": None,
+        "xmr": None,
+        "dot": None,
+        "owner": owner,
+        "resolver": resolver_addr,
+    }
+    if resolver_addr == ZERO_ADDR:
+        return rec
+    texts = {}
+    for k in TEXT_KEYS:
+        try:
+            v = text(resolver_addr, node, k)
+        except RuntimeError:
+            v = ""
+        if v:
+            texts[k] = v
+    rec.update(
+        {
+            "nickname": texts.get("nickname") or texts.get("name") or texts.get("description") or "",
+            "website": texts.get("url", ""),
+            "location": texts.get("location", ""),
+            "simplexContact": split_links(texts.get("simplex.contact", "")),
+            "simplexChannel": split_links(texts.get("simplex.channel", "")),
+            "eth": addr_multicoin(resolver_addr, node, COIN_ETH),
+            "btc": addr_multicoin(resolver_addr, node, COIN_BTC),
+            "xmr": addr_multicoin(resolver_addr, node, COIN_XMR),
+            "dot": addr_multicoin(resolver_addr, node, COIN_DOT),
+        }
+    )
+    return rec
+
+
+def name_response(reg, registration_body):
+    """The SMP protocol's NameResponse: the registration and the block read at."""
+    return 200, {"lastBlockTs": reg["lastBlockTs"], "registration": registration_body}
+
+
+def registration(name: str):
+    """The SMP protocol's NameRegistration, which the relay decodes as is.
+    Translating the contract's model to it is this resolver's job."""
+    tld = name.rsplit(".", 1)[-1]
+    if not REGISTRIES.get(tld):
+        return 400, {"name": name, "error": "tldNotConfigured"}
+    reg = name_status(name)
+    status = reg["status"]
+    if status in ("registered", "grace"):
+        rec = name_record(name)
+        # the client checks that the record names what it asked about, so a
+        # hashed query the registrar cannot name is refused rather than answered
+        if rec["name"] is None:
+            return 502, {"name": name, "error": "labelNotRecorded"}
+        # a subname inherits the 2LD's status, so only its node's owner says
+        # whether anyone created it
+        if len(name.split(".")) > 2 and rec["owner"] == ZERO_ADDR:
+            # name_status reads pricing only when the name was already
+            # unregistered, so read it here
+            status = "unregistered"
+            pricing = pricing_params(tld)
+            if pricing:
+                reg.update({k: v for k, v in pricing.items() if not k.startswith("_")})
+        else:
+            return name_response(reg, {
+                "type": "registered",
+                "expires": reg["expires"],
+                "graceUntil": reg["graceEnds"],
+                "reservedReason_": reg["reasonCode"],
+                "nameRecord": rec,
+            })
+    if reg["reasonCode"]:
+        return name_response(reg, {"type": "reserved", "reservedReason": reg["reasonCode"]})
+    if status in ("unregistered", "expired"):
+        if "basePrice" not in reg:
+            return 502, {"name": name, "error": "noPriceOracle"}
+        return name_response(reg, {
+            "type": "available",
+            "pricing": {
+                "registrationPrices": reg["registrationPrices"],
+                "basePrice": reg["basePrice"],
+                "minLabelLength": reg["minLabelLength"],
+            },
+        })
+    return 502, {"name": name, "error": status}
+
+
 def resolve(name: str):
     tld = name.rsplit(".", 1)[-1]
     registry = REGISTRIES.get(tld)
@@ -397,17 +782,60 @@ def resolve(name: str):
         configured = [k for k, v in REGISTRIES.items() if v]
         return 400, {
             "name": name,
-            "error": f"TLD '{tld}' is not configured on this resolver",
-            "configured_tlds": configured,
+            "error": "tldNotConfigured",
+            "message": f"TLD '{tld}' is not configured on this resolver",
+            "configuredTlds": configured,
         }
 
-    node = namehash(name)
+    node = node_of(name)
     node_hex = node.hex()
 
+    # Before the resolver lookup, so a lapsed name is not reported as noResolver.
+    reg = name_status(name)
+    if reg["status"] in ("unregistered", "expired"):
+        # A name in grace is not here: its record still resolves.
+        body = {
+            "name": name,
+            **reg,
+            "error": reg["status"],
+            "message": (
+                "this name has never been registered"
+                if reg["status"] == "unregistered"
+                else "this registration expired and is open to anyone"
+            ),
+        }
+        return (404 if reg["status"] == "unregistered" else 410), body
+
     resolver_raw = eth_call(registry, selector("resolver(bytes32)") + node_hex)
     resolver_addr = decode_address(resolver_raw)
     if resolver_addr == ZERO_ADDR:
-        return 404, {"name": name, "error": "no resolver set for this name"}
+        # A registered name always resolves: with no resolver set the record is
+        # still returned with every field unset, so "taken until <date>" stays
+        # answerable. For a subname, no owner means nobody created it.
+        owner = decode_address(eth_call(registry, selector("owner(bytes32)") + node_hex))
+        if len(name.split(".")) > 2 and owner == ZERO_ADDR:
+            return 404, {
+                "name": name,
+                **reg,
+                "status": "unregistered",
+                "error": "unregistered",
+                "message": "this subname has never been created",
+            }
+        return 200, {
+            "name": canonical_name(name) or name,
+            "nickname": "",
+            "website": "",
+            "location": "",
+            "simplexContact": [],
+            "simplexChannel": [],
+            "eth": None,
+            "btc": None,
+            "xmr": None,
+            "dot": None,
+            "owner": owner,
+            "resolver": ZERO_ADDR,
+            **reg,
+        }
 
     owner_raw = eth_call(registry, selector("owner(bytes32)") + node_hex)
     owner = decode_address(owner_raw)
@@ -431,7 +859,7 @@ def resolve(name: str):
     # use the ENSIP-5 dot convention (e.g. "simplex.contact") — only the
     # resolver's JSON surface camelCases them.
     return 200, {
-        "name": name,
+        "name": canonical_name(name) or name,
         "nickname": nickname,
         "website": texts.get("url", ""),
         "location": texts.get("location", ""),
@@ -443,6 +871,7 @@ def resolve(name: str):
         "dot": addr_multicoin(resolver_addr, node, COIN_DOT),
         "owner": owner,
         "resolver": resolver_addr,
+        **reg,
     }
 
 
@@ -454,33 +883,51 @@ class Handler(BaseHTTPRequestHandler):
         parts = [unquote(p) for p in path.split("/") if p]
 
         if parts == ["health"]:
-            self._respond(
-                200,
-                {"ok": True, "rpc": RPC, "registries": REGISTRIES},
-            )
+            self._respond(200, {"ok": True, "rpc": RPC, "registries": REGISTRIES, **head_block()})
             return
 
+        if len(parts) == 3 and parts[0] == "v2" and parts[1] == "resolve":
+            name = parts[2].strip().lower()
+            if not name or "." not in name:
+                self._respond(400, {"name": name, "error": "notFullyQualified"})
+                return
+            try:
+                status, body = registration(name)
+            except Exception as e:  # surface upstream errors as 502
+                status, body = 502, upstream_error({"name": name}, e)
+            self._respond(status, body)
+            return
+
+        # /v1/resolve is an alias: relays before SMP v22 call /resolve
+        if parts[:2] == ["v1", "resolve"] and len(parts) == 3:
+            parts = ["resolve", parts[2]]
+
         if len(parts) == 2 and parts[0] == "resolve":
             name = parts[1].strip().lower()
             if not name or "." not in name:
                 self._respond(
                     400,
                     {
-                        "error": "expected fully-qualified name, e.g. /resolve/alice.testing",
-                        "got": name,
+                        "name": name,
+                        "error": "notFullyQualified",
+                        "message": "expected a fully-qualified name, e.g. alice.testing",
                     },
                 )
                 return
             try:
                 status, body = resolve(name)
             except Exception as e:  # surface upstream errors as 502
-                status, body = 502, {"name": name, "error": f"{type(e).__name__}: {e}"}
+                status, body = 502, upstream_error({"name": name}, e)
             self._respond(status, body)
             return
 
         self._respond(
             404,
-            {"error": "not found", "routes": ["/health", "/resolve/<name>"]},
+            {
+                "error": "noSuchRoute",
+                "message": "not found",
+                "routes": ["/health", "/v2/resolve/<query>", "/v1/resolve/<name>", "/resolve/<name>"],
+            },
         )
 
     def _respond(self, status: int, body: dict):
@@ -505,7 +952,7 @@ def main():
     )
     for tld, addr in REGISTRIES.items():
         sys.stderr.write(f"    .{tld:<8s} = {addr or '(not configured)'}\n")
-    sys.stderr.write("  GET /resolve/<name>   GET /health\n")
+    sys.stderr.write("  GET /v2/resolve/<name>   GET /v1/resolve/<name>   GET /health\n")
     try:
         server.serve_forever()
     except KeyboardInterrupt:

scripts/resolver/service/test_snrc_resolve.py

@@ -4,8 +4,11 @@
 Run with `python3 -m unittest scripts/resolver/service/test_snrc_resolve.py`.
 """
 
+import contextlib
 import importlib.util
+import io
 import os
+import time
 import unittest
 
 # snrc-resolve.py has a hyphen, so import it via importlib instead of `import`.
@@ -17,6 +20,12 @@ snrc = importlib.util.module_from_spec(_SPEC)
 _SPEC.loader.exec_module(snrc)
 
 
+def registration(name):
+    """registration() answers a NameResponse; most tests assert what is in it."""
+    status, body = snrc.registration(name)
+    return status, (body["registration"] if status == 200 else body)
+
+
 class SplitLinksTests(unittest.TestCase):
     """`split_links` decodes the multi-URL convention for simplex.contact /
     simplex.channel text records. Reuses the same rule the dApp's
@@ -82,5 +91,949 @@ class SplitLinksTests(unittest.TestCase):
         )
 
 
+class EncodedLabelhashTests(unittest.TestCase):
+    # keccak-256("alice"), written out in full wherever a test needs it.
+    # 9c0257114eb9399a2985f8e75dad7600c5d89fe3824ffa99ec1c3eb8bf3b0501
+
+    REGISTRAR = "0xef47eb4384b46c89e4482a677c2cbcbd2a6fd85a"
+    GRACE = 90 * 86400
+
+    def setUp(self):
+        self._saved = (snrc.REGISTRARS, snrc.CONTROLLERS, snrc.eth_call, snrc.chain_now)
+        snrc.REGISTRARS = {"testing": self.REGISTRAR}
+        snrc.CONTROLLERS = {"testing": ""}
+        snrc.chain_now = lambda: int(time.time())
+
+    def tearDown(self):
+        snrc.REGISTRARS, snrc.CONTROLLERS, snrc.eth_call, snrc.chain_now = self._saved
+
+    def test_the_encoded_form_is_recognised(self):
+        self.assertTrue(
+            snrc.is_encoded_labelhash(
+                "[9c0257114eb9399a2985f8e75dad7600c5d89fe3824ffa99ec1c3eb8bf3b0501]"
+            )
+        )
+
+    def test_an_ordinary_label_is_not(self):
+        self.assertFalse(snrc.is_encoded_labelhash("alice"))
+        self.assertFalse(snrc.is_encoded_labelhash("[alice]"))
+        self.assertFalse(snrc.is_encoded_labelhash("9c0257114eb9399a2985f8e75dad7600c5d89fe3824ffa99ec1c3eb8bf3b0501"))
+
+    def test_non_hex_between_the_brackets_is_not(self):
+        self.assertFalse(snrc.is_encoded_labelhash("[" + "z" * 64 + "]"))
+        # uppercase is rejected because the handler lowercases the whole name
+        self.assertFalse(snrc.is_encoded_labelhash("[" + "A" * 64 + "]"))
+        self.assertFalse(snrc.is_encoded_labelhash("[0x9c0257114eb9399a2985f8e75dad7600c5d89fe3824ffa99ec1c3eb8bf3b0501]"))
+
+    def test_the_wrong_length_is_not(self):
+        self.assertFalse(snrc.is_encoded_labelhash("[" + "a" * 63 + "]"))
+        self.assertFalse(snrc.is_encoded_labelhash("[" + "a" * 65 + "]"))
+
+    def test_hash_and_label_reach_the_same_node(self):
+        self.assertEqual(
+            snrc.node_of("alice.testing"),
+            snrc.node_of(
+                "[9c0257114eb9399a2985f8e75dad7600c5d89fe3824ffa99ec1c3eb8bf3b0501]"
+                ".testing"
+            ),
+        )
+
+    def test_a_plain_name_is_unaffected(self):
+        self.assertEqual(snrc.node_of("alice.testing"), snrc.namehash("alice.testing"))
+
+    def test_a_bracket_subname_label_stays_literal(self):
+        """Only the 2LD is a key, so a bracket label left of it is hashed as
+        written."""
+        self.assertNotEqual(
+            snrc.node_of(
+                "[9c0257114eb9399a2985f8e75dad7600c5d89fe3824ffa99ec1c3eb8bf3b0501]"
+                ".alice.testing"
+            ),
+            snrc.namehash("alice.alice.testing"),
+        )
+
+    def test_a_0x_prefixed_label_is_taken_literally(self):
+        name = "0x9c0257114eb9399a2985f8e75dad7600c5d89fe3824ffa99ec1c3eb8bf3b0501.testing"
+        self.assertEqual(snrc.node_of(name), snrc.namehash(name))
+        self.assertNotEqual(snrc.node_of(name), snrc.node_of("alice.testing"))
+
+    def test_a_malformed_bracket_label_falls_back_to_a_literal_name(self):
+        name = "[nothex].testing"
+        self.assertEqual(snrc.node_of(name), snrc.namehash(name))
+
+    def test_status_by_hash_matches_status_by_name(self):
+        future = int(time.time()) + 86400
+        seen = []
+
+        def eth_call(to, data):
+            seen.append(data)
+            if data.startswith(snrc.selector("GRACE_PERIOD()")):
+                return "0x" + snrc.encode_uint(self.GRACE)
+            return "0x" + snrc.encode_uint(future)
+
+        snrc.eth_call = eth_call
+        by_name = snrc.name_status("alice.testing")
+        by_hash = snrc.name_status(
+            "[9c0257114eb9399a2985f8e75dad7600c5d89fe3824ffa99ec1c3eb8bf3b0501]"
+            ".testing"
+        )
+        self.assertEqual(by_name, by_hash)
+        self.assertEqual(by_name["status"], "registered")
+        # nothing in either request carried the label itself
+        self.assertTrue(all("alice".encode().hex() not in d for d in seen))
+
+
+class NameStatusTests(unittest.TestCase):
+    REGISTRAR = "0xef47eb4384b46c89e4482a677c2cbcbd2a6fd85a"
+
+    GRACE = 90 * 86400
+
+    def _expiry(self, value):
+        def eth_call(to, data):
+            if data.startswith(snrc.selector("GRACE_PERIOD()")):
+                return "0x" + snrc.encode_uint(self.GRACE)
+            self.assertTrue(data.startswith(snrc.selector("nameExpires(uint256)")))
+            return "0x" + snrc.encode_uint(value)
+
+        return eth_call
+
+    def _keys(self, status, expires, grace_ends, read_at=-1):
+        """Every branch answers with the same keys; only some carry values."""
+        return {
+            "status": status,
+            "lastBlockTs": self.now if read_at == -1 else read_at,
+            "expires": expires,
+            "graceEnds": grace_ends,
+            "reasonCode": None,
+            "reason": None,
+        }
+
+    def setUp(self):
+        self._saved = (
+            snrc.REGISTRARS,
+            snrc.CONTROLLERS,
+            snrc.eth_call,
+            snrc.chain_now,
+            snrc.rpc,
+        )
+        snrc.REGISTRARS = {"testing": self.REGISTRAR}
+        # Expiry alone; ReservedTests covers a configured controller.
+        snrc.CONTROLLERS = {"testing": ""}
+        self.now = int(time.time())
+        snrc.chain_now = lambda: self.now
+
+    def tearDown(self):
+        (
+            snrc.REGISTRARS,
+            snrc.CONTROLLERS,
+            snrc.eth_call,
+            snrc.chain_now,
+            snrc.rpc,
+        ) = self._saved
+
+    def test_now_is_the_latest_blocks_timestamp(self):
+        # setUp replaced chain_now with the fixture clock; test the real one
+        real_chain_now = self._saved[3]
+        snrc.rpc = lambda method, params: {"timestamp": "0x65f1a2c0", "number": "0x123"}
+        self.assertEqual(real_chain_now(), 0x65F1A2C0)
+
+    def test_status_reads_the_chain_clock_not_the_host_clock(self):
+        future = int(time.time()) + 3600
+        snrc.eth_call = self._expiry(future)
+        self.assertEqual(snrc.name_status("alice.testing")["status"], "registered")
+        snrc.chain_now = lambda: future + 3650 * 86400
+        self.assertEqual(snrc.name_status("alice.testing")["status"], "expired")
+
+    def test_a_registrar_that_is_not_a_contract_is_an_error_not_a_free_name(self):
+        """An address with no code answers eth_call with empty data. Read as
+        zero, that would make every name look free."""
+        snrc.eth_call = self._saved[2]  # the real one, so its guard runs
+        snrc.rpc = lambda method, params: "0x"
+        with self.assertRaises(RuntimeError):
+            snrc.name_status("alice.testing")
+
+    def test_zero_expiry_means_never_registered(self):
+        snrc.eth_call = self._expiry(0)
+        self.assertEqual(
+            snrc.name_status("alice.testing"),
+            self._keys("unregistered", None, None),
+        )
+
+    def test_recently_expired_is_in_grace_and_says_when_it_ends(self):
+        past = int(time.time()) - 3600
+        snrc.eth_call = self._expiry(past)
+        self.assertEqual(
+            snrc.name_status("alice.testing"),
+            self._keys("grace", past, past + self.GRACE),
+        )
+
+    def test_past_the_grace_window_it_is_expired_and_claimable(self):
+        past = int(time.time()) - self.GRACE - 3600
+        snrc.eth_call = self._expiry(past)
+        self.assertEqual(snrc.name_status("alice.testing")["status"], "expired")
+
+    def test_the_boundary_belongs_to_grace(self):
+        """The registrar frees a name only when expires + GRACE < now."""
+        now = int(time.time())
+        snrc.eth_call = self._expiry(now - self.GRACE)
+        self.assertEqual(snrc.name_status("alice.testing")["status"], "grace")
+
+    def test_future_expiry_is_registered(self):
+        future = int(time.time()) + 3600
+        snrc.eth_call = self._expiry(future)
+        self.assertEqual(
+            snrc.name_status("alice.testing"),
+            self._keys("registered", future, future + self.GRACE),
+        )
+
+    def test_never_registered_is_not_confused_with_claimable(self):
+        """`available(id)` is true for both, since 0 + GRACE < now."""
+        snrc.eth_call = self._expiry(0)
+        self.assertEqual(snrc.name_status("alice.testing")["status"], "unregistered")
+        self.assertNotEqual(snrc.name_status("alice.testing")["status"], "expired")
+
+    def test_a_subname_reports_the_status_of_its_2ld(self):
+        future = int(time.time()) + 3600
+        seen = []
+
+        def eth_call(to, data):
+            seen.append(data)
+            return "0x" + snrc.encode_uint(future)
+
+        snrc.eth_call = eth_call
+        self.assertEqual(snrc.name_status("x.alice.testing")["status"], "registered")
+        # the token asked about is keccak("alice"), not keccak("x")
+        self.assertTrue(seen[0].endswith(snrc.keccak(b"alice").hex()))
+
+    def test_a_hashed_2ld_is_queried_by_its_hash_at_any_depth(self):
+        """The token must come from the hash, not from hashing the brackets."""
+        seen = []
+
+        def eth_call(to, data):
+            seen.append(data)
+            return "0x" + snrc.encode_uint(0)
+
+        snrc.eth_call = eth_call
+        hashed = "[" + snrc.keccak(b"alice").hex() + "]"
+        snrc.name_status("x." + hashed + ".testing")
+        self.assertTrue(seen[0].endswith(snrc.keccak(b"alice").hex()))
+
+    def test_unconfigured_tld_is_unknown_rather_than_unregistered(self):
+        snrc.REGISTRARS = {"testing": ""}
+        snrc.eth_call = lambda *a: self.fail("must not reach the chain")
+        self.assertEqual(
+            snrc.name_status("alice.testing"),
+            self._keys("unknown", None, None, read_at=None),
+        )
+
+    def test_every_branch_returns_the_same_keys(self):
+        keys = {
+            "status",
+            "lastBlockTs",
+            "expires",
+            "graceEnds",
+            "reasonCode",
+            "reason",
+        }
+        snrc.eth_call = self._expiry(0)
+        self.assertEqual(set(snrc.name_status("alice.testing")), keys)
+        snrc.eth_call = self._expiry(int(time.time()) + 3600)
+        self.assertEqual(set(snrc.name_status("alice.testing")), keys)
+        snrc.REGISTRARS = {"testing": ""}
+        snrc.eth_call = lambda *a: self.fail("must not reach the chain")
+        self.assertEqual(set(snrc.name_status("alice.testing")), keys)
+
+
+class ReservedTests(unittest.TestCase):
+    REGISTRAR = "0xef47eb4384b46c89e4482a677c2cbcbd2a6fd85a"
+    CONTROLLER = "0x281ca41311c2aa808c917c4674639d7567b75714"
+
+    def setUp(self):
+        self._saved = (snrc.REGISTRARS, snrc.CONTROLLERS, snrc.eth_call, snrc.chain_now)
+        snrc.REGISTRARS = {"testing": self.REGISTRAR}
+        snrc.CONTROLLERS = {"testing": self.CONTROLLER}
+        snrc.chain_now = lambda: int(time.time())
+
+    def tearDown(self):
+        snrc.REGISTRARS, snrc.CONTROLLERS, snrc.eth_call, snrc.chain_now = self._saved
+
+    def _chain(self, expires, reserved):
+        def eth_call(to, data):
+            if data.startswith(snrc.selector("reservedNames(bytes32)")):
+                self.assertEqual(to, self.CONTROLLER)
+                return "0x" + snrc.encode_uint(1 if reserved else 0)
+            if data.startswith(snrc.selector("GRACE_PERIOD()")):
+                return "0x" + snrc.encode_uint(90 * 86400)
+            if data.startswith(snrc.selector("prices()")):
+                return "0x" + snrc.encode_uint(0)  # no price oracle, no auction
+            return "0x" + snrc.encode_uint(expires)
+
+        return eth_call
+
+    def test_unregistered_and_reserved_reports_the_reservation(self):
+        snrc.eth_call = self._chain(0, True)
+        reg = snrc.name_status("acme.testing")
+        self.assertEqual(reg["status"], "unregistered")
+        self.assertEqual(reg["reasonCode"], "internal")
+
+    def test_unregistered_and_not_reserved_reads_unregistered(self):
+        snrc.eth_call = self._chain(0, False)
+        self.assertEqual(snrc.name_status("acme.testing")["status"], "unregistered")
+
+    def test_a_lapsed_reserved_name_keeps_its_reservation(self):
+        past = int(time.time()) - 91 * 86400
+        snrc.eth_call = self._chain(past, True)
+        reg = snrc.name_status("acme.testing")
+        self.assertEqual(reg["status"], "expired")
+        self.assertEqual(reg["reasonCode"], "internal")
+
+    def test_a_live_name_is_registered_even_if_reserved(self):
+        snrc.eth_call = self._chain(int(time.time()) + 86400, True)
+        self.assertEqual(snrc.name_status("acme.testing")["status"], "registered")
+
+    def test_a_name_in_grace_belongs_to_its_owner_not_the_reserved_set(self):
+        snrc.eth_call = self._chain(int(time.time()) - 3600, True)
+        self.assertEqual(snrc.name_status("acme.testing")["status"], "grace")
+
+    def test_no_controller_configured_means_reserved_is_never_reported(self):
+        snrc.CONTROLLERS = {"testing": ""}
+        snrc.eth_call = self._chain(0, True)  # reserved on chain, but unread
+        self.assertEqual(snrc.name_status("acme.testing")["status"], "unregistered")
+
+    def test_reserved_is_asked_by_labelhash_so_a_hashed_query_works(self):
+        # keccak-256("acme")
+        hashed = "[e29dae06ef4c3e336b7538b6d4f52ca1ecec009b1df6fb501320e11b223aeeaf]"
+        snrc.eth_call = self._chain(0, True)
+        self.assertEqual(snrc.name_status(hashed + ".testing")["reasonCode"], "internal")
+
+
+class ReservedReasonTests(unittest.TestCase):
+    REGISTRY = "0x58fc46996d975c57883564648bda5206d1a0102b"
+    REGISTRAR = "0xef47eb4384b46c89e4482a677c2cbcbd2a6fd85a"
+    CONTROLLER = "0x281ca41311c2aa808c917c4674639d7567b75714"
+
+    def setUp(self):
+        self._saved = (
+            snrc.REGISTRIES,
+            snrc.REGISTRARS,
+            snrc.CONTROLLERS,
+            snrc.eth_call,
+            snrc.chain_now,
+        )
+        snrc.REGISTRIES = {"testing": self.REGISTRY}
+        snrc.REGISTRARS = {"testing": self.REGISTRAR}
+        snrc.CONTROLLERS = {"testing": self.CONTROLLER}
+        snrc.chain_now = lambda: int(time.time())
+
+    def tearDown(self):
+        (
+            snrc.REGISTRIES,
+            snrc.REGISTRARS,
+            snrc.CONTROLLERS,
+            snrc.eth_call,
+            snrc.chain_now,
+        ) = self._saved
+
+    def _chain(self, expires, reserved):
+        def eth_call(to, data):
+            if data.startswith(snrc.selector("reservedNames(bytes32)")):
+                return "0x" + snrc.encode_uint(1 if reserved else 0)
+            if data.startswith(snrc.selector("GRACE_PERIOD()")):
+                return "0x" + snrc.encode_uint(90 * 86400)
+            if data.startswith(snrc.selector("prices()")):
+                return "0x" + snrc.encode_uint(0)  # no price oracle, no auction
+            return "0x" + snrc.encode_uint(expires)
+
+        return eth_call
+
+    def _reserved_as(self, code):
+        def eth_call(to, data):
+            if data.startswith(snrc.selector("reservedNames(bytes32)")):
+                return "0x" + snrc.encode_uint(code)
+            if data.startswith(snrc.selector("GRACE_PERIOD()")):
+                return "0x" + snrc.encode_uint(90 * 86400)
+            if data.startswith(snrc.selector("prices()")):
+                return "0x" + snrc.encode_uint(0)
+            return "0x" + snrc.encode_uint(0)
+
+        return eth_call
+
+    def test_every_enum_value_has_a_code_and_a_sentence(self):
+        for code, (name, sentence) in snrc.RESERVED_REASONS.items():
+            snrc.eth_call = self._reserved_as(code)
+            reg = snrc.name_status("acme.testing")
+            self.assertEqual(reg["reasonCode"], name)
+            self.assertEqual(reg["reason"], sentence)
+
+    def test_a_trademark_reservation_says_so(self):
+        snrc.eth_call = self._reserved_as(2)
+        _, body = snrc.resolve("acme.testing")
+        self.assertEqual(body["reasonCode"], "trademark")
+
+    def test_a_controller_storing_a_bool_reads_as_internal(self):
+        """Before the enum `reservedNames` was a bool; its `true` decodes as 1."""
+        snrc.eth_call = self._reserved_as(1)
+        reg = snrc.name_status("acme.testing")
+        self.assertEqual(reg["reasonCode"], "internal")
+        self.assertEqual(reg["reason"], "reserved for SimpleX")
+
+    def test_an_enum_value_this_resolver_predates_is_not_dropped(self):
+        """A new Reason still reserves the name, and says it is unknown rather
+        than claiming the chain recorded none."""
+        snrc.eth_call = self._reserved_as(99)
+        reg = snrc.name_status("acme.testing")
+        self.assertEqual(reg["reasonCode"], "unknown")
+        self.assertEqual(reg["reason"], "reserved")
+
+    def test_a_reserved_name_carries_the_reason(self):
+        snrc.eth_call = self._chain(0, True)
+        status, body = snrc.resolve("acme.testing")
+        self.assertEqual(status, 404)
+        self.assertEqual(body["status"], "unregistered")
+        self.assertEqual(body["reason"], "reserved for SimpleX")
+
+    def test_the_message_does_not_claim_a_trademark(self):
+        snrc.eth_call = self._chain(0, True)
+        _, body = snrc.resolve("acme.testing")
+        self.assertNotIn("trademark", body["message"])
+
+    def test_an_unregistered_name_has_no_reason(self):
+        snrc.eth_call = self._chain(0, False)
+        status, body = snrc.resolve("acme.testing")
+        self.assertEqual(status, 404)
+        self.assertEqual(body["status"], "unregistered")
+        self.assertIsNone(body["reason"])
+
+    def test_an_expired_name_has_no_reason(self):
+        snrc.eth_call = self._chain(1, False)
+        status, body = snrc.resolve("acme.testing")
+        self.assertEqual(status, 410)
+        self.assertEqual(body["status"], "expired")
+        self.assertIsNone(body["reason"])
+
+    def test_a_hashed_query_gets_the_reason_too(self):
+        snrc.eth_call = self._chain(0, True)
+        # keccak-256("acme")
+        hashed = "[e29dae06ef4c3e336b7538b6d4f52ca1ecec009b1df6fb501320e11b223aeeaf]"
+        _, body = snrc.resolve(hashed + ".testing")
+        self.assertEqual(body["reason"], "reserved for SimpleX")
+
+
+class PricingTests(unittest.TestCase):
+    """The oracle keeps the curve in US cents per year, and a lapsed name costs
+    the ordinary price: this registry runs no auction."""
+
+    REGISTRY = "0x58fc46996d975c57883564648bda5206d1a0102b"
+    REGISTRAR = "0xef47eb4384b46c89e4482a677c2cbcbd2a6fd85a"
+    CONTROLLER = "0x281ca41311c2aa808c917c4674639d7567b75714"
+    ORACLE = "0x1e0c9a2b9d1a4c8f7b3e5d6a9c2f4b8e1d7a3c50"
+
+    GRACE = 90 * 86400
+    BASE = 200
+    EXCEPTIONS = {1: 64000, 2: 16000, 3: 1600, 4: 800, 5: 500}
+    MIN_LENGTH = 3
+
+    def setUp(self):
+        self._saved = (
+            snrc.REGISTRIES,
+            snrc.REGISTRARS,
+            snrc.CONTROLLERS,
+            snrc.eth_call,
+            snrc.chain_now,
+        )
+        snrc.REGISTRIES = {"testing": self.REGISTRY}
+        snrc.REGISTRARS = {"testing": self.REGISTRAR}
+        snrc.CONTROLLERS = {"testing": self.CONTROLLER}
+        self.now = int(time.time())
+        snrc.chain_now = lambda: self.now
+
+    def tearDown(self):
+        (
+            snrc.REGISTRIES,
+            snrc.REGISTRARS,
+            snrc.CONTROLLERS,
+            snrc.eth_call,
+            snrc.chain_now,
+        ) = self._saved
+
+    def _prices_return(self):
+        words = [snrc.encode_uint(self.BASE), snrc.encode_uint(0x40),
+                 snrc.encode_uint(len(self.EXCEPTIONS))]
+        for length, cents in self.EXCEPTIONS.items():
+            words += [snrc.encode_uint(length), snrc.encode_uint(cents)]
+        return "0x" + "".join(words)
+
+    def _chain(self, expires, oracle=None, reserved=0):
+        oracle = self.ORACLE if oracle is None else oracle
+        self.oracle_calls = []
+
+        def eth_call(to, data):
+            if data.startswith(snrc.selector("nameExpires(uint256)")):
+                return "0x" + snrc.encode_uint(expires)
+            if data.startswith(snrc.selector("GRACE_PERIOD()")):
+                return "0x" + snrc.encode_uint(self.GRACE)
+            if data.startswith(snrc.selector("reservedNames(bytes32)")):
+                return "0x" + snrc.encode_uint(reserved)
+            if data.startswith(snrc.selector("minCharLength()")):
+                self.assertEqual(to, self.CONTROLLER)
+                return "0x" + snrc.encode_uint(self.MIN_LENGTH)
+            if data.startswith(snrc.selector("prices()")):
+                if to == self.CONTROLLER:
+                    return "0x" + snrc.encode_uint(int(oracle, 16))
+                self.oracle_calls.append(data[:10])
+                self.assertEqual(to, oracle)
+                return self._prices_return()
+            return self.fail("unexpected call " + data[:10])
+
+        return eth_call
+
+    def _lapsed(self, days_past_grace):
+        """An expiry whose grace ended `days_past_grace` days ago. The extra
+        second clears the boundary, which counts as still in grace."""
+        return self.now - self.GRACE - 1 - days_past_grace * 86400
+
+    def test_the_prices_are_the_oracles_cents_per_year(self):
+        snrc.eth_call = self._chain(self._lapsed(0))
+        reg = snrc.name_status("acme.testing")
+        # 1 and 2 are below minCharLength
+        self.assertEqual(reg["registrationPrices"], {3: 1600, 4: 800, 5: 500})
+        self.assertEqual(reg["basePrice"], self.BASE)
+        self.assertEqual(reg["minLabelLength"], self.MIN_LENGTH)
+
+    def test_a_lapsed_name_costs_the_ordinary_price(self):
+        snrc.eth_call = self._chain(self._lapsed(0))
+        reg = snrc.name_status("acme.testing")
+        self.assertEqual(reg["status"], "expired")
+
+    def test_a_controller_with_no_oracle_leaves_the_name_merely_expired(self):
+        snrc.eth_call = self._chain(self._lapsed(0), oracle=snrc.ZERO_ADDR)
+        self.assertEqual(snrc.name_status("acme.testing")["status"], "expired")
+
+    def test_a_name_in_grace_never_reaches_the_oracle(self):
+        snrc.eth_call = self._chain(self.now - 3600)
+        self.assertEqual(snrc.name_status("acme.testing")["status"], "grace")
+        self.assertEqual(self.oracle_calls, [])
+
+    def test_a_reserved_lapsed_name_keeps_its_reservation(self):
+        snrc.eth_call = self._chain(self._lapsed(0), reserved=2)
+        reg = snrc.name_status("acme.testing")
+        self.assertEqual(reg["status"], "expired")
+        self.assertEqual(reg["reasonCode"], "trademark")
+
+    def test_resolve_reports_the_prices(self):
+        snrc.eth_call = self._chain(self._lapsed(1))
+        status, body = snrc.resolve("acme.testing")
+        self.assertEqual(status, 410)
+        self.assertEqual(body["status"], "expired")
+        self.assertEqual(body["basePrice"], self.BASE)
+
+    def test_a_hashed_query_is_priced_too(self):
+        # keccak-256("acme")
+        hashed = "[e29dae06ef4c3e336b7538b6d4f52ca1ecec009b1df6fb501320e11b223aeeaf]"
+        snrc.eth_call = self._chain(self._lapsed(0))
+        _, body = snrc.resolve(hashed + ".testing")
+        self.assertEqual(body["status"], "expired")
+        self.assertEqual(body["basePrice"], self.BASE)
+
+
+class EnsOracleTests(unittest.TestCase):
+    """.testing runs an ENS-shaped oracle: it prices in attoUSD per second and
+    charges a premium on lapsed names that it does not expose."""
+
+    REGISTRY = "0x58fc46996d975c57883564648bda5206d1a0102b"
+    REGISTRAR = "0xef47eb4384b46c89e4482a677c2cbcbd2a6fd85a"
+    CONTROLLER = "0x281ca41311c2aa808c917c4674639d7567b75714"
+    ORACLE = "0x1e0c9a2b9d1a4c8f7b3e5d6a9c2f4b8e1d7a3c50"
+    GRACE = 90 * 86400
+    MIN_LENGTH = 6
+
+    def setUp(self):
+        self._saved = (snrc.REGISTRIES, snrc.REGISTRARS, snrc.CONTROLLERS, snrc.eth_call, snrc.chain_now)
+        snrc.REGISTRIES = {"testing": self.REGISTRY}
+        snrc.REGISTRARS = {"testing": self.REGISTRAR}
+        snrc.CONTROLLERS = {"testing": self.CONTROLLER}
+        self.now = int(time.time())
+        snrc.chain_now = lambda: self.now
+
+    def tearDown(self):
+        (snrc.REGISTRIES, snrc.REGISTRARS, snrc.CONTROLLERS, snrc.eth_call, snrc.chain_now) = self._saved
+
+    def _chain(self, expires, letter_cents=0):
+        def eth_call(to, data):
+            if data.startswith(snrc.selector("nameExpires(uint256)")):
+                return "0x" + snrc.encode_uint(expires)
+            if data.startswith(snrc.selector("GRACE_PERIOD()")):
+                return "0x" + snrc.encode_uint(self.GRACE)
+            if data.startswith(snrc.selector("reservedNames(bytes32)")):
+                return "0x" + snrc.encode_uint(0)
+            if data.startswith(snrc.selector("minCharLength()")):
+                return "0x" + snrc.encode_uint(self.MIN_LENGTH)
+            if data.startswith(snrc.selector("prices()")):
+                if to == self.CONTROLLER:
+                    return "0x" + snrc.encode_uint(int(self.ORACLE, 16))
+                raise RuntimeError("eth_call returned 0x")  # no prices() on this oracle
+            for n in range(1, 7):
+                if data.startswith(snrc.selector(f"price{n}Letter()")):
+                    rate = letter_cents * snrc.ATTO_PER_CENT // snrc.SECONDS_PER_YEAR
+                    return "0x" + snrc.encode_uint(rate)
+            return self.fail("unexpected call " + data[:10])
+
+        return eth_call
+
+    def test_a_never_registered_name_is_priced_from_the_letter_curve(self):
+        snrc.eth_call = self._chain(0)
+        reg = snrc.name_status("ghost.testing")
+        self.assertEqual(reg["status"], "unregistered")
+        self.assertEqual(reg["basePrice"], 0)
+        self.assertEqual(reg["minLabelLength"], self.MIN_LENGTH)
+
+    def test_a_non_zero_letter_curve_converts_to_cents_per_year(self):
+        snrc.eth_call = self._chain(0, letter_cents=1200)
+        self.assertEqual(snrc.name_status("ghost.testing")["basePrice"], 1200)
+
+    def test_a_lapsed_name_is_not_priced_because_the_premium_is_unreadable(self):
+        snrc.eth_call = self._chain(self.now - self.GRACE - 1)
+        reg = snrc.name_status("acme.testing")
+        self.assertEqual(reg["status"], "expired")
+        self.assertNotIn("basePrice", reg)
+
+
+class ErrorCodeTests(unittest.TestCase):
+    REGISTRY = "0x58fc46996d975c57883564648bda5206d1a0102b"
+    REGISTRAR = "0xef47eb4384b46c89e4482a677c2cbcbd2a6fd85a"
+
+    def setUp(self):
+        self._saved = (
+            snrc.REGISTRIES,
+            snrc.REGISTRARS,
+            snrc.CONTROLLERS,
+            snrc.eth_call,
+            snrc.chain_now,
+        )
+        snrc.REGISTRIES = {"testing": self.REGISTRY, "simplex": ""}
+        snrc.REGISTRARS = {"testing": self.REGISTRAR}
+        snrc.CONTROLLERS = {"testing": ""}
+        snrc.chain_now = lambda: int(time.time())
+
+    def tearDown(self):
+        (
+            snrc.REGISTRIES,
+            snrc.REGISTRARS,
+            snrc.CONTROLLERS,
+            snrc.eth_call,
+            snrc.chain_now,
+        ) = self._saved
+
+    def _chain(self, expires, resolver=None):
+        def eth_call(to, data):
+            if data.startswith(snrc.selector("GRACE_PERIOD()")):
+                return "0x" + snrc.encode_uint(90 * 86400)
+            if data.startswith(snrc.selector("resolver(bytes32)")):
+                return "0x" + "00" * 12 + (resolver or "00" * 20)
+            return "0x" + snrc.encode_uint(expires)
+
+        return eth_call
+
+    def test_an_unconfigured_tld_names_the_ones_that_are(self):
+        status, body = snrc.resolve("alice.nosuchtld")
+        self.assertEqual(status, 400)
+        self.assertEqual(body["error"], "tldNotConfigured")
+        self.assertEqual(body["configuredTlds"], ["testing"])
+        self.assertIn("nosuchtld", body["message"])
+
+    def test_a_registration_problem_reports_the_status_as_the_code(self):
+        for expires, code in (
+            (0, "unregistered"),
+            (int(time.time()) - 91 * 86400, "expired"),
+        ):
+            with self.subTest(code=code):
+                snrc.eth_call = self._chain(expires)
+                _, body = snrc.resolve("alice.testing")
+                self.assertEqual(body["error"], code)
+                self.assertEqual(body["status"], code)
+
+    def test_a_name_in_grace_still_resolves(self):
+        snrc.eth_call = self._chain(int(time.time()) - 3600)
+        status, body = snrc.resolve("alice.testing")
+        self.assertEqual(status, 200)
+        self.assertEqual(body["status"], "grace")
+        self.assertNotIn("error", body)
+
+    def test_a_registered_name_pointing_nowhere_resolves_with_empty_records(self):
+        snrc.eth_call = self._chain(int(time.time()) + 86400)
+        status, body = snrc.resolve("alice.testing")
+        self.assertEqual(status, 200)
+        self.assertEqual(body["status"], "registered")
+        self.assertEqual(body["resolver"], snrc.ZERO_ADDR)
+        self.assertEqual(body["simplexContact"], [])
+
+    def test_every_error_body_carries_both_fields(self):
+        snrc.eth_call = self._chain(0)
+        for name in ("alice.nosuchtld", "alice.testing"):
+            with self.subTest(name=name):
+                _, body = snrc.resolve(name)
+                self.assertIsInstance(body["error"], str)
+                self.assertIsInstance(body["message"], str)
+                self.assertNotEqual(body["error"], body["message"])
+
+    def test_an_upstream_failure_does_not_echo_the_exception(self):
+        with contextlib.redirect_stderr(io.StringIO()) as log:
+            body = snrc.upstream_error(
+                {"name": "alice.testing"},
+                RuntimeError("http://user:[email protected]/kEy8 refused"),
+            )
+        # the operator still sees the detail in the log
+        self.assertIn("secret", log.getvalue())
+        self.assertEqual(body["error"], "upstreamError")
+        self.assertIn("RuntimeError", body["message"])
+        self.assertNotIn("secret", body["message"])
+        self.assertNotIn("kEy8", body["message"])
+
+
+class RegistrationV2Tests(unittest.TestCase):
+    """`/v2/resolve` answers with the SMP protocol's NameRegistration, which the
+    relay decodes as is. The key names are the wire contract, so they are pinned
+    here: renaming one without the Haskell side is a silent break."""
+
+    REGISTRY = "0x58fc46996d975c57883564648bda5206d1a0102b"
+    REGISTRAR = "0xef47eb4384b46c89e4482a677c2cbcbd2a6fd85a"
+    CONTROLLER = "0x281ca41311c2aa808c917c4674639d7567b75714"
+    ORACLE = "0x1e0c9a2b9d1a4c8f7b3e5d6a9c2f4b8e1d7a3c50"
+    OWNER = "0xd83bd7e0e6b8a4c1f2593a7b0c4e8d1a6f9b2c37"
+
+    GRACE = 90 * 86400
+    BASE = 200
+    EXCEPTIONS = {1: 64000, 2: 16000, 3: 1600, 4: 800, 5: 500}
+    MIN_LENGTH = 3
+
+    def setUp(self):
+        self._saved = (
+            snrc.REGISTRIES,
+            snrc.REGISTRARS,
+            snrc.CONTROLLERS,
+            snrc.eth_call,
+            snrc.chain_now,
+        )
+        snrc.REGISTRIES = {"testing": self.REGISTRY}
+        snrc.REGISTRARS = {"testing": self.REGISTRAR}
+        snrc.CONTROLLERS = {"testing": self.CONTROLLER}
+        self.now = int(time.time())
+        snrc.chain_now = lambda: self.now
+
+    def tearDown(self):
+        (
+            snrc.REGISTRIES,
+            snrc.REGISTRARS,
+            snrc.CONTROLLERS,
+            snrc.eth_call,
+            snrc.chain_now,
+        ) = self._saved
+
+    def _prices_return(self):
+        words = [snrc.encode_uint(self.BASE), snrc.encode_uint(0x40),
+                 snrc.encode_uint(len(self.EXCEPTIONS))]
+        for length, cents in self.EXCEPTIONS.items():
+            words += [snrc.encode_uint(length), snrc.encode_uint(cents)]
+        return "0x" + "".join(words)
+
+    @staticmethod
+    def _abi_bytes(value: bytes) -> str:
+        """head offset, length, then the payload padded to a 32-byte word."""
+        pad = (-len(value)) % 32
+        return ("0x" + snrc.encode_uint(0x20) + snrc.encode_uint(len(value))
+                + (value + b"\x00" * pad).hex())
+
+    def _chain(self, expires, reserved=0, oracle=None, label=b"acme", owner=None):
+        """The registry answers a zero resolver, so name_record returns the
+        empty record a registered name still has. `label` is what the registrar
+        recorded for the 2LD; b"" means it recorded none. `owner` is the owner of
+        the queried node; ZERO_ADDR means that node was never created."""
+        oracle = self.ORACLE if oracle is None else oracle
+        owner = self.OWNER if owner is None else owner
+
+        def eth_call(to, data):
+            if data.startswith(snrc.selector("labelOf(uint256)")):
+                return self._abi_bytes(label)
+            if data.startswith(snrc.selector("nameExpires(uint256)")):
+                return "0x" + snrc.encode_uint(expires)
+            if data.startswith(snrc.selector("GRACE_PERIOD()")):
+                return "0x" + snrc.encode_uint(self.GRACE)
+            if data.startswith(snrc.selector("reservedNames(bytes32)")):
+                return "0x" + snrc.encode_uint(reserved)
+            if data.startswith(snrc.selector("minCharLength()")):
+                return "0x" + snrc.encode_uint(self.MIN_LENGTH)
+            if data.startswith(snrc.selector("prices()")):
+                if to == self.CONTROLLER:
+                    return "0x" + snrc.encode_uint(int(oracle, 16))
+                return self._prices_return()
+            if data.startswith(snrc.selector("resolver(bytes32)")):
+                return "0x" + snrc.encode_uint(0)
+            if data.startswith(snrc.selector("owner(bytes32)")):
+                return "0x" + snrc.encode_uint(int(owner, 16))
+            return self.fail("unexpected call " + data[:10])
+
+        return eth_call
+
+    def _lapsed(self, days_past_grace):
+        return self.now - self.GRACE - 1 - days_past_grace * 86400
+
+    def test_a_live_name_is_registered_and_carries_its_record(self):
+        expires = self.now + 3600
+        snrc.eth_call = self._chain(expires)
+        status, body = registration("acme.testing")
+        self.assertEqual(status, 200)
+        self.assertEqual(body["type"], "registered")
+        self.assertEqual(body["expires"], expires)
+        self.assertEqual(body["graceUntil"], expires + self.GRACE)
+        self.assertIsNone(body["reservedReason_"])
+        self.assertEqual(body["nameRecord"]["name"], "acme.testing")
+
+    def test_a_name_in_grace_is_still_registered(self):
+        expires = self.now - 3600
+        snrc.eth_call = self._chain(expires)
+        _, body = registration("acme.testing")
+        self.assertEqual(body["type"], "registered")
+        self.assertGreater(body["graceUntil"], self.now)
+
+    def test_a_registered_name_that_is_held_back_says_so(self):
+        snrc.eth_call = self._chain(self.now + 3600, reserved=1)
+        _, body = registration("acme.testing")
+        self.assertEqual(body["type"], "registered")
+        self.assertEqual(body["reservedReason_"], "internal")
+
+    def test_an_unregistered_name_is_available_with_its_pricing(self):
+        snrc.eth_call = self._chain(0)
+        status, body = registration("acme.testing")
+        self.assertEqual(status, 200)
+        self.assertEqual(body["type"], "available")
+        # lengths below minCharLength are unregistrable, so they are not priced
+        self.assertEqual(body["pricing"]["registrationPrices"], {3: 1600, 4: 800, 5: 500})
+        self.assertEqual(body["pricing"]["basePrice"], self.BASE)
+        self.assertEqual(body["pricing"]["minLabelLength"], self.MIN_LENGTH)
+
+    def test_a_lapsed_name_is_available_at_the_ordinary_price(self):
+        snrc.eth_call = self._chain(self._lapsed(1))
+        _, body = registration("acme.testing")
+        self.assertEqual(body["type"], "available")
+        self.assertEqual(body["pricing"]["basePrice"], self.BASE)
+
+    def test_a_held_back_name_is_reserved_and_is_never_priced(self):
+        snrc.eth_call = self._chain(0, reserved=2)
+        status, body = registration("acme.testing")
+        self.assertEqual(status, 200)
+        self.assertEqual(body["type"], "reserved")
+        self.assertEqual(body["reservedReason"], "trademark")
+        self.assertNotIn("pricing", body)
+
+    def test_a_hashed_query_answers_the_same_as_the_name(self):
+        # keccak-256("acme")
+        hashed = "[e29dae06ef4c3e336b7538b6d4f52ca1ecec009b1df6fb501320e11b223aeeaf]"
+        snrc.eth_call = self._chain(0)
+        _, by_name = registration("acme.testing")
+        _, by_hash = registration(hashed + ".testing")
+        self.assertEqual(by_name, by_hash)
+
+    def test_an_unconfigured_tld_is_refused_not_answered(self):
+        snrc.REGISTRIES = {"testing": ""}
+        snrc.eth_call = lambda *a: self.fail("must not reach the chain")
+        status, body = registration("acme.testing")
+        self.assertEqual(status, 400)
+        self.assertEqual(body["error"], "tldNotConfigured")
+
+    def test_no_price_oracle_is_an_error_not_a_free_name(self):
+        snrc.eth_call = self._chain(0, oracle=snrc.ZERO_ADDR)
+        status, body = registration("acme.testing")
+        self.assertEqual(status, 502)
+        self.assertEqual(body["error"], "noPriceOracle")
+
+    def test_a_status_it_cannot_read_is_an_error_not_a_registration(self):
+        snrc.REGISTRARS = {"testing": ""}
+        snrc.eth_call = self._chain(0)
+        status, body = registration("acme.testing")
+        self.assertEqual(status, 502)
+        self.assertEqual(body["error"], "unknown")
+
+    def test_each_answer_carries_exactly_its_own_fields(self):
+        """The relay decodes by these names; an extra or missing one is a break."""
+        cases = {
+            "registered": (self._chain(self.now + 3600),
+                           {"type", "expires", "graceUntil", "reservedReason_", "nameRecord"}),
+            "available": (self._chain(0), {"type", "pricing"}),
+            "reserved": (self._chain(0, reserved=1), {"type", "reservedReason"}),
+        }
+        for expected_type, (chain, keys) in cases.items():
+            with self.subTest(type=expected_type):
+                snrc.eth_call = chain
+                _, body = registration("acme.testing")
+                self.assertEqual(body["type"], expected_type)
+                self.assertEqual(set(body), keys)
+    def test_a_hashed_query_the_registrar_cannot_name_is_refused(self):
+        """The client checks the record names what it asked about, so answering
+        with a record the registrar could not name would only fail there."""
+        hashed = "[e29dae06ef4c3e336b7538b6d4f52ca1ecec009b1df6fb501320e11b223aeeaf]"
+        snrc.eth_call = self._chain(self.now + 3600, label=b"")
+        status, body = registration(hashed + ".testing")
+        self.assertEqual(status, 502)
+        self.assertEqual(body["error"], "labelNotRecorded")
+
+    def test_a_hashed_query_is_answered_with_the_name_the_registrar_recorded(self):
+        hashed = "[e29dae06ef4c3e336b7538b6d4f52ca1ecec009b1df6fb501320e11b223aeeaf]"
+        snrc.eth_call = self._chain(self.now + 3600)
+        status, body = registration(hashed + ".testing")
+        self.assertEqual(status, 200)
+        self.assertEqual(body["nameRecord"]["name"], "acme.testing")
+    def test_a_subname_that_exists_is_registered_with_its_parents_dates(self):
+        expires = self.now + 3600
+        snrc.eth_call = self._chain(expires)
+        status, body = registration("sub.acme.testing")
+        self.assertEqual(status, 200)
+        self.assertEqual(body["type"], "registered")
+        self.assertEqual(body["expires"], expires)
+        self.assertEqual(body["nameRecord"]["name"], "sub.acme.testing")
+
+    def test_a_subname_nobody_created_is_not_registered(self):
+        """The registrar only tracks 2LDs, so the parent's registration says
+        nothing about a child that was never created: its node has no owner."""
+        snrc.eth_call = self._chain(self.now + 3600, owner=snrc.ZERO_ADDR)
+        status, body = registration("sub.acme.testing")
+        self.assertEqual(status, 200)
+        self.assertEqual(body["type"], "available")
+
+    def test_a_2ld_is_not_subject_to_the_owner_check(self):
+        """Only a subname can be absent under a registered parent."""
+        snrc.eth_call = self._chain(self.now + 3600, owner=snrc.ZERO_ADDR)
+        _, body = registration("acme.testing")
+        self.assertEqual(body["type"], "registered")
+
+    def test_v1_does_not_report_an_uncreated_subname_as_registered(self):
+        """v1 has no availability, so the only honest answer is not-found. The
+        2LD case is untouched: a registered name with no resolver still resolves."""
+        snrc.eth_call = self._chain(self.now + 3600, owner=snrc.ZERO_ADDR)
+        status, body = snrc.resolve("sub.acme.testing")
+        self.assertEqual(status, 404)
+        self.assertEqual(body["error"], "unregistered")
+
+    def test_v1_still_resolves_a_2ld_with_no_resolver_set(self):
+        snrc.eth_call = self._chain(self.now + 3600, owner=snrc.ZERO_ADDR)
+        status, body = snrc.resolve("acme.testing")
+        self.assertEqual(status, 200)
+        self.assertEqual(body["resolver"], snrc.ZERO_ADDR)
+
+    def test_the_answer_says_which_block_it_was_read_at(self):
+        """The resolver is only as current as its node. Without this a client
+        cannot tell an answer that predates its own registration."""
+        snrc.eth_call = self._chain(self.now + 3600)
+        _, res = snrc.registration("acme.testing")
+        self.assertEqual(res["lastBlockTs"], self.now)
+        self.assertEqual(res["registration"]["type"], "registered")
+
+    def test_an_available_name_says_so_too(self):
+        """This is the path that reads no block otherwise, and the one where
+        staleness matters most: the name may already be taken."""
+        snrc.eth_call = self._chain(0)
+        _, res = snrc.registration("acme.testing")
+        self.assertEqual(res["lastBlockTs"], self.now)
+        self.assertEqual(res["registration"]["type"], "available")
+
 if __name__ == "__main__":
     unittest.main()

simplexmq.cabal

@@ -1,7 +1,7 @@
 cabal-version: 3.0
 
 name:           simplexmq
-version:        7.1.0.4
+version:        7.1.0.8
 synopsis:       SimpleXMQ message broker
 description:    This package includes <./docs/Simplex-Messaging-Server.html server>,
                 <./docs/Simplex-Messaging-Client.html client> and
@@ -135,6 +135,7 @@ library
       Simplex.Messaging.Crypto.Lazy
       Simplex.Messaging.Crypto.Ratchet
       Simplex.Messaging.Crypto.BBS
+      Simplex.Messaging.Crypto.Entitlement
       Simplex.Messaging.Crypto.SNTRUP761
       Simplex.Messaging.Crypto.SNTRUP761.Bindings
       Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines
@@ -192,6 +193,8 @@ library
           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_rpc
+          Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260823_snd_files_entitlement
+          Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260919_ratchet_verify_codes
   else
       exposed-modules:
           Simplex.Messaging.Agent.Store.SQLite
@@ -245,6 +248,8 @@ library
           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_rpc
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260823_snd_files_entitlement
+          Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260919_ratchet_verify_codes
           Simplex.Messaging.Agent.Store.SQLite.Util
   if flag(client_postgres) || flag(server_postgres)
       exposed-modules:
@@ -266,6 +271,7 @@ library
           Simplex.FileTransfer.Server.Store
           Simplex.FileTransfer.Server.StoreLog
           Simplex.Messaging.Server
+          Simplex.Messaging.Server.AddressStats
           Simplex.Messaging.Server.CLI
           Simplex.Messaging.Server.Control
           Simplex.Messaging.Server.Env.STM
@@ -537,6 +543,7 @@ test-suite simplexmq-test
       AgentTests.ServerChoice
       AgentTests.ShortLinkTests
       CLITests
+      CoreTests.AddressStatsTests
       CoreTests.BatchingTests
       CoreTests.CryptoFileTests
       CoreTests.CryptoTests

src/Simplex/FileTransfer/Agent.hs

@@ -17,11 +17,16 @@ module Simplex.FileTransfer.Agent
     toFSFilePath,
     -- Receiving files
     xftpReceiveFile',
+    xftpPrepareReceiveFile',
+    xftpStartReceiveFile',
     xftpDeleteRcvFile',
     xftpDeleteRcvFiles',
     -- Sending files
     xftpSendFile',
     xftpSendDescription',
+    xftpPrepareSendFile',
+    xftpPrepareSendDescription',
+    xftpStartSendFile',
     deleteSndFileInternal,
     deleteSndFilesInternal,
     deleteSndFileRemote,
@@ -50,11 +55,12 @@ import qualified Data.Set as S
 import Data.Text (Text, pack)
 import Data.Time.Clock (getCurrentTime)
 import Data.Time.Format (defaultTimeLocale, formatTime)
+import Data.Word (Word32)
 import Simplex.FileTransfer.Chunks (toKB)
 import Simplex.FileTransfer.Client (XFTPChunkSpec (..), getChunkDigest, prepareChunkSizes, prepareChunkSpecs, singleChunkSize)
 import Simplex.FileTransfer.Crypto
 import Simplex.FileTransfer.Description
-import Simplex.FileTransfer.Protocol (FileParty (..), SFileParty (..))
+import Simplex.FileTransfer.Protocol (FileParty (..), GrantedStorageTime, SFileParty (..))
 import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..))
 import qualified Simplex.FileTransfer.Transport as XFTP
 import Simplex.FileTransfer.Types
@@ -126,7 +132,12 @@ closeXFTPAgent a = do
     stopWorkers workers = atomically (swapTVar workers M.empty) >>= mapM_ (liftIO . cancelWorker)
 
 xftpReceiveFile' :: AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> Bool -> AM RcvFileId
-xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks, redirect}) cfArgs approvedRelays = do
+xftpReceiveFile' c userId vfd cfArgs approvedRelays = do
+  fId <- xftpPrepareReceiveFile' c userId vfd cfArgs approvedRelays
+  fId <$ xftpStartReceiveFile' c fId
+
+xftpPrepareReceiveFile' :: AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> Bool -> AM RcvFileId
+xftpPrepareReceiveFile' c userId (ValidFileDescription fd@FileDescription {redirect}) cfArgs approvedRelays = do
   g <- asks random
   prefixPath <- lift $ getPrefixPath "rcv.xftp"
   createDirectory prefixPath
@@ -136,7 +147,7 @@ xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks, redi
   lift $ createDirectory =<< toFSFilePath relTmpPath
   lift $ createEmptyFile =<< toFSFilePath relSavePath
   let saveFile = CryptoFile relSavePath cfArgs
-  fId <- case redirect of
+  case redirect of
     Nothing -> withStore c $ \db -> createRcvFile db g userId fd relPrefixPath relTmpPath saveFile approvedRelays
     Just _ -> do
       -- prepare description paths
@@ -148,8 +159,11 @@ xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks, redi
       let saveFileRedirect = CryptoFile relSavePathRedirect $ Just cfArgsRedirect
       -- create download tasks
       withStore c $ \db -> createRcvFileRedirect db g userId fd relPrefixPath relTmpPathRedirect saveFileRedirect relTmpPath saveFile approvedRelays
-  forM_ chunks (downloadChunk c)
-  pure fId
+
+xftpStartReceiveFile' :: AgentClient -> RcvFileId -> AM ()
+xftpStartReceiveFile' c rcvFileEntityId = do
+  srvs <- withStore c (`startPreparedRcvFile` rcvFileEntityId)
+  lift $ forM_ srvs $ void . getXFTPRcvWorker True c . Just
 
 downloadChunk :: AgentClient -> FileChunk -> AM ()
 downloadChunk c FileChunk {replicas = (FileChunkReplica {server} : _)} = do
@@ -350,8 +364,13 @@ xftpDeleteRcvFiles' c rcvFileEntityIds = do
 notify :: forall m e. (MonadIO m, AEntityI e) => AgentClient -> AEntityId -> AEvent e -> m ()
 notify c entId cmd = atomically $ writeTBQueue (subQ c) ("", entId, AEvt (sAEntity @e) cmd)
 
-xftpSendFile' :: AgentClient -> UserId -> CryptoFile -> Int -> AM SndFileId
-xftpSendFile' c userId file numRecipients = do
+xftpSendFile' :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe Word32 -> AM SndFileId
+xftpSendFile' c userId file numRecipients storageHours = do
+  fId <- xftpPrepareSendFile' c userId file numRecipients storageHours
+  fId <$ xftpStartSendFile' c fId
+
+xftpPrepareSendFile' :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe Word32 -> AM SndFileId
+xftpPrepareSendFile' c userId file numRecipients storageHours = do
   g <- asks random
   prefixPath <- lift $ getPrefixPath "snd.xftp"
   createDirectory prefixPath
@@ -359,12 +378,15 @@ xftpSendFile' c userId file numRecipients = do
   key <- atomically $ C.randomSbKey g
   nonce <- atomically $ C.randomCbNonce g
   -- saving absolute filePath will not allow to restore file encryption after app update, but it's a short window
-  fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce Nothing
-  lift . void $ getXFTPSndWorker True c Nothing
-  pure fId
+  withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce Nothing storageHours
 
 xftpSendDescription' :: AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Int -> AM SndFileId
-xftpSendDescription' c userId (ValidFileDescription fdDirect@FileDescription {size, digest}) numRecipients = do
+xftpSendDescription' c userId vfd numRecipients = do
+  fId <- xftpPrepareSendDescription' c userId vfd numRecipients
+  fId <$ xftpStartSendFile' c fId
+
+xftpPrepareSendDescription' :: AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Int -> AM SndFileId
+xftpPrepareSendDescription' c userId (ValidFileDescription fdDirect@FileDescription {size, digest}) numRecipients = do
   g <- asks random
   prefixPath <- lift $ getPrefixPath "snd.xftp"
   createDirectory prefixPath
@@ -375,9 +397,12 @@ xftpSendDescription' c userId (ValidFileDescription fdDirect@FileDescription {si
   liftError (FILE . FILE_IO . show) $ CF.writeFile file (LB.fromStrict $ strEncode fdDirect)
   key <- atomically $ C.randomSbKey g
   nonce <- atomically $ C.randomCbNonce g
-  fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce $ Just RedirectFileInfo {size, digest}
+  withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce (Just RedirectFileInfo {size, digest}) Nothing
+
+xftpStartSendFile' :: AgentClient -> SndFileId -> AM ()
+xftpStartSendFile' c sndFileEntityId = do
+  withStore c (`startPreparedSndFile` sndFileEntityId)
   lift . void $ getXFTPSndWorker True c Nothing
-  pure fId
 
 resumeXFTPSndWork :: AgentClient -> Maybe XFTPServer -> AM' ()
 resumeXFTPSndWork = void .: getXFTPSndWorker False
@@ -405,7 +430,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
     prepareFile _ SndFile {prefixPath = Nothing} =
       throwE $ INTERNAL "no prefix path"
     prepareFile cfg sndFile@SndFile {sndFileId, sndFileEntityId, userId, prefixPath = Just ppath, status} = do
-      SndFile {numRecipients, chunks} <-
+      SndFile {numRecipients, chunks, storageHours} <-
         if status /= SFSEncrypted -- status is SFSNew or SFSEncrypting
           then do
             fsEncPath <- lift . toFSFilePath $ sndFileEncPath ppath
@@ -424,7 +449,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
       let (pendingChunks, preparedSrvs) = partitionEithers $ map srvOrPendingChunk chunks
       -- concurrently?
       -- separate worker to create chunks? record retries and delay on snd_file_chunks?
-      srvs <- forM pendingChunks $ createChunk numRecipients'
+      srvs <- forM pendingChunks $ createChunk numRecipients' storageHours
       let allSrvs = S.fromList $ preparedSrvs <> srvs
       lift $ forM_ allSrvs $ \srv -> getXFTPSndWorker True c (Just srv)
       withStore' c $ \db -> updateSndFileStatus db sndFileId SFSUploading
@@ -454,8 +479,8 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
         srvOrPendingChunk ch@SndFileChunk {replicas} = case replicas of
           [] -> Left ch
           SndFileChunkReplica {server} : _ -> Right server
-        createChunk :: Int -> SndFileChunk -> AM (ProtocolServer 'PXFTP)
-        createChunk numRecipients' ch = do
+        createChunk :: Int -> Maybe Word32 -> SndFileChunk -> AM (ProtocolServer 'PXFTP)
+        createChunk numRecipients' storageHours ch = do
           liftIO $ assertAgentForeground c
           (replica, ProtoServerWithAuth srv _) <- tryCreate
           withStore' c $ \db -> createSndFileReplica db ch replica
@@ -482,7 +507,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
               deleted <- withStore' c $ \db -> getSndFileDeleted db sndFileId
               when deleted $ throwE $ FILE NO_FILE
               withNextSrv c userId storageSrvs triedHosts [] $ \srvAuth -> do
-                replica <- agentXFTPNewChunk c ch numRecipients' srvAuth
+                replica <- agentXFTPNewChunk c ch numRecipients' srvAuth storageHours
                 pure (replica, srvAuth)
 
 sndWorkerInternalError :: AgentClient -> DBSndFileId -> SndFileId -> Maybe FilePath -> AgentErrorType -> AM ()
@@ -543,7 +568,7 @@ runXFTPSndWorker c srv Worker {doWork} = do
       notify c sndFileEntityId $ SFPROG uploaded total
       when complete $ do
         (sndDescr, rcvDescrs) <- sndFileToDescrs sf
-        notify c sndFileEntityId $ SFDONE sndDescr rcvDescrs
+        notify c sndFileEntityId $ SFDONE sndDescr rcvDescrs (sndFileExpiresAt chunks)
         lift . forM_ prefixPath $ removePath <=< toFSFilePath
         withStore' c $ \db -> updateSndFileComplete db sndFileId
       where
@@ -577,6 +602,10 @@ runXFTPSndWorker c srv Worker {doWork} = do
           let chunkSize = FileSize $ sndChunkSize ch
               replicas = [FileChunkReplica {server, replicaId, replicaKey}]
           pure FileChunk {chunkNo, digest = chDigest, chunkSize, replicas}
+        sndFileExpiresAt :: [SndFileChunk] -> Maybe GrantedStorageTime
+        sndFileExpiresAt chunks' = fmap minimum $ L.nonEmpty =<< mapM chunkExpiresAt chunks'
+          where
+            chunkExpiresAt SndFileChunk {replicas} = maximum <$> L.nonEmpty (mapMaybe (\SndFileChunkReplica {expiresAt} -> expiresAt) replicas)
         createRcvFileDescriptions :: FileDescription 'FRecipient -> [SndFileChunk] -> [FileDescription 'FRecipient]
         createRcvFileDescriptions fd sndChunks = map (\chunks -> (fd :: (FileDescription 'FRecipient)) {chunks}) rcvChunks
           where

src/Simplex/FileTransfer/Client.hs

@@ -36,8 +36,10 @@ import qualified Control.Exception as E
 import Control.Logger.Simple
 import Control.Monad
 import Control.Monad.Except
+import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Except
 import Crypto.Random (ChaChaDRG)
+import qualified Data.Aeson as J
 import Data.Bifunctor (first)
 import Data.ByteString.Builder (Builder, byteString)
 import Data.ByteString.Char8 (ByteString)
@@ -57,6 +59,7 @@ import Network.Socket (HostName)
 import Simplex.FileTransfer.Chunks
 import Simplex.FileTransfer.Protocol
 import Simplex.FileTransfer.Transport
+import Simplex.Messaging.Crypto.Entitlement (EntitlementProof)
 import Simplex.Messaging.Client
   ( NetworkConfig (..),
     NetworkRequestMode (..),
@@ -84,7 +87,7 @@ import Simplex.Messaging.Protocol
     SenderId,
     pattern NoEntity,
   )
-import Simplex.Messaging.Transport (ALPN, CertChainPubKey (..), HandshakeError (..), THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), defaultSupportedParams)
+import Simplex.Messaging.Transport (ALPN, CertChainPubKey (..), HandshakeError (..), SessionId, THandleAuth (..), THandleParams (..), TransportError (..), TransportPeer (..), defaultSupportedParams)
 import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost)
 import Simplex.Messaging.Transport.HTTP2
 import Simplex.Messaging.Transport.HTTP2.Client
@@ -126,8 +129,8 @@ defaultXFTPClientConfig =
       clientALPN = Just alpnSupportedXFTPhandshakes
     }
 
-getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> [HostName] -> UTCTime -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient)
-getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, xftpNetworkConfig, serverVRange} presetDomains proxySessTs disconnected = runExceptT $ do
+getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> [HostName] -> UTCTime -> (SessionId -> IO (Maybe EntitlementProof)) -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient)
+getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN, xftpNetworkConfig, serverVRange} presetDomains proxySessTs mkEntitlementProof disconnected = runExceptT $ do
   let socksCreds = clientSocksCredentials xftpNetworkConfig proxySessTs transportSession
       ProtocolServer _ host port keyHash = srv
       useALPN = if useWebPort xftpNetworkConfig presetDomains srv then Just [httpALPN11] else clientALPN
@@ -146,21 +149,23 @@ getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {clientALPN,
   thParams@THandleParams {thVersion} <- case sessionALPN of
     Just alpn
       | alpn == xftpALPNv1 || alpn == httpALPN11 ->
-          xftpClientHandshakeV1 serverVRange keyHash http2Client thParams0
+          xftpClientHandshakeV1 serverVRange keyHash http2Client mkEntitlementProof thParams0
     _ -> pure thParams0
   logDebug $ "Client negotiated protocol: " <> tshow thVersion
   let c = XFTPClient {http2Client, thParams, transportSession, config}
   atomically $ writeTVar clientVar $ Just c
   pure c
 
-xftpClientHandshakeV1 :: VersionRangeXFTP -> C.KeyHash -> HTTP2Client -> THandleParamsXFTP 'TClient -> ExceptT XFTPClientError IO (THandleParamsXFTP 'TClient)
-xftpClientHandshakeV1 serverVRange keyHash@(C.KeyHash kh) c@HTTP2Client {sessionId, serverKey} thParams0 = do
-  shs@XFTPServerHandshake {authPubKey = ck} <- getServerHandshake
+xftpClientHandshakeV1 :: VersionRangeXFTP -> C.KeyHash -> HTTP2Client -> (SessionId -> IO (Maybe EntitlementProof)) -> THandleParamsXFTP 'TClient -> ExceptT XFTPClientError IO (THandleParamsXFTP 'TClient)
+xftpClientHandshakeV1 serverVRange keyHash@(C.KeyHash kh) c@HTTP2Client {sessionId, serverKey} mkEntitlementProof thParams0 = do
+  shs@XFTPServerHandshake {authPubKey = ck, serverInfoBytes} <- getServerHandshake
   (vr, sk) <- processServerHandshake shs
   let v = maxVersion vr
-  sendClientHandshake XFTPClientHandshake {xftpVersion = v, keyHash}
+  ep <- if v >= fileStorageTimeXFTPVersion then liftIO (mkEntitlementProof sessionId) else pure Nothing
+  sendClientHandshake XFTPClientHandshake {xftpVersion = v, keyHash, entitlementProof = ep}
   let thAuth = Just THAuthClient {peerServerPubKey = sk, peerServerCertKey = ck, clientService = Nothing, sessSecret = Nothing}
-  pure thParams0 {thAuth, thVersion = v, thServerVRange = vr}
+      serverInfo = J.eitherDecodeStrict' <$> serverInfoBytes
+  pure thParams0 {thAuth, thVersion = v, thServerVRange = vr, serverInfo}
   where
     getServerHandshake :: ExceptT XFTPClientError IO XFTPServerHandshake
     getServerHandshake = do
@@ -253,10 +258,11 @@ createXFTPChunk ::
   FileInfo ->
   NonEmpty C.APublicAuthKey ->
   Maybe BasicAuth ->
-  ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId)
-createXFTPChunk c spKey file rcps auth_ =
-  sendXFTPCommand c spKey NoEntity (FNEW file rcps auth_) Nothing >>= \case
-    (FRSndIds sId rIds, body) -> noFile body (sId, rIds)
+  Maybe Word32 ->
+  ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId, Maybe GrantedStorageTime)
+createXFTPChunk c spKey file rcps auth_ storageHours =
+  sendXFTPCommand c spKey NoEntity (FNEW file rcps auth_ storageHours) Nothing >>= \case
+    (FRSndIds sId rIds gs, body) -> noFile body (sId, rIds, gs)
     (r, _) -> throwE $ unexpectedResponse r
 
 addXFTPRecipients :: XFTPClient -> C.APrivateAuthKey -> XFTPFileId -> NonEmpty C.APublicAuthKey -> ExceptT XFTPClientError IO (NonEmpty RecipientId)

src/Simplex/FileTransfer/Client/Agent.hs

@@ -81,7 +81,7 @@ getXFTPServerClient XFTPClientAgent {xftpClients, startedAt, config} srv = do
     connectClient =
       ExceptT $
         first (XFTPClientAgentError srv)
-          <$> getXFTPClient (1, srv, Nothing) (xftpConfig config) [] startedAt clientDisconnected
+          <$> getXFTPClient (1, srv, Nothing) (xftpConfig config) [] startedAt (\_ -> pure Nothing) clientDisconnected
 
     clientDisconnected :: XFTPClient -> IO ()
     clientDisconnected _ = do

src/Simplex/FileTransfer/Client/Main.hs

@@ -328,7 +328,7 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re
           digest <- liftIO $ getChunkDigest chunkSpec
           let ch = FileInfo {sndKey, size = chunkSize, digest}
           c <- withRetry retryCount $ getXFTPServerClient a xftpServer
-          (sndId, rIds) <- withRetry retryCount $ createXFTPChunk c spKey ch (L.map fst rKeys) auth
+          (sndId, rIds, _) <- withRetry retryCount $ createXFTPChunk c spKey ch (L.map fst rKeys) auth Nothing
           withReconnect a xftpServer retryCount $ \c' -> uploadXFTPChunk c' spKey sndId chunkSpec
           logDebug $ "uploaded chunk " <> tshow chunkNo
           uploaded <- atomically . stateTVar uploadedChunks $ \cs ->
@@ -441,7 +441,6 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath,
           | depth > 0 -> do
               CryptoFile tmpFile _ <- withExceptT cliCryptoError $ decryptChunks encSize chunkPaths key nonce $ \_ ->
                 fmap CF.plain $ uniqueCombine encPath "redirect.yaml"
-              forM_ chunks $ acknowledgeFileChunk a
               yaml <- liftIO $ B.readFile tmpFile
               whenM (doesPathExist encPath) $ removeDirectoryRecursive encPath
               innerVfd <- either (throwE . CLIError . ("Redirect: invalid file description: " <>)) pure $ strDecode yaml
@@ -450,7 +449,6 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath,
         Nothing -> do
           liftIO $ printNoNewLine "Decrypting file..."
           CryptoFile path _ <- withExceptT cliCryptoError $ decryptChunks encSize chunkPaths key nonce $ fmap CF.plain . getFilePath
-          forM_ chunks $ acknowledgeFileChunk a
           whenM (doesPathExist encPath) $ removeDirectoryRecursive encPath
           liftIO $ do
             printNoNewLine $ "File downloaded: " <> path
@@ -479,12 +477,6 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath,
       _ -> (`uniqueCombine` name') . (</> "Downloads") =<< getHomeDirectory
       where
         name' = T.unpack name
-    acknowledgeFileChunk :: XFTPClientAgent -> FileChunk -> ExceptT CLIError IO ()
-    acknowledgeFileChunk a FileChunk {replicas = replica : _} = do
-      let FileChunkReplica {server, replicaId, replicaKey} = replica
-      c <- withRetry retryCount $ getXFTPServerClient a server
-      withRetry retryCount $ ackXFTPChunk c replicaKey (unChunkReplicaId replicaId)
-    acknowledgeFileChunk _ _ = throwE $ CLIError "chunk has no replicas"
 
 printProgress :: String -> Int64 -> Int64 -> IO ()
 printProgress s part total = printNoNewLine $ s <> " " <> show ((part * 100) `div` total) <> "%"

src/Simplex/FileTransfer/Description.hs

@@ -29,6 +29,7 @@ module Simplex.FileTransfer.Description
     YAMLFileDescription (..), -- for tests
     YAMLServerReplicas (..), -- for tests
     validateFileDescription,
+    sharedDescriptionHash,
     groupReplicasByServer,
     fdSeparator,
     kb,
@@ -72,6 +73,7 @@ import Simplex.FileTransfer.Protocol
 import Simplex.Messaging.Agent.QueryString
 import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..))
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding (Encoding (..))
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (defaultJSON, parseAll)
 import Simplex.Messaging.Protocol (XFTPServer)
@@ -227,6 +229,13 @@ validateFileDescription fd@FileDescription {size, chunks}
     chunkNos = map (\FileChunk {chunkNo} -> chunkNo) chunks
     chunksSize = foldl' (\(s :: Int64) FileChunk {chunkSize} -> s + fromIntegral (unFileSize chunkSize)) 0
 
+sharedDescriptionHash :: FileDescription p -> ByteString
+sharedDescriptionHash FileDescription {size, digest, key, nonce, chunkSize, chunks} =
+  C.sha512Hash $ smpEncode (unFileSize size, unFileDigest digest, C.unSbKey key, nonce, unFileSize chunkSize) <> foldMap chunkFields chunks
+  where
+    chunkFields FileChunk {chunkNo, chunkSize = cSize, digest = cDigest} =
+      smpEncode (fromIntegral chunkNo :: Int64, unFileSize cSize, unFileDigest cDigest)
+
 encodeFileDescription :: FileDescription p -> YAMLFileDescription
 encodeFileDescription FileDescription {party, size, digest, key, nonce, chunkSize, chunks, redirect} =
   YAMLFileDescription

src/Simplex/FileTransfer/Protocol.hs

@@ -22,6 +22,7 @@ module Simplex.FileTransfer.Protocol
     FileCommand (..),
     FileCmd (..),
     FileInfo (..),
+    GrantedStorageTime (..),
     XFTPFileId,
     FileResponse (..),
     xftpBlockSize,
@@ -38,12 +39,13 @@ import qualified Data.Aeson.TH as J
 import Data.Bifunctor (first)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import Data.Int (Int64)
 import Data.Kind (Type)
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.Maybe (isNothing)
 import Data.Type.Equality
 import Data.Word (Word32)
-import Simplex.FileTransfer.Transport (XFTPErrorType (..), XFTPVersion, blockedFilesXFTPVersion, xftpClientHandshakeStub)
+import Simplex.FileTransfer.Transport (XFTPErrorType (..), XFTPVersion, blockedFilesXFTPVersion, fileStorageTimeXFTPVersion, xftpClientHandshakeStub)
 import Simplex.Messaging.Client (authTransmission)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
@@ -175,7 +177,7 @@ instance Protocol XFTPVersion XFTPErrorType FileResponse where
   {-# INLINE protocolError #-}
 
 data FileCommand (p :: FileParty) where
-  FNEW :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe BasicAuth -> FileCommand FSender
+  FNEW :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe BasicAuth -> Maybe Word32 -> FileCommand FSender
   FADD :: NonEmpty RcvPublicAuthKey -> FileCommand FSender
   FPUT :: FileCommand FSender
   FDEL :: FileCommand FSender
@@ -196,12 +198,27 @@ data FileInfo = FileInfo
   }
   deriving (Show)
 
+data GrantedStorageTime = GSTExpires {epochSeconds :: Int64}
+  deriving (Eq, Ord, Show)
+
+instance Encoding GrantedStorageTime where
+  smpEncode = \case
+    GSTExpires t -> smpEncode ('T', t)
+  smpP =
+    smpP >>= \case
+      'T' -> GSTExpires <$> smpP
+      _ -> fail "bad GrantedStorageTime"
+
 type XFTPFileId = EntityId
 
 instance FilePartyI p => ProtocolEncoding XFTPVersion XFTPErrorType (FileCommand p) where
   type Tag (FileCommand p) = FileCommandTag p
-  encodeProtocol _v = \case
-    FNEW file rKeys auth_ -> e (FNEW_, ' ', file, rKeys, auth_)
+  encodeProtocol v = \case
+    FNEW file rKeys auth_ st
+      | v >= fileStorageTimeXFTPVersion -> fnew <> e st
+      | otherwise -> fnew
+      where
+        fnew = e (FNEW_, ' ', file, rKeys, auth_)
     FADD rKeys -> e (FADD_, ' ', rKeys)
     FPUT -> e FPUT_
     FDEL -> e FDEL_
@@ -235,10 +252,14 @@ instance ProtocolEncoding XFTPVersion XFTPErrorType FileCmd where
   type Tag FileCmd = FileCmdTag
   encodeProtocol _v (FileCmd _ c) = encodeProtocol _v c
 
-  protocolP _v = \case
+  protocolP v = \case
     FCT SFSender tag ->
       FileCmd SFSender <$> case tag of
-        FNEW_ -> FNEW <$> _smpP <*> smpP <*> smpP
+        FNEW_
+          | v >= fileStorageTimeXFTPVersion -> fnewP smpP
+          | otherwise -> fnewP (pure Nothing)
+          where
+            fnewP stP = FNEW <$> _smpP <*> smpP <*> smpP <*> stP
         FADD_ -> FADD <$> _smpP
         FPUT_ -> pure FPUT
         FDEL_ -> pure FDEL
@@ -292,7 +313,7 @@ instance ProtocolMsgTag FileResponseTag where
     _ -> Nothing
 
 data FileResponse
-  = FRSndIds SenderId (NonEmpty RecipientId)
+  = FRSndIds SenderId (NonEmpty RecipientId) (Maybe GrantedStorageTime)
   | FRRcvIds (NonEmpty RecipientId)
   | FRFile RcvPublicDhKey C.CbNonce
   | FROk
@@ -303,7 +324,9 @@ data FileResponse
 instance ProtocolEncoding XFTPVersion XFTPErrorType FileResponse where
   type Tag FileResponse = FileResponseTag
   encodeProtocol v = \case
-    FRSndIds fId rIds -> e (FRSndIds_, ' ', fId, rIds)
+    FRSndIds fId rIds gs
+      | v >= fileStorageTimeXFTPVersion -> e (FRSndIds_, ' ', fId, rIds, gs)
+      | otherwise -> e (FRSndIds_, ' ', fId, rIds)
     FRRcvIds rIds -> e (FRRcvIds_, ' ', rIds)
     FRFile rDhKey nonce -> e (FRFile_, ' ', rDhKey, nonce)
     FROk -> e FROk_
@@ -315,8 +338,10 @@ instance ProtocolEncoding XFTPVersion XFTPErrorType FileResponse where
       e :: Encoding a => a -> ByteString
       e = smpEncode
 
-  protocolP _v = \case
-    FRSndIds_ -> FRSndIds <$> _smpP <*> smpP
+  protocolP v = \case
+    FRSndIds_
+      | v >= fileStorageTimeXFTPVersion -> FRSndIds <$> _smpP <*> smpP <*> smpP
+      | otherwise -> FRSndIds <$> _smpP <*> smpP <*> pure Nothing
     FRRcvIds_ -> FRRcvIds <$> _smpP
     FRFile_ -> FRFile <$> _smpP <*> smpP
     FROk_ -> pure FROk

src/Simplex/FileTransfer/Server.hs

@@ -23,18 +23,22 @@ import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Reader
 import Control.Monad.Trans.Except
+import qualified Data.Aeson as J
 import Data.Bifunctor (first)
 import qualified Data.ByteString.Base64.URL as B64
 import Data.ByteString.Builder (Builder, byteString)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as L
+import qualified Data.Map.Strict as M
 import Data.Maybe (fromMaybe, isJust)
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime)
+import Data.Time.Clock.System (systemSeconds, utcToSystemTime)
 import Data.Time.Format.ISO8601 (iso8601Show)
 import Data.Word (Word32)
 import qualified Data.X509 as X
@@ -54,11 +58,14 @@ import Simplex.FileTransfer.Server.Store
 import Simplex.FileTransfer.Server.StoreLog
 import Simplex.FileTransfer.Transport
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.BBS (BBSPresHeader (..))
+import Simplex.Messaging.Crypto.Entitlement (Entitlement (..), EntitlementProof (..), EntitlementVerification (..), verifyEntitlement)
 import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (BlockingInfo, EntityId (..), RcvPublicAuthKey, RcvPublicDhKey, RecipientId, SignedTransmission, pattern NoEntity)
+import Simplex.Messaging.Protocol (BlockingInfo, CommandError (..), EntityId (..), RcvPublicAuthKey, RcvPublicDhKey, RecipientId, SignedTransmission, pattern NoEntity)
 import Simplex.Messaging.Server (controlPortAuth, dummyVerifyCmd, verifyCmdAuthorization)
+import Simplex.Messaging.Server.AddressStats (AddrStats, ServerAddrStats (..), addAddrCounter, addressStatsThread, incAddrCounter, printTopAddresses, withAddrStats)
 import Simplex.Messaging.Server.Control (CPClientRole (..))
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.QueueStore (ServerEntityStatus (..))
@@ -66,7 +73,7 @@ import Simplex.Messaging.Server.Stats
 import Simplex.Messaging.SystemTime
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
-import Simplex.Messaging.Transport (CertChainPubKey (..), SessionId, THandleAuth (..), THandleParams (..), TransportPeer (..), defaultSupportedParams, defaultSupportedParamsHTTPS)
+import Simplex.Messaging.Transport (CertChainPubKey (..), EntitlementConfig (..), SessionEntitlement (..), SessionId, THandleAuth (..), THandleParams (..), TransportPeer (..), defaultSupportedParams, defaultSupportedParamsHTTPS)
 import Simplex.Messaging.Transport.Buffer (trimCR)
 import Simplex.Messaging.Transport.HTTP2
 import Simplex.Messaging.Transport.HTTP2.File (fileBlockSize)
@@ -95,7 +102,8 @@ data XFTPTransportRequest = XFTPTransportRequest
     request :: H.Request,
     sendResponse :: H.Response -> IO (),
     sniUsed :: SNICredentialUsed,
-    addCORS :: Bool
+    addCORS :: Bool,
+    clientAddrStats :: Maybe (AddrStats XFTPAddrCounter)
   }
 
 corsHeaders :: Bool -> [N.Header]
@@ -120,18 +128,22 @@ runXFTPServerBlocking :: FileStoreClass s => TMVar Bool -> XFTPServerConfig s ->
 runXFTPServerBlocking started cfg = newXFTPServerEnv cfg >>= runReaderT (xftpServer cfg started)
 
 data Handshake
-  = HandshakeSent C.PrivateKeyX25519
+  = HandshakeSent C.PrivateKeyX25519 EntitlementChecked
   | HandshakeAccepted (THandleParams XFTPVersion 'TServer)
 
+-- | the entitlement of the session is resolved once, however many handshakes it has
+data EntitlementChecked = EntNotChecked | EntChecked (Maybe SessionEntitlement)
+
 xftpServer :: forall s. FileStoreClass s => XFTPServerConfig s -> TMVar Bool -> M s ()
-xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration, xftpServerVRange} started = do
-  mapM_ (expireServerFiles Nothing) fileExpiration
+xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpiration, fileExpiration, xftpServerVRange, information} started = do
+  expireServerFiles Nothing fileExpiration
   restoreServerStats
   raceAny_
     ( runServer
-        : expireFilesThread_ cfg
-          <> serverStatsThread_ cfg
+        : expireFiles fileExpiration
+        : serverStatsThread_ cfg
           <> prometheusMetricsThread_ cfg
+          <> addressStatsThread_ cfg
           <> controlPortThread_ cfg
     )
     `finally` stopServer
@@ -145,20 +157,27 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
         Left e -> putStrLn ("Server has no valid key: " <> show e) >> exitFailure
       env <- ask
       sessions <- liftIO TM.emptyIO
+      sessionAddrStats <- liftIO TM.emptyIO
+      stats_ <- asks addrStats
       let cleanup sessionId = atomically $ TM.delete sessionId sessions
+          withConnection sock sessionId handler =
+            withAddrStats (addrStatsMap <$> stats_) sock $ \case
+              Just s -> (atomically (TM.insert sessionId s sessionAddrStats) >> handler) `finally` atomically (TM.delete sessionId sessionAddrStats)
+              Nothing -> handler
           srvParams = if isJust httpCreds_ then defaultSupportedParamsHTTPS else defaultSupportedParams
       webCanonicalRoot_ <- liftIO $ mapM canonicalizePath (webStaticPath cfg)
-      liftIO . runHTTP2Server started xftpPort defaultHTTP2BufferSize srvParams srvCreds httpCreds_ transportConfig inactiveClientExpiration cleanup $ \sniUsed sessionId sessionALPN r sendResponse -> do
+      liftIO . runHTTP2Server started xftpPort defaultHTTP2BufferSize srvParams srvCreds httpCreds_ transportConfig inactiveClientExpiration cleanup withConnection $ \sniUsed sessionId sessionALPN r sendResponse -> do
         let addCORS' = sniUsed && addCORSHeaders transportConfig
         case H.requestMethod r of
           Just "OPTIONS" | addCORS' -> sendResponse $ H.responseNoBody N.ok200 corsPreflightHeaders
           Just "GET" | sniUsed -> forM_ webCanonicalRoot_ $ \root -> serveStaticPageH2 root r sendResponse
           _ -> do
             reqBody <- getHTTP2Body r xftpBlockSize
+            clientAddrStats <- TM.lookupIO sessionId sessionAddrStats
             let v = VersionXFTP 1
                 thServerVRange = versionToRange v
                 thParams0 = THandleParams {sessionId, blockSize = xftpBlockSize, thVersion = v, thServerVRange, thAuth = Nothing, implySessId = False, encryptBlock = Nothing, serviceAuth = False, serverInfo = Nothing}
-                req0 = XFTPTransportRequest {thParams = thParams0, request = r, reqBody, sendResponse, sniUsed, addCORS = addCORS'}
+                req0 = XFTPTransportRequest {thParams = thParams0, request = r, reqBody, sendResponse, sniUsed, addCORS = addCORS', clientAddrStats}
             flip runReaderT env $ case sessionALPN of
               Nothing -> processRequest req0
               Just alpn
@@ -174,12 +193,12 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
         Nothing
           | sniUsed && not webHello -> throwE SESSION
           | otherwise -> processHello Nothing
-        Just (HandshakeSent pk)
+        Just (HandshakeSent pk ent_)
           | webHello -> processHello (Just pk)
-          | otherwise -> processClientHandshake pk
+          | otherwise -> processClientHandshake pk ent_
         Just (HandshakeAccepted thParams)
           | webHello -> processHello (serverPrivKey <$> thAuth thParams)
-          | webHandshake, Just auth <- thAuth thParams -> processClientHandshake (serverPrivKey auth)
+          | webHandshake, Just auth <- thAuth thParams -> processClientHandshake (serverPrivKey auth) (EntChecked $ peerEntitlement auth)
           | otherwise -> pure $ Just thParams
       either sendError pure r
       where
@@ -196,28 +215,35 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
               | otherwise -> throwE HANDSHAKE
           rng <- asks random
           k <- atomically $ TM.lookup sessionId sessions >>= \case
-            Just (HandshakeSent pk') -> pure $ C.publicKey pk'
-            _ -> do
+            Just (HandshakeSent pk' _) -> pure $ C.publicKey pk'
+            s' -> do
               kp <- maybe (C.generateKeyPair rng) (\p -> pure (C.publicKey p, p)) pk_
-              fst kp <$ TM.insert sessionId (HandshakeSent $ snd kp) sessions
+              let ent_ = case s' of
+                    Just (HandshakeAccepted thParams) -> EntChecked $ peerEntitlement =<< thAuth thParams
+                    _ -> EntNotChecked
+              fst kp <$ TM.insert sessionId (HandshakeSent (snd kp) ent_) sessions
           let authPubKey = CertChainPubKey chain (C.signX509 serverSignKey $ C.publicToX509 k)
               webIdentityProof = C.sign serverSignKey . (<> sessionId) <$> challenge_
-          let hs = XFTPServerHandshake {xftpVersionRange = xftpServerVRange, sessionId, authPubKey, webIdentityProof}
+              serverInfoBytes = LB.toStrict . J.encode <$> information
+          let hs = XFTPServerHandshake {xftpVersionRange = xftpServerVRange, sessionId, authPubKey, webIdentityProof, serverInfoBytes}
           shs <- encodeXftp hs
 #ifdef slow_servers
           lift randomDelay
 #endif
           liftIO . sendResponse $ H.responseBuilder N.ok200 (corsHeaders addCORS) shs
           pure Nothing
-        processClientHandshake pk = do
+        processClientHandshake pk ent_ = do
           unless (B.length bodyHead == xftpBlockSize) $ throwE HANDSHAKE
           body <- liftHS $ C.unPad bodyHead
-          XFTPClientHandshake {xftpVersion = v, keyHash} <- liftHS $ smpDecode body
+          XFTPClientHandshake {xftpVersion = v, keyHash, entitlementProof} <- liftHS $ smpDecode body
           kh <- asks serverIdentity
           unless (keyHash == kh) $ throwE HANDSHAKE
           case compatibleVRange' xftpServerVRange v of
             Just (Compatible vr) -> do
-              let auth = THAuthServer {serverPrivKey = pk, peerClientService = Nothing, sessSecret' = Nothing}
+              ent <- case ent_ of
+                EntChecked ent -> pure ent
+                EntNotChecked -> lift $ verifiedEntitlement entitlementProof
+              let auth = THAuthServer {serverPrivKey = pk, peerClientService = Nothing, peerEntitlement = ent, sessSecret' = Nothing}
                   thParams = thParams0 {thAuth = Just auth, thVersion = v, thServerVRange = vr}
               atomically $ TM.insert sessionId (HandshakeAccepted thParams) sessions
 #ifdef slow_servers
@@ -226,6 +252,19 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
               liftIO . sendResponse $ H.responseNoBody N.ok200 (corsHeaders addCORS)
               pure Nothing
             Nothing -> throwE HANDSHAKE
+        verifiedEntitlement :: Maybe EntitlementProof -> M s (Maybe SessionEntitlement)
+        verifiedEntitlement ep =
+          pure ep $>>= \proof@EntitlementProof {entitlement = Entitlement {entitlementName, expiresAt = expiresAtTs}} -> do
+            entCfg <- asks $ M.lookup entitlementName . fileStorageEntitlements . config
+            now <- liftIO getSystemSeconds
+            let expiresAt = RoundedSystemTime $ systemSeconds $ utcToSystemTime expiresAtTs
+            case entCfg of
+              Just cfg | entitlementValid now expiresAt -> do
+                keys <- asks $ entitlementKeys . config
+                liftIO (verifyEntitlement keys (BBSPresHeader sessionId) proof) >>= \case
+                  EVValid -> pure $ Just SessionEntitlement {expiresAt, entConfig = cfg}
+                  r -> Nothing <$ logError ("entitlement not verified: " <> tshow r)
+              _ -> pure Nothing
         sendError :: XFTPErrorType -> M s (Maybe (THandleParams XFTPVersion 'TServer))
         sendError err = do
           runExceptT (encodeXftp err) >>= \case
@@ -243,10 +282,6 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
       saveServerStats
       logNote "Server stopped"
 
-    expireFilesThread_ :: XFTPServerConfig s -> [M s ()]
-    expireFilesThread_ XFTPServerConfig {fileExpiration = Just fileExp} = [expireFiles fileExp]
-    expireFilesThread_ _ = []
-
     expireFiles :: ExpirationConfig -> M s ()
     expireFiles expCfg = do
       let interval = checkInterval expCfg * 1000000
@@ -305,24 +340,30 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
       [savePrometheusMetrics interval prometheusMetricsFile]
     prometheusMetricsThread_ _ = []
 
+    addressStatsThread_ :: XFTPServerConfig s -> [M s ()]
+    addressStatsThread_ XFTPServerConfig {addressStats = Just statsCfg} = [asks addrStats >>= mapM_ (liftIO . addressStatsThread statsCfg)]
+    addressStatsThread_ _ = []
+
     savePrometheusMetrics :: Int -> FilePath -> M s ()
     savePrometheusMetrics saveInterval metricsFile = do
       labelMyThread "savePrometheusMetrics"
       liftIO $ putStrLn $ "Prometheus metrics saved every " <> show saveInterval <> " seconds to " <> metricsFile
       ss <- asks serverStats
+      stats_ <- asks addrStats
       rtsOpts <- liftIO $ maybe ("set " <> rtsOptionsEnv) T.pack <$> lookupEnv (T.unpack rtsOptionsEnv)
       let interval = 1000000 * saveInterval
       liftIO $ forever $ do
         threadDelay interval
         ts <- getCurrentTime
-        sm <- getFileServerMetrics ss rtsOpts
+        sm <- getFileServerMetrics ss stats_ rtsOpts
         T.writeFile metricsFile $ xftpPrometheusMetrics sm ts
 
-    getFileServerMetrics :: FileServerStats -> T.Text -> IO FileServerMetrics
-    getFileServerMetrics ss rtsOptions = do
+    getFileServerMetrics :: FileServerStats -> Maybe (ServerAddrStats XFTPAddrCounter) -> T.Text -> IO FileServerMetrics
+    getFileServerMetrics ss stats_ rtsOptions = do
       d <- getFileServerStatsData ss
       let fd = periodStatDataCounts $ _filesDownloaded d
-      pure FileServerMetrics {statsData = d, filesDownloadedPeriods = fd, rtsOptions}
+      addressHistograms <- mapM (readIORef . addrHistograms) stats_
+      pure FileServerMetrics {statsData = d, filesDownloadedPeriods = fd, rtsOptions, addressHistograms}
 
     controlPortThread_ :: XFTPServerConfig s -> [M s ()]
     controlPortThread_ XFTPServerConfig {controlPort = Just port} = [runCPServer port]
@@ -377,7 +418,10 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
                   (fr, _) <- ExceptT $ liftIO $ getFile fs SFRecipient fileId
                   ExceptT $ blockServerFile fr info
                 liftIO . hPutStrLn h $ either (\e -> "error: " <> show e) (\() -> "ok") r
-              CPHelp -> hPutStrLn h "commands: stats-rts, delete, help, quit"
+              CPAddresses name n_ -> withUserRole $ do
+                stats_ <- unliftIO u $ asks addrStats
+                printTopAddresses h (addrStatsMap <$> stats_) name n_
+              CPHelp -> hPutStrLn h "commands: stats-rts, delete, addresses, help, quit"
               CPQuit -> pure ()
               CPSkip -> pure ()
               where
@@ -396,20 +440,23 @@ data ServerFile = ServerFile
   }
 
 processRequest :: FileStoreClass s => XFTPTransportRequest -> M s ()
-processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHead}, sendResponse, addCORS}
-  | B.length bodyHead /= xftpBlockSize = sendXFTPResponse ("", NoEntity, FRErr BLOCK) Nothing
+processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHead}, sendResponse, addCORS, clientAddrStats}
+  | B.length bodyHead /= xftpBlockSize = incAddrStats XACErrors >> sendXFTPResponse ("", NoEntity, FRErr BLOCK) Nothing
   | otherwise =
       case xftpDecodeTServer thParams bodyHead of
-        Right (Right t@(_, _, (corrId, fId, _))) -> do
+        Right (Right t@(_, _, (corrId, fId, cmd))) -> do
+          incAddrStats $ xftpCmdCounter cmd
           let THandleParams {thAuth} = thParams
+              ent = peerEntitlement =<< thAuth
           verifyXFTPTransmission thAuth t >>= \case
-            VRVerified req -> uncurry send =<< processXFTPRequest body req
-            VRFailed e -> send (FRErr e) Nothing
+            VRVerified req -> uncurry send =<< processXFTPRequest clientAddrStats ent body req
+            VRFailed e -> incAddrStats XACErrors >> send (FRErr e) Nothing
           where
             send resp = sendXFTPResponse (corrId, fId, resp)
-        Right (Left (corrId, fId, e)) -> sendXFTPResponse (corrId, fId, FRErr e) Nothing
-        Left e -> sendXFTPResponse ("", NoEntity, FRErr e) Nothing
+        Right (Left (corrId, fId, e)) -> incAddrStats XACErrors >> sendXFTPResponse (corrId, fId, FRErr e) Nothing
+        Left e -> incAddrStats XACErrors >> sendXFTPResponse ("", NoEntity, FRErr e) Nothing
   where
+    incAddrStats c = liftIO $ forM_ clientAddrStats (`incAddrCounter` c)
     sendXFTPResponse t' serverFile_ = do
       let t_ = xftpEncodeTransmission thParams t'
 #ifdef slow_servers
@@ -443,7 +490,7 @@ data VerificationResult = VRVerified XFTPRequest | VRFailed XFTPErrorType
 verifyXFTPTransmission :: forall s. FileStoreClass s => Maybe (THandleAuth 'TServer) -> SignedTransmission FileCmd -> M s VerificationResult
 verifyXFTPTransmission thAuth (tAuth, authorized, (corrId, fId, cmd)) =
   case cmd of
-    FileCmd SFSender (FNEW file rcps auth') -> pure $ XFTPReqNew file rcps auth' `verifyWith` sndKey file
+    FileCmd SFSender (FNEW file rcps auth' st) -> pure $ XFTPReqNew file rcps auth' st `verifyWith` sndKey file
     FileCmd SFRecipient PING -> pure $ VRVerified XFTPReqPing
     FileCmd party _ -> verifyCmd party
   where
@@ -464,9 +511,9 @@ verifyXFTPTransmission thAuth (tAuth, authorized, (corrId, fId, cmd)) =
     -- TODO verify with DH authorization
     req `verifyWith` k = if verifyCmdAuthorization thAuth tAuth authorized corrId k then VRVerified req else VRFailed AUTH
 
-processXFTPRequest :: forall s. FileStoreClass s => HTTP2Body -> XFTPRequest -> M s (FileResponse, Maybe ServerFile)
-processXFTPRequest HTTP2Body {bodyPart} = \case
-  XFTPReqNew file rks auth -> noFile =<< ifM allowNew (createFile file rks) (pure $ FRErr AUTH)
+processXFTPRequest :: forall s. FileStoreClass s => Maybe (AddrStats XFTPAddrCounter) -> Maybe SessionEntitlement -> HTTP2Body -> XFTPRequest -> M s (FileResponse, Maybe ServerFile)
+processXFTPRequest addrStats_ ent HTTP2Body {bodyPart} = \case
+  XFTPReqNew file rks auth storageHours -> noFile =<< ifM allowNew (createFile file rks storageHours) (pure $ FRErr AUTH)
     where
       allowNew = do
         XFTPServerConfig {allowNewFiles, newFileBasicAuth} <- asks config
@@ -483,29 +530,47 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
   XFTPReqPing -> noFile FRPong
   where
     noFile resp = pure (resp, Nothing)
-    createFile :: FileInfo -> NonEmpty RcvPublicAuthKey -> M s FileResponse
-    createFile file rks = do
+    addAddrStats :: XFTPAddrCounter -> Int -> M s ()
+    addAddrStats c n = liftIO $ forM_ addrStats_ $ \s -> addAddrCounter s c n
+    kilobytes :: Word32 -> Int
+    kilobytes bytes = (fromIntegral bytes + 1023) `div` 1024
+    createFile :: FileInfo -> NonEmpty RcvPublicAuthKey -> Maybe Word32 -> M s FileResponse
+    createFile file rks storageHours = do
       st <- asks fileStore
       r <- runExceptT $ do
         sizes <- asks $ allowedChunkSizes . config
         unless (size file `elem` sizes) $ throwE SIZE
-        ts <- liftIO getFileTime
+        now <- liftIO getSystemSeconds
+        maxSeconds <- lift $ storageMaxSeconds now
+        let nowSeconds = roundedSeconds now
+            ts = RoundedSystemTime $ (nowSeconds `div` fileTimePrecision) * fileTimePrecision
+            secs = case storageHours of
+              Just hours | hours > 0 -> min maxSeconds (fromIntegral hours * 3600)
+              _ -> maxSeconds
+            fileExpiresAt = RoundedSystemTime $ ((nowSeconds + secs + fileTimePrecision - 1) `div` fileTimePrecision) * fileTimePrecision
         -- TODO validate body empty
-        sId <- ExceptT $ addFileRetry st file 3 ts
+        sId <- ExceptT $ addFileRetry st file 3 ts (Just fileExpiresAt)
         rcps <- mapM (ExceptT . addRecipientRetry st 3 sId) rks
         lift $ withFileLog $ \sl -> do
-          logAddFile sl sId file ts EntityActive
+          logAddFile sl sId file ts (Just fileExpiresAt) EntityActive
           logAddRecipients sl sId rcps
         stats <- asks serverStats
         lift $ incFileStat filesCreated
         liftIO $ atomicModifyIORef'_ (fileRecipients stats) (+ length rks)
+        lift $ addAddrStats XACRecipients $ length rks
         let rIds = L.map (\(FileRecipient rId _) -> rId) rcps
-        pure $ FRSndIds sId rIds
+        pure $ FRSndIds sId rIds (Just (GSTExpires (roundedSeconds fileExpiresAt)))
       pure $ either FRErr id r
-    addFileRetry :: s -> FileInfo -> Int -> RoundedFileTime -> M s (Either XFTPErrorType XFTPFileId)
-    addFileRetry st file n ts =
+    storageMaxSeconds :: SystemSeconds -> M s Int64
+    storageMaxSeconds now = do
+      defaultMax <- asks $ ttl . fileExpiration . config
+      pure $ case ent of
+        Just SessionEntitlement {expiresAt, entConfig} | entitlementValid now expiresAt -> max (storageTime entConfig) defaultMax
+        _ -> defaultMax
+    addFileRetry :: s -> FileInfo -> Int -> RoundedFileTime -> Maybe RoundedFileTime -> M s (Either XFTPErrorType XFTPFileId)
+    addFileRetry st file n ts expiresAt =
       retryAdd n $ \sId -> runExceptT $ do
-        ExceptT $ addFile st sId file ts EntityActive
+        ExceptT $ addFile st sId file ts expiresAt EntityActive
         pure sId
     addRecipientRetry :: s -> Int -> XFTPFileId -> RcvPublicAuthKey -> M s (Either XFTPErrorType FileRecipient)
     addRecipientRetry st n sId rpk =
@@ -528,6 +593,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
         lift $ withFileLog $ \sl -> logAddRecipients sl sId rcps
         stats <- asks serverStats
         liftIO $ atomicModifyIORef'_ (fileRecipients stats) (+ length rks)
+        lift $ addAddrStats XACRecipients $ length rks
         let rIds = L.map (\(FileRecipient rId _) -> rId) rcps
         pure $ FRRcvIds rIds
       pure $ either FRErr id r
@@ -566,6 +632,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
                     incFileStat filesUploaded
                     incFileStat filesCount
                     liftIO $ atomicModifyIORef'_ (filesSize stats) (+ fromIntegral size)
+                    addAddrStats XACUploadKb $ kilobytes size
                     pure FROk
                   Left _e -> do
                     us <- asks usedStorage
@@ -595,6 +662,7 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
                   stats <- asks serverStats
                   incFileStat fileDownloads
                   liftIO $ updatePeriodStats (filesDownloaded stats) senderId
+                  addAddrStats XACDownloadKb $ kilobytes size
                   pure (FRFile sDhKey cbNonce, Just ServerFile {filePath = path, fileSize = size, sbState})
                 _ -> pure (FRErr INTERNAL, Nothing)
         _ -> pure (FRErr NO_FILE, Nothing)
@@ -607,11 +675,12 @@ processXFTPRequest HTTP2Body {bodyPart} = \case
 
     ackFileReception :: RecipientId -> FileRec -> M s FileResponse
     ackFileReception rId fr = do
-      withFileLog (`logAckFile` rId)
-      st <- asks fileStore
-      liftIO $ deleteRecipient st rId fr
-      incFileStat fileDownloadAcks
-      pure FROk
+      pure $ FRErr $ CMD PROHIBITED
+      -- withFileLog (`logAckFile` rId)
+      -- st <- asks fileStore
+      -- liftIO $ deleteRecipient st rId fr
+      -- incFileStat fileDownloadAcks
+      -- pure FROk
 
 deleteServerFile_ :: FileStoreClass s => FileRec -> M s (Either XFTPErrorType ())
 deleteServerFile_ fr@FileRec {senderId} = do
@@ -640,24 +709,25 @@ deleteOrBlockServerFile_ FileRec {filePath, fileInfo} stat storeAction = runExce
       liftIO $ atomicModifyIORef'_ (filesCount stats) (subtract 1)
       liftIO $ atomicModifyIORef'_ (filesSize stats) (subtract $ fromIntegral $ size fileInfo)
 
-getFileTime :: IO RoundedFileTime
-getFileTime = getRoundedSystemTime
+entitlementValid :: SystemSeconds -> SystemSeconds -> Bool
+entitlementValid now expiresAt = roundedSeconds expiresAt + 86400 > roundedSeconds now
 
 expireServerFiles :: FileStoreClass s => Maybe Int -> ExpirationConfig -> M s ()
 expireServerFiles itemDelay expCfg = do
   st <- asks fileStore
   us <- asks usedStorage
   usedStart <- readTVarIO us
+  now <- liftIO getSystemSeconds
   old <- liftIO $ expireBeforeEpoch expCfg
   filesCount <- liftIO $ getFileCount st
   logNote $ "Expiration check: " <> tshow filesCount <> " files"
-  expireLoop st us old
+  expireLoop st us now old
   usedEnd <- readTVarIO us
   logNote $ "Used " <> mbs usedStart <> " -> " <> mbs usedEnd <> ", " <> mbs (usedStart - usedEnd) <> " reclaimed."
   where
     mbs bs = tshow (bs `div` 1048576) <> "mb"
-    expireLoop st us old = do
-      expired <- liftIO $ expiredFiles st old 10000
+    expireLoop st us now old = do
+      expired <- liftIO $ expiredFiles st now old 10000
       forM_ expired $ \(sId, filePath_, fileSize) -> do
         mapM_ threadDelay itemDelay
         forM_ filePath_ $ \fp ->
@@ -670,7 +740,7 @@ expireServerFiles itemDelay expCfg = do
       unless (null sIds) $ do
         withFileLog $ \sl -> mapM_ (logDeleteFile sl) sIds
         liftIO $ deleteFiles st sIds
-        expireLoop st us old
+        expireLoop st us now old
 
 randomId :: Int -> M s ByteString
 randomId n = atomically . C.randomBytes n =<< asks random

src/Simplex/FileTransfer/Server/Control.hs

@@ -7,15 +7,18 @@ module Simplex.FileTransfer.Server.Control
 where
 
 import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.Text (Text)
 import Simplex.FileTransfer.Protocol (XFTPFileId)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (BasicAuth, BlockingInfo)
+import Simplex.Messaging.Server.AddressStats (addressesArgs, addressesArgsP)
 
 data ControlProtocol
   = CPAuth BasicAuth
   | CPStatsRTS
   | CPDelete XFTPFileId
   | CPBlock XFTPFileId BlockingInfo
+  | CPAddresses Text (Maybe Int)
   | CPHelp
   | CPQuit
   | CPSkip
@@ -26,6 +29,7 @@ instance StrEncoding ControlProtocol where
     CPStatsRTS -> "stats-rts"
     CPDelete fId -> strEncode (Str "delete", fId)
     CPBlock fId info -> strEncode (Str "block", fId, info)
+    CPAddresses name n_ -> "addresses " <> addressesArgs name n_
     CPHelp -> "help"
     CPQuit -> "quit"
     CPSkip -> ""
@@ -35,6 +39,7 @@ instance StrEncoding ControlProtocol where
       "stats-rts" -> pure CPStatsRTS
       "delete" -> CPDelete <$> _strP
       "block" -> CPBlock <$> _strP <*> _strP
+      "addresses" -> uncurry CPAddresses <$> addressesArgsP
       "help" -> pure CPHelp
       "quit" -> pure CPQuit
       "" -> pure CPSkip

src/Simplex/FileTransfer/Server/Env.hs

@@ -16,6 +16,8 @@ module Simplex.FileTransfer.Server.Env
     XFTPStoreConfig (..),
     XFTPEnv (..),
     XFTPRequest (..),
+    XFTPAddrCounter (..),
+    xftpCmdCounter,
     XFTPStoreType,
     FileStore (..),
     AFStoreType (..),
@@ -37,12 +39,15 @@ import Control.Monad
 import Crypto.Random
 import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import Data.Text (Text)
 import Data.Time.Clock (getCurrentTime)
-import Data.Word (Word32)
+import Data.Word (Word16, Word32)
 import Data.X509.Validation (Fingerprint (..))
 import Network.Socket
 import qualified Network.TLS as T
-import Simplex.FileTransfer.Protocol (FileCmd, FileInfo (..), XFTPFileId)
+import Simplex.FileTransfer.Protocol (FileCmd (..), FileCommand (..), FileInfo (..), XFTPFileId)
 import Simplex.FileTransfer.Server.Stats
 import Data.Either (fromRight)
 import Data.Ini (Ini, lookupValue)
@@ -62,8 +67,12 @@ import System.Directory (doesFileExist)
 import Simplex.FileTransfer.Server.StoreLog
 import Simplex.FileTransfer.Transport (VersionRangeXFTP)
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.BBS (BBSPublicKey)
 import Simplex.Messaging.Protocol (BasicAuth, RcvPublicAuthKey)
+import Simplex.Messaging.Server.AddressStats (AddrCounter (..), AddressStatsConfig, ServerAddrStats, countBounds, kilobyteBounds, newServerAddrStats)
 import Simplex.Messaging.Server.Expiration
+import Simplex.Messaging.Server.Information (ServerPublicInfo)
+import Simplex.Messaging.Transport (EntitlementConfig (..))
 import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), loadFingerprint, loadServerCredential)
 import Simplex.Messaging.Util (tshow)
 import System.IO (IOMode (..))
@@ -88,7 +97,10 @@ data XFTPServerConfig s = XFTPServerConfig
     controlPortUserAuth :: Maybe BasicAuth,
     controlPortAdminAuth :: Maybe BasicAuth,
     -- | time after which the files can be removed and check interval, seconds
-    fileExpiration :: Maybe ExpirationConfig,
+    fileExpiration :: ExpirationConfig,
+    -- | what each entitlement name grants
+    fileStorageEntitlements :: Map Text EntitlementConfig,
+    entitlementKeys :: Map Word16 BBSPublicKey,
     -- | timeout to receive file
     fileTimeout :: Int,
     -- | time after which inactive clients can be disconnected and check interval, seconds
@@ -97,6 +109,8 @@ data XFTPServerConfig s = XFTPServerConfig
     httpCredentials :: Maybe ServerCredentials,
     -- | XFTP client-server protocol version range
     xftpServerVRange :: VersionRangeXFTP,
+    -- | server public information sent in handshake and used to generate static mini-site
+    information :: Maybe ServerPublicInfo,
     -- stats config - see SMP server config
     logStatsInterval :: Maybe Int64,
     logStatsStartTime :: Int64,
@@ -104,6 +118,7 @@ data XFTPServerConfig s = XFTPServerConfig
     serverStatsBackupFile :: Maybe FilePath,
     prometheusInterval :: Maybe Int,
     prometheusMetricsFile :: FilePath,
+    addressStats :: Maybe AddressStatsConfig,
     transportConfig :: TransportServerConfig,
     responseDelay :: Int,
     webStaticPath :: Maybe FilePath
@@ -125,9 +140,55 @@ data XFTPEnv s = XFTPEnv
     serverIdentity :: C.KeyHash,
     tlsServerCreds :: T.Credential,
     httpServerCreds :: Maybe T.Credential,
-    serverStats :: FileServerStats
+    serverStats :: FileServerStats,
+    addrStats :: Maybe (ServerAddrStats XFTPAddrCounter)
   }
 
+data XFTPAddrCounter
+  = XACConnections
+  | XACErrors
+  | XACFNew
+  | XACFAdd
+  | XACFPut
+  | XACFDel
+  | XACFGet
+  | XACFAck
+  | XACPing
+  | XACUploadKb
+  | XACDownloadKb
+  | XACRecipients
+  deriving (Eq, Ord, Enum, Bounded, Show)
+
+instance AddrCounter XFTPAddrCounter where
+  counterName = \case
+    XACConnections -> "connections"
+    XACErrors -> "errors"
+    XACFNew -> "FNEW"
+    XACFAdd -> "FADD"
+    XACFPut -> "FPUT"
+    XACFDel -> "FDEL"
+    XACFGet -> "FGET"
+    XACFAck -> "FACK"
+    XACPing -> "PING"
+    XACUploadKb -> "upload_kb"
+    XACDownloadKb -> "download_kb"
+    XACRecipients -> "recipients"
+  counterBounds = \case
+    XACUploadKb -> kilobyteBounds
+    XACDownloadKb -> kilobyteBounds
+    _ -> countBounds
+  connectionsCounter = XACConnections
+
+xftpCmdCounter :: FileCmd -> XFTPAddrCounter
+xftpCmdCounter (FileCmd _ cmd) = case cmd of
+  FNEW {} -> XACFNew
+  FADD _ -> XACFAdd
+  FPUT -> XACFPut
+  FDEL -> XACFDel
+  FGET _ -> XACFGet
+  FACK -> XACFAck
+  PING -> XACPing
+
 fileStore :: XFTPEnv s -> s
 fileStore = fromFileStore . store
 {-# INLINE fileStore #-}
@@ -171,7 +232,13 @@ defaultFileExpiration =
     }
 
 newXFTPServerEnv :: FileStoreClass s => XFTPServerConfig s -> IO (XFTPEnv s)
-newXFTPServerEnv config@XFTPServerConfig {serverStoreCfg, fileSizeQuota, xftpCredentials, httpCredentials} = do
+newXFTPServerEnv config@XFTPServerConfig {serverStoreCfg, fileSizeQuota, fileExpiration, fileStorageEntitlements, xftpCredentials, httpCredentials, addressStats} = do
+  let defaultMax = ttl fileExpiration
+      belowDefault = M.filter ((< defaultMax) . storageTime) fileStorageEntitlements
+  unless (M.null belowDefault) $ do
+    forM_ (M.assocs belowDefault) $ \(name, EntitlementConfig {storageTime}) ->
+      logError $ "expire_files_hours_for_" <> name <> " is " <> tshow (storageTime `div` 3600) <> " hours, below expire_files_hours " <> tshow (defaultMax `div` 3600) <> " hours, server not started"
+    exitFailure
   random <- C.newRandom
   (store, storeLog) <- case serverStoreCfg of
     XSCMemory storeLogPath -> do
@@ -193,10 +260,11 @@ newXFTPServerEnv config@XFTPServerConfig {serverStoreCfg, fileSizeQuota, xftpCre
   httpServerCreds <- mapM loadServerCredential httpCredentials
   Fingerprint fp <- loadFingerprint xftpCredentials
   serverStats <- newFileServerStats =<< getCurrentTime
-  pure XFTPEnv {config, store, usedStorage, storeLog, random, tlsServerCreds, httpServerCreds, serverIdentity = C.KeyHash fp, serverStats}
+  addrStats <- mapM (const newServerAddrStats) addressStats
+  pure XFTPEnv {config, store, usedStorage, storeLog, random, tlsServerCreds, httpServerCreds, serverIdentity = C.KeyHash fp, serverStats, addrStats}
 
 data XFTPRequest
-  = XFTPReqNew FileInfo (NonEmpty RcvPublicAuthKey) (Maybe BasicAuth)
+  = XFTPReqNew FileInfo (NonEmpty RcvPublicAuthKey) (Maybe BasicAuth) (Maybe Word32)
   | XFTPReqCmd XFTPFileId FileRec FileCmd
   | XFTPReqPing
 

src/Simplex/FileTransfer/Server/Main.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Simplex.FileTransfer.Server.Main
@@ -13,14 +14,16 @@ module Simplex.FileTransfer.Server.Main
     xftpServerCLI_,
   ) where
 
-import Control.Monad (unless, when)
+import Control.Monad (forM_, unless, when)
 import Data.Either (fromRight)
 import Data.Functor (($>))
-import Data.Ini (lookupValue, readIniFile)
+import Data.Ini (Ini, lookupValue, readIniFile)
 import Data.Int (Int64)
 import Data.List (find)
 import qualified Data.List.NonEmpty as L
-import Data.Maybe (fromMaybe, isJust)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import Data.Maybe (fromMaybe, isJust, mapMaybe)
 import Data.Text.Encoding (encodeUtf8)
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
@@ -32,6 +35,7 @@ import Simplex.FileTransfer.Server (runXFTPServer)
 import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), XFTPStoreConfig, AFStoreType (..), defFileExpirationHours, defaultFileExpiration, defaultInactiveClientExpiration, readFileStoreType, runWithStoreConfig, checkFileStoreMode, importToDatabase, exportFromDatabase)
 import Simplex.FileTransfer.Transport (alpnSupportedXFTPhandshakes, supportedFileServerVRange)
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.Entitlement (entitlementIssuerKeys)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern XFTPServer)
 import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
@@ -40,6 +44,7 @@ import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.Information (ServerPublicInfo (..))
 import Simplex.Messaging.Server.Main (serverPublicInfo, printSourceCode)
 import Simplex.Messaging.Server.Web (EmbeddedWebParams (..), WebHttpsParams (..))
+import Simplex.Messaging.Transport (EntitlementConfig (..))
 import Simplex.Messaging.Transport.Client (TransportHost (..))
 import Simplex.Messaging.Transport.HTTP2 (httpALPN)
 import Simplex.Messaging.Transport.Server (ServerCredentials (..), TransportServerConfig (..), mkTransportServerConfig)
@@ -155,8 +160,14 @@ xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do
                \# db_pool_size = 10\n\n\
                \# Write database changes to store log file\n\
                \# db_store_log = off\n\n"
-            <> "# Expire files after the specified number of hours.\n"
+            <> "# Expire files after the specified number of hours.\n\
+               \# The change only affects new files.\n"
             <> ("expire_files_hours = " <> tshow defFileExpirationHours <> "\n\n")
+            <> "# Expire files after the specified number of hours for the senders that present\n\
+               \# a proof of the entitlement. Must not be below expire_files_hours.\n\
+               \# The change only affects new files.\n\
+               \# expire_files_hours_for_supporter = 168\n\
+               \# expire_files_hours_for_legend = 504\n\n"
             <> "log_stats = off\n\
                \\n\
                \# Log interval for real-time Prometheus metrics\n\
@@ -193,6 +204,8 @@ xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do
                \disconnect = off\n"
             <> ("# ttl = " <> tshow (ttl defaultInactiveClientExpiration) <> "\n")
             <> ("# check_interval = " <> tshow (checkInterval defaultInactiveClientExpiration) <> "\n")
+            <> "\n"
+            <> addressStatsIniContent
             <> "\n\
                \[WEB]\n\
                \# Set path to generate static mini-site for server information\n"
@@ -235,13 +248,13 @@ xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do
         enableStoreLog = settingIsOn "STORE_LOG" "enable" ini
         logStats = settingIsOn "STORE_LOG" "log_stats" ini
         c = combine cfgPath . ($ defaultX509Config)
-        printXFTPConfig XFTPServerConfig {allowNewFiles, newFileBasicAuth, xftpPort, storeLogFile, fileExpiration, inactiveClientExpiration} = do
+        printXFTPConfig XFTPServerConfig {allowNewFiles, newFileBasicAuth, xftpPort, storeLogFile, fileExpiration, fileStorageEntitlements, inactiveClientExpiration} = do
           putStrLn $ case storeLogFile of
             Just f -> "Store log: " <> f
             _ -> "Store log disabled."
-          putStrLn $ case fileExpiration of
-            Just ExpirationConfig {ttl} -> "expiring files after " <> showTTL ttl
-            _ -> "not expiring files"
+          putStrLn $ "expiring files after " <> showTTL (ttl fileExpiration)
+          forM_ (M.assocs fileStorageEntitlements) $ \(name, EntitlementConfig {storageTime}) ->
+            putStrLn $ "expiring files of " <> T.unpack name <> " after " <> showTTL storageTime
           putStrLn $ case inactiveClientExpiration of
             Just ExpirationConfig {ttl, checkInterval} -> "expiring clients inactive for " <> show ttl <> " seconds every " <> show checkInterval <> " seconds"
             _ -> "not expiring inactive clients"
@@ -287,10 +300,11 @@ xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do
               controlPortAdminAuth = either error id <$> strDecodeIni "AUTH" "control_port_admin_password" ini,
               controlPortUserAuth = either error id <$> strDecodeIni "AUTH" "control_port_user_password" ini,
               fileExpiration =
-                Just
-                  defaultFileExpiration
-                    { ttl = 3600 * readIniDefault defFileExpirationHours "STORE_LOG" "expire_files_hours" ini
-                    },
+                defaultFileExpiration
+                  { ttl = 3600 * readIniDefault defFileExpirationHours "STORE_LOG" "expire_files_hours" ini
+                  },
+              fileStorageEntitlements = iniEntitlements ini,
+              entitlementKeys = entitlementIssuerKeys,
               fileTimeout = 5 * 60 * 1000000, -- 5 mins to send 4mb chunk
               inactiveClientExpiration =
                 settingIsOn "INACTIVE_CLIENTS" "disconnect" ini
@@ -306,12 +320,14 @@ xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do
                   },
               httpCredentials = httpCredentials_,
               xftpServerVRange = supportedFileServerVRange,
+              information = serverPublicInfo ini,
               logStatsInterval = logStats $> 86400, -- seconds
               logStatsStartTime = 0, -- seconds from 00:00 UTC
               serverStatsLogFile = combine logPath "file-server-stats.daily.log",
               serverStatsBackupFile = logStats $> combine logPath "file-server-stats.log",
               prometheusInterval = eitherToMaybe (lookupValue "STORE_LOG" "prometheus_interval" ini) >>= readMaybe . T.unpack,
               prometheusMetricsFile = combine logPath "xftp-server-metrics.txt",
+              addressStats = iniAddressStats ini,
               transportConfig =
                 let cfg =
                       mkTransportServerConfig
@@ -437,3 +453,10 @@ cliCommandP cfgPath logPath iniFile =
         ( command "import" (info (pure SCImport) (progDesc "Import store log file into PostgreSQL database"))
             <> command "export" (info (pure SCExport) (progDesc "Export PostgreSQL database to store log file"))
         )
+
+iniEntitlements :: Ini -> Map T.Text EntitlementConfig
+iniEntitlements ini =
+  M.fromList $ mapMaybe readEntitlement [("supporter", "expire_files_hours_for_supporter"), ("legend", "expire_files_hours_for_legend")]
+  where
+    readEntitlement (name, key) = (name,) . EntitlementConfig . parseHours key <$> eitherToMaybe (lookupValue "STORE_LOG" key ini)
+    parseHours key t = maybe (error $ "Error: invalid " <> T.unpack key <> " value: " <> T.unpack t) (3600 *) (readMaybe (T.unpack (T.strip t)) :: Maybe Int64)

src/Simplex/FileTransfer/Server/Prometheus.hs

@@ -11,12 +11,15 @@ module Simplex.FileTransfer.Server.Prometheus
   ) where
 
 import Data.Int (Int64)
+import Data.Map.Strict (Map)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time.Clock (UTCTime (..), diffUTCTime)
 import Data.Time.Clock.System (systemEpochDay)
 import Data.Time.Format.ISO8601 (iso8601Show)
+import Simplex.FileTransfer.Server.Env (XFTPAddrCounter)
 import Simplex.FileTransfer.Server.Stats
+import Simplex.Messaging.Server.AddressStats (AddrHistogram, addrHistogramMetrics)
 import Simplex.Messaging.Server.Stats (PeriodStatCounts (..))
 import Simplex.Messaging.Transport (simplexMQVersion)
 import Simplex.Messaging.Util (tshow)
@@ -24,7 +27,8 @@ import Simplex.Messaging.Util (tshow)
 data FileServerMetrics = FileServerMetrics
   { statsData :: FileServerStatsData,
     filesDownloadedPeriods :: PeriodStatCounts,
-    rtsOptions :: Text
+    rtsOptions :: Text,
+    addressHistograms :: Maybe (Map XFTPAddrCounter AddrHistogram)
   }
 
 rtsOptionsEnv :: Text
@@ -33,9 +37,9 @@ rtsOptionsEnv = "XFTP_RTS_OPTIONS"
 {-# FOURMOLU_DISABLE\n#-}
 xftpPrometheusMetrics :: FileServerMetrics -> UTCTime -> Text
 xftpPrometheusMetrics sm ts =
-  time <> files <> info
+  time <> files <> clientAddresses <> info
   where
-    FileServerMetrics {statsData, filesDownloadedPeriods, rtsOptions} = sm
+    FileServerMetrics {statsData, filesDownloadedPeriods, rtsOptions, addressHistograms} = sm
     FileServerStatsData
       { _fromTime,
         _filesCreated,
@@ -122,6 +126,7 @@ xftpPrometheusMetrics sm ts =
       \simplex_xftp_files_count_monthly " <> mstr (monthCount filesDownloadedPeriods) <> "\n\
       \# filesDownloaded.monthCount\n\
       \\n"
+    clientAddresses = maybe "" (addrHistogramMetrics "simplex_xftp" tsEpoch) addressHistograms
     info =
       "# Info\n\
       \# ----\n\

src/Simplex/FileTransfer/Server/Store.hs

@@ -55,6 +55,7 @@ data FileRec = FileRec
     filePath :: TVar (Maybe FilePath),
     recipientIds :: TVar (Set RecipientId),
     createdAt :: RoundedFileTime,
+    expiresAt :: Maybe RoundedFileTime,
     fileStatus :: TVar ServerEntityStatus
   }
 
@@ -74,7 +75,7 @@ class FileStoreClass s where
   type FileStoreConfig s
   newFileStore :: FileStoreConfig s -> IO s
   closeFileStore :: s -> IO ()
-  addFile :: s -> SenderId -> FileInfo -> RoundedFileTime -> ServerEntityStatus -> IO (Either XFTPErrorType ())
+  addFile :: s -> SenderId -> FileInfo -> RoundedFileTime -> Maybe RoundedFileTime -> ServerEntityStatus -> IO (Either XFTPErrorType ())
   setFilePath :: s -> SenderId -> FilePath -> IO (Either XFTPErrorType ())
   addRecipient :: s -> SenderId -> FileRecipient -> IO (Either XFTPErrorType ())
   deleteFile :: s -> SenderId -> IO (Either XFTPErrorType ())
@@ -84,7 +85,7 @@ class FileStoreClass s where
   deleteRecipient :: s -> RecipientId -> FileRec -> IO ()
   getFile :: s -> SFileParty p -> XFTPFileId -> IO (Either XFTPErrorType (FileRec, C.APublicAuthKey))
   ackFile :: s -> RecipientId -> IO (Either XFTPErrorType ())
-  expiredFiles :: s -> Int64 -> Int -> IO [(SenderId, Maybe FilePath, Word32)]
+  expiredFiles :: s -> SystemSeconds -> Int64 -> Int -> IO [(SenderId, Maybe FilePath, Word32)]
   getUsedStorage :: s -> IO Int64
   getFileCount :: s -> IO Int
 
@@ -107,9 +108,9 @@ instance FileStoreClass STMFileStore where
 
   closeFileStore STMFileStore {stmStoreLog} = readTVarIO stmStoreLog >>= mapM_ closeStoreLog
 
-  addFile STMFileStore {files} sId fileInfo createdAt status = atomically $
+  addFile STMFileStore {files} sId fileInfo createdAt expiresAt status = atomically $
     ifM (TM.member sId files) (pure $ Left DUPLICATE_) $ do
-      f <- newFileRec sId fileInfo createdAt status
+      f <- newFileRec sId fileInfo createdAt expiresAt status
       TM.insert sId f files
       pure $ Right ()
 
@@ -166,14 +167,17 @@ instance FileStoreClass STMFileStore where
           pure $ Right ()
       _ -> pure $ Left AUTH
 
-  expiredFiles STMFileStore {files} old _limit = do
+  expiredFiles STMFileStore {files} now old _limit = do
     fs <- readTVarIO files
-    fmap catMaybes . forM (M.toList fs) $ \(sId, FileRec {fileInfo = FileInfo {size}, filePath, createdAt = RoundedSystemTime createdAt}) ->
-      if createdAt + fileTimePrecision < old
-        then do
-          path <- readTVarIO filePath
-          pure $ Just (sId, path, size)
-        else pure Nothing
+    fmap catMaybes . forM (M.toList fs) $ \(sId, FileRec {fileInfo = FileInfo {size}, filePath, createdAt = RoundedSystemTime createdAt, expiresAt}) ->
+      let expired = case expiresAt of
+            Just e -> roundedSeconds e < roundedSeconds now
+            Nothing -> createdAt + fileTimePrecision < old
+       in if expired
+            then do
+              path <- readTVarIO filePath
+              pure $ Just (sId, path, size)
+            else pure Nothing
 
   getUsedStorage STMFileStore {files} = foldM addSize 0 =<< readTVarIO files
     where
@@ -184,12 +188,12 @@ instance FileStoreClass STMFileStore where
 
 -- Internal STM helpers
 
-newFileRec :: SenderId -> FileInfo -> RoundedFileTime -> ServerEntityStatus -> STM FileRec
-newFileRec senderId fileInfo createdAt status = do
+newFileRec :: SenderId -> FileInfo -> RoundedFileTime -> Maybe RoundedFileTime -> ServerEntityStatus -> STM FileRec
+newFileRec senderId fileInfo createdAt expiresAt status = do
   recipientIds <- newTVar S.empty
   filePath <- newTVar Nothing
   fileStatus <- newTVar status
-  pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, fileStatus}
+  pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, expiresAt, fileStatus}
 
 withFile :: STMFileStore -> SenderId -> (FileRec -> STM (Either XFTPErrorType a)) -> STM (Either XFTPErrorType a)
 withFile STMFileStore {files} sId a =

src/Simplex/FileTransfer/Server/Store/Postgres.hs

@@ -55,6 +55,7 @@ import Simplex.Messaging.Transport (EntityId (..))
 import Simplex.Messaging.Server.QueueStore (ServerEntityStatus (..))
 import Simplex.Messaging.Server.QueueStore.Postgres ()
 import Simplex.Messaging.Server.StoreLog (openWriteStoreLog)
+import Simplex.Messaging.SystemTime (roundedSeconds)
 import Simplex.Messaging.Util (firstRow, tshow)
 import System.Directory (renameFile)
 import System.Exit (exitFailure)
@@ -82,17 +83,17 @@ instance FileStoreClass PostgresFileStore where
     closeDBStore dbStore
     mapM_ closeStoreLog dbStoreLog
 
-  addFile st sId fileInfo@FileInfo {sndKey, size, digest} createdAt status =
+  addFile st sId fileInfo@FileInfo {sndKey, size, digest} createdAt expiresAt status =
     E.uninterruptibleMask_ $ runExceptT $ do
       void $ withDB "addFile" st $ \db ->
         E.try
           ( DB.execute
               db
-              "INSERT INTO files (sender_id, file_size, file_digest, sender_key, created_at, status) VALUES (?,?,?,?,?,?)"
-              (sId, (fromIntegral size :: Int32), Binary digest, Binary (C.encodePubKey sndKey), createdAt, status)
+              "INSERT INTO files (sender_id, file_size, file_digest, sender_key, created_at, expires_at, status) VALUES (?,?,?,?,?,?,?)"
+              (sId, (fromIntegral size :: Int32), Binary digest, Binary (C.encodePubKey sndKey), createdAt, expiresAt, status)
           )
           >>= either handleDuplicate (pure . Right)
-      withLog "addFile" st $ \s -> logAddFile s sId fileInfo createdAt status
+      withLog "addFile" st $ \s -> logAddFile s sId fileInfo createdAt expiresAt status
 
   setFilePath st sId fPath = E.uninterruptibleMask_ $ runExceptT $ do
     assertUpdated $ withDB' "setFilePath" st $ \db ->
@@ -131,13 +132,13 @@ instance FileStoreClass PostgresFileStore where
 
   getFile st party fId = runExceptT $ case party of
     SFSender -> do
-      row <- loadFileRow "SELECT sender_id, file_size, file_digest, sender_key, file_path, created_at, status FROM files WHERE sender_id = ?"
+      row <- loadFileRow "SELECT sender_id, file_size, file_digest, sender_key, file_path, created_at, expires_at, status FROM files WHERE sender_id = ?"
       fr <- ExceptT $ rowToFileRec row
       pure (fr, sndKey (fileInfo fr))
     SFRecipient -> do
       row :. Only rcpKeyBs <-
         loadFileRow
-          "SELECT f.sender_id, f.file_size, f.file_digest, f.sender_key, f.file_path, f.created_at, f.status, r.recipient_key FROM files f JOIN recipients r ON r.sender_id = f.sender_id WHERE r.recipient_id = ?"
+          "SELECT f.sender_id, f.file_size, f.file_digest, f.sender_key, f.file_path, f.created_at, f.expires_at, f.status, r.recipient_key FROM files f JOIN recipients r ON r.sender_id = f.sender_id WHERE r.recipient_id = ?"
       fr <- ExceptT $ rowToFileRec row
       rcpKey <- either (const $ throwE INTERNAL) pure $ C.decodePubKey rcpKeyBs
       pure (fr, rcpKey)
@@ -152,12 +153,12 @@ instance FileStoreClass PostgresFileStore where
       DB.execute db "DELETE FROM recipients WHERE recipient_id = ?" (Only rId)
     withLog "ackFile" st $ \s -> logAckFile s rId
 
-  expiredFiles st old limit =
+  expiredFiles st now old limit =
     fmap toResult $ withTransaction (dbStore st) $ \db ->
       DB.query
         db
-        "SELECT sender_id, file_path, file_size FROM files WHERE created_at + ? < ? ORDER BY created_at LIMIT ?"
-        (fileTimePrecision, old, limit)
+        "(SELECT sender_id, file_path, file_size FROM files WHERE expires_at < ? LIMIT ?) UNION ALL (SELECT sender_id, file_path, file_size FROM files WHERE expires_at IS NULL AND created_at < ? LIMIT ?)"
+        (roundedSeconds now, limit, old - fileTimePrecision, limit)
     where
       toResult :: [(SenderId, Maybe FilePath, Int32)] -> [(SenderId, Maybe FilePath, Word32)]
       toResult = map (\(sId, path, size) -> (sId, path, fromIntegral size))
@@ -174,21 +175,21 @@ instance FileStoreClass PostgresFileStore where
 
 -- Internal helpers
 
-mkFileRec :: SenderId -> FileInfo -> Maybe FilePath -> RoundedFileTime -> ServerEntityStatus -> IO FileRec
-mkFileRec senderId fileInfo path createdAt status = do
+mkFileRec :: SenderId -> FileInfo -> Maybe FilePath -> RoundedFileTime -> Maybe RoundedFileTime -> ServerEntityStatus -> IO FileRec
+mkFileRec senderId fileInfo path createdAt expiresAt status = do
   filePath <- newTVarIO path
   recipientIds <- newTVarIO S.empty
   fileStatus <- newTVarIO status
-  pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, fileStatus}
+  pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, expiresAt, fileStatus}
 
-type FileRecRow = (SenderId, Int32, ByteString, ByteString, Maybe FilePath, RoundedFileTime, ServerEntityStatus)
+type FileRecRow = (SenderId, Int32, ByteString, ByteString, Maybe FilePath, RoundedFileTime, Maybe RoundedFileTime, ServerEntityStatus)
 
 rowToFileRec :: FileRecRow -> IO (Either XFTPErrorType FileRec)
-rowToFileRec (sId, size, digest, sndKeyBs, path, createdAt, status) =
+rowToFileRec (sId, size, digest, sndKeyBs, path, createdAt, expiresAt, status) =
   case C.decodePubKey sndKeyBs of
     Right sndKey -> do
       let fileInfo = FileInfo {sndKey, size = fromIntegral size, digest}
-      Right <$> mkFileRec sId fileInfo path createdAt status
+      Right <$> mkFileRec sId fileInfo path createdAt expiresAt status
     Left _ -> pure $ Left INTERNAL
 
 -- DB helpers
@@ -243,7 +244,7 @@ importFileStore storeLogFilePath dbCfg = do
   fCnt <- withTransaction (dbStore pgStore) $ \db -> do
     DB.copy_
       db
-      "COPY files (sender_id, file_size, file_digest, sender_key, file_path, created_at, status) FROM STDIN WITH (FORMAT csv)"
+      "COPY files (sender_id, file_size, file_digest, sender_key, file_path, created_at, expires_at, status) FROM STDIN WITH (FORMAT csv)"
     iforM_ (M.toList allFiles) $ \i (sId, fr) -> do
       DB.putCopyData db =<< fileRecToCSV sId fr
       when (i > 0 && i `mod` 10000 == 0) $ putStr ("  " <> show i <> " files\r") >> hFlush stdout
@@ -282,13 +283,13 @@ exportFileStore storeLogFilePath dbCfg = do
   !fCnt <- withTransaction (dbStore pgStore) $ \db ->
     DB.fold_
       db
-      "SELECT sender_id, file_size, file_digest, sender_key, file_path, created_at, status FROM files ORDER BY created_at"
+      "SELECT sender_id, file_size, file_digest, sender_key, file_path, created_at, expires_at, status FROM files ORDER BY created_at"
       (0 :: Int)
-      ( \(!fc) (sId, size :: Int32, digest :: ByteString, sndKeyBs :: ByteString, path :: Maybe String, createdAt, status) ->
+      ( \(!fc) (sId, size :: Int32, digest :: ByteString, sndKeyBs :: ByteString, path :: Maybe String, createdAt, expiresAt, status) ->
           case C.decodePubKey sndKeyBs of
             Right sndKey -> do
               let fileInfo = FileInfo {sndKey, size = fromIntegral size, digest}
-              logAddFile sl sId fileInfo createdAt status
+              logAddFile sl sId fileInfo createdAt expiresAt status
               forM_ path $ logPutFile sl sId
               pure (fc + 1)
             Left _ -> do
@@ -326,7 +327,7 @@ iforM_ :: Monad m => [a] -> (Int -> a -> m ()) -> m ()
 iforM_ xs f = zipWithM_ f [0 ..] xs
 
 fileRecToCSV :: SenderId -> FileRec -> IO ByteString
-fileRecToCSV sId FileRec {fileInfo = FileInfo {sndKey, size, digest}, filePath, createdAt, fileStatus} = do
+fileRecToCSV sId FileRec {fileInfo = FileInfo {sndKey, size, digest}, filePath, createdAt, expiresAt, fileStatus} = do
   path <- readTVarIO filePath
   status <- readTVarIO fileStatus
   pure $ LB.toStrict $ BB.toLazyByteString $ mconcat (BB.char7 ',' `intersperse` fields path status) <> BB.char7 '\n'
@@ -338,6 +339,7 @@ fileRecToCSV sId FileRec {fileInfo = FileInfo {sndKey, size, digest}, filePath,
         renderField (toField (Binary (C.encodePubKey sndKey))),
         nullable (toField <$> path),
         renderField (toField createdAt),
+        nullable (toField <$> expiresAt),
         quotedField (toField status)
       ]
 

src/Simplex/FileTransfer/Server/Store/Postgres/Migrations.hs

@@ -14,7 +14,8 @@ import Text.RawString.QQ (r)
 
 xftpSchemaMigrations :: [(String, Text, Maybe Text)]
 xftpSchemaMigrations =
-  [ ("20260325_initial", m20260325_initial, Nothing)
+  [ ("20260325_initial", m20260325_initial, Nothing),
+    ("20260823_file_expiration", m20260823_file_expiration, Just down_m20260823_file_expiration)
   ]
 
 -- | The list of migrations in ascending order by date
@@ -45,3 +46,17 @@ CREATE TABLE recipients (
 CREATE INDEX idx_recipients_sender_id ON recipients (sender_id);
 CREATE INDEX idx_files_created_at ON files (created_at);
 |]
+
+m20260823_file_expiration :: Text
+m20260823_file_expiration =
+  [r|
+ALTER TABLE files ADD COLUMN expires_at BIGINT;
+CREATE INDEX idx_files_expiry ON files (expires_at, created_at);
+|]
+
+down_m20260823_file_expiration :: Text
+down_m20260823_file_expiration =
+  [r|
+DROP INDEX idx_files_expiry;
+ALTER TABLE files DROP COLUMN expires_at;
+|]

src/Simplex/FileTransfer/Server/StoreLog.hs

@@ -20,13 +20,13 @@ module Simplex.FileTransfer.Server.StoreLog
   )
 where
 
-import Control.Applicative ((<|>))
+import Control.Applicative (optional, (<|>))
 import Control.Concurrent.STM
 import Control.Monad.Except
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
-import Data.Composition ((.:), (.::))
+import Data.Composition ((.:), (.::.))
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.List.NonEmpty as L
 import Data.Map.Strict (Map)
@@ -42,7 +42,7 @@ import Simplex.Messaging.Util (bshow)
 import System.IO
 
 data FileStoreLogRecord
-  = AddFile SenderId FileInfo RoundedFileTime ServerEntityStatus
+  = AddFile SenderId FileInfo RoundedFileTime (Maybe RoundedFileTime) ServerEntityStatus
   | PutFile SenderId FilePath
   | AddRecipients SenderId (NonEmpty FileRecipient)
   | DeleteFile SenderId
@@ -52,27 +52,37 @@ data FileStoreLogRecord
 
 instance StrEncoding FileStoreLogRecord where
   strEncode = \case
-    AddFile sId file createdAt status -> strEncode (Str "FNEW", sId, file, createdAt, status)
+    AddFile sId file createdAt expiresAt status -> B.concat [strEncode (Str "FNEW", sId, file, createdAt), expE expiresAt, " ", strEncode status]
     PutFile sId path -> strEncode (Str "FPUT", sId, path)
     AddRecipients sId rcps -> strEncode (Str "FADD", sId, rcps)
     DeleteFile sId -> strEncode (Str "FDEL", sId)
     BlockFile sId info -> strEncode (Str "FBLK", sId, info)
     AckFile rId -> strEncode (Str "FACK", rId)
+    where
+      expE = maybe "" ((" " <>) . strEncode)
   strP =
     A.choice
-      [ "FNEW " *> (AddFile <$> strP_ <*> strP_ <*> strP <*> (_strP <|> pure EntityActive)),
+      [ "FNEW " *> addFileP,
         "FPUT " *> (PutFile <$> strP_ <*> strP),
         "FADD " *> (AddRecipients <$> strP_ <*> strP),
         "FDEL " *> (DeleteFile <$> strP),
         "FBLK " *> (BlockFile <$> strP_ <*> strP),
         "FACK " *> (AckFile <$> strP)
       ]
+    where
+      addFileP = do
+        sId <- strP_
+        file <- strP_
+        createdAt <- strP
+        expiresAt <- optional _strP
+        status <- _strP <|> pure EntityActive
+        pure $ AddFile sId file createdAt expiresAt status
 
 logFileStoreRecord :: StoreLog 'WriteMode -> FileStoreLogRecord -> IO ()
 logFileStoreRecord = writeStoreLogRecord
 
-logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> RoundedFileTime -> ServerEntityStatus -> IO ()
-logAddFile s = logFileStoreRecord s .:: AddFile
+logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> RoundedFileTime -> Maybe RoundedFileTime -> ServerEntityStatus -> IO ()
+logAddFile s = logFileStoreRecord s .::. AddFile
 
 logPutFile :: StoreLog 'WriteMode -> SenderId -> FilePath -> IO ()
 logPutFile s = logFileStoreRecord s .: PutFile
@@ -102,8 +112,8 @@ readFileStore f st = mapM_ (addFileLogRecord . LB.toStrict) . LB.lines =<< LB.re
           Left e -> B.putStrLn $ "Log processing error (" <> bshow e <> "): " <> B.take 100 s
           _ -> pure ()
     addToStore = \case
-      AddFile sId file createdAt status
-        | size file > 0 -> addFile st sId file createdAt status
+      AddFile sId file createdAt expiresAt status
+        | size file > 0 -> addFile st sId file createdAt expiresAt status
         | otherwise -> pure $ Left SIZE
       PutFile qId path -> setFilePath st qId path
       AddRecipients sId rcps -> runExceptT $ addRecipients sId rcps
@@ -118,9 +128,9 @@ writeFileStore s STMFileStore {files, recipients} = do
   readTVarIO files >>= mapM_ (logFile allRcps)
   where
     logFile :: Map RecipientId (SenderId, RcvPublicAuthKey) -> FileRec -> IO ()
-    logFile allRcps FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, fileStatus} = do
+    logFile allRcps FileRec {senderId, fileInfo, filePath, recipientIds, createdAt, expiresAt, fileStatus} = do
       status <- readTVarIO fileStatus
-      logAddFile s senderId fileInfo createdAt status
+      logAddFile s senderId fileInfo createdAt expiresAt status
       (rcpErrs, rcps) <- M.mapEither getRcp . M.fromSet id <$> readTVarIO recipientIds
       mapM_ (logAddRecipients s senderId) $ L.nonEmpty $ M.elems rcps
       mapM_ (B.putStrLn . ("Error storing log: " <>)) rcpErrs

src/Simplex/FileTransfer/Transport.hs

@@ -12,6 +12,7 @@ module Simplex.FileTransfer.Transport
   ( supportedFileServerVRange,
     authCmdsXFTPVersion,
     blockedFilesXFTPVersion,
+    fileStorageTimeXFTPVersion,
     xftpClientHandshakeStub,
     alpnSupportedXFTPhandshakes,
     xftpALPNv1,
@@ -36,7 +37,6 @@ module Simplex.FileTransfer.Transport
   )
 where
 
-import Control.Applicative (optional)
 import qualified Control.Exception as E
 import Control.Logger.Simple
 import Control.Monad
@@ -56,13 +56,14 @@ import Data.Word (Word16, Word32)
 import Network.HTTP2.Client (HTTP2Error)
 import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Lazy as LC
+import Simplex.Messaging.Crypto.Entitlement (EntitlementProof)
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers
 import Simplex.Messaging.Protocol (BlockingInfo, CommandError)
 import Simplex.Messaging.Transport (ALPN, CertChainPubKey, ServiceCredentials, SessionId, THandle (..), THandleParams (..), TransportError (..), TransportPeer (..))
 import Simplex.Messaging.Transport.HTTP2.File
-import Simplex.Messaging.Util (bshow, tshow, (<$?>))
+import Simplex.Messaging.Util (bshow, tshow, (<$?>), (<$$>))
 import Simplex.Messaging.Version
 import Simplex.Messaging.Version.Internal
 import System.IO (Handle, IOMode (..), withFile)
@@ -97,15 +98,18 @@ authCmdsXFTPVersion = VersionXFTP 2
 blockedFilesXFTPVersion :: VersionXFTP
 blockedFilesXFTPVersion = VersionXFTP 3
 
+fileStorageTimeXFTPVersion :: VersionXFTP
+fileStorageTimeXFTPVersion = VersionXFTP 4
+
 currentXFTPVersion :: VersionXFTP
-currentXFTPVersion = VersionXFTP 3
+currentXFTPVersion = VersionXFTP 4
 
 supportedFileServerVRange :: VersionRangeXFTP
 supportedFileServerVRange = mkVersionRange initialXFTPVersion currentXFTPVersion
 
 -- XFTP protocol does not use this handshake method
-xftpClientHandshakeStub :: c 'TClient -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeXFTP -> Bool -> Maybe (ServiceCredentials, C.KeyPairEd25519) -> ExceptT TransportError IO (THandle XFTPVersion c 'TClient)
-xftpClientHandshakeStub _c _ks _keyHash _xftpVRange _proxyServer _serviceKeys = throwE TEVersion
+xftpClientHandshakeStub :: c 'TClient -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeXFTP -> Bool -> Maybe (ServiceCredentials, C.KeyPairEd25519) -> (SessionId -> IO (Maybe EntitlementProof)) -> ExceptT TransportError IO (THandle XFTPVersion c 'TClient)
+xftpClientHandshakeStub _c _ks _keyHash _xftpVRange _proxyServer _serviceKeys _mkEntitlementProof = throwE TEVersion
 
 alpnSupportedXFTPhandshakes :: [ALPN]
 alpnSupportedXFTPhandshakes = [xftpALPNv1]
@@ -124,14 +128,18 @@ data XFTPServerHandshake = XFTPServerHandshake
     -- | pub key to agree shared secrets for command authorization and entity ID encryption.
     authPubKey :: CertChainPubKey,
     -- | signed identity challenge from  XFTPClientHello
-    webIdentityProof :: Maybe C.ASignature
+    webIdentityProof :: Maybe C.ASignature,
+    -- | optional server public information (JSON-encoded ServerPublicInfo), sent when version >= fileStorageTimeXFTPVersion
+    serverInfoBytes :: Maybe ByteString
   }
 
 data XFTPClientHandshake = XFTPClientHandshake
   { -- | agreed XFTP server protocol version
     xftpVersion :: VersionXFTP,
     -- | server identity - CA certificate fingerprint
-    keyHash :: C.KeyHash
+    keyHash :: C.KeyHash,
+    -- | proof of the user entitlement bound to the session
+    entitlementProof :: Maybe EntitlementProof
   }
 
 instance Encoding XFTPClientHello where
@@ -143,21 +151,33 @@ instance Encoding XFTPClientHello where
     pure XFTPClientHello {webChallenge}
 
 instance Encoding XFTPClientHandshake where
-  smpEncode XFTPClientHandshake {xftpVersion, keyHash} =
-    smpEncode (xftpVersion, keyHash)
+  smpEncode XFTPClientHandshake {xftpVersion = v, keyHash, entitlementProof} =
+    smpEncode (v, keyHash) <> ifHasEntitlement v (smpEncode entitlementProof) ""
   smpP = do
-    (xftpVersion, keyHash) <- smpP
+    (v, keyHash) <- smpP
+    entitlementProof <- ifHasEntitlement v smpP (pure Nothing)
     Tail _compat <- smpP
-    pure XFTPClientHandshake {xftpVersion, keyHash}
+    pure XFTPClientHandshake {xftpVersion = v, keyHash, entitlementProof}
+
+ifHasEntitlement :: VersionXFTP -> a -> a -> a
+ifHasEntitlement v a b = if v >= fileStorageTimeXFTPVersion then a else b
 
 instance Encoding XFTPServerHandshake where
-  smpEncode XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey, webIdentityProof} =
-    smpEncode (xftpVersionRange, sessionId, authPubKey, C.signatureBytes webIdentityProof)
+  smpEncode XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey, webIdentityProof, serverInfoBytes} =
+    smpEncode (xftpVersionRange, sessionId, authPubKey, C.signatureBytes webIdentityProof) <> info
+    where
+      info = ifHasServerInfo (maxVersion xftpVersionRange) (smpEncode (Large <$> serverInfoBytes)) ""
   smpP = do
     (xftpVersionRange, sessionId, authPubKey) <- smpP
-    webIdentityProof <- optional $ C.decodeSignature <$?> smpP
+    -- decode the (length-prefixed) signature bytes deterministically: empty bytes decode to Nothing.
+    -- (Must not use `optional`, which would backtrack and leave the bytes for the parsers that follow.)
+    webIdentityProof <- C.decodeSignature <$?> smpP
+    serverInfoBytes <- ifHasServerInfo (maxVersion xftpVersionRange) (unLarge <$$> smpP) (pure Nothing)
     Tail _compat <- smpP
-    pure XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey, webIdentityProof}
+    pure XFTPServerHandshake {xftpVersionRange, sessionId, authPubKey, webIdentityProof, serverInfoBytes}
+
+ifHasServerInfo :: VersionXFTP -> a -> a -> a
+ifHasServerInfo v a b = if v >= fileStorageTimeXFTPVersion then a else b
 
 sendEncFile :: Handle -> (Builder -> IO ()) -> LC.SbState -> Word32 -> IO ()
 sendEncFile h send = go

src/Simplex/FileTransfer/Types.hs

@@ -39,6 +39,7 @@ import Data.Text.Encoding (encodeUtf8)
 import Data.Word (Word32)
 import Simplex.FileTransfer.Client (XFTPChunkSpec (..))
 import Simplex.FileTransfer.Description
+import Simplex.FileTransfer.Protocol (GrantedStorageTime (..))
 import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..), fromTextField_)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.File (CryptoFile (..))
@@ -92,7 +93,8 @@ data RcvFile = RcvFile
   deriving (Show)
 
 data RcvFileStatus
-  = RFSReceiving
+  = RFSPrepared
+  | RFSReceiving
   | RFSReceived
   | RFSDecrypting
   | RFSComplete
@@ -105,6 +107,7 @@ instance ToField RcvFileStatus where toField = toField . textEncode
 
 instance TextEncoding RcvFileStatus where
   textDecode = \case
+    "prepared" -> Just RFSPrepared
     "receiving" -> Just RFSReceiving
     "received" -> Just RFSReceived
     "decrypting" -> Just RFSDecrypting
@@ -112,6 +115,7 @@ instance TextEncoding RcvFileStatus where
     "error" -> Just RFSError
     _ -> Nothing
   textEncode = \case
+    RFSPrepared -> "prepared"
     RFSReceiving -> "receiving"
     RFSReceived -> "received"
     RFSDecrypting -> "decrypting"
@@ -167,7 +171,8 @@ data SndFile = SndFile
     prefixPath :: Maybe FilePath,
     status :: SndFileStatus,
     deleted :: Bool,
-    redirect :: Maybe RedirectFileInfo
+    redirect :: Maybe RedirectFileInfo,
+    storageHours :: Maybe Word32
   }
   deriving (Show)
 
@@ -175,7 +180,8 @@ sndFileEncPath :: FilePath -> FilePath
 sndFileEncPath prefixPath = prefixPath </> "xftp.encrypted"
 
 data SndFileStatus
-  = SFSNew -- db record created
+  = SFSPrepared
+  | SFSNew -- db record created
   | SFSEncrypting -- encryption started
   | SFSEncrypted -- encryption complete
   | SFSUploading -- all chunk replicas are created on servers
@@ -189,6 +195,7 @@ instance ToField SndFileStatus where toField = toField . textEncode
 
 instance TextEncoding SndFileStatus where
   textDecode = \case
+    "prepared" -> Just SFSPrepared
     "new" -> Just SFSNew
     "encrypting" -> Just SFSEncrypting
     "encrypted" -> Just SFSEncrypted
@@ -197,6 +204,7 @@ instance TextEncoding SndFileStatus where
     "error" -> Just SFSError
     _ -> Nothing
   textEncode = \case
+    SFSPrepared -> "prepared"
     SFSNew -> "new"
     SFSEncrypting -> "encrypting"
     SFSEncrypted -> "encrypted"
@@ -225,7 +233,8 @@ data NewSndChunkReplica = NewSndChunkReplica
   { server :: XFTPServer,
     replicaId :: ChunkReplicaId,
     replicaKey :: C.APrivateAuthKey,
-    rcvIdsKeys :: [(ChunkReplicaId, C.APrivateAuthKey)]
+    rcvIdsKeys :: [(ChunkReplicaId, C.APrivateAuthKey)],
+    expiresAt :: Maybe GrantedStorageTime
   }
   deriving (Show)
 
@@ -237,7 +246,8 @@ data SndFileChunkReplica = SndFileChunkReplica
     rcvIdsKeys :: [(ChunkReplicaId, C.APrivateAuthKey)],
     replicaStatus :: SndFileReplicaStatus,
     delay :: Maybe Int64,
-    retries :: Int
+    retries :: Int,
+    expiresAt :: Maybe GrantedStorageTime
   }
   deriving (Show)
 

src/Simplex/Messaging/Agent.hs

@@ -106,8 +106,10 @@ module Simplex.Messaging.Agent
     deleteConnection,
     deleteConnections,
     getConnectionServers,
-    getConnectionRatchetAdHash,
+    getConnectionVerifyCodes,
+    getConnectionsVerifyCodes,
     setProtocolServers,
+    setUserEntitlement,
     checkUserServers,
     testProtocolServer,
     setNtfServers,
@@ -125,10 +127,15 @@ module Simplex.Messaging.Agent
     xftpStartWorkers,
     xftpStartSndWorkers,
     xftpReceiveFile,
+    xftpPrepareReceiveFile,
+    xftpStartReceiveFile,
     xftpDeleteRcvFile,
     xftpDeleteRcvFiles,
     xftpSendFile,
     xftpSendDescription,
+    xftpPrepareSendFile,
+    xftpPrepareSendDescription,
+    xftpStartSendFile,
     xftpDeleteSndFileInternal,
     xftpDeleteSndFilesInternal,
     xftpDeleteSndFileRemote,
@@ -187,8 +194,8 @@ import qualified Data.Text as T
 import Data.Time.Clock
 import Data.Time.Clock.System (systemToUTCTime)
 import Data.Traversable (mapAccumL)
-import Data.Word (Word16)
-import Simplex.FileTransfer.Agent (closeXFTPAgent, deleteSndFileInternal, deleteSndFileRemote, deleteSndFilesInternal, deleteSndFilesRemote, startXFTPSndWorkers, startXFTPWorkers, toFSFilePath, xftpDeleteRcvFile', xftpDeleteRcvFiles', xftpReceiveFile', xftpSendDescription', xftpSendFile')
+import Data.Word (Word16, Word32)
+import Simplex.FileTransfer.Agent (closeXFTPAgent, deleteSndFileInternal, deleteSndFileRemote, deleteSndFilesInternal, deleteSndFilesRemote, startXFTPSndWorkers, startXFTPWorkers, toFSFilePath, xftpDeleteRcvFile', xftpDeleteRcvFiles', xftpPrepareReceiveFile', xftpPrepareSendDescription', xftpPrepareSendFile', xftpReceiveFile', xftpSendDescription', xftpSendFile', xftpStartReceiveFile', xftpStartSendFile')
 import Simplex.FileTransfer.Description (ValidFileDescription)
 import Simplex.FileTransfer.Protocol (FileParty (..))
 import Simplex.FileTransfer.Types (RcvFileId, SndFileId)
@@ -211,6 +218,7 @@ import Simplex.Messaging.Server.Information (ServerPublicInfo)
 import qualified Simplex.Messaging.Agent.TSessionSubs as SS
 import Simplex.Messaging.Client (NetworkRequestMode (..), ProtocolClientError (..), SMPClientError, ServerTransmission (..), ServerTransmissionBatch, TransportSessionMode (..), nonBlockingWriteTBQueue, smpErrorClientNotice, temporaryClientError, unexpectedResponse)
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential)
 import Simplex.Messaging.Crypto.File (CryptoFile, CryptoFileArgs)
 import Simplex.Messaging.Crypto.Ratchet (PQEncryption, PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
 import qualified Simplex.Messaging.Crypto.Ratchet as CR
@@ -226,7 +234,7 @@ import Simplex.Messaging.Protocol
     ErrorType (AUTH),
     MsgBody,
     MsgFlags (..),
-    NameRecord,
+    NameResponse,
     NtfServer,
     ProtoServerWithAuth (..),
     ProtocolServer (..),
@@ -459,7 +467,7 @@ getConnShortLink c = withAgentEnv c .:. getConnShortLink' c
 -- | Resolve a SimpleX name (PFWD RSLV). The agent owns server selection: it
 -- picks a names-capable server (ServerRoles.names) from the user's nameSrvs, so
 -- chat clients just pass the parsed domain.
-resolveSimplexName :: AgentClient -> NetworkRequestMode -> UserId -> SimplexDomain -> AE NameRecord
+resolveSimplexName :: AgentClient -> NetworkRequestMode -> UserId -> SimplexDomain -> AE NameResponse
 resolveSimplexName c nm userId domain = withAgentEnv c $ resolveSimplexName' c nm userId domain
 {-# INLINE resolveSimplexName #-}
 
@@ -482,12 +490,12 @@ changeConnectionUser c oldUserId connId newUserId = withAgentEnv c $ changeConne
 -- the caller of joinConnection saves connection ID to the database.
 -- 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 :: AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> PQSupport -> AE (ConnId, ContactRequestBinding)
 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).
-prepareConnectionToAccept :: AgentClient -> UserId -> Bool -> InvitationId -> PQSupport -> AE ConnId
+prepareConnectionToAccept :: AgentClient -> UserId -> Bool -> InvitationId -> PQSupport -> AE (ConnId, ContactRequestBinding)
 prepareConnectionToAccept c userId enableNtfs = withAgentEnv c .: newConnToAccept c userId "" enableNtfs
 {-# INLINE prepareConnectionToAccept #-}
 
@@ -671,15 +679,19 @@ getConnectionServers c = withAgentEnv c . getConnectionServers' c
 {-# INLINE getConnectionServers #-}
 
 -- | get connection ratchet associated data hash for verification (should match peer AD hash)
-getConnectionRatchetAdHash :: AgentClient -> ConnId -> AE ByteString
-getConnectionRatchetAdHash c = withAgentEnv c . getConnectionRatchetAdHash' c
-{-# INLINE getConnectionRatchetAdHash #-}
+getConnectionVerifyCodes :: AgentClient -> ConnId -> AE ConnVerifyCodes
+getConnectionVerifyCodes c = withAgentEnv c . getConnectionVerifyCodes' c
+{-# INLINE getConnectionVerifyCodes #-}
+
+getConnectionsVerifyCodes :: AgentClient -> [ConnId] -> AE (Map ConnId ConnVerifyCodes)
+getConnectionsVerifyCodes c = withAgentEnv c . getConnectionsVerifyCodes' c
+{-# INLINE getConnectionsVerifyCodes #-}
 
 -- | Test protocol server
 testProtocolServer :: forall p. ProtocolTypeI p => AgentClient -> NetworkRequestMode -> UserId -> ProtoServerWithAuth p -> IO (Either ProtocolTestFailure (Maybe (Either String ServerPublicInfo)))
 testProtocolServer c nm userId srv = withAgentEnv' c $ case protocolTypeI @p of
   SPSMP -> runSMPServerTest c nm userId srv
-  SPXFTP -> maybe (Right Nothing) Left <$> runXFTPServerTest c nm userId srv
+  SPXFTP -> runXFTPServerTest c nm userId srv
   SPNTF -> maybe (Right Nothing) Left <$> runNTFServerTest c nm userId srv
 
 -- | set SOCKS5 proxy on/off and optionally set TCP timeouts for fast network
@@ -762,6 +774,14 @@ xftpReceiveFile :: AgentClient -> UserId -> ValidFileDescription 'FRecipient ->
 xftpReceiveFile c = withAgentEnv c .:: xftpReceiveFile' c
 {-# INLINE xftpReceiveFile #-}
 
+xftpPrepareReceiveFile :: AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> Bool -> AE RcvFileId
+xftpPrepareReceiveFile c = withAgentEnv c .:: xftpPrepareReceiveFile' c
+{-# INLINE xftpPrepareReceiveFile #-}
+
+xftpStartReceiveFile :: AgentClient -> RcvFileId -> AE ()
+xftpStartReceiveFile c = withAgentEnv c . xftpStartReceiveFile' c
+{-# INLINE xftpStartReceiveFile #-}
+
 -- | Delete XFTP rcv file (deletes work files from file system and db records)
 xftpDeleteRcvFile :: AgentClient -> RcvFileId -> IO ()
 xftpDeleteRcvFile c = withAgentEnv' c . xftpDeleteRcvFile' c
@@ -773,8 +793,8 @@ xftpDeleteRcvFiles c = withAgentEnv' c . xftpDeleteRcvFiles' c
 {-# INLINE xftpDeleteRcvFiles #-}
 
 -- | Send XFTP file
-xftpSendFile :: AgentClient -> UserId -> CryptoFile -> Int -> AE SndFileId
-xftpSendFile c = withAgentEnv c .:. xftpSendFile' c
+xftpSendFile :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe Word32 -> AE SndFileId
+xftpSendFile c = withAgentEnv c .:: xftpSendFile' c
 {-# INLINE xftpSendFile #-}
 
 -- | Send XFTP file
@@ -782,6 +802,18 @@ xftpSendDescription :: AgentClient -> UserId -> ValidFileDescription 'FRecipient
 xftpSendDescription c = withAgentEnv c .:. xftpSendDescription' c
 {-# INLINE xftpSendDescription #-}
 
+xftpPrepareSendFile :: AgentClient -> UserId -> CryptoFile -> Int -> Maybe Word32 -> AE SndFileId
+xftpPrepareSendFile c = withAgentEnv c .:: xftpPrepareSendFile' c
+{-# INLINE xftpPrepareSendFile #-}
+
+xftpPrepareSendDescription :: AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Int -> AE SndFileId
+xftpPrepareSendDescription c = withAgentEnv c .:. xftpPrepareSendDescription' c
+{-# INLINE xftpPrepareSendDescription #-}
+
+xftpStartSendFile :: AgentClient -> SndFileId -> AE ()
+xftpStartSendFile c = withAgentEnv c . xftpStartSendFile' c
+{-# INLINE xftpStartSendFile #-}
+
 -- | Delete XFTP snd file internally (deletes work files from file system and db records)
 xftpDeleteSndFileInternal :: AgentClient -> SndFileId -> IO ()
 xftpDeleteSndFileInternal c = withAgentEnv' c . deleteSndFileInternal c
@@ -1268,7 +1300,7 @@ getConnShortLink' c nm userId = \case
 deleteLocalInvShortLink' :: AgentClient -> ConnShortLink 'CMInvitation -> AM ()
 deleteLocalInvShortLink' c (CSLInvitation _ srv linkId _) = withStore' c $ \db -> deleteInvShortLink db srv linkId
 
-resolveSimplexName' :: AgentClient -> NetworkRequestMode -> UserId -> SimplexDomain -> AM NameRecord
+resolveSimplexName' :: AgentClient -> NetworkRequestMode -> UserId -> SimplexDomain -> AM NameResponse
 resolveSimplexName' c nm userId domain = do
   resolverSrv <- getNextNameServer c userId
   resolveName c nm userId resolverSrv domain
@@ -1309,8 +1341,13 @@ newRcvConnSrv c nm userId connId enableNtfs cMode userLinkData_ clientData pqIni
         SCMInvitation -> do
           g <- asks random
           let pqEnc = CR.initialPQEncryption (isJust userLinkData_) pqInitKeys
-          (pks, e2eRcvParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion e2eEncryptVRange) pqEnc
-          withStore' c $ \db -> createRatchetX3dhKeys db connId pks
+          e2eRcvParams <- withStore' c $ \db -> do
+            lockConnForUpdate db connId
+            getRatchetX3dhKeys db connId >>= \case
+              Right keys -> pure $ CR.mkRcvE2ERatchetParams (maxVersion e2eEncryptVRange) keys
+              Left _ -> do
+                (pks, e2eRcvParams) <- CR.generateRcvE2EParams g (maxVersion e2eEncryptVRange) pqEnc
+                e2eRcvParams <$ createRatchetX3dhKeys db connId pks
           pure $ CRInvitationUri crData $ toVersionRangeT e2eRcvParams e2eEncryptVRange
     setLinkDataRatchetKeys :: Maybe AddressRatchetKeys -> UserConnLinkData c -> UserConnLinkData c
     setLinkDataRatchetKeys ks = \case
@@ -1368,30 +1405,47 @@ newQueueNtfSubscription c RcvQueue {userId, connId, server, clientNtfCreds} ntfS
   ns <- asks ntfSupervisor
   liftIO $ sendNtfSubCommand ns (NSCCreate, [connId])
 
-newConnToJoin :: forall c. AgentClient -> UserId -> ConnId -> Bool -> Maybe UTCTime -> ConnectionRequestUri c -> PQSupport -> AM ConnId
+newConnToJoin :: forall c. AgentClient -> UserId -> ConnId -> Bool -> Maybe UTCTime -> ConnectionRequestUri c -> PQSupport -> AM (ConnId, ContactRequestBinding)
 newConnToJoin c userId connId enableNtfs serviceRequestExpiresAt cReq pqSupport = case cReq of
   CRInvitationUri {} ->
     lift (compatibleInvitationUri cReq) >>= \case
-      Just (_, _, aVersion) -> create aVersion
+      Just (_, Compatible e2eRcvParams, aVersion) -> create aVersion $ Right e2eRcvParams
       Nothing -> throwE $ AGENT A_VERSION
   CRContactUri {} ->
     lift (compatibleContactUri cReq) >>= \case
-      Just (_, _, aVersion) -> create aVersion
+      Just (Compatible SMPQueueInfo {queueAddress = SMPQueueAddress {senderId}}, ratchet_, aVersion) ->
+        create aVersion $ case ratchet_ of
+          Just (_, Compatible e2eRcvParams) -> Right e2eRcvParams
+          Nothing -> Left senderId
       Nothing -> throwE $ AGENT A_VERSION
   where
-    create :: Compatible VersionSMPA -> AM ConnId
-    create (Compatible connAgentVersion) = do
+    create :: Compatible VersionSMPA -> Either SMP.SenderId (CR.RcvE2ERatchetParams 'C.X448) -> AM (ConnId, ContactRequestBinding)
+    create (Compatible connAgentVersion) addrOrParams = do
       g <- asks random
+      maxSupported <- asks $ maxVersion . e2eEncryptVRange . config
       let cData = ConnData {userId, connId, connAgentVersion, enableNtfs, lastExternalSndId = 0, deleted = False, ratchetSyncState = RSOk, pqSupport, serviceRequestExpiresAt}
-      withStore c $ \db -> createNewConn db g cData SCMInvitation
+      withStore c $ \db -> runExceptT $ do
+        connId' <- ExceptT $ createNewConn db g cData SCMInvitation
+        binding <- case addrOrParams of
+          Right e2eRcvParams -> CRBRatchet . ratchetVerifyCodes . fst <$> createRatchet_ db g connId' maxSupported pqSupport e2eRcvParams
+          Left senderId -> do
+            let pqEnc = CR.initialPQEncryption False $ CR.joinContactInitialKeys pqSupport
+            (pks, CR.E2ERatchetParams _ k1 k2 kem_) <- liftIO $ CR.generateRcvE2EParams g maxSupported pqEnc
+            liftIO $ CRBRequest (requestCode k1 k2 kem_ senderId) <$ createRatchetX3dhKeys db connId' pks
+        pure (connId', binding)
 
-newConnToAccept :: AgentClient -> UserId -> ConnId -> Bool -> InvitationId -> PQSupport -> AM ConnId
+requestCode :: C.PublicKeyX448 -> C.PublicKeyX448 -> Maybe (CR.RKEMParams 'CR.RKSProposed) -> SMP.SenderId -> ByteString
+requestCode k1 k2 kem_ sndId = C.sha256Hash $ smpEncode (k1, k2, kem_, sndId)
+
+newConnToAccept :: AgentClient -> UserId -> ConnId -> Bool -> InvitationId -> PQSupport -> AM (ConnId, ContactRequestBinding)
 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 Nothing cReq pqSup
-    CRInvitationDR dr -> (\ConnData {connId = connId'} -> connId') <$> newConnToAcceptDR c userId connId dr enableNtfs
-      
+    CRInvitationDR dr@DRInvitation {ratchetState} -> do
+      ConnData {connId = connId'} <- newConnToAcceptDR c userId connId dr enableNtfs
+      pure (connId', CRBRatchet $ ratchetVerifyCodes ratchetState)
+
 newConnToAcceptDR :: AgentClient -> UserId -> ConnId -> DRInvitation -> Bool -> AM ConnData
 newConnToAcceptDR c userId connId DRInvitation {agentVersion, pqSupport} enableNtfs = do
   g <- asks random
@@ -1434,7 +1488,7 @@ startJoinInvitation c userId connId sq_ enableNtfs cReqUri pqSupport =
           (q, _) <- lift $ newSndQueue userId "" qInfo sndKey_
           withStore c $ \db -> runExceptT $ do
             liftIO $ lockConnForUpdate db connId
-            e2eSndParams <- snd <$> createRatchet_ db g connId maxSupported pqSupport e2eRcvParams
+            (_, e2eSndParams) <- liftIO (getSndRatchet db connId v) >>= either (const $ createRatchet_ db g connId maxSupported pqSupport e2eRcvParams) pure
             sq' <- maybe (ExceptT $ updateNewConnSnd db connId q) pure sq_
             pure ((cData, sq'), (Just e2eSndParams, lnkId_))
     Nothing -> throwE $ AGENT A_VERSION
@@ -1727,7 +1781,7 @@ 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
+  (connId, _) <- newConnToJoin c userId "" False (Just expiresAt) cReqUri PQSupportOn
   var <- atomically newEmptyTMVar
   atomically $ TM.insert connId var (serviceRequests c)
   r <- tryAllErrors $ do
@@ -2114,20 +2168,21 @@ data CommandCompletion = CCMoved | CCCompleted
 
 runCommandProcessing :: AgentClient -> ConnId -> Maybe SMPServer -> Worker -> AM ()
 runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do
-  ri <- asks $ messageRetryInterval . config -- different retry interval?
+  AgentConfig {messageRetryInterval = RetryInterval2 {riFast}, commandQuotaRetryInterval} <- asks config
+  let ri = RetryInterval2 {riSlow = commandQuotaRetryInterval, riFast}
   forever $ do
     atomically $ endAgentOperation c AOSndNetwork
     lift $ waitForWork doWork
     liftIO $ throwWhenInactive c
     atomically $ beginAgentOperation c AOSndNetwork
-    withWork c doWork (\db -> getPendingServerCommand db connId server_) $ runProcessCmd (riFast ri)
+    withWork c doWork (\db -> getPendingServerCommand db connId server_) $ runProcessCmd ri
   where
     runProcessCmd ri cmd = do
       pending <- newTVarIO []
       processCmd ri cmd pending
       mapM_ (atomically . writeTBQueue subQ) . reverse =<< readTVarIO pending
-    processCmd :: RetryInterval -> PendingCommand -> TVar [ATransmission] -> AM ()
-    processCmd ri PendingCommand {cmdId, corrId, userId, command} pendingCmds = case command of
+    processCmd :: RetryInterval2 -> PendingCommand -> TVar [ATransmission] -> AM ()
+    processCmd ri PendingCommand {cmdId, corrId, userId, command, createdAt} pendingCmds = case command of
       AClientCommand cmd -> case cmd of
         NEW enableNtfs (ACM cMode) pqEnc subMode useDR -> noServer $ do
           triedHosts <- newTVarIO S.empty
@@ -2322,12 +2377,18 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do
             SomeConn _ conn@DuplexConnection {} -> a conn
             _ -> internalErr "command requires duplex connection"
         tryCommand action = tryMoveableCommand (action $> CCCompleted)
-        tryMoveableCommand action = withRetryInterval ri $ \_ loop -> do
+        tryMoveableCommand action = withRetryInterval2 ri $ \_ loop -> do
           liftIO $ waitWhileSuspended c
           liftIO $ waitForUserNetwork c
           tryAllErrors action >>= \case
+            Left e@(SMP _ SMP.QUOTA) -> do
+              AgentConfig {quotaExceededTimeout} <- asks config
+              expireTs <- addUTCTime (-quotaExceededTimeout) <$> liftIO getCurrentTime
+              if createdAt < expireTs
+                then cmdError e
+                else retrySndOp c $ loop RISlow
             Left e
-              | temporaryOrHostError e -> retrySndOp c loop
+              | temporaryOrHostError e -> retrySndOp c $ loop RIFast
               | otherwise -> cmdError e
             Right CCCompleted -> withStore' c (`deleteCommand` cmdId)
             Right CCMoved -> pure () -- command processing moved to another command queue
@@ -2987,10 +3048,12 @@ getConnectionServers' c connId = do
   SomeConn _ conn <- withStore c (`getConn` connId)
   connectionStats c conn
 
-getConnectionRatchetAdHash' :: AgentClient -> ConnId -> AM ByteString
-getConnectionRatchetAdHash' c connId = do
-  CR.Ratchet {rcAD = Str rcAD} <- withStore c (`getRatchet` connId)
-  pure $ C.sha256Hash rcAD
+getConnectionVerifyCodes' :: AgentClient -> ConnId -> AM ConnVerifyCodes
+getConnectionVerifyCodes' c connId =
+  getConnectionsVerifyCodes' c [connId] >>= maybe (throwE $ CONN NOT_FOUND "") pure . M.lookup connId
+
+getConnectionsVerifyCodes' :: AgentClient -> [ConnId] -> AM (Map ConnId ConnVerifyCodes)
+getConnectionsVerifyCodes' c connIds = withStore' c (`getRatchetVerifyCodes` connIds)
 
 connectionStats :: AgentClient -> Connection c -> AM ConnectionStats
 connectionStats c = \case
@@ -3049,6 +3112,17 @@ setProtocolServers c userId srvs = do
   checkUserServers "setProtocolServers" srvs
   atomically $ TM.insert userId (mkUserServers srvs) (userServers c)
 
+-- | Change the entitlement credential presented to the servers of the user.
+-- The credential is presented in the handshake, so the user's clients are closed to present the new one.
+setUserEntitlement :: AgentClient -> UserId -> Maybe EntitlementCredential -> IO ()
+setUserEntitlement c userId cred_ = do
+  changed <- atomically $ do
+    prev_ <- TM.lookup userId $ userEntitlements c
+    if prev_ == cred_
+      then pure False
+      else True <$ maybe (TM.delete userId) (TM.insert userId) cred_ (userEntitlements c)
+  when changed $ closeUserClients c userId
+
 checkUserServers :: Text -> NonEmpty (ServerCfg p) -> IO ()
 checkUserServers name srvs =
   unless (any (\ServerCfg {enabled} -> enabled) srvs) $
@@ -4027,14 +4101,14 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
               enqueueMessages' c cData' sqs SMP.MsgFlags {notification = True} (EREADY lastExternalSndId)
 
           smpInvitation :: SMP.MsgId -> Connection c -> ConnectionRequestUri 'CMInvitation -> ConnInfo -> AM ()
-          smpInvitation srvMsgId conn' connReq@(CRInvitationUri crData _) cInfo = do
+          smpInvitation srvMsgId conn' connReq@(CRInvitationUri crData (CR.E2ERatchetParamsUri _ k1 k2 kem_)) cInfo = do
             logServer "<--" c srv rId $ "MSG <KEY>:" <> logSecret' srvMsgId
             case conn' of
-              ContactConnection {} -> do
+              ContactConnection _ RcvQueue {sndId} -> do
                 -- show connection request even if invitaion via contact address is not compatible.
                 invId <- storeInvitation (CRInvitation connReq) cInfo False
                 let srvs = L.map qServer $ crSmpQueues crData
-                notify $ REQ invId PQSupportOn srvs cInfo False
+                notify $ REQ invId PQSupportOn srvs cInfo (CRBRequest $ requestCode k1 k2 kem_ sndId) False
               _ -> prohibited "inv: sent to message conn"
 
           storeInvitation :: ContactRequest -> ConnInfo -> Bool -> AM InvitationId
@@ -4061,7 +4135,7 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar
                           parseMessage "3" agentMsgBody >>= \case
                             AgentConnInfoReply (replyQueue :| _) cInfo -> do
                               invId <- storeInvitation (CRInvitationDR $ mkDR replyQueue) cInfo False
-                              notify $ REQ invId PQSupportOn (qServer replyQueue :| []) cInfo True
+                              notify $ REQ invId PQSupportOn (qServer replyQueue :| []) cInfo (CRBRatchet $ ratchetVerifyCodes ratchetState) True
                             AgentServiceRequest (replyQueue :| _) sig_ payload ->
                               case verifyServiceReq rc payload sig_ of
                                 Left err -> logError ("service request: " <> T.pack err) >> notify (ERR $ AGENT $ A_SERVICE ASEBadSignature)

src/Simplex/Messaging/Agent/Client.hs

@@ -41,6 +41,7 @@ module Simplex.Messaging.Agent.Client
     reconnectServerClients,
     reconnectSMPServer,
     closeXFTPServerClient,
+    closeUserClients,
     runSMPServerTest,
     runXFTPServerTest,
     runNTFServerTest,
@@ -227,7 +228,7 @@ import Data.Text (Text)
 import Data.Text.Encoding
 import Data.Time (UTCTime, addUTCTime, defaultTimeLocale, formatTime, getCurrentTime)
 import Data.Time.Clock.System (getSystemTime)
-import Data.Word (Word16)
+import Data.Word (Word16, Word32)
 import qualified Data.X509.Validation as XV
 import Network.Socket (HostName)
 import Simplex.FileTransfer.Client (XFTPChunkSpec (..), XFTPClient, XFTPClientConfig (..), XFTPClientError)
@@ -253,6 +254,8 @@ import Simplex.Messaging.Agent.TSessionSubs (TSessionSubs)
 import qualified Simplex.Messaging.Agent.TSessionSubs as SS
 import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.BBS (BBSPresHeader (..), BBSPublicKey)
+import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential, EntitlementProof, generateEntitlementProof)
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Notifications.Client
@@ -269,7 +272,7 @@ import Simplex.Messaging.Protocol
     NetworkError (..),
     MsgFlags (..),
     MsgId,
-    NameRecord,
+    NameResponse,
     NtfServer,
     NtfServerWithAuth,
     ProtoServer,
@@ -354,6 +357,7 @@ data AgentClient = AgentClient
     ntfClients :: TMap NtfTransportSession NtfClientVar,
     xftpServers :: TMap UserId (UserServers 'PXFTP),
     xftpClients :: TMap XFTPTransportSession XFTPClientVar,
+    userEntitlements :: TMap UserId EntitlementCredential,
     useNetworkConfig :: TVar (NetworkConfig, NetworkConfig), -- (slow, fast) networks
     presetDomains :: [HostName],
     presetServers :: [SMPServer],
@@ -511,7 +515,7 @@ data UserNetworkType = UNNone | UNCellular | UNWifi | UNEthernet | UNOther
 
 -- | Creates an SMP agent client instance that receives commands and sends responses via 'TBQueue's.
 newAgentClient :: Int -> InitialAgentServers -> UTCTime -> Map (Maybe SMPServer) (Maybe SystemSeconds) -> Env -> IO AgentClient
-newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg, useServices, presetDomains, presetServers} currentTs notices agentEnv = do
+newAgentClient clientId InitialAgentServers {smp, ntf, xftp, entitlements, netCfg, useServices, presetDomains, presetServers} currentTs notices agentEnv = do
   let cfg = config agentEnv
       qSize = tbqSize cfg
   proxySessTs <- newTVarIO =<< getCurrentTime
@@ -527,6 +531,7 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg, useServices
   ntfClients <- TM.emptyIO
   xftpServers <- newTVarIO $ M.map mkUserServers xftp
   xftpClients <- TM.emptyIO
+  userEntitlements <- newTVarIO entitlements
   useNetworkConfig <- newTVarIO (slowNetworkConfig netCfg, netCfg)
   userNetworkInfo <- newTVarIO $ UserNetworkInfo UNOther True
   userNetworkUpdated <- newTVarIO Nothing
@@ -568,6 +573,7 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg, useServices
         ntfClients,
         xftpServers,
         xftpClients,
+        userEntitlements,
         useNetworkConfig,
         presetDomains,
         presetServers,
@@ -754,9 +760,10 @@ smpConnectClient c@AgentClient {smpClients, msgQ, proxySessTs, presetDomains} nm
     connectClient :: SMPClientVar -> AM SMPConnectedClient
     connectClient v' = do
       cfg <- lift $ getClientConfig c smpCfg
+      keys <- asks $ entitlementKeys . config
       g <- asks random
       service <- getServiceCredentials c userId srv
-      let cfg' = cfg {serviceCredentials = fst <$> service}
+      let cfg' = cfg {serviceCredentials = fst <$> service, mkEntitlementProof = userEntitlementProof c keys userId $ knownUserServer (smpServers c) userId srv}
       env <- ask
       smp <- liftError (protocolClientError SMP $ B.unpack $ strEncode srv) $ do
         ts <- readTVarIO proxySessTs
@@ -857,7 +864,7 @@ notifySub c = notifySub' c ""
 {-# INLINE notifySub #-}
 
 getNtfServerClient :: AgentClient -> NetworkRequestMode -> NtfTransportSession -> AM NtfClient
-getNtfServerClient c@AgentClient {active, ntfClients, workerSeq, proxySessTs, presetDomains} nm tSess@(_, srv, _) = do
+getNtfServerClient c@AgentClient {active, ntfClients, workerSeq, proxySessTs, presetDomains} nm tSess@(userId, srv, _) = do
   unlessM (readTVarIO active) $ throwE INACTIVE
   ts <- liftIO getCurrentTime
   withGetSessVar workerSeq tSess ntfClients ts (newProtocolClient c tSess ntfClients connectClient) (waitForProtocolClient c nm tSess ntfClients)
@@ -865,10 +872,12 @@ getNtfServerClient c@AgentClient {active, ntfClients, workerSeq, proxySessTs, pr
     connectClient :: NtfClientVar -> AM NtfClient
     connectClient v = do
       cfg <- lift $ getClientConfig c ntfCfg
+      keys <- asks $ entitlementKeys . config
       g <- asks random
       ts <- readTVarIO proxySessTs
+      let cfg' = cfg {mkEntitlementProof = userEntitlementProof c keys userId $ knownNtfServer c srv}
       liftError' (protocolClientError NTF $ B.unpack $ strEncode srv) $
-        getProtocolClient g nm tSess cfg presetDomains Nothing ts $
+        getProtocolClient g nm tSess cfg' presetDomains Nothing ts $
           clientDisconnected v
 
     clientDisconnected :: NtfClientVar -> NtfClient -> IO ()
@@ -878,7 +887,7 @@ getNtfServerClient c@AgentClient {active, ntfClients, workerSeq, proxySessTs, pr
       logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
 
 getXFTPServerClient :: AgentClient -> XFTPTransportSession -> AM XFTPClient
-getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq, proxySessTs, presetDomains} tSess@(_, srv, _) = do
+getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq, proxySessTs, presetDomains} tSess@(userId, srv, _) = do
   unlessM (readTVarIO active) $ throwE INACTIVE
   ts <- liftIO getCurrentTime
   withGetSessVar workerSeq tSess xftpClients ts (newProtocolClient c tSess xftpClients connectClient) (waitForProtocolClient c NRMBackground tSess xftpClients)
@@ -886,10 +895,11 @@ getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq, proxySessTs,
     connectClient :: XFTPClientVar -> AM XFTPClient
     connectClient v = do
       cfg <- asks $ xftpCfg . config
+      keys <- asks $ entitlementKeys . config
       xftpNetworkConfig <- getNetworkConfig c
       ts <- readTVarIO proxySessTs
       liftError' (protocolClientError XFTP $ B.unpack $ strEncode srv) $
-        X.getXFTPClient tSess cfg {xftpNetworkConfig} presetDomains ts $
+        X.getXFTPClient tSess cfg {xftpNetworkConfig} presetDomains ts (userEntitlementProof c keys userId $ knownUserServer (xftpServers c) userId srv) $
           clientDisconnected v
 
     clientDisconnected :: XFTPClientVar -> XFTPClient -> IO ()
@@ -898,6 +908,29 @@ getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq, proxySessTs,
       atomically $ writeTBQueue (subQ c) ("", "", AEvt SAENone $ hostEvent DISCONNECT client)
       logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
 
+userEntitlementProof :: AgentClient -> Map Word16 BBSPublicKey -> UserId -> IO Bool -> SessionId -> IO (Maybe EntitlementProof)
+userEntitlementProof AgentClient {userEntitlements} keys userId knownServer sessId =
+  ifM knownServer proof (pure Nothing)
+  where
+    proof =
+      TM.lookupIO userId userEntitlements $>>= \cred ->
+        generateEntitlementProof keys cred (BBSPresHeader sessId) >>= \case
+          Right p -> pure $ Just p
+          Left e -> Nothing <$ logError ("entitlement proof error: " <> tshow e)
+
+-- the entitlement is presented only to the servers of this user, matched by key hash that TLS pins,
+-- so a server address received from another party cannot direct it to another server
+knownUserServer :: TMap UserId (UserServers p) -> UserId -> ProtocolServer p -> IO Bool
+knownUserServer servers userId srv = maybe False (any sameSrvKeyHash . storageSrvs) <$> TM.lookupIO userId servers
+  where
+    sameSrvKeyHash (_, ProtoServerWithAuth srv' _) = sameKeyHash srv srv'
+
+knownNtfServer :: AgentClient -> NtfServer -> IO Bool
+knownNtfServer c srv = any (sameKeyHash srv) <$> readTVarIO (ntfServers c)
+
+sameKeyHash :: ProtocolServer p -> ProtocolServer p -> Bool
+sameKeyHash ProtocolServer {keyHash} ProtocolServer {keyHash = kh} = keyHash == kh
+
 waitForProtocolClient ::
   (ProtocolTypeI (ProtoType msg), ProtocolServerClient v err msg) =>
   AgentClient ->
@@ -1037,6 +1070,19 @@ reconnectSMPServer c userId srv = do
       | userId == userId' && srv == srv' = (v :)
       | otherwise = id
 
+closeUserClients :: AgentClient -> UserId -> IO ()
+closeUserClients c userId = do
+  closeUserSessions c userId smpClients
+  closeUserSessions c userId ntfClients
+  closeUserSessions c userId xftpClients
+
+closeUserSessions :: ProtocolServerClient v err msg => AgentClient -> UserId -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> IO ()
+closeUserSessions c userId clientsSel = do
+  vs <- atomically $ stateTVar (clientsSel c) $ \cs ->
+    let (userCs, cs') = M.partitionWithKey (\(userId', _, _) _ -> userId == userId') cs
+     in (M.elems userCs, cs')
+  mapM_ (forkIO . closeClient_ c) vs
+
 closeClient :: ProtocolServerClient v err msg => AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> TransportSession msg -> IO ()
 closeClient c clientSel tSess =
   atomically (TM.lookupDelete tSess $ clientSel c) >>= mapM_ (closeClient_ c)
@@ -1326,7 +1372,7 @@ runSMPServerTest c@AgentClient {presetDomains} nm userId (ProtoServerWithAuth sr
     testErr :: ProtocolTestStep -> SMPClientError -> ProtocolTestFailure
     testErr step = ProtocolTestFailure step . protocolClientError SMP addr
 
-runXFTPServerTest :: AgentClient -> NetworkRequestMode -> UserId -> XFTPServerWithAuth -> AM' (Maybe ProtocolTestFailure)
+runXFTPServerTest :: AgentClient -> NetworkRequestMode -> UserId -> XFTPServerWithAuth -> AM' (Either ProtocolTestFailure (Maybe (Either String ServerPublicInfo)))
 runXFTPServerTest c@AgentClient {presetDomains} nm userId (ProtoServerWithAuth srv auth) = do
   cfg <- asks $ xftpCfg . config
   g <- asks random
@@ -1337,7 +1383,7 @@ runXFTPServerTest c@AgentClient {presetDomains} nm userId (ProtoServerWithAuth s
   liftIO $ do
     let tSess = (userId, srv, Nothing)
     ts <- readTVarIO $ proxySessTs c
-    X.getXFTPClient tSess cfg {xftpNetworkConfig} presetDomains ts (\_ -> pure ()) >>= \case
+    X.getXFTPClient tSess cfg {xftpNetworkConfig} presetDomains ts (\_ -> pure Nothing) (\_ -> pure ()) >>= \case
       Right xftp -> withTestChunk filePath $ do
         (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
         (rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
@@ -1345,15 +1391,15 @@ runXFTPServerTest c@AgentClient {presetDomains} nm userId (ProtoServerWithAuth s
         let file = FileInfo {sndKey, size = chSize, digest}
             chunkSpec = X.XFTPChunkSpec {filePath, chunkOffset = 0, chunkSize = chSize}
         r <- runExceptT $ do
-          (sId, [rId]) <- liftError (testErr TSCreateFile) $ X.createXFTPChunk xftp spKey file [rcvKey] auth
+          (sId, [rId], _) <- liftError (testErr TSCreateFile) $ X.createXFTPChunk xftp spKey file [rcvKey] auth Nothing
           liftError (testErr TSUploadFile) $ X.uploadXFTPChunk xftp spKey sId chunkSpec
           liftError (testErr TSDownloadFile) $ X.downloadXFTPChunk g xftp rpKey rId $ XFTPRcvChunkSpec rcvPath chSize digest
           rcvDigest <- liftIO $ C.sha256Hash <$> B.readFile rcvPath
           unless (digest == rcvDigest) $ throwE $ ProtocolTestFailure TSCompareFile $ XFTP (B.unpack $ strEncode srv) DIGEST
           liftError (testErr TSDeleteFile) $ X.deleteXFTPChunk xftp spKey sId
         ok <- netTimeoutInt (tcpTimeout xftpNetworkConfig) nm `timeout` X.closeXFTPClient xftp
-        pure $ either Just (const Nothing) r <|> maybe (Just (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const Nothing) ok
-      Left e -> pure (Just $ testErr TSConnect e)
+        pure $ r >> maybe (Left (ProtocolTestFailure TSDisconnect $ BROKER addr TIMEOUT)) (const $ Right $ serverInfo (X.thParams xftp)) ok
+      Left e -> pure $ Left (testErr TSConnect e)
   where
     addr = B.unpack $ strEncode srv
     testErr :: ProtocolTestStep -> XFTPClientError -> ProtocolTestFailure
@@ -1993,7 +2039,7 @@ getQueueLink c nm userId server lnkId =
 -- resolver) and falls back to a direct send when the proxy is unavailable
 -- (faster but exposes the client IP). Mode selection is delegated to
 -- `sendOrProxySMPCommand`, which honours the network config (SPMNever etc.).
-resolveName :: AgentClient -> NetworkRequestMode -> UserId -> SMPServer -> SimplexDomain -> AM NameRecord
+resolveName :: AgentClient -> NetworkRequestMode -> UserId -> SMPServer -> SimplexDomain -> AM NameResponse
 resolveName c nm userId server domain =
   snd <$> sendOrProxySMPCommand c nm userId server "" "RSLV" NoEntity resolveViaProxy resolveDirectly
   where
@@ -2186,16 +2232,17 @@ agentXFTPDownloadChunk c userId (FileDigest chunkDigest) RcvFileChunkReplica {se
   g <- asks random
   withXFTPClient c (userId, server, chunkDigest) "FGET" $ \xftp -> X.downloadXFTPChunk g xftp replicaKey fId chunkSpec
 
-agentXFTPNewChunk :: AgentClient -> SndFileChunk -> Int -> XFTPServerWithAuth -> AM NewSndChunkReplica
-agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, digest = FileDigest chunkDigest} n (ProtoServerWithAuth srv auth) = do
+agentXFTPNewChunk :: AgentClient -> SndFileChunk -> Int -> XFTPServerWithAuth -> Maybe Word32 -> AM NewSndChunkReplica
+agentXFTPNewChunk c SndFileChunk {userId, chunkSpec = XFTPChunkSpec {chunkSize}, digest = FileDigest chunkDigest} n (ProtoServerWithAuth srv auth) storageHours = do
   rKeys <- xftpRcvKeys n
   (sndKey, replicaKey) <- atomically . C.generateAuthKeyPair C.SEd25519 =<< asks random
   let fileInfo = FileInfo {sndKey, size = chunkSize, digest = chunkDigest}
   logServer "-->" c srv NoEntity "FNEW"
   tSess <- mkTransportSession c userId srv chunkDigest
-  (sndId, rIds) <- withClient c NRMBackground tSess $ \xftp -> X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth
+  (sndId, rIds, expiresAt) <- withClient c NRMBackground tSess $ \xftp ->
+    X.createXFTPChunk xftp replicaKey fileInfo (L.map fst rKeys) auth storageHours
   logServer "<--" c srv NoEntity $ B.unwords ["SIDS", logSecret sndId]
-  pure NewSndChunkReplica {server = srv, replicaId = ChunkReplicaId sndId, replicaKey, rcvIdsKeys = L.toList $ xftpRcvIdsKeys rIds rKeys}
+  pure NewSndChunkReplica {server = srv, replicaId = ChunkReplicaId sndId, replicaKey, rcvIdsKeys = L.toList $ xftpRcvIdsKeys rIds rKeys, expiresAt}
 
 agentXFTPUploadChunk :: AgentClient -> UserId -> FileDigest -> SndFileChunkReplica -> XFTPChunkSpec -> AM ()
 agentXFTPUploadChunk c userId (FileDigest chunkDigest) SndFileChunkReplica {server, replicaId = ChunkReplicaId fId, replicaKey} chunkSpec =

src/Simplex/Messaging/Agent/Env/SQLite.hs

@@ -67,6 +67,8 @@ import Simplex.Messaging.Agent.Store.Interface (DBOpts)
 import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationError (..))
 import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.BBS (BBSPublicKey)
+import Simplex.Messaging.Crypto.Entitlement (EntitlementCredential, entitlementIssuerKeys)
 import Simplex.Messaging.Crypto.Ratchet (VersionRangeE2E, supportedE2EEncryptVRange)
 import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig)
 import Simplex.Messaging.Notifications.Transport (NTFVersion)
@@ -89,6 +91,7 @@ data InitialAgentServers = InitialAgentServers
   { smp :: Map UserId (NonEmpty (ServerCfg 'PSMP)),
     ntf :: [NtfServer],
     xftp :: Map UserId (NonEmpty (ServerCfg 'PXFTP)),
+    entitlements :: Map UserId EntitlementCredential,
     netCfg :: NetworkConfig,
     useServices :: Map UserId Bool,
     presetDomains :: [HostName],
@@ -148,6 +151,7 @@ data AgentConfig = AgentConfig
     smpCfg :: ProtocolClientConfig SMPVersion,
     ntfCfg :: ProtocolClientConfig NTFVersion,
     xftpCfg :: XFTPClientConfig,
+    entitlementKeys :: Map Word16 BBSPublicKey,
     reconnectInterval :: RetryInterval,
     messageRetryInterval :: RetryInterval2,
     userNetworkInterval :: Int,
@@ -158,6 +162,7 @@ data AgentConfig = AgentConfig
     connDeleteDeliveryTimeout :: NominalDiffTime,
     helloTimeout :: NominalDiffTime,
     quotaExceededTimeout :: NominalDiffTime,
+    commandQuotaRetryInterval :: RetryInterval,
     persistErrorInterval :: NominalDiffTime,
     initialCleanupDelay :: Int64,
     cleanupInterval :: Int64,
@@ -226,6 +231,7 @@ defaultAgentConfig =
       smpCfg = defaultSMPClientConfig,
       ntfCfg = defaultNTFClientConfig,
       xftpCfg = defaultXFTPClientConfig,
+      entitlementKeys = entitlementIssuerKeys,
       reconnectInterval = defaultReconnectInterval,
       messageRetryInterval = defaultMessageRetryInterval,
       userNetworkInterval = 1800_000000, -- 30 minutes, should be less than Int32 max value
@@ -236,6 +242,7 @@ defaultAgentConfig =
       connDeleteDeliveryTimeout = 2 * nominalDay,
       helloTimeout = 2 * nominalDay,
       quotaExceededTimeout = 7 * nominalDay,
+      commandQuotaRetryInterval = RetryInterval {initialInterval = 30_000000, increaseAfter = 0, maxInterval = 3600_000000},
       persistErrorInterval = 3, -- seconds
       initialCleanupDelay = 30 * 1000000, -- 30 seconds
       cleanupInterval = 5 * 60 * 1000000, -- 5 minutes

src/Simplex/Messaging/Agent/Protocol.hs

@@ -166,6 +166,8 @@ module Simplex.Messaging.Agent.Protocol
     ConnId,
     ConfirmationId,
     InvitationId,
+    ConnVerifyCodes (..),
+    ContactRequestBinding (..),
     MsgIntegrity (..),
     MsgErrorType (..),
     QueueStatus (..),
@@ -228,7 +230,7 @@ import Data.Type.Equality
 import Data.Typeable (Typeable)
 import Data.Word (Word16, Word32)
 import Simplex.FileTransfer.Description
-import Simplex.FileTransfer.Protocol (FileParty (..))
+import Simplex.FileTransfer.Protocol (FileParty (..), GrantedStorageTime)
 import Simplex.FileTransfer.Transport (XFTPErrorType)
 import Simplex.FileTransfer.Types (FileErrorType)
 import Simplex.Messaging.Agent.QueryString
@@ -404,7 +406,7 @@ data AEvent (e :: AEntity) where
   LINK :: ConnShortLink 'CMContact -> UserConnLinkData 'CMContact -> AEvent AEConn
   LDATA :: FixedLinkData 'CMContact -> ConnLinkData 'CMContact -> ConnectionRequestUri 'CMContact -> AEvent AEConn
   CONF :: ConfirmationId -> PQSupport -> [SMPServer] -> ConnInfo -> AEvent AEConn -- ConnInfo is from sender, [SMPServer] will be empty only in v1 handshake
-  REQ :: InvitationId -> PQSupport -> NonEmpty SMPServer -> ConnInfo -> Bool -> AEvent AEConn -- ConnInfo is from sender; Bool - rejection reason can be sent
+  REQ :: InvitationId -> PQSupport -> NonEmpty SMPServer -> ConnInfo -> ContactRequestBinding -> Bool -> AEvent AEConn -- ConnInfo is from sender; Bool - rejection reason can be sent
   SREQ :: InvitationId -> Maybe C.PublicKeyEd25519 -> MsgBody -> AEvent AEConn
   SSENT :: AgentMsgId -> Maybe SMPServer -> AEvent AEConn
   RJCT :: ConnInfo -> AEvent AEConn
@@ -444,7 +446,7 @@ data AEvent (e :: AEntity) where
   RFERR :: AgentErrorType -> AEvent AERcvFile
   RFWARN :: AgentErrorType -> AEvent AERcvFile
   SFPROG :: Int64 -> Int64 -> AEvent AESndFile
-  SFDONE :: ValidFileDescription 'FSender -> [ValidFileDescription 'FRecipient] -> AEvent AESndFile
+  SFDONE :: ValidFileDescription 'FSender -> [ValidFileDescription 'FRecipient] -> Maybe GrantedStorageTime -> AEvent AESndFile
   SFERR :: AgentErrorType -> AEvent AESndFile
   SFWARN :: AgentErrorType -> AEvent AESndFile
 
@@ -1372,6 +1374,15 @@ type ConfirmationId = ByteString
 
 type InvitationId = ByteString
 
+data ConnVerifyCodes = ConnVerifyCodes
+  { codeAD :: ByteString,
+    codePQ :: Maybe ByteString
+  }
+  deriving (Eq, Show)
+
+data ContactRequestBinding = CRBRatchet ConnVerifyCodes | CRBRequest ByteString
+  deriving (Eq, Show)
+
 extraSMPServerHosts :: Map TransportHost TransportHost
 extraSMPServerHosts =
   M.fromList

src/Simplex/Messaging/Agent/RetryInterval.hs

@@ -10,6 +10,7 @@ module Simplex.Messaging.Agent.RetryInterval
     withRetryInterval,
     withRetryIntervalCount,
     withRetryForeground,
+    withRetryInterval2,
     withRetryLock2,
     updateRetryInterval2,
     nextRetryDelay,
@@ -86,9 +87,24 @@ withRetryForeground ri isForeground isOnline action = callAction 0 $ initialInte
                 | otherwise = (elapsed + delay, nextRetryDelay elapsed' delay ri)
           callAction elapsed' delay'
 
+withRetryInterval2 :: forall m. MonadIO m => RetryInterval2 -> (RI2State -> (RetryIntervalMode -> m ()) -> m ()) -> m ()
+withRetryInterval2 = withRetryWait2 $ liftIO . threadDelay'
+
 -- This function allows action to toggle between slow and fast retry intervals.
 withRetryLock2 :: forall m. MonadIO m => RetryInterval2 -> TMVar () -> (RI2State -> (RetryIntervalMode -> m ()) -> m ()) -> m ()
-withRetryLock2 RetryInterval2 {riSlow, riFast} lock action =
+withRetryLock2 ri lock = withRetryWait2 wait ri
+  where
+    wait delay = do
+      waiting <- newTVarIO True
+      _ <- liftIO . forkIO $ do
+        threadDelay' delay
+        atomically $ whenM (readTVar waiting) $ void $ tryPutTMVar lock ()
+      atomically $ do
+        takeTMVar lock
+        writeTVar waiting False
+
+withRetryWait2 :: forall m. Monad m => (Int64 -> m ()) -> RetryInterval2 -> (RI2State -> (RetryIntervalMode -> m ()) -> m ()) -> m ()
+withRetryWait2 wait RetryInterval2 {riSlow, riFast} action =
   callAction (0, initialInterval riSlow) (0, initialInterval riFast)
   where
     callAction :: (Int64, Int64) -> (Int64, Int64) -> m ()
@@ -102,14 +118,6 @@ withRetryLock2 RetryInterval2 {riSlow, riFast} lock action =
           let elapsed' = elapsed + delay
               delay' = nextRetryDelay elapsed' delay ri
           call (elapsed', delay')
-        wait delay = do
-          waiting <- newTVarIO True
-          _ <- liftIO . forkIO $ do
-            threadDelay' delay
-            atomically $ whenM (readTVar waiting) $ void $ tryPutTMVar lock ()
-          atomically $ do
-            takeTMVar lock
-            writeTVar waiting False
 
 nextRetryDelay :: Int64 -> Int64 -> RetryInterval -> Int64
 nextRetryDelay elapsed delay RetryInterval {increaseAfter, maxInterval} =

src/Simplex/Messaging/Agent/Store.hs

@@ -489,7 +489,8 @@ data PendingCommand = PendingCommand
     corrId :: ACorrId,
     userId :: UserId,
     connId :: ConnId,
-    command :: AgentCommand
+    command :: AgentCommand,
+    createdAt :: UTCTime
   }
 
 data AgentCmdType = ACClient | ACInternal

src/Simplex/Messaging/Agent/Store/AgentStore.hs

@@ -165,6 +165,8 @@ module Simplex.Messaging.Agent.Store.AgentStore
     createRatchet,
     deleteRatchet,
     getRatchet,
+    getRatchetVerifyCodes,
+    ratchetVerifyCodes,
     getRatchetForUpdate,
     getSkippedMsgKeys,
     updateRatchet,
@@ -213,6 +215,7 @@ module Simplex.Messaging.Agent.Store.AgentStore
     -- Rcv files
     createRcvFile,
     createRcvFileRedirect,
+    startPreparedRcvFile,
     lockRcvFileForUpdate,
     getRcvFile,
     getRcvFileByEntityId,
@@ -234,6 +237,7 @@ module Simplex.Messaging.Agent.Store.AgentStore
     getRcvFilesExpired,
     -- Snd files
     createSndFile,
+    startPreparedSndFile,
     lockSndFileForUpdate,
     getSndFile,
     getSndFileByEntityId,
@@ -291,6 +295,7 @@ import Data.ByteString (ByteString)
 import qualified Data.ByteString.Base64.URL as U
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy as LB
+import Data.Either (partitionEithers)
 import Data.Functor (($>))
 import Data.Int (Int64)
 import Data.List (foldl', sortBy)
@@ -309,7 +314,7 @@ import Network.Socket (ServiceName)
 import qualified Network.TLS as TLS
 import Simplex.FileTransfer.Client (XFTPChunkSpec (..))
 import Simplex.FileTransfer.Description
-import Simplex.FileTransfer.Protocol (FileParty (..), SFileParty (..))
+import Simplex.FileTransfer.Protocol (FileParty (..), GrantedStorageTime (..), SFileParty (..))
 import Simplex.FileTransfer.Types
 import Simplex.Messaging.Agent.Protocol
 import Simplex.Messaging.Agent.RetryInterval (RI2State (..))
@@ -1474,9 +1479,11 @@ createSndRatchet db connId ratchetState (CR.AE2ERatchetParams s (CR.E2ERatchetPa
     db
     [sql|
       INSERT INTO ratchets
-        (conn_id, ratchet_state, x3dh_pub_key_1, x3dh_pub_key_2, pq_pub_kem) VALUES (?, ?, ?, ?, ?)
+        (conn_id, ratchet_state, rc_verify_code_ad, rc_verify_code_pq, x3dh_pub_key_1, x3dh_pub_key_2, pq_pub_kem) VALUES (?, ?, ?, ?, ?, ?, ?)
       ON CONFLICT (conn_id) DO UPDATE SET
         ratchet_state = EXCLUDED.ratchet_state,
+        rc_verify_code_ad = EXCLUDED.rc_verify_code_ad,
+        rc_verify_code_pq = EXCLUDED.rc_verify_code_pq,
         x3dh_priv_key_1 = NULL,
         x3dh_priv_key_2 = NULL,
         x3dh_pub_key_1 = EXCLUDED.x3dh_pub_key_1,
@@ -1484,7 +1491,13 @@ createSndRatchet db connId ratchetState (CR.AE2ERatchetParams s (CR.E2ERatchetPa
         pq_priv_kem = NULL,
         pq_pub_kem = EXCLUDED.pq_pub_kem
     |]
-    (connId, ratchetState, x3dhPubKey1, x3dhPubKey2, CR.ARKP s <$> pqPubKem)
+    ((connId, ratchetState) :. verifyCodesRow (ratchetVerifyCodes ratchetState) :. (x3dhPubKey1, x3dhPubKey2, CR.ARKP s <$> pqPubKem))
+
+ratchetVerifyCodes :: RatchetX448 -> ConnVerifyCodes
+ratchetVerifyCodes CR.Ratchet {rcAD, rcVCPQ} = ConnVerifyCodes {codeAD = C.sha256Hash $ unStr rcAD, codePQ = unStr <$> rcVCPQ}
+
+verifyCodesRow :: ConnVerifyCodes -> (Binary ByteString, Maybe (Binary ByteString))
+verifyCodesRow ConnVerifyCodes {codeAD, codePQ} = (Binary codeAD, Binary <$> codePQ)
 
 getSndRatchet :: DB.Connection -> ConnId -> CR.VersionE2E -> IO (Either StoreError (RatchetX448, CR.AE2ERatchetParams 'C.X448))
 getSndRatchet db connId v =
@@ -1505,10 +1518,12 @@ createRatchet db connId rc =
   DB.execute
     db
     [sql|
-      INSERT INTO ratchets (conn_id, ratchet_state)
-      VALUES (?, ?)
+      INSERT INTO ratchets (conn_id, ratchet_state, rc_verify_code_ad, rc_verify_code_pq)
+      VALUES (?, ?, ?, ?)
       ON CONFLICT (conn_id) DO UPDATE SET
-        ratchet_state = ?,
+        ratchet_state = EXCLUDED.ratchet_state,
+        rc_verify_code_ad = EXCLUDED.rc_verify_code_ad,
+        rc_verify_code_pq = EXCLUDED.rc_verify_code_pq,
         x3dh_priv_key_1 = NULL,
         x3dh_priv_key_2 = NULL,
         x3dh_pub_key_1 = NULL,
@@ -1516,7 +1531,42 @@ createRatchet db connId rc =
         pq_priv_kem = NULL,
         pq_pub_kem = NULL
     |]
-    (connId, rc, rc)
+    ((connId, rc) :. verifyCodesRow (ratchetVerifyCodes rc))
+
+getRatchetVerifyCodes :: DB.Connection -> [ConnId] -> IO (Map ConnId ConnVerifyCodes)
+getRatchetVerifyCodes db connIds = do
+  (saved, computed) <- partitionEithers . mapMaybe rowCodes <$> selectCodes
+  stored <- saveCodes computed
+  pure $ M.fromList $ saved <> stored
+  where
+    rowCodes (connId, codeAD_, codePQ_, rc_) = case codeAD_ of
+      Just codeAD -> Just $ Left $ toCodes (connId, codeAD, codePQ_)
+      Nothing -> Right . (connId,) . ratchetVerifyCodes <$> rc_
+    toCodes (connId, Binary codeAD, codePQ_) = (connId, ConnVerifyCodes {codeAD, codePQ = fromBinary <$> codePQ_})
+    codesRow (connId, cs) = verifyCodesRow cs :. Only connId
+    codesQuery :: Query
+    codesQuery = "SELECT conn_id, rc_verify_code_ad, rc_verify_code_pq, CASE WHEN rc_verify_code_ad IS NULL THEN ratchet_state END FROM ratchets"
+    selectCodes :: IO [(ConnId, Maybe (Binary ByteString), Maybe (Binary ByteString), Maybe RatchetX448)]
+    saveCodes :: [(ConnId, ConnVerifyCodes)] -> IO [(ConnId, ConnVerifyCodes)]
+#if defined(dbPostgres)
+    selectCodes = DB.query db (codesQuery <> " WHERE conn_id IN ?") (Only (In connIds))
+    saveCodes cs =
+      map toCodes
+        <$> DB.returning
+          db
+          [sql|
+            UPDATE ratchets r
+            SET rc_verify_code_ad = COALESCE(r.rc_verify_code_ad, (upd.rc_verify_code_ad :: BYTEA)),
+              rc_verify_code_pq = CASE WHEN r.rc_verify_code_ad IS NULL THEN (upd.rc_verify_code_pq :: BYTEA) ELSE r.rc_verify_code_pq END
+            FROM (VALUES(?, ?, ?)) AS upd(rc_verify_code_ad, rc_verify_code_pq, conn_id)
+            WHERE r.conn_id = (upd.conn_id :: BYTEA)
+            RETURNING r.conn_id, r.rc_verify_code_ad, r.rc_verify_code_pq
+          |]
+          (map codesRow cs)
+#else
+    selectCodes = concat <$> mapM (DB.query db (codesQuery <> " WHERE conn_id = ?") . Only) connIds
+    saveCodes cs = cs <$ unless (null cs) (DB.executeMany db "UPDATE ratchets SET rc_verify_code_ad = ?, rc_verify_code_pq = ? WHERE conn_id = ?" $ map codesRow cs)
+#endif
 
 deleteRatchet :: DB.Connection -> ConnId -> IO ()
 deleteRatchet db connId =
@@ -1668,7 +1718,7 @@ getPendingServerCommand db connId srv_ = getWorkItem "command" getCmdId getComma
         DB.query
           db
           [sql|
-            SELECT c.corr_id, cs.user_id, c.command
+            SELECT c.corr_id, cs.user_id, c.command, c.created_at
             FROM commands c
             JOIN connections cs USING (conn_id)
             WHERE c.command_id = ?
@@ -1676,7 +1726,7 @@ getPendingServerCommand db connId srv_ = getWorkItem "command" getCmdId getComma
           (Only cmdId)
       where
         err = SEInternal $ "command  " <> bshow cmdId <> " returned []"
-        pendingCommand (corrId, userId, command) = PendingCommand {cmdId, corrId, userId, connId, command}
+        pendingCommand (corrId, userId, command, createdAt) = PendingCommand {cmdId, corrId, userId, connId, command, createdAt}
     markCommandFailed cmdId = DB.execute db "UPDATE commands SET failed = 1 WHERE command_id = ?" (Only cmdId)
 
 updateCommandServer :: DB.Connection -> AsyncCmdId -> SMPServer -> IO (Either StoreError ())
@@ -3115,6 +3165,29 @@ createRcvFileRedirect db gVar userId redirectFd@FileDescription {chunks = redire
           chunks = []
         }
 
+startPreparedRcvFile :: DB.Connection -> RcvFileId -> IO (Either StoreError [XFTPServer])
+startPreparedRcvFile db rcvFileEntityId = runExceptT $ do
+  rcvFileId <- ExceptT $ getRcvFileIdByEntityId_ db rcvFileEntityId
+  liftIO $ do
+    updatedAt <- getCurrentTime
+    DB.execute
+      db
+      "UPDATE rcv_files SET status = ?, updated_at = ? WHERE (rcv_file_id = ? OR redirect_id = ?) AND status = ?"
+      (RFSReceiving, updatedAt, rcvFileId, rcvFileId, RFSPrepared)
+    map toXFTPServer
+      <$> DB.query
+        db
+        [sql|
+          SELECT DISTINCT
+            s.xftp_host, s.xftp_port, s.xftp_key_hash
+          FROM rcv_file_chunk_replicas r
+          JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id
+          JOIN rcv_file_chunks c ON c.rcv_file_chunk_id = r.rcv_file_chunk_id
+          JOIN rcv_files f ON f.rcv_file_id = c.rcv_file_id
+          WHERE (f.rcv_file_id = ? OR f.redirect_id = ?) AND r.replica_number = 1
+        |]
+        (rcvFileId, rcvFileId)
+
 insertRcvFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> CryptoFile -> Maybe DBRcvFileId -> Maybe RcvFileId -> Bool -> IO (Either StoreError (RcvFileId, DBRcvFileId))
 insertRcvFile db gVar userId FileDescription {size, digest, key, nonce, chunkSize, redirect} prefixPath tmpPath (CryptoFile savePath cfArgs) redirectId_ redirectEntityId_ approvedRelays = runExceptT $ do
   let (redirectDigest_, redirectSize_) = case redirect of
@@ -3125,7 +3198,7 @@ insertRcvFile db gVar userId FileDescription {size, digest, key, nonce, chunkSiz
       DB.execute
         db
         "INSERT INTO rcv_files (rcv_file_entity_id, user_id, size, digest, key, nonce, chunk_size, prefix_path, tmp_path, save_path, save_file_key, save_file_nonce, status, redirect_id, redirect_entity_id, redirect_digest, redirect_size, approved_relays) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)"
-        ((Binary rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, prefixPath, tmpPath) :. (savePath, fileKey <$> cfArgs, fileNonce <$> cfArgs, RFSReceiving, redirectId_, Binary <$> redirectEntityId_, redirectDigest_, redirectSize_, BI approvedRelays))
+        ((Binary rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, prefixPath, tmpPath) :. (savePath, fileKey <$> cfArgs, fileNonce <$> cfArgs, RFSPrepared, redirectId_, Binary <$> redirectEntityId_, redirectDigest_, redirectSize_, BI approvedRelays))
   rcvFileId <- liftIO $ insertedRowId db
   pure (rcvFileEntityId, rcvFileId)
 
@@ -3424,19 +3497,29 @@ getRcvFilesExpired db ttl = do
     |]
     (Only cutoffTs)
 
-createSndFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> CryptoFile -> Int -> FilePath -> C.SbKey -> C.CbNonce -> Maybe RedirectFileInfo -> IO (Either StoreError SndFileId)
-createSndFile db gVar userId (CryptoFile path cfArgs) numRecipients prefixPath key nonce redirect_ =
+createSndFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> CryptoFile -> Int -> FilePath -> C.SbKey -> C.CbNonce -> Maybe RedirectFileInfo -> Maybe Word32 -> IO (Either StoreError SndFileId)
+createSndFile db gVar userId (CryptoFile path cfArgs) numRecipients prefixPath key nonce redirect_ storageHours =
   createWithRandomId db gVar $ \sndFileEntityId ->
     DB.execute
       db
-      "INSERT INTO snd_files (snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, prefix_path, key, nonce, status, redirect_size, redirect_digest) VALUES (?,?,?,?,?,?,?,?,?,?,?,?)"
-      ((Binary sndFileEntityId, userId, path, fileKey <$> cfArgs, fileNonce <$> cfArgs, numRecipients) :. (prefixPath, key, nonce, SFSNew, redirectSize_, redirectDigest_))
+      "INSERT INTO snd_files (snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, prefix_path, key, nonce, status, redirect_size, redirect_digest, storage_time) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)"
+      ((Binary sndFileEntityId, userId, path, fileKey <$> cfArgs, fileNonce <$> cfArgs, numRecipients) :. (prefixPath, key, nonce, SFSPrepared, redirectSize_, redirectDigest_, storageHours))
   where
     (redirectSize_, redirectDigest_) =
       case redirect_ of
         Nothing -> (Nothing, Nothing)
         Just RedirectFileInfo {size, digest} -> (Just size, Just digest)
 
+startPreparedSndFile :: DB.Connection -> SndFileId -> IO (Either StoreError ())
+startPreparedSndFile db sndFileEntityId = runExceptT $ do
+  sndFileId <- ExceptT $ getSndFileIdByEntityId_ db sndFileEntityId
+  liftIO $ do
+    updatedAt <- getCurrentTime
+    DB.execute
+      db
+      "UPDATE snd_files SET status = ?, updated_at = ? WHERE snd_file_id = ? AND status = ?"
+      (SFSNew, updatedAt, sndFileId, SFSPrepared)
+
 getSndFileByEntityId :: DB.Connection -> SndFileId -> IO (Either StoreError SndFile)
 getSndFileByEntityId db sndFileEntityId = runExceptT $ do
   sndFileId <- ExceptT $ getSndFileIdByEntityId_ db sndFileEntityId
@@ -3466,7 +3549,7 @@ getSndFile db sndFileId = runExceptT $ do
         DB.query
           db
           ( [sql|
-              SELECT snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, digest, prefix_path, key, nonce, status, deleted, redirect_size, redirect_digest
+              SELECT snd_file_entity_id, user_id, path, src_file_key, src_file_nonce, num_recipients, digest, prefix_path, key, nonce, status, deleted, redirect_size, redirect_digest, storage_time
               FROM snd_files
               WHERE snd_file_id = ?
             |]
@@ -3476,12 +3559,12 @@ getSndFile db sndFileId = runExceptT $ do
           )
           (Only sndFileId)
       where
-        toFile :: (SndFileId, UserId, FilePath, Maybe C.SbKey, Maybe C.CbNonce, Int, Maybe FileDigest, Maybe FilePath, C.SbKey, C.CbNonce) :. (SndFileStatus, BoolInt, Maybe (FileSize Int64), Maybe FileDigest) -> SndFile
-        toFile ((sndFileEntityId, userId, srcPath, srcKey_, srcNonce_, numRecipients, digest, prefixPath, key, nonce) :. (status, BI deleted, redirectSize_, redirectDigest_)) =
+        toFile :: (SndFileId, UserId, FilePath, Maybe C.SbKey, Maybe C.CbNonce, Int, Maybe FileDigest, Maybe FilePath, C.SbKey, C.CbNonce) :. (SndFileStatus, BoolInt, Maybe (FileSize Int64), Maybe FileDigest, Maybe Word32) -> SndFile
+        toFile ((sndFileEntityId, userId, srcPath, srcKey_, srcNonce_, numRecipients, digest, prefixPath, key, nonce) :. (status, BI deleted, redirectSize_, redirectDigest_, storageHours)) =
           let cfArgs = CFArgs <$> srcKey_ <*> srcNonce_
               srcFile = CryptoFile srcPath cfArgs
               redirect = RedirectFileInfo <$> redirectSize_ <*> redirectDigest_
-           in SndFile {sndFileId, sndFileEntityId, userId, srcFile, numRecipients, digest, prefixPath, key, nonce, status, deleted, redirect, chunks = []}
+           in SndFile {sndFileId, sndFileEntityId, userId, srcFile, numRecipients, digest, prefixPath, key, nonce, status, deleted, redirect, storageHours, chunks = []}
     getChunks :: SndFileId -> UserId -> Int -> FilePath -> IO [SndFileChunk]
     getChunks sndFileEntityId userId numRecipients filePrefixPath = do
       chunks <-
@@ -3510,7 +3593,7 @@ getSndFile db sndFileId = runExceptT $ do
             db
             [sql|
               SELECT
-                r.snd_file_chunk_replica_id, r.replica_id, r.replica_key, r.replica_status, r.delay, r.retries,
+                r.snd_file_chunk_replica_id, r.replica_id, r.replica_key, r.replica_status, r.delay, r.retries, r.replica_expires_at,
                 s.xftp_host, s.xftp_port, s.xftp_key_hash
               FROM snd_file_chunk_replicas r
               JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id
@@ -3521,10 +3604,10 @@ getSndFile db sndFileId = runExceptT $ do
         rcvIdsKeys <- getChunkReplicaRecipients_ db sndChunkReplicaId
         pure (replica :: SndFileChunkReplica) {rcvIdsKeys}
       where
-        toReplica :: (Int64, ChunkReplicaId, C.APrivateAuthKey, SndFileReplicaStatus, Maybe Int64, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> SndFileChunkReplica
-        toReplica (sndChunkReplicaId, replicaId, replicaKey, replicaStatus, delay, retries, host, port, keyHash) =
+        toReplica :: (Int64, ChunkReplicaId, C.APrivateAuthKey, SndFileReplicaStatus, Maybe Int64, Int, Maybe Int64, NonEmpty TransportHost, ServiceName, C.KeyHash) -> SndFileChunkReplica
+        toReplica (sndChunkReplicaId, replicaId, replicaKey, replicaStatus, delay, retries, expiresAtSec, host, port, keyHash) =
           let server = XFTPServer host port keyHash
-           in SndFileChunkReplica {sndChunkReplicaId, server, replicaId, replicaKey, replicaStatus, delay, retries, rcvIdsKeys = []}
+           in SndFileChunkReplica {sndChunkReplicaId, server, replicaId, replicaKey, replicaStatus, delay, retries, expiresAt = GSTExpires <$> expiresAtSec, rcvIdsKeys = []}
 
 getChunkReplicaRecipients_ :: DB.Connection -> Int64 -> IO [(ChunkReplicaId, C.APrivateAuthKey)]
 getChunkReplicaRecipients_ db replicaId =
@@ -3605,16 +3688,16 @@ createSndFileReplica :: DB.Connection -> SndFileChunk -> NewSndChunkReplica -> I
 createSndFileReplica db SndFileChunk {sndChunkId} = createSndFileReplica_ db sndChunkId
 
 createSndFileReplica_ :: DB.Connection -> Int64 -> NewSndChunkReplica -> IO ()
-createSndFileReplica_ db sndChunkId NewSndChunkReplica {server, replicaId, replicaKey, rcvIdsKeys} = do
+createSndFileReplica_ db sndChunkId NewSndChunkReplica {server, replicaId, replicaKey, rcvIdsKeys, expiresAt} = do
   srvId <- createXFTPServer_ db server
   DB.execute
     db
     [sql|
       INSERT INTO snd_file_chunk_replicas
-        (snd_file_chunk_id, replica_number, xftp_server_id, replica_id, replica_key, replica_status)
-      VALUES (?,?,?,?,?,?)
+        (snd_file_chunk_id, replica_number, xftp_server_id, replica_id, replica_key, replica_status, replica_expires_at)
+      VALUES (?,?,?,?,?,?,?)
     |]
-    (sndChunkId, 1 :: Int, srvId, replicaId, replicaKey, SFRSCreated)
+    (sndChunkId, 1 :: Int, srvId, replicaId, replicaKey, SFRSCreated, epochSeconds <$> expiresAt)
   rId <- insertedRowId db
   forM_ rcvIdsKeys $ \(rcvId, rcvKey) -> do
     DB.execute
@@ -3660,7 +3743,7 @@ getNextSndChunkToUpload db server@ProtocolServer {host, port, keyHash} ttl = do
               SELECT
                 f.snd_file_id, f.snd_file_entity_id, f.user_id, f.num_recipients, f.prefix_path,
                 c.snd_file_chunk_id, c.chunk_no, c.chunk_offset, c.chunk_size, c.digest,
-                r.snd_file_chunk_replica_id, r.replica_id, r.replica_key, r.replica_status, r.delay, r.retries
+                r.snd_file_chunk_replica_id, r.replica_id, r.replica_key, r.replica_status, r.delay, r.retries, r.replica_expires_at
               FROM snd_file_chunk_replicas r
               JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id
               JOIN snd_file_chunks c ON c.snd_file_chunk_id = r.snd_file_chunk_id
@@ -3674,8 +3757,8 @@ getNextSndChunkToUpload db server@ProtocolServer {host, port, keyHash} ttl = do
           pure (replica :: SndFileChunkReplica) {rcvIdsKeys}
         pure (chunk {replicas = replicas'} :: SndFileChunk)
       where
-        toChunk :: ((DBSndFileId, SndFileId, UserId, Int, FilePath) :. (Int64, Int, Int64, Word32, FileDigest) :. (Int64, ChunkReplicaId, C.APrivateAuthKey, SndFileReplicaStatus, Maybe Int64, Int)) -> SndFileChunk
-        toChunk ((sndFileId, sndFileEntityId, userId, numRecipients, filePrefixPath) :. (sndChunkId, chunkNo, chunkOffset, chunkSize, digest) :. (sndChunkReplicaId, replicaId, replicaKey, replicaStatus, delay, retries)) =
+        toChunk :: ((DBSndFileId, SndFileId, UserId, Int, FilePath) :. (Int64, Int, Int64, Word32, FileDigest) :. (Int64, ChunkReplicaId, C.APrivateAuthKey, SndFileReplicaStatus, Maybe Int64, Int, Maybe Int64)) -> SndFileChunk
+        toChunk ((sndFileId, sndFileEntityId, userId, numRecipients, filePrefixPath) :. (sndChunkId, chunkNo, chunkOffset, chunkSize, digest) :. (sndChunkReplicaId, replicaId, replicaKey, replicaStatus, delay, retries, expiresAtSec)) =
           let chunkSpec = XFTPChunkSpec {filePath = sndFileEncPath filePrefixPath, chunkOffset, chunkSize}
            in SndFileChunk
                 { sndFileId,
@@ -3687,7 +3770,7 @@ getNextSndChunkToUpload db server@ProtocolServer {host, port, keyHash} ttl = do
                   chunkSpec,
                   digest,
                   filePrefixPath,
-                  replicas = [SndFileChunkReplica {sndChunkReplicaId, server, replicaId, replicaKey, replicaStatus, delay, retries, rcvIdsKeys = []}]
+                  replicas = [SndFileChunkReplica {sndChunkReplicaId, server, replicaId, replicaKey, replicaStatus, delay, retries, expiresAt = GSTExpires <$> expiresAtSec, rcvIdsKeys = []}]
                 }
 
 updateSndChunkReplicaDelay :: DB.Connection -> Int64 -> Int64 -> IO ()

src/Simplex/Messaging/Agent/Store/Postgres/DB.hs

@@ -13,6 +13,7 @@ module Simplex.Messaging.Agent.Store.Postgres.DB
     execute,
     execute_,
     executeMany,
+    returning,
     query,
     query_,
     blobFieldDecoder,
@@ -60,6 +61,10 @@ executeMany :: ToRow q => PSQL.Connection -> Query -> [q] -> IO ()
 executeMany db q qs = void $ PSQL.executeMany db q qs `E.catch` addSql q
 {-# INLINE executeMany #-}
 
+returning :: (ToRow q, FromRow r) => PSQL.Connection -> Query -> [q] -> IO [r]
+returning db q qs = PSQL.returning db q qs `E.catch` addSql q
+{-# INLINE returning #-}
+
 query :: (ToRow q, FromRow r) => PSQL.Connection -> Query -> q -> IO [r]
 query db q qs = PSQL.query db q qs `E.catch` addSql q
 {-# INLINE query #-}

src/Simplex/Messaging/Agent/Store/Postgres/Migrations/App.hs

@@ -14,6 +14,8 @@ 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_rpc
+import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260823_snd_files_entitlement
+import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260919_ratchet_verify_codes
 import Simplex.Messaging.Agent.Store.Shared (Migration (..))
 
 schemaMigrations :: [(String, Text, Maybe Text)]
@@ -27,7 +29,9 @@ 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_rpc", m20260712_address_dr_rpc, Just down_m20260712_address_dr_rpc)
+    ("20260712_address_dr_rpc", m20260712_address_dr_rpc, Just down_m20260712_address_dr_rpc),
+    ("20260823_snd_files_entitlement", m20260823_snd_files_entitlement, Just down_m20260823_snd_files_entitlement),
+    ("20260919_ratchet_verify_codes", m20260919_ratchet_verify_codes, Just down_m20260919_ratchet_verify_codes)
   ]
 
 -- | The list of migrations in ascending order by date

src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20260823_snd_files_entitlement.hs

@@ -0,0 +1,21 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260823_snd_files_entitlement where
+
+import Data.Text (Text)
+import Text.RawString.QQ (r)
+
+m20260823_snd_files_entitlement :: Text
+m20260823_snd_files_entitlement =
+  [r|
+ALTER TABLE snd_files ADD COLUMN storage_time BIGINT;
+ALTER TABLE snd_file_chunk_replicas ADD COLUMN replica_expires_at BIGINT;
+|]
+
+down_m20260823_snd_files_entitlement :: Text
+down_m20260823_snd_files_entitlement =
+  [r|
+ALTER TABLE snd_file_chunk_replicas DROP COLUMN replica_expires_at;
+ALTER TABLE snd_files DROP COLUMN storage_time;
+|]

src/Simplex/Messaging/Agent/Store/Postgres/Migrations/M20260919_ratchet_verify_codes.hs

@@ -0,0 +1,21 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260919_ratchet_verify_codes where
+
+import Data.Text (Text)
+import Text.RawString.QQ (r)
+
+m20260919_ratchet_verify_codes :: Text
+m20260919_ratchet_verify_codes =
+  [r|
+ALTER TABLE ratchets ADD COLUMN rc_verify_code_ad BYTEA;
+ALTER TABLE ratchets ADD COLUMN rc_verify_code_pq BYTEA;
+|]
+
+down_m20260919_ratchet_verify_codes :: Text
+down_m20260919_ratchet_verify_codes =
+  [r|
+ALTER TABLE ratchets DROP COLUMN rc_verify_code_pq;
+ALTER TABLE ratchets DROP COLUMN rc_verify_code_ad;
+|]

src/Simplex/Messaging/Agent/Store/Postgres/Migrations/agent_postgres_schema.sql

@@ -448,7 +448,9 @@ CREATE TABLE smp_agent_test_protocol_schema.ratchets (
     x3dh_pub_key_1 bytea,
     x3dh_pub_key_2 bytea,
     pq_priv_kem bytea,
-    pq_pub_kem bytea
+    pq_pub_kem bytea,
+    rc_verify_code_ad bytea,
+    rc_verify_code_pq bytea
 );
 
 
@@ -682,7 +684,8 @@ CREATE TABLE smp_agent_test_protocol_schema.snd_file_chunk_replicas (
     delay bigint,
     retries bigint DEFAULT 0 NOT NULL,
     created_at timestamp with time zone DEFAULT now() NOT NULL,
-    updated_at timestamp with time zone DEFAULT now() NOT NULL
+    updated_at timestamp with time zone DEFAULT now() NOT NULL,
+    replica_expires_at bigint
 );
 
 
@@ -741,7 +744,8 @@ CREATE TABLE smp_agent_test_protocol_schema.snd_files (
     src_file_nonce bytea,
     failed smallint DEFAULT 0,
     redirect_size bigint,
-    redirect_digest bytea
+    redirect_digest bytea,
+    storage_time bigint
 );
 
 

src/Simplex/Messaging/Agent/Store/SQLite/Migrations/App.hs

@@ -50,6 +50,8 @@ 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_rpc
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260823_snd_files_entitlement
+import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260919_ratchet_verify_codes
 import Simplex.Messaging.Agent.Store.Shared (Migration (..))
 
 schemaMigrations :: [(String, Query, Maybe Query)]
@@ -99,7 +101,9 @@ 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_rpc", m20260712_address_dr_rpc, Just down_m20260712_address_dr_rpc)
+    ("m20260712_address_dr_rpc", m20260712_address_dr_rpc, Just down_m20260712_address_dr_rpc),
+    ("m20260823_snd_files_entitlement", m20260823_snd_files_entitlement, Just down_m20260823_snd_files_entitlement),
+    ("m20260919_ratchet_verify_codes", m20260919_ratchet_verify_codes, Just down_m20260919_ratchet_verify_codes)
   ]
 
 -- | The list of migrations in ascending order by date

src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20260823_snd_files_entitlement.hs

@@ -0,0 +1,20 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260823_snd_files_entitlement where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20260823_snd_files_entitlement :: Query
+m20260823_snd_files_entitlement =
+  [sql|
+ALTER TABLE snd_files ADD COLUMN storage_time INTEGER;
+ALTER TABLE snd_file_chunk_replicas ADD COLUMN replica_expires_at INTEGER;
+  |]
+
+down_m20260823_snd_files_entitlement :: Query
+down_m20260823_snd_files_entitlement =
+  [sql|
+ALTER TABLE snd_file_chunk_replicas DROP COLUMN replica_expires_at;
+ALTER TABLE snd_files DROP COLUMN storage_time;
+  |]

src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20260919_ratchet_verify_codes.hs

@@ -0,0 +1,20 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260919_ratchet_verify_codes where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20260919_ratchet_verify_codes :: Query
+m20260919_ratchet_verify_codes =
+  [sql|
+ALTER TABLE ratchets ADD COLUMN rc_verify_code_ad BLOB;
+ALTER TABLE ratchets ADD COLUMN rc_verify_code_pq BLOB;
+  |]
+
+down_m20260919_ratchet_verify_codes :: Query
+down_m20260919_ratchet_verify_codes =
+  [sql|
+ALTER TABLE ratchets DROP COLUMN rc_verify_code_pq;
+ALTER TABLE ratchets DROP COLUMN rc_verify_code_ad;
+  |]

src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql

@@ -182,7 +182,9 @@ CREATE TABLE ratchets(
   x3dh_pub_key_1 BLOB,
   x3dh_pub_key_2 BLOB,
   pq_priv_kem BLOB,
-  pq_pub_kem BLOB
+  pq_pub_kem BLOB,
+  rc_verify_code_ad BLOB,
+  rc_verify_code_pq BLOB
 ) WITHOUT ROWID, STRICT;
 CREATE TABLE skipped_messages(
   skipped_message_id INTEGER PRIMARY KEY,
@@ -352,7 +354,8 @@ CREATE TABLE snd_files(
   src_file_nonce BLOB,
   failed INTEGER DEFAULT 0,
   redirect_size INTEGER,
-  redirect_digest BLOB
+  redirect_digest BLOB,
+  storage_time INTEGER
 ) STRICT;
 CREATE TABLE snd_file_chunks(
   snd_file_chunk_id INTEGER PRIMARY KEY,
@@ -376,6 +379,8 @@ CREATE TABLE snd_file_chunk_replicas(
   retries INTEGER NOT NULL DEFAULT 0,
   created_at TEXT NOT NULL DEFAULT(datetime('now')),
   updated_at TEXT NOT NULL DEFAULT(datetime('now'))
+  ,
+  replica_expires_at INTEGER
 ) STRICT;
 CREATE TABLE snd_file_chunk_replica_recipients(
   snd_file_chunk_replica_recipient_id INTEGER PRIMARY KEY,

src/Simplex/Messaging/Client.hs

@@ -160,13 +160,14 @@ import Network.Socket (HostName, ServiceName)
 import Network.Socks5 (SocksCredentials (..))
 import Numeric.Natural
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.Entitlement (EntitlementProof)
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, sumTypeJSON)
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Protocol.Types
 import Simplex.Messaging.Server.QueueStore.QueueInfo
-import Simplex.Messaging.SimplexName (SimplexDomain)
+import Simplex.Messaging.SimplexName (SimplexDomain, fullDomainName)
 import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport
@@ -482,7 +483,9 @@ data ProtocolClientConfig v = ProtocolClientConfig
     -- | Whether connecting client is a proxy server. See comment in ClientHandshake
     proxyServer :: Bool,
     -- | send SNI to server, False for SMP
-    useSNI :: Bool
+    useSNI :: Bool,
+    -- | proof of the user entitlement to send in the handshake, bound to the session
+    mkEntitlementProof :: SessionId -> IO (Maybe EntitlementProof)
   }
 
 -- | Default protocol client configuration.
@@ -497,7 +500,8 @@ defaultClientConfig clientALPN useSNI serverVRange =
       serverVRange,
       agreeSecret = False,
       proxyServer = False,
-      useSNI
+      useSNI,
+      mkEntitlementProof = \_ -> pure Nothing
     }
 {-# INLINE defaultClientConfig #-}
 
@@ -568,7 +572,7 @@ type SMPTransportSession = TransportSession BrokerMsg
 -- A single queue can be used for multiple 'SMPClient' instances,
 -- as 'SMPServerTransmission' includes server information.
 getProtocolClient :: forall v err msg. Protocol v err msg => TVar ChaChaDRG -> NetworkRequestMode -> TransportSession msg -> ProtocolClientConfig v -> [HostName] -> Maybe (TBQueue (ServerTransmissionBatch v err msg)) -> UTCTime -> (ProtocolClient v err msg -> IO ()) -> IO (Either (ProtocolClientError err) (ProtocolClient v err msg))
-getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serviceCredentials, serverVRange, agreeSecret, proxyServer, useSNI} presetDomains msgQ proxySessTs disconnected = do
+getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qSize, networkConfig, clientALPN, serviceCredentials, serverVRange, agreeSecret, proxyServer, useSNI, mkEntitlementProof} presetDomains msgQ proxySessTs disconnected = do
   case chooseTransportHost networkConfig (host srv) of
     Right useHost ->
       (getCurrentTime >>= mkProtocolClient useHost >>= runClient useTransport useHost)
@@ -635,7 +639,7 @@ getProtocolClient g nm transportSession@(_, srv, _) cfg@ProtocolClientConfig {qS
     client _ c cVar h = do
       ks <- if agreeSecret then Just <$> atomically (C.generateKeyPair g) else pure Nothing
       serviceKeys_ <- mapM (\creds -> (creds,) <$> atomically (C.generateKeyPair g)) serviceCredentials
-      runExceptT (protocolClientHandshake @v @err @msg h ks (keyHash srv) serverVRange proxyServer serviceKeys_) >>= \case
+      runExceptT (protocolClientHandshake @v @err @msg h ks (keyHash srv) serverVRange proxyServer serviceKeys_ mkEntitlementProof) >>= \case
         Left e -> atomically . putTMVar cVar . Left $ PCETransportError e
         Right th@THandle {params} -> do
           sessionTs <- getCurrentTime
@@ -1054,11 +1058,11 @@ proxySMPMessage c nm proxiedRelay spKey sId flags msg = proxyOKSMPCommand c nm p
 -- through `proxySMPCommand` and pattern-matches the expected RNAME response.
 -- Version-gated on the destination relay (mirrors `connectSMPProxiedRelay`):
 -- the client never sends RSLV to a relay that predates names support.
-proxyResolveName :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> SimplexDomain -> ExceptT SMPClientError IO (Either ProxyClientError NameRecord)
+proxyResolveName :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> SimplexDomain -> ExceptT SMPClientError IO (Either ProxyClientError NameResponse)
 proxyResolveName c nm proxiedRelay name
   | prVersion proxiedRelay >= namesSMPVersion =
-      proxySMPCommand c nm proxiedRelay Nothing NoEntity (RSLV name) >>= \case
-        Right (RNAME nr) -> pure $ Right nr
+      proxySMPCommand c nm proxiedRelay Nothing NoEntity (RSLV (NQDomain name)) >>= \case
+        Right (RNAME reg) | resolvedNameOrNotFound name reg -> pure $ Right reg
         Right r -> throwE $ unexpectedResponse r
         Left e -> pure $ Left e
   | otherwise = throwE $ PCETransportError TEVersion
@@ -1066,16 +1070,21 @@ proxyResolveName c nm proxiedRelay name
 -- | Direct (non-PFWD) name resolution. Exposes the client IP to the resolver;
 -- callers that want anonymity should use `proxyResolveName` via the standard
 -- proxy fallback in the agent. RSLV requires no entity ID or authorization
--- (see `noAuthCmd` in Protocol.hs). Version-gated on the session here, not the
--- encoder, so an old server never receives RSLV.
-directResolveName :: SMPClient -> NetworkRequestMode -> SimplexDomain -> ExceptT SMPClientError IO NameRecord
+-- (see `noAuthCmd` in Protocol.hs). Gated on the session version, below which
+-- the server has no RSLV at all; the encoder gates the query format separately.
+directResolveName :: SMPClient -> NetworkRequestMode -> SimplexDomain -> ExceptT SMPClientError IO NameResponse
 directResolveName c nm name
   | thVersion (thParams c) >= namesSMPVersion =
-      sendProtocolCommand c nm Nothing NoEntity (Cmd SResolver (RSLV name)) >>= \case
-        RNAME nr -> pure nr
+      sendProtocolCommand c nm Nothing NoEntity (Cmd SResolver (RSLV (NQDomain name))) >>= \case
+        RNAME reg | resolvedNameOrNotFound name reg -> pure reg
         r -> throwE $ unexpectedResponse r
   | otherwise = throwE $ PCETransportError TEVersion
 
+resolvedNameOrNotFound :: SimplexDomain -> NameResponse -> Bool
+resolvedNameOrNotFound d NameResponse {registration} = case registration of
+  NRRegistered {nameRecord} -> T.toLower (nrName nameRecord) == fullDomainName d
+  _ -> True
+
 -- | Acknowledge message delivery (server deletes the message).
 --
 -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#acknowledge-message-delivery

src/Simplex/Messaging/Crypto/BBS.hs

@@ -17,6 +17,7 @@ module Simplex.Messaging.Crypto.BBS
     BBSProof (..),
     BBSHeader (..),
     BBSPresHeader (..),
+    FixedBS (..),
     bbsKeyGen,
     bbsPublicKey,
     bbsSign,
@@ -33,7 +34,9 @@ import Data.Proxy (Proxy (..))
 import Foreign
 import Foreign.C
 import GHC.TypeLits (KnownNat, KnownSymbol, Nat, Symbol, natVal, symbolVal)
+import Simplex.Messaging.Encoding (Encoding (..), Large (..))
 import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Util ((<$?>))
 import System.IO.Unsafe (unsafePerformIO)
 
 -- Note: the data constructors below are unchecked escape hatches for trusted,
@@ -71,8 +74,8 @@ newtype BBSPresHeader = BBSPresHeader ByteString
   deriving (ToJSON, FromJSON) via (StrJSON "BBSPresHeader" BBSPresHeader)
 
 -- | A ByteString validated to be exactly @n@ bytes when parsed via StrEncoding
--- (and the JSON derived from it). Local to BBS, where every key/signature is a
--- fixed size; @name@ appears in the decode error only.
+-- (and the JSON derived from it), for keys and signatures of a fixed size;
+-- @name@ appears in the decode error only.
 newtype FixedBS (name :: Symbol) (n :: Nat) = FixedBS ByteString
 
 instance forall name n. (KnownSymbol name, KnownNat n) => StrEncoding (FixedBS name n) where
@@ -97,14 +100,20 @@ bbsProofLen :: Int -> Int
 bbsProofLen numUndisclosed = bbsProofBaseLen + numUndisclosed * bbsProofUdElemLen
 
 -- | A proof is @bbsProofBaseLen + 32 * numUndisclosed@ bytes; reject anything else.
+mkBBSProof :: ByteString -> Either String BBSProof
+mkBBSProof bs
+  | len >= bbsProofBaseLen && (len - bbsProofBaseLen) `mod` bbsProofUdElemLen == 0 = Right $ BBSProof bs
+  | otherwise = Left $ "BBS: invalid proof length " <> show len
+  where
+    len = B.length bs
+
 instance StrEncoding BBSProof where
   strEncode (BBSProof bs) = strEncode bs
-  strP = do
-    bs <- base64urlP
-    let len = B.length bs
-    if len >= bbsProofBaseLen && (len - bbsProofBaseLen) `mod` bbsProofUdElemLen == 0
-      then pure (BBSProof bs)
-      else fail $ "BBS: invalid proof length " <> show len
+  strP = mkBBSProof <$?> base64urlP
+
+instance Encoding BBSProof where
+  smpEncode (BBSProof p) = smpEncode (Large p)
+  smpP = mkBBSProof . unLarge <$?> smpP
 
 -- FFI
 

src/Simplex/Messaging/Crypto/Entitlement.hs

@@ -0,0 +1,151 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Simplex.Messaging.Crypto.Entitlement
+  ( Entitlement (..),
+    EntitlementCredential (..),
+    EntitlementProof (..),
+    EntitlementVerification (..),
+    MasterKey (..),
+    randomMasterKey,
+    entitlementBBSHeader,
+    entitlementIssuerKeys,
+    signEntitlement,
+    verifyCredential,
+    generateEntitlementProof,
+    verifyEntitlement,
+  )
+where
+
+import Control.Concurrent.STM
+import Crypto.Random (ChaChaDRG)
+import Data.Aeson (FromJSON (..), ToJSON (..))
+import qualified Data.Aeson.TH as JQ
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import Data.Either (fromRight)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import Data.Text (Text)
+import Data.Text.Encoding (decodeUtf8', encodeUtf8)
+import Data.Time.Clock (UTCTime)
+import Data.Word (Word16)
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.BBS
+import Simplex.Messaging.Encoding
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Parsers (defaultJSON)
+import Simplex.Messaging.Util ((<$$>))
+
+newtype MasterKey = MasterKey ByteString
+  deriving newtype (Eq, Show)
+  deriving (StrEncoding) via (FixedBS "MasterKey" 32)
+  deriving (ToJSON, FromJSON) via (StrJSON "MasterKey" MasterKey)
+
+data Entitlement = Entitlement
+  { expiresAt :: UTCTime,
+    entitlementName :: Text,
+    extraInfo :: Text
+  }
+  deriving (Eq, Show)
+
+data EntitlementCredential = EntitlementCredential
+  { issuerKeyIdx :: Word16,
+    masterKey :: MasterKey,
+    entitlement :: Entitlement,
+    issuerSignature :: BBSSignature
+  }
+  deriving (Eq, Show)
+
+data EntitlementProof = EntitlementProof
+  { issuerKeyIdx :: Word16,
+    entitlement :: Entitlement,
+    entProof :: BBSProof
+  }
+  deriving (Eq, Show)
+
+data EntitlementVerification = EVValid | EVInvalid | EVUnknownIssuer
+  deriving (Eq, Show)
+
+instance Encoding Entitlement where
+  smpEncode Entitlement {expiresAt, entitlementName, extraInfo} =
+    smpEncode (strEncode expiresAt, entitlementName, Large $ encodeUtf8 extraInfo)
+  smpP = do
+    (expBs, entitlementName, Large extraBs) <- smpP
+    expiresAt <- either fail pure $ strDecode (expBs :: ByteString)
+    extraInfo <- either (fail . show) pure $ decodeUtf8' extraBs
+    pure Entitlement {expiresAt, entitlementName, extraInfo}
+
+instance Encoding EntitlementProof where
+  smpEncode EntitlementProof {issuerKeyIdx, entProof, entitlement} =
+    smpEncode (issuerKeyIdx, entProof, entitlement)
+  smpP = do
+    (issuerKeyIdx, entProof, entitlement) <- smpP
+    pure EntitlementProof {issuerKeyIdx, entProof, entitlement}
+
+entitlementBBSHeader :: BBSHeader
+entitlementBBSHeader = BBSHeader "SimpleX badges v1"
+
+entitlementMessageCount :: Int
+entitlementMessageCount = 4
+
+entitlementDisclosedIndexes :: [Int]
+entitlementDisclosedIndexes = [1, 2, 3]
+
+entitlementMessages :: MasterKey -> Entitlement -> [ByteString]
+entitlementMessages (MasterKey mk) ent = mk : disclosedMessages ent
+
+disclosedMessages :: Entitlement -> [ByteString]
+disclosedMessages Entitlement {expiresAt, entitlementName, extraInfo} =
+  [strEncode expiresAt, encodeUtf8 entitlementName, encodeUtf8 extraInfo]
+
+randomMasterKey :: TVar ChaChaDRG -> STM MasterKey
+randomMasterKey g = MasterKey <$> C.randomBytes 32 g
+
+signEntitlement :: BBSSecretKey -> Word16 -> MasterKey -> Entitlement -> IO (Either String EntitlementCredential)
+signEntitlement sk keyIdx mk ent =
+  EntitlementCredential keyIdx mk ent <$$> bbsSign sk entitlementBBSHeader (entitlementMessages mk ent)
+
+verifyCredential :: BBSPublicKey -> EntitlementCredential -> IO Bool
+verifyCredential pk EntitlementCredential {masterKey, issuerSignature, entitlement} =
+  bbsVerify pk issuerSignature entitlementBBSHeader (entitlementMessages masterKey entitlement)
+
+generateEntitlementProof :: Map Word16 BBSPublicKey -> EntitlementCredential -> BBSPresHeader -> IO (Either String EntitlementProof)
+generateEntitlementProof keys EntitlementCredential {issuerKeyIdx, masterKey, issuerSignature, entitlement} ph =
+  case M.lookup issuerKeyIdx keys of
+    Nothing -> pure $ Left $ "no issuer key " <> show issuerKeyIdx
+    Just pk -> EntitlementProof issuerKeyIdx entitlement <$$> bbsProofGen pk issuerSignature entitlementBBSHeader ph entitlementDisclosedIndexes (entitlementMessages masterKey entitlement)
+
+verifyEntitlement :: Map Word16 BBSPublicKey -> BBSPresHeader -> EntitlementProof -> IO EntitlementVerification
+verifyEntitlement keys ph EntitlementProof {issuerKeyIdx, entProof, entitlement} =
+  case M.lookup issuerKeyIdx keys of
+    Nothing -> pure EVUnknownIssuer
+    Just pk ->
+      (\valid -> if valid then EVValid else EVInvalid)
+        <$> bbsProofVerify pk entProof entitlementBBSHeader ph entitlementDisclosedIndexes entitlementMessageCount (disclosedMessages entitlement)
+
+entitlementIssuerKeys :: Map Word16 BBSPublicKey
+entitlementIssuerKeys =
+  M.fromList
+    [ (1, key "mW_5Zp1wHnXDF56wOZwFcRjGrf0GLLsfyymIQDqYoWfjfvS7oQWSfi7hH65N8JhuE9x8wbKXHidnQLO4GnOSMP_bRKUMH1qIzv5SQKFHNM8G4PaWcTcri8iZLc-3xhSI"),
+      (2, key "odGCB7uVDXTURsHgSvSciByV4Q3-3ZvEB8myDsDJqm-PwOYc5-At36uc7n_pyUDxEQEHr9i4RJgFih2FSArPW-EQBXNPNf4wTtA0znn74qLEGc4fh9pVYPEIm_ZGbnsJ"),
+      (3, key "txkT2003WMjc43KvYvPKEcR970NLmw5UZY51eUqgk91sgp53idt1HTlKYvnrEttJDFMlctYf1-bpri0e9DhBQ-xk1J4WoLN2uif_1OcA1pGCobpk9lwtsq1Idek4biy0"),
+      (4, key "q_YzegihaLYrEm9z3cAghsfDGNZfXuEpQGMJERJQS4M0Szl4gvSC_fV_muKc3NIMA_8iYuBN8qyvb5U55RctCRn3kleFQ4sqf-WBgoydX6UVo7BsYcUbXWWEFZXlOGIH"),
+      (5, key "oqymHASH_okefShrnz4HnTooUNlE1WoDRnSrgd0bTCpOacgJWBsMpwZpdmYlX-vQAKAC_zmI4VdKoOznnhW-sdUXZw6bthCi5JYjGxCR1Co27i1tix5UXCTbR5Jp901-"),
+      (6, key "kDqaB6zKSRp_97QPFj5JPDlo0vzfSTLSp9goFx1qajv4q4H6dR6BbkmWZ4xx_9Q2AxmcpqcV0ethz1OH-Jk_Sz2J1mIz1PUVM9LkdLhi_PNtqhezzO5dbVs-HJ1fNqe6"),
+      (7, key "rl36D5mg2N3NmmEybxE_RBeU9YZ_zeXNPfp7ZMLtUEuf2Mo4OQM_Up1v5rX_IqICD-AIJcuyptEBsELx_PJQzpmiNuG5I4cWO6HkRKtc6fVFvgZMrDJjaascPd1CIyxX"),
+      (8, key "joM3Bnt7JPt5JiwQwERHGjro2iVZ0mPD_clUh4hzkhxvbjuFrWuTmfSNA8PWBqGKEGNl13aRi1pMf6yY14E27c5C71JxWm7T-rZaBrGPEUWifhD-qidWuf3PU7KJCCWd")
+    ]
+  where
+    key = fromRight (error "bad base64 in BBSPublicKey") . strDecode . B.pack
+
+$(JQ.deriveJSON defaultJSON ''Entitlement)
+
+$(JQ.deriveJSON defaultJSON ''EntitlementCredential)
+
+$(JQ.deriveJSON defaultJSON ''EntitlementProof)

src/Simplex/Messaging/Crypto/Ratchet.hs

@@ -451,6 +451,7 @@ generateSndE2EParams g v = \case
 
 data RatchetInitParams = RatchetInitParams
   { assocData :: Str,
+    rcVerifyCodePQ :: Str,
     ratchetKey :: RatchetKey,
     sndHK :: HeaderKey,
     rcvNextHK :: HeaderKey,
@@ -493,14 +494,14 @@ pqX3dhRcv (rpk1, rpk2, rpKem_) (E2ERatchetParams _ sk1 sk2 sKem_) = do
 
 pqX3dh :: DhAlgorithm a => (PublicKey a, PublicKey a) -> DhSecret a -> DhSecret a -> DhSecret a -> Maybe RatchetKEMAccepted -> RatchetInitParams
 pqX3dh (sk1, rk1) dh1 dh2 dh3 kemAccepted =
-  RatchetInitParams {assocData, ratchetKey = RatchetKey sk, sndHK = Key hk, rcvNextHK = Key nhk, kemAccepted}
+  RatchetInitParams {assocData, rcVerifyCodePQ = Str vcPQ, ratchetKey = RatchetKey sk, sndHK = Key hk, rcvNextHK = Key nhk, kemAccepted}
   where
     assocData = Str $ pubKeyBytes sk1 <> pubKeyBytes rk1
     dhs = dhBytes' dh1 <> dhBytes' dh2 <> dhBytes' dh3 <> pq
     pq = maybe "" (\RatchetKEMAccepted {rcPQRss = KEMSharedKey ss} -> BA.convert ss) kemAccepted
-    (hk, nhk, sk) =
-      let salt = B.replicate 64 '\0'
-       in hkdf3 salt dhs "SimpleXX3DH"
+    salt = B.replicate 64 '\0'
+    (hk, nhk, sk) = hkdf3 salt dhs "SimpleXX3DH"
+    vcPQ = hkdf salt dhs "SimpleXVerifyCode" 32
 
 type RatchetX448 = Ratchet 'X448
 
@@ -509,6 +510,8 @@ data Ratchet a = Ratchet
     rcVersion :: RatchetVersions,
     -- associated data - must be the same in both parties ratchets
     rcAD :: Str,
+    -- verification code covering all handshake keys, absent in the ratchets created before it was added
+    rcVCPQ :: Maybe Str,
     rcDHRs :: PrivateKey a,
     rcKEM :: Maybe RatchetKEM,
     rcSupportKEM :: PQSupport, -- defines header size, can only be enabled once
@@ -637,13 +640,14 @@ instance FromField MessageKey where fromField = blobFieldDecoder smpDecode
 -- @
 initSndRatchet ::
   forall a. (AlgorithmI a, DhAlgorithm a) => RatchetVersions -> PublicKey a -> PrivateKey a -> (RatchetInitParams, Maybe KEMKeyPair) -> Ratchet a
-initSndRatchet rcVersion rcDHRr rcDHRs (RatchetInitParams {assocData, ratchetKey, sndHK, rcvNextHK, kemAccepted}, rcPQRs_) = do
+initSndRatchet rcVersion rcDHRr rcDHRs (RatchetInitParams {assocData, rcVerifyCodePQ, ratchetKey, sndHK, rcvNextHK, kemAccepted}, rcPQRs_) = do
   -- state.RK, state.CKs, state.NHKs = KDF_RK_HE(SK, DH(state.DHRs, state.DHRr) || state.PQRss)
   let (rcRK, rcCKs, rcNHKs) = rootKdf ratchetKey rcDHRr rcDHRs (rcPQRss <$> kemAccepted)
       pqOn = isJust rcPQRs_
    in Ratchet
         { rcVersion,
           rcAD = assocData,
+          rcVCPQ = Just rcVerifyCodePQ,
           rcDHRs,
           rcKEM = (`RatchetKEM` kemAccepted) <$> rcPQRs_,
           rcSupportKEM = PQSupport pqOn,
@@ -668,10 +672,11 @@ initSndRatchet rcVersion rcDHRr rcDHRs (RatchetInitParams {assocData, ratchetKey
 -- as part of the connection request and random salt was received from the sender.
 initRcvRatchet ::
   forall a. (AlgorithmI a, DhAlgorithm a) => RatchetVersions -> PrivateKey a -> (RatchetInitParams, Maybe KEMKeyPair) -> PQSupport -> Ratchet a
-initRcvRatchet rcVersion rcDHRs (RatchetInitParams {assocData, ratchetKey, sndHK, rcvNextHK, kemAccepted}, rcPQRs_) pqSupport =
+initRcvRatchet rcVersion rcDHRs (RatchetInitParams {assocData, rcVerifyCodePQ, ratchetKey, sndHK, rcvNextHK, kemAccepted}, rcPQRs_) pqSupport =
   Ratchet
     { rcVersion,
       rcAD = assocData,
+      rcVCPQ = Just rcVerifyCodePQ,
       rcDHRs,
       -- rcKEM:
       -- state.PQRs = bob_pq_kem_key_pair

src/Simplex/Messaging/Names/Record.hs

@@ -1,3 +1,6 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE StrictData #-}
@@ -5,13 +8,24 @@
 
 module Simplex.Messaging.Names.Record
   ( NameRecord (..),
+    NameResponse (..),
+    NameRegistration (..),
+    NamePricing (..),
+    USDCents (..),
+    NameReservedReason (..),
   )
 where
 
+import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Aeson as J
 import qualified Data.Aeson.TH as JQ
+import Data.Int (Int64)
+import Data.Map.Strict (Map)
 import Data.Text (Text)
-import Simplex.Messaging.Parsers (defaultJSON, dropPrefix)
+import qualified Data.Text as T
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, taggedObjectJSON)
+import Simplex.Messaging.SystemTime (SystemSeconds)
 
 -- | Resolved name record returned by the names role. JSON keys match the
 --   resolver REST output; both FromJSON (resolver -> server) and ToJSON
@@ -44,3 +58,87 @@ $( JQ.deriveJSON
     defaultJSON {J.omitNothingFields = False, J.fieldLabelModifier = dropPrefix "nr"}
     ''NameRecord
  )
+
+-- | US cents.
+newtype USDCents = USDCents Int64
+  deriving (Eq, Ord, Show)
+  deriving newtype (ToJSON, FromJSON)
+
+-- | What the registry holds for a name, and the block it was read at.
+data NameResponse = NameResponse
+  { -- | absent only from a v20/v21 router, which sent the record alone
+    lastBlockTs :: Maybe SystemSeconds,
+    registration :: NameRegistration
+  }
+  deriving (Eq, Show)
+
+-- | What the registry holds for a name.
+data NameRegistration
+  = -- | Held by someone. Always carries a record, empty where none was set.
+    NRRegistered
+      { -- | absent only from a v20/v21 router, which sent the record alone
+        expires :: Maybe SystemSeconds,
+        -- | unix seconds, > expires: until here only the owner may renew
+        graceUntil :: Maybe SystemSeconds,
+        -- | held back as well, which is why it will not free up at expiry
+        reservedReason_ :: Maybe NameReservedReason,
+        nameRecord :: NameRecord
+      }
+  | -- | Held by nobody, and registrable now.
+    NRAvailable {pricing :: NamePricing}
+  | -- | Held back by the registry, and not for sale at its price.
+    NRReserved {reservedReason :: NameReservedReason}
+  deriving (Eq, Show)
+
+-- | Enough to price the name locally, which the router cannot do behind a hash.
+data NamePricing = NamePricing
+  { -- | US cents per year, for the lengths the registry prices specially
+    registrationPrices :: Map Int USDCents,
+    -- | US cents per year for every other length
+    basePrice :: USDCents,
+    -- | characters; the registry refuses shorter labels
+    minLabelLength :: Int
+  }
+  deriving (Eq, Show)
+
+-- | Why the registry holds a name back.
+data NameReservedReason
+  = -- | held for SimpleX
+    NRRInternal
+  | NRRTrademark
+  | NRRCommunity
+  | -- | added to the registry after this version, and still reserved
+    NRRUnknown Text
+  deriving (Eq, Show)
+
+instance TextEncoding NameReservedReason where
+  textEncode = \case
+    NRRInternal -> "internal"
+    NRRTrademark -> "trademark"
+    NRRCommunity -> "community"
+    NRRUnknown t -> t
+  textDecode = Just . reservedReasonOf
+
+-- | An unknown reason is kept as text, capped: it reaches a client as a word.
+-- Capping precedes the match, so what is kept encodes back to what it decoded.
+reservedReasonOf :: Text -> NameReservedReason
+reservedReasonOf t = case T.take 32 $ T.takeWhile (\c -> c > ' ' && c < '\DEL') t of
+  "internal" -> NRRInternal
+  "trademark" -> NRRTrademark
+  "community" -> NRRCommunity
+  r -> NRRUnknown r
+
+instance ToJSON NameReservedReason where
+  toJSON = textToJSON
+  toEncoding = textToEncoding
+
+instance FromJSON NameReservedReason where
+  parseJSON = textParseJSON "NameReservedReason"
+
+$(JQ.deriveJSON defaultJSON ''NamePricing)
+
+-- taggedObjectJSON, not sumTypeJSON: this JSON is the RNAME payload and the
+-- resolver contract, so it must not vary with the swift build flag.
+$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "NR") ''NameRegistration)
+
+$(JQ.deriveJSON defaultJSON ''NameResponse)

src/Simplex/Messaging/Notifications/Server.hs

@@ -72,6 +72,7 @@ import Simplex.Messaging.Notifications.Transport
 import Simplex.Messaging.Protocol (EntityId (..), ErrorType (..), NotifierId, Party (..), ProtocolServer (host), SMPServer, ServiceSub (..), SignedTransmission, Transmission, pattern NoEntity, pattern SMPServer, encodeTransmission, tGetServer, tPut)
 import qualified Simplex.Messaging.Protocol as SMP
 import Simplex.Messaging.Server
+import Simplex.Messaging.Server.AddressStats (AddrStats, ServerAddrStats (..), addressStatsThread, incAddrCounter, printTopAddresses, withAddrStats)
 import Simplex.Messaging.Server.Control (CPClientRole (..))
 import Simplex.Messaging.Server.Env.STM (StartOptions (..))
 import Simplex.Messaging.Server.Stats (PeriodStats (..), PeriodStatCounts (..), periodStatCounts, periodStatDataCounts, updatePeriodStats)
@@ -80,7 +81,7 @@ import Simplex.Messaging.SystemTime
 import Simplex.Messaging.TMap (TMap)
 import Simplex.Messaging.Transport (ASrvTransport, ATransport (..), THandle (..), THandleAuth (..), THandleParams (..), TProxy, Transport (..), TransportPeer (..), defaultSupportedParams)
 import Simplex.Messaging.Transport.Buffer (trimCR)
-import Simplex.Messaging.Transport.Server (AddHTTP, runTransportServer, runLocalTCPServer)
+import Simplex.Messaging.Transport.Server (AddHTTP, TLSServerCredential (..), newSocketState, runLocalTCPServer, runTransportServerState_)
 import Simplex.Messaging.Util
 import System.Environment (lookupEnv)
 import System.Exit (exitFailure, exitSuccess)
@@ -122,6 +123,7 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions}
         : map runServer transports
           <> serverStatsThread_ cfg
           <> prometheusMetricsThread_ cfg
+          <> addressStatsThread_ cfg
           <> controlPortThread_ cfg
     )
     `finally` stopServer
@@ -131,16 +133,20 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions}
       srvCreds <- asks tlsServerCreds
       serverSignKey <- either fail pure $ C.x509ToPrivate' $ snd srvCreds
       env <- ask
-      liftIO $ runTransportServer started tcpPort defaultSupportedParams srvCreds tCfg $ \h -> runClient serverSignKey t h `runReaderT` env
+      ss <- liftIO newSocketState
+      liftIO $ runTransportServerState_ ss started tcpPort defaultSupportedParams TLSServerCredential {credential = srvCreds, sniCredential = Nothing} tCfg $ \sock (_, h) ->
+        runClient serverSignKey t sock h `runReaderT` env
 
-    runClient :: Transport c => C.APrivateSignKey -> TProxy c 'TServer -> c 'TServer -> M ()
-    runClient signKey _ h = do
-      kh <- asks serverIdentity
-      ks <- atomically . C.generateKeyPair =<< asks random
-      NtfServerConfig {ntfServerVRange} <- asks config
-      liftIO (runExceptT $ ntfServerHandshake signKey h ks kh ntfServerVRange) >>= \case
-        Right th -> runNtfClientTransport th
-        Left _ -> pure ()
+    runClient :: Transport c => C.APrivateSignKey -> TProxy c 'TServer -> Socket -> c 'TServer -> M ()
+    runClient signKey _ sock h = do
+      stats_ <- asks addrStats
+      withAddrStats (addrStatsMap <$> stats_) sock $ \addrStats_ -> do
+        kh <- asks serverIdentity
+        ks <- atomically . C.generateKeyPair =<< asks random
+        NtfServerConfig {ntfServerVRange} <- asks config
+        liftIO (runExceptT $ ntfServerHandshake signKey h ks kh ntfServerVRange) >>= \case
+          Right th -> runNtfClientTransport addrStats_ th
+          Left _ -> pure ()
 
     stopServer :: M ()
     stopServer = do
@@ -231,6 +237,10 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions}
       [savePrometheusMetrics interval prometheusMetricsFile]
     prometheusMetricsThread_ _ = []
 
+    addressStatsThread_ :: NtfServerConfig -> [M ()]
+    addressStatsThread_ NtfServerConfig {addressStats = Just statsCfg} = [asks addrStats >>= mapM_ (liftIO . addressStatsThread statsCfg)]
+    addressStatsThread_ _ = []
+
     savePrometheusMetrics :: Int -> FilePath -> M ()
     savePrometheusMetrics saveInterval metricsFile = do
       labelMyThread "savePrometheusMetrics"
@@ -256,7 +266,7 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions}
       pure NtfServerMetrics {statsData = d, activeTokensCounts = psTkns, activeSubsCounts = psSubs, tokenCount, approxSubCount, lastNtfCount, rtsOptions}
 
     getNtfRealTimeMetrics :: NtfEnv -> IO NtfRealTimeMetrics
-    getNtfRealTimeMetrics NtfEnv {subscriber, pushServer} = do
+    getNtfRealTimeMetrics NtfEnv {subscriber, pushServer, addrStats} = do
 #if MIN_VERSION_base(4,18,0)
       threadsCount <- length <$> listThreads
 #else
@@ -274,6 +284,7 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions}
       ntfPendingQueueSubs <- getSMPSubMetrics a pendingQueueSubs
       smpSessionCount <- M.size <$> readTVarIO smpSessions
       apnsPushQLength <- pushWorkersQLength pushWorkers
+      addressHistograms <- mapM (readIORef . addrHistograms) addrStats
       pure
         NtfRealTimeMetrics
           { threadsCount,
@@ -285,7 +296,8 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions}
             ntfPendingServiceSubs,
             ntfPendingQueueSubs,
             smpSessionCount,
-            apnsPushQLength
+            apnsPushQLength,
+            addressHistograms
           }
       where
         getSMPServiceSubMetrics :: forall sub. SMPClientAgent 'NotifierService -> (SMPClientAgent 'NotifierService -> TMap SMPServer (TVar (Maybe sub))) -> (sub -> Int64) -> IO NtfSMPSubMetrics
@@ -441,7 +453,10 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions}
                       T.hPutStrLn h $ name <> " own servers count: " <> tshow (length ownServers)
                       when (r == CPRAdmin) $ T.hPutStrLn h $ name <> " own servers: " <> T.intercalate "," ownServers
                       T.hPutStrLn h $ name <> " other servers count: " <> tshow otherServers
-              CPHelp -> hPutStrLn h "commands: stats, stats-rts, server-info, help, quit"
+              CPAddresses name n_ -> withUserRole $ do
+                stats_ <- unliftIO u $ asks addrStats
+                printTopAddresses h (addrStatsMap <$> stats_) name n_
+              CPHelp -> hPutStrLn h "commands: stats, stats-rts, server-info, addresses, help, quit"
               CPQuit -> pure ()
               CPSkip -> pure ()
               where
@@ -756,11 +771,11 @@ periodicNtfsThread s = do
     cnt <- withPeriodicNtfTokens st now $ \tkn -> unlift $ pushNotification s Nothing False tkn PNCheckMessages
     logNote $ "Scheduled periodic notifications: " <> tshow cnt
 
-runNtfClientTransport :: Transport c => THandleNTF c 'TServer -> M ()
-runNtfClientTransport th@THandle {params} = do
+runNtfClientTransport :: Transport c => Maybe (AddrStats NtfAddrCounter) -> THandleNTF c 'TServer -> M ()
+runNtfClientTransport addrStats_ th@THandle {params} = do
   qSize <- asks $ clientQSize . config
   ts <- liftIO getSystemTime
-  c <- liftIO $ newNtfServerClient qSize params ts
+  c <- liftIO $ newNtfServerClient qSize params ts addrStats_
   s <- asks subscriber
   ps <- asks pushServer
   expCfg <- asks $ inactiveClientExpiration . config
@@ -775,7 +790,7 @@ clientDisconnected :: NtfServerClient -> IO ()
 clientDisconnected NtfServerClient {connected} = atomically $ writeTVar connected False
 
 receive :: Transport c => NtfPostgresStore -> THandleNTF c 'TServer -> NtfServerClient -> IO ()
-receive st th@THandle {params = THandleParams {thAuth}} NtfServerClient {rcvQ, sndQ, rcvActiveAt} = forever $ do
+receive st th@THandle {params = THandleParams {thAuth}} NtfServerClient {rcvQ, sndQ, rcvActiveAt, ntfClientAddrStats} = forever $ do
   ts <- L.toList <$> tGetServer th
   atomically . (writeTVar rcvActiveAt $!) =<< getSystemTime
   (errs, cmds) <- partitionEithers <$> mapM cmdAction ts
@@ -784,17 +799,21 @@ receive st th@THandle {params = THandleParams {thAuth}} NtfServerClient {rcvQ, s
   where
     cmdAction = \case
       Left (corrId, entId, e) -> do
+        incAddrStats NACErrors
         logError $ "invalid client request: " <> tshow e
         pure $ Left (corrId, entId, NRErr e)
-      Right t@(_, _, (corrId, entId, _)) ->
+      Right t@(_, _, (corrId, entId, cmd)) -> do
+        incAddrStats $ ntfCmdCounter cmd
         verified =<< verifyNtfTransmission st thAuth t
         where
           verified = \case
             VRVerified req -> pure $ Right req
             VRFailed e -> do
+              incAddrStats NACErrors
               logError "unauthorized client request"
               pure $ Left (corrId, entId, NRErr e)
     write q = mapM_ (atomically . writeTBQueue q) . L.nonEmpty
+    incAddrStats c = forM_ ntfClientAddrStats (`incAddrCounter` c)
 
 send :: Transport c => THandleNTF c 'TServer -> NtfServerClient -> IO ()
 send h@THandle {params} NtfServerClient {sndQ, sndActiveAt} = forever $ do

src/Simplex/Messaging/Notifications/Server/Control.hs

@@ -7,14 +7,17 @@ module Simplex.Messaging.Notifications.Server.Control
 where
 
 import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.Text (Text)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (BasicAuth)
+import Simplex.Messaging.Server.AddressStats (addressesArgs, addressesArgsP)
 
 data ControlProtocol
   = CPAuth BasicAuth
   | CPStats
   | CPStatsRTS
   | CPServerInfo
+  | CPAddresses Text (Maybe Int)
   | CPHelp
   | CPQuit
   | CPSkip
@@ -25,6 +28,7 @@ instance StrEncoding ControlProtocol where
     CPStats -> "stats"
     CPStatsRTS -> "stats-rts"
     CPServerInfo -> "server-info"
+    CPAddresses name n_ -> "addresses " <> addressesArgs name n_
     CPHelp -> "help"
     CPQuit -> "quit"
     CPSkip -> ""
@@ -34,6 +38,7 @@ instance StrEncoding ControlProtocol where
       "stats" -> pure CPStats
       "stats-rts" -> pure CPStatsRTS
       "server-info" -> pure CPServerInfo
+      "addresses" -> uncurry CPAddresses <$> addressesArgsP
       "help" -> pure CPHelp
       "quit" -> pure CPQuit
       "" -> pure CPSkip

src/Simplex/Messaging/Notifications/Server/Env.hs

@@ -19,6 +19,8 @@ module Simplex.Messaging.Notifications.Server.Env
     PushWorkerVar,
     NtfRequest (..),
     NtfServerClient (..),
+    NtfAddrCounter (..),
+    ntfCmdCounter,
     defaultInactiveClientExpiration,
     newNtfServerEnv,
     newNtfSubscriber,
@@ -55,6 +57,7 @@ import Simplex.Messaging.Notifications.Server.Store.Postgres
 import Simplex.Messaging.Notifications.Server.Store.Types
 import Simplex.Messaging.Notifications.Transport (NTFVersion, VersionRangeNTF)
 import Simplex.Messaging.Protocol (BasicAuth, CorrId, Party (..), SMPServer, SParty (..), ServiceId, Transmission)
+import Simplex.Messaging.Server.AddressStats (AddrCounter (..), AddrStats, AddressStatsConfig, ServerAddrStats, newServerAddrStats)
 import Simplex.Messaging.Server.Env.STM (StartOptions (..))
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
@@ -97,6 +100,7 @@ data NtfServerConfig = NtfServerConfig
     -- | interval and file to save prometheus metrics
     prometheusInterval :: Maybe Int,
     prometheusMetricsFile :: FilePath,
+    addressStats :: Maybe AddressStatsConfig,
     ntfServerVRange :: VersionRangeNTF,
     transportConfig :: TransportServerConfig,
     startOptions :: StartOptions
@@ -117,11 +121,56 @@ data NtfEnv = NtfEnv
     random :: TVar ChaChaDRG,
     tlsServerCreds :: TLS.Credential,
     serverIdentity :: C.KeyHash,
-    serverStats :: NtfServerStats
+    serverStats :: NtfServerStats,
+    addrStats :: Maybe (ServerAddrStats NtfAddrCounter)
   }
 
+data NtfAddrCounter
+  = NACConnections
+  | NACErrors
+  | NACTNew
+  | NACTVfy
+  | NACTChk
+  | NACTRpl
+  | NACTDel
+  | NACTCrn
+  | NACSNew
+  | NACSChk
+  | NACSDel
+  | NACPing
+  deriving (Eq, Ord, Enum, Bounded, Show)
+
+instance AddrCounter NtfAddrCounter where
+  counterName = \case
+    NACConnections -> "connections"
+    NACErrors -> "errors"
+    NACTNew -> "TNEW"
+    NACTVfy -> "TVFY"
+    NACTChk -> "TCHK"
+    NACTRpl -> "TRPL"
+    NACTDel -> "TDEL"
+    NACTCrn -> "TCRN"
+    NACSNew -> "SNEW"
+    NACSChk -> "SCHK"
+    NACSDel -> "SDEL"
+    NACPing -> "PING"
+  connectionsCounter = NACConnections
+
+ntfCmdCounter :: NtfCmd -> NtfAddrCounter
+ntfCmdCounter (NtfCmd _ cmd) = case cmd of
+  TNEW _ -> NACTNew
+  TVFY _ -> NACTVfy
+  TCHK -> NACTChk
+  TRPL _ -> NACTRpl
+  TDEL -> NACTDel
+  TCRN _ -> NACTCrn
+  SNEW _ -> NACSNew
+  SCHK -> NACSChk
+  SDEL -> NACSDel
+  PING -> NACPing
+
 newNtfServerEnv :: NtfServerConfig -> IO NtfEnv
-newNtfServerEnv config@NtfServerConfig {pushQSize, smpAgentCfg, apnsConfig, dbStoreConfig, ntfCredentials, useServiceCreds} = do
+newNtfServerEnv config@NtfServerConfig {pushQSize, smpAgentCfg, apnsConfig, dbStoreConfig, ntfCredentials, useServiceCreds, addressStats} = do
   random <- C.newRandom
   store <- newNtfDbStore dbStoreConfig
   tlsServerCreds <- loadServerCredential ntfCredentials
@@ -130,7 +179,8 @@ newNtfServerEnv config@NtfServerConfig {pushQSize, smpAgentCfg, apnsConfig, dbSt
   subscriber <- newNtfSubscriber smpAgentCfg dbService random
   pushServer <- newNtfPushServer pushQSize apnsConfig
   serverStats <- newNtfServerStats =<< getCurrentTime
-  pure NtfEnv {config, subscriber, pushServer, store, random, tlsServerCreds, serverIdentity = C.KeyHash fp, serverStats}
+  addrStats <- mapM (const newServerAddrStats) addressStats
+  pure NtfEnv {config, subscriber, pushServer, store, random, tlsServerCreds, serverIdentity = C.KeyHash fp, serverStats, addrStats}
   where
     mkDbService g st = DBService {getCredentials, updateServiceId}
       where
@@ -242,14 +292,15 @@ data NtfServerClient = NtfServerClient
     ntfThParams :: THandleParams NTFVersion 'TServer,
     connected :: TVar Bool,
     rcvActiveAt :: TVar SystemTime,
-    sndActiveAt :: TVar SystemTime
+    sndActiveAt :: TVar SystemTime,
+    ntfClientAddrStats :: Maybe (AddrStats NtfAddrCounter)
   }
 
-newNtfServerClient :: Natural -> THandleParams NTFVersion 'TServer -> SystemTime -> IO NtfServerClient
-newNtfServerClient qSize ntfThParams ts = do
+newNtfServerClient :: Natural -> THandleParams NTFVersion 'TServer -> SystemTime -> Maybe (AddrStats NtfAddrCounter) -> IO NtfServerClient
+newNtfServerClient qSize ntfThParams ts ntfClientAddrStats = do
   rcvQ <- newTBQueueIO qSize
   sndQ <- newTBQueueIO qSize
   connected <- newTVarIO True
   rcvActiveAt <- newTVarIO ts
   sndActiveAt <- newTVarIO ts
-  return NtfServerClient {rcvQ, sndQ, ntfThParams, connected, rcvActiveAt, sndActiveAt}
+  return NtfServerClient {rcvQ, sndQ, ntfThParams, connected, rcvActiveAt, sndActiveAt, ntfClientAddrStats}

src/Simplex/Messaging/Notifications/Server/Main.hs

@@ -141,6 +141,8 @@ ntfServerCLI cfgPath logPath =
                \disconnect = off\n"
             <> ("# ttl = " <> tshow (ttl defaultInactiveClientExpiration) <> "\n")
             <> ("# check_interval = " <> tshow (checkInterval defaultInactiveClientExpiration) <> "\n")
+            <> "\n"
+            <> addressStatsIniContent
     enableStoreLog' = settingIsOn "STORE_LOG" "enable"
     runServer startOptions ini = do
       setLogLevel $ logLevel startOptions
@@ -216,6 +218,7 @@ ntfServerCLI cfgPath logPath =
               serverStatsBackupFile = logStats $> combine logPath "ntf-server-stats.log",
               prometheusInterval = eitherToMaybe $ read . T.unpack <$> lookupValue "STORE_LOG" "prometheus_interval" ini,
               prometheusMetricsFile = combine logPath "ntf-server-metrics.txt",
+              addressStats = iniAddressStats ini,
               ntfServerVRange = supportedServerNTFVRange,
               transportConfig =
                 mkTransportServerConfig

src/Simplex/Messaging/Notifications/Server/Prometheus.hs

@@ -21,7 +21,9 @@ import Data.Time.Clock (UTCTime (..), diffUTCTime)
 import Data.Time.Clock.System (systemEpochDay)
 import Data.Time.Format.ISO8601 (iso8601Show)
 import Numeric.Natural (Natural)
+import Simplex.Messaging.Notifications.Server.Env (NtfAddrCounter)
 import Simplex.Messaging.Notifications.Server.Stats
+import Simplex.Messaging.Server.AddressStats (AddrHistogram, addrHistogramMetrics)
 import Simplex.Messaging.Server.Stats (PeriodStatCounts (..))
 import Simplex.Messaging.Transport (simplexMQVersion)
 import Simplex.Messaging.Util (tshow)
@@ -49,7 +51,8 @@ data NtfRealTimeMetrics = NtfRealTimeMetrics
     ntfPendingServiceSubs :: NtfSMPSubMetrics,
     ntfPendingQueueSubs :: NtfSMPSubMetrics,
     smpSessionCount :: Int,
-    apnsPushQLength :: Natural
+    apnsPushQLength :: Natural,
+    addressHistograms :: Maybe (M.Map NtfAddrCounter AddrHistogram)
   }
 
 data NtfSMPWorkerMetrics = NtfSMPWorkerMetrics {ownServers :: [Text], otherServers :: Int}
@@ -59,7 +62,7 @@ data NtfSMPSubMetrics = NtfSMPSubMetrics {ownSrvSubs :: M.Map Text Int, otherSer
 {-# FOURMOLU_DISABLE\n#-}
 ntfPrometheusMetrics :: NtfServerMetrics -> NtfRealTimeMetrics -> UTCTime -> Text
 ntfPrometheusMetrics sm rtm ts =
-  time <> tokens <> subscriptions <> notifications <> info
+  time <> tokens <> subscriptions <> notifications <> clientAddresses <> info
   where
     NtfServerMetrics {statsData, activeTokensCounts = psTkns, activeSubsCounts = psSubs, tokenCount, approxSubCount, lastNtfCount, rtsOptions} = sm
     NtfRealTimeMetrics
@@ -72,7 +75,8 @@ ntfPrometheusMetrics sm rtm ts =
         ntfPendingServiceSubs,
         ntfPendingQueueSubs,
         smpSessionCount,
-        apnsPushQLength
+        apnsPushQLength,
+        addressHistograms
       } = rtm
     NtfServerStatsData
       { _fromTime,
@@ -221,6 +225,7 @@ ntfPrometheusMetrics sm rtm ts =
       <> showNtfsByServer _ntfReceivedAuthOwn "simplex_ntf_notifications_received_auth_own" "Received notifications without token or subscription (AUTH error)" "ntfReceivedAuthOwn"
       <> showNtfsByServer _ntfDeliveredOwn "simplex_ntf_notifications_delivered_own" "Delivered notifications" "ntfDeliveredOwn"
       <> showNtfsByServer _ntfFailedOwn "simplex_ntf_notifications_failed_own" "Failed notifications" "ntfFailedOwn"
+    clientAddresses = maybe "" (addrHistogramMetrics "simplex_ntf" tsEpoch) addressHistograms
     info =
       "# Info\n\
       \# ----\n\

src/Simplex/Messaging/Notifications/Transport.hs

@@ -14,16 +14,19 @@ module Simplex.Messaging.Notifications.Transport
     THandleNTF,
     supportedClientNTFVRange,
     supportedServerNTFVRange,
+    entitlementNTFVersion,
     alpnSupportedNTFHandshakes,
     ntfServerHandshake,
     ntfClientHandshake,
   ) where
 
 import Control.Monad.Except
+import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Except
 import Data.Word (Word16)
 import qualified Data.X509 as X
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.Entitlement (EntitlementProof)
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Util (liftEitherWith)
@@ -50,11 +53,14 @@ initialNTFVersion = VersionNTF 3
 _invalidReasonNTFVersion :: VersionNTF
 _invalidReasonNTFVersion = VersionNTF 3
 
+entitlementNTFVersion :: VersionNTF
+entitlementNTFVersion = VersionNTF 4
+
 currentClientNTFVersion :: VersionNTF
-currentClientNTFVersion = VersionNTF 3
+currentClientNTFVersion = VersionNTF 4
 
 currentServerNTFVersion :: VersionNTF
-currentServerNTFVersion = VersionNTF 3
+currentServerNTFVersion = VersionNTF 4
 
 supportedClientNTFVRange :: VersionRangeNTF
 supportedClientNTFVRange = mkVersionRange initialNTFVersion currentClientNTFVersion
@@ -78,7 +84,9 @@ data NtfClientHandshake = NtfClientHandshake
   { -- | agreed SMP notifications server protocol version
     ntfVersion :: VersionNTF,
     -- | server identity - CA certificate fingerprint
-    keyHash :: C.KeyHash
+    keyHash :: C.KeyHash,
+    -- | proof of the user entitlement bound to the session
+    entitlementProof :: Maybe EntitlementProof
   }
 
 instance Encoding NtfServerHandshake where
@@ -91,11 +99,15 @@ instance Encoding NtfServerHandshake where
     pure NtfServerHandshake {ntfVersionRange, sessionId, authPubKey}
 
 instance Encoding NtfClientHandshake where
-  smpEncode NtfClientHandshake {ntfVersion, keyHash} =
-    smpEncode (ntfVersion, keyHash)
+  smpEncode NtfClientHandshake {ntfVersion = v, keyHash, entitlementProof} =
+    smpEncode (v, keyHash) <> ifHasEntitlement v (smpEncode entitlementProof) ""
   smpP = do
-    (ntfVersion, keyHash) <- smpP
-    pure NtfClientHandshake {ntfVersion, keyHash}
+    (v, keyHash) <- smpP
+    entitlementProof <- ifHasEntitlement v smpP (pure Nothing)
+    pure NtfClientHandshake {ntfVersion = v, keyHash, entitlementProof}
+
+ifHasEntitlement :: VersionNTF -> a -> a -> a
+ifHasEntitlement v a b = if v >= entitlementNTFVersion then a else b
 
 -- | Notifcations server transport handshake.
 ntfServerHandshake :: forall c. Transport c => C.APrivateSignKey -> c 'TServer -> C.KeyPairX25519 -> C.KeyHash -> VersionRangeNTF -> ExceptT TransportError IO (THandleNTF c 'TServer)
@@ -113,8 +125,8 @@ ntfServerHandshake serverSignKey c (k, pk) kh ntfVersionRange = do
             Nothing -> throwE TEVersion
 
 -- | Notifcations server client transport handshake.
-ntfClientHandshake :: forall c. Transport c => c 'TClient -> C.KeyHash -> VersionRangeNTF -> Bool -> Maybe (ServiceCredentials, C.KeyPairEd25519) -> ExceptT TransportError IO (THandleNTF c 'TClient)
-ntfClientHandshake c keyHash ntfVRange _proxyServer _serviceKeys = do
+ntfClientHandshake :: forall c. Transport c => c 'TClient -> C.KeyHash -> VersionRangeNTF -> Bool -> Maybe (ServiceCredentials, C.KeyPairEd25519) -> (SessionId -> IO (Maybe EntitlementProof)) -> ExceptT TransportError IO (THandleNTF c 'TClient)
+ntfClientHandshake c keyHash ntfVRange _proxyServer _serviceKeys mkEntitlementProof = do
   let th@THandle {params = THandleParams {sessionId}} = ntfTHandle c
   NtfServerHandshake {sessionId = sessId, ntfVersionRange, authPubKey} <- getHandshake th
   if sessionId /= sessId
@@ -126,13 +138,14 @@ ntfClientHandshake c keyHash ntfVRange _proxyServer _serviceKeys = do
           pubKey <- C.verifyX509 serverKey authPubKey
           (,CertChainPubKey (getPeerCertChain c) authPubKey) <$> C.x509ToPublic' pubKey
         let v = maxVersion vr
-        sendHandshake th $ NtfClientHandshake {ntfVersion = v, keyHash}
+        ep <- if v >= entitlementNTFVersion then liftIO (mkEntitlementProof sessionId) else pure Nothing
+        sendHandshake th $ NtfClientHandshake {ntfVersion = v, keyHash, entitlementProof = ep}
         pure $ ntfThHandleClient th v vr ck
       Nothing -> throwE TEVersion
 
 ntfThHandleServer :: forall c. THandleNTF c 'TServer -> VersionNTF -> VersionRangeNTF -> C.PrivateKeyX25519 -> THandleNTF c 'TServer
 ntfThHandleServer th v vr pk =
-  let thAuth = THAuthServer {serverPrivKey = pk, peerClientService = Nothing, sessSecret' = Nothing}
+  let thAuth = THAuthServer {serverPrivKey = pk, peerClientService = Nothing, peerEntitlement = Nothing, sessSecret' = Nothing}
    in ntfThHandle_ th v vr (Just thAuth)
 
 ntfThHandleClient :: forall c. THandleNTF c 'TClient -> VersionNTF -> VersionRangeNTF -> (C.PublicKeyX25519, CertChainPubKey) -> THandleNTF c 'TClient

src/Simplex/Messaging/Protocol.hs

@@ -80,6 +80,12 @@ module Simplex.Messaging.Protocol
     ErrorType (..),
     CommandError (..),
     ProxyError (..),
+    NameQuery (..),
+    NameResponse (..),
+    NameRegistration (..),
+    NamePricing (..),
+    USDCents (..),
+    NameReservedReason (..),
     NameErrorType (..),
     BrokerErrorType (..),
     NetworkError (..),
@@ -263,14 +269,15 @@ import Network.Socket (ServiceName)
 import qualified Network.TLS as TLS
 import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..))
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.Entitlement (EntitlementProof)
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Names.Record (NameRecord (..))
+import Simplex.Messaging.Names.Record
 import Simplex.Messaging.Parsers
 import Simplex.Messaging.Protocol.Types
 import Simplex.Messaging.Server.QueueStore.QueueInfo
 import Simplex.Messaging.ServiceScheme
-import Simplex.Messaging.SimplexName (SimplexDomain)
+import Simplex.Messaging.SimplexName (LabelHash, SimplexDomain (..), SimplexTLD (..), fullDomainName, labelHash)
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Client (TransportHost, TransportHosts (..))
 import Simplex.Messaging.Util (bshow, eitherToMaybe, safeDecodeUtf8, (<$?>))
@@ -603,7 +610,7 @@ data Command (p :: Party) where
   -- - corrId: unique correlation ID between proxy and relay, also used as a nonce to encrypt forwarded transmission
   RFWD :: EncFwdTransmission -> Command ProxyService -- use CorrId as CbNonce, proxy to relay
   -- Resolve SimpleX name.
-  RSLV :: SimplexDomain -> Command Resolver
+  RSLV :: NameQuery -> Command Resolver
 
 deriving instance Show (Command p)
 
@@ -739,8 +746,8 @@ data BrokerMsg where
   OK :: BrokerMsg
   ERR :: ErrorType -> BrokerMsg
   PONG :: BrokerMsg
-  -- Resolved SimpleX name.
-  RNAME :: NameRecord -> BrokerMsg
+  -- What the router knows about a SimpleX name.
+  RNAME :: NameResponse -> BrokerMsg
   deriving (Eq, Show)
 
 data RcvMessage = RcvMessage
@@ -1589,11 +1596,28 @@ data ErrorType
     DUPLICATE_ -- not part of SMP protocol, used internally
   deriving (Eq, Show)
 
+-- | What RSLV asks about: a name, or the hash of a second-level label.
+data NameQuery = NQDomain SimplexDomain | NQHash LabelHash SimplexTLD
+  deriving (Eq, Show)
+
+instance Encoding NameQuery where
+  smpEncode = \case
+    NQDomain d -> encodeUtf8 $ fullDomainName d
+    NQHash h tld -> strEncode h <> strEncode tld
+  smpP = NQHash <$> strP <*> strP <|> NQDomain <$> strP
+
+-- | Hashed from v22, except a name with subnames or a web TLD.
+hashedQuery :: NameQuery -> NameQuery
+hashedQuery q = case q of
+  NQDomain SimplexDomain {nameTLD, domain, subDomain}
+    | null subDomain && nameTLD /= TLDWeb -> NQHash (labelHash domain) nameTLD
+  _ -> q
+
 -- | Name resolution error
 data NameErrorType
   = -- | the names role / resolver is not configured on this server
     NO_RESOLVER
-  | -- | the name is not registered (resolver returned not-found)
+  | -- | the name does not resolve; sent only to a session below v22
     NOT_FOUND
   | -- | backing resolver/RPC failure - contains the diagnostic detail
     RESOLVER {resolverErr :: Text}
@@ -1754,7 +1778,7 @@ transmissionP THandleParams {sessionId, implySessId, serviceAuth} = do
 class (ProtocolTypeI (ProtoType msg), ProtocolEncoding v err msg, ProtocolEncoding v err (ProtoCommand msg), Show err, Show msg) => Protocol v err msg | msg -> v, msg -> err where
   type ProtoCommand msg = cmd | cmd -> msg
   type ProtoType msg = (sch :: ProtocolType) | sch -> msg
-  protocolClientHandshake :: Transport c => c 'TClient -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRange v -> Bool -> Maybe (ServiceCredentials, C.KeyPairEd25519) -> ExceptT TransportError IO (THandle v c 'TClient)
+  protocolClientHandshake :: Transport c => c 'TClient -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRange v -> Bool -> Maybe (ServiceCredentials, C.KeyPairEd25519) -> (SessionId -> IO (Maybe EntitlementProof)) -> ExceptT TransportError IO (THandle v c 'TClient)
   useServiceAuth :: ProtoCommand msg -> Bool
   protocolPing :: ProtoCommand msg
   protocolError :: msg -> Maybe err
@@ -1822,7 +1846,7 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
     PRXY host auth_ -> e (PRXY_, ' ', host, auth_)
     PFWD fwdV pubKey (EncTransmission s) -> e (PFWD_, ' ', fwdV, pubKey, Tail s)
     RFWD (EncFwdTransmission s) -> e (RFWD_, ' ', Tail s)
-    RSLV d -> e (RSLV_, ' ', d)
+    RSLV q -> e (RSLV_, ' ', if v >= nameAvailSMPVersion then hashedQuery q else q)
     where
       e :: Encoding a => a -> ByteString
       e = smpEncode
@@ -1929,7 +1953,7 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where
     CT SNotifierService NSUBS_
       | v >= rcvServiceSMPVersion -> Cmd SNotifierService <$> (NSUBS <$> _smpP <*> smpP)
       | otherwise -> pure $ Cmd SNotifierService $ NSUBS (-1) mempty
-    CT SResolver RSLV_ -> Cmd SResolver . RSLV <$> _smpP <* A.takeByteString
+    CT SResolver RSLV_ -> Cmd SResolver . RSLV <$> _smpP
 
   fromProtocolError = fromProtocolError @SMPVersion @ErrorType @BrokerMsg
   {-# INLINE fromProtocolError #-}
@@ -1972,7 +1996,11 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
             | v < clientNoticesSMPVersion -> BLOCKED info {notice = Nothing}
           _ -> err
     PONG -> e PONG_
-    RNAME rec -> e (RNAME_, ' ', Tail $ LB.toStrict $ J.encode rec)
+    RNAME res
+      | v >= nameAvailSMPVersion -> e (RNAME_, ' ', Tail $ LB.toStrict $ J.encode res)
+      | otherwise -> case registration res of
+          NRRegistered {nameRecord} -> e (RNAME_, ' ', Tail $ LB.toStrict $ J.encode nameRecord)
+          _ -> e (ERR_, ' ', NAME NOT_FOUND)
     where
       e :: Encoding a => a -> ByteString
       e = smpEncode
@@ -2019,8 +2047,12 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
     OK_ -> pure OK
     ERR_ -> ERR <$> _smpP
     PONG_ -> pure PONG
-    RNAME_ -> fmap RNAME . J.eitherDecodeStrict . unTail <$?> _smpP
+    RNAME_
+      | v >= nameAvailSMPVersion -> fmap RNAME . J.eitherDecodeStrict . unTail <$?> _smpP
+      | otherwise -> fmap (RNAME . oldResponse) . J.eitherDecodeStrict . unTail <$?> _smpP
     where
+      oldResponse nameRecord =
+        NameResponse {lastBlockTs = Nothing, registration = NRRegistered {expires = Nothing, graceUntil = Nothing, reservedReason_ = Nothing, nameRecord}}
       serviceRespP resp
         | v >= rcvServiceSMPVersion = resp <$> _smpP <*> smpP
         | otherwise = resp <$> _smpP <*> pure mempty
@@ -2042,7 +2074,7 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
     PKEY {} -> noEntityMsg
     RRES _ -> noEntityMsg
     ALLS -> noEntityMsg
-    RNAME _ -> noEntityMsg
+    RNAME {} -> noEntityMsg
     -- other broker responses must have queue ID
     _
       | B.null entId -> Left $ CMD NO_ENTITY
@@ -2412,3 +2444,4 @@ $(J.deriveJSON defaultJSON ''BlockingInfo)
 
 -- run deriveJSON in one TH splice to allow mutual instance
 $(concat <$> mapM @[] (J.deriveJSON (sumTypeJSON id)) [''ProxyError, ''NameErrorType, ''ErrorType])
+

src/Simplex/Messaging/Server.hs

@@ -98,13 +98,13 @@ import Network.Socket (ServiceName, Socket, socketToHandle)
 import qualified Network.TLS as TLS
 import Numeric.Natural (Natural)
 import Simplex.Messaging.Agent.Lock
-import Simplex.Messaging.Client (ProtocolClient (thParams), ProtocolClientError (..), SMPClient, SMPClientError, clientHandlers, forwardSMPTransmission, smpProxyError, temporaryClientError)
+import Simplex.Messaging.Client (ProtocolClient (thParams), ProtocolClientError (..), SMPClient, SMPClientError, clientHandlers, forwardSMPTransmission, smpProxyError, temporaryClientError, transportHost')
 import Simplex.Messaging.Client.Agent (OwnServer, SMPClientAgent (..), SMPClientAgentEvent (..), closeSMPClientAgent, getSMPServerClient'', isOwnServer, lookupSMPServerClient, getConnectedSMPServerClient)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
-import Simplex.Messaging.SimplexName (SimplexDomain)
+import Simplex.Messaging.Server.AddressStats (AddrStats, ServerAddrStats (..), addAddrCounter, addressStatsThread, incAddrCounter, printTopAddresses, withAddrStats)
 import Simplex.Messaging.Server.Control
 import Simplex.Messaging.Server.Env.STM as Env
 import Simplex.Messaging.Server.Expiration
@@ -125,6 +125,7 @@ import Simplex.Messaging.TMap (TMap)
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport
 import Simplex.Messaging.Transport.Buffer (trimCR)
+import Simplex.Messaging.Transport.Client (TransportHost (..))
 import Simplex.Messaging.Transport.Server
 import Simplex.Messaging.Util
 import Simplex.Messaging.Version
@@ -200,6 +201,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
             <> expireMessagesThread_ cfg
             <> serverStatsThread_ cfg
             <> prometheusMetricsThread_ cfg
+            <> addressStatsThread_ cfg
             <> controlPortThread_ cfg
     )
     `finally` stopServer s
@@ -217,11 +219,12 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
           runTransportServerState_ ss started tcpPort defaultSupportedParamsHTTPS combinedCreds tCfg $ \s (sniUsed, h) ->
             case cast h of
               Just (TLS {tlsContext} :: TLS 'TServer) | sniUsed -> labelMyThread "https client" >> attachHTTP s tlsContext
-              _ -> runClient srvCert srvSignKey t h `runReaderT` env
+              _ -> runClient srvCert srvSignKey t s h `runReaderT` env
           where
             combinedCreds = TLSServerCredential {credential = smpCreds, sniCredential = Just httpCreds}
         _ ->
-          runTransportServerState ss started tcpPort defaultSupportedParams smpCreds tCfg $ \h -> runClient srvCert srvSignKey t h `runReaderT` env
+          runTransportServerState_ ss started tcpPort defaultSupportedParams TLSServerCredential {credential = smpCreds, sniCredential = Nothing} tCfg $ \s (_, h) ->
+            runClient srvCert srvSignKey t s h `runReaderT` env
 
     sigIntHandlerThread :: M s ()
     sigIntHandlerThread = do
@@ -516,6 +519,10 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
       [logServerStats logStatsStartTime interval serverStatsLogFile]
     serverStatsThread_ _ = []
 
+    addressStatsThread_ :: ServerConfig s -> [M s ()]
+    addressStatsThread_ ServerConfig {addressStats = Just statsCfg} = [asks addrStats >>= mapM_ (liftIO . addressStatsThread statsCfg)]
+    addressStatsThread_ _ = []
+
     logServerStats :: Int64 -> Int64 -> FilePath -> M s ()
     logServerStats startAt logInterval statsFilePath = do
       labelMyThread "logServerStats"
@@ -700,7 +707,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
       pure ServerMetrics {statsData = d, activeQueueCounts = ps, activeNtfCounts = psNtf, entityCounts, rtsOptions}
 
     getRealTimeMetrics :: Env s -> IO RealTimeMetrics
-    getRealTimeMetrics Env {sockets, msgStore_ = ms, server = srv@Server {subscribers, ntfSubscribers}} = do
+    getRealTimeMetrics Env {sockets, msgStore_ = ms, server = srv@Server {subscribers, ntfSubscribers}, addrStats} = do
       socketStats <- mapM (traverse getSocketStats) =<< readTVarIO sockets
 #if MIN_VERSION_base(4,18,0)
       threadsCount <- length <$> listThreads
@@ -712,7 +719,8 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
       smpSubs <- getSubscribersMetrics subscribers
       ntfSubs <- getSubscribersMetrics ntfSubscribers
       loadedCounts <- loadedQueueCounts $ fromMsgStore ms
-      pure RealTimeMetrics {socketStats, threadsCount, clientsCount, deliveredSubs, deliveredTimes, smpSubs, ntfSubs, loadedCounts}
+      addressHistograms <- mapM (readIORef . addrHistograms) addrStats
+      pure RealTimeMetrics {socketStats, threadsCount, clientsCount, deliveredSubs, deliveredTimes, smpSubs, ntfSubs, loadedCounts, addressHistograms}
       where
         getSubscribersMetrics ServerSubscribers {queueSubscribers, serviceSubscribers, totalServiceSubs, subClients} = do
           subsCount <- M.size <$> getSubscribedClients queueSubscribers
@@ -733,19 +741,21 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
                 Nothing -> acc
                 Just (_, ts) -> (cnt + 1, updateTimeBuckets ts ts' times)
 
-    runClient :: Transport c => X.CertificateChain -> C.APrivateSignKey -> TProxy c 'TServer -> c 'TServer -> M s ()
-    runClient srvCert srvSignKey tp h = do
-      ms <- asks msgStore
-      g <- asks random
-      idSize <- asks $ queueIdBytes . config
-      kh <- asks serverIdentity
-      ks <- atomically . C.generateKeyPair =<< asks random
-      ServerConfig {smpServerVRange, smpHandshakeTimeout, information} <- asks config
-      let serverInfo = LB.toStrict . J.encode <$> information
-      labelMyThread $ "smp handshake for " <> transportName tp
-      liftIO (timeout smpHandshakeTimeout . runExceptT $ smpServerHandshake srvCert srvSignKey h ks kh smpServerVRange serverInfo $ getClientService ms g idSize) >>= \case
-        Just (Right th) -> runClientTransport th
-        _ -> pure ()
+    runClient :: Transport c => X.CertificateChain -> C.APrivateSignKey -> TProxy c 'TServer -> Socket -> c 'TServer -> M s ()
+    runClient srvCert srvSignKey tp sock h = do
+      stats_ <- asks addrStats
+      withAddrStats (addrStatsMap <$> stats_) sock $ \addrStats_ -> do
+        ms <- asks msgStore
+        g <- asks random
+        idSize <- asks $ queueIdBytes . config
+        kh <- asks serverIdentity
+        ks <- atomically . C.generateKeyPair =<< asks random
+        ServerConfig {smpServerVRange, smpHandshakeTimeout, information} <- asks config
+        let serverInfo = LB.toStrict . J.encode <$> information
+        labelMyThread $ "smp handshake for " <> transportName tp
+        liftIO (timeout smpHandshakeTimeout . runExceptT $ smpServerHandshake srvCert srvSignKey h ks kh smpServerVRange serverInfo $ getClientService ms g idSize) >>= \case
+          Just (Right th) -> runClientTransport addrStats_ th
+          _ -> pure ()
 
     getClientService :: s -> TVar ChaChaDRG -> Int -> SMPServiceRole -> X.CertificateChain -> XV.Fingerprint -> ExceptT TransportError IO ServiceId
     getClientService ms g idSize role cert fp = do
@@ -1041,7 +1051,10 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
                 hPutStrLn h "saving server state..."
                 unliftIO u $ saveServer False
                 hPutStrLn h "server state saved!"
-              CPHelp -> hPutStrLn h "commands: stats, stats-rts, clients, sockets, socket-threads, threads, server-info, delete, save, help, quit"
+              CPAddresses name n_ -> withUserRole $ do
+                stats_ <- unliftIO u $ asks addrStats
+                printTopAddresses h (addrStatsMap <$> stats_) name n_
+              CPHelp -> hPutStrLn h "commands: stats, stats-rts, clients, sockets, socket-threads, threads, server-info, delete, addresses, save, help, quit"
               CPQuit -> pure ()
               CPSkip -> pure ()
               where
@@ -1062,13 +1075,13 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
                     logError "Unauthorized control port command"
                     hPutStrLn h "AUTH"
 
-runClientTransport :: forall c s. (Transport c, MsgStoreClass s) => THandleSMP c 'TServer -> M s ()
-runClientTransport h@THandle {params = thParams@THandleParams {sessionId}} = do
+runClientTransport :: forall c s. (Transport c, MsgStoreClass s) => Maybe (AddrStats SMPAddrCounter) -> THandleSMP c 'TServer -> M s ()
+runClientTransport addrStats_ h@THandle {params = thParams@THandleParams {sessionId}} = do
   q <- asks $ tbqSize . config
   ts <- liftIO getSystemTime
   nextClientId <- asks clientSeq
   clientId <- atomically $ stateTVar nextClientId $ \next -> (next, next + 1)
-  c <- liftIO $ newClient clientId q thParams ts
+  c <- liftIO $ newClient clientId q thParams ts addrStats_
   runClientThreads c `finally` clientDisconnected c
   where
     runClientThreads :: Client s -> M s ()
@@ -1145,7 +1158,7 @@ cancelSub s = case subThread s of
 type VerifiedTransmissionOrError s = Either (Transmission BrokerMsg) (VerifiedTransmission s)
 
 receive :: forall c s. (Transport c, MsgStoreClass s) => THandleSMP c 'TServer -> s -> Client s -> M s ()
-receive h@THandle {params = THandleParams {thAuth, sessionId}} ms Client {rcvQ, sndQ, rcvActiveAt} = do
+receive h@THandle {params = THandleParams {thAuth, sessionId}} ms Client {rcvQ, sndQ, rcvActiveAt, clientAddrStats} = do
   labelMyThread . B.unpack $ "client $" <> encode sessionId <> " receive"
   sa <- asks serverActive
   stats <- asks serverStats
@@ -1155,6 +1168,9 @@ receive h@THandle {params = THandleParams {thAuth, sessionId}} ms Client {rcvQ,
     atomically . (writeTVar rcvActiveAt $!) =<< getSystemTime
     let (es, ts') = partitionEithers $ L.toList ts
         errs = map (second ERR) es
+    forM_ clientAddrStats $ \s -> do
+      unless (null es) $ addAddrCounter s SACErrors $ length es
+      forM_ ts' $ \(_, _, (_, _, cmd)) -> incAddrCounter s $ smpCmdCounter cmd
     errs' <- case ts' of
       (_, _, (_, _, Cmd p cmd)) : rest -> do
         let service = peerClientService =<< thAuth
@@ -1182,7 +1198,9 @@ receive h@THandle {params = THandleParams {thAuth, sessionId}} ms Client {rcvQ,
     verified :: ServerStats -> SignedTransmission Cmd -> VerificationResult s -> IO (VerifiedTransmissionOrError s)
     verified stats (_, _, t@(corrId, entId, Cmd _ command)) = \case
       VRVerified q -> pure $ Right (q, t)
-      VRFailed e -> Left (corrId, entId, ERR e) <$ when (e == AUTH) incAuthStat
+      VRFailed e -> do
+        forM_ clientAddrStats (`incAddrCounter` SACErrors)
+        Left (corrId, entId, ERR e) <$ when (e == AUTH) incAuthStat
         where
           incAuthStat = case command of
             SEND {} -> incStat $ msgSentAuth stats
@@ -1377,7 +1395,7 @@ client :: forall s. MsgStoreClass s => Server s -> s -> Client s -> M s ()
 client
   Server {subscribers, ntfSubscribers}
   ms
-  clnt@Client {clientId, rcvQ, sndQ, msgQ, clientTHParams = thParams'@THandleParams {sessionId}, procThreads} = do
+  clnt@Client {clientId, rcvQ, sndQ, msgQ, clientTHParams = thParams'@THandleParams {sessionId}, procThreads, clientAddrStats} = do
     labelMyThread . B.unpack $ "client $" <> encode sessionId <> " commands"
     let clntServiceId = (\THClientService {serviceId} -> serviceId) <$> (peerClientService =<< thAuth thParams')
         process batchSubs t acc@(rs, msgs) =
@@ -1422,25 +1440,30 @@ client
           getRelay = do
             ProxyAgent {smpAgent = a} <- asks proxyAgent
             liftIO (getConnectedSMPServerClient a srv) >>= \case
-              Just r -> Just <$> proxyServerResponse a r
+              Just r -> Just <$> proxyServerResponse a SACPrxyConnected r
               Nothing ->
                 forkProxiedCmd $
                   liftIO (runExceptT (getSMPServerClient'' a srv) `E.catches` clientHandlers)
-                    >>= proxyServerResponse a
-          proxyServerResponse :: SMPClientAgent 'Sender -> Either SMPClientError (OwnServer, SMPClient) -> M s BrokerMsg
-          proxyServerResponse a smp_ = do
+                    >>= proxyServerResponse a SACPrxyNew
+          proxyServerResponse :: SMPClientAgent 'Sender -> SMPAddrCounter -> Either SMPClientError (OwnServer, SMPClient) -> M s BrokerMsg
+          proxyServerResponse a otherCounter smp_ = do
             ServerStats {pRelays, pRelaysOwn} <- asks serverStats
             let inc = mkIncProxyStats pRelays pRelaysOwn
             case smp_ of
               Right (own, smp) -> do
                 inc own pRequests
                 case proxyResp smp of
-                  r@PKEY {} -> r <$ inc own pSuccesses
-                  r -> r <$ inc own pErrorsCompat
+                  r@PKEY {} -> do
+                    incAddrStats $ proxyDestCounter own smp SACPrxyOwn SACPrxyOnion otherCounter
+                    r <$ inc own pSuccesses
+                  r -> do
+                    incAddrStats SACPrxyFailed
+                    r <$ inc own pErrorsCompat
               Left e -> do
                 let own = isOwnServer a srv
                 inc own pRequests
                 inc own $ if temporaryClientError e then pErrorsConnect else pErrorsOther
+                incAddrStats SACPrxyFailed
                 logWarn $ "Error connecting: " <> decodeLatin1 (strEncode $ host srv) <> " " <> tshow e
                 pure . ERR $ smpProxyError e
             where
@@ -1460,16 +1483,24 @@ client
         liftIO (lookupSMPServerClient a sessId) >>= \case
           Just (own, smp) -> do
             inc own pRequests
+            let delivered = incAddrStats (proxyDestCounter own smp SACPfwdOwn SACPfwdOnion SACPfwdOther) >> inc own pSuccesses
             forkProxiedCmd $ do
               liftIO (runExceptT (forwardSMPTransmission smp corrId fwdV pubKey encBlock) `E.catches` clientHandlers)  >>= \case
-                Right r -> PRES r <$ inc own pSuccesses
+                Right r -> PRES r <$ delivered
                 Left e -> ERR (smpProxyError e) <$ case e of
-                  PCEProtocolError {} -> inc own pSuccesses
-                  _ -> inc own pErrorsOther
-          Nothing -> inc False pRequests >> inc False pErrorsConnect $> Just (ERR $ PROXY NO_SESSION)
+                  PCEProtocolError {} -> delivered
+                  _ -> incAddrStats SACPfwdFailed >> inc own pErrorsOther
+          Nothing -> incAddrStats SACPfwdFailed >> inc False pRequests >> inc False pErrorsConnect $> Just (ERR $ PROXY NO_SESSION)
       where
         forkProxiedCmd :: M s BrokerMsg -> M s (Maybe BrokerMsg)
         forkProxiedCmd = forkCmd serverClientConcurrency corrId (EntityId sessId)
+        proxyDestCounter :: OwnServer -> SMPClient -> SMPAddrCounter -> SMPAddrCounter -> SMPAddrCounter -> SMPAddrCounter
+        proxyDestCounter own smp ownCounter onionCounter otherCounter
+          | own = ownCounter
+          | THOnionHost _ <- transportHost' smp = onionCounter
+          | otherwise = otherCounter
+    incAddrStats :: SMPAddrCounter -> M s ()
+    incAddrStats c = liftIO $ forM_ clientAddrStats (`incAddrCounter` c)
     -- Run a slow command on a thread
     forkCmd :: (ServerConfig s -> Int) -> CorrId -> EntityId -> M s BrokerMsg -> M s (Maybe a)
     forkCmd concurrency corrId entId cmdAction = do
@@ -1494,15 +1525,19 @@ client
         Just nenv -> pure (Just nenv)
     -- Runs on a forked thread so RSLV does not block other commands;
     -- concurrency is limited by serverResolverConcurrency in forkCmd.
-    resolveNameMsg :: NamesEnv -> SimplexDomain -> M s BrokerMsg
-    resolveNameMsg nenv d = do
+    resolveNameMsg :: VersionSMP -> NamesEnv -> NameQuery -> M s BrokerMsg
+    resolveNameMsg v nenv q = do
       st <- asks (rslvStats . serverStats)
       (selector, msg) <-
-        liftIO (resolveName nenv d) <&> \case
-          Right rec -> (rslvSucc, RNAME rec)
-          Left e@NOT_FOUND -> (rslvNotFound, ERR $ NAME e)
+        liftIO (resolveName nenv q) <&> \case
+          Right res -> (if answered (registration res) then rslvSucc else rslvNotFound, RNAME res)
           Left e -> (rslvResolverErrs, ERR $ NAME e)
       incStat (selector st) $> msg
+      where
+        -- below v22 the encoder answers anything but a record as NAME NOT_FOUND
+        answered = \case
+          NRRegistered {} -> True
+          _ -> v >= nameAvailSMPVersion
     transportErr :: TransportError -> ErrorType
     transportErr = PROXY . BROKER . TRANSPORT
     mkIncProxyStats :: MonadIO m => ProxyStats -> ProxyStats -> OwnServer -> (ProxyStats -> IORef Int) -> m ()
@@ -1519,7 +1554,7 @@ client
       Cmd SProxyService (RFWD encBlock) -> (response . (corrId, NoEntity,) =<<) <$> processForwardedCommand encBlock
       Cmd SResolver (RSLV d) -> rslvNamesEnv >>= \case
         Nothing -> pure $ response (corrId, NoEntity, ERR (NAME NO_RESOLVER))
-        Just nenv -> forkCmd serverResolverConcurrency corrId NoEntity (resolveNameMsg nenv d)
+        Just nenv -> forkCmd serverResolverConcurrency corrId NoEntity (resolveNameMsg (thVersion thParams') nenv d)
       Cmd SSenderLink command -> case command of
         LKEY k -> withQueue $ \q qr -> checkMode QMMessaging qr $ secureQueue_ q k $>> getQueueLink_ q qr
         LGET -> withQueue $ \q qr -> checkContact qr $ getQueueLink_ q qr
@@ -2132,7 +2167,7 @@ client
           t' <- case tParse clntTHParams b of
             t :| [] -> pure $ tDecodeServer clntTHParams t
             _ -> throwE BLOCK
-          let clntThAuth = Just $ THAuthServer {serverPrivKey, peerClientService = Nothing, sessSecret' = Just clientSecret}
+          let clntThAuth = Just $ THAuthServer {serverPrivKey, peerClientService = Nothing, peerEntitlement = Nothing, sessSecret' = Just clientSecret}
               encodeResp r = do
                 r' <- case batchTransmissions clntTHParams [Right (Nothing, encodeTransmission clntTHParams r)] of
                   [] -> throwE INTERNAL -- at least 1 item is guaranteed from NonEmpty/Right
@@ -2150,7 +2185,7 @@ client
               Cmd SResolver (RSLV d) -> lift $ rslvNamesEnv >>= \case
                 Nothing -> pure $ Just (corrId', entId', ERR (NAME NO_RESOLVER))
                 Just nenv -> forkCmd serverResolverConcurrency corrId NoEntity $ do
-                  msg <- resolveNameMsg nenv d
+                  msg <- resolveNameMsg (thVersion clntTHParams) nenv d
                   either ERR id <$> runExceptT (encodeResp (corrId', entId', msg))
               -- INTERNAL because processCommand never returns Nothing for sender commands;
               -- `fst` drops the empty message only returned for SUB.

src/Simplex/Messaging/Server/AddressStats.hs

@@ -0,0 +1,250 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+
+module Simplex.Messaging.Server.AddressStats
+  ( AddrKey (..),
+    AddrCounter (..),
+    AddrStats (..),
+    AddrStatsMap,
+    AddrHistogram (..),
+    ServerAddrStats (..),
+    AddressStatsConfig (..),
+    defaultAddressStatsPeriod,
+    countBounds,
+    kilobyteBounds,
+    addrKey,
+    addrKeyText,
+    counterByName,
+    newServerAddrStats,
+    withAddrStats,
+    openAddrStats,
+    closeAddrStats,
+    incAddrCounter,
+    addAddrCounter,
+    rolloverAddrStats,
+    addressStatsThread,
+    topAddresses,
+    printTopAddresses,
+    addressesArgsP,
+    addressesArgs,
+    addrHistogramMetrics,
+  )
+where
+
+import Control.Applicative (optional)
+import Control.Monad
+import Control.Monad.IO.Unlift
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.Bits (shiftL, shiftR, (.&.), (.|.))
+import Data.ByteString.Char8 (ByteString)
+import Data.IORef
+import Data.Int (Int64)
+import qualified Data.IntMap.Strict as IM
+import Data.List (find, foldl', sortOn)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import Data.Maybe (fromMaybe)
+import Data.Ord (Down (..))
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
+import qualified Data.Text.IO as T
+import Data.Word (Word32, Word64)
+import Network.Socket (SockAddr (..), Socket, getPeerName, hostAddress6ToTuple, hostAddressToTuple)
+import Numeric (showHex)
+import Simplex.Messaging.TMap (TMap)
+import qualified Simplex.Messaging.TMap as TM
+import Simplex.Messaging.Util (atomicModifyIORef'_, bshow, labelMyThread, safeDecodeUtf8, threadDelay', tshow, whenM, (<$$>))
+import System.IO (Handle, hPutStrLn)
+import UnliftIO.Exception (finally, tryAny)
+import UnliftIO.STM
+
+data AddrKey
+  = AKIPv4 Word32
+  | AKIPv6 Word64
+  deriving (Eq, Ord, Show)
+
+class (Ord c, Enum c, Bounded c) => AddrCounter c where
+  counterName :: c -> Text
+  counterBounds :: c -> [Int]
+  counterBounds _ = countBounds
+  connectionsCounter :: c
+
+data AddrStats c = AddrStats
+  { connectionsCount :: TVar Int,
+    current :: Map c (IORef Int),
+    previous :: Map c (IORef Int)
+  }
+
+type AddrStatsMap c = TMap AddrKey (AddrStats c)
+
+data AddrHistogram = AddrHistogram
+  { bucketCounts :: [Int],
+    countSum :: Int,
+    addressCount :: Int,
+    periodMax :: Int
+  }
+  deriving (Eq, Show)
+
+data ServerAddrStats c = ServerAddrStats
+  { addrStatsMap :: AddrStatsMap c,
+    addrHistograms :: IORef (Map c AddrHistogram)
+  }
+
+newtype AddressStatsConfig = AddressStatsConfig
+  { period :: Int64
+  }
+  deriving (Show)
+
+defaultAddressStatsPeriod :: Int64
+defaultAddressStatsPeriod = 300
+
+countBounds :: [Int]
+countBounds = r10Bounds 5
+
+kilobyteBounds :: [Int]
+kilobyteBounds = r10Bounds 7
+
+r10Bounds :: Int -> [Int]
+r10Bounds decades =
+  [1 .. 9]
+    <> [(r * 10 ^ d + 50) `div` 100 | d <- [1 .. decades], r <- [100, 125, 160, 200, 250, 315, 400, 500, 630, 800]]
+    <> [10 ^ (decades + 1)]
+
+addrKey :: SockAddr -> Maybe AddrKey
+addrKey = \case
+  SockAddrInet _ a ->
+    let (b1, b2, b3, b4) = hostAddressToTuple a
+     in Just $ AKIPv4 $ foldl' (\acc b -> acc `shiftL` 8 .|. fromIntegral b) 0 [b1, b2, b3, b4]
+  SockAddrInet6 _ _ a _ -> Just $ case hostAddress6ToTuple a of
+    (0, 0, 0, 0, 0, 0xffff, w1, w2) -> AKIPv4 $ fromIntegral w1 `shiftL` 16 .|. fromIntegral w2
+    (w1, w2, w3, w4, _, _, _, _) -> AKIPv6 $ foldl' (\acc w -> acc `shiftL` 16 .|. fromIntegral w) 0 [w1, w2, w3, w4]
+  _ -> Nothing
+
+addrKeyText :: AddrKey -> Text
+addrKeyText = \case
+  AKIPv4 a -> T.intercalate "." $ map (\s -> tshow $ (a `shiftR` s) .&. 0xff) [24, 16, 8, 0]
+  AKIPv6 p -> T.intercalate ":" (map (\s -> T.pack $ showHex ((p `shiftR` s) .&. 0xffff) "") [48, 32, 16, 0]) <> "::/64"
+
+counterByName :: AddrCounter c => Text -> Maybe c
+counterByName name = find ((name ==) . counterName) [minBound .. maxBound]
+
+newServerAddrStats :: AddrCounter c => IO (ServerAddrStats c)
+newServerAddrStats = ServerAddrStats <$> TM.emptyIO <*> newIORef (M.fromList $ map (\c -> (c, emptyHistogram c)) [minBound .. maxBound])
+  where
+    emptyHistogram c = AddrHistogram {bucketCounts = map (const 0) (counterBounds c), countSum = 0, addressCount = 0, periodMax = 0}
+
+newAddrStats :: AddrCounter c => IO (AddrStats c)
+newAddrStats = AddrStats <$> newTVarIO 0 <*> newCells <*> newCells
+  where
+    newCells = M.fromList <$> mapM (\c -> (c,) <$> newIORef 0) [minBound .. maxBound]
+
+withAddrStats :: (AddrCounter c, MonadUnliftIO m) => Maybe (AddrStatsMap c) -> Socket -> (Maybe (AddrStats c) -> m a) -> m a
+withAddrStats m_ sock action = case m_ of
+  Just m ->
+    liftIO (addrKey <$$> tryAny (getPeerName sock)) >>= \case
+      Right (Just k) -> do
+        s <- liftIO $ openAddrStats m k
+        action (Just s) `finally` liftIO (closeAddrStats s)
+      _ -> action Nothing
+  Nothing -> action Nothing
+
+openAddrStats :: AddrCounter c => AddrStatsMap c -> AddrKey -> IO (AddrStats c)
+openAddrStats m k = do
+  new <- maybe newAddrStats pure =<< TM.lookupIO k m
+  s <- atomically $ TM.lookup k m >>= maybe (new <$ TM.insert k new m) pure >>= \entry -> entry <$ modifyTVar' (connectionsCount entry) (+ 1)
+  s <$ incAddrCounter s connectionsCounter
+
+closeAddrStats :: AddrStats c -> IO ()
+closeAddrStats AddrStats {connectionsCount} = atomically $ modifyTVar' connectionsCount (subtract 1)
+
+incAddrCounter :: AddrCounter c => AddrStats c -> c -> IO ()
+incAddrCounter s c = addAddrCounter s c 1
+
+addAddrCounter :: AddrCounter c => AddrStats c -> c -> Int -> IO ()
+addAddrCounter AddrStats {current} c n = forM_ (M.lookup c current) $ \cell -> atomicModifyIORef'_ cell (+ n)
+
+rolloverAddrStats :: AddrCounter c => ServerAddrStats c -> IO ()
+rolloverAddrStats ServerAddrStats {addrStatsMap, addrHistograms} = do
+  entries <- M.toList <$> readTVarIO addrStatsMap
+  closingCounts <- forM entries $ \(k, s) -> do
+    counts <- closePeriod s
+    when (all (== 0) counts) $ atomically $ deleteIdle k s
+    pure counts
+  let periodCounts = M.unionsWith (<>) $ map (M.map (: []) . M.filter (> 0)) closingCounts
+  atomicModifyIORef'_ addrHistograms $ M.mapWithKey $ \c -> addPeriodCounts (counterBounds c) (M.findWithDefault [] c periodCounts)
+  where
+    closePeriod AddrStats {current, previous} = M.traverseWithKey closeCell current
+      where
+        closeCell c cell = do
+          n <- atomicModifyIORef' cell (0,)
+          forM_ (M.lookup c previous) (`writeIORef` n)
+          pure n
+    deleteIdle k AddrStats {connectionsCount} =
+      whenM ((0 ==) <$> readTVar connectionsCount) $ TM.delete k addrStatsMap
+
+addPeriodCounts :: [Int] -> [Int] -> AddrHistogram -> AddrHistogram
+addPeriodCounts bounds ns AddrHistogram {bucketCounts, countSum, addressCount} =
+  AddrHistogram
+    { bucketCounts = zipWith (+) bucketCounts $ scanl1 (+) $ map (\i -> IM.findWithDefault 0 i boundCounts) [0 .. length bounds - 1],
+      countSum = countSum + sum ns,
+      addressCount = addressCount + length ns,
+      periodMax = maximum (0 : ns)
+    }
+  where
+    boundCounts = IM.fromListWith (+) $ map (\n -> (length $ takeWhile (< n) bounds, 1)) ns
+
+addressStatsThread :: AddrCounter c => AddressStatsConfig -> ServerAddrStats c -> IO ()
+addressStatsThread AddressStatsConfig {period} stats = do
+  labelMyThread "addressStatsThread"
+  forever $ threadDelay' (period * 1000000) >> rolloverAddrStats stats
+
+topAddresses :: AddrCounter c => AddrStatsMap c -> c -> Int -> IO [(AddrKey, Int, Int)]
+topAddresses m c n = do
+  entries <- M.toList <$> readTVarIO m
+  counts <- forM entries $ \(k, AddrStats {previous, current}) -> (k,,) <$> cellValue previous <*> cellValue current
+  pure $ take n $ sortOn (\(_, p, cur) -> Down (p + cur)) $ filter (\(_, p, cur) -> p + cur > 0) counts
+  where
+    cellValue = maybe (pure 0) readIORef . M.lookup c
+
+printTopAddresses :: AddrCounter c => Handle -> Maybe (AddrStatsMap c) -> Text -> Maybe Int -> IO ()
+printTopAddresses h m_ name n_ = case m_ of
+  Just m -> case counterByName name of
+    Just c -> do
+      rows <- topAddresses m c (fromMaybe 10 n_)
+      hPutStrLn h "address,previous,current"
+      forM_ rows $ \(k, p, cur) -> T.hPutStrLn h $ addrKeyText k <> "," <> tshow p <> "," <> tshow cur
+    Nothing -> hPutStrLn h "error: unknown counter"
+  Nothing -> hPutStrLn h "error: address statistics are off"
+
+addressesArgsP :: A.Parser (Text, Maybe Int)
+addressesArgsP = (,) <$> (A.space *> (safeDecodeUtf8 <$> A.takeTill (== ' '))) <*> optional (A.space *> A.decimal)
+
+addressesArgs :: Text -> Maybe Int -> ByteString
+addressesArgs name n_ = encodeUtf8 name <> maybe "" ((" " <>) . bshow) n_
+
+addrHistogramMetrics :: AddrCounter c => Text -> Text -> Map c AddrHistogram -> Text
+addrHistogramMetrics prefix tsEpoch histograms =
+  "# Client addresses\n\
+  \# ----------------\n\
+  \\n"
+    <> "# HELP " <> countMetric <> " Counts of client addresses per period\n"
+    <> "# TYPE " <> countMetric <> " histogram\n"
+    <> T.concat (map countLines hs)
+    <> "\n# HELP " <> maxMetric <> " Maximum count of a client address in the last period\n"
+    <> "# TYPE " <> maxMetric <> " gauge\n"
+    <> T.concat (map (\(c, AddrHistogram {periodMax}) -> sample maxMetric c [] periodMax) hs)
+    <> "\n"
+  where
+    hs = M.toList histograms
+    countMetric = prefix <> "_client_address_period_count"
+    maxMetric = prefix <> "_client_address_period_max"
+    countLines (c, AddrHistogram {bucketCounts, countSum, addressCount}) =
+      T.concat (zipWith (\b cnt -> sample (countMetric <> "_bucket") c [("le", tshow b)] cnt) (counterBounds c) bucketCounts)
+        <> sample (countMetric <> "_bucket") c [("le", "+Inf")] addressCount
+        <> sample (countMetric <> "_sum") c [] countSum
+        <> sample (countMetric <> "_count") c [] addressCount
+    sample metric c labels v =
+      metric <> "{" <> T.intercalate "," (map (\(l, lv) -> l <> "=\"" <> lv <> "\"") (("counter", counterName c) : labels)) <> "} " <> tshow v <> " " <> tsEpoch <> "\n"

src/Simplex/Messaging/Server/CLI.hs

@@ -44,6 +44,8 @@ module Simplex.Messaging.Server.CLI
     checkSavedFingerprint,
     iniTransports,
     iniDBOptions,
+    iniAddressStats,
+    addressStatsIniContent,
     printServerConfig,
     printServerTransports,
     printSMPServerConfig,
@@ -73,13 +75,14 @@ import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..))
 import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolServer (..), ProtocolTypeI)
+import Simplex.Messaging.Server.AddressStats (AddressStatsConfig (..), defaultAddressStatsPeriod)
 import Simplex.Messaging.Server.Env.STM (ServerStoreCfg (..), StartOptions (..), dbStoreCfg, storeLogFile')
 import Simplex.Messaging.Server.Main.GitCommit
 import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
 import Simplex.Messaging.Transport (ASrvTransport, ATransport (..), TLS, Transport (..), simplexMQVersion)
 import Simplex.Messaging.Transport.Server (AddHTTP, loadFileFingerprint)
 import Simplex.Messaging.Transport.WebSockets (WS)
-import Simplex.Messaging.Util (eitherToMaybe, whenM)
+import Simplex.Messaging.Util (eitherToMaybe, tshow, whenM)
 import System.Directory (doesDirectoryExist, listDirectory, removeDirectoryRecursive, removePathForcibly)
 import System.Environment (lookupEnv)
 import System.Exit (exitFailure)
@@ -435,6 +438,19 @@ iniDBOptions ini _default@DBOpts {connstr, schema, poolSize} =
       createSchema = False
     }
 
+iniAddressStats :: Ini -> Maybe AddressStatsConfig
+iniAddressStats ini =
+  AddressStatsConfig {period = readIniDefault defaultAddressStatsPeriod "ADDRESS_STATS" "period" ini}
+    <$ settingIsOn "ADDRESS_STATS" "enable" ini
+
+addressStatsIniContent :: Text
+addressStatsIniContent =
+  "[ADDRESS_STATS]\n\
+  \# Command counts per client address, shown by the control port command `addresses`\n\
+  \# and aggregated in Prometheus metrics.\n\
+  \enable = off\n"
+    <> ("period = " <> tshow defaultAddressStatsPeriod <> "\n")
+
 printServerConfig :: String -> [(ServiceName, ASrvTransport, AddHTTP)] -> Maybe FilePath -> IO ()
 printServerConfig protocol transports logFile = do
   putStrLn $ case logFile of

src/Simplex/Messaging/Server/Control.hs

@@ -7,8 +7,10 @@ module Simplex.Messaging.Server.Control
   ) where
 
 import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.Text (Text)
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (BasicAuth, BlockingInfo, SenderId)
+import Simplex.Messaging.Server.AddressStats (addressesArgs, addressesArgsP)
 
 data CPClientRole = CPRNone | CPRUser | CPRAdmin
   deriving (Eq, Show)
@@ -28,6 +30,7 @@ data ControlProtocol
   | CPStatus SenderId
   | CPBlock SenderId BlockingInfo
   | CPUnblock SenderId
+  | CPAddresses Text (Maybe Int)
   | CPSave
   | CPHelp
   | CPQuit
@@ -49,6 +52,7 @@ instance StrEncoding ControlProtocol where
     CPStatus sId -> "status " <> strEncode sId
     CPBlock sId info -> "block " <> strEncode sId <> " " <> strEncode info
     CPUnblock sId -> "unblock " <> strEncode sId
+    CPAddresses name n_ -> "addresses " <> addressesArgs name n_
     CPSave -> "save"
     CPHelp -> "help"
     CPQuit -> "quit"
@@ -69,6 +73,7 @@ instance StrEncoding ControlProtocol where
       "status" -> CPStatus <$> _strP
       "block" -> CPBlock <$> _strP <*> _strP
       "unblock" -> CPUnblock <$> _strP
+      "addresses" -> uncurry CPAddresses <$> addressesArgsP
       "save" -> pure CPSave
       "help" -> pure CPHelp
       "quit" -> pure CPQuit

src/Simplex/Messaging/Server/Env/STM.hs

@@ -31,6 +31,8 @@ module Simplex.Messaging.Server.Env.STM
     SubscribedClients,
     ProxyAgent (..),
     Client (..),
+    SMPAddrCounter (..),
+    smpCmdCounter,
     ClientId,
     ClientSub (..),
     Sub (..),
@@ -111,6 +113,7 @@ import Simplex.Messaging.Client.Agent (SMPClientAgent, SMPClientAgentConfig, new
 import Simplex.Messaging.Crypto (KeyHash (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Protocol
+import Simplex.Messaging.Server.AddressStats (AddrCounter (..), AddrStats, AddressStatsConfig, ServerAddrStats, newServerAddrStats)
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.Information
 import Simplex.Messaging.Server.MsgStore.Journal
@@ -183,6 +186,7 @@ data ServerConfig s = ServerConfig
     -- | interval and file to save prometheus metrics
     prometheusInterval :: Maybe Int,
     prometheusMetricsFile :: FilePath,
+    addressStats :: Maybe AddressStatsConfig,
     -- | notification delivery interval
     ntfDeliveryInterval :: Int,
     -- | interval between sending pending END events to unsubscribed clients, seconds
@@ -285,7 +289,8 @@ data Env s = Env
     sockets :: TVar [(ServiceName, SocketState)],
     clientSeq :: TVar ClientId,
     proxyAgent :: ProxyAgent, -- senders served on this proxy
-    namesEnv :: Maybe NamesEnv -- public-namespace resolver, present when [NAMES] enable: on
+    namesEnv :: Maybe NamesEnv, -- public-namespace resolver, present when [NAMES] enable: on
+    addrStats :: Maybe (ServerAddrStats SMPAddrCounter)
   }
 
 msgStore :: Env s -> s
@@ -465,9 +470,117 @@ data Client s = Client
     connected :: TVar Bool,
     createdAt :: SystemTime,
     rcvActiveAt :: TVar SystemTime,
-    sndActiveAt :: TVar SystemTime
+    sndActiveAt :: TVar SystemTime,
+    clientAddrStats :: Maybe (AddrStats SMPAddrCounter)
   }
 
+data SMPAddrCounter
+  = SACConnections
+  | SACErrors
+  | SACNew
+  | SACSub
+  | SACSubs
+  | SACKey
+  | SACRKey
+  | SACLSet
+  | SACLDel
+  | SACNKey
+  | SACNDel
+  | SACGet
+  | SACAck
+  | SACOff
+  | SACDel
+  | SACQue
+  | SACSKey
+  | SACSend
+  | SACPing
+  | SACLKey
+  | SACLGet
+  | SACNSub
+  | SACNSubs
+  | SACPrxy
+  | SACPfwd
+  | SACRfwd
+  | SACRslv
+  | SACPrxyOwn
+  | SACPrxyConnected
+  | SACPrxyNew
+  | SACPrxyOnion
+  | SACPrxyFailed
+  | SACPfwdOwn
+  | SACPfwdOther
+  | SACPfwdOnion
+  | SACPfwdFailed
+  deriving (Eq, Ord, Enum, Bounded, Show)
+
+instance AddrCounter SMPAddrCounter where
+  counterName = \case
+    SACConnections -> "connections"
+    SACErrors -> "errors"
+    SACNew -> "NEW"
+    SACSub -> "SUB"
+    SACSubs -> "SUBS"
+    SACKey -> "KEY"
+    SACRKey -> "RKEY"
+    SACLSet -> "LSET"
+    SACLDel -> "LDEL"
+    SACNKey -> "NKEY"
+    SACNDel -> "NDEL"
+    SACGet -> "GET"
+    SACAck -> "ACK"
+    SACOff -> "OFF"
+    SACDel -> "DEL"
+    SACQue -> "QUE"
+    SACSKey -> "SKEY"
+    SACSend -> "SEND"
+    SACPing -> "PING"
+    SACLKey -> "LKEY"
+    SACLGet -> "LGET"
+    SACNSub -> "NSUB"
+    SACNSubs -> "NSUBS"
+    SACPrxy -> "PRXY"
+    SACPfwd -> "PFWD"
+    SACRfwd -> "RFWD"
+    SACRslv -> "RSLV"
+    SACPrxyOwn -> "PRXY_own"
+    SACPrxyConnected -> "PRXY_connected"
+    SACPrxyNew -> "PRXY_new"
+    SACPrxyOnion -> "PRXY_onion"
+    SACPrxyFailed -> "PRXY_failed"
+    SACPfwdOwn -> "PFWD_own"
+    SACPfwdOther -> "PFWD_other"
+    SACPfwdOnion -> "PFWD_onion"
+    SACPfwdFailed -> "PFWD_failed"
+  connectionsCounter = SACConnections
+
+smpCmdCounter :: Cmd -> SMPAddrCounter
+smpCmdCounter (Cmd _ cmd) = case cmd of
+  NEW _ -> SACNew
+  SUB -> SACSub
+  SUBS {} -> SACSubs
+  KEY _ -> SACKey
+  RKEY _ -> SACRKey
+  LSET {} -> SACLSet
+  LDEL -> SACLDel
+  NKEY {} -> SACNKey
+  NDEL -> SACNDel
+  GET -> SACGet
+  ACK _ -> SACAck
+  OFF -> SACOff
+  DEL -> SACDel
+  QUE -> SACQue
+  SKEY _ -> SACSKey
+  SEND {} -> SACSend
+  PING -> SACPing
+  LKEY _ -> SACLKey
+  LGET -> SACLGet
+  NSUB -> SACNSub
+  NSUBS {} -> SACNSubs
+  PRXY {} -> SACPrxy
+  PFWD {} -> SACPfwd
+  RFWD _ -> SACRfwd
+  RSLV _ -> SACRslv
+
 type VerifiedTransmission s = (Maybe (StoreQueue s, QueueRec), Transmission Cmd)
 
 type ResponseAndMessage = (Transmission BrokerMsg, Maybe (Transmission BrokerMsg))
@@ -520,8 +633,8 @@ newServerSubscribers = do
   pendingEvents <- newTVarIO IM.empty
   pure ServerSubscribers {subQ, queueSubscribers, serviceSubscribers, totalServiceSubs, subClients, pendingEvents}
 
-newClient :: ClientId -> Natural -> THandleParams SMPVersion 'TServer -> SystemTime -> IO (Client s)
-newClient clientId qSize clientTHParams createdAt = do
+newClient :: ClientId -> Natural -> THandleParams SMPVersion 'TServer -> SystemTime -> Maybe (AddrStats SMPAddrCounter) -> IO (Client s)
+newClient clientId qSize clientTHParams createdAt clientAddrStats = do
   subscriptions <- TM.emptyIO
   ntfSubscriptions <- TM.emptyIO
   serviceSubscribed <- newTVarIO False
@@ -556,7 +669,8 @@ newClient clientId qSize clientTHParams createdAt = do
         connected,
         createdAt,
         rcvActiveAt,
-        sndActiveAt
+        sndActiveAt,
+        clientAddrStats
       }
 
 newSubscription :: SubscriptionThread -> STM Sub
@@ -571,7 +685,7 @@ newProhibitedSub = do
   return Sub {subThread = ProhibitSub, delivered}
 
 newEnv :: ServerConfig s -> IO (Env s)
-newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smpAgentCfg, information, messageExpiration, idleQueueInterval, msgQueueQuota, maxJournalMsgCount, maxJournalStateLines, namesConfig} = do
+newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smpAgentCfg, information, messageExpiration, idleQueueInterval, msgQueueQuota, maxJournalMsgCount, maxJournalStateLines, namesConfig, addressStats} = do
   serverActive <- newTVarIO True
   server <- newServer
   msgStore_ <- case serverStoreCfg of
@@ -626,6 +740,7 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp
       Right _ -> logInfo "[NAMES] endpoint probe ok"
       Left e -> logWarn $ "[NAMES] endpoint probe failed (server will still start, RSLV will return ERR (NAME ...) until reachable): " <> tshow e
     pure env
+  addrStats <- mapM (const newServerAddrStats) addressStats
   pure
     Env
       { serverActive,
@@ -642,7 +757,8 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp
         sockets,
         clientSeq,
         proxyAgent,
-        namesEnv
+        namesEnv,
+        addrStats
       }
   where
     loadStoreLog :: StoreQueueClass q => (RecipientId -> QueueRec -> IO q) -> FilePath -> STMQueueStore q -> IO ()

src/Simplex/Messaging/Server/Main.hs

@@ -578,6 +578,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
               serverStatsBackupFile = logStats $> combine logPath "smp-server-stats.log",
               prometheusInterval = eitherToMaybe (lookupValue "STORE_LOG" "prometheus_interval" ini) >>= readMaybe . T.unpack,
               prometheusMetricsFile = combine logPath "smp-server-metrics.txt",
+              addressStats = iniAddressStats ini,
               pendingENDInterval = 15000000, -- 15 seconds
               ntfDeliveryInterval = 1500000, -- 1.5 second
               smpServerVRange = supportedServerSMPRelayVRange,

src/Simplex/Messaging/Server/Main/GitCommit.hs

@@ -6,14 +6,25 @@ module Simplex.Messaging.Server.Main.GitCommit
   ) where
 
 import Language.Haskell.TH
+import Language.Haskell.TH.Syntax (addDependentFile)
 import System.Process
 import Control.Exception
+import Control.Monad (filterM)
+import System.Directory (doesFileExist)
 import System.Exit
+import System.FilePath ((</>))
 
 gitCommit :: Q Exp
-gitCommit = stringE . commit =<< runIO (try $ readProcessWithExitCode "git" ["rev-parse", "HEAD"] "")
+gitCommit =
+  runIO gitHead >>= \case
+    Right (ExitSuccess, out, _)
+      | [commit, gitDir] <- lines out -> do
+          -- without these dependencies GHC recompilation check would not know that the commit changed.
+          -- HEAD reflog is updated on any HEAD change and, unlike branch ref files, git gc cannot remove it
+          -- mid-build; it is absent when reflogs are disabled, and addDependentFile fails on a missing file
+          mapM_ addDependentFile =<< runIO (filterM doesFileExist [gitDir </> "HEAD", gitDir </> "logs" </> "HEAD"])
+          stringE commit
+    _ -> stringE ""
   where
-    commit :: Either SomeException (ExitCode, String, String) -> String
-    commit = \case
-      Right (ExitSuccess, out, _) -> take 40 out
-      _ -> ""
+    gitHead :: IO (Either SomeException (ExitCode, String, String))
+    gitHead = try $ readProcessWithExitCode "git" ["rev-parse", "HEAD", "--git-dir"] ""

src/Simplex/Messaging/Server/Main/Init.hs

@@ -25,7 +25,7 @@ import Network.Socket (HostName)
 import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..))
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol (BasicAuth)
-import Simplex.Messaging.Server.CLI (SignAlgorithm, onOff)
+import Simplex.Messaging.Server.CLI (SignAlgorithm, addressStatsIniContent, onOff)
 import Simplex.Messaging.Server.Env.STM
 import Simplex.Messaging.Server.Expiration (ExpirationConfig (..))
 import Simplex.Messaging.Server.Information (Entity (..), ServerPublicInfo (..))
@@ -176,7 +176,9 @@ iniFileContent cfgPath logPath opts host basicAuth controlPortPwds =
         \disconnect = on\n"
     <> ("ttl = " <> tshow (ttl defaultInactiveClientExpiration) <> "\n")
     <> ("check_interval = " <> tshow (checkInterval defaultInactiveClientExpiration))
-    <> "\n\n\
+    <> "\n\n"
+    <> addressStatsIniContent
+    <> "\n\
         \[WEB]\n\
         \# Set path to generate static mini-site for server information and qr codes/links\n"
     <> ("static_path = " <> T.pack (fromMaybe defaultStaticPath webStaticPath) <> "\n\n")

src/Simplex/Messaging/Server/MsgStore/Postgres.hs

@@ -110,10 +110,9 @@ instance MsgStoreClass PostgresMsgStore where
   expireOldMessages :: Bool -> PostgresMsgStore -> Int64 -> Int64 -> IO MessageStats
   expireOldMessages _tty ms now ttl =
     maybeFirstRow' newMessageStats toMessageStats $ withConnection st $ \db ->
-      DB.query db "CALL expire_old_messages(?,?,?,0,0,0)" (oldQueue, oldMsg, batchSize)
+      DB.query db "CALL expire_old_messages(?,?,0,0,0)" (oldMsg, batchSize)
     where
       st = dbStore $ queueStore_ ms
-      oldQueue = 0 :: Int64 -- expire all queues
       oldMsg = now - ttl
       batchSize = 10000 :: Int
       toMessageStats (expiredMsgsCount, storedMsgsCount, storedQueues) =

src/Simplex/Messaging/Server/Names.hs

@@ -20,7 +20,9 @@ import Control.Logger.Simple (logError)
 import Data.Bifunctor (first)
 import Data.Maybe (fromMaybe)
 import qualified Data.Text as T
-import Simplex.Messaging.Protocol (NameErrorType (..), NameRecord)
+import Data.Text.Encoding (decodeLatin1)
+import Simplex.Messaging.Encoding
+import Simplex.Messaging.Protocol (NameErrorType (..), NameQuery, NameResponse)
 import Simplex.Messaging.Server.Names.HttpResolver
   ( ResolverEnv,
     ResolverError (..),
@@ -30,7 +32,6 @@ import Simplex.Messaging.Server.Names.HttpResolver
     newResolverEnv,
     resolveHttp,
   )
-import Simplex.Messaging.SimplexName (SimplexDomain, fullDomainName)
 import System.Timeout (timeout)
 
 data NamesConfig = NamesConfig
@@ -58,9 +59,9 @@ pingEndpoint :: NamesEnv -> IO (Either ResolverError ())
 pingEndpoint NamesEnv {resolverEnv, config} =
   fromMaybe (Left ResolverTimeout) <$> timeout (resolverTimeoutMs config * 1000) (healthHttp resolverEnv)
 
-resolveName :: NamesEnv -> SimplexDomain -> IO (Either NameErrorType NameRecord)
-resolveName env d = do
-  r <- E.try (timeout (resolverTimeoutMs (config env) * 1000) (fetch env d))
+resolveName :: NamesEnv -> NameQuery -> IO (Either NameErrorType NameResponse)
+resolveName env q = do
+  r <- E.try (timeout (resolverTimeoutMs (config env) * 1000) (fetch env q))
   case r of
     Right result -> pure (fromMaybe (Left (RESOLVER "timeout")) result)
     Left e
@@ -69,14 +70,12 @@ resolveName env d = do
           logError $ "[NAMES] resolver fetch raised " <> T.pack (E.displayException e)
           pure (Left (RESOLVER "resolver error"))
 
-fetch :: NamesEnv -> SimplexDomain -> IO (Either NameErrorType NameRecord)
-fetch NamesEnv {resolverEnv} d =
-  first mapResolverError <$> resolveHttp resolverEnv (fullDomainName d)
+fetch :: NamesEnv -> NameQuery -> IO (Either NameErrorType NameResponse)
+fetch NamesEnv {resolverEnv} q =
+  first mapResolverError <$> resolveHttp resolverEnv (decodeLatin1 $ smpEncode q)
 
 mapResolverError :: ResolverError -> NameErrorType
 mapResolverError = \case
-  HttpStatusErr 404 -> NOT_FOUND
-  HttpStatusErr 400 -> NOT_FOUND
   HttpStatusErr code -> RESOLVER ("HTTP " <> T.pack (show code))
   HttpFailure _ -> RESOLVER "transport failure"
   BodyTooLarge -> RESOLVER "response too large"

src/Simplex/Messaging/Server/Names/HttpResolver.hs

@@ -8,10 +8,12 @@
 --
 -- The Python REST resolver (see scripts/resolver/snrc-resolve.py) exposes
 --
---   GET /resolve/<name>   -> 200 with a NameRecord JSON document
---                            404 / 400 for unknown names / TLDs
---                            502 for upstream RPC failures
---   GET /health           -> 200 when the resolver process is ready
+--   GET /v2/resolve/<query> -> 200 with a NameRegistration JSON document, for
+--                              all three registration shapes; 400 for unknown
+--                              TLDs, 502 for upstream RPC failures
+--   GET /v1/resolve/<name>  -> 200 with a NameRecord, what relays before SMP
+--                              v22 call as /resolve
+--   GET /health             -> 200 when the resolver process is ready
 --
 -- Boundary properties:
 --   * Response body read with `brReadSome maxResponseBytes` — adversarial
@@ -57,7 +59,7 @@ import qualified Network.HTTP.Client as HC
 import Network.HTTP.Client.TLS (tlsManagerSettings)
 import qualified Network.HTTP.Types as HT
 import Network.HTTP.Types.URI (urlEncode)
-import Simplex.Messaging.Names.Record (NameRecord)
+import Simplex.Messaging.Names.Record (NameResponse)
 
 data RpcAuth = AuthBearer Text | AuthBasic Text Text
 
@@ -108,14 +110,12 @@ authHeader = \case
     let encoded = BAE.convertToBase BAE.Base64 (encodeUtf8 u <> ":" <> encodeUtf8 p) :: ByteString
      in ("Authorization", "Basic " <> encoded)
 
--- | GET <baseUrl>/resolve/<percent-encoded name>, decoding the 200 body
--- directly into a NameRecord in one pass (no intermediate Aeson Value). The
--- name is percent-encoded (every non-unreserved byte per RFC 3986): the
--- resolver expects raw labels, so slashes/punctuation must not alter the path.
-resolveHttp :: ResolverEnv -> Text -> IO (Either ResolverError NameRecord)
-resolveHttp env name =
+-- | The query is a name or a bracketed label hash, percent-encoded (every
+-- non-unreserved byte per RFC 3986) so it cannot alter the path.
+resolveHttp :: ResolverEnv -> Text -> IO (Either ResolverError NameResponse)
+resolveHttp env q =
   (>>= first InvalidJson . J.eitherDecodeStrict . BL.toStrict)
-    <$> httpGet env ("/resolve/" <> B.unpack (urlEncode True (encodeUtf8 name)))
+    <$> httpGet env ("/v2/resolve/" <> B.unpack (urlEncode True (encodeUtf8 q)))
 
 -- | GET <baseUrl>/health; success = reachable with status < 400. The body is
 -- size-capped but NOT decoded — the probe only checks reachability.

src/Simplex/Messaging/Server/Prometheus.hs

@@ -14,12 +14,15 @@ module Simplex.Messaging.Server.Prometheus
 import Data.Int (Int64)
 import qualified Data.IntMap.Strict as IM
 import Data.List (mapAccumL)
+import Data.Map.Strict (Map)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time.Clock (UTCTime (..), diffUTCTime)
 import Data.Time.Clock.System (systemEpochDay)
 import Data.Time.Format.ISO8601 (iso8601Show)
 import Network.Socket (ServiceName)
+import Simplex.Messaging.Server.AddressStats (AddrHistogram, addrHistogramMetrics)
+import Simplex.Messaging.Server.Env.STM (SMPAddrCounter)
 import Simplex.Messaging.Server.MsgStore.Types (LoadedQueueCounts (..))
 import Simplex.Messaging.Server.QueueStore.Types (EntityCounts (..))
 import Simplex.Messaging.Server.Stats
@@ -46,7 +49,8 @@ data RealTimeMetrics = RealTimeMetrics
     deliveredTimes :: TimeBuckets,
     smpSubs :: RTSubscriberMetrics,
     ntfSubs :: RTSubscriberMetrics,
-    loadedCounts :: LoadedQueueCounts
+    loadedCounts :: LoadedQueueCounts,
+    addressHistograms :: Maybe (Map SMPAddrCounter AddrHistogram)
   }
 
 data RTSubscriberMetrics = RTSubscriberMetrics
@@ -59,7 +63,7 @@ data RTSubscriberMetrics = RTSubscriberMetrics
 {-# FOURMOLU_DISABLE\n#-}
 prometheusMetrics :: ServerMetrics -> RealTimeMetrics -> UTCTime -> Text
 prometheusMetrics sm rtm ts =
-  time <> queues <> subscriptions <> messages <> ntfMessages <> ntfs <> relays <> services <> names <> info
+  time <> queues <> subscriptions <> messages <> ntfMessages <> ntfs <> relays <> services <> names <> clientAddresses <> info
   where
     ServerMetrics {statsData, activeQueueCounts = ps, activeNtfCounts = psNtf, entityCounts, rtsOptions} = sm
     RealTimeMetrics
@@ -70,7 +74,8 @@ prometheusMetrics sm rtm ts =
         deliveredTimes,
         smpSubs,
         ntfSubs,
-        loadedCounts
+        loadedCounts,
+        addressHistograms
       } = rtm
     ServerStatsData
       { _fromTime,
@@ -469,11 +474,11 @@ prometheusMetrics sm rtm ts =
           \# TYPE simplex_smp_names_reqs counter\n\
           \simplex_smp_names_reqs " <> mshow _rslvReqs <> "\n# rslvReqs\n\
           \\n\
-          \# HELP simplex_smp_names_success NameRecord successfully resolved and returned.\n\
+          \# HELP simplex_smp_names_success NameRecord resolved, or availability answered.\n\
           \# TYPE simplex_smp_names_success counter\n\
           \simplex_smp_names_success " <> mshow _rslvSucc <> "\n# rslvSucc\n\
           \\n\
-          \# HELP simplex_smp_names_not_found Name not registered (resolver returned 404 / 400).\n\
+          \# HELP simplex_smp_names_not_found Answers a client below v22 reads as NOT_FOUND.\n\
           \# TYPE simplex_smp_names_not_found counter\n\
           \simplex_smp_names_not_found " <> mshow _rslvNotFound <> "\n# rslvNotFound\n\
           \\n\
@@ -485,6 +490,7 @@ prometheusMetrics sm rtm ts =
           \# TYPE simplex_smp_names_disabled counter\n\
           \simplex_smp_names_disabled " <> mshow _rslvDisabled <> "\n# rslvDisabled\n\
           \\n"
+    clientAddresses = maybe "" (addrHistogramMetrics "simplex_smp" $ tsEpoch ts) addressHistograms
     info =
       "# Info\n\
       \# ----\n\

src/Simplex/Messaging/Server/QueueStore/Postgres.hs

@@ -159,7 +159,8 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
           db
           [sql|
             SELECT
-              (SELECT COUNT(1) FROM msg_queues WHERE deleted_at IS NULL) AS queue_count,
+              -- estimate via reltuples to avoid a full heap scan on every scrape
+              (SELECT GREATEST(reltuples, 0)::bigint FROM pg_class WHERE oid = 'msg_queues'::regclass) AS queue_count,
               (SELECT COUNT(1) FROM msg_queues WHERE deleted_at IS NULL AND notifier_id IS NOT NULL) AS notifier_count,
               (SELECT COUNT(1) FROM services WHERE service_role = ?) AS rcv_service_count,
               (SELECT COUNT(1) FROM services WHERE service_role = ?) AS ntf_service_count,

src/Simplex/Messaging/Server/QueueStore/Postgres/Migrations.hs

@@ -20,7 +20,9 @@ serverSchemaMigrations =
     ("20250320_short_links", m20250320_short_links, Just down_m20250320_short_links),
     ("20250514_service_certs", m20250514_service_certs, Just down_m20250514_service_certs),
     ("20250903_store_messages", m20250903_store_messages, Just down_m20250903_store_messages),
-    ("20250915_queue_ids_hash", m20250915_queue_ids_hash, Just down_m20250915_queue_ids_hash)
+    ("20250915_queue_ids_hash", m20250915_queue_ids_hash, Just down_m20250915_queue_ids_hash),
+    ("20260916_prometheus_indexes", m20260916_prometheus_indexes, Just down_m20260916_prometheus_indexes),
+    ("20260917_msg_queues_hot", m20260917_msg_queues_hot, Just down_m20260917_msg_queues_hot)
   ]
 
 -- | The list of migrations in ascending order by date
@@ -588,3 +590,147 @@ ALTER TABLE services
   DROP COLUMN queue_ids_hash;
     |]
     <> dropXorHashFuncs
+
+m20260916_prometheus_indexes :: Text
+m20260916_prometheus_indexes =
+  [r|
+CREATE INDEX idx_msg_queues_expire ON msg_queues (recipient_id) WHERE deleted_at IS NULL AND msg_queue_expire;
+CREATE INDEX idx_msg_queues_notifier_active ON msg_queues (notifier_id) WHERE deleted_at IS NULL AND notifier_id IS NOT NULL;
+    |]
+
+down_m20260916_prometheus_indexes :: Text
+down_m20260916_prometheus_indexes =
+  [r|
+DROP INDEX idx_msg_queues_expire;
+DROP INDEX idx_msg_queues_notifier_active;
+    |]
+
+m20260917_msg_queues_hot :: Text
+m20260917_msg_queues_hot =
+  [r|
+DROP INDEX idx_msg_queues_updated_at_recipient_id;
+
+ALTER TABLE msg_queues SET (
+  fillfactor = 80,
+  autovacuum_vacuum_scale_factor = 0.02,
+  autovacuum_analyze_scale_factor = 0.01,
+  autovacuum_vacuum_cost_limit = 1000
+);
+
+ALTER TABLE messages SET (
+  autovacuum_vacuum_scale_factor = 0.02,
+  autovacuum_analyze_scale_factor = 0.01,
+  toast.autovacuum_vacuum_scale_factor = 0.02
+);
+
+ALTER TABLE services SET (
+  fillfactor = 70,
+  autovacuum_vacuum_threshold = 1000,
+  autovacuum_vacuum_scale_factor = 0
+);
+
+DROP PROCEDURE expire_old_messages(bigint, bigint, integer);
+
+CREATE PROCEDURE expire_old_messages(IN p_old_ts bigint, IN batch_size integer, OUT r_expired_msgs_count bigint, OUT r_stored_msgs_count bigint, OUT r_stored_queues bigint)
+    LANGUAGE plpgsql
+    AS $$
+DECLARE
+  rids BYTEA[];
+  rid BYTEA;
+  last_rid BYTEA := '\x';
+  del_count BIGINT;
+  total_deleted BIGINT := 0;
+BEGIN
+  LOOP
+    SELECT array_agg(recipient_id)
+    INTO rids
+    FROM (
+      SELECT recipient_id
+      FROM msg_queues
+      WHERE deleted_at IS NULL
+        AND msg_queue_expire = TRUE
+        AND recipient_id > last_rid
+      ORDER BY recipient_id ASC
+      LIMIT batch_size
+    ) qs;
+
+    EXIT WHEN rids IS NULL OR cardinality(rids) = 0;
+
+    FOREACH rid IN ARRAY rids
+    LOOP
+      BEGIN
+        del_count := delete_expired_msgs(rid, p_old_ts);
+        total_deleted := total_deleted + del_count;
+      EXCEPTION WHEN OTHERS THEN
+        RAISE WARNING 'STORE, expire_old_messages, error expiring queue %: %', encode(rid, 'base64'), SQLERRM;
+        CONTINUE;
+      END;
+      COMMIT;
+    END LOOP;
+    last_rid := rids[cardinality(rids)];
+  END LOOP;
+
+  r_expired_msgs_count := total_deleted;
+  r_stored_msgs_count := (SELECT COUNT(1) FROM messages);
+  r_stored_queues := (SELECT COUNT(1) FROM msg_queues WHERE deleted_at IS NULL);
+END;
+$$;
+    |]
+
+down_m20260917_msg_queues_hot :: Text
+down_m20260917_msg_queues_hot =
+  [r|
+DROP PROCEDURE expire_old_messages(bigint, integer);
+
+CREATE PROCEDURE expire_old_messages(IN p_old_queue bigint, IN p_old_ts bigint, IN batch_size integer, OUT r_expired_msgs_count bigint, OUT r_stored_msgs_count bigint, OUT r_stored_queues bigint)
+    LANGUAGE plpgsql
+    AS $$
+DECLARE
+  rids BYTEA[];
+  rid BYTEA;
+  last_rid BYTEA := '\x';
+  del_count BIGINT;
+  total_deleted BIGINT := 0;
+BEGIN
+  LOOP
+    SELECT array_agg(recipient_id)
+    INTO rids
+    FROM (
+      SELECT recipient_id
+      FROM msg_queues
+      WHERE deleted_at IS NULL
+        AND updated_at > p_old_queue
+        AND msg_queue_expire = TRUE
+        AND recipient_id > last_rid
+      ORDER BY recipient_id ASC
+      LIMIT batch_size
+    ) qs;
+
+    EXIT WHEN rids IS NULL OR cardinality(rids) = 0;
+
+    FOREACH rid IN ARRAY rids
+    LOOP
+      BEGIN
+        del_count := delete_expired_msgs(rid, p_old_ts);
+        total_deleted := total_deleted + del_count;
+      EXCEPTION WHEN OTHERS THEN
+        RAISE WARNING 'STORE, expire_old_messages, error expiring queue %: %', encode(rid, 'base64'), SQLERRM;
+        CONTINUE;
+      END;
+      COMMIT;
+    END LOOP;
+    last_rid := rids[cardinality(rids)];
+  END LOOP;
+
+  r_expired_msgs_count := total_deleted;
+  r_stored_msgs_count := (SELECT COUNT(1) FROM messages);
+  r_stored_queues := (SELECT COUNT(1) FROM msg_queues WHERE deleted_at IS NULL);
+END;
+$$;
+
+CREATE INDEX idx_msg_queues_updated_at_recipient_id ON msg_queues (deleted_at, updated_at, msg_queue_expire, recipient_id);
+
+ALTER TABLE msg_queues RESET (fillfactor, autovacuum_vacuum_scale_factor, autovacuum_analyze_scale_factor, autovacuum_vacuum_cost_limit);
+ALTER TABLE messages RESET (autovacuum_vacuum_scale_factor, autovacuum_analyze_scale_factor, toast.autovacuum_vacuum_scale_factor);
+ALTER TABLE services RESET (fillfactor, autovacuum_vacuum_threshold, autovacuum_vacuum_scale_factor);
+    |]

src/Simplex/Messaging/Server/QueueStore/Postgres/server_schema.sql

@@ -1,5 +1,6 @@
 
 
+
 SET statement_timeout = 0;
 SET lock_timeout = 0;
 SET idle_in_transaction_session_timeout = 0;
@@ -56,7 +57,7 @@ $$;
 
 
 
-CREATE PROCEDURE smp_server.expire_old_messages(IN p_old_queue bigint, IN p_old_ts bigint, IN batch_size integer, OUT r_expired_msgs_count bigint, OUT r_stored_msgs_count bigint, OUT r_stored_queues bigint)
+CREATE PROCEDURE smp_server.expire_old_messages(IN p_old_ts bigint, IN batch_size integer, OUT r_expired_msgs_count bigint, OUT r_stored_msgs_count bigint, OUT r_stored_queues bigint)
     LANGUAGE plpgsql
     AS $$
 DECLARE
@@ -73,7 +74,6 @@ BEGIN
       SELECT recipient_id
       FROM msg_queues
       WHERE deleted_at IS NULL
-        AND updated_at > p_old_queue
         AND msg_queue_expire = TRUE
         AND recipient_id > last_rid
       ORDER BY recipient_id ASC
@@ -397,7 +397,8 @@ CREATE TABLE smp_server.messages (
     msg_quota boolean NOT NULL,
     msg_ntf_flag boolean NOT NULL,
     msg_body bytea NOT NULL
-);
+)
+WITH (autovacuum_vacuum_scale_factor='0.02', autovacuum_analyze_scale_factor='0.01', toast.autovacuum_vacuum_scale_factor='0.02');
 
 
 
@@ -441,7 +442,8 @@ CREATE TABLE smp_server.msg_queues (
     msg_can_write boolean DEFAULT true NOT NULL,
     msg_queue_expire boolean DEFAULT false NOT NULL,
     msg_queue_size bigint DEFAULT 0 NOT NULL
-);
+)
+WITH (fillfactor='80', autovacuum_vacuum_scale_factor='0.02', autovacuum_analyze_scale_factor='0.01', autovacuum_vacuum_cost_limit='1000');
 
 
 
@@ -453,7 +455,8 @@ CREATE TABLE smp_server.services (
     created_at bigint NOT NULL,
     queue_count bigint DEFAULT 0 NOT NULL,
     queue_ids_hash bytea DEFAULT '\x00000000000000000000000000000000'::bytea NOT NULL
-);
+)
+WITH (fillfactor='70', autovacuum_vacuum_threshold='1000', autovacuum_vacuum_scale_factor='0');
 
 
 
@@ -494,10 +497,18 @@ CREATE INDEX idx_messages_recipient_id_msg_ts ON smp_server.messages USING btree
 
 
 
+CREATE INDEX idx_msg_queues_expire ON smp_server.msg_queues USING btree (recipient_id) WHERE ((deleted_at IS NULL) AND msg_queue_expire);
+
+
+
 CREATE UNIQUE INDEX idx_msg_queues_link_id ON smp_server.msg_queues USING btree (link_id);
 
 
 
+CREATE INDEX idx_msg_queues_notifier_active ON smp_server.msg_queues USING btree (notifier_id) WHERE ((deleted_at IS NULL) AND (notifier_id IS NOT NULL));
+
+
+
 CREATE UNIQUE INDEX idx_msg_queues_notifier_id ON smp_server.msg_queues USING btree (notifier_id);
 
 
@@ -514,10 +525,6 @@ CREATE UNIQUE INDEX idx_msg_queues_sender_id ON smp_server.msg_queues USING btre
 
 
 
-CREATE INDEX idx_msg_queues_updated_at_recipient_id ON smp_server.msg_queues USING btree (deleted_at, updated_at, msg_queue_expire, recipient_id);
-
-
-
 CREATE INDEX idx_services_service_role ON smp_server.services USING btree (service_role);
 
 
@@ -549,3 +556,4 @@ ALTER TABLE ONLY smp_server.msg_queues
 
 
 
+

src/Simplex/Messaging/SimplexName.hs

@@ -10,14 +10,21 @@ module Simplex.Messaging.SimplexName
     SimplexTLD (..),
     SimplexNameType (..),
     fullDomainName,
+    LabelHash (..),
+    labelHash,
+    boundedNonSpace,
     shortNameInfoStr,
   )
 where
 
 import Control.Applicative (optional, (<|>))
+import Crypto.Hash (Digest, hash)
+import Crypto.Hash.Algorithms (Keccak_256)
 import qualified Data.Aeson.TH as J
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import qualified Data.Attoparsec.Text as AT
+import qualified Data.ByteArray as BA
+import qualified Data.ByteArray.Encoding as BAE
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.Char (isDigit)
@@ -70,6 +77,20 @@ nameLabelP = do
     -- (Cyrillic а vs ASCII a hash to different on-chain records).
     isNameLetter c = c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z'
 
+-- | The registry's key for a label: 32 bytes, as labelOf takes it.
+newtype LabelHash = LabelHash ByteString
+  deriving (Eq, Show)
+
+-- | keccak-256 of the lowercased label, as the registry keys it.
+labelHash :: Text -> LabelHash
+labelHash label = LabelHash $ BA.convert (hash (encodeUtf8 (T.toLower label)) :: Digest Keccak_256)
+
+instance StrEncoding LabelHash where
+  strEncode (LabelHash h) = '[' `B.cons` (BAE.convertToBase BAE.Base16 h `B.snoc` ']')
+  strP = do
+    h <- BAE.convertFromBase BAE.Base16 <$?> (A.char '[' *> A.takeWhile (/= ']') <* A.char ']')
+    if B.length h == 32 then pure $ LabelHash h else fail "bad LabelHash"
+
 -- | Cap the name at 253 bytes (DNS full-domain limit)
 boundedNonSpace :: A.Parser ByteString
 boundedNonSpace = do
@@ -108,12 +129,15 @@ instance Encoding SimplexDomain where
   smpP = strP
 
 fullDomainName :: SimplexDomain -> Text
-fullDomainName SimplexDomain {nameTLD, domain, subDomain} = T.intercalate "." (reverse subDomain ++ [domain] ++ tld')
-  where
-    tld' = case nameTLD of
-      TLDSimplex -> ["simplex"]
-      TLDTesting -> ["testing"]
-      TLDWeb -> []
+fullDomainName SimplexDomain {nameTLD, domain, subDomain} = T.intercalate "." (reverse subDomain ++ [domain]) <> decodeLatin1 (strEncode nameTLD)
+
+instance StrEncoding SimplexTLD where
+  strEncode = \case
+    TLDSimplex -> ".simplex"
+    TLDTesting -> ".testing"
+    TLDWeb -> ""
+  strP =
+    ".simplex" $> TLDSimplex <|> ".testing" $> TLDTesting <|> pure TLDWeb
 
 shortNameInfoStr :: SimplexNameInfo -> Text
 shortNameInfoStr = \case

src/Simplex/Messaging/Transport.hs

@@ -53,6 +53,8 @@ module Simplex.Messaging.Transport
     rcvServiceSMPVersion,
     namesSMPVersion,
     serverInfoSMPVersion,
+    nameAvailSMPVersion,
+    entitlementSMPVersion,
     simplexMQVersion,
     smpBlockSize,
     TransportConfig (..),
@@ -84,6 +86,8 @@ module Simplex.Messaging.Transport
     THandle (..),
     THandleParams (..),
     THandleAuth (..),
+    SessionEntitlement (..),
+    EntitlementConfig (..),
     CertChainPubKey (..),
     ServiceCredentials (..),
     THClientService' (..),
@@ -119,6 +123,7 @@ import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Default (def)
 import Data.Functor (($>))
+import Data.Int (Int64)
 import Data.Kind (Type)
 import Data.Tuple (swap)
 import Data.Typeable (Typeable)
@@ -132,10 +137,12 @@ import qualified Network.TLS as T
 import qualified Network.TLS.Extra as TE
 import qualified Paths_simplexmq as SMQ
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.Entitlement (EntitlementProof)
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (dropPrefix, parseRead1, sumTypeJSON)
 import Simplex.Messaging.Server.Information
+import Simplex.Messaging.SystemTime (SystemSeconds)
 import Simplex.Messaging.Transport.Buffer
 import Simplex.Messaging.Transport.Shared
 import Simplex.Messaging.Util (bshow, catchAll, catchAll_, liftEitherWith, (<$$>))
@@ -171,6 +178,8 @@ smpBlockSize = 16384
 -- 19 - service subscriptions to messages (10/20/2025)
 -- 20 - public namespaces resolver, RSLV command (6/20/2026)
 -- 21 - server public information in handshake (7/5/2026)
+-- 22 - RNAME answers name availability as well as the record (7/25/2026)
+-- 23 - entitlement proof in client handshake (9/11/2026)
 
 data SMPVersion
 
@@ -207,6 +216,14 @@ namesSMPVersion = VersionSMP 20
 serverInfoSMPVersion :: VersionSMP
 serverInfoSMPVersion = VersionSMP 21
 
+-- | RNAME carries availability. A server below this answers RSLV with the
+-- record alone, and ERR NAME NOT_FOUND for a name that does not resolve.
+nameAvailSMPVersion :: VersionSMP
+nameAvailSMPVersion = VersionSMP 22
+
+entitlementSMPVersion :: VersionSMP
+entitlementSMPVersion = VersionSMP 23
+
 minClientSMPRelayVersion :: VersionSMP
 minClientSMPRelayVersion = VersionSMP 14
 
@@ -214,20 +231,19 @@ minServerSMPRelayVersion :: VersionSMP
 minServerSMPRelayVersion = VersionSMP 14
 
 currentClientSMPRelayVersion :: VersionSMP
-currentClientSMPRelayVersion = VersionSMP 21
+currentClientSMPRelayVersion = VersionSMP 23
 
 currentServerSMPRelayVersion :: VersionSMP
-currentServerSMPRelayVersion = VersionSMP 21
+currentServerSMPRelayVersion = VersionSMP 23
 
 -- Max SMP protocol version to be used in e2e encrypted connection between
 -- client and server, as defined by SMP proxy. Normally set below the current
 -- version to prevent client version fingerprinting by the destination relays
--- when clients upgrade at different times. Pinned to the current version (20)
--- for this release because proxied name resolution is gated on namesSMPVersion
--- (20), so the one-version anti-fingerprinting buffer does not apply yet; it
--- reappears once the current version advances past 20.
+-- when clients upgrade at different times. Set to 22, one below the current
+-- version (23): a proxied RSLV carries availability from nameAvailSMPVersion (22),
+-- and the entitlement proof of version 23 is never sent via proxy.
 proxiedSMPRelayVersion :: VersionSMP
-proxiedSMPRelayVersion = VersionSMP 20
+proxiedSMPRelayVersion = VersionSMP 22
 
 -- minimal supported protocol version is 14
 supportedClientSMPRelayVRange :: VersionRangeSMP
@@ -483,10 +499,15 @@ data THandleAuth (p :: TransportPeer) where
   THAuthServer ::
     { serverPrivKey :: C.PrivateKeyX25519, -- used by the server to combine with client's public per-queue key
       peerClientService :: Maybe THPeerClientService,
+      peerEntitlement :: Maybe SessionEntitlement, -- verified in the handshake, applies to the whole session
       sessSecret' :: Maybe C.DhSecretX25519 -- session secret (will be used in SMP proxy only)
     } ->
     THandleAuth 'TServer
 
+data SessionEntitlement = SessionEntitlement {expiresAt :: SystemSeconds, entConfig :: EntitlementConfig}
+
+newtype EntitlementConfig = EntitlementConfig {storageTime :: Int64}
+
 type THClientService = THClientService' C.PrivateKeyEd25519
 
 type THPeerClientService = THClientService' C.PublicKeyEd25519
@@ -557,7 +578,9 @@ data SMPClientHandshake = SMPClientHandshake
     -- - notification servers,
     -- - high traffic chat bots,
     -- - high traffic business support clients.
-    clientService :: Maybe SMPClientHandshakeService
+    clientService :: Maybe SMPClientHandshakeService,
+    -- | proof of the user entitlement bound to the session
+    entitlementProof :: Maybe EntitlementProof
   }
 
 data SMPClientHandshakeService = SMPClientHandshakeService
@@ -575,17 +598,19 @@ data ServiceCredentials = ServiceCredentials
 data SMPServiceRole = SRMessaging | SRNotifier | SRProxy deriving (Eq, Show)
 
 instance Encoding SMPClientHandshake where
-  smpEncode SMPClientHandshake {smpVersion = v, keyHash, authPubKey, proxyServer, clientService} =
+  smpEncode SMPClientHandshake {smpVersion = v, keyHash, authPubKey, proxyServer, clientService, entitlementProof} =
     smpEncode (v, keyHash)
       <> maybe "" smpEncode authPubKey
       <> smpEncode proxyServer
       <> ifHasService v (smpEncode clientService) ""
+      <> ifHasEntitlement v (smpEncode entitlementProof) ""
   smpP = do
     (v, keyHash) <- smpP
     authPubKey <- optional smpP
     proxyServer <- smpP
     clientService <- ifHasService v smpP (pure Nothing)
-    pure SMPClientHandshake {smpVersion = v, keyHash, authPubKey, proxyServer, clientService}
+    entitlementProof <- ifHasEntitlement v smpP (pure Nothing)
+    pure SMPClientHandshake {smpVersion = v, keyHash, authPubKey, proxyServer, clientService, entitlementProof}
 
 instance Encoding SMPClientHandshakeService where
   smpEncode SMPClientHandshakeService {serviceRole, serviceCertKey} =
@@ -609,6 +634,9 @@ instance Encoding SMPServiceRole where
 ifHasService :: VersionSMP -> a -> a -> a
 ifHasService v a b = if v >= serviceCertsSMPVersion then a else b
 
+ifHasEntitlement :: VersionSMP -> a -> a -> a
+ifHasEntitlement v a b = if v >= entitlementSMPVersion then a else b
+
 ifHasServerInfo :: VersionSMP -> a -> a -> a
 ifHasServerInfo v a b = if v >= serverInfoSMPVersion then a else b
 
@@ -764,8 +792,8 @@ smpServerHandshake srvCert srvSignKey c (k, pk) kh smpVersionRange serverInfoByt
 -- | Client SMP transport handshake.
 --
 -- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#appendix-a
-smpClientHandshake :: forall c. Transport c => c 'TClient -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeSMP -> Bool -> Maybe (ServiceCredentials, C.KeyPairEd25519) -> ExceptT TransportError IO (THandleSMP c 'TClient)
-smpClientHandshake c ks_ keyHash@(C.KeyHash kh) smpVRange proxyServer serviceKeys_ = do
+smpClientHandshake :: forall c. Transport c => c 'TClient -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRangeSMP -> Bool -> Maybe (ServiceCredentials, C.KeyPairEd25519) -> (SessionId -> IO (Maybe EntitlementProof)) -> ExceptT TransportError IO (THandleSMP c 'TClient)
+smpClientHandshake c ks_ keyHash@(C.KeyHash kh) smpVRange proxyServer serviceKeys_ mkEntitlementProof = do
   SMPServerHandshake {sessionId = sessId, smpVersionRange, authPubKey = certKey@(CertChainPubKey chain exact), serverInfoBytes} <- getHandshake th
   when (sessionId /= sessId) $ throwE TEBadSession
   case smpVersionRange `compatibleVRange` smpVRange of
@@ -782,8 +810,8 @@ smpClientHandshake c ks_ keyHash@(C.KeyHash kh) smpVRange proxyServer serviceKey
             Just sks | v >= serviceVersion (fst sks) && certificateSent c -> Just sks
             _ -> Nothing
           clientService = mkClientService <$> serviceKeys
-          hs = SMPClientHandshake {smpVersion = v, keyHash, authPubKey = fst <$> ks_, proxyServer, clientService}
-      sendHandshake th hs
+      ep <- if v >= entitlementSMPVersion then liftIO (mkEntitlementProof sessionId) else pure Nothing
+      sendHandshake th SMPClientHandshake {smpVersion = v, keyHash, authPubKey = fst <$> ks_, proxyServer, clientService, entitlementProof = ep}
       service <- mapM getClientService serviceKeys
       liftIO $ smpTHandleClient th v vr (snd <$> ks_) ck proxyServer service serverInfoBytes
     Nothing -> throwE TEVersion
@@ -801,7 +829,7 @@ smpClientHandshake c ks_ keyHash@(C.KeyHash kh) smpVRange proxyServer serviceKey
 
 smpTHandleServer :: forall c. THandleSMP c 'TServer -> VersionSMP -> VersionRangeSMP -> C.PrivateKeyX25519 -> Maybe C.PublicKeyX25519 -> Bool -> Maybe THPeerClientService -> IO (THandleSMP c 'TServer)
 smpTHandleServer th v vr pk k_ proxyServer peerClientService = do
-  let thAuth = Just THAuthServer {serverPrivKey = pk, peerClientService, sessSecret' = (`C.dh'` pk) <$!> k_}
+  let thAuth = Just THAuthServer {serverPrivKey = pk, peerClientService, peerEntitlement = Nothing, sessSecret' = (`C.dh'` pk) <$!> k_}
   be <- blockEncryption th proxyServer thAuth
   pure $ smpTHandle_ th v vr thAuth (uncurry TSbChainKeys <$> be) Nothing
 

src/Simplex/Messaging/Transport/HTTP2/Server.hs

@@ -54,7 +54,7 @@ getHTTP2Server HTTP2ServerConfig {qSize, http2Port, bufferSize, bodyHeadSize, se
   started <- newEmptyTMVarIO
   reqQ <- newTBQueueIO qSize
   action <- async $
-    runHTTP2Server started http2Port bufferSize serverSupported srvCreds Nothing transportConfig Nothing (const $ pure ()) $ \_sniUsed sessionId sessionALPN r sendResponse -> do
+    runHTTP2Server started http2Port bufferSize serverSupported srvCreds Nothing transportConfig Nothing (const $ pure ()) (\_ _ handler -> handler) $ \_sniUsed sessionId sessionALPN r sendResponse -> do
       reqBody <- getHTTP2Body r bodyHeadSize
       atomically $ writeTBQueue reqQ HTTP2Request {sessionId, sessionALPN, request = r, reqBody, sendResponse}
   void . atomically $ takeTMVar started
@@ -63,13 +63,13 @@ getHTTP2Server HTTP2ServerConfig {qSize, http2Port, bufferSize, bodyHeadSize, se
 closeHTTP2Server :: HTTP2Server -> IO ()
 closeHTTP2Server = uninterruptibleCancel . action
 
-runHTTP2Server :: TMVar Bool -> ServiceName -> BufferSize -> T.Supported -> T.Credential -> Maybe T.Credential -> TransportServerConfig -> Maybe ExpirationConfig -> (SessionId -> IO ()) -> (SNICredentialUsed -> HTTP2ServerFunc) -> IO ()
-runHTTP2Server started port bufferSize srvSupported srvCreds httpCreds_ transportConfig expCfg_ clientFinished = runHTTP2ServerWith_ expCfg_ clientFinished bufferSize setup
+runHTTP2Server :: TMVar Bool -> ServiceName -> BufferSize -> T.Supported -> T.Credential -> Maybe T.Credential -> TransportServerConfig -> Maybe ExpirationConfig -> (SessionId -> IO ()) -> (Socket -> SessionId -> IO () -> IO ()) -> (SNICredentialUsed -> HTTP2ServerFunc) -> IO ()
+runHTTP2Server started port bufferSize srvSupported srvCreds httpCreds_ transportConfig expCfg_ clientFinished withConnection = runHTTP2ServerWith_ expCfg_ clientFinished bufferSize setup
   where
     setup handler = do
       ss <- newSocketState
       let combinedCreds = TLSServerCredential {credential = srvCreds, sniCredential = httpCreds_}
-      runTransportServerState_ ss started port srvSupported combinedCreds transportConfig $ \_ -> handler
+      runTransportServerState_ ss started port srvSupported combinedCreds transportConfig $ \sock h@(_, tls) -> withConnection sock (tlsUniq tls) (handler h)
 
 -- HTTP2 server can be run on both client and server TLS connections.
 runHTTP2ServerWith :: BufferSize -> ((TLS p -> IO ()) -> a) -> HTTP2ServerFunc -> a

tests/AgentTests/DoubleRatchetTests.hs

@@ -53,6 +53,7 @@ doubleRatchetTests = do
       it "should propose KEM during agreement, but no shared secret" $ testAlgs testPqX3dhProposeInReply
       it "should agree shared secret using KEM" $ testAlgs testPqX3dhProposeAccept
       it "should reject proposed KEM in reply" $ testAlgs testPqX3dhProposeReject
+      it "should agree different PQ associated data with substituted KEM key" $ testAlgs testPqX3dhSubstitutedKem
       it "should allow second proposal in reply" $ testAlgs testPqX3dhProposeAgain
     describe "hybrid KEM key agreement errors" $ do
       it "should fail if reply contains acceptance without proposal" $ testAlgs testPqX3dhAcceptWithoutProposalError
@@ -362,6 +363,7 @@ testDecodeV2RatchetJSON :: IO ()
 testDecodeV2RatchetJSON = do
   let v2RatchetJSON = "{\"rcVersion\":[2,2],\"rcAD\":\"2GEJrq48TmQse6NR16I-hrI0tSySZQ57E_g46nDceAPRAiF6j0drq26RTE7be6X7uiB4RaGJGf4QRXzcYuVtWw==\",\"rcDHRs\":\"TUM0Q0FRQXdCUVlESzJWdUJDSUVJRkNYbUxtSHQ3SUNfeHpGTi1Qb3ZqTVQ3S2p6XzZlZlBjOG9fRFY2RWxKOQ==\",\"rcRK\":\"BOX2X7YW5qDSp2XknY_lqacSrtDqQNPvS6iJlZIs3G0=\",\"rcNs\":0,\"rcNr\":0,\"rcPN\":0,\"rcNHKs\":\"IMouSkXUvzT_mo0WM-pqEUK09-HTLk9WOTCFQglyQxU=\",\"rcNHKr\":\"g-tus1clYPV0rGlzkf5a959tUqDYQVZ1FpcPeXdKwxI=\"}"
   Right (r :: Ratchet X25519) <- pure $ J.eitherDecodeStrict' v2RatchetJSON
+  rcVCPQ r `shouldBe` Nothing
   rcSupportKEM r `shouldBe` PQSupportOff
   rcEnableKEM r `shouldBe` PQEncOff
   rcSndKEM r `shouldBe` PQEncOff
@@ -417,6 +419,18 @@ testPqX3dhProposeAccept _ = do
   Right paramsAlice <- runExceptT $ pqX3dhRcv pksAlice e2eBob
   paramsAlice `compatibleRatchets` paramsBob
 
+testPqX3dhSubstitutedKem :: forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO ()
+testPqX3dhSubstitutedKem _ = do
+  g <- C.newRandom
+  let v = currentE2EEncryptVersion
+  (pksAlice@(_, _, Just _), e2eAlice) <- liftIO $ generateRcvE2EParams @a g v PQSupportOn
+  (_, E2ERatchetParams _ _ _ (Just (RKParamsProposed mallorysKem))) <- liftIO $ generateRcvE2EParams @a g v PQSupportOn
+  (pksBob@(_, _, Just _), AE2ERatchetParams _ e2eBob) <- liftIO $ generateSndE2EParams @a g v (Just $ AUseKEM SRKSAccepted $ AcceptKEM mallorysKem)
+  Right (paramsBob, _) <- pure $ pqX3dhSnd pksBob e2eAlice
+  Right (paramsAlice, _) <- runExceptT $ pqX3dhRcv pksAlice e2eBob
+  assocData paramsAlice `shouldBe` assocData paramsBob
+  rcVerifyCodePQ paramsAlice `shouldNotBe` rcVerifyCodePQ paramsBob
+
 testPqX3dhProposeReject :: forall a. (AlgorithmI a, DhAlgorithm a) => C.SAlgorithm a -> IO ()
 testPqX3dhProposeReject _ = do
   g <- C.newRandom
@@ -459,9 +473,9 @@ testPqX3dhProposeAgain _ = do
 
 compatibleRatchets :: (RatchetInitParams, x) -> (RatchetInitParams, x) -> Expectation
 compatibleRatchets
-  (RatchetInitParams {assocData, ratchetKey, sndHK, rcvNextHK, kemAccepted}, _)
-  (RatchetInitParams {assocData = ad, ratchetKey = rk, sndHK = shk, rcvNextHK = rnhk, kemAccepted = ka}, _) = do
-    assocData == ad && ratchetKey == rk && sndHK == shk && rcvNextHK == rnhk `shouldBe` True
+  (RatchetInitParams {assocData, rcVerifyCodePQ, ratchetKey, sndHK, rcvNextHK, kemAccepted}, _)
+  (RatchetInitParams {assocData = ad, rcVerifyCodePQ = vcPQ, ratchetKey = rk, sndHK = shk, rcvNextHK = rnhk, kemAccepted = ka}, _) = do
+    assocData == ad && rcVerifyCodePQ == vcPQ && ratchetKey == rk && sndHK == shk && rcvNextHK == rnhk `shouldBe` True
     case (kemAccepted, ka) of
       (Just RatchetKEMAccepted {rcPQRr, rcPQRss, rcPQRct}, Just RatchetKEMAccepted {rcPQRr = pqk, rcPQRss = pqss, rcPQRct = pqct}) ->
         pqk /= rcPQRr && pqss == rcPQRss && pqct == rcPQRct `shouldBe` True

tests/AgentTests/FunctionalAPITests.hs

@@ -54,6 +54,7 @@ module AgentTests.FunctionalAPITests
     pattern SENT,
     agentCfgVPrevPQ,
     agentCfgV7,
+    testServerInformation,
   )
 where
 
@@ -203,7 +204,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
@@ -292,7 +293,7 @@ createConnection c userId enableNtfs cMode clientData subMode = do
 
 joinConnection :: AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> AE (ConnId, SndQueueSecured)
 joinConnection c userId enableNtfs cReq connInfo subMode = do
-  connId <- A.prepareConnectionToJoin c userId enableNtfs cReq PQSupportOn
+  (connId, _) <- A.prepareConnectionToJoin c userId enableNtfs cReq PQSupportOn
   sndSecure <- A.joinConnection c NRMInteractive userId connId enableNtfs cReq connInfo PQSupportOn subMode
   pure (connId, sndSecure)
 
@@ -331,6 +332,8 @@ functionalAPITests ps = do
       withSmpServer ps testServerMultipleIdentities
     it "should connect with two peers" $
       withSmpServer ps testAgentClient3
+    it "should connect with entitlement credential" $
+      withSmpServer ps testAgentEntitlement
     it "should establish connection without PQ encryption and enable it" $
       withSmpServer ps testEnablePQEncryption
   describe "Duplex connection - delivery stress test" $ do
@@ -441,6 +444,9 @@ functionalAPITests ps = do
       it "should expire multiple messages" $ testExpireManyMessages ps
       it "should expire one message if quota is exceeded" $ testExpireMessageQuota ps
       it "should expire multiple messages if quota is exceeded" $ testExpireManyMessagesQuota ps
+    describe "joining a full contact address" $ do
+      it "should retry joining until the address has space" $ testJoinFullContactAsync ps
+      it "should fail joining after quota exceeded timeout" $ testJoinFullContactAsyncExpire ps
     it "should drop message after too many receive attempts" $ testDropMsgAfterRcvAttempts ps
 #if !defined(dbPostgres)
     -- TODO [postgres] restore from outdated db backup (we use copyFile/renameFile for sqlite)
@@ -580,9 +586,9 @@ functionalAPITests ps = do
       it "should pass with correct password" $ testSMPServerConnectionTest ps auth (srv auth) `shouldReturn` Right (Just (Right testServerInformation))
       it "should fail without password" $ testSMPServerConnectionTest ps auth (srv Nothing) `shouldReturn` Left authErr
       it "should fail with incorrect password" $ testSMPServerConnectionTest ps auth (srv $ Just "wrong") `shouldReturn` Left authErr
-  describe "getRatchetAdHash" $
-    it "should return the same data for both peers" $
-      withSmpServer ps testRatchetAdHash
+  describe "getConnectionVerifyCodes" $
+    it "should return the same codes for both peers" $
+      withSmpServer ps testConnectionVerifyCodes
   describe "Delivery receipts" $ do
     it "should send and receive delivery receipt" $ withSmpServer ps testDeliveryReceipts
     it "send delivery receipts concurrently with messages" $ testDeliveryReceiptsConcurrent ps
@@ -754,7 +760,7 @@ runAgentClientTestPQ :: HasCallStack => Bool -> (AgentClient, InitialKeys) -> (A
 runAgentClientTestPQ viaProxy (alice, aPQ) (bob, bPQ) baseId =
   runRight_ $ do
     (bobId, CCLink qInfo Nothing) <- A.createConnection alice NRMInteractive 1 True True SCMInvitation Nothing Nothing aPQ False SMSubscribe
-    aliceId <- A.prepareConnectionToJoin bob 1 True qInfo bPQ
+    (aliceId, _) <- A.prepareConnectionToJoin bob 1 True qInfo bPQ
     sqSecured' <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" bPQ SMSubscribe
     liftIO $ sqSecured' `shouldBe` True
     ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
@@ -975,6 +981,15 @@ testAgentClient3 =
     get c =##> \case ("", connId, Msg "c5") -> connId == aIdForC; _ -> False
     ackMessage c aIdForC 3 Nothing
 
+testAgentEntitlement :: HasCallStack => IO ()
+testAgentEntitlement = do
+  (keys, credential) <- mkTestEntitlement
+  let aCfg = agentCfg {entitlementKeys = keys}
+      servers = initAgentServers {entitlements = M.fromList [(1, credential)]}
+  withAgentClientsCfgServers2 aCfg aCfg servers $ \a b -> runRight_ $ do
+    (aId, bId) <- makeConnection a b
+    exchangeGreetings a bId b aId
+
 runAgentClientContactTest :: HasCallStack => PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()
 runAgentClientContactTest pqSupport sqSecured viaProxy alice bob baseId =
   runAgentClientContactTestPQ sqSecured viaProxy (alice, IKLinkPQ pqSupport) (bob, pqSupport) baseId
@@ -983,12 +998,12 @@ runAgentClientContactTestPQ :: HasCallStack => SndQueueSecured -> Bool -> (Agent
 runAgentClientContactTestPQ sqSecured viaProxy (alice, aPQ) (bob, bPQ) baseId =
   runRight_ $ do
     (_, CCLink qInfo Nothing) <- A.createConnection alice NRMInteractive 1 True True SCMContact Nothing Nothing aPQ False SMSubscribe
-    aliceId <- A.prepareConnectionToJoin bob 1 True qInfo bPQ
+    (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` PQSupportOn
-    bobId <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption aPQ)
+    (bobId, _) <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption aPQ)
     sqSecured' <- acceptContact alice 1 bobId True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe
     liftIO $ sqSecured' `shouldBe` sqSecured
     ("", _, A.CONF confId pqSup'' _ "alice's connInfo") <- get bob
@@ -1052,7 +1067,7 @@ runAgentClientContactDRTest_ asyncAccept asyncJoin addrIK useDR bPQ ps = withSmp
       Nothing -> expectationFailure "address must advertise DR ratchet keys"
     -- classic (non-DR) join drops the address keys from the request
     let connReqJoin = if useDR then connReq' else case connReq' of CRContactUri d _ -> CRContactUri d Nothing
-    aliceId <- A.prepareConnectionToJoin bob 1 True connReqJoin bPQ
+    (aliceId, _) <- A.prepareConnectionToJoin bob 1 True connReqJoin bPQ
     if asyncJoin
       then do
         A.joinConnectionAsync bob "join" False aliceId True connReqJoin "bob's connInfo" bPQ SMSubscribe
@@ -1060,9 +1075,9 @@ 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)
+    (bobId, _) <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption addrIK)
     if asyncAccept
       then do
         acceptContactAsync alice "accept" bobId True invId "alice's connInfo" (CR.connPQEncryption addrIK) SMSubscribe
@@ -1092,10 +1107,10 @@ runCreateConnectionDRTest_ asyncNew addrIK bPQ ps = withSmpServer ps $ withAgent
     liftIO $ case addrKeys_ of
       Just (_, CR.E2ERatchetParamsUri _ _ _ kem_) -> isJust kem_ `shouldBe` supportPQ (CR.initialPQEncryption False addrIK)
       Nothing -> expectationFailure "createConnection must advertise DR ratchet keys"
-    aliceId <- A.prepareConnectionToJoin bob 1 True connReq bPQ
+    (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
-    bobId <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption addrIK)
+    ("", _, 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
     allowConfirmGreet alice bobId bob aliceId confId addrIK pqEnc
@@ -1117,10 +1132,10 @@ testContactDRMatrix ps = do
 
 joinContactDR :: HasCallStack => AgentClient -> AgentClient -> ConnectionRequestUri 'CMContact -> InitialKeys -> PQEncryption -> ExceptT AgentErrorType IO ()
 joinContactDR alice requester connReq addrIK pqEnc = do
-  aliceId <- A.prepareConnectionToJoin requester 1 True connReq PQSupportOn
+  (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
-  reqId <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption addrIK)
+  ("", _, 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
   allowConfirmGreet alice reqId requester aliceId confId addrIK pqEnc
@@ -1148,7 +1163,7 @@ testAddressKeyRotation ps = withSmpServer ps $ withAgentClients3 $ \alice bob ca
     joinContactDR alice carol connReq2 addrIK pqEnc
     void $ A.setConnShortLink alice NRMInteractive addrConnId SCMContact userLinkData Nothing True (Just addrIK)
     void $ A.setConnShortLink alice NRMInteractive addrConnId SCMContact userLinkData Nothing True (Just addrIK)
-    aId <- A.prepareConnectionToJoin bob 1 True connReq1 PQSupportOn
+    (aId, _) <- A.prepareConnectionToJoin bob 1 True connReq1 PQSupportOn
     void $ A.joinConnection bob NRMInteractive 1 aId True connReq1 "bob's connInfo" PQSupportOn SMSubscribe
     get alice =##> \case ("", _, A.ERR _) -> True; _ -> False
 
@@ -1191,11 +1206,11 @@ testAddressUpdatePreservesDRKeys ps = withSmpServer ps $ withAgentClients2 $ \al
     liftIO $ shortLink' `shouldBe` shortLink
     (_, ContactLinkData _ updated, connReq') <- getConnShortLink bob 1 shortLink
     liftIO $ ratchetKeys updated `shouldBe` ratchetKeys published
-    aliceId <- A.prepareConnectionToJoin bob 1 True connReq' bPQ
+    (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
-    bobId <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption addrIK)
+    ("", _, 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
     allowConfirmGreet alice bobId bob aliceId confId addrIK pqEnc
@@ -1215,10 +1230,10 @@ testAcceptContactDRResumeAfterOffline ps = withAgentClients2 $ \alice bob -> do
     (ccLink@(CCLink _ (Just shortLink)), preparedParams) <- A.prepareConnectionLink alice 1 rootKey linkEntId True Nothing connIK True Nothing
     _ <- A.createConnectionForLink alice NRMInteractive 1 True ccLink preparedParams (UserContactLinkData userCtData) SMSubscribe
     (_, _, connReq') <- getConnShortLink bob 1 shortLink
-    aId <- A.prepareConnectionToJoin bob 1 True connReq' PQSupportOn
+    (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
-    bId <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption addrIK)
+    ("", _, 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
   ("", "", DOWN _ _) <- nGet bob
@@ -1243,12 +1258,12 @@ runAgentClientContactTestPQ3 viaProxy (alice, aPQ) (bob, bPQ) (tom, tPQ) baseId
   where
     msgId = subtract baseId . fst
     connectViaContact b pq qInfo = do
-      aId <- A.prepareConnectionToJoin b 1 True qInfo pq
+      (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)
+      (bId, _) <- A.prepareConnectionToAccept alice 1 True invId (CR.connPQEncryption aPQ)
       sqSecuredAccept <- acceptContact alice 1 bId True invId "alice's connInfo" (CR.connPQEncryption aPQ) SMSubscribe
       liftIO $ sqSecuredAccept `shouldBe` True
       ("", _, A.CONF confId pqSup'' _ "alice's connInfo") <- get b
@@ -1289,10 +1304,10 @@ testRejectContactRequest :: HasCallStack => IO ()
 testRejectContactRequest =
   withAgentClients2 $ \alice bob -> runRight_ $ do
     (_addrConnId, CCLink qInfo Nothing) <- A.createConnection alice NRMInteractive 1 True True SCMContact Nothing Nothing IKPQOn False SMSubscribe
-    aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
+    (aliceId, _) <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
     sqSecured <- A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
     liftIO $ sqSecured `shouldBe` False -- joining via contact address connection
-    ("", _, A.REQ invId PQSupportOn _ "bob's connInfo" _) <- get alice
+    ("", _, A.REQ invId PQSupportOn _ "bob's connInfo" _ _) <- get alice
     Left (A.CMD PROHIBITED _) <- tryError $ rejectContact alice NRMInteractive 1 invId (Just "no rejection without double ratchet")
     rejectContact alice NRMInteractive 1 invId Nothing
     liftIO $ noMessages bob "nothing delivered to bob"
@@ -1302,9 +1317,9 @@ 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
+    (aliceId, _) <- A.prepareConnectionToJoin bob 1 True connReq PQSupportOn
     void $ A.joinConnection bob NRMInteractive 1 aliceId True connReq "bob's connInfo" PQSupportOn SMSubscribe
-    ("", _, A.REQ invId _ _ "bob's connInfo" _) <- get alice
+    ("", _, A.REQ invId _ _ "bob's connInfo" _ _) <- get alice
     rejectContact alice NRMInteractive 1 invId (Just "not now")
     ("", _, A.RJCT "not now") <- get bob
     pure ()
@@ -1314,9 +1329,9 @@ 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
+    (aliceId, _) <- A.prepareConnectionToJoin bob 1 True connReq PQSupportOn
     void $ A.joinConnection bob NRMInteractive 1 aliceId True connReq "bob's connInfo" PQSupportOn SMSubscribe
-    ("", _, A.REQ invId _ _ "bob's connInfo" _) <- get alice
+    ("", _, A.REQ invId _ _ "bob's connInfo" _ _) <- get alice
     rejectContactAsync alice "1" 1 invId (Just "not now")
     ("", _, A.RJCT "not now") <- get bob
     pure ()
@@ -1429,7 +1444,7 @@ testUpdateConnectionUserId =
     (connId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe
     newUserId <- createUser alice False [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer]
     _ <- changeConnectionUser alice 1 connId newUserId
-    aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
+    (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` True
     ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
@@ -1588,7 +1603,7 @@ testInvitationErrors ps restart = do
   b <- getAgentB
   (bId, cReq) <- withServer1 ps $ runRight $ createConnection a 1 True SCMInvitation Nothing SMSubscribe
   ("", "", DOWN _ [_]) <- nGet a
-  aId <- runRight $ A.prepareConnectionToJoin b 1 True cReq PQSupportOn
+  (aId, _) <- runRight $ A.prepareConnectionToJoin b 1 True cReq PQSupportOn
   -- fails to secure the queue on testPort
   BROKER srv (NETWORK _) <- runLeft $ A.joinConnection b NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe
   (testPort `isSuffixOf` srv) `shouldBe` True
@@ -1658,7 +1673,7 @@ testContactErrors ps restart = do
   b <- getAgentB
   (contactId, cReq) <- withServer1 ps $ runRight $ createConnection a 1 True SCMContact Nothing SMSubscribe
   ("", "", DOWN _ [_]) <- nGet a
-  aId <- runRight $ A.prepareConnectionToJoin b 1 True cReq PQSupportOn
+  (aId, _) <- runRight $ A.prepareConnectionToJoin b 1 True cReq PQSupportOn
   -- fails to create queue on testPort2
   BROKER srv2 (NETWORK _) <- runLeft $ A.joinConnection b NRMInteractive 1 aId True cReq "bob's connInfo" PQSupportOn SMSubscribe
   (testPort2 `isSuffixOf` srv2) `shouldBe` True
@@ -1680,10 +1695,10 @@ 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
+  (bId, _) <- runRight $ A.prepareConnectionToAccept a 1 True invId PQSupportOn
   withServer2 ps $ do
     ("", "", UP _ [_]) <- nGet b''
     let loopSecure = do
@@ -1763,7 +1778,7 @@ testInvitationShortLink viaProxy a b =
 
 testJoinConn_ :: Bool -> Bool -> AgentClient -> ConnId -> AgentClient -> ConnectionRequestUri c -> ExceptT AgentErrorType IO ()
 testJoinConn_ viaProxy sndSecure a bId b connReq = do
-  aId <- A.prepareConnectionToJoin b 1 True connReq PQSupportOn
+  (aId, _) <- A.prepareConnectionToJoin b 1 True connReq PQSupportOn
   sndSecure' <- A.joinConnection b NRMInteractive 1 aId True connReq "bob's connInfo" PQSupportOn SMSubscribe
   liftIO $ sndSecure' `shouldBe` sndSecure
   ("", _, CONF confId _ "bob's connInfo") <- get a
@@ -1791,7 +1806,7 @@ testInvitationShortLinkAsync viaProxy a b = do
   connReq' `shouldBe` connReq
   linkUserData connData' `shouldBe` userData
   runRight $ do
-    aId <- A.prepareConnectionToJoin b 1 True connReq PQSupportOn
+    (aId, _) <- A.prepareConnectionToJoin b 1 True connReq PQSupportOn
     A.joinConnectionAsync b "123" False aId True connReq "bob's connInfo" PQSupportOn SMSubscribe
     get b =##> \case ("123", c, JOINED sndSecure) -> c == aId && sndSecure; _ -> False
     ("", _, CONF confId _ "bob's connInfo") <- get a
@@ -1833,7 +1848,7 @@ testContactShortLink viaProxy a b =
       (aId, sndSecure) <- joinConnection b 1 True connReq "bob's connInfo" SMSubscribe
       liftIO $ sndSecure `shouldBe` False
       ("", _, REQ invId _ "bob's connInfo") <- get a
-      bId <- A.prepareConnectionToAccept a 1 True invId PQSupportOn
+      (bId, _) <- A.prepareConnectionToAccept a 1 True invId PQSupportOn
       sndSecure' <- acceptContact a 1 bId True invId "alice's connInfo" PQSupportOn SMSubscribe
       liftIO $ sndSecure' `shouldBe` True
       ("", _, CONF confId  _ "alice's connInfo") <- get b
@@ -1886,7 +1901,7 @@ testAddContactShortLink viaProxy a b =
       (aId, sndSecure) <- joinConnection b 1 True connReq "bob's connInfo" SMSubscribe
       liftIO $ sndSecure `shouldBe` False
       ("", _, REQ invId _ "bob's connInfo") <- get a
-      bId <- A.prepareConnectionToAccept a 1 True invId PQSupportOn
+      (bId, _) <- A.prepareConnectionToAccept a 1 True invId PQSupportOn
       sndSecure' <- acceptContact a 1 bId True invId "alice's connInfo" PQSupportOn SMSubscribe
       liftIO $ sndSecure' `shouldBe` True
       ("", _, CONF confId  _ "alice's connInfo") <- get b
@@ -2045,7 +2060,7 @@ testPrepareCreateConnectionLink ps = withSmpServer ps $ withAgentClients2 $ \a b
     (bId, sndSecure) <- joinConnection b 1 True connReq' "bob's connInfo" SMSubscribe
     liftIO $ sndSecure `shouldBe` False
     ("", _, REQ invId _ "bob's connInfo") <- get a
-    aId <- A.prepareConnectionToAccept a 1 True invId PQSupportOn
+    (aId, _) <- A.prepareConnectionToAccept a 1 True invId PQSupportOn
     sndSecure' <- acceptContact a 1 aId True invId "alice's connInfo" PQSupportOn SMSubscribe
     liftIO $ sndSecure' `shouldBe` True
     ("", _, CONF confId _ "alice's connInfo") <- get b
@@ -2483,6 +2498,49 @@ testExpireManyMessagesQuota (t, msType) = withSmpServerConfigOn t cfg' testPort
   where
     cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 1, maxJournalMsgCount = 2}
 
+testJoinFullContactAsync :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
+testJoinFullContactAsync (t, msType) = withSmpServerConfigOn t cfg' testPort $ \_ -> do
+  (contactId, qInfo) <- fillContactAddress
+  withAgent 2 agentCfg {commandQuotaRetryInterval = fastRetryInterval} initAgentServers testDB2 $ \bob -> do
+    aliceId <- runRight $ do
+      (aliceId, _) <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
+      A.joinConnectionAsync bob "2" False aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
+      pure aliceId
+    threadDelay 500000
+    noMessages bob "joining should be retried while the address is full"
+    withAgent 1 agentCfg initAgentServers testDB $ \alice -> runRight_ $ do
+      subscribeConnection alice contactId
+      ("", _, A.REQ _ _ _ "carol's connInfo" _ _) <- get alice
+      get bob =##> \case ("2", c, JOINED False) -> c == aliceId; _ -> False
+      ("", _, A.REQ _ _ _ "bob's connInfo" _ _) <- get alice
+      pure ()
+  where
+    cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 1, maxJournalMsgCount = 2}
+
+testJoinFullContactAsyncExpire :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
+testJoinFullContactAsyncExpire (t, msType) = withSmpServerConfigOn t cfg' testPort $ \_ -> do
+  (_, qInfo) <- fillContactAddress
+  withAgent 2 agentCfg {quotaExceededTimeout = 2, commandQuotaRetryInterval = fastRetryInterval} initAgentServers testDB2 $ \bob -> do
+    aliceId <- runRight $ do
+      (aliceId, _) <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
+      A.joinConnectionAsync bob "2" False aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
+      pure aliceId
+    threadDelay 500000
+    noMessages bob "joining should be retried until quota exceeded timeout"
+    get bob =##> \case ("2", c, ERR (SMP _ QUOTA)) -> c == aliceId; _ -> False
+  where
+    cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 1, maxJournalMsgCount = 2}
+
+fillContactAddress :: HasCallStack => IO (ConnId, ConnectionRequestUri 'CMContact)
+fillContactAddress = do
+  (contactId, qInfo) <- withAgent 1 agentCfg initAgentServers testDB $ \alice -> runRight $ do
+    (contactId, CCLink qInfo Nothing) <- A.createConnection alice NRMInteractive 1 True True SCMContact Nothing Nothing IKPQOn False SMSubscribe
+    pure (contactId, qInfo)
+  withAgent 3 agentCfg initAgentServers testDB3 $ \carol -> runRight_ $ do
+    (aliceId, _) <- A.prepareConnectionToJoin carol 1 True qInfo PQSupportOn
+    void $ A.joinConnection carol NRMInteractive 1 aliceId True qInfo "carol's connInfo" PQSupportOn SMSubscribe
+  pure (contactId, qInfo)
+
 testDropMsgAfterRcvAttempts :: HasCallStack => (ASrvTransport, AStoreType) -> IO ()
 testDropMsgAfterRcvAttempts ps =
   withSmpServerStoreLogOn ps testPort $ \_ -> do
@@ -2748,7 +2806,7 @@ makeConnectionForUsers = makeConnectionForUsers_ PQSupportOn
 makeConnectionForUsers_ :: HasCallStack => PQSupport -> AgentClient -> UserId -> AgentClient -> UserId -> ExceptT AgentErrorType IO (ConnId, ConnId)
 makeConnectionForUsers_ pqSupport alice aliceUserId bob bobUserId = do
   (bobId, CCLink qInfo Nothing) <- A.createConnection alice NRMInteractive aliceUserId True True SCMInvitation Nothing Nothing (IKLinkPQ pqSupport) False SMSubscribe
-  aliceId <- A.prepareConnectionToJoin bob bobUserId True qInfo pqSupport
+  (aliceId, _) <- A.prepareConnectionToJoin bob bobUserId True qInfo pqSupport
   sqSecured' <- A.joinConnection bob NRMInteractive bobUserId aliceId True qInfo "bob's connInfo" pqSupport SMSubscribe
   liftIO $ sqSecured' `shouldBe` True
   ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
@@ -3030,7 +3088,7 @@ testAsyncCommands alice bob baseId =
     createConnectionAsync alice "1" bobId True SCMInvitation IKPQOn False SMSubscribe
     ("1", bobId', INV (ACR _ qInfo)) <- get alice
     liftIO $ bobId' `shouldBe` bobId
-    aliceId <- prepareConnectionToJoin bob 1 True qInfo PQSupportOn
+    (aliceId, _) <- prepareConnectionToJoin bob 1 True qInfo PQSupportOn
     joinConnectionAsync bob "2" False aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
     ("2", aliceId', JOINED sqSecured') <- get bob
     liftIO $ do
@@ -3100,7 +3158,7 @@ testSetConnShortLinkAsync ps = withAgentClients2 $ \alice bob ->
     -- complete connection via contact address
     (aliceId, _) <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
     ("", _, REQ invId _ "bob's connInfo") <- get alice
-    bobId <- A.prepareConnectionToAccept alice 1 True invId PQSupportOn
+    (bobId, _) <- A.prepareConnectionToAccept alice 1 True invId PQSupportOn
     _ <- acceptContact alice 1 bobId True invId "alice's connInfo" PQSupportOn SMSubscribe
     ("", _, CONF confId _ "alice's connInfo") <- get bob
     allowConnection bob aliceId confId "bob's connInfo"
@@ -3128,7 +3186,7 @@ testGetConnShortLinkAsync ps = withAgentClients2 $ \alice bob ->
     liftIO $ aliceId' `shouldBe` aliceId
     -- complete connection
     ("", _, REQ invId _ "bob's connInfo") <- get alice
-    bobId <- A.prepareConnectionToAccept alice 1 True invId PQSupportOn
+    (bobId, _) <- A.prepareConnectionToAccept alice 1 True invId PQSupportOn
     _ <- acceptContact alice 1 bobId True invId "alice's connInfo" PQSupportOn SMSubscribe
     ("", _, CONF confId _ "alice's connInfo") <- get bob
     allowConnection bob aliceId confId "bob's connInfo"
@@ -3158,7 +3216,7 @@ testAcceptContactAsync alice bob baseId =
     (aliceId, sqSecuredJoin) <- joinConnection bob 1 True qInfo "bob's connInfo" SMSubscribe
     liftIO $ sqSecuredJoin `shouldBe` False -- joining via contact address connection
     ("", _, REQ invId _ "bob's connInfo") <- get alice
-    bobId <- prepareConnectionToAccept alice 1 True invId PQSupportOn
+    (bobId, _) <- prepareConnectionToAccept alice 1 True invId PQSupportOn
     acceptContactAsync alice "1" bobId True invId "alice's connInfo" PQSupportOn SMSubscribe
     get alice =##> \case ("1", c, JOINED sqSecured') -> c == bobId && sqSecured' == True; _ -> False
     ("", _, CONF confId _ "alice's connInfo") <- get bob
@@ -3439,7 +3497,7 @@ testJoinConnectionAsyncReplyError ps@(t, ASType qsType _) = do
         createConnectionAsync a "1" bId True SCMInvitation IKPQOn False SMSubscribe
         ("1", bId', INV (ACR _ qInfo)) <- get a
         liftIO $ bId' `shouldBe` bId
-        aId <- prepareConnectionToJoin b 1 True qInfo PQSupportOn
+        (aId, _) <- prepareConnectionToJoin b 1 True qInfo PQSupportOn
         joinConnectionAsync b "2" False aId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
         liftIO $ threadDelay 500000
         ConnectionStats {rcvQueuesInfo = [], sndQueuesInfo = [SndQueueInfo {}]} <- getConnectionServers b aId
@@ -4022,13 +4080,23 @@ testServerInformation =
       serverCountry = Nothing
     }
 
-testRatchetAdHash :: HasCallStack => IO ()
-testRatchetAdHash =
+testConnectionVerifyCodes :: HasCallStack => IO ()
+testConnectionVerifyCodes =
   withAgentClients2 $ \a b -> runRight_ $ do
     (aId, bId) <- makeConnection a b
-    ad1 <- getConnectionRatchetAdHash a bId
-    ad2 <- getConnectionRatchetAdHash b aId
-    liftIO $ ad1 `shouldBe` ad2
+    codes1 <- getConnectionVerifyCodes a bId
+    codes2 <- getConnectionVerifyCodes b aId
+    liftIO $ do
+      codes1 `shouldBe` codes2
+      codePQ codes1 `shouldNotBe` Nothing
+    liftIO $ withTransaction (store $ agentEnv a) $ \db ->
+      DB.execute_ db "UPDATE ratchets SET rc_verify_code_ad = NULL, rc_verify_code_pq = NULL"
+    codes1' <- getConnectionVerifyCodes a bId
+    liftIO $ codes1' `shouldBe` codes1
+    liftIO $ withTransaction (store $ agentEnv a) $ \db ->
+      DB.execute_ db "UPDATE ratchets SET ratchet_state = NULL"
+    codes1'' <- getConnectionVerifyCodes a bId
+    liftIO $ codes1'' `shouldBe` codes1
 
 testDeliveryReceipts :: HasCallStack => IO ()
 testDeliveryReceipts =
@@ -4617,8 +4685,7 @@ testServerMultipleIdentities =
         testE2ERatchetParams12
 
 testWaitForUserNetwork :: IO ()
-testWaitForUserNetwork = do
-  a <- getSMPAgentClient' 1 aCfg initAgentServers testDB
+testWaitForUserNetwork = withAgent 1 aCfg initAgentServers testDB $ \a -> do
   noNetworkDelay a
   setUserNetworkInfo a $ UserNetworkInfo UNNone False
   networkDelay a 100000
@@ -4635,8 +4702,7 @@ testWaitForUserNetwork = do
     aCfg = agentCfg {userNetworkInterval = 100000, userOfflineDelay = 0}
 
 testDoNotResetOnlineToOffline :: IO ()
-testDoNotResetOnlineToOffline = do
-  a <- getSMPAgentClient' 1 aCfg initAgentServers testDB
+testDoNotResetOnlineToOffline = withAgent 1 aCfg initAgentServers testDB $ \a -> do
   noNetworkDelay a
   setUserNetworkInfo a $ UserNetworkInfo UNWifi False
   networkDelay a 100000
@@ -4657,8 +4723,7 @@ testDoNotResetOnlineToOffline = do
     aCfg = agentCfg {userNetworkInterval = 100000, userOfflineDelay = 0.1}
 
 testResumeMultipleThreads :: IO ()
-testResumeMultipleThreads = do
-  a <- getSMPAgentClient' 1 aCfg initAgentServers testDB
+testResumeMultipleThreads = withAgent 1 aCfg initAgentServers testDB $ \a -> do
   noNetworkDelay a
   setUserNetworkInfo a $ UserNetworkInfo UNNone False
   vs <-

tests/AgentTests/ResolveNameTests.hs

@@ -14,7 +14,6 @@ module AgentTests.ResolveNameTests (resolveNameTests) where
 
 import AgentTests.FunctionalAPITests (withAgent)
 import Control.Monad.Except (runExceptT)
-import qualified Data.Aeson as J
 import qualified Data.ByteString.Lazy as LB
 import Data.List (isInfixOf)
 import Network.HTTP.Types (Status, status200, status404, status502)
@@ -22,7 +21,7 @@ import NamesResolverServer (memCfg, memCfg2, memProxyCfg, withNames)
 import qualified NamesResolverServer as NRS
 import SMPAgentClient
 import SMPClient
-import SMPNamesTests (testNameRecord)
+import SMPNamesTests (availableBody, registeredBody, testNameRecord)
 import Simplex.Messaging.Agent (resolveSimplexName)
 import Simplex.Messaging.Agent.Client (AgentClient)
 import Simplex.Messaging.Agent.Env.SQLite (InitialAgentServers (..), ServerCfg, ServerRoles (..), presetServerCfg)
@@ -71,13 +70,13 @@ withNoNameServers k = withAgent 1 agentCfg (oneSrv (proxySrvCfg testSMPServer))
 resolveNameTests :: Spec
 resolveNameTests = do
   describe "direct path (SPMNever)" $
-    it "404 propagates as SMP host (NAME NOT_FOUND)" testDirectNotFound
+    it "a resolver error propagates as SMP host (NAME RESOLVER)" testDirectResolverErr
   describe "proxy path (SPMAlways)" $
-    it "404 from resolver propagates via proxy as SMP <proxyHost> (NAME NOT_FOUND)" testProxyNotFound
+    it "a resolver error propagates via proxy as SMP <proxyHost> (NAME RESOLVER)" testProxyResolverErr
   describe "TLDTesting path" $
-    it "NAME NOT_FOUND for TLDTesting too" testTestingTldNotFound
+    it "NAME RESOLVER for TLDTesting too" testTestingTldResolverErr
   describe "TLDWeb path" $
-    it "NAME NOT_FOUND for TLDWeb too" testWebTldNotFound
+    it "NAME RESOLVER for TLDWeb too" testWebTldResolverErr
   describe "no resolver configured" $
     it "answers NAME NO_RESOLVER" testNoResolver
   describe "no names servers (names role off everywhere)" $
@@ -86,38 +85,50 @@ resolveNameTests = do
     it "surfaces as SMP host (NAME (RESOLVER ..))" testBackendError
   describe "success path" $
     it "returns NameRecord" testDirectSuccess
+  describe "name availability" $
+    it "an unregistered name answers as available" testAvailSuccess
 
-testDirectNotFound :: HasCallStack => IO ()
-testDirectNotFound =
+testAvailSuccess :: HasCallStack => IO ()
+testAvailSuccess =
+  withDirectResolver (status200, availableBody) $ \c -> do
+    r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDSimplex "alice" [])
+    case r of
+      Right SMP.NameResponse {registration = SMP.NRAvailable {}} -> pure ()
+      _ -> expectationFailure $ "expected Right NRAvailable, got: " <> show r
+
+-- | 404 is a resolver that predates /v2/resolve: no status from that endpoint
+-- means "not registered", since an unregistered name answers NRAvailable.
+testDirectResolverErr :: HasCallStack => IO ()
+testDirectResolverErr =
   withDirectResolver (status404, "{}") $ \c -> do
     r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDSimplex "alice" [])
     case r of
-      Left (SMP _ (SMP.NAME SMP.NOT_FOUND)) -> pure ()
-      _ -> expectationFailure $ "expected Left (SMP _ (NAME NOT_FOUND)), got: " <> show r
+      Left (SMP _ (SMP.NAME (SMP.RESOLVER _))) -> pure ()
+      _ -> expectationFailure $ "expected Left (SMP _ (NAME (RESOLVER _))), got: " <> show r
 
-testProxyNotFound :: HasCallStack => IO ()
-testProxyNotFound =
+testProxyResolverErr :: HasCallStack => IO ()
+testProxyResolverErr =
   withProxyAndResolver (status404, "{}") $ \c -> do
     r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDSimplex "alice" [])
     case r of
-      Left (SMP host (SMP.NAME SMP.NOT_FOUND)) | testPort `isInfixOf` host -> pure ()
-      _ -> expectationFailure $ "expected Left (SMP <proxyHost:" <> testPort <> "> (NAME NOT_FOUND)), got: " <> show r
+      Left (SMP host (SMP.NAME (SMP.RESOLVER _))) | testPort `isInfixOf` host -> pure ()
+      _ -> expectationFailure $ "expected Left (SMP <proxyHost:" <> testPort <> "> (NAME (RESOLVER _))), got: " <> show r
 
-testTestingTldNotFound :: HasCallStack => IO ()
-testTestingTldNotFound =
+testTestingTldResolverErr :: HasCallStack => IO ()
+testTestingTldResolverErr =
   withDirectResolver (status404, "{}") $ \c -> do
     r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDTesting "bob" [])
     case r of
-      Left (SMP _ (SMP.NAME SMP.NOT_FOUND)) -> pure ()
-      _ -> expectationFailure $ "expected Left (SMP _ (NAME NOT_FOUND)), got: " <> show r
+      Left (SMP _ (SMP.NAME (SMP.RESOLVER _))) -> pure ()
+      _ -> expectationFailure $ "expected Left (SMP _ (NAME (RESOLVER _))), got: " <> show r
 
-testWebTldNotFound :: HasCallStack => IO ()
-testWebTldNotFound =
+testWebTldResolverErr :: HasCallStack => IO ()
+testWebTldResolverErr =
   withDirectResolver (status404, "{}") $ \c -> do
     r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDWeb "example.com" [])
     case r of
-      Left (SMP _ (SMP.NAME SMP.NOT_FOUND)) -> pure ()
-      _ -> expectationFailure $ "expected Left (SMP _ (NAME NOT_FOUND)), got: " <> show r
+      Left (SMP _ (SMP.NAME (SMP.RESOLVER _))) -> pure ()
+      _ -> expectationFailure $ "expected Left (SMP _ (NAME (RESOLVER _))), got: " <> show r
 
 testNoResolver :: HasCallStack => IO ()
 testNoResolver =
@@ -145,8 +156,8 @@ testBackendError =
 
 testDirectSuccess :: HasCallStack => IO ()
 testDirectSuccess =
-  withDirectResolver (status200, J.encode testNameRecord) $ \c -> do
+  withDirectResolver (status200, registeredBody testNameRecord) $ \c -> do
     r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDSimplex "alice" [])
     case r of
-      Right nr -> nr `shouldBe` testNameRecord
-      _ -> expectationFailure $ "expected Right NameRecord, got: " <> show r
+      Right SMP.NameResponse {registration = SMP.NRRegistered {nameRecord}} -> nameRecord `shouldBe` testNameRecord
+      _ -> expectationFailure $ "expected Right NRRegistered, got: " <> show r

tests/AgentTests/SQLiteTests.hs

@@ -743,9 +743,11 @@ testGetNextRcvChunkToDownload st = do
   withTransaction st $ \db -> do
     Right Nothing <- getNextRcvChunkToDownload db xftpServer1 86400
 
-    Right _ <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing) True
+    Right fId1 <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing) True
+    Right _ <- startPreparedRcvFile db fId1
     DB.execute_ db "UPDATE rcv_file_chunk_replicas SET replica_key = cast('bad' as blob) WHERE rcv_file_chunk_replica_id = 1"
     Right fId2 <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing) True
+    Right _ <- startPreparedRcvFile db fId2
 
     Left e <- getNextRcvChunkToDownload db xftpServer1 86400
     show e `shouldContain` "ConversionFailed"
@@ -782,7 +784,8 @@ testGetNextSndFileToPrepare st = do
     -- Can't test it with strict tables
     -- Right _ <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing
     -- DB.execute_ db "UPDATE snd_files SET status = 'new', num_recipients = 'bad' WHERE snd_file_id = 1"
-    Right fId2 <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing
+    Right fId2 <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing Nothing
+    Right _ <- startPreparedSndFile db fId2
     DB.execute_ db "UPDATE snd_files SET status = 'new' WHERE snd_file_id = 2"
 
     -- Left e <- getNextSndFileToPrepare db 86400
@@ -798,7 +801,8 @@ newSndChunkReplica1 =
     { server = xftpServer1,
       replicaId = ChunkReplicaId $ EntityId "abc",
       replicaKey = testFileReplicaKey,
-      rcvIdsKeys = [(ChunkReplicaId $ EntityId "abc", testFileReplicaKey)]
+      rcvIdsKeys = [(ChunkReplicaId $ EntityId "abc", testFileReplicaKey)],
+      expiresAt = Nothing
     }
 
 testGetNextSndChunkToUpload :: DBStore -> Expectation
@@ -808,13 +812,13 @@ testGetNextSndChunkToUpload st = do
     Right Nothing <- getNextSndChunkToUpload db xftpServer1 86400
 
     -- create file 1
-    Right _ <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing
+    Right _ <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing Nothing
     updateSndFileEncrypted db 1 (FileDigest "abc") [(XFTPChunkSpec "filepath" 1 1, FileDigest "ghi")]
     -- Can't test it with strict tables
     -- createSndFileReplica_ db 1 newSndChunkReplica1
     -- DB.execute_ db "UPDATE snd_files SET num_recipients = 'bad' WHERE snd_file_id = 1"
     -- create file 2
-    Right fId2 <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing
+    Right fId2 <- createSndFile db g 1 (CryptoFile "filepath" Nothing) 1 "filepath" testFileSbKey testFileCbNonce Nothing Nothing
     updateSndFileEncrypted db 2 (FileDigest "abc") [(XFTPChunkSpec "filepath" 1 1, FileDigest "ghi")]
     createSndFileReplica_ db 2 newSndChunkReplica1
 

tests/AgentTests/ServerChoice.hs

@@ -63,6 +63,7 @@ initServers =
     { smp = M.fromList [(1, testSMPServers)],
       ntf = [testNtfServer],
       xftp = userServers [testXFTPServer],
+      entitlements = M.empty,
       netCfg = defaultNetworkConfig,
       useServices = M.empty,
       presetDomains = [],
@@ -70,9 +71,7 @@ initServers =
     }
 
 testChooseDifferentOperator :: IO ()
-testChooseDifferentOperator = do
-  c <- getSMPAgentClient' 1 agentCfg initServers testDB
-  runRight_ $ do
+testChooseDifferentOperator = withAgent 1 agentCfg initServers testDB $ \c -> runRight_ $ do
     -- chooses the only operator with storage role
     srv1 <- withAgentEnv c $ getNextServer c 1 storageSrvs []
     liftIO $ srv1 == testOp1Srv1 || srv1 == testOp1Srv2 `shouldBe` True

tests/CLITests.hs

@@ -108,6 +108,8 @@ smpServerTest storeLog basicAuth = do
   lookupValue "TRANSPORT" "websockets" ini `shouldBe` Right "off"
   lookupValue "AUTH" "new_queues" ini `shouldBe` Right "on"
   lookupValue "INACTIVE_CLIENTS" "disconnect" ini `shouldBe` Right "on"
+  lookupValue "ADDRESS_STATS" "enable" ini `shouldBe` Right "off"
+  lookupValue "ADDRESS_STATS" "period" ini `shouldBe` Right "300"
   doesFileExist (cfgPath <> "/ca.key") `shouldReturn` True
   -- start
   r <- lines <$> capture_ (withArgs ["start"] $ (100000 `timeout` smpServerCLI cfgPath logPath) `catchAll_` pure (Just ()))
@@ -193,7 +195,7 @@ smpServerTestStatic = do
         X.Certificate {X.certPubKey = X.PubKeyEd25519 _k} : _ca -> print _ca -- pure ()
         leaf : _ -> error $ "Unexpected leaf cert: " <> show leaf
         [] -> error "Empty chain"
-      runRight_ . void $ smpClientHandshake tls Nothing caSMP supportedClientSMPRelayVRange False Nothing
+      runRight_ . void $ smpClientHandshake tls Nothing caSMP supportedClientSMPRelayVRange False Nothing (\_ -> pure Nothing)
     logDebug "Combined SMP works"
   where
     getCerts :: TLS 'TClient -> [X.Certificate]
@@ -234,6 +236,8 @@ ntfServerTest storeLog = do
   lookupValue "STORE_LOG" "log_stats" ini `shouldBe` Right "off"
   lookupValue "TRANSPORT" "port" ini `shouldBe` Right "443"
   lookupValue "TRANSPORT" "websockets" ini `shouldBe` Right "off"
+  lookupValue "ADDRESS_STATS" "enable" ini `shouldBe` Right "off"
+  lookupValue "ADDRESS_STATS" "period" ini `shouldBe` Right "300"
   doesFileExist (ntfCfgPath <> "/ca.key") `shouldReturn` True
   r <- lines <$> capture_ (withArgs ["start"] $ (100000 `timeout` ntfServerCLI ntfCfgPath ntfLogPath) `catchAll_` pure (Just ()))
   r `shouldContain` ["SMP notifications server v" <> simplexmqVersionCommit]
@@ -252,6 +256,8 @@ xftpServerTest storeLog = do
   lookupValue "STORE_LOG" "enable" ini `shouldBe` Right (if storeLog then "on" else "off")
   lookupValue "STORE_LOG" "log_stats" ini `shouldBe` Right "off"
   lookupValue "TRANSPORT" "port" ini `shouldBe` Right "443"
+  lookupValue "ADDRESS_STATS" "enable" ini `shouldBe` Right "off"
+  lookupValue "ADDRESS_STATS" "period" ini `shouldBe` Right "300"
   doesFileExist (fileCfgPath <> "/ca.key") `shouldReturn` True
   r <- lines <$> capture_ (withArgs ["start"] $ (100000 `timeout` xftpServerCLI fileCfgPath fileLogPath) `catchAll_` pure (Just ()))
   r `shouldContain` ["SimpleX XFTP server v" <> simplexmqVersionCommit]

tests/CoreTests/AddressStatsTests.hs

@@ -0,0 +1,326 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module CoreTests.AddressStatsTests where
+
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import Data.IORef (readIORef)
+import Data.List.NonEmpty (NonEmpty (..))
+import qualified Data.Map.Strict as M
+import qualified Data.Set as S
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding (decodeLatin1)
+import Network.Socket (SockAddr (..), tupleToHostAddress, tupleToHostAddress6)
+import qualified Simplex.FileTransfer.Protocol as XFTP
+import Simplex.FileTransfer.Server.Env (XFTPAddrCounter (..), xftpCmdCounter)
+import Simplex.FileTransfer.Transport (supportedFileServerVRange)
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Protocol
+import Simplex.Messaging.Server.AddressStats
+import Simplex.Messaging.Server.Env.STM (SMPAddrCounter (..), smpCmdCounter)
+import Simplex.Messaging.SimplexName (SimplexDomain (..), SimplexTLD (..))
+import Simplex.Messaging.Transport (supportedClientSMPRelayVRange, supportedServerSMPRelayVRange)
+import Simplex.Messaging.Version (VersionRange (..))
+import Test.Hspec hiding (fit, it)
+import UnliftIO.STM
+import Util
+#if defined(dbServerPostgres)
+import qualified Simplex.Messaging.Notifications.Protocol as NTF
+import Simplex.Messaging.Notifications.Server.Env (NtfAddrCounter (..), ntfCmdCounter)
+import Simplex.Messaging.Notifications.Transport (supportedServerNTFVRange)
+#endif
+
+data TestCounter = TCConnections | TCSend | TCGet
+  deriving (Eq, Ord, Enum, Bounded, Show)
+
+instance AddrCounter TestCounter where
+  counterName = \case
+    TCConnections -> "connections"
+    TCSend -> "SEND"
+    TCGet -> "GET"
+  counterBounds _ = [1, 2, 5, 10]
+  connectionsCounter = TCConnections
+
+addr1, addr2, addr3, addr4 :: AddrKey
+addr1 = AKIPv4 1
+addr2 = AKIPv4 2
+addr3 = AKIPv4 3
+addr4 = AKIPv4 4
+
+addressStatsTests :: Spec
+addressStatsTests = do
+  describe "addrKey" addrKeyTests
+  describe "bounds" boundsTests
+  describe "counterByName" counterByNameTests
+  describe "openAddrStats" openAddrStatsTests
+  describe "rolloverAddrStats" rolloverTests
+  describe "topAddresses" topAddressesTests
+  describe "addrHistogramMetrics" metricsTests
+  describe "command counters" commandCounterTests
+
+addrKeyTests :: Spec
+addrKeyTests = do
+  it "should use IPv4 address" $
+    addrKeyText <$> addrKey (ipv4 (192, 168, 1, 2)) `shouldBe` Just "192.168.1.2"
+  it "should use IPv4 address of IPv4-mapped IPv6 address" $
+    addrKey (ipv6 (0, 0, 0, 0, 0, 0xffff, 0xc0a8, 0x0102)) `shouldBe` addrKey (ipv4 (192, 168, 1, 2))
+  it "should use one key for IPv6 addresses in one /64" $ do
+    addrKey (ipv6 (0x2001, 0xdb8, 1, 2, 3, 4, 5, 6)) `shouldBe` addrKey (ipv6 (0x2001, 0xdb8, 1, 2, 7, 8, 9, 10))
+    addrKeyText <$> addrKey (ipv6 (0x2001, 0xdb8, 1, 2, 3, 4, 5, 6)) `shouldBe` Just "2001:db8:1:2::/64"
+  it "should use different keys for IPv6 addresses in different /64" $
+    addrKey (ipv6 (0x2001, 0xdb8, 1, 2, 3, 4, 5, 6)) `shouldNotBe` addrKey (ipv6 (0x2001, 0xdb8, 1, 3, 3, 4, 5, 6))
+  it "should not use other address types" $
+    addrKey (SockAddrUnix "tests/tmp/socket") `shouldBe` Nothing
+  where
+    ipv4 a = SockAddrInet 443 $ tupleToHostAddress a
+    ipv6 a = SockAddrInet6 443 0 (tupleToHostAddress6 a) 0
+
+boundsTests :: Spec
+boundsTests = do
+  it "should use R10 values up to 1000000 for counts" $
+    countBounds
+      `shouldBe` [ 1, 2, 3, 4, 5, 6, 7, 8, 9,
+                   10, 13, 16, 20, 25, 32, 40, 50, 63, 80,
+                   100, 125, 160, 200, 250, 315, 400, 500, 630, 800,
+                   1000, 1250, 1600, 2000, 2500, 3150, 4000, 5000, 6300, 8000,
+                   10000, 12500, 16000, 20000, 25000, 31500, 40000, 50000, 63000, 80000,
+                   100000, 125000, 160000, 200000, 250000, 315000, 400000, 500000, 630000, 800000,
+                   1000000
+                 ]
+  it "should use R10 values up to 100000000 for kilobytes" $ do
+    take 60 kilobyteBounds `shouldBe` countBounds
+    drop 59 kilobyteBounds
+      `shouldBe` [ 1000000, 1250000, 1600000, 2000000, 2500000, 3150000, 4000000, 5000000, 6300000, 8000000,
+                   10000000, 12500000, 16000000, 20000000, 25000000, 31500000, 40000000, 50000000, 63000000, 80000000,
+                   100000000
+                 ]
+
+counterByNameTests :: Spec
+counterByNameTests = do
+  it "should find SMP counters" $ testCounterNames [minBound .. maxBound :: SMPAddrCounter]
+  it "should find XFTP counters" $ testCounterNames [minBound .. maxBound :: XFTPAddrCounter]
+#if defined(dbServerPostgres)
+  it "should find NTF counters" $ testCounterNames [minBound .. maxBound :: NtfAddrCounter]
+#endif
+  it "should not find unknown counter" $
+    counterByName "unknown" `shouldBe` (Nothing :: Maybe SMPAddrCounter)
+  where
+    testCounterNames :: (AddrCounter c, Show c) => [c] -> Expectation
+    testCounterNames cs = map (counterByName . counterName) cs `shouldBe` map Just cs
+
+openAddrStatsTests :: Spec
+openAddrStatsTests =
+  it "should count connections of one address in one entry" $ do
+    ServerAddrStats {addrStatsMap = m} <- newServerAddrStats
+    s <- openAddrStats m addr1
+    s' <- openAddrStats m addr1
+    readTVarIO (connectionsCount s) `shouldReturn` 2
+    counts s TCConnections `shouldReturn` (0, 2)
+    closeAddrStats s'
+    readTVarIO (connectionsCount s) `shouldReturn` 1
+
+rolloverTests :: Spec
+rolloverTests = do
+  it "should add non-zero closing counts to histograms" $ do
+    stats@ServerAddrStats {addrStatsMap = m, addrHistograms} <- newServerAddrStats
+    s1 <- openAddrStats m addr1
+    s2 <- openAddrStats m addr2
+    addAddrCounter s1 TCSend 3
+    addAddrCounter s2 TCSend 7
+    rolloverAddrStats stats
+    readIORef addrHistograms
+      `shouldReturn` M.fromList
+        [ (TCConnections, AddrHistogram [2, 2, 2, 2] 2 2 1),
+          (TCSend, AddrHistogram [0, 0, 1, 2] 10 2 7),
+          (TCGet, AddrHistogram [0, 0, 0, 0] 0 0 0)
+        ]
+    addAddrCounter s1 TCSend 20
+    rolloverAddrStats stats
+    readIORef addrHistograms
+      `shouldReturn` M.fromList
+        [ (TCConnections, AddrHistogram [2, 2, 2, 2] 2 2 0),
+          (TCSend, AddrHistogram [0, 0, 1, 2] 30 3 20),
+          (TCGet, AddrHistogram [0, 0, 0, 0] 0 0 0)
+        ]
+  it "should set previous counts to closing counts" $ do
+    stats@ServerAddrStats {addrStatsMap = m} <- newServerAddrStats
+    s <- openAddrStats m addr1
+    addAddrCounter s TCSend 3
+    counts s TCSend `shouldReturn` (0, 3)
+    rolloverAddrStats stats
+    counts s TCSend `shouldReturn` (3, 0)
+    addAddrCounter s TCSend 5
+    rolloverAddrStats stats
+    counts s TCSend `shouldReturn` (5, 0)
+    rolloverAddrStats stats
+    counts s TCSend `shouldReturn` (0, 0)
+  it "should keep entries with open connections or closing counts, and delete other entries" $ do
+    stats@ServerAddrStats {addrStatsMap = m} <- newServerAddrStats
+    _ <- openAddrStats m addr1
+    s2 <- openAddrStats m addr2
+    s3 <- openAddrStats m addr3
+    closeAddrStats s3
+    rolloverAddrStats stats
+    M.keys <$> readTVarIO m `shouldReturn` [addr1, addr2, addr3]
+    addAddrCounter s2 TCSend 1
+    closeAddrStats s2
+    rolloverAddrStats stats
+    M.keys <$> readTVarIO m `shouldReturn` [addr1, addr2]
+    rolloverAddrStats stats
+    M.keys <$> readTVarIO m `shouldReturn` [addr1]
+
+topAddressesTests :: Spec
+topAddressesTests =
+  it "should return addresses with non-zero counts, sorted by the sum of previous and current counts" $ do
+    stats@ServerAddrStats {addrStatsMap = m} <- newServerAddrStats
+    [s1, s2, s3, _] <- mapM (openAddrStats m) [addr1, addr2, addr3, addr4]
+    addAddrCounter s1 TCSend 3
+    addAddrCounter s2 TCSend 7
+    rolloverAddrStats stats
+    addAddrCounter s1 TCSend 5
+    addAddrCounter s3 TCSend 10
+    topAddresses m TCSend 10 `shouldReturn` [(addr3, 0, 10), (addr1, 3, 5), (addr2, 7, 0)]
+    topAddresses m TCSend 2 `shouldReturn` [(addr3, 0, 10), (addr1, 3, 5)]
+
+metricsTests :: Spec
+metricsTests =
+  it "should encode histograms and maximums as Prometheus metrics" $
+    addrHistogramMetrics "simplex_test" "1767225600000" histograms
+      `shouldBe` T.unlines
+        [ "# Client addresses",
+          "# ----------------",
+          "",
+          "# HELP simplex_test_client_address_period_count Counts of client addresses per period",
+          "# TYPE simplex_test_client_address_period_count histogram",
+          "simplex_test_client_address_period_count_bucket{counter=\"SEND\",le=\"1\"} 0 1767225600000",
+          "simplex_test_client_address_period_count_bucket{counter=\"SEND\",le=\"2\"} 0 1767225600000",
+          "simplex_test_client_address_period_count_bucket{counter=\"SEND\",le=\"5\"} 1 1767225600000",
+          "simplex_test_client_address_period_count_bucket{counter=\"SEND\",le=\"10\"} 2 1767225600000",
+          "simplex_test_client_address_period_count_bucket{counter=\"SEND\",le=\"+Inf\"} 2 1767225600000",
+          "simplex_test_client_address_period_count_sum{counter=\"SEND\"} 10 1767225600000",
+          "simplex_test_client_address_period_count_count{counter=\"SEND\"} 2 1767225600000",
+          "simplex_test_client_address_period_count_bucket{counter=\"GET\",le=\"1\"} 0 1767225600000",
+          "simplex_test_client_address_period_count_bucket{counter=\"GET\",le=\"2\"} 0 1767225600000",
+          "simplex_test_client_address_period_count_bucket{counter=\"GET\",le=\"5\"} 0 1767225600000",
+          "simplex_test_client_address_period_count_bucket{counter=\"GET\",le=\"10\"} 0 1767225600000",
+          "simplex_test_client_address_period_count_bucket{counter=\"GET\",le=\"+Inf\"} 1 1767225600000",
+          "simplex_test_client_address_period_count_sum{counter=\"GET\"} 12 1767225600000",
+          "simplex_test_client_address_period_count_count{counter=\"GET\"} 1 1767225600000",
+          "",
+          "# HELP simplex_test_client_address_period_max Maximum count of a client address in the last period",
+          "# TYPE simplex_test_client_address_period_max gauge",
+          "simplex_test_client_address_period_max{counter=\"SEND\"} 7 1767225600000",
+          "simplex_test_client_address_period_max{counter=\"GET\"} 12 1767225600000",
+          ""
+        ]
+  where
+    histograms =
+      M.fromList
+        [ (TCSend, AddrHistogram [0, 0, 1, 2] 10 2 7),
+          (TCGet, AddrHistogram [0, 0, 0, 0] 12 1 12)
+        ]
+
+commandCounterTests :: Spec
+commandCounterTests = do
+  it "should count each SMP command in the counter named by its tag" $ do
+    cmds <- smpCommands
+    map (counterName . smpCmdCounter) cmds `shouldBe` map (commandTag . encodeProtocol (maxVersion supportedServerSMPRelayVRange)) cmds
+    S.fromList (map smpCmdCounter cmds) `shouldBe` S.fromList [SACNew .. SACRslv]
+  it "should count each XFTP command in the counter named by its tag" $ do
+    cmds <- xftpCommands
+    map (counterName . xftpCmdCounter) cmds `shouldBe` map (commandTag . encodeProtocol (maxVersion supportedFileServerVRange)) cmds
+    S.fromList (map xftpCmdCounter cmds) `shouldBe` S.fromList [XACFNew .. XACPing]
+#if defined(dbServerPostgres)
+  it "should count each NTF command in the counter named by its tag" $ do
+    cmds <- ntfCommands
+    map (counterName . ntfCmdCounter) cmds `shouldBe` map (commandTag . encodeProtocol (maxVersion supportedServerNTFVRange)) cmds
+    S.fromList (map ntfCmdCounter cmds) `shouldBe` S.fromList [NACTNew .. NACPing]
+#endif
+  where
+    commandTag :: ByteString -> Text
+    commandTag = decodeLatin1 . B.takeWhile (/= ' ')
+
+counts :: AddrStats TestCounter -> TestCounter -> IO (Int, Int)
+counts AddrStats {previous, current} c = (,) <$> readIORef (previous M.! c) <*> readIORef (current M.! c)
+
+testKeys :: IO (C.APublicAuthKey, C.APrivateAuthKey, C.PublicKeyX25519)
+testKeys = do
+  g <- C.newRandom
+  (authKey, authPrivKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
+  (dhKey, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
+  pure (authKey, authPrivKey, dhKey)
+
+testSMPServer :: SMPServer
+testSMPServer = SMPServer "localhost" "5001" (C.KeyHash "hash")
+
+smpCommands :: IO [Cmd]
+smpCommands = do
+  (authKey, _, dhKey) <- testKeys
+  let newQueue = NewQueueReq {rcvAuthKey = authKey, rcvDhKey = dhKey, auth_ = Nothing, subMode = SMSubscribe, queueReqData = Nothing, ntfCreds = Nothing}
+      linkData = (EncDataBytes "fixed", EncDataBytes "user")
+      name = NQDomain SimplexDomain {nameTLD = TLDSimplex, domain = "alice", subDomain = []}
+  pure
+    [ Cmd SCreator $ NEW newQueue,
+      Cmd SRecipient SUB,
+      Cmd SRecipientService $ SUBS 1 mempty,
+      Cmd SRecipient $ KEY authKey,
+      Cmd SRecipient $ RKEY (authKey :| []),
+      Cmd SRecipient $ LSET (EntityId "link") linkData,
+      Cmd SRecipient LDEL,
+      Cmd SRecipient $ NKEY authKey dhKey,
+      Cmd SRecipient NDEL,
+      Cmd SRecipient GET,
+      Cmd SRecipient $ ACK "message",
+      Cmd SRecipient OFF,
+      Cmd SRecipient DEL,
+      Cmd SRecipient QUE,
+      Cmd SSender $ SKEY authKey,
+      Cmd SSender $ SEND noMsgFlags "hello",
+      Cmd SIdleClient PING,
+      Cmd SSenderLink $ LKEY authKey,
+      Cmd SSenderLink LGET,
+      Cmd SNotifier NSUB,
+      Cmd SNotifierService $ NSUBS 1 mempty,
+      Cmd SProxiedClient $ PRXY testSMPServer Nothing,
+      Cmd SProxiedClient $ PFWD (maxVersion supportedClientSMPRelayVRange) dhKey (EncTransmission "transmission"),
+      Cmd SProxyService $ RFWD (EncFwdTransmission "transmission"),
+      Cmd SResolver $ RSLV name
+    ]
+
+xftpCommands :: IO [XFTP.FileCmd]
+xftpCommands = do
+  (authKey, _, dhKey) <- testKeys
+  pure
+    [ XFTP.FileCmd XFTP.SFSender $ XFTP.FNEW (XFTP.FileInfo authKey 65536 "digest") (authKey :| []) Nothing Nothing,
+      XFTP.FileCmd XFTP.SFSender $ XFTP.FADD (authKey :| []),
+      XFTP.FileCmd XFTP.SFSender XFTP.FPUT,
+      XFTP.FileCmd XFTP.SFSender XFTP.FDEL,
+      XFTP.FileCmd XFTP.SFRecipient $ XFTP.FGET dhKey,
+      XFTP.FileCmd XFTP.SFRecipient XFTP.FACK,
+      XFTP.FileCmd XFTP.SFRecipient XFTP.PING
+    ]
+
+#if defined(dbServerPostgres)
+ntfCommands :: IO [NTF.NtfCmd]
+ntfCommands = do
+  (authKey, authPrivKey, dhKey) <- testKeys
+  let token = NTF.DeviceToken NTF.PPApnsTest "token"
+      queue = NTF.SMPQueueNtf testSMPServer (EntityId "notifier")
+  pure
+    [ NTF.NtfCmd NTF.SToken $ NTF.TNEW $ NTF.NewNtfTkn token authKey dhKey,
+      NTF.NtfCmd NTF.SToken $ NTF.TVFY $ NTF.NtfRegCode "code",
+      NTF.NtfCmd NTF.SToken NTF.TCHK,
+      NTF.NtfCmd NTF.SToken $ NTF.TRPL token,
+      NTF.NtfCmd NTF.SToken NTF.TDEL,
+      NTF.NtfCmd NTF.SToken $ NTF.TCRN 20,
+      NTF.NtfCmd NTF.SSubscription $ NTF.SNEW $ NTF.NewNtfSub (EntityId "token") queue authPrivKey,
+      NTF.NtfCmd NTF.SSubscription NTF.SCHK,
+      NTF.NtfCmd NTF.SSubscription NTF.SDEL,
+      NTF.NtfCmd NTF.SSubscription NTF.PING
+    ]
+#endif

tests/CoreTests/CryptoTests.hs

@@ -7,14 +7,18 @@
 module CoreTests.CryptoTests (cryptoTests) where
 
 import Control.Concurrent.STM
+import Control.Exception (evaluate)
 import Control.Monad.Except
 import qualified Data.Aeson as J
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Either (isLeft, isRight)
 import Data.Int (Int64)
+import qualified Data.Map.Strict as M
 import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
+import Data.Time.Calendar (fromGregorian)
+import Data.Time.Clock (UTCTime (..))
 import qualified Data.Text.Lazy as LT
 import qualified Data.Text.Lazy.Encoding as LE
 import Data.Type.Equality
@@ -25,6 +29,7 @@ import qualified SMPClient
 import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Lazy as LC
 import Simplex.Messaging.Crypto.BBS
+import Simplex.Messaging.Crypto.Entitlement
 import Simplex.Messaging.Crypto.SNTRUP761.Bindings
 import Simplex.Messaging.Crypto.SNTRUP761.Bindings.Defines
 import Simplex.Messaging.Encoding (Large (..), smpDecode, smpEncode)
@@ -119,6 +124,9 @@ cryptoTests = do
     it "should produce unlinkable proofs" testBBSUnlinkable
     it "should produce proof of expected size" testBBSProofSize
     it "should roundtrip JSON and reject wrong-length input" testBBSJSON
+  describe "Entitlement" $ do
+    it "should sign, prove and verify, bound to the presentation header" testEntitlementRoundtrip
+    it "should decode all issuer keys" testEntitlementIssuerKeys
 
 instance Eq C.APublicKey where
   C.APublicKey a k == C.APublicKey a' k' = case testEquality a a' of
@@ -444,3 +452,26 @@ testBBSJSON = do
   -- FromJSON must reject wrong-length input (regression: StrJSON length validation)
   (J.decode (J.encode (BBSSecretKey (B.replicate 16 '\0'))) :: Maybe BBSSecretKey) `shouldBe` Nothing
   (J.decode (J.encode (BBSSignature (B.replicate 10 '\0'))) :: Maybe BBSSignature) `shouldBe` Nothing
+
+testEntitlementRoundtrip :: IO ()
+testEntitlementRoundtrip = do
+  Right (pk, sk) <- bbsKeyGen
+  let keys = M.singleton 1 pk
+      mk = MasterKey (B.replicate 32 '\7')
+      ent = Entitlement {entitlementName = "supporter", expiresAt = UTCTime (fromGregorian 2030 1 1) 0, extraInfo = ""}
+      ph = BBSPresHeader "session-id"
+  Right cred <- signEntitlement sk 1 mk ent
+  verifyCredential pk cred `shouldReturn` True
+  Right proof <- generateEntitlementProof keys cred ph
+  verifyEntitlement keys ph proof `shouldReturn` EVValid
+  -- a different presentation header does not verify (session binding)
+  verifyEntitlement keys (BBSPresHeader "other") proof `shouldReturn` EVInvalid
+  -- an unknown issuer key index is distinguished from an invalid proof
+  verifyEntitlement (M.singleton 2 pk) ph proof `shouldReturn` EVUnknownIssuer
+  -- the protocol encoding of the proof roundtrips
+  smpDecode (smpEncode proof) `shouldBe` Right proof
+
+testEntitlementIssuerKeys :: IO ()
+testEntitlementIssuerKeys = do
+  mapM_ evaluate entitlementIssuerKeys
+  M.size entitlementIssuerKeys `shouldBe` 8

tests/CoreTests/RetryIntervalTests.hs

@@ -14,8 +14,11 @@ import Util
 retryIntervalTests :: Spec
 retryIntervalTests = do
   describe "Retry interval with 2 modes and lock" $ do
-    testRetryIntervalSameMode
-    testRetryIntervalSwitchMode
+    testRetryIntervalSameMode withRetryNewLock2
+    testRetryIntervalSwitchMode withRetryNewLock2
+  describe "Retry interval with 2 modes" $ do
+    testRetryIntervalSameMode withRetryInterval2
+    testRetryIntervalSwitchMode withRetryInterval2
   describe "Foreground retry interval" $ do
     testRetryForeground
     testRetryToBackground
@@ -41,14 +44,18 @@ testFastRI =
       maxInterval = 40000
     }
 
-testRetryIntervalSameMode :: Spec
-testRetryIntervalSameMode =
+type WithRetry2 = RetryInterval2 -> (RI2State -> (RetryIntervalMode -> IO ()) -> IO ()) -> IO ()
+
+withRetryNewLock2 :: WithRetry2
+withRetryNewLock2 ri action = newEmptyTMVarIO >>= \lock -> withRetryLock2 ri lock action
+
+testRetryIntervalSameMode :: WithRetry2 -> Spec
+testRetryIntervalSameMode withRetry =
   it "should increase elapased time and interval when the mode stays the same" $ do
-    lock <- newEmptyTMVarIO
     intervals <- newTVarIO []
     reportedIntervals <- newTVarIO []
     ts <- newTVarIO =<< getCurrentTime
-    withRetryLock2 testRI lock $ \(RI2State slow fast) loop -> do
+    withRetry testRI $ \(RI2State slow fast) loop -> do
       ints <- addInterval intervals ts
       atomically $ modifyTVar' reportedIntervals ((slow, fast) :)
       when (length ints < 9) $ loop RIFast
@@ -65,14 +72,13 @@ testRetryIntervalSameMode =
                        (20000, 40000)
                      ]
 
-testRetryIntervalSwitchMode :: Spec
-testRetryIntervalSwitchMode =
+testRetryIntervalSwitchMode :: WithRetry2 -> Spec
+testRetryIntervalSwitchMode withRetry =
   it "should increase elapased time and interval when the mode switches" $ do
-    lock <- newEmptyTMVarIO
     intervals <- newTVarIO []
     reportedIntervals <- newTVarIO []
     ts <- newTVarIO =<< getCurrentTime
-    withRetryLock2 testRI lock $ \(RI2State slow fast) loop -> do
+    withRetry testRI $ \(RI2State slow fast) loop -> do
       ints <- addInterval intervals ts
       atomically $ modifyTVar' reportedIntervals ((slow, fast) :)
       when (length ints < 11) $ loop $ if length ints <= 5 then RIFast else RISlow

tests/CoreTests/StoreLogTests.hs

@@ -20,9 +20,13 @@ import qualified Data.Map.Strict as M
 import qualified Data.X509 as X
 import qualified Data.X509.Validation as XV
 import SMPClient
+import Simplex.FileTransfer.Protocol (FileInfo (..))
+import Simplex.FileTransfer.Server.Store (FileRec (..), FileRecipient (..), FileStoreClass (..), RoundedFileTime, STMFileStore (..))
+import Simplex.FileTransfer.Server.StoreLog (FileStoreLogRecord (..), readWriteFileStore)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Protocol
+import Simplex.Messaging.Protocol.Types (ClientNotice (..))
 import Simplex.Messaging.Server.Env.STM (readWriteQueueStore)
 import Simplex.Messaging.Server.MsgStore.Journal
 import Simplex.Messaging.Server.MsgStore.Types
@@ -191,3 +195,100 @@ testSMPStoreLog testSuite tests =
       compacted' `shouldBe` compacted
     storeState :: JournalMsgStore 'QSMemory -> IO (M.Map RecipientId QueueRec)
     storeState st = M.mapMaybe id <$> (readTVarIO (queues $ stmQueueStore st) >>= mapM (readTVarIO . queueRec))
+
+type FileRecState = (FileInfo, RoundedFileTime, Maybe RoundedFileTime, ServerEntityStatus)
+
+type XFTPStoreLogTestCase = StoreLogTestCase FileStoreLogRecord (M.Map SenderId FileRecState)
+
+deriving instance Eq FileInfo
+
+deriving instance Eq FileRecipient
+
+deriving instance Eq FileStoreLogRecord
+
+testFileStoreLogFile :: FilePath
+testFileStoreLogFile = "tests/tmp/xftp-server-store.log"
+
+fileExpirationTests :: Spec
+fileExpirationTests =
+  describe "XFTP file expiration" $
+    it "expires by stored expiration and by creation time" testExpiredFiles
+
+testExpiredFiles :: Expectation
+testExpiredFiles = do
+  st <- newFileStore () :: IO STMFileStore
+  g <- C.newRandom
+  (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
+  let file = FileInfo {sndKey, size = 16384, digest = "12345678"}
+      created = RoundedSystemTime 100000
+  addFile st (EntityId "expired_stored__") file created (Just (RoundedSystemTime 400000)) EntityActive `shouldReturn` Right ()
+  addFile st (EntityId "stored_ahead____") file created (Just (RoundedSystemTime 900000)) EntityActive `shouldReturn` Right ()
+  addFile st (EntityId "legacy_expired__") file created Nothing EntityActive `shouldReturn` Right ()
+  addFile st (EntityId "legacy_in_grace_") file (RoundedSystemTime 297000) Nothing EntityActive `shouldReturn` Right ()
+  expired <- expiredFiles st (RoundedSystemTime 500000) 300000 100
+  map (\(sId, _, _) -> sId) expired `shouldMatchList` [EntityId "expired_stored__", EntityId "legacy_expired__"]
+
+fileStoreLogTests :: Spec
+fileStoreLogTests = do
+  g <- runIO C.newRandom
+  (sndKey, _) <- runIO $ atomically $ C.generateAuthKeyPair C.SEd25519 g
+  sId <- runIO $ atomically $ EntityId <$> C.randomBytes 24 g
+  let file = FileInfo {sndKey, size = 16384, digest = "12345678"}
+      createdAt = RoundedSystemTime 1600000000
+      expiresAt = RoundedSystemTime 1600172800
+      blocked = BlockingInfo {reason = BRSpam, notice = Nothing}
+      blockedWithNotice = BlockingInfo {reason = BRContent, notice = Just ClientNotice {ttl = Just 86400}}
+  testXFTPStoreLog
+    "XFTP server store log"
+    [ SLTC
+        { name = "create file",
+          saved = [AddFile sId file createdAt (Just expiresAt) EntityActive],
+          compacted = [AddFile sId file createdAt (Just expiresAt) EntityActive],
+          state = M.fromList [(sId, (file, createdAt, Just expiresAt, EntityActive))]
+        },
+      SLTC
+        { name = "create file without expiration",
+          saved = [AddFile sId file createdAt Nothing EntityActive],
+          compacted = [AddFile sId file createdAt Nothing EntityActive],
+          state = M.fromList [(sId, (file, createdAt, Nothing, EntityActive))]
+        },
+      SLTC
+        { name = "create and block file",
+          saved = [AddFile sId file createdAt (Just expiresAt) EntityActive, BlockFile sId blocked],
+          compacted = [AddFile sId file createdAt (Just expiresAt) (EntityBlocked blocked)],
+          state = M.fromList [(sId, (file, createdAt, Just expiresAt, EntityBlocked blocked))]
+        },
+      SLTC
+        { name = "create and block file with notice",
+          saved = [AddFile sId file createdAt (Just expiresAt) EntityActive, BlockFile sId blockedWithNotice],
+          compacted = [AddFile sId file createdAt (Just expiresAt) (EntityBlocked blockedWithNotice)],
+          state = M.fromList [(sId, (file, createdAt, Just expiresAt, EntityBlocked blockedWithNotice))]
+        },
+      SLTC
+        { name = "block file without expiration",
+          saved = [AddFile sId file createdAt Nothing EntityActive, BlockFile sId blockedWithNotice],
+          compacted = [AddFile sId file createdAt Nothing (EntityBlocked blockedWithNotice)],
+          state = M.fromList [(sId, (file, createdAt, Nothing, EntityBlocked blockedWithNotice))]
+        }
+    ]
+
+testXFTPStoreLog :: String -> [XFTPStoreLogTestCase] -> Spec
+testXFTPStoreLog testSuite tests =
+  describe testSuite $ forM_ tests $ \t@SLTC {name, saved} -> it name $ do
+    l <- openWriteStoreLog False testFileStoreLogFile
+    mapM_ (writeStoreLogRecord l) saved
+    closeStoreLog l
+    replicateM_ 3 $ testReadWrite t
+  where
+    testReadWrite SLTC {compacted, state} = do
+      st <- newFileStore () :: IO STMFileStore
+      l <- readWriteFileStore testFileStoreLogFile st
+      storeState st `shouldReturn` state
+      closeStoreLog l
+      ([], compacted') <- partitionEithers . map strDecode . B.lines <$> B.readFile testFileStoreLogFile
+      compacted' `shouldBe` compacted
+    storeState :: STMFileStore -> IO (M.Map SenderId FileRecState)
+    storeState st = readTVarIO (files st) >>= mapM fileState
+    fileState FileRec {fileInfo, createdAt, expiresAt, fileStatus} = do
+      status <- readTVarIO fileStatus
+      pure (fileInfo, createdAt, expiresAt, status)

tests/CoreTests/XFTPStoreTests.hs

@@ -37,6 +37,7 @@ xftpStoreTests = do
     it "should block file and update status" testBlockFile
     it "should ack file reception" testAckFile
     it "should return expired files with limit" testExpiredFiles
+    it "should expire files by stored expiration" testExpiredFilesStoredExpiration
     it "should compute committed used storage and file count" testStorageAndCount
 
 xftpMigrationTests :: Spec
@@ -68,6 +69,9 @@ testFileInfo sndKey =
 testCreatedAt :: RoundedFileTime
 testCreatedAt = RoundedSystemTime 1000000
 
+testExpiresAt :: RoundedFileTime
+testExpiresAt = RoundedSystemTime 2000000
+
 -- Tests
 
 testAddGetFileSender :: Expectation
@@ -75,7 +79,7 @@ testAddGetFileSender = withPgStore $ \st -> do
   g <- C.newRandom
   (sk, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
   let fileInfo = testFileInfo sk
-  addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right ()
+  addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right ()
   result <- getFile st SFSender testSenderId
   case result of
     Right (FileRec {senderId, fileInfo = fi, createdAt}, key) -> do
@@ -92,7 +96,7 @@ testAddGetFileRecipient = withPgStore $ \st -> do
   (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
   (rcpKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
   let fileInfo = testFileInfo sndKey
-  addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right ()
+  addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right ()
   addRecipient st testSenderId (FileRecipient testRecipientId rcpKey) `shouldReturn` Right ()
   result <- getFile st SFRecipient testRecipientId
   case result of
@@ -106,8 +110,8 @@ testDuplicateFile = withPgStore $ \st -> do
   g <- C.newRandom
   (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
   let fileInfo = testFileInfo sndKey
-  addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right ()
-  addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Left DUPLICATE_
+  addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right ()
+  addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Left DUPLICATE_
 
 testGetNonexistent :: Expectation
 testGetNonexistent = withPgStore $ \st -> do
@@ -119,7 +123,7 @@ testSetFilePath = withPgStore $ \st -> do
   g <- C.newRandom
   (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
   let fileInfo = testFileInfo sndKey
-  addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right ()
+  addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right ()
   setFilePath st testSenderId "/tmp/test_file" `shouldReturn` Right ()
   -- Second setFilePath should fail (file_path IS NULL guard)
   setFilePath st testSenderId "/tmp/other_file" `shouldReturn` Left AUTH
@@ -135,7 +139,7 @@ testDuplicateRecipient = withPgStore $ \st -> do
   (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
   (rcpKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
   let fileInfo = testFileInfo sndKey
-  addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right ()
+  addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right ()
   addRecipient st testSenderId (FileRecipient testRecipientId rcpKey) `shouldReturn` Right ()
   addRecipient st testSenderId (FileRecipient testRecipientId rcpKey) `shouldReturn` Left DUPLICATE_
 
@@ -145,7 +149,7 @@ testDeleteFileCascade = withPgStore $ \st -> do
   (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
   (rcpKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
   let fileInfo = testFileInfo sndKey
-  addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right ()
+  addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right ()
   addRecipient st testSenderId (FileRecipient testRecipientId rcpKey) `shouldReturn` Right ()
   deleteFile st testSenderId `shouldReturn` Right ()
   -- File and recipient should both be gone
@@ -157,7 +161,7 @@ testBlockFile = withPgStore $ \st -> do
   g <- C.newRandom
   (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
   let fileInfo = testFileInfo sndKey
-  addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right ()
+  addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right ()
   let blockInfo = BlockingInfo {reason = BRContent, notice = Nothing}
   blockFile st testSenderId blockInfo False `shouldReturn` Right ()
   result <- getFile st SFSender testSenderId
@@ -171,7 +175,7 @@ testAckFile = withPgStore $ \st -> do
   (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
   (rcpKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
   let fileInfo = testFileInfo sndKey
-  addFile st testSenderId fileInfo testCreatedAt EntityActive `shouldReturn` Right ()
+  addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right ()
   addRecipient st testSenderId (FileRecipient testRecipientId rcpKey) `shouldReturn` Right ()
   ackFile st testRecipientId `shouldReturn` Right ()
   -- Recipient gone, but file still exists
@@ -189,11 +193,11 @@ testExpiredFiles = withPgStore $ \st -> do
       oldTime = RoundedSystemTime 100000
       newTime = RoundedSystemTime 999999999
   -- Add old and new files
-  addFile st (EntityId "old_file________") fileInfo oldTime EntityActive `shouldReturn` Right ()
+  addFile st (EntityId "old_file________") fileInfo oldTime Nothing EntityActive `shouldReturn` Right ()
   void $ setFilePath st (EntityId "old_file________") "/tmp/old"
-  addFile st (EntityId "new_file________") fileInfo newTime EntityActive `shouldReturn` Right ()
+  addFile st (EntityId "new_file________") fileInfo newTime Nothing EntityActive `shouldReturn` Right ()
   -- Query expired with cutoff that only catches old file
-  expired <- expiredFiles st 500000 100
+  expired <- expiredFiles st (RoundedSystemTime 500000) 500000 100
   length expired `shouldBe` 1
   case expired of
     [(sId, path, sz)] -> do
@@ -202,6 +206,18 @@ testExpiredFiles = withPgStore $ \st -> do
       sz `shouldBe` 128000
     _ -> expectationFailure "expected 1 expired file"
 
+testExpiredFilesStoredExpiration :: Expectation
+testExpiredFilesStoredExpiration = withPgStore $ \st -> do
+  g <- C.newRandom
+  (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
+  let fileInfo = testFileInfo sndKey
+      oldTime = RoundedSystemTime 100000
+  -- both files are created before the cutoff, the stored expiration decides
+  addFile st (EntityId "expired_file____") fileInfo oldTime (Just (RoundedSystemTime 400000)) EntityActive `shouldReturn` Right ()
+  addFile st (EntityId "stored_file_____") fileInfo oldTime (Just (RoundedSystemTime 900000)) EntityActive `shouldReturn` Right ()
+  expired <- expiredFiles st (RoundedSystemTime 500000) 0 100
+  map (\(sId, _, _) -> sId) expired `shouldBe` [EntityId "expired_file____"]
+
 testStorageAndCount :: Expectation
 testStorageAndCount = withPgStore $ \st -> do
   testStorageAndCountForStore st
@@ -222,8 +238,8 @@ testStorageAndCountForStore st = do
       fileInfoB = fileInfoA {size = 64000}
       fileA = EntityId "file_a__________"
       fileB = EntityId "file_b__________"
-  addFile st fileA fileInfoA testCreatedAt EntityActive `shouldReturn` Right ()
-  addFile st fileB fileInfoB testCreatedAt EntityActive `shouldReturn` Right ()
+  addFile st fileA fileInfoA testCreatedAt Nothing EntityActive `shouldReturn` Right ()
+  addFile st fileB fileInfoB testCreatedAt Nothing EntityActive `shouldReturn` Right ()
   getFileCount st `shouldReturn` 2
   getUsedStorage st `shouldReturn` 0
   setFilePath st fileA "/tmp/file_a" `shouldReturn` Right ()
@@ -248,11 +264,11 @@ testMigrationRoundTrip = do
       sId1 = EntityId "migration_file_1"
       sId2 = EntityId "migration_file_2"
       rId1 = EntityId "migration_rcp_1_"
-  addFile stmStore sId1 fileInfo1 testCreatedAt EntityActive `shouldReturn` Right ()
+  addFile stmStore sId1 fileInfo1 testCreatedAt (Just testExpiresAt) EntityActive `shouldReturn` Right ()
   void $ setFilePath stmStore sId1 "/tmp/file1"
   addRecipient stmStore sId1 (FileRecipient rId1 rcpKey1) `shouldReturn` Right ()
   let testBlockInfo = BlockingInfo {reason = BRSpam, notice = Nothing}
-  addFile stmStore sId2 fileInfo2 testCreatedAt (EntityBlocked testBlockInfo) `shouldReturn` Right ()
+  addFile stmStore sId2 fileInfo2 testCreatedAt Nothing (EntityBlocked testBlockInfo) `shouldReturn` Right ()
   -- 2. Write to StoreLog
   sl <- openWriteStoreLog False storeLogPath
   writeFileStore sl stmStore
@@ -271,9 +287,10 @@ testMigrationRoundTrip = do
   -- Verify file 1
   result1 <- getFile stmStore2 SFSender sId1
   case result1 of
-    Right (FileRec {fileInfo = fi, filePath, fileStatus}, _) -> do
+    Right (FileRec {fileInfo = fi, filePath, expiresAt, fileStatus}, _) -> do
       size fi `shouldBe` 128000
       readTVarIO filePath `shouldReturn` Just "/tmp/file1"
+      expiresAt `shouldBe` Just testExpiresAt
       readTVarIO fileStatus `shouldReturn` EntityActive
     Left e -> expectationFailure $ "getFile sId1 failed: " <> show e
   -- Verify recipient

tests/NamesResolverServer.hs

@@ -47,10 +47,12 @@ withResolverServerDelayed delayMs handler action = do
       let (st, body) = handler (pathInfo req)
       send $ responseLBS st [(hContentType, "application/json")] body
 
+-- | The resolver API is versioned on its own: v2 answers with NameRegistration
+-- JSON, which is the only shape the server asks for.
 resolveResp :: Status -> LB.ByteString -> [Text] -> (Status, LB.ByteString)
 resolveResp st body = \case
   ["health"] -> (ok200, "{}")
-  ("resolve" : _) -> (st, body)
+  ("v2" : "resolve" : _) -> (st, body)
   _ -> (notFound404, "{}")
 
 testNamesConfig :: Int -> NamesConfig

tests/NtfClient.hs

@@ -40,6 +40,7 @@ import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
 import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, defaultNetworkConfig)
 import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.Entitlement (EntitlementProof)
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfResponse)
 import Simplex.Messaging.Notifications.Server (runNtfServerBlocking)
@@ -48,6 +49,7 @@ import Simplex.Messaging.Notifications.Server.Push.APNS
 import Simplex.Messaging.Notifications.Server.Push.APNS.Internal
 import Simplex.Messaging.Notifications.Transport
 import Simplex.Messaging.Protocol
+import Simplex.Messaging.Server.AddressStats (AddressStatsConfig (..))
 import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport
@@ -117,10 +119,13 @@ ntfTestDBCfg2 :: PostgresStoreCfg
 ntfTestDBCfg2 = ntfTestDBCfg {dbOpts = ntfTestStoreDBOpts2, dbStoreLogPath = Just ntfTestStoreLogFile2}
 
 testNtfClient :: Transport c => (THandleNTF c 'TClient -> IO a) -> IO a
-testNtfClient client = do
+testNtfClient = testNtfClientProof (\_ -> pure Nothing)
+
+testNtfClientProof :: Transport c => (SessionId -> IO (Maybe EntitlementProof)) -> (THandleNTF c 'TClient -> IO a) -> IO a
+testNtfClientProof mkEntitlementProof client = do
   Right host <- pure $ chooseTransportHost defaultNetworkConfig testHost
   runTransportClient defaultTransportClientConfig Nothing host ntfTestPort (Just testKeyHash) $ \h ->
-    runExceptT (ntfClientHandshake h testKeyHash supportedClientNTFVRange False Nothing) >>= \case
+    runExceptT (ntfClientHandshake h testKeyHash supportedClientNTFVRange False Nothing mkEntitlementProof) >>= \case
       Right th -> client th
       Left e -> error $ show e
 
@@ -155,6 +160,7 @@ ntfServerCfg =
       serverStatsBackupFile = Nothing,
       prometheusInterval = Nothing,
       prometheusMetricsFile = ntfTestPrometheusMetricsFile,
+      addressStats = Just AddressStatsConfig {period = 1},
       ntfServerVRange = supportedServerNTFVRange,
       transportConfig = mkTransportServerConfig True (Just alpnSupportedNTFHandshakes) False,
       startOptions = defaultStartOptions

tests/NtfServerTests.hs

@@ -39,9 +39,10 @@ import qualified Simplex.Messaging.Agent.Protocol as AP
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Notifications.Protocol
+import qualified Simplex.Messaging.Notifications.Protocol as NP
 import Simplex.Messaging.Notifications.Server.Env (NtfServerConfig (..))
 import Simplex.Messaging.Notifications.Server.Push.APNS
-import Simplex.Messaging.Notifications.Transport (THandleNTF)
+import Simplex.Messaging.Notifications.Transport (THandleNTF, entitlementNTFVersion)
 import Simplex.Messaging.Parsers (parse, parseAll)
 import Simplex.Messaging.Protocol hiding (notification)
 import Simplex.Messaging.Server.Env.STM (AStoreType)
@@ -55,6 +56,8 @@ ntfServerTests ps@(t, _) = do
   describe "Notifications server protocol syntax" $ ntfSyntaxTests t
   describe "Push provider policy" $ do
     it "rejects APNS test provider unless enabled" $ testApnsTestProviderRejected t
+  describe "Entitlement proof" $ do
+    it "responds in the session with entitlement proof" $ testNtfEntitlementProof t
   describe "Notification subscriptions (NKEY)" $ testNotificationSubscription ps createNtfQueueNKEY
   describe "Notification subscriptions (NEW with ntf creds)" $ testNotificationSubscription ps createNtfQueueNEW
   describe "Retried notification subscription" $ testRetriedNtfSubscription ps
@@ -88,6 +91,16 @@ testApnsTestProviderRejected (ATransport (t :: TProxy c 'TServer)) = do
         signSendRecvNtf nh tknKey ("1", NoEntity, TNEW $ NewNtfTkn tkn tknPub dhPub)
       pure ()
 
+testNtfEntitlementProof :: ASrvTransport -> Expectation
+testNtfEntitlementProof (ATransport (t :: TProxy c 'TServer)) = do
+  mkProof <- mkTestEntitlementProof
+  withNtfServer (ATransport t) $
+    testNtfClientProof mkProof $ \(nh :: THandleNTF c 'TClient) -> do
+      let THandle {params = THandleParams {thVersion}} = nh
+      thVersion `shouldSatisfy` (>= entitlementNTFVersion)
+      RespNtf "1" NoEntity NRPong <- sendRecvNtf nh (Nothing, "1", NoEntity, NP.PING)
+      pure ()
+
 pattern RespNtf :: CorrId -> QueueId -> NtfResponse -> Transmission (Either ErrorType NtfResponse)
 pattern RespNtf corrId queueId command <- (corrId, queueId, Right command)
 

tests/RSLVTests.hs

@@ -12,9 +12,9 @@
 module RSLVTests (rslvTests) where
 
 import Control.Monad.Trans.Except (ExceptT, runExceptT)
-import qualified Data.Aeson as J
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy as LB
+import Data.IORef (IORef, readIORef)
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.Text (Text)
 import Data.Text.Encoding (encodeUtf8)
@@ -26,14 +26,18 @@ import SMPClient
 import Simplex.Messaging.Client
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String (strDecode)
-import SMPNamesTests (testNameRecord)
+import SMPNamesTests (availableBody, registeredBody, reservedBody, resolved, testNameRecord, testPricing)
 import Simplex.Messaging.Protocol
   ( BrokerMsg (..),
     Cmd (..),
     Command (..),
     CorrId (..),
     ErrorType (..),
+    NameQuery (..),
+    NameRegistration (..),
+    NameResponse (..),
     NameErrorType (..),
+    NameReservedReason (..),
     SParty (..),
     Transmission,
     TransmissionForAuth (..),
@@ -57,6 +61,11 @@ withResolverServer (st, body) runTest =
   NRS.withResolverServer (NRS.resolveResp st body) $ \port _ ->
     withSmpServerConfigOn (transport @TLS) (withNames port memCfg) testPort (const runTest)
 
+withResolverServerReqs :: (Status, LB.ByteString) -> (IORef [[Text]] -> IO a) -> IO a
+withResolverServerReqs (st, body) runTest =
+  NRS.withResolverServer (NRS.resolveResp st body) $ \port reqs ->
+    withSmpServerConfigOn (transport @TLS) (withNames port memCfg) testPort (const (runTest reqs))
+
 withProxyAndResolver :: (Status, LB.ByteString) -> IO a -> IO a
 withProxyAndResolver (st, body) runTest =
   NRS.withResolverServer (NRS.resolveResp st body) $ \port _ ->
@@ -65,7 +74,7 @@ withProxyAndResolver (st, body) runTest =
 
 sendRslv :: Transport c => THandleSMP c 'TClient -> B.ByteString -> SimplexDomain -> IO (Transmission (Either ErrorType BrokerMsg))
 sendRslv h@THandle {params} corrId d = do
-  let TransmissionForAuth {tToSend} = encodeTransmissionForAuth params (CorrId corrId, NoEntity, Cmd SResolver (RSLV d))
+  let TransmissionForAuth {tToSend} = encodeTransmissionForAuth params (CorrId corrId, NoEntity, Cmd SResolver (RSLV (NQDomain d)))
   [Right ()] <- tPut h (Right (Nothing, tToSend) :| [])
   r :| _ <- tGetClient h
   pure r
@@ -73,23 +82,36 @@ sendRslv h@THandle {params} corrId d = do
 rslvTests :: Spec
 rslvTests = do
   describe "RSLV direct (non-forwarded)" $ do
-    it "resolver replies 404 -> NAME NOT_FOUND (reached, not CMD PROHIBITED)" testRslvBackendNotFound
+    it "resolver without the v2 route (404) -> NAME RESOLVER, not NOT_FOUND" testRslvBackendNotFound
     it "resolver replies 502 -> NAME (RESOLVER ..)" testRslvBackendHttpErr
     it "no names config -> NAME NO_RESOLVER" testRslvDisabled
     it "refuses to send RSLV on a session below namesSMPVersion" testRslvVersion
   describe "RSLV forwarded (PFWD)" $ do
-    it "PFWD-wrapped RSLV reaches resolver via proxy (PCEProtocolError (NAME NOT_FOUND))" testRslvForwarded
+    it "PFWD-wrapped RSLV reaches resolver via proxy (PCEProtocolError (NAME RESOLVER))" testRslvForwarded
     it "PFWD-wrapped RSLV success returns RNAME (record JSON frames over the proxy)" testRslvForwardedSuccess
   describe "RSLV success path (RNAME response)" $ do
     it "returns RNAME with NameRecord" testRslvSuccess
+  describe "RSLV availability (RNAME response)" $ do
+    it "unregistered comes back AVAILABLE" testRslvAvailable
+    it "reserved comes back with the reason" testRslvReserved
+    it "PFWD-wrapped availability reaches the resolver" testRslvForwardedAvailable
+  describe "RSLV below v22" $ do
+    it "still resolves a name to its record" testRslvOldClientRecord
+    it "still answers NAME NOT_FOUND for a name that does not resolve" testRslvOldClientNotFound
+  describe "hashed lookups" $ do
+    it "RSLV sends the 2LD as its hash" testRslvSendsTheHash
+    it "a name with subnames is sent as text" testSubnameKeepsItsLabels
+    it "a record naming a different name is rejected" testRslvWrongName
 
+-- | /v2/resolve answers 200, 400 or 502, so a 404 is a resolver that predates
+-- the route, not a name that does not exist.
 testRslvBackendNotFound :: IO ()
 testRslvBackendNotFound =
   withResolverServer (status404, "{}") $
     testSMPClient @TLS $ \h -> do
       (corrId, _entId, resp) <- sendRslv h "rs01" (domain "ghost.simplex")
       corrId `shouldBe` CorrId "rs01"
-      resp `shouldBe` Right (ERR (NAME NOT_FOUND))
+      resp `shouldBe` Right (ERR (NAME (RESOLVER "HTTP 404")))
 
 testRslvBackendHttpErr :: IO ()
 testRslvBackendHttpErr =
@@ -107,7 +129,7 @@ testRslvDisabled =
 
 testRslvVersion :: IO ()
 testRslvVersion =
-  withResolverServer (status200, J.encode testNameRecord) $ do
+  withResolverServer (status200, registeredBody testNameRecord) $ do
     g <- C.newRandom
     ts <- getCurrentTime
     let srv = SMPServer testHost testPort testKeyHash
@@ -119,7 +141,7 @@ testRslvVersion =
       Left (PCETransportError TEVersion) -> pure ()
       _ -> expectationFailure $ "expected Left (PCETransportError TEVersion), got: " <> show r
 
-forwardedResolveAlice :: IO (Either SMPClientError (Either ProxyClientError SMP.NameRecord))
+forwardedResolveAlice :: IO (Either SMPClientError (Either ProxyClientError SMP.NameResponse))
 forwardedResolveAlice = do
   g <- C.newRandom
   ts <- getCurrentTime
@@ -135,25 +157,123 @@ testRslvForwarded :: IO ()
 testRslvForwarded =
   withProxyAndResolver (status404, "{}") $
     forwardedResolveAlice >>= \r -> case r of
-      Left (PCEProtocolError (SMP.NAME SMP.NOT_FOUND)) -> pure ()
-      _ -> expectationFailure $ "expected Left (PCEProtocolError (NAME NOT_FOUND)), got: " <> show r
+      Left (PCEProtocolError (SMP.NAME (SMP.RESOLVER _))) -> pure ()
+      _ -> expectationFailure $ "expected Left (PCEProtocolError (NAME (RESOLVER _))), got: " <> show r
 
 testRslvForwardedSuccess :: IO ()
 testRslvForwardedSuccess =
-  withProxyAndResolver (status200, J.encode testNameRecord) $
+  withProxyAndResolver (status200, registeredBody testNameRecord) $
     forwardedResolveAlice >>= \r -> case r of
-      Right (Right nr) -> nr `shouldBe` testNameRecord
-      _ -> expectationFailure $ "expected Right (Right NameRecord), got: " <> show r
+      Right (Right NameResponse {registration = NRRegistered {nameRecord}}) -> nameRecord `shouldBe` testNameRecord
+      _ -> expectationFailure $ "expected Right (Right NRRegistered), got: " <> show r
 
 testRslvSuccess :: IO ()
 testRslvSuccess =
-  withResolverServer (status200, J.encode testNameRecord) $
+  withResolverServer (status200, registeredBody testNameRecord) $
     testSMPClient @TLS $ \h -> do
       (corrId, _entId, resp) <- sendRslv h "rs07" (domain "alice.simplex")
       corrId `shouldBe` CorrId "rs07"
       case resp of
-        Right (RNAME nr) -> nr `shouldBe` testNameRecord
-        _ -> expectationFailure $ "expected Right (RNAME ..), got: " <> show resp
+        Right (RNAME NameResponse {registration = NRRegistered {nameRecord}}) -> nameRecord `shouldBe` testNameRecord
+        _ -> expectationFailure $ "expected Right (RNAME NRRegistered), got: " <> show resp
+
+testRslvAvailable :: IO ()
+testRslvAvailable =
+  withResolverServer (status200, availableBody) $
+    testSMPClient @TLS $ \h -> do
+      (corrId, _entId, resp) <- sendRslv h "na01" (domain "ghost.simplex")
+      corrId `shouldBe` CorrId "na01"
+      resp `shouldBe` Right (RNAME (resolved (NRAvailable testPricing)))
+
+testRslvReserved :: IO ()
+testRslvReserved =
+  withResolverServer (status200, reservedBody) $
+    testSMPClient @TLS $ \h -> do
+      (_, _, resp) <- sendRslv h "na03" (domain "acme.simplex")
+      resp `shouldBe` Right (RNAME (resolved (NRReserved NRRTrademark)))
+
+-- | A client that predates v22 must see exactly what it saw before: the record
+-- for a name that resolves, and NOT_FOUND for one that does not.
+oldClient :: IO SMPClient
+oldClient = do
+  g <- C.newRandom
+  ts <- getCurrentTime
+  let srv = SMPServer testHost testPort testKeyHash
+      -- the version just below the gate: a lower ceiling would pass even if
+      -- the gate were at 20 or 21
+      oldCfg = defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion serverInfoSMPVersion}
+  pcE <- getProtocolClient g NRMInteractive (1, srv, Nothing) oldCfg [] Nothing ts (\_ -> pure ())
+  either (fail . show) pure pcE
+
+testRslvOldClientRecord :: IO ()
+testRslvOldClientRecord =
+  withResolverServer (status200, registeredBody testNameRecord) $ do
+    pc <- oldClient
+    r <- runExceptT' (directResolveName pc NRMInteractive (domain "alice.simplex"))
+    r `shouldBe` NameResponse Nothing (NRRegistered Nothing Nothing Nothing testNameRecord)
+
+testRslvOldClientNotFound :: IO ()
+testRslvOldClientNotFound =
+  withResolverServer (status200, availableBody) $ do
+    pc <- oldClient
+    r <- runExceptT (directResolveName pc NRMInteractive (domain "alice.simplex"))
+    case r of
+      Left (PCEProtocolError (SMP.NAME SMP.NOT_FOUND)) -> pure ()
+      _ -> expectationFailure $ "expected Left (PCEProtocolError (NAME NOT_FOUND)), got: " <> show r
+
+testRslvForwardedAvailable :: IO ()
+testRslvForwardedAvailable =
+  withProxyAndResolver (status200, availableBody) $
+    forwardedResolveAlice >>= \r -> case r of
+      Right (Right NameResponse {registration = NRAvailable {pricing}}) -> pricing `shouldBe` testPricing
+      _ -> expectationFailure $ "expected Right (Right NRAvailable), got: " <> show r
+
+-- keccak-256("alice"), the registry key
+aliceHash :: Text
+aliceHash = "[9c0257114eb9399a2985f8e75dad7600c5d89fe3824ffa99ec1c3eb8bf3b0501]"
+
+-- | The paths the client asked the resolver for.
+resolvePaths :: IORef [[Text]] -> IO [[Text]]
+resolvePaths reqs = filter isResolve <$> readIORef reqs
+  where
+    isResolve = \case ("v2" : "resolve" : _) -> True; _ -> False
+
+currentClient :: IO SMPClient
+currentClient = do
+  g <- C.newRandom
+  ts <- getCurrentTime
+  let srv = SMPServer testHost testPort testKeyHash
+  pcE <- getProtocolClient g NRMInteractive (1, srv, Nothing) defaultSMPClientConfig [] Nothing ts (\_ -> pure ())
+  either (fail . show) pure pcE
+
+testRslvSendsTheHash :: IO ()
+testRslvSendsTheHash =
+  withResolverServerReqs (status200, registeredBody testNameRecord) $ \reqs -> do
+    pc <- currentClient
+    r <- runExceptT' (directResolveName pc NRMInteractive (domain "alice.simplex"))
+    resolvePaths reqs `shouldReturn` [["v2", "resolve", aliceHash <> ".simplex"]]
+    -- the client never sent the name, and the record still names it
+    case r of
+      NameResponse {registration = NRRegistered {nameRecord}} -> SMP.nrName nameRecord `shouldBe` "alice.simplex"
+      _ -> expectationFailure $ "expected NRRegistered, got: " <> show r
+
+testSubnameKeepsItsLabels :: IO ()
+testSubnameKeepsItsLabels =
+  withResolverServerReqs (status200, availableBody) $ \reqs -> do
+    pc <- currentClient
+    _ <- runExceptT' (directResolveName pc NRMInteractive (domain "x.alice.simplex"))
+    resolvePaths reqs `shouldReturn` [["v2", "resolve", "x.alice.simplex"]]
+
+-- a hashed query does not tell the router the name, so the record's own name is
+-- checked against the one that was asked for
+testRslvWrongName :: IO ()
+testRslvWrongName =
+  withResolverServer (status200, registeredBody testNameRecord {SMP.nrName = "mallory.simplex"}) $ do
+    pc <- currentClient
+    r <- runExceptT (directResolveName pc NRMInteractive (domain "alice.simplex"))
+    case r of
+      Left (PCEUnexpectedResponse _) -> pure ()
+      _ -> expectationFailure $ "expected Left (PCEUnexpectedResponse ..), got: " <> show r
 
 runExceptT' :: Show e => ExceptT e IO a -> IO a
 runExceptT' a = runExceptT a >>= either (fail . show) pure

tests/SMPAgentClient.hs

@@ -64,6 +64,7 @@ initAgentServers =
     { smp = userServers [testSMPServer],
       ntf = [testNtfServer],
       xftp = userServers [testXFTPServer],
+      entitlements = M.empty,
       netCfg = defaultNetworkConfig {tcpTimeout = NetworkTimeout 500000 500000, tcpConnectTimeout = NetworkTimeout 500000 500000},
       useServices = M.empty,
       presetDomains = [],

tests/SMPClient.hs

@@ -18,7 +18,12 @@ module SMPClient where
 import Control.Monad
 import Control.Monad.Except (runExceptT)
 import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
 import Data.List.NonEmpty (NonEmpty)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import Data.Time.Clock (addUTCTime, getCurrentTime, nominalDay)
+import Data.Word (Word16)
 import qualified Data.X509 as X
 import qualified Data.X509.Validation as XV
 import Network.Socket
@@ -28,19 +33,24 @@ import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..))
 import Simplex.Messaging.Client (NetworkConfig (..), NetworkTimeout (..), ProtocolClientConfig (..), chooseTransportHost, defaultNetworkConfig)
 import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClientAgentConfig)
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.BBS (BBSPresHeader (..), BBSPublicKey, bbsKeyGen)
+import Simplex.Messaging.Crypto.Entitlement (Entitlement (..), EntitlementCredential, EntitlementProof, MasterKey (..), generateEntitlementProof, signEntitlement)
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server (runSMPServerBlocking)
+import Simplex.Messaging.Server.AddressStats (AddressStatsConfig (..))
 import Simplex.Messaging.Server.Env.STM
 import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), SMSType (..), SQSType (..))
 import Simplex.Messaging.Server.QueueStore.Postgres.Config (PostgresStoreCfg (..))
 import Simplex.Messaging.Transport
+import Simplex.Messaging.Transport.Buffer (trimCR)
 import Simplex.Messaging.Transport.Client
 import Simplex.Messaging.Transport.Server
 import Simplex.Messaging.Transport.Shared (ChainCertificates (..), chainIdCaCerts)
 import Simplex.Messaging.Util (ifM)
 import Simplex.Messaging.Version
 import Simplex.Messaging.Version.Internal
+import System.IO (Handle, IOMode (..), hClose, hFlush)
 import System.Info (os)
 import Test.Hspec hiding (fit, it)
 import UnliftIO.Concurrent
@@ -84,6 +94,12 @@ ntfTestPort = "6001"
 ntfTestPort2 :: ServiceName
 ntfTestPort2 = "6002"
 
+testControlPort :: ServiceName
+testControlPort = "5226"
+
+testControlPortUserAuth :: BasicAuth
+testControlPortUserAuth = "user_password"
+
 testKeyHash :: C.KeyHash
 testKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
 
@@ -163,8 +179,16 @@ testSMPServiceClient serviceCreds client = do
   Right useHost <- pure $ chooseTransportHost defaultNetworkConfig testHost
   testSMPClient_ useHost testPort supportedClientSMPRelayVRange (Just serviceCreds) client
 
+testSMPClientProof :: Transport c => (SessionId -> IO (Maybe EntitlementProof)) -> (THandleSMP c 'TClient -> IO a) -> IO a
+testSMPClientProof mkEntitlementProof client = do
+  Right useHost <- pure $ chooseTransportHost defaultNetworkConfig testHost
+  testSMPClientProof_ useHost testPort supportedClientSMPRelayVRange Nothing mkEntitlementProof client
+
 testSMPClient_ :: Transport c => TransportHost -> ServiceName -> VersionRangeSMP -> Maybe (TLS.Credential, C.KeyPairEd25519) -> (THandleSMP c 'TClient -> IO a) -> IO a
-testSMPClient_ host port vr serviceCreds_ client = do
+testSMPClient_ host port vr serviceCreds_ = testSMPClientProof_ host port vr serviceCreds_ (\_ -> pure Nothing)
+
+testSMPClientProof_ :: Transport c => TransportHost -> ServiceName -> VersionRangeSMP -> Maybe (TLS.Credential, C.KeyPairEd25519) -> (SessionId -> IO (Maybe EntitlementProof)) -> (THandleSMP c 'TClient -> IO a) -> IO a
+testSMPClientProof_ host port vr serviceCreds_ mkEntitlementProof client = do
   serviceAndKeys_ <- forM serviceCreds_ $ \(serviceCreds@(cc, pk), keys) -> do
     Right serviceSignKey <- pure $ C.x509ToPrivate' pk
     let idCert' = case chainIdCaCerts cc of
@@ -175,12 +199,25 @@ testSMPClient_ host port vr serviceCreds_ client = do
     pure (ServiceCredentials {serviceRole = SRMessaging, serviceCreds, serviceCertHash, serviceSignKey}, keys)
   let tcConfig = defaultTransportClientConfig {clientALPN, clientCredentials = fst <$> serviceCreds_} :: TransportClientConfig
   runTransportClient tcConfig Nothing host port (Just testKeyHash) $ \h ->
-    runExceptT (smpClientHandshake h Nothing testKeyHash vr False serviceAndKeys_) >>= \case
+    runExceptT (smpClientHandshake h Nothing testKeyHash vr False serviceAndKeys_ mkEntitlementProof) >>= \case
       Right th -> client th
       Left e -> error $ show e
   where
     clientALPN = Just alpnSupportedSMPHandshakes
 
+mkTestEntitlement :: IO (Map Word16 BBSPublicKey, EntitlementCredential)
+mkTestEntitlement = do
+  Right (issuerKey, issuerSecret) <- bbsKeyGen
+  expiresAt <- addUTCTime (30 * nominalDay) <$> getCurrentTime
+  let entitlement = Entitlement {entitlementName = "supporter", expiresAt, extraInfo = ""}
+  Right credential <- signEntitlement issuerSecret 1 (MasterKey "0123456789abcdef0123456789abcdef") entitlement
+  pure (M.singleton 1 issuerKey, credential)
+
+mkTestEntitlementProof :: IO (SessionId -> IO (Maybe EntitlementProof))
+mkTestEntitlementProof = do
+  (keys, credential) <- mkTestEntitlement
+  pure $ \sessId -> either error Just <$> generateEntitlementProof keys credential (BBSPresHeader sessId)
+
 runSMPClient :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO a) -> IO a
 runSMPClient _ test' = testSMPClient test'
 
@@ -199,7 +236,7 @@ testNtfServiceClient _ keys client = do
             clientALPN = Just alpnSupportedSMPHandshakes
           }
   runTransportClient tcConfig Nothing "localhost" testPort (Just testKeyHash) $ \h ->
-    runExceptT (smpClientHandshake h Nothing testKeyHash supportedClientSMPRelayVRange False $ Just (service, keys)) >>= \case
+    runExceptT (smpClientHandshake h Nothing testKeyHash supportedClientSMPRelayVRange False (Just (service, keys)) (\_ -> pure Nothing)) >>= \case
       Right th -> client th
       Left e -> error $ show e
 
@@ -261,6 +298,7 @@ cfgMS msType = withStoreCfg (testServerStoreConfig msType) $ \serverStoreCfg ->
       serverStatsBackupFile = Nothing,
       prometheusInterval = Nothing,
       prometheusMetricsFile = testPrometheusMetricsFile,
+      addressStats = Just AddressStatsConfig {period = 1},
       pendingENDInterval = 500000,
       ntfDeliveryInterval = 200000,
       smpCredentials =
@@ -396,6 +434,22 @@ withStallingServerOn port action =
     (pure ())
     (const action)
 
+withControlPort :: (Handle -> IO a) -> IO a
+withControlPort action = do
+  addr : _ <- getAddrInfo (Just defaultHints {addrSocketType = Stream}) (Just "127.0.0.1") (Just testControlPort)
+  E.bracket (connectHandle addr) hClose $ \h -> replicateM_ 2 (B.hGetLine h) >> action h
+  where
+    connectHandle addr = do
+      sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
+      connect sock $ addrAddress addr
+      socketToHandle sock ReadWriteMode
+
+controlPortCommand :: Handle -> ByteString -> Int -> IO [ByteString]
+controlPortCommand h cmd n = do
+  B.hPutStrLn h cmd
+  hFlush h
+  replicateM n $ trimCR <$> B.hGetLine h
+
 withSmpServerOn :: HasCallStack => (ASrvTransport, AStoreType) -> ServiceName -> IO a -> IO a
 withSmpServerOn ps port' = withSmpServerThreadOn ps port' . const
 

tests/SMPNamesTests.hs

@@ -3,7 +3,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
-module SMPNamesTests (smpNamesTests, testNameRecord) where
+module SMPNamesTests (smpNamesTests, testNameRecord, testPricing, registeredBody, availableBody, reservedBody, responseBody, resolved) where
 
 import qualified Data.Aeson as J
 import qualified Data.ByteString.Char8 as B
@@ -11,13 +11,14 @@ import qualified Data.ByteString.Lazy as LB
 import Data.Either (isLeft, isRight)
 import Data.IORef (readIORef)
 import Data.List (sort)
+import qualified Data.Map.Strict as M
 import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
 import Network.HTTP.Types (status200, status400, status404, status500, status502)
 import NamesResolverServer (resolveResp, testNamesConfig, withResolverServer, withResolverServerDelayed)
 import Simplex.Messaging.Encoding (smpDecode, smpEncode)
 import Simplex.Messaging.Encoding.String (strDecode)
-import Simplex.Messaging.Protocol (ErrorType (..), NameErrorType (..), NameRecord (..))
+import Simplex.Messaging.Protocol (Command (..), ErrorType (..), NameErrorType (..), NamePricing (..), NameQuery (..), NameRecord (..), NameRegistration (..), NameResponse (..), NameReservedReason (..), ProtocolEncoding (..), USDCents (..))
 import Simplex.Messaging.Server.Main (validateUrl)
 import Simplex.Messaging.Server.Names
   ( NamesConfig (..),
@@ -27,7 +28,9 @@ import Simplex.Messaging.Server.Names
     resolveName,
   )
 import Simplex.Messaging.Server.Names.HttpResolver (ResolverError (..))
-import Simplex.Messaging.SimplexName (SimplexDomain (..), SimplexTLD (..))
+import Simplex.Messaging.SimplexName (SimplexDomain (..), SimplexTLD (..), labelHash)
+import Simplex.Messaging.SystemTime (RoundedSystemTime (..))
+import Simplex.Messaging.Transport (nameAvailSMPVersion, serverInfoSMPVersion)
 import Test.Hspec
 
 testNameRecord :: NameRecord
@@ -47,12 +50,41 @@ testNameRecord =
       nrResolver = "0x0202020202020202020202020202020202020202"
     }
 
+-- | What the resolver serves on /v2/resolve. Spelled out rather than encoded
+-- from the Haskell value: the literal JSON is the contract with the resolver.
+registeredBody :: NameRecord -> LB.ByteString
+registeredBody nameRec =
+  responseBody $ "{\"type\":\"registered\",\"expires\":1813853483,\"graceUntil\":1821629483,\"reservedReason_\":null,\"nameRecord\":" <> J.encode nameRec <> "}"
+
+availableBody :: LB.ByteString
+availableBody = responseBody "{\"type\":\"available\",\"pricing\":{\"registrationPrices\":{\"3\":12793,\"4\":3198},\"basePrice\":100,\"minLabelLength\":3}}"
+
+reservedBody :: LB.ByteString
+reservedBody = responseBody "{\"type\":\"reserved\",\"reservedReason\":\"trademark\"}"
+
+-- | The registration, and the block the resolver read it at.
+responseBody :: LB.ByteString -> LB.ByteString
+responseBody reg = "{\"lastBlockTs\":" <> testReadAt <> ",\"registration\":" <> reg <> "}"
+
+testReadAt :: LB.ByteString
+testReadAt = "1813000000"
+
+resolved :: NameRegistration -> NameResponse
+resolved registration = NameResponse {lastBlockTs = Just (RoundedSystemTime 1813000000), registration}
+
+-- | What `registeredBody testNameRecord` resolves to.
+registeredAlice :: NameRegistration
+registeredAlice =
+  NRRegistered {expires = Just (RoundedSystemTime 1813853483), graceUntil = Just (RoundedSystemTime 1821629483), reservedReason_ = Nothing, nameRecord = testNameRecord}
+
 smpNamesTests :: Spec
 smpNamesTests = do
   describe "NameRecord JSON (Protocol)" nameRecordEncodingSpec
   describe "ErrorType NAME wire encoding" errorWireSpec
+  describe "RSLV wire encoding" rslvWireSpec
   describe "Name parsing (SimplexDomain)" parseNameSpec
   describe "HTTP resolver" resolverSpec
+  describe "name availability" availabilitySpec
   describe "Resolver health probe" healthSpec
   describe "resolver_endpoint validation" validateUrlSpec
 
@@ -101,8 +133,87 @@ errorWireSpec =
     -- RESOLVER detail may contain spaces - must survive the round-trip
     smpDecode (smpEncode (NAME (RESOLVER "HTTP 502"))) `shouldBe` Right (NAME (RESOLVER "HTTP 502"))
 
+-- the query format changed at v22, so an older session must still get the name
+rslvWireSpec :: Spec
+rslvWireSpec = do
+  it "below v22 carries the name, as it did before" $
+    encodeProtocol v20 (RSLV (NQDomain aliceDomain')) `shouldBe` "RSLV " <> smpEncode aliceDomain'
+  -- keccak-256("alice"), the same constant the resolver's own tests use
+  it "from v22 carries the 2LD as its hash" $
+    encodeProtocol v22 (RSLV (NQDomain aliceDomain'))
+      `shouldBe` "RSLV [9c0257114eb9399a2985f8e75dad7600c5d89fe3824ffa99ec1c3eb8bf3b0501].simplex"
+  -- the hashed query has no room for subname labels, so such a name goes as text
+  it "a name with subnames is not hashed" $
+    encodeProtocol v22 (RSLV (NQDomain aliceDomain' {subDomain = ["x"]})) `shouldBe` "RSLV x.alice.simplex"
+  it "leaves a web name alone: no registry, nothing to key on" $
+    encodeProtocol v22 (RSLV (NQDomain webDomain')) `shouldBe` "RSLV example.com"
+  where
+    v20 = serverInfoSMPVersion
+    v22 = nameAvailSMPVersion
+    aliceDomain' = SimplexDomain {nameTLD = TLDSimplex, domain = "alice", subDomain = []}
+    webDomain' = SimplexDomain {nameTLD = TLDWeb, domain = "example.com", subDomain = []}
+
+availabilitySpec :: Spec
+availabilitySpec = do
+  -- one lookup answers what the name points to, whether it can be taken, and
+  -- whether it is held back
+  it "a registered name answers with its record and dates" $
+    answers (registeredBody testNameRecord) (resolved registeredAlice)
+  it "a registered name can be held back too" $
+    answers heldBackBody . resolved $
+      NRRegistered {expires = Just (RoundedSystemTime 1813853483), graceUntil = Just (RoundedSystemTime 1821629483), reservedReason_ = Just NRRInternal, nameRecord = testNameRecord}
+  it "an unregistered name answers with the price" $
+    answers availableBody (resolved NRAvailable {pricing = testPricing})
+  it "reserved carries the reason and no price" $
+    answers reservedBody (resolved $ NRReserved NRRTrademark)
+  -- losing the reservation would offer a name that cannot be registered
+  it "a reason from a later version still reserves the name" $
+    answers (responseBody "{\"type\":\"reserved\",\"reservedReason\":\"seasonal\"}") (resolved $ NRReserved (NRRUnknown "seasonal"))
+  -- RNAME carries the registration as JSON, so that is the encoding to hold
+  it "every registration survives the wire" $
+    mapM_
+      (\a -> J.eitherDecodeStrict (LB.toStrict (J.encode a)) `shouldBe` Right a)
+      [ registeredAlice,
+        NRRegistered {expires = Nothing, graceUntil = Nothing, reservedReason_ = Just NRRInternal, nameRecord = testNameRecord},
+        NRAvailable {pricing = testPricing},
+        NRReserved NRRInternal,
+        NRReserved NRRTrademark,
+        NRReserved NRRCommunity,
+        NRReserved (NRRUnknown "seasonal")
+      ]
+  -- one vocabulary: the same word from the resolver and in JSON
+  it "a reason reads the same in JSON as from the resolver" $ do
+    J.encode (NRRUnknown "seasonal") `shouldBe` "\"seasonal\""
+    J.encode NRRTrademark `shouldBe` "\"trademark\""
+  where
+    heldBackBody =
+      responseBody $ "{\"type\":\"registered\",\"expires\":1813853483,\"graceUntil\":1821629483,\"reservedReason_\":\"internal\",\"nameRecord\":" <> J.encode testNameRecord <> "}"
+    answers body a =
+      withResolverServer (resolveResp status200 body) $ \port _ -> do
+        env <- newNamesEnv (testNamesConfig port)
+        resolveName env aliceQuery `shouldReturn` Right a
+    aliceQuery = NQDomain SimplexDomain {nameTLD = TLDSimplex, domain = "alice", subDomain = []}
+
+-- | The .testing oracle: US cents per year by label length.
+testPricing :: NamePricing
+testPricing =
+  NamePricing
+    { registrationPrices = M.fromList [(3, USDCents 12793), (4, USDCents 3198)],
+      basePrice = USDCents 100,
+      minLabelLength = 3
+    }
+
 parseNameSpec :: Spec
 parseNameSpec = do
+  -- the hashed form is a query, not a name: it has its own type
+  it "a name is never a hash" $
+    parseN ("[" <> T.replicate 64 "b" <> "].simplex") `shouldSatisfy` isLeft
+  it "a query survives the wire" $
+    mapM_
+      (\q -> smpDecode (smpEncode q) `shouldBe` Right q)
+      [ NQDomain d,
+        NQHash (labelHash "alice") TLDSimplex
+      ]
   it "accepts a valid simplex-TLD name" $
     case parseN "privacy.simplex" of
       Right d -> do
@@ -138,23 +249,26 @@ parseNameSpec = do
   where
     parseN :: T.Text -> Either String SimplexDomain
     parseN = strDecode . encodeUtf8
+    d = SimplexDomain {nameTLD = TLDSimplex, domain = "alice", subDomain = ["x"]}
 
 resolverSpec :: Spec
 resolverSpec = do
-  it "returns NameRecord on 200 OK" $
-    withResolverServer (resolveResp status200 (J.encode testNameRecord)) $ \port _ -> do
+  it "returns the registration on 200 OK" $
+    withResolverServer (resolveResp status200 (registeredBody testNameRecord)) $ \port _ -> do
       env <- newNamesEnv (testNamesConfig port)
-      resolveName env aliceDomain `shouldReturn` Right testNameRecord
+      resolveName env aliceDomain `shouldReturn` Right (resolved registeredAlice)
 
-  it "returns NOT_FOUND on 404" $
+  -- /v2/resolve answers 200, 400 or 502 and never says "no such name": an
+  -- unregistered name is NRAvailable. So no status maps to NOT_FOUND.
+  it "returns RESOLVER on 404 (a resolver without the v2 route)" $
     withResolverServer (resolveResp status404 "{}") $ \port _ -> do
       env <- newNamesEnv (testNamesConfig port)
-      resolveName env aliceDomain `shouldReturn` Left NOT_FOUND
+      resolveName env aliceDomain `shouldReturn` Left (RESOLVER "HTTP 404")
 
-  it "returns NOT_FOUND on 400 (unknown TLD)" $
+  it "returns RESOLVER on 400 (TLD not configured)" $
     withResolverServer (resolveResp status400 "{}") $ \port _ -> do
       env <- newNamesEnv (testNamesConfig port)
-      resolveName env aliceDomain `shouldReturn` Left NOT_FOUND
+      resolveName env aliceDomain `shouldReturn` Left (RESOLVER "HTTP 400")
 
   it "returns RESOLVER on 502 (upstream failure)" $
     withResolverServer (resolveResp status502 "{}") $ \port _ -> do
@@ -171,31 +285,31 @@ resolverSpec = do
       env <- newNamesEnv (testNamesConfig port)
       resolveName env aliceDomain `shouldReturn` Left (RESOLVER "invalid response")
 
-  it "returns RESOLVER when JSON parses but isn't a NameRecord shape" $
+  it "returns RESOLVER when JSON parses but isn't a NameRegistration shape" $
     withResolverServer (resolveResp status200 "{}") $ \port _ -> do
       env <- newNamesEnv (testNamesConfig port)
       resolveName env aliceDomain `shouldReturn` Left (RESOLVER "invalid response")
 
   it "returns RESOLVER (timeout) when the resolver is slower than resolverTimeoutMs" $
-    withResolverServerDelayed 1500 (resolveResp status200 (J.encode testNameRecord)) $ \port _ -> do
+    withResolverServerDelayed 1500 (resolveResp status200 (registeredBody testNameRecord)) $ \port _ -> do
       env <- newNamesEnv (testNamesConfig port) {resolverTimeoutMs = 300}
       resolveName env aliceDomain `shouldReturn` Left (RESOLVER "timeout")
 
   it "sends one HTTP request per lookup (no cache)" $
-    withResolverServer (resolveResp status200 (J.encode testNameRecord)) $ \port reqs -> do
+    withResolverServer (resolveResp status200 (registeredBody testNameRecord)) $ \port reqs -> do
       env <- newNamesEnv (testNamesConfig port)
       _ <- resolveName env aliceDomain
       _ <- resolveName env aliceDomain
       readIORef reqs >>= \rs -> length rs `shouldBe` 2
 
   it "addresses the resolver with the full canonical domain name" $
-    withResolverServer (resolveResp status200 (J.encode testNameRecord)) $ \port reqs -> do
+    withResolverServer (resolveResp status200 (registeredBody testNameRecord)) $ \port reqs -> do
       env <- newNamesEnv (testNamesConfig port)
       _ <- resolveName env aliceDomain
-      readIORef reqs `shouldReturn` [["resolve", "alice.simplex"]]
+      readIORef reqs `shouldReturn` [["v2", "resolve", "alice.simplex"]]
 
   where
-    aliceDomain = SimplexDomain {nameTLD = TLDSimplex, domain = "alice", subDomain = []}
+    aliceDomain = NQDomain SimplexDomain {nameTLD = TLDSimplex, domain = "alice", subDomain = []}
 
 healthSpec :: Spec
 healthSpec = do

tests/SMPProxyTests.hs

@@ -33,11 +33,13 @@ import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers
 import Simplex.Messaging.Agent.Protocol hiding (CON, CONF, INFO, REQ)
 import qualified Simplex.Messaging.Agent.Protocol as A
 import Simplex.Messaging.Client
+import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..))
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.Ratchet (pattern PQSupportOn)
 import qualified Simplex.Messaging.Crypto.Ratchet as CR
 import Simplex.Messaging.Protocol (EncRcvMsgBody (..), MsgBody, QueueReqData (..), RcvMessage (..), SubscriptionMode (..), maxMessageLength, noMsgFlags)
 import qualified Simplex.Messaging.Protocol as SMP
+import Simplex.Messaging.Server.AddressStats (AddressStatsConfig (..), defaultAddressStatsPeriod)
 import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..))
 import Simplex.Messaging.Server.MsgStore.Types (SQSType (..))
 import Simplex.Messaging.Transport
@@ -149,7 +151,29 @@ smpProxyTests = do
       xdescribe "stress test 10k" $ do
         let deliver nAgents nMsgs = agentDeliverMessagesViaProxyConc (replicate nAgents [srv1]) (map bshow [1 :: Int .. nMsgs])
         it "25 agents, 300 pairs, 17 messages" . oneServer . withNumCapabilities 4 $ deliver 25 17
+  describe "client address statistics" $ do
+    it "should count proxy commands to other servers" $
+      proxyAddressStats [] [("PRXY", "2"), ("PRXY_new", "1"), ("PRXY_connected", "1"), ("PFWD", "3"), ("PFWD_other", "2"), ("PFWD_failed", "1")]
+    it "should count proxy commands to own servers" $
+      proxyAddressStats ["127.0.0.1"] [("PRXY", "2"), ("PRXY_own", "2"), ("PFWD", "3"), ("PFWD_own", "2"), ("PFWD_failed", "1")]
   where
+    proxyAddressStats :: [ByteString] -> [(ByteString, ByteString)] -> AStoreType -> IO ()
+    proxyAddressStats ownDomains counts msType =
+      twoServers_ proxyCfg' (cfgMS msType) testProxyCounts msType
+      where
+        proxyCfg' = updateCfg (proxyCfgMS msType) $ \cfg_ ->
+          cfg_
+            { addressStats = Just AddressStatsConfig {period = defaultAddressStatsPeriod},
+              controlPort = Just testControlPort,
+              controlPortUserAuth = Just testControlPortUserAuth,
+              smpAgentCfg = (smpAgentCfg cfg_) {ownServerDomains = ownDomains}
+            }
+        testProxyCounts = do
+          deliverMessageViaProxy (SMPServer testHost2 testPort testKeyHash) (SMPServer testHost2 testPort2 testKeyHash) C.SEd448 "hello 1" "hello 2"
+          withControlPort $ \h -> do
+            controlPortCommand h ("auth " <> SMP.unBasicAuth testControlPortUserAuth) 1 `shouldReturn` ["Current role is CPRUser"]
+            forM_ counts $ \(counter, n) ->
+              controlPortCommand h ("addresses " <> counter) 2 `shouldReturn` ["address,previous,current", "127.0.0.1,0," <> n]
     oneServer test msType = withSmpServerConfigOn (transport @TLS) (updateCfg (proxyCfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 128, maxJournalMsgCount = 256}) testPort $ const test
     twoServers test msType = twoServers_ (proxyCfgMS msType) (proxyCfgMS msType) test msType
     twoServersFirstProxy test msType = twoServers_ (proxyCfgMS msType) (updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 128, maxJournalMsgCount = 256}) test msType
@@ -229,7 +253,7 @@ agentDeliverMessageViaProxy aTestCfg@(aSrvs, _, aViaProxy) bTestCfg@(bSrvs, _, b
   withAgent 1 aCfg (servers aTestCfg) testDB $ \alice ->
     withAgent 2 aCfg (servers bTestCfg) testDB2 $ \bob -> runRight_ $ do
       (bobId, CCLink qInfo Nothing) <- A.createConnection alice NRMInteractive 1 True True SCMInvitation Nothing Nothing CR.IKPQOn False SMSubscribe
-      aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
+      (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` True
       ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice
@@ -285,7 +309,7 @@ agentDeliverMessagesViaProxyConc agentServers msgs =
     -- otherwise the CONF messages would get mixed with MSG
     prePair alice bob = do
       (bobId, CCLink qInfo Nothing) <- runExceptT' $ A.createConnection alice NRMInteractive 1 True True SCMInvitation Nothing Nothing CR.IKPQOn False SMSubscribe
-      aliceId <- runExceptT' $ A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
+      (aliceId, _) <- runExceptT' $ A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
       sqSecured <- runExceptT' $ A.joinConnection bob NRMInteractive 1 aliceId True qInfo "bob's connInfo" PQSupportOn SMSubscribe
       liftIO $ sqSecured `shouldBe` True
       confId <-
@@ -344,7 +368,7 @@ agentViaProxyRetryOffline = do
       withServer $ \_ -> do
         (aliceId, bobId) <- withServer2 $ \_ -> runRight $ do
           (bobId, CCLink qInfo Nothing) <- A.createConnection alice NRMInteractive 1 True True SCMInvitation Nothing Nothing CR.IKPQOn False SMSubscribe
-          aliceId <- A.prepareConnectionToJoin bob 1 True qInfo PQSupportOn
+          (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` True
           ("", _, A.CONF confId pqSup' _ "bob's connInfo") <- get alice

tests/ServerTests.hs

@@ -47,6 +47,7 @@ import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (parseAll, parseString)
 import Simplex.Messaging.Protocol
 import Simplex.Messaging.Server (exportMessages)
+import Simplex.Messaging.Server.AddressStats (AddressStatsConfig (..), defaultAddressStatsPeriod)
 import Simplex.Messaging.Server.Env.STM (AStoreType (..), MsgStore (..), ServerConfig (..), ServerStoreCfg (..), readWriteQueueStore)
 import Simplex.Messaging.Server.Expiration
 import Simplex.Messaging.Server.MsgStore.Journal (JournalStoreConfig (..), QStoreCfg (..), stmQueueStore)
@@ -81,6 +82,7 @@ serverTests = do
     describe "NEW, OFF and DEL commands, SEND messages" testCreateDelete
     describe "Stress test" stressTest
     describe "allowNewQueues setting" testAllowNewQueues
+    describe "entitlement proof in handshake" testEntitlementProofHandshake
   describe "SMP messages" $ do
     describe "duplex communication over 2 SMP connections" testDuplex
     describe "switch subscription to another TCP connection" testSwitchSub
@@ -96,6 +98,7 @@ serverTests = do
   describe "Restore messages" testRestoreMessages
   describe "Restore messages (old / v2)" testRestoreExpireMessages
   describe "Save prometheus metrics" testPrometheusMetrics
+  describe "Client address statistics" testAddressStatsControlPort
   describe "Timing of AUTH error" testTiming
   describe "Message notifications" $ do
     testMessageNotifications
@@ -464,6 +467,19 @@ testAllowNewQueues =
         Resp "abcd" NoEntity (ERR AUTH) <- signSendRecv h rKey ("abcd", NoEntity, New rPub dhPub)
         pure ()
 
+testEntitlementProofHandshake :: SpecWith (ASrvTransport, AStoreType)
+testEntitlementProofHandshake =
+  it "should create queue in the session with entitlement proof" $ \(ATransport (t :: TProxy c 'TServer), msType) -> do
+    mkProof <- mkTestEntitlementProof
+    withSmpServerConfigOn (ATransport t) (cfgMS msType) testPort $ \_ ->
+      testSMPClientProof @c mkProof $ \h@THandle {params = THandleParams {thVersion}} -> do
+        thVersion `shouldSatisfy` (>= entitlementSMPVersion)
+        g <- C.newRandom
+        (rPub, rKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
+        (dhPub, _ :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
+        Resp "abcd" NoEntity (Ids _ _ _) <- signSendRecv h rKey ("abcd", NoEntity, New rPub dhPub)
+        pure ()
+
 testDuplex :: SpecWith (ASrvTransport, AStoreType)
 testDuplex =
   it "should create 2 simplex connections and exchange messages" $ \(ATransport t, msType) ->
@@ -1254,6 +1270,27 @@ testPrometheusMetrics =
     let cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {prometheusInterval = Just 1}
     withSmpServerConfigOn at cfg' testPort $ \_ -> threadDelay 1000000
     doesFileExist testPrometheusMetricsFile `shouldReturn` True
+    metrics <- B.readFile testPrometheusMetricsFile
+    metrics `shouldSatisfy` ("# TYPE simplex_smp_client_address_period_count histogram" `B.isInfixOf`)
+
+testAddressStatsControlPort :: SpecWith (ASrvTransport, AStoreType)
+testAddressStatsControlPort =
+  it "should list client addresses by counter via control port" $ \(at@(ATransport (_ :: TProxy c 'TServer)), msType) -> do
+    let cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {addressStats = Just AddressStatsConfig {period = defaultAddressStatsPeriod}, controlPort = Just testControlPort, controlPortUserAuth = Just testControlPortUserAuth}
+        ipv4Client = testSMPClient_ @c "127.0.0.1" testPort supportedClientSMPRelayVRange Nothing
+    withSmpServerConfigOn at cfg' testPort $ \_ ->
+      ipv4Client $ \r -> ipv4Client $ \s -> do
+        g <- C.newRandom
+        (sPub, sKey) <- atomically $ C.generateAuthKeyPair C.SEd448 g
+        (sId, _, _, _) <- createAndSecureQueue r sPub
+        Resp "bcda" _ OK <- signSendRecv s sKey ("bcda", sId, _SEND "hello")
+        Resp "cdab" _ OK <- signSendRecv s sKey ("cdab", sId, _SEND "hello again")
+        withControlPort $ \h -> do
+          controlPortCommand h "addresses SEND" 1 `shouldReturn` ["AUTH"]
+          controlPortCommand h ("auth " <> unBasicAuth testControlPortUserAuth) 1 `shouldReturn` ["Current role is CPRUser"]
+          controlPortCommand h "addresses unknown" 1 `shouldReturn` ["error: unknown counter"]
+          controlPortCommand h "addresses SEND" 2 `shouldReturn` ["address,previous,current", "127.0.0.1,0,2"]
+          controlPortCommand h "addresses connections" 2 `shouldReturn` ["address,previous,current", "127.0.0.1,0,2"]
 
 createAndSecureQueue :: Transport c => THandleSMP c 'TClient -> SndPublicAuthKey -> IO (SenderId, RecipientId, RcvPrivateAuthKey, RcvDhSecret)
 createAndSecureQueue h sPub = do

tests/Test.hs

@@ -7,6 +7,7 @@ import CLITests
 import Control.Concurrent (threadDelay)
 import qualified Control.Exception as E
 import Control.Logger.Simple
+import CoreTests.AddressStatsTests
 import CoreTests.BatchingTests
 import CoreTests.CryptoFileTests
 import CoreTests.CryptoTests
@@ -83,6 +84,7 @@ main = do
       . after_ (eventuallyRemove "tests/tmp" 3)
       $ do
         describe "Core tests" $ do
+          describe "Address statistics tests" addressStatsTests
           describe "Batching tests" batchingTests
           describe "Encoding tests" encodingTests
           describe "Version range" versionRangeTests
@@ -97,6 +99,8 @@ main = do
 #else
           describe "Store log tests" storeLogTests
 #endif
+          describe "XFTP store log tests" fileStoreLogTests
+          fileExpirationTests
           describe "TSessionSubs tests" tSessionSubsTests
           describe "Util tests" utilTests
           describe "Names resolver tests" smpNamesTests