mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-10-12 11:39:56 +00:00
Compare commits
5
Commits
| Author | SHA1 | Date | |
|---|---|---|---|
 Alain Brenzikofer
|
aaed545fed | ||
|
sh
|
ad4077bf14 | ||
|
Alain Brenzikofer
|
e670d9fa37 | ||
|
Alain Brenzikofer
|
bd4b07ab79 | ||
|
Alain Brenzikofer
|
a8cee354eb |
@@ -9,10 +9,6 @@ on:
|
||||
- "v*"
|
||||
pull_request:
|
||||
|
||||
concurrency:
|
||||
group: ${{ github.workflow }}-${{ github.ref }}
|
||||
cancel-in-progress: ${{ !startsWith(github.ref, 'refs/tags/v') }}
|
||||
|
||||
jobs:
|
||||
|
||||
# =============================
|
||||
|
||||
@@ -12,4 +12,3 @@ cabal.project.local~
|
||||
*.tix
|
||||
.coverage
|
||||
|
||||
__pycache__/
|
||||
|
||||
@@ -1,200 +0,0 @@
|
||||
# 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`.
|
||||
@@ -1,309 +0,0 @@
|
||||
# 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.
|
||||
+43
-123
@@ -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 22. Versions 1-5 are discontinued. The version history:
|
||||
This document describes SMP protocol version 20. Versions 1-5 are discontinued. The version history:
|
||||
|
||||
- v1: binary protocol encoding
|
||||
- v2: message flags (used to control notifications)
|
||||
@@ -108,7 +108,6 @@ This document describes SMP protocol version 22. 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
|
||||
|
||||
## Introduction
|
||||
|
||||
@@ -1452,150 +1451,53 @@ 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
|
||||
/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>` 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.
|
||||
|
||||
#### Resolve name command
|
||||
|
||||
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:
|
||||
The `RSLV` command carries the canonical fully-qualified name directly as the
|
||||
payload (not JSON):
|
||||
|
||||
```abnf
|
||||
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"
|
||||
rslv = %s"RSLV" SP domain ; domain = canonical name as non-space bytes, consuming the remainder of the transmission
|
||||
```
|
||||
|
||||
`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 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:
|
||||
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:
|
||||
|
||||
| Response | Condition | Client action |
|
||||
|---|---|---|
|
||||
| `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 |
|
||||
| `RNAME` | record resolved | use it |
|
||||
| `ERR NAME NOT_FOUND` | name not registered, unknown TLD, or malformed name | authoritative "no such name" — stop |
|
||||
| `ERR NAME NO_RESOLVER` | this router has no resolver (names role not enabled) | skip this server, try the next |
|
||||
| `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 |
|
||||
| `ERR NAME RESOLVER <detail>` | transient failure: backing resolver error (upstream 5xx, transport, timeout, decode) | transient — retry or surface, do not treat as "not found" |
|
||||
|
||||
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 response
|
||||
#### Name record response
|
||||
|
||||
`RNAME` answers both what a name resolves to and whether it can be registered.
|
||||
The `RNAME` response carries a JSON-encoded record as the payload:
|
||||
|
||||
```abnf
|
||||
rname = %s"RNAME" SP nameResponse
|
||||
rname = %s"RNAME" SP json-bytes ; json-bytes consumes the remainder of the transmission
|
||||
```
|
||||
|
||||
`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:
|
||||
`json-bytes` MUST be a UTF-8 JSON object with the following schema:
|
||||
|
||||
| Field | JSON type | Constraints |
|
||||
|---|---|---|
|
||||
@@ -1612,16 +1514,34 @@ could not date or resolve, and any status word it does not recognise.
|
||||
| `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 |
|
||||
|
||||
Testnet-vs-mainnet status is derived from the queried TLD, not from 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.
|
||||
|
||||
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.
|
||||
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.
|
||||
|
||||
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`.
|
||||
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.
|
||||
|
||||
## Transport connection with the SMP router
|
||||
|
||||
|
||||
+20
-223
@@ -62,26 +62,15 @@ 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": ""},
|
||||
# "blockNumber": 23400000, "chainLagSeconds": 12}
|
||||
# → {"ok": true, "rpc": "http://reth:8545", "registries": {"testing": "0x…", "simplex": ""}}
|
||||
```
|
||||
|
||||
`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).
|
||||
|
||||
@@ -93,7 +82,7 @@ curl -s http://127.0.0.1:8000/v2/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 (`/v2/resolve`, `/resolve`, `/health`) |
|
||||
| **resolver** | `127.0.0.1:8000` | SNRC REST (`/resolve`, `/health`) |
|
||||
|
||||
## Caveats
|
||||
|
||||
@@ -121,57 +110,7 @@ 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
|
||||
```
|
||||
|
||||
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
|
||||
### Response shape
|
||||
|
||||
```jsonc
|
||||
{
|
||||
@@ -180,84 +119,16 @@ alongside its fields.
|
||||
"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…",
|
||||
"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
|
||||
"owner": "0xd83b…", "resolver": "0x80fa…"
|
||||
}
|
||||
```
|
||||
|
||||
`simplexContact`/`simplexChannel` are arrays (a name can advertise multiple SMP
|
||||
servers; clients try them in order). On-chain they're a single `;`-separated
|
||||
servers; clients try them in order). On-chain they're a single comma-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`).
|
||||
|
||||
#### 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 (`status` is `registered` or `grace`, or `unknown` when no registrar is configured) |
|
||||
| 400 | TLD not configured, or not a fully-qualified name |
|
||||
| 404 | `unregistered` |
|
||||
| 410 | `expired`: lapsed and past grace, so anyone may take it |
|
||||
| 502 | upstream RPC error / reth not synced |
|
||||
|
||||
### Querying by labelhash
|
||||
|
||||
A client asking whether a name is free is usually about to register it, and
|
||||
@@ -270,29 +141,8 @@ curl -s "http://127.0.0.1:8000/resolve/[$(printf acme | keccak-256sum | cut -d'
|
||||
```
|
||||
|
||||
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`.
|
||||
returns the same record. The resolver learns the name only by guessing the label
|
||||
and hashing it.
|
||||
|
||||
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
|
||||
@@ -301,76 +151,23 @@ 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.
|
||||
so it points at a node nobody can own.
|
||||
|
||||
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.
|
||||
public, and commit-reveal covers that step.
|
||||
|
||||
### What a name costs
|
||||
### Status codes
|
||||
|
||||
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 |
|
||||
| Status | 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 |
|
||||
| 200 | resolved |
|
||||
| 400 | TLD not configured, or not a fully-qualified name |
|
||||
| 404 | name has no resolver set on the registry |
|
||||
| 502 | upstream RPC error / reth not synced |
|
||||
|
||||
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 registries
|
||||
|
||||
### 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.
|
||||
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.
|
||||
|
||||
@@ -150,12 +150,6 @@ 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
|
||||
|
||||
@@ -39,11 +39,6 @@ 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)
|
||||
|
||||
@@ -67,7 +62,6 @@ 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
|
||||
@@ -91,31 +85,6 @@ 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
|
||||
@@ -124,8 +93,6 @@ 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) ----------
|
||||
|
||||
@@ -172,190 +139,18 @@ def is_encoded_labelhash(label: str) -> bool:
|
||||
|
||||
|
||||
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."""
|
||||
"""namehash, accepting an encoded labelhash in place of a 2LD's label.
|
||||
|
||||
keccak(parent || keccak(label)) reaches the same node without the label,
|
||||
so a caller can check a 2LD without disclosing which one they are about to
|
||||
register. Subnames are excluded - only the 2LD's owner creates them, so
|
||||
there is nothing to front-run - and a bracket label there 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
|
||||
if len(labels) == 2 and is_encoded_labelhash(labels[0]):
|
||||
return keccak(namehash(labels[1]) + bytes.fromhex(labels[0][1:-1]))
|
||||
return namehash(name)
|
||||
|
||||
|
||||
def selector(signature: str) -> str:
|
||||
@@ -363,10 +158,7 @@ def selector(signature: str) -> str:
|
||||
|
||||
|
||||
def eth_call(to: str, data: str) -> str:
|
||||
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
|
||||
return rpc("eth_call", [{"to": to, "data": data}, "latest"])
|
||||
|
||||
|
||||
def decode_address(hex_data: str) -> str:
|
||||
@@ -381,42 +173,6 @@ 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()
|
||||
@@ -664,117 +420,6 @@ 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)
|
||||
@@ -782,60 +427,17 @@ def resolve(name: str):
|
||||
configured = [k for k, v in REGISTRIES.items() if v]
|
||||
return 400, {
|
||||
"name": name,
|
||||
"error": "tldNotConfigured",
|
||||
"message": f"TLD '{tld}' is not configured on this resolver",
|
||||
"configuredTlds": configured,
|
||||
"error": f"TLD '{tld}' is not configured on this resolver",
|
||||
"configured_tlds": configured,
|
||||
}
|
||||
|
||||
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:
|
||||
# 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,
|
||||
}
|
||||
return 404, {"name": name, "error": "no resolver set for this name"}
|
||||
|
||||
owner_raw = eth_call(registry, selector("owner(bytes32)") + node_hex)
|
||||
owner = decode_address(owner_raw)
|
||||
@@ -859,7 +461,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": canonical_name(name) or name,
|
||||
"name": name,
|
||||
"nickname": nickname,
|
||||
"website": texts.get("url", ""),
|
||||
"location": texts.get("location", ""),
|
||||
@@ -871,7 +473,6 @@ def resolve(name: str):
|
||||
"dot": addr_multicoin(resolver_addr, node, COIN_DOT),
|
||||
"owner": owner,
|
||||
"resolver": resolver_addr,
|
||||
**reg,
|
||||
}
|
||||
|
||||
|
||||
@@ -883,51 +484,33 @@ 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, **head_block()})
|
||||
self._respond(
|
||||
200,
|
||||
{"ok": True, "rpc": RPC, "registries": REGISTRIES},
|
||||
)
|
||||
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,
|
||||
{
|
||||
"name": name,
|
||||
"error": "notFullyQualified",
|
||||
"message": "expected a fully-qualified name, e.g. alice.testing",
|
||||
"error": "expected fully-qualified name, e.g. /resolve/alice.testing",
|
||||
"got": name,
|
||||
},
|
||||
)
|
||||
return
|
||||
try:
|
||||
status, body = resolve(name)
|
||||
except Exception as e: # surface upstream errors as 502
|
||||
status, body = 502, upstream_error({"name": name}, e)
|
||||
status, body = 502, {"name": name, "error": f"{type(e).__name__}: {e}"}
|
||||
self._respond(status, body)
|
||||
return
|
||||
|
||||
self._respond(
|
||||
404,
|
||||
{
|
||||
"error": "noSuchRoute",
|
||||
"message": "not found",
|
||||
"routes": ["/health", "/v2/resolve/<query>", "/v1/resolve/<name>", "/resolve/<name>"],
|
||||
},
|
||||
{"error": "not found", "routes": ["/health", "/resolve/<name>"]},
|
||||
)
|
||||
|
||||
def _respond(self, status: int, body: dict):
|
||||
@@ -952,7 +535,7 @@ def main():
|
||||
)
|
||||
for tld, addr in REGISTRIES.items():
|
||||
sys.stderr.write(f" .{tld:<8s} = {addr or '(not configured)'}\n")
|
||||
sys.stderr.write(" GET /v2/resolve/<name> GET /v1/resolve/<name> GET /health\n")
|
||||
sys.stderr.write(" GET /resolve/<name> GET /health\n")
|
||||
try:
|
||||
server.serve_forever()
|
||||
except KeyboardInterrupt:
|
||||
|
||||
@@ -4,11 +4,8 @@
|
||||
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`.
|
||||
@@ -20,12 +17,6 @@ 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
|
||||
@@ -92,21 +83,12 @@ class SplitLinksTests(unittest.TestCase):
|
||||
|
||||
|
||||
class EncodedLabelhashTests(unittest.TestCase):
|
||||
"""`node_of` accepts a 2LD's label as an encoded labelhash `[<64 hex>]`,
|
||||
reaching the same node as the label itself."""
|
||||
|
||||
# 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(
|
||||
@@ -141,9 +123,7 @@ class EncodedLabelhashTests(unittest.TestCase):
|
||||
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."""
|
||||
def test_an_encoded_subname_is_not_the_name_it_would_decode_to(self):
|
||||
self.assertNotEqual(
|
||||
snrc.node_of(
|
||||
"[9c0257114eb9399a2985f8e75dad7600c5d89fe3824ffa99ec1c3eb8bf3b0501]"
|
||||
@@ -151,6 +131,14 @@ class EncodedLabelhashTests(unittest.TestCase):
|
||||
),
|
||||
snrc.namehash("alice.alice.testing"),
|
||||
)
|
||||
self.assertNotEqual(
|
||||
snrc.node_of(
|
||||
"alice."
|
||||
"[9c0257114eb9399a2985f8e75dad7600c5d89fe3824ffa99ec1c3eb8bf3b0501]"
|
||||
".testing"
|
||||
),
|
||||
snrc.namehash("alice.alice.testing"),
|
||||
)
|
||||
|
||||
def test_a_0x_prefixed_label_is_taken_literally(self):
|
||||
name = "0x9c0257114eb9399a2985f8e75dad7600c5d89fe3824ffa99ec1c3eb8bf3b0501.testing"
|
||||
@@ -161,879 +149,6 @@ class EncodedLabelhashTests(unittest.TestCase):
|
||||
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()
|
||||
|
||||
+1
-5
@@ -1,7 +1,7 @@
|
||||
cabal-version: 3.0
|
||||
|
||||
name: simplexmq
|
||||
version: 7.1.0.9
|
||||
version: 7.1.0.5
|
||||
synopsis: SimpleXMQ message broker
|
||||
description: This package includes <./docs/Simplex-Messaging-Server.html server>,
|
||||
<./docs/Simplex-Messaging-Client.html client> and
|
||||
@@ -194,7 +194,6 @@ library
|
||||
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
|
||||
@@ -249,7 +248,6 @@ library
|
||||
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:
|
||||
@@ -271,7 +269,6 @@ 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
|
||||
@@ -543,7 +540,6 @@ test-suite simplexmq-test
|
||||
AgentTests.ServerChoice
|
||||
AgentTests.ShortLinkTests
|
||||
CLITests
|
||||
CoreTests.AddressStatsTests
|
||||
CoreTests.BatchingTests
|
||||
CoreTests.CryptoFileTests
|
||||
CoreTests.CryptoTests
|
||||
|
||||
@@ -17,16 +17,11 @@ module Simplex.FileTransfer.Agent
|
||||
toFSFilePath,
|
||||
-- Receiving files
|
||||
xftpReceiveFile',
|
||||
xftpPrepareReceiveFile',
|
||||
xftpStartReceiveFile',
|
||||
xftpDeleteRcvFile',
|
||||
xftpDeleteRcvFiles',
|
||||
-- Sending files
|
||||
xftpSendFile',
|
||||
xftpSendDescription',
|
||||
xftpPrepareSendFile',
|
||||
xftpPrepareSendDescription',
|
||||
xftpStartSendFile',
|
||||
deleteSndFileInternal,
|
||||
deleteSndFilesInternal,
|
||||
deleteSndFileRemote,
|
||||
@@ -132,12 +127,7 @@ 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 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
|
||||
xftpReceiveFile' c userId (ValidFileDescription fd@FileDescription {chunks, redirect}) cfArgs approvedRelays = do
|
||||
g <- asks random
|
||||
prefixPath <- lift $ getPrefixPath "rcv.xftp"
|
||||
createDirectory prefixPath
|
||||
@@ -147,7 +137,7 @@ xftpPrepareReceiveFile' c userId (ValidFileDescription fd@FileDescription {redir
|
||||
lift $ createDirectory =<< toFSFilePath relTmpPath
|
||||
lift $ createEmptyFile =<< toFSFilePath relSavePath
|
||||
let saveFile = CryptoFile relSavePath cfArgs
|
||||
case redirect of
|
||||
fId <- case redirect of
|
||||
Nothing -> withStore c $ \db -> createRcvFile db g userId fd relPrefixPath relTmpPath saveFile approvedRelays
|
||||
Just _ -> do
|
||||
-- prepare description paths
|
||||
@@ -159,11 +149,8 @@ xftpPrepareReceiveFile' c userId (ValidFileDescription fd@FileDescription {redir
|
||||
let saveFileRedirect = CryptoFile relSavePathRedirect $ Just cfArgsRedirect
|
||||
-- create download tasks
|
||||
withStore c $ \db -> createRcvFileRedirect db g userId fd relPrefixPath relTmpPathRedirect saveFileRedirect relTmpPath saveFile approvedRelays
|
||||
|
||||
xftpStartReceiveFile' :: AgentClient -> RcvFileId -> AM ()
|
||||
xftpStartReceiveFile' c rcvFileEntityId = do
|
||||
srvs <- withStore c (`startPreparedRcvFile` rcvFileEntityId)
|
||||
lift $ forM_ srvs $ void . getXFTPRcvWorker True c . Just
|
||||
forM_ chunks (downloadChunk c)
|
||||
pure fId
|
||||
|
||||
downloadChunk :: AgentClient -> FileChunk -> AM ()
|
||||
downloadChunk c FileChunk {replicas = (FileChunkReplica {server} : _)} = do
|
||||
@@ -366,11 +353,6 @@ notify c entId cmd = atomically $ writeTBQueue (subQ c) ("", entId, AEvt (sAEnti
|
||||
|
||||
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
|
||||
@@ -378,15 +360,12 @@ xftpPrepareSendFile' c userId file numRecipients storageHours = 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
|
||||
withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce Nothing storageHours
|
||||
fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce Nothing storageHours
|
||||
lift . void $ getXFTPSndWorker True c Nothing
|
||||
pure fId
|
||||
|
||||
xftpSendDescription' :: AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Int -> AM SndFileId
|
||||
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
|
||||
xftpSendDescription' c userId (ValidFileDescription fdDirect@FileDescription {size, digest}) numRecipients = do
|
||||
g <- asks random
|
||||
prefixPath <- lift $ getPrefixPath "snd.xftp"
|
||||
createDirectory prefixPath
|
||||
@@ -397,12 +376,9 @@ xftpPrepareSendDescription' c userId (ValidFileDescription fdDirect@FileDescript
|
||||
liftError (FILE . FILE_IO . show) $ CF.writeFile file (LB.fromStrict $ strEncode fdDirect)
|
||||
key <- atomically $ C.randomSbKey g
|
||||
nonce <- atomically $ C.randomCbNonce g
|
||||
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)
|
||||
fId <- withStore c $ \db -> createSndFile db g userId file numRecipients relPrefixPath key nonce (Just RedirectFileInfo {size, digest}) Nothing
|
||||
lift . void $ getXFTPSndWorker True c Nothing
|
||||
pure fId
|
||||
|
||||
resumeXFTPSndWork :: AgentClient -> Maybe XFTPServer -> AM' ()
|
||||
resumeXFTPSndWork = void .: getXFTPSndWorker False
|
||||
|
||||
@@ -441,6 +441,7 @@ 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
|
||||
@@ -449,6 +450,7 @@ 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
|
||||
@@ -477,6 +479,12 @@ 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) <> "%"
|
||||
|
||||
@@ -29,7 +29,6 @@ module Simplex.FileTransfer.Description
|
||||
YAMLFileDescription (..), -- for tests
|
||||
YAMLServerReplicas (..), -- for tests
|
||||
validateFileDescription,
|
||||
sharedDescriptionHash,
|
||||
groupReplicasByServer,
|
||||
fdSeparator,
|
||||
kb,
|
||||
@@ -73,7 +72,6 @@ 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)
|
||||
@@ -229,13 +227,6 @@ 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
|
||||
|
||||
@@ -63,9 +63,8 @@ import Simplex.Messaging.Crypto.Entitlement (Entitlement (..), EntitlementProof
|
||||
import qualified Simplex.Messaging.Crypto.Lazy as LC
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol (BlockingInfo, CommandError (..), EntityId (..), RcvPublicAuthKey, RcvPublicDhKey, RecipientId, SignedTransmission, pattern NoEntity)
|
||||
import Simplex.Messaging.Protocol (BlockingInfo, 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 (..))
|
||||
@@ -102,8 +101,7 @@ data XFTPTransportRequest = XFTPTransportRequest
|
||||
request :: H.Request,
|
||||
sendResponse :: H.Response -> IO (),
|
||||
sniUsed :: SNICredentialUsed,
|
||||
addCORS :: Bool,
|
||||
clientAddrStats :: Maybe (AddrStats XFTPAddrCounter)
|
||||
addCORS :: Bool
|
||||
}
|
||||
|
||||
corsHeaders :: Bool -> [N.Header]
|
||||
@@ -143,7 +141,6 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
|
||||
: expireFiles fileExpiration
|
||||
: serverStatsThread_ cfg
|
||||
<> prometheusMetricsThread_ cfg
|
||||
<> addressStatsThread_ cfg
|
||||
<> controlPortThread_ cfg
|
||||
)
|
||||
`finally` stopServer
|
||||
@@ -157,27 +154,20 @@ 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 withConnection $ \sniUsed sessionId sessionALPN r sendResponse -> do
|
||||
liftIO . runHTTP2Server started xftpPort defaultHTTP2BufferSize srvParams srvCreds httpCreds_ transportConfig inactiveClientExpiration cleanup $ \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', clientAddrStats}
|
||||
req0 = XFTPTransportRequest {thParams = thParams0, request = r, reqBody, sendResponse, sniUsed, addCORS = addCORS'}
|
||||
flip runReaderT env $ case sessionALPN of
|
||||
Nothing -> processRequest req0
|
||||
Just alpn
|
||||
@@ -340,30 +330,24 @@ 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 stats_ rtsOpts
|
||||
sm <- getFileServerMetrics ss rtsOpts
|
||||
T.writeFile metricsFile $ xftpPrometheusMetrics sm ts
|
||||
|
||||
getFileServerMetrics :: FileServerStats -> Maybe (ServerAddrStats XFTPAddrCounter) -> T.Text -> IO FileServerMetrics
|
||||
getFileServerMetrics ss stats_ rtsOptions = do
|
||||
getFileServerMetrics :: FileServerStats -> T.Text -> IO FileServerMetrics
|
||||
getFileServerMetrics ss rtsOptions = do
|
||||
d <- getFileServerStatsData ss
|
||||
let fd = periodStatDataCounts $ _filesDownloaded d
|
||||
addressHistograms <- mapM (readIORef . addrHistograms) stats_
|
||||
pure FileServerMetrics {statsData = d, filesDownloadedPeriods = fd, rtsOptions, addressHistograms}
|
||||
pure FileServerMetrics {statsData = d, filesDownloadedPeriods = fd, rtsOptions}
|
||||
|
||||
controlPortThread_ :: XFTPServerConfig s -> [M s ()]
|
||||
controlPortThread_ XFTPServerConfig {controlPort = Just port} = [runCPServer port]
|
||||
@@ -418,10 +402,7 @@ 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
|
||||
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"
|
||||
CPHelp -> hPutStrLn h "commands: stats-rts, delete, help, quit"
|
||||
CPQuit -> pure ()
|
||||
CPSkip -> pure ()
|
||||
where
|
||||
@@ -440,23 +421,21 @@ data ServerFile = ServerFile
|
||||
}
|
||||
|
||||
processRequest :: FileStoreClass s => XFTPTransportRequest -> M s ()
|
||||
processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHead}, sendResponse, addCORS, clientAddrStats}
|
||||
| B.length bodyHead /= xftpBlockSize = incAddrStats XACErrors >> sendXFTPResponse ("", NoEntity, FRErr BLOCK) Nothing
|
||||
processRequest XFTPTransportRequest {thParams, reqBody = body@HTTP2Body {bodyHead}, sendResponse, addCORS}
|
||||
| B.length bodyHead /= xftpBlockSize = sendXFTPResponse ("", NoEntity, FRErr BLOCK) Nothing
|
||||
| otherwise =
|
||||
case xftpDecodeTServer thParams bodyHead of
|
||||
Right (Right t@(_, _, (corrId, fId, cmd))) -> do
|
||||
incAddrStats $ xftpCmdCounter cmd
|
||||
Right (Right t@(_, _, (corrId, fId, _))) -> do
|
||||
let THandleParams {thAuth} = thParams
|
||||
ent = peerEntitlement =<< thAuth
|
||||
verifyXFTPTransmission thAuth t >>= \case
|
||||
VRVerified req -> uncurry send =<< processXFTPRequest clientAddrStats ent body req
|
||||
VRFailed e -> incAddrStats XACErrors >> send (FRErr e) Nothing
|
||||
VRVerified req -> uncurry send =<< processXFTPRequest ent body req
|
||||
VRFailed e -> send (FRErr e) Nothing
|
||||
where
|
||||
send resp = sendXFTPResponse (corrId, fId, resp)
|
||||
Right (Left (corrId, fId, e)) -> incAddrStats XACErrors >> sendXFTPResponse (corrId, fId, FRErr e) Nothing
|
||||
Left e -> incAddrStats XACErrors >> sendXFTPResponse ("", NoEntity, FRErr e) Nothing
|
||||
Right (Left (corrId, fId, e)) -> sendXFTPResponse (corrId, fId, FRErr e) Nothing
|
||||
Left e -> 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
|
||||
@@ -511,8 +490,8 @@ 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 => Maybe (AddrStats XFTPAddrCounter) -> Maybe SessionEntitlement -> HTTP2Body -> XFTPRequest -> M s (FileResponse, Maybe ServerFile)
|
||||
processXFTPRequest addrStats_ ent HTTP2Body {bodyPart} = \case
|
||||
processXFTPRequest :: forall s. FileStoreClass s => Maybe SessionEntitlement -> HTTP2Body -> XFTPRequest -> M s (FileResponse, Maybe ServerFile)
|
||||
processXFTPRequest ent HTTP2Body {bodyPart} = \case
|
||||
XFTPReqNew file rks auth storageHours -> noFile =<< ifM allowNew (createFile file rks storageHours) (pure $ FRErr AUTH)
|
||||
where
|
||||
allowNew = do
|
||||
@@ -530,10 +509,6 @@ processXFTPRequest addrStats_ ent HTTP2Body {bodyPart} = \case
|
||||
XFTPReqPing -> noFile FRPong
|
||||
where
|
||||
noFile resp = pure (resp, Nothing)
|
||||
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
|
||||
@@ -557,7 +532,6 @@ processXFTPRequest addrStats_ ent HTTP2Body {bodyPart} = \case
|
||||
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 (Just (GSTExpires (roundedSeconds fileExpiresAt)))
|
||||
pure $ either FRErr id r
|
||||
@@ -593,7 +567,6 @@ processXFTPRequest addrStats_ ent 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
|
||||
@@ -632,7 +605,6 @@ processXFTPRequest addrStats_ ent 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
|
||||
@@ -662,7 +634,6 @@ processXFTPRequest addrStats_ ent 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)
|
||||
@@ -675,12 +646,11 @@ processXFTPRequest addrStats_ ent HTTP2Body {bodyPart} = \case
|
||||
|
||||
ackFileReception :: RecipientId -> FileRec -> M s FileResponse
|
||||
ackFileReception rId fr = do
|
||||
pure $ FRErr $ CMD PROHIBITED
|
||||
-- withFileLog (`logAckFile` rId)
|
||||
-- st <- asks fileStore
|
||||
-- liftIO $ deleteRecipient st rId fr
|
||||
-- incFileStat fileDownloadAcks
|
||||
-- pure FROk
|
||||
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
|
||||
|
||||
@@ -7,18 +7,15 @@ 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
|
||||
@@ -29,7 +26,6 @@ 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 -> ""
|
||||
@@ -39,7 +35,6 @@ 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
|
||||
|
||||
@@ -16,8 +16,6 @@ module Simplex.FileTransfer.Server.Env
|
||||
XFTPStoreConfig (..),
|
||||
XFTPEnv (..),
|
||||
XFTPRequest (..),
|
||||
XFTPAddrCounter (..),
|
||||
xftpCmdCounter,
|
||||
XFTPStoreType,
|
||||
FileStore (..),
|
||||
AFStoreType (..),
|
||||
@@ -47,7 +45,7 @@ import Data.Word (Word16, Word32)
|
||||
import Data.X509.Validation (Fingerprint (..))
|
||||
import Network.Socket
|
||||
import qualified Network.TLS as T
|
||||
import Simplex.FileTransfer.Protocol (FileCmd (..), FileCommand (..), FileInfo (..), XFTPFileId)
|
||||
import Simplex.FileTransfer.Protocol (FileCmd, FileInfo (..), XFTPFileId)
|
||||
import Simplex.FileTransfer.Server.Stats
|
||||
import Data.Either (fromRight)
|
||||
import Data.Ini (Ini, lookupValue)
|
||||
@@ -69,7 +67,6 @@ 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 (..))
|
||||
@@ -118,7 +115,6 @@ data XFTPServerConfig s = XFTPServerConfig
|
||||
serverStatsBackupFile :: Maybe FilePath,
|
||||
prometheusInterval :: Maybe Int,
|
||||
prometheusMetricsFile :: FilePath,
|
||||
addressStats :: Maybe AddressStatsConfig,
|
||||
transportConfig :: TransportServerConfig,
|
||||
responseDelay :: Int,
|
||||
webStaticPath :: Maybe FilePath
|
||||
@@ -140,55 +136,9 @@ data XFTPEnv s = XFTPEnv
|
||||
serverIdentity :: C.KeyHash,
|
||||
tlsServerCreds :: T.Credential,
|
||||
httpServerCreds :: Maybe T.Credential,
|
||||
serverStats :: FileServerStats,
|
||||
addrStats :: Maybe (ServerAddrStats XFTPAddrCounter)
|
||||
serverStats :: FileServerStats
|
||||
}
|
||||
|
||||
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 #-}
|
||||
@@ -232,7 +182,7 @@ defaultFileExpiration =
|
||||
}
|
||||
|
||||
newXFTPServerEnv :: FileStoreClass s => XFTPServerConfig s -> IO (XFTPEnv s)
|
||||
newXFTPServerEnv config@XFTPServerConfig {serverStoreCfg, fileSizeQuota, fileExpiration, fileStorageEntitlements, xftpCredentials, httpCredentials, addressStats} = do
|
||||
newXFTPServerEnv config@XFTPServerConfig {serverStoreCfg, fileSizeQuota, fileExpiration, fileStorageEntitlements, xftpCredentials, httpCredentials} = do
|
||||
let defaultMax = ttl fileExpiration
|
||||
belowDefault = M.filter ((< defaultMax) . storageTime) fileStorageEntitlements
|
||||
unless (M.null belowDefault) $ do
|
||||
@@ -260,8 +210,7 @@ newXFTPServerEnv config@XFTPServerConfig {serverStoreCfg, fileSizeQuota, fileExp
|
||||
httpServerCreds <- mapM loadServerCredential httpCredentials
|
||||
Fingerprint fp <- loadFingerprint xftpCredentials
|
||||
serverStats <- newFileServerStats =<< getCurrentTime
|
||||
addrStats <- mapM (const newServerAddrStats) addressStats
|
||||
pure XFTPEnv {config, store, usedStorage, storeLog, random, tlsServerCreds, httpServerCreds, serverIdentity = C.KeyHash fp, serverStats, addrStats}
|
||||
pure XFTPEnv {config, store, usedStorage, storeLog, random, tlsServerCreds, httpServerCreds, serverIdentity = C.KeyHash fp, serverStats}
|
||||
|
||||
data XFTPRequest
|
||||
= XFTPReqNew FileInfo (NonEmpty RcvPublicAuthKey) (Maybe BasicAuth) (Maybe Word32)
|
||||
|
||||
@@ -204,8 +204,6 @@ 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"
|
||||
@@ -327,7 +325,6 @@ xftpServerCLI_ generateSite serveStaticFiles cfgPath logPath = do
|
||||
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
|
||||
|
||||
@@ -11,15 +11,12 @@ 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)
|
||||
@@ -27,8 +24,7 @@ import Simplex.Messaging.Util (tshow)
|
||||
data FileServerMetrics = FileServerMetrics
|
||||
{ statsData :: FileServerStatsData,
|
||||
filesDownloadedPeriods :: PeriodStatCounts,
|
||||
rtsOptions :: Text,
|
||||
addressHistograms :: Maybe (Map XFTPAddrCounter AddrHistogram)
|
||||
rtsOptions :: Text
|
||||
}
|
||||
|
||||
rtsOptionsEnv :: Text
|
||||
@@ -37,9 +33,9 @@ rtsOptionsEnv = "XFTP_RTS_OPTIONS"
|
||||
{-# FOURMOLU_DISABLE\n#-}
|
||||
xftpPrometheusMetrics :: FileServerMetrics -> UTCTime -> Text
|
||||
xftpPrometheusMetrics sm ts =
|
||||
time <> files <> clientAddresses <> info
|
||||
time <> files <> info
|
||||
where
|
||||
FileServerMetrics {statsData, filesDownloadedPeriods, rtsOptions, addressHistograms} = sm
|
||||
FileServerMetrics {statsData, filesDownloadedPeriods, rtsOptions} = sm
|
||||
FileServerStatsData
|
||||
{ _fromTime,
|
||||
_filesCreated,
|
||||
@@ -126,7 +122,6 @@ 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\
|
||||
|
||||
@@ -93,8 +93,7 @@ data RcvFile = RcvFile
|
||||
deriving (Show)
|
||||
|
||||
data RcvFileStatus
|
||||
= RFSPrepared
|
||||
| RFSReceiving
|
||||
= RFSReceiving
|
||||
| RFSReceived
|
||||
| RFSDecrypting
|
||||
| RFSComplete
|
||||
@@ -107,7 +106,6 @@ 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
|
||||
@@ -115,7 +113,6 @@ instance TextEncoding RcvFileStatus where
|
||||
"error" -> Just RFSError
|
||||
_ -> Nothing
|
||||
textEncode = \case
|
||||
RFSPrepared -> "prepared"
|
||||
RFSReceiving -> "receiving"
|
||||
RFSReceived -> "received"
|
||||
RFSDecrypting -> "decrypting"
|
||||
@@ -180,8 +177,7 @@ sndFileEncPath :: FilePath -> FilePath
|
||||
sndFileEncPath prefixPath = prefixPath </> "xftp.encrypted"
|
||||
|
||||
data SndFileStatus
|
||||
= SFSPrepared
|
||||
| SFSNew -- db record created
|
||||
= SFSNew -- db record created
|
||||
| SFSEncrypting -- encryption started
|
||||
| SFSEncrypted -- encryption complete
|
||||
| SFSUploading -- all chunk replicas are created on servers
|
||||
@@ -195,7 +191,6 @@ 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
|
||||
@@ -204,7 +199,6 @@ instance TextEncoding SndFileStatus where
|
||||
"error" -> Just SFSError
|
||||
_ -> Nothing
|
||||
textEncode = \case
|
||||
SFSPrepared -> "prepared"
|
||||
SFSNew -> "new"
|
||||
SFSEncrypting -> "encrypting"
|
||||
SFSEncrypted -> "encrypted"
|
||||
|
||||
@@ -106,8 +106,7 @@ module Simplex.Messaging.Agent
|
||||
deleteConnection,
|
||||
deleteConnections,
|
||||
getConnectionServers,
|
||||
getConnectionVerifyCodes,
|
||||
getConnectionsVerifyCodes,
|
||||
getConnectionRatchetAdHash,
|
||||
setProtocolServers,
|
||||
setUserEntitlement,
|
||||
checkUserServers,
|
||||
@@ -127,15 +126,10 @@ module Simplex.Messaging.Agent
|
||||
xftpStartWorkers,
|
||||
xftpStartSndWorkers,
|
||||
xftpReceiveFile,
|
||||
xftpPrepareReceiveFile,
|
||||
xftpStartReceiveFile,
|
||||
xftpDeleteRcvFile,
|
||||
xftpDeleteRcvFiles,
|
||||
xftpSendFile,
|
||||
xftpSendDescription,
|
||||
xftpPrepareSendFile,
|
||||
xftpPrepareSendDescription,
|
||||
xftpStartSendFile,
|
||||
xftpDeleteSndFileInternal,
|
||||
xftpDeleteSndFilesInternal,
|
||||
xftpDeleteSndFileRemote,
|
||||
@@ -195,7 +189,7 @@ import Data.Time.Clock
|
||||
import Data.Time.Clock.System (systemToUTCTime)
|
||||
import Data.Traversable (mapAccumL)
|
||||
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.Agent (closeXFTPAgent, deleteSndFileInternal, deleteSndFileRemote, deleteSndFilesInternal, deleteSndFilesRemote, startXFTPSndWorkers, startXFTPWorkers, toFSFilePath, xftpDeleteRcvFile', xftpDeleteRcvFiles', xftpReceiveFile', xftpSendDescription', xftpSendFile')
|
||||
import Simplex.FileTransfer.Description (ValidFileDescription)
|
||||
import Simplex.FileTransfer.Protocol (FileParty (..))
|
||||
import Simplex.FileTransfer.Types (RcvFileId, SndFileId)
|
||||
@@ -234,7 +228,7 @@ import Simplex.Messaging.Protocol
|
||||
ErrorType (AUTH),
|
||||
MsgBody,
|
||||
MsgFlags (..),
|
||||
NameResponse,
|
||||
NameRecord,
|
||||
NtfServer,
|
||||
ProtoServerWithAuth (..),
|
||||
ProtocolServer (..),
|
||||
@@ -467,7 +461,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 NameResponse
|
||||
resolveSimplexName :: AgentClient -> NetworkRequestMode -> UserId -> SimplexDomain -> AE NameRecord
|
||||
resolveSimplexName c nm userId domain = withAgentEnv c $ resolveSimplexName' c nm userId domain
|
||||
{-# INLINE resolveSimplexName #-}
|
||||
|
||||
@@ -490,12 +484,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, ContactRequestBinding)
|
||||
prepareConnectionToJoin :: AgentClient -> UserId -> Bool -> ConnectionRequestUri c -> PQSupport -> AE ConnId
|
||||
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, ContactRequestBinding)
|
||||
prepareConnectionToAccept :: AgentClient -> UserId -> Bool -> InvitationId -> PQSupport -> AE ConnId
|
||||
prepareConnectionToAccept c userId enableNtfs = withAgentEnv c .: newConnToAccept c userId "" enableNtfs
|
||||
{-# INLINE prepareConnectionToAccept #-}
|
||||
|
||||
@@ -679,13 +673,9 @@ getConnectionServers c = withAgentEnv c . getConnectionServers' c
|
||||
{-# INLINE getConnectionServers #-}
|
||||
|
||||
-- | get connection ratchet associated data hash for verification (should match peer AD hash)
|
||||
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 #-}
|
||||
getConnectionRatchetAdHash :: AgentClient -> ConnId -> AE ByteString
|
||||
getConnectionRatchetAdHash c = withAgentEnv c . getConnectionRatchetAdHash' c
|
||||
{-# INLINE getConnectionRatchetAdHash #-}
|
||||
|
||||
-- | Test protocol server
|
||||
testProtocolServer :: forall p. ProtocolTypeI p => AgentClient -> NetworkRequestMode -> UserId -> ProtoServerWithAuth p -> IO (Either ProtocolTestFailure (Maybe (Either String ServerPublicInfo)))
|
||||
@@ -774,14 +764,6 @@ 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
|
||||
@@ -802,18 +784,6 @@ 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
|
||||
@@ -1300,7 +1270,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 NameResponse
|
||||
resolveSimplexName' :: AgentClient -> NetworkRequestMode -> UserId -> SimplexDomain -> AM NameRecord
|
||||
resolveSimplexName' c nm userId domain = do
|
||||
resolverSrv <- getNextNameServer c userId
|
||||
resolveName c nm userId resolverSrv domain
|
||||
@@ -1341,13 +1311,8 @@ newRcvConnSrv c nm userId connId enableNtfs cMode userLinkData_ clientData pqIni
|
||||
SCMInvitation -> do
|
||||
g <- asks random
|
||||
let pqEnc = CR.initialPQEncryption (isJust userLinkData_) pqInitKeys
|
||||
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
|
||||
(pks, e2eRcvParams) <- liftIO $ CR.generateRcvE2EParams g (maxVersion e2eEncryptVRange) pqEnc
|
||||
withStore' c $ \db -> createRatchetX3dhKeys db connId pks
|
||||
pure $ CRInvitationUri crData $ toVersionRangeT e2eRcvParams e2eEncryptVRange
|
||||
setLinkDataRatchetKeys :: Maybe AddressRatchetKeys -> UserConnLinkData c -> UserConnLinkData c
|
||||
setLinkDataRatchetKeys ks = \case
|
||||
@@ -1405,47 +1370,30 @@ 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, ContactRequestBinding)
|
||||
newConnToJoin :: forall c. AgentClient -> UserId -> ConnId -> Bool -> Maybe UTCTime -> ConnectionRequestUri c -> PQSupport -> AM ConnId
|
||||
newConnToJoin c userId connId enableNtfs serviceRequestExpiresAt cReq pqSupport = case cReq of
|
||||
CRInvitationUri {} ->
|
||||
lift (compatibleInvitationUri cReq) >>= \case
|
||||
Just (_, Compatible e2eRcvParams, aVersion) -> create aVersion $ Right e2eRcvParams
|
||||
Just (_, _, aVersion) -> create aVersion
|
||||
Nothing -> throwE $ AGENT A_VERSION
|
||||
CRContactUri {} ->
|
||||
lift (compatibleContactUri cReq) >>= \case
|
||||
Just (Compatible SMPQueueInfo {queueAddress = SMPQueueAddress {senderId}}, ratchet_, aVersion) ->
|
||||
create aVersion $ case ratchet_ of
|
||||
Just (_, Compatible e2eRcvParams) -> Right e2eRcvParams
|
||||
Nothing -> Left senderId
|
||||
Just (_, _, aVersion) -> create aVersion
|
||||
Nothing -> throwE $ AGENT A_VERSION
|
||||
where
|
||||
create :: Compatible VersionSMPA -> Either SMP.SenderId (CR.RcvE2ERatchetParams 'C.X448) -> AM (ConnId, ContactRequestBinding)
|
||||
create (Compatible connAgentVersion) addrOrParams = do
|
||||
create :: Compatible VersionSMPA -> AM ConnId
|
||||
create (Compatible connAgentVersion) = 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 -> 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)
|
||||
withStore c $ \db -> createNewConn db g cData SCMInvitation
|
||||
|
||||
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 :: AgentClient -> UserId -> ConnId -> Bool -> InvitationId -> PQSupport -> AM ConnId
|
||||
newConnToAccept c userId connId enableNtfs invId pqSup = do
|
||||
Invitation {connReq} <- withStore c $ \db -> getInvitation db "newConnToAccept" invId
|
||||
case connReq of
|
||||
CRInvitation cReq -> newConnToJoin c userId connId enableNtfs Nothing cReq pqSup
|
||||
CRInvitationDR dr@DRInvitation {ratchetState} -> do
|
||||
ConnData {connId = connId'} <- newConnToAcceptDR c userId connId dr enableNtfs
|
||||
pure (connId', CRBRatchet $ ratchetVerifyCodes ratchetState)
|
||||
|
||||
CRInvitationDR dr -> (\ConnData {connId = connId'} -> connId') <$> newConnToAcceptDR c userId connId dr enableNtfs
|
||||
|
||||
newConnToAcceptDR :: AgentClient -> UserId -> ConnId -> DRInvitation -> Bool -> AM ConnData
|
||||
newConnToAcceptDR c userId connId DRInvitation {agentVersion, pqSupport} enableNtfs = do
|
||||
g <- asks random
|
||||
@@ -1488,7 +1436,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) <- liftIO (getSndRatchet db connId v) >>= either (const $ createRatchet_ db g connId maxSupported pqSupport e2eRcvParams) pure
|
||||
e2eSndParams <- snd <$> createRatchet_ db g connId maxSupported pqSupport e2eRcvParams
|
||||
sq' <- maybe (ExceptT $ updateNewConnSnd db connId q) pure sq_
|
||||
pure ((cData, sq'), (Just e2eSndParams, lnkId_))
|
||||
Nothing -> throwE $ AGENT A_VERSION
|
||||
@@ -1781,7 +1729,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
|
||||
@@ -2168,21 +2116,20 @@ data CommandCompletion = CCMoved | CCCompleted
|
||||
|
||||
runCommandProcessing :: AgentClient -> ConnId -> Maybe SMPServer -> Worker -> AM ()
|
||||
runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do
|
||||
AgentConfig {messageRetryInterval = RetryInterval2 {riFast}, commandQuotaRetryInterval} <- asks config
|
||||
let ri = RetryInterval2 {riSlow = commandQuotaRetryInterval, riFast}
|
||||
ri <- asks $ messageRetryInterval . config -- different retry interval?
|
||||
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 ri
|
||||
withWork c doWork (\db -> getPendingServerCommand db connId server_) $ runProcessCmd (riFast ri)
|
||||
where
|
||||
runProcessCmd ri cmd = do
|
||||
pending <- newTVarIO []
|
||||
processCmd ri cmd pending
|
||||
mapM_ (atomically . writeTBQueue subQ) . reverse =<< readTVarIO pending
|
||||
processCmd :: RetryInterval2 -> PendingCommand -> TVar [ATransmission] -> AM ()
|
||||
processCmd ri PendingCommand {cmdId, corrId, userId, command, createdAt} pendingCmds = case command of
|
||||
processCmd :: RetryInterval -> PendingCommand -> TVar [ATransmission] -> AM ()
|
||||
processCmd ri PendingCommand {cmdId, corrId, userId, command} pendingCmds = case command of
|
||||
AClientCommand cmd -> case cmd of
|
||||
NEW enableNtfs (ACM cMode) pqEnc subMode useDR -> noServer $ do
|
||||
triedHosts <- newTVarIO S.empty
|
||||
@@ -2377,18 +2324,12 @@ 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 = withRetryInterval2 ri $ \_ loop -> do
|
||||
tryMoveableCommand action = withRetryInterval 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 RIFast
|
||||
| temporaryOrHostError e -> retrySndOp c loop
|
||||
| otherwise -> cmdError e
|
||||
Right CCCompleted -> withStore' c (`deleteCommand` cmdId)
|
||||
Right CCMoved -> pure () -- command processing moved to another command queue
|
||||
@@ -3048,12 +2989,10 @@ getConnectionServers' c connId = do
|
||||
SomeConn _ conn <- withStore c (`getConn` connId)
|
||||
connectionStats c conn
|
||||
|
||||
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)
|
||||
getConnectionRatchetAdHash' :: AgentClient -> ConnId -> AM ByteString
|
||||
getConnectionRatchetAdHash' c connId = do
|
||||
CR.Ratchet {rcAD = Str rcAD} <- withStore c (`getRatchet` connId)
|
||||
pure $ C.sha256Hash rcAD
|
||||
|
||||
connectionStats :: AgentClient -> Connection c -> AM ConnectionStats
|
||||
connectionStats c = \case
|
||||
@@ -4101,14 +4040,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 (CR.E2ERatchetParamsUri _ k1 k2 kem_)) cInfo = do
|
||||
smpInvitation srvMsgId conn' connReq@(CRInvitationUri crData _) cInfo = do
|
||||
logServer "<--" c srv rId $ "MSG <KEY>:" <> logSecret' srvMsgId
|
||||
case conn' of
|
||||
ContactConnection _ RcvQueue {sndId} -> do
|
||||
ContactConnection {} -> 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 (CRBRequest $ requestCode k1 k2 kem_ sndId) False
|
||||
notify $ REQ invId PQSupportOn srvs cInfo False
|
||||
_ -> prohibited "inv: sent to message conn"
|
||||
|
||||
storeInvitation :: ContactRequest -> ConnInfo -> Bool -> AM InvitationId
|
||||
@@ -4135,7 +4074,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 (CRBRatchet $ ratchetVerifyCodes ratchetState) True
|
||||
notify $ REQ invId PQSupportOn (qServer replyQueue :| []) cInfo 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)
|
||||
|
||||
@@ -272,7 +272,7 @@ import Simplex.Messaging.Protocol
|
||||
NetworkError (..),
|
||||
MsgFlags (..),
|
||||
MsgId,
|
||||
NameResponse,
|
||||
NameRecord,
|
||||
NtfServer,
|
||||
NtfServerWithAuth,
|
||||
ProtoServer,
|
||||
@@ -2022,7 +2022,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 NameResponse
|
||||
resolveName :: AgentClient -> NetworkRequestMode -> UserId -> SMPServer -> SimplexDomain -> AM NameRecord
|
||||
resolveName c nm userId server domain =
|
||||
snd <$> sendOrProxySMPCommand c nm userId server "" "RSLV" NoEntity resolveViaProxy resolveDirectly
|
||||
where
|
||||
|
||||
@@ -162,7 +162,6 @@ data AgentConfig = AgentConfig
|
||||
connDeleteDeliveryTimeout :: NominalDiffTime,
|
||||
helloTimeout :: NominalDiffTime,
|
||||
quotaExceededTimeout :: NominalDiffTime,
|
||||
commandQuotaRetryInterval :: RetryInterval,
|
||||
persistErrorInterval :: NominalDiffTime,
|
||||
initialCleanupDelay :: Int64,
|
||||
cleanupInterval :: Int64,
|
||||
@@ -242,7 +241,6 @@ 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
|
||||
|
||||
@@ -166,8 +166,6 @@ module Simplex.Messaging.Agent.Protocol
|
||||
ConnId,
|
||||
ConfirmationId,
|
||||
InvitationId,
|
||||
ConnVerifyCodes (..),
|
||||
ContactRequestBinding (..),
|
||||
MsgIntegrity (..),
|
||||
MsgErrorType (..),
|
||||
QueueStatus (..),
|
||||
@@ -406,7 +404,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 -> ContactRequestBinding -> Bool -> AEvent AEConn -- ConnInfo is from sender; Bool - rejection reason can be sent
|
||||
REQ :: InvitationId -> PQSupport -> NonEmpty SMPServer -> ConnInfo -> 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
|
||||
@@ -1374,15 +1372,6 @@ 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
|
||||
|
||||
@@ -10,7 +10,6 @@ module Simplex.Messaging.Agent.RetryInterval
|
||||
withRetryInterval,
|
||||
withRetryIntervalCount,
|
||||
withRetryForeground,
|
||||
withRetryInterval2,
|
||||
withRetryLock2,
|
||||
updateRetryInterval2,
|
||||
nextRetryDelay,
|
||||
@@ -87,24 +86,9 @@ 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 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 =
|
||||
withRetryLock2 RetryInterval2 {riSlow, riFast} lock action =
|
||||
callAction (0, initialInterval riSlow) (0, initialInterval riFast)
|
||||
where
|
||||
callAction :: (Int64, Int64) -> (Int64, Int64) -> m ()
|
||||
@@ -118,6 +102,14 @@ withRetryWait2 wait RetryInterval2 {riSlow, riFast} 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} =
|
||||
|
||||
@@ -489,8 +489,7 @@ data PendingCommand = PendingCommand
|
||||
corrId :: ACorrId,
|
||||
userId :: UserId,
|
||||
connId :: ConnId,
|
||||
command :: AgentCommand,
|
||||
createdAt :: UTCTime
|
||||
command :: AgentCommand
|
||||
}
|
||||
|
||||
data AgentCmdType = ACClient | ACInternal
|
||||
|
||||
@@ -165,8 +165,6 @@ module Simplex.Messaging.Agent.Store.AgentStore
|
||||
createRatchet,
|
||||
deleteRatchet,
|
||||
getRatchet,
|
||||
getRatchetVerifyCodes,
|
||||
ratchetVerifyCodes,
|
||||
getRatchetForUpdate,
|
||||
getSkippedMsgKeys,
|
||||
updateRatchet,
|
||||
@@ -215,7 +213,6 @@ module Simplex.Messaging.Agent.Store.AgentStore
|
||||
-- Rcv files
|
||||
createRcvFile,
|
||||
createRcvFileRedirect,
|
||||
startPreparedRcvFile,
|
||||
lockRcvFileForUpdate,
|
||||
getRcvFile,
|
||||
getRcvFileByEntityId,
|
||||
@@ -237,7 +234,6 @@ module Simplex.Messaging.Agent.Store.AgentStore
|
||||
getRcvFilesExpired,
|
||||
-- Snd files
|
||||
createSndFile,
|
||||
startPreparedSndFile,
|
||||
lockSndFileForUpdate,
|
||||
getSndFile,
|
||||
getSndFileByEntityId,
|
||||
@@ -295,7 +291,6 @@ 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)
|
||||
@@ -1479,11 +1474,9 @@ createSndRatchet db connId ratchetState (CR.AE2ERatchetParams s (CR.E2ERatchetPa
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO ratchets
|
||||
(conn_id, ratchet_state, rc_verify_code_ad, rc_verify_code_pq, x3dh_pub_key_1, x3dh_pub_key_2, pq_pub_kem) VALUES (?, ?, ?, ?, ?, ?, ?)
|
||||
(conn_id, ratchet_state, 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,
|
||||
@@ -1491,13 +1484,7 @@ createSndRatchet db connId ratchetState (CR.AE2ERatchetParams s (CR.E2ERatchetPa
|
||||
pq_priv_kem = NULL,
|
||||
pq_pub_kem = EXCLUDED.pq_pub_kem
|
||||
|]
|
||||
((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)
|
||||
(connId, ratchetState, x3dhPubKey1, x3dhPubKey2, CR.ARKP s <$> pqPubKem)
|
||||
|
||||
getSndRatchet :: DB.Connection -> ConnId -> CR.VersionE2E -> IO (Either StoreError (RatchetX448, CR.AE2ERatchetParams 'C.X448))
|
||||
getSndRatchet db connId v =
|
||||
@@ -1518,12 +1505,10 @@ createRatchet db connId rc =
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO ratchets (conn_id, ratchet_state, rc_verify_code_ad, rc_verify_code_pq)
|
||||
VALUES (?, ?, ?, ?)
|
||||
INSERT INTO ratchets (conn_id, ratchet_state)
|
||||
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,
|
||||
ratchet_state = ?,
|
||||
x3dh_priv_key_1 = NULL,
|
||||
x3dh_priv_key_2 = NULL,
|
||||
x3dh_pub_key_1 = NULL,
|
||||
@@ -1531,42 +1516,7 @@ createRatchet db connId rc =
|
||||
pq_priv_kem = NULL,
|
||||
pq_pub_kem = NULL
|
||||
|]
|
||||
((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
|
||||
(connId, rc, rc)
|
||||
|
||||
deleteRatchet :: DB.Connection -> ConnId -> IO ()
|
||||
deleteRatchet db connId =
|
||||
@@ -1718,7 +1668,7 @@ getPendingServerCommand db connId srv_ = getWorkItem "command" getCmdId getComma
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT c.corr_id, cs.user_id, c.command, c.created_at
|
||||
SELECT c.corr_id, cs.user_id, c.command
|
||||
FROM commands c
|
||||
JOIN connections cs USING (conn_id)
|
||||
WHERE c.command_id = ?
|
||||
@@ -1726,7 +1676,7 @@ getPendingServerCommand db connId srv_ = getWorkItem "command" getCmdId getComma
|
||||
(Only cmdId)
|
||||
where
|
||||
err = SEInternal $ "command " <> bshow cmdId <> " returned []"
|
||||
pendingCommand (corrId, userId, command, createdAt) = PendingCommand {cmdId, corrId, userId, connId, command, createdAt}
|
||||
pendingCommand (corrId, userId, command) = PendingCommand {cmdId, corrId, userId, connId, command}
|
||||
markCommandFailed cmdId = DB.execute db "UPDATE commands SET failed = 1 WHERE command_id = ?" (Only cmdId)
|
||||
|
||||
updateCommandServer :: DB.Connection -> AsyncCmdId -> SMPServer -> IO (Either StoreError ())
|
||||
@@ -2500,12 +2450,12 @@ getSubscriptionServers db onlyNeeded =
|
||||
|
||||
-- TODO [certs rcv] check index for getting queues with service present
|
||||
getUserServerRcvQueueSubs :: DB.Connection -> UserId -> SMPServer -> Bool -> ServiceAssoc -> Int -> Maybe SMP.RecipientId -> IO [RcvQueueSub]
|
||||
getUserServerRcvQueueSubs db userId srv@(SMPServer h p kh) onlyNeeded hasService limit cursor_ =
|
||||
map (toServerRcvQueueSub srv) <$> case cursor_ of
|
||||
getUserServerRcvQueueSubs db userId (SMPServer h p kh) onlyNeeded hasService limit cursor_ =
|
||||
map toRcvQueueSub <$> case cursor_ of
|
||||
Nothing -> DB.query db (q <> orderLimit) (userId, h, p, kh, limit)
|
||||
Just cursor -> DB.query db (q <> " AND q.rcv_id > ? " <> orderLimit) (userId, h, p, kh, cursor, limit)
|
||||
where
|
||||
q = serverRcvQueueSubQuery <> toSubscribe <> " c.deleted = 0 AND q.deleted = 0 AND c.user_id = ? AND q.host = ? AND q.port = ? AND COALESCE(q.server_key_hash, s.key_hash) = ?" <> serviceCond
|
||||
q = rcvQueueSubQuery <> toSubscribe <> " c.deleted = 0 AND q.deleted = 0 AND c.user_id = ? AND q.host = ? AND q.port = ? AND COALESCE(q.server_key_hash, s.key_hash) = ?" <> serviceCond
|
||||
orderLimit = " ORDER BY q.rcv_id LIMIT ?"
|
||||
toSubscribe
|
||||
| onlyNeeded = " WHERE q.to_subscribe = 1 AND "
|
||||
@@ -2518,7 +2468,7 @@ unassocUserServerRcvQueueSubs :: DB.Connection -> UserId -> SMPServer -> IO [Rcv
|
||||
unassocUserServerRcvQueueSubs db userId srv@(SMPServer h p kh) = do
|
||||
deleteClientService db userId srv
|
||||
#if defined(dbPostgres)
|
||||
map (toServerRcvQueueSub srv)
|
||||
map toRcvQueueSub
|
||||
<$> DB.query
|
||||
db
|
||||
(removeRcvAssocsQuery <> " " <> returningColumns)
|
||||
@@ -2526,15 +2476,15 @@ unassocUserServerRcvQueueSubs db userId srv@(SMPServer h p kh) = do
|
||||
where
|
||||
returningColumns =
|
||||
[sql|
|
||||
RETURNING c.user_id, rcv_queues.conn_id,
|
||||
RETURNING c.user_id, rcv_queues.conn_id, rcv_queues.host, rcv_queues.port, COALESCE(rcv_queues.server_key_hash, s.key_hash),
|
||||
rcv_queues.rcv_id, rcv_queues.rcv_private_key, rcv_queues.status, c.enable_ntfs, rcv_queues.client_notice_id,
|
||||
rcv_queues.rcv_queue_id, rcv_queues.rcv_primary, rcv_queues.replace_rcv_queue_id
|
||||
|]
|
||||
#else
|
||||
qs <- map (toServerRcvQueueSub srv)
|
||||
qs <- map toRcvQueueSub
|
||||
<$> DB.query
|
||||
db
|
||||
(serverRcvQueueSubQuery <> " WHERE c.user_id = ? AND q.host = ? AND q.port = ? AND COALESCE(q.server_key_hash, s.key_hash) = ? AND q.rcv_service_assoc = 1")
|
||||
(rcvQueueSubQuery <> " WHERE c.user_id = ? AND q.host = ? AND q.port = ? AND COALESCE(q.server_key_hash, s.key_hash) = ? AND q.rcv_service_assoc = 1")
|
||||
(userId, h, p, kh)
|
||||
DB.execute db removeRcvAssocsQuery (h, p, userId, kh)
|
||||
pure qs
|
||||
@@ -2885,32 +2835,17 @@ getRcvQueueSubsByConnId_ db connId =
|
||||
rcvQueueSubQuery :: Query
|
||||
rcvQueueSubQuery =
|
||||
[sql|
|
||||
SELECT q.host, q.port, COALESCE(q.server_key_hash, s.key_hash), c.user_id, q.conn_id, q.rcv_id, q.rcv_private_key, q.status, c.enable_ntfs, q.client_notice_id,
|
||||
SELECT c.user_id, q.conn_id, q.host, q.port, COALESCE(q.server_key_hash, s.key_hash), q.rcv_id, q.rcv_private_key, q.status, c.enable_ntfs, q.client_notice_id,
|
||||
q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id
|
||||
FROM rcv_queues q
|
||||
JOIN servers s ON q.host = s.host AND q.port = s.port
|
||||
JOIN connections c ON q.conn_id = c.conn_id
|
||||
|]
|
||||
|
||||
serverRcvQueueSubQuery :: Query
|
||||
serverRcvQueueSubQuery =
|
||||
[sql|
|
||||
SELECT c.user_id, q.conn_id, q.rcv_id, q.rcv_private_key, q.status, c.enable_ntfs, q.client_notice_id,
|
||||
q.rcv_queue_id, q.rcv_primary, q.replace_rcv_queue_id
|
||||
FROM rcv_queues q
|
||||
JOIN servers s ON q.host = s.host AND q.port = s.port
|
||||
JOIN connections c ON q.conn_id = c.conn_id
|
||||
|]
|
||||
|
||||
type RcvQueueSubRow = (UserId, ConnId, SMP.RecipientId, SMP.RcvPrivateAuthKey) :. (QueueStatus, Maybe BoolInt, Maybe NoticeId, Int64, BoolInt, Maybe Int64)
|
||||
|
||||
toRcvQueueSub :: (NonEmpty TransportHost, ServiceName, C.KeyHash) :. RcvQueueSubRow -> RcvQueueSub
|
||||
toRcvQueueSub ((host, port, keyHash) :. r) = toServerRcvQueueSub (SMPServer host port keyHash) r
|
||||
|
||||
toServerRcvQueueSub :: SMPServer -> RcvQueueSubRow -> RcvQueueSub
|
||||
toServerRcvQueueSub server ((userId, connId, rcvId, rcvPrivateKey) :. (status, enableNtfs_, clientNoticeId, dbQueueId, BI primary, dbReplaceQueueId)) =
|
||||
toRcvQueueSub :: (UserId, ConnId, NonEmpty TransportHost, ServiceName, C.KeyHash, SMP.RecipientId, SMP.RcvPrivateAuthKey) :. (QueueStatus, Maybe BoolInt, Maybe NoticeId, Int64, BoolInt, Maybe Int64) -> RcvQueueSub
|
||||
toRcvQueueSub ((userId, connId, host, port, keyHash, rcvId, rcvPrivateKey) :. (status, enableNtfs_, clientNoticeId, dbQueueId, BI primary, dbReplaceQueueId)) =
|
||||
let enableNtfs = maybe True unBI enableNtfs_
|
||||
in RcvQueueSub {userId, connId, server, rcvId, rcvPrivateKey, status, enableNtfs, clientNoticeId, dbQueueId, primary, dbReplaceQueueId}
|
||||
in RcvQueueSub {userId, connId, server = SMPServer host port keyHash, rcvId, rcvPrivateKey, status, enableNtfs, clientNoticeId, dbQueueId, primary, dbReplaceQueueId}
|
||||
|
||||
getRcvQueueById :: DB.Connection -> ConnId -> Int64 -> IO (Either StoreError RcvQueue)
|
||||
getRcvQueueById db connId dbRcvId =
|
||||
@@ -3180,29 +3115,6 @@ 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
|
||||
@@ -3213,7 +3125,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, RFSPrepared, redirectId_, Binary <$> redirectEntityId_, redirectDigest_, redirectSize_, BI approvedRelays))
|
||||
((Binary rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, prefixPath, tmpPath) :. (savePath, fileKey <$> cfArgs, fileNonce <$> cfArgs, RFSReceiving, redirectId_, Binary <$> redirectEntityId_, redirectDigest_, redirectSize_, BI approvedRelays))
|
||||
rcvFileId <- liftIO $ insertedRowId db
|
||||
pure (rcvFileEntityId, rcvFileId)
|
||||
|
||||
@@ -3518,23 +3430,13 @@ createSndFile db gVar userId (CryptoFile path cfArgs) numRecipients prefixPath k
|
||||
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, storage_time) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)"
|
||||
((Binary sndFileEntityId, userId, path, fileKey <$> cfArgs, fileNonce <$> cfArgs, numRecipients) :. (prefixPath, key, nonce, SFSPrepared, redirectSize_, redirectDigest_, storageHours))
|
||||
((Binary sndFileEntityId, userId, path, fileKey <$> cfArgs, fileNonce <$> cfArgs, numRecipients) :. (prefixPath, key, nonce, SFSNew, 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
|
||||
|
||||
@@ -13,7 +13,6 @@ module Simplex.Messaging.Agent.Store.Postgres.DB
|
||||
execute,
|
||||
execute_,
|
||||
executeMany,
|
||||
returning,
|
||||
query,
|
||||
query_,
|
||||
blobFieldDecoder,
|
||||
@@ -61,10 +60,6 @@ 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 #-}
|
||||
|
||||
@@ -15,7 +15,6 @@ import Simplex.Messaging.Agent.Store.Postgres.Migrations.M20260410_receive_attem
|
||||
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)]
|
||||
@@ -30,8 +29,7 @@ schemaMigrations =
|
||||
("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),
|
||||
("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)
|
||||
("20260823_snd_files_entitlement", m20260823_snd_files_entitlement, Just down_m20260823_snd_files_entitlement)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
|
||||
-21
@@ -1,21 +0,0 @@
|
||||
{-# 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;
|
||||
|]
|
||||
@@ -448,9 +448,7 @@ 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,
|
||||
rc_verify_code_ad bytea,
|
||||
rc_verify_code_pq bytea
|
||||
pq_pub_kem bytea
|
||||
);
|
||||
|
||||
|
||||
|
||||
@@ -51,7 +51,6 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20260410_receive_attempt
|
||||
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)]
|
||||
@@ -102,8 +101,7 @@ schemaMigrations =
|
||||
("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),
|
||||
("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)
|
||||
("m20260823_snd_files_entitlement", m20260823_snd_files_entitlement, Just down_m20260823_snd_files_entitlement)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
|
||||
@@ -1,20 +0,0 @@
|
||||
{-# 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;
|
||||
|]
|
||||
@@ -182,9 +182,7 @@ CREATE TABLE ratchets(
|
||||
x3dh_pub_key_1 BLOB,
|
||||
x3dh_pub_key_2 BLOB,
|
||||
pq_priv_kem BLOB,
|
||||
pq_pub_kem BLOB,
|
||||
rc_verify_code_ad BLOB,
|
||||
rc_verify_code_pq BLOB
|
||||
pq_pub_kem BLOB
|
||||
) WITHOUT ROWID, STRICT;
|
||||
CREATE TABLE skipped_messages(
|
||||
skipped_message_id INTEGER PRIMARY KEY,
|
||||
|
||||
@@ -166,7 +166,7 @@ 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, fullDomainName)
|
||||
import Simplex.Messaging.SimplexName (SimplexDomain)
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import qualified Simplex.Messaging.TMap as TM
|
||||
import Simplex.Messaging.Transport
|
||||
@@ -1054,11 +1054,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 NameResponse)
|
||||
proxyResolveName :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> SimplexDomain -> ExceptT SMPClientError IO (Either ProxyClientError NameRecord)
|
||||
proxyResolveName c nm proxiedRelay name
|
||||
| prVersion proxiedRelay >= namesSMPVersion =
|
||||
proxySMPCommand c nm proxiedRelay Nothing NoEntity (RSLV (NQDomain name)) >>= \case
|
||||
Right (RNAME reg) | resolvedNameOrNotFound name reg -> pure $ Right reg
|
||||
proxySMPCommand c nm proxiedRelay Nothing NoEntity (RSLV name) >>= \case
|
||||
Right (RNAME nr) -> pure $ Right nr
|
||||
Right r -> throwE $ unexpectedResponse r
|
||||
Left e -> pure $ Left e
|
||||
| otherwise = throwE $ PCETransportError TEVersion
|
||||
@@ -1066,21 +1066,16 @@ 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). 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
|
||||
-- (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
|
||||
directResolveName c nm name
|
||||
| thVersion (thParams c) >= namesSMPVersion =
|
||||
sendProtocolCommand c nm Nothing NoEntity (Cmd SResolver (RSLV (NQDomain name))) >>= \case
|
||||
RNAME reg | resolvedNameOrNotFound name reg -> pure reg
|
||||
sendProtocolCommand c nm Nothing NoEntity (Cmd SResolver (RSLV name)) >>= \case
|
||||
RNAME nr -> pure nr
|
||||
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
|
||||
|
||||
@@ -451,7 +451,6 @@ generateSndE2EParams g v = \case
|
||||
|
||||
data RatchetInitParams = RatchetInitParams
|
||||
{ assocData :: Str,
|
||||
rcVerifyCodePQ :: Str,
|
||||
ratchetKey :: RatchetKey,
|
||||
sndHK :: HeaderKey,
|
||||
rcvNextHK :: HeaderKey,
|
||||
@@ -494,14 +493,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, rcVerifyCodePQ = Str vcPQ, ratchetKey = RatchetKey sk, sndHK = Key hk, rcvNextHK = Key nhk, kemAccepted}
|
||||
RatchetInitParams {assocData, 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
|
||||
salt = B.replicate 64 '\0'
|
||||
(hk, nhk, sk) = hkdf3 salt dhs "SimpleXX3DH"
|
||||
vcPQ = hkdf salt dhs "SimpleXVerifyCode" 32
|
||||
(hk, nhk, sk) =
|
||||
let salt = B.replicate 64 '\0'
|
||||
in hkdf3 salt dhs "SimpleXX3DH"
|
||||
|
||||
type RatchetX448 = Ratchet 'X448
|
||||
|
||||
@@ -510,8 +509,6 @@ 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
|
||||
@@ -640,14 +637,13 @@ 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, rcVerifyCodePQ, ratchetKey, sndHK, rcvNextHK, kemAccepted}, rcPQRs_) = do
|
||||
initSndRatchet rcVersion rcDHRr rcDHRs (RatchetInitParams {assocData, 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,
|
||||
@@ -672,11 +668,10 @@ initSndRatchet rcVersion rcDHRr rcDHRs (RatchetInitParams {assocData, rcVerifyCo
|
||||
-- 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, rcVerifyCodePQ, ratchetKey, sndHK, rcvNextHK, kemAccepted}, rcPQRs_) pqSupport =
|
||||
initRcvRatchet rcVersion rcDHRs (RatchetInitParams {assocData, ratchetKey, sndHK, rcvNextHK, kemAccepted}, rcPQRs_) pqSupport =
|
||||
Ratchet
|
||||
{ rcVersion,
|
||||
rcAD = assocData,
|
||||
rcVCPQ = Just rcVerifyCodePQ,
|
||||
rcDHRs,
|
||||
-- rcKEM:
|
||||
-- state.PQRs = bob_pq_kem_key_pair
|
||||
|
||||
@@ -1,6 +1,3 @@
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
@@ -8,24 +5,13 @@
|
||||
|
||||
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 qualified Data.Text as T
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, taggedObjectJSON)
|
||||
import Simplex.Messaging.SystemTime (SystemSeconds)
|
||||
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix)
|
||||
|
||||
-- | Resolved name record returned by the names role. JSON keys match the
|
||||
-- resolver REST output; both FromJSON (resolver -> server) and ToJSON
|
||||
@@ -58,87 +44,3 @@ $( 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)
|
||||
|
||||
@@ -72,7 +72,6 @@ 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)
|
||||
@@ -81,7 +80,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, TLSServerCredential (..), newSocketState, runLocalTCPServer, runTransportServerState_)
|
||||
import Simplex.Messaging.Transport.Server (AddHTTP, runTransportServer, runLocalTCPServer)
|
||||
import Simplex.Messaging.Util
|
||||
import System.Environment (lookupEnv)
|
||||
import System.Exit (exitFailure, exitSuccess)
|
||||
@@ -123,7 +122,6 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions}
|
||||
: map runServer transports
|
||||
<> serverStatsThread_ cfg
|
||||
<> prometheusMetricsThread_ cfg
|
||||
<> addressStatsThread_ cfg
|
||||
<> controlPortThread_ cfg
|
||||
)
|
||||
`finally` stopServer
|
||||
@@ -133,20 +131,16 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions}
|
||||
srvCreds <- asks tlsServerCreds
|
||||
serverSignKey <- either fail pure $ C.x509ToPrivate' $ snd srvCreds
|
||||
env <- ask
|
||||
ss <- liftIO newSocketState
|
||||
liftIO $ runTransportServerState_ ss started tcpPort defaultSupportedParams TLSServerCredential {credential = srvCreds, sniCredential = Nothing} tCfg $ \sock (_, h) ->
|
||||
runClient serverSignKey t sock h `runReaderT` env
|
||||
liftIO $ runTransportServer started tcpPort defaultSupportedParams srvCreds tCfg $ \h -> runClient serverSignKey t h `runReaderT` env
|
||||
|
||||
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 ()
|
||||
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 ()
|
||||
|
||||
stopServer :: M ()
|
||||
stopServer = do
|
||||
@@ -237,10 +231,6 @@ 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"
|
||||
@@ -266,7 +256,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, addrStats} = do
|
||||
getNtfRealTimeMetrics NtfEnv {subscriber, pushServer} = do
|
||||
#if MIN_VERSION_base(4,18,0)
|
||||
threadsCount <- length <$> listThreads
|
||||
#else
|
||||
@@ -284,7 +274,6 @@ 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,
|
||||
@@ -296,8 +285,7 @@ ntfServer cfg@NtfServerConfig {transports, transportConfig = tCfg, startOptions}
|
||||
ntfPendingServiceSubs,
|
||||
ntfPendingQueueSubs,
|
||||
smpSessionCount,
|
||||
apnsPushQLength,
|
||||
addressHistograms
|
||||
apnsPushQLength
|
||||
}
|
||||
where
|
||||
getSMPServiceSubMetrics :: forall sub. SMPClientAgent 'NotifierService -> (SMPClientAgent 'NotifierService -> TMap SMPServer (TVar (Maybe sub))) -> (sub -> Int64) -> IO NtfSMPSubMetrics
|
||||
@@ -453,10 +441,7 @@ 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
|
||||
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"
|
||||
CPHelp -> hPutStrLn h "commands: stats, stats-rts, server-info, help, quit"
|
||||
CPQuit -> pure ()
|
||||
CPSkip -> pure ()
|
||||
where
|
||||
@@ -771,11 +756,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 => Maybe (AddrStats NtfAddrCounter) -> THandleNTF c 'TServer -> M ()
|
||||
runNtfClientTransport addrStats_ th@THandle {params} = do
|
||||
runNtfClientTransport :: Transport c => THandleNTF c 'TServer -> M ()
|
||||
runNtfClientTransport th@THandle {params} = do
|
||||
qSize <- asks $ clientQSize . config
|
||||
ts <- liftIO getSystemTime
|
||||
c <- liftIO $ newNtfServerClient qSize params ts addrStats_
|
||||
c <- liftIO $ newNtfServerClient qSize params ts
|
||||
s <- asks subscriber
|
||||
ps <- asks pushServer
|
||||
expCfg <- asks $ inactiveClientExpiration . config
|
||||
@@ -790,7 +775,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, ntfClientAddrStats} = forever $ do
|
||||
receive st th@THandle {params = THandleParams {thAuth}} NtfServerClient {rcvQ, sndQ, rcvActiveAt} = forever $ do
|
||||
ts <- L.toList <$> tGetServer th
|
||||
atomically . (writeTVar rcvActiveAt $!) =<< getSystemTime
|
||||
(errs, cmds) <- partitionEithers <$> mapM cmdAction ts
|
||||
@@ -799,21 +784,17 @@ 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, cmd)) -> do
|
||||
incAddrStats $ ntfCmdCounter cmd
|
||||
Right t@(_, _, (corrId, entId, _)) ->
|
||||
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
|
||||
|
||||
@@ -7,17 +7,14 @@ 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
|
||||
@@ -28,7 +25,6 @@ instance StrEncoding ControlProtocol where
|
||||
CPStats -> "stats"
|
||||
CPStatsRTS -> "stats-rts"
|
||||
CPServerInfo -> "server-info"
|
||||
CPAddresses name n_ -> "addresses " <> addressesArgs name n_
|
||||
CPHelp -> "help"
|
||||
CPQuit -> "quit"
|
||||
CPSkip -> ""
|
||||
@@ -38,7 +34,6 @@ 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
|
||||
|
||||
@@ -19,8 +19,6 @@ module Simplex.Messaging.Notifications.Server.Env
|
||||
PushWorkerVar,
|
||||
NtfRequest (..),
|
||||
NtfServerClient (..),
|
||||
NtfAddrCounter (..),
|
||||
ntfCmdCounter,
|
||||
defaultInactiveClientExpiration,
|
||||
newNtfServerEnv,
|
||||
newNtfSubscriber,
|
||||
@@ -57,7 +55,6 @@ 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 (..))
|
||||
@@ -100,7 +97,6 @@ data NtfServerConfig = NtfServerConfig
|
||||
-- | interval and file to save prometheus metrics
|
||||
prometheusInterval :: Maybe Int,
|
||||
prometheusMetricsFile :: FilePath,
|
||||
addressStats :: Maybe AddressStatsConfig,
|
||||
ntfServerVRange :: VersionRangeNTF,
|
||||
transportConfig :: TransportServerConfig,
|
||||
startOptions :: StartOptions
|
||||
@@ -121,56 +117,11 @@ data NtfEnv = NtfEnv
|
||||
random :: TVar ChaChaDRG,
|
||||
tlsServerCreds :: TLS.Credential,
|
||||
serverIdentity :: C.KeyHash,
|
||||
serverStats :: NtfServerStats,
|
||||
addrStats :: Maybe (ServerAddrStats NtfAddrCounter)
|
||||
serverStats :: NtfServerStats
|
||||
}
|
||||
|
||||
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, addressStats} = do
|
||||
newNtfServerEnv config@NtfServerConfig {pushQSize, smpAgentCfg, apnsConfig, dbStoreConfig, ntfCredentials, useServiceCreds} = do
|
||||
random <- C.newRandom
|
||||
store <- newNtfDbStore dbStoreConfig
|
||||
tlsServerCreds <- loadServerCredential ntfCredentials
|
||||
@@ -179,8 +130,7 @@ newNtfServerEnv config@NtfServerConfig {pushQSize, smpAgentCfg, apnsConfig, dbSt
|
||||
subscriber <- newNtfSubscriber smpAgentCfg dbService random
|
||||
pushServer <- newNtfPushServer pushQSize apnsConfig
|
||||
serverStats <- newNtfServerStats =<< getCurrentTime
|
||||
addrStats <- mapM (const newServerAddrStats) addressStats
|
||||
pure NtfEnv {config, subscriber, pushServer, store, random, tlsServerCreds, serverIdentity = C.KeyHash fp, serverStats, addrStats}
|
||||
pure NtfEnv {config, subscriber, pushServer, store, random, tlsServerCreds, serverIdentity = C.KeyHash fp, serverStats}
|
||||
where
|
||||
mkDbService g st = DBService {getCredentials, updateServiceId}
|
||||
where
|
||||
@@ -292,15 +242,14 @@ data NtfServerClient = NtfServerClient
|
||||
ntfThParams :: THandleParams NTFVersion 'TServer,
|
||||
connected :: TVar Bool,
|
||||
rcvActiveAt :: TVar SystemTime,
|
||||
sndActiveAt :: TVar SystemTime,
|
||||
ntfClientAddrStats :: Maybe (AddrStats NtfAddrCounter)
|
||||
sndActiveAt :: TVar SystemTime
|
||||
}
|
||||
|
||||
newNtfServerClient :: Natural -> THandleParams NTFVersion 'TServer -> SystemTime -> Maybe (AddrStats NtfAddrCounter) -> IO NtfServerClient
|
||||
newNtfServerClient qSize ntfThParams ts ntfClientAddrStats = do
|
||||
newNtfServerClient :: Natural -> THandleParams NTFVersion 'TServer -> SystemTime -> IO NtfServerClient
|
||||
newNtfServerClient qSize ntfThParams ts = do
|
||||
rcvQ <- newTBQueueIO qSize
|
||||
sndQ <- newTBQueueIO qSize
|
||||
connected <- newTVarIO True
|
||||
rcvActiveAt <- newTVarIO ts
|
||||
sndActiveAt <- newTVarIO ts
|
||||
return NtfServerClient {rcvQ, sndQ, ntfThParams, connected, rcvActiveAt, sndActiveAt, ntfClientAddrStats}
|
||||
return NtfServerClient {rcvQ, sndQ, ntfThParams, connected, rcvActiveAt, sndActiveAt}
|
||||
|
||||
@@ -141,8 +141,6 @@ 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
|
||||
@@ -218,7 +216,6 @@ 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
|
||||
|
||||
@@ -21,9 +21,7 @@ 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)
|
||||
@@ -51,8 +49,7 @@ data NtfRealTimeMetrics = NtfRealTimeMetrics
|
||||
ntfPendingServiceSubs :: NtfSMPSubMetrics,
|
||||
ntfPendingQueueSubs :: NtfSMPSubMetrics,
|
||||
smpSessionCount :: Int,
|
||||
apnsPushQLength :: Natural,
|
||||
addressHistograms :: Maybe (M.Map NtfAddrCounter AddrHistogram)
|
||||
apnsPushQLength :: Natural
|
||||
}
|
||||
|
||||
data NtfSMPWorkerMetrics = NtfSMPWorkerMetrics {ownServers :: [Text], otherServers :: Int}
|
||||
@@ -62,7 +59,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 <> clientAddresses <> info
|
||||
time <> tokens <> subscriptions <> notifications <> info
|
||||
where
|
||||
NtfServerMetrics {statsData, activeTokensCounts = psTkns, activeSubsCounts = psSubs, tokenCount, approxSubCount, lastNtfCount, rtsOptions} = sm
|
||||
NtfRealTimeMetrics
|
||||
@@ -75,8 +72,7 @@ ntfPrometheusMetrics sm rtm ts =
|
||||
ntfPendingServiceSubs,
|
||||
ntfPendingQueueSubs,
|
||||
smpSessionCount,
|
||||
apnsPushQLength,
|
||||
addressHistograms
|
||||
apnsPushQLength
|
||||
} = rtm
|
||||
NtfServerStatsData
|
||||
{ _fromTime,
|
||||
@@ -225,7 +221,6 @@ 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\
|
||||
|
||||
@@ -80,12 +80,6 @@ module Simplex.Messaging.Protocol
|
||||
ErrorType (..),
|
||||
CommandError (..),
|
||||
ProxyError (..),
|
||||
NameQuery (..),
|
||||
NameResponse (..),
|
||||
NameRegistration (..),
|
||||
NamePricing (..),
|
||||
USDCents (..),
|
||||
NameReservedReason (..),
|
||||
NameErrorType (..),
|
||||
BrokerErrorType (..),
|
||||
NetworkError (..),
|
||||
@@ -271,12 +265,12 @@ import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (.
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Names.Record
|
||||
import Simplex.Messaging.Names.Record (NameRecord (..))
|
||||
import Simplex.Messaging.Parsers
|
||||
import Simplex.Messaging.Protocol.Types
|
||||
import Simplex.Messaging.Server.QueueStore.QueueInfo
|
||||
import Simplex.Messaging.ServiceScheme
|
||||
import Simplex.Messaging.SimplexName (LabelHash, SimplexDomain (..), SimplexTLD (..), fullDomainName, labelHash)
|
||||
import Simplex.Messaging.SimplexName (SimplexDomain)
|
||||
import Simplex.Messaging.Transport
|
||||
import Simplex.Messaging.Transport.Client (TransportHost, TransportHosts (..))
|
||||
import Simplex.Messaging.Util (bshow, eitherToMaybe, safeDecodeUtf8, (<$?>))
|
||||
@@ -609,7 +603,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 :: NameQuery -> Command Resolver
|
||||
RSLV :: SimplexDomain -> Command Resolver
|
||||
|
||||
deriving instance Show (Command p)
|
||||
|
||||
@@ -745,8 +739,8 @@ data BrokerMsg where
|
||||
OK :: BrokerMsg
|
||||
ERR :: ErrorType -> BrokerMsg
|
||||
PONG :: BrokerMsg
|
||||
-- What the router knows about a SimpleX name.
|
||||
RNAME :: NameResponse -> BrokerMsg
|
||||
-- Resolved SimpleX name.
|
||||
RNAME :: NameRecord -> BrokerMsg
|
||||
deriving (Eq, Show)
|
||||
|
||||
data RcvMessage = RcvMessage
|
||||
@@ -1595,28 +1589,11 @@ 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 does not resolve; sent only to a session below v22
|
||||
| -- | the name is not registered (resolver returned not-found)
|
||||
NOT_FOUND
|
||||
| -- | backing resolver/RPC failure - contains the diagnostic detail
|
||||
RESOLVER {resolverErr :: Text}
|
||||
@@ -1845,7 +1822,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 q -> e (RSLV_, ' ', if v >= nameAvailSMPVersion then hashedQuery q else q)
|
||||
RSLV d -> e (RSLV_, ' ', d)
|
||||
where
|
||||
e :: Encoding a => a -> ByteString
|
||||
e = smpEncode
|
||||
@@ -1952,7 +1929,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
|
||||
CT SResolver RSLV_ -> Cmd SResolver . RSLV <$> _smpP <* A.takeByteString
|
||||
|
||||
fromProtocolError = fromProtocolError @SMPVersion @ErrorType @BrokerMsg
|
||||
{-# INLINE fromProtocolError #-}
|
||||
@@ -1995,11 +1972,7 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
|
||||
| v < clientNoticesSMPVersion -> BLOCKED info {notice = Nothing}
|
||||
_ -> err
|
||||
PONG -> e PONG_
|
||||
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)
|
||||
RNAME rec -> e (RNAME_, ' ', Tail $ LB.toStrict $ J.encode rec)
|
||||
where
|
||||
e :: Encoding a => a -> ByteString
|
||||
e = smpEncode
|
||||
@@ -2046,12 +2019,8 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
|
||||
OK_ -> pure OK
|
||||
ERR_ -> ERR <$> _smpP
|
||||
PONG_ -> pure PONG
|
||||
RNAME_
|
||||
| v >= nameAvailSMPVersion -> fmap RNAME . J.eitherDecodeStrict . unTail <$?> _smpP
|
||||
| otherwise -> fmap (RNAME . oldResponse) . J.eitherDecodeStrict . unTail <$?> _smpP
|
||||
RNAME_ -> fmap RNAME . 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
|
||||
@@ -2073,7 +2042,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
|
||||
@@ -2443,4 +2412,3 @@ $(J.deriveJSON defaultJSON ''BlockingInfo)
|
||||
|
||||
-- run deriveJSON in one TH splice to allow mutual instance
|
||||
$(concat <$> mapM @[] (J.deriveJSON (sumTypeJSON id)) [''ProxyError, ''NameErrorType, ''ErrorType])
|
||||
|
||||
|
||||
@@ -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, transportHost')
|
||||
import Simplex.Messaging.Client (ProtocolClient (thParams), ProtocolClientError (..), SMPClient, SMPClientError, clientHandlers, forwardSMPTransmission, smpProxyError, temporaryClientError)
|
||||
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.Server.AddressStats (AddrStats, ServerAddrStats (..), addAddrCounter, addressStatsThread, incAddrCounter, printTopAddresses, withAddrStats)
|
||||
import Simplex.Messaging.SimplexName (SimplexDomain)
|
||||
import Simplex.Messaging.Server.Control
|
||||
import Simplex.Messaging.Server.Env.STM as Env
|
||||
import Simplex.Messaging.Server.Expiration
|
||||
@@ -125,7 +125,6 @@ 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
|
||||
@@ -201,7 +200,6 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
|
||||
<> expireMessagesThread_ cfg
|
||||
<> serverStatsThread_ cfg
|
||||
<> prometheusMetricsThread_ cfg
|
||||
<> addressStatsThread_ cfg
|
||||
<> controlPortThread_ cfg
|
||||
)
|
||||
`finally` stopServer s
|
||||
@@ -219,12 +217,11 @@ 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 s h `runReaderT` env
|
||||
_ -> runClient srvCert srvSignKey t h `runReaderT` env
|
||||
where
|
||||
combinedCreds = TLSServerCredential {credential = smpCreds, sniCredential = Just httpCreds}
|
||||
_ ->
|
||||
runTransportServerState_ ss started tcpPort defaultSupportedParams TLSServerCredential {credential = smpCreds, sniCredential = Nothing} tCfg $ \s (_, h) ->
|
||||
runClient srvCert srvSignKey t s h `runReaderT` env
|
||||
runTransportServerState ss started tcpPort defaultSupportedParams smpCreds tCfg $ \h -> runClient srvCert srvSignKey t h `runReaderT` env
|
||||
|
||||
sigIntHandlerThread :: M s ()
|
||||
sigIntHandlerThread = do
|
||||
@@ -519,10 +516,6 @@ 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"
|
||||
@@ -707,7 +700,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}, addrStats} = do
|
||||
getRealTimeMetrics Env {sockets, msgStore_ = ms, server = srv@Server {subscribers, ntfSubscribers}} = do
|
||||
socketStats <- mapM (traverse getSocketStats) =<< readTVarIO sockets
|
||||
#if MIN_VERSION_base(4,18,0)
|
||||
threadsCount <- length <$> listThreads
|
||||
@@ -719,8 +712,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
|
||||
smpSubs <- getSubscribersMetrics subscribers
|
||||
ntfSubs <- getSubscribersMetrics ntfSubscribers
|
||||
loadedCounts <- loadedQueueCounts $ fromMsgStore ms
|
||||
addressHistograms <- mapM (readIORef . addrHistograms) addrStats
|
||||
pure RealTimeMetrics {socketStats, threadsCount, clientsCount, deliveredSubs, deliveredTimes, smpSubs, ntfSubs, loadedCounts, addressHistograms}
|
||||
pure RealTimeMetrics {socketStats, threadsCount, clientsCount, deliveredSubs, deliveredTimes, smpSubs, ntfSubs, loadedCounts}
|
||||
where
|
||||
getSubscribersMetrics ServerSubscribers {queueSubscribers, serviceSubscribers, totalServiceSubs, subClients} = do
|
||||
subsCount <- M.size <$> getSubscribedClients queueSubscribers
|
||||
@@ -741,21 +733,19 @@ 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 -> 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 ()
|
||||
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 ()
|
||||
|
||||
getClientService :: s -> TVar ChaChaDRG -> Int -> SMPServiceRole -> X.CertificateChain -> XV.Fingerprint -> ExceptT TransportError IO ServiceId
|
||||
getClientService ms g idSize role cert fp = do
|
||||
@@ -1051,10 +1041,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
|
||||
hPutStrLn h "saving server state..."
|
||||
unliftIO u $ saveServer False
|
||||
hPutStrLn h "server state saved!"
|
||||
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"
|
||||
CPHelp -> hPutStrLn h "commands: stats, stats-rts, clients, sockets, socket-threads, threads, server-info, delete, save, help, quit"
|
||||
CPQuit -> pure ()
|
||||
CPSkip -> pure ()
|
||||
where
|
||||
@@ -1075,13 +1062,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) => Maybe (AddrStats SMPAddrCounter) -> THandleSMP c 'TServer -> M s ()
|
||||
runClientTransport addrStats_ h@THandle {params = thParams@THandleParams {sessionId}} = do
|
||||
runClientTransport :: forall c s. (Transport c, MsgStoreClass s) => THandleSMP c 'TServer -> M s ()
|
||||
runClientTransport 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 addrStats_
|
||||
c <- liftIO $ newClient clientId q thParams ts
|
||||
runClientThreads c `finally` clientDisconnected c
|
||||
where
|
||||
runClientThreads :: Client s -> M s ()
|
||||
@@ -1158,7 +1145,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, clientAddrStats} = do
|
||||
receive h@THandle {params = THandleParams {thAuth, sessionId}} ms Client {rcvQ, sndQ, rcvActiveAt} = do
|
||||
labelMyThread . B.unpack $ "client $" <> encode sessionId <> " receive"
|
||||
sa <- asks serverActive
|
||||
stats <- asks serverStats
|
||||
@@ -1168,9 +1155,6 @@ 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
|
||||
@@ -1198,9 +1182,7 @@ 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 -> do
|
||||
forM_ clientAddrStats (`incAddrCounter` SACErrors)
|
||||
Left (corrId, entId, ERR e) <$ when (e == AUTH) incAuthStat
|
||||
VRFailed e -> Left (corrId, entId, ERR e) <$ when (e == AUTH) incAuthStat
|
||||
where
|
||||
incAuthStat = case command of
|
||||
SEND {} -> incStat $ msgSentAuth stats
|
||||
@@ -1395,7 +1377,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, clientAddrStats} = do
|
||||
clnt@Client {clientId, rcvQ, sndQ, msgQ, clientTHParams = thParams'@THandleParams {sessionId}, procThreads} = do
|
||||
labelMyThread . B.unpack $ "client $" <> encode sessionId <> " commands"
|
||||
let clntServiceId = (\THClientService {serviceId} -> serviceId) <$> (peerClientService =<< thAuth thParams')
|
||||
process batchSubs t acc@(rs, msgs) =
|
||||
@@ -1440,30 +1422,25 @@ client
|
||||
getRelay = do
|
||||
ProxyAgent {smpAgent = a} <- asks proxyAgent
|
||||
liftIO (getConnectedSMPServerClient a srv) >>= \case
|
||||
Just r -> Just <$> proxyServerResponse a SACPrxyConnected r
|
||||
Just r -> Just <$> proxyServerResponse a r
|
||||
Nothing ->
|
||||
forkProxiedCmd $
|
||||
liftIO (runExceptT (getSMPServerClient'' a srv) `E.catches` clientHandlers)
|
||||
>>= proxyServerResponse a SACPrxyNew
|
||||
proxyServerResponse :: SMPClientAgent 'Sender -> SMPAddrCounter -> Either SMPClientError (OwnServer, SMPClient) -> M s BrokerMsg
|
||||
proxyServerResponse a otherCounter smp_ = do
|
||||
>>= proxyServerResponse a
|
||||
proxyServerResponse :: SMPClientAgent 'Sender -> Either SMPClientError (OwnServer, SMPClient) -> M s BrokerMsg
|
||||
proxyServerResponse a 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 {} -> do
|
||||
incAddrStats $ proxyDestCounter own smp SACPrxyOwn SACPrxyOnion otherCounter
|
||||
r <$ inc own pSuccesses
|
||||
r -> do
|
||||
incAddrStats SACPrxyFailed
|
||||
r <$ inc own pErrorsCompat
|
||||
r@PKEY {} -> r <$ inc own pSuccesses
|
||||
r -> 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
|
||||
@@ -1483,24 +1460,16 @@ 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 <$ delivered
|
||||
Right r -> PRES r <$ inc own pSuccesses
|
||||
Left e -> ERR (smpProxyError e) <$ case e of
|
||||
PCEProtocolError {} -> delivered
|
||||
_ -> incAddrStats SACPfwdFailed >> inc own pErrorsOther
|
||||
Nothing -> incAddrStats SACPfwdFailed >> inc False pRequests >> inc False pErrorsConnect $> Just (ERR $ PROXY NO_SESSION)
|
||||
PCEProtocolError {} -> inc own pSuccesses
|
||||
_ -> inc own pErrorsOther
|
||||
Nothing -> 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
|
||||
@@ -1525,19 +1494,15 @@ 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 :: VersionSMP -> NamesEnv -> NameQuery -> M s BrokerMsg
|
||||
resolveNameMsg v nenv q = do
|
||||
resolveNameMsg :: NamesEnv -> SimplexDomain -> M s BrokerMsg
|
||||
resolveNameMsg nenv d = do
|
||||
st <- asks (rslvStats . serverStats)
|
||||
(selector, msg) <-
|
||||
liftIO (resolveName nenv q) <&> \case
|
||||
Right res -> (if answered (registration res) then rslvSucc else rslvNotFound, RNAME res)
|
||||
liftIO (resolveName nenv d) <&> \case
|
||||
Right rec -> (rslvSucc, RNAME rec)
|
||||
Left e@NOT_FOUND -> (rslvNotFound, ERR $ NAME e)
|
||||
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 ()
|
||||
@@ -1554,7 +1519,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 (thVersion thParams') nenv d)
|
||||
Just nenv -> forkCmd serverResolverConcurrency corrId NoEntity (resolveNameMsg 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
|
||||
@@ -2185,7 +2150,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 (thVersion clntTHParams) nenv d
|
||||
msg <- resolveNameMsg 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.
|
||||
|
||||
@@ -1,250 +0,0 @@
|
||||
{-# 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"
|
||||
@@ -44,8 +44,6 @@ module Simplex.Messaging.Server.CLI
|
||||
checkSavedFingerprint,
|
||||
iniTransports,
|
||||
iniDBOptions,
|
||||
iniAddressStats,
|
||||
addressStatsIniContent,
|
||||
printServerConfig,
|
||||
printServerTransports,
|
||||
printSMPServerConfig,
|
||||
@@ -75,14 +73,13 @@ 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, tshow, whenM)
|
||||
import Simplex.Messaging.Util (eitherToMaybe, whenM)
|
||||
import System.Directory (doesDirectoryExist, listDirectory, removeDirectoryRecursive, removePathForcibly)
|
||||
import System.Environment (lookupEnv)
|
||||
import System.Exit (exitFailure)
|
||||
@@ -438,19 +435,6 @@ 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
|
||||
|
||||
@@ -7,10 +7,8 @@ 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)
|
||||
@@ -30,7 +28,6 @@ data ControlProtocol
|
||||
| CPStatus SenderId
|
||||
| CPBlock SenderId BlockingInfo
|
||||
| CPUnblock SenderId
|
||||
| CPAddresses Text (Maybe Int)
|
||||
| CPSave
|
||||
| CPHelp
|
||||
| CPQuit
|
||||
@@ -52,7 +49,6 @@ 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"
|
||||
@@ -73,7 +69,6 @@ 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
|
||||
|
||||
@@ -31,8 +31,6 @@ module Simplex.Messaging.Server.Env.STM
|
||||
SubscribedClients,
|
||||
ProxyAgent (..),
|
||||
Client (..),
|
||||
SMPAddrCounter (..),
|
||||
smpCmdCounter,
|
||||
ClientId,
|
||||
ClientSub (..),
|
||||
Sub (..),
|
||||
@@ -113,7 +111,6 @@ 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
|
||||
@@ -186,7 +183,6 @@ 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
|
||||
@@ -289,8 +285,7 @@ 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
|
||||
addrStats :: Maybe (ServerAddrStats SMPAddrCounter)
|
||||
namesEnv :: Maybe NamesEnv -- public-namespace resolver, present when [NAMES] enable: on
|
||||
}
|
||||
|
||||
msgStore :: Env s -> s
|
||||
@@ -470,117 +465,9 @@ data Client s = Client
|
||||
connected :: TVar Bool,
|
||||
createdAt :: SystemTime,
|
||||
rcvActiveAt :: TVar SystemTime,
|
||||
sndActiveAt :: TVar SystemTime,
|
||||
clientAddrStats :: Maybe (AddrStats SMPAddrCounter)
|
||||
sndActiveAt :: TVar SystemTime
|
||||
}
|
||||
|
||||
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))
|
||||
@@ -633,8 +520,8 @@ newServerSubscribers = do
|
||||
pendingEvents <- newTVarIO IM.empty
|
||||
pure ServerSubscribers {subQ, queueSubscribers, serviceSubscribers, totalServiceSubs, subClients, pendingEvents}
|
||||
|
||||
newClient :: ClientId -> Natural -> THandleParams SMPVersion 'TServer -> SystemTime -> Maybe (AddrStats SMPAddrCounter) -> IO (Client s)
|
||||
newClient clientId qSize clientTHParams createdAt clientAddrStats = do
|
||||
newClient :: ClientId -> Natural -> THandleParams SMPVersion 'TServer -> SystemTime -> IO (Client s)
|
||||
newClient clientId qSize clientTHParams createdAt = do
|
||||
subscriptions <- TM.emptyIO
|
||||
ntfSubscriptions <- TM.emptyIO
|
||||
serviceSubscribed <- newTVarIO False
|
||||
@@ -669,8 +556,7 @@ newClient clientId qSize clientTHParams createdAt clientAddrStats = do
|
||||
connected,
|
||||
createdAt,
|
||||
rcvActiveAt,
|
||||
sndActiveAt,
|
||||
clientAddrStats
|
||||
sndActiveAt
|
||||
}
|
||||
|
||||
newSubscription :: SubscriptionThread -> STM Sub
|
||||
@@ -685,7 +571,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, addressStats} = do
|
||||
newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smpAgentCfg, information, messageExpiration, idleQueueInterval, msgQueueQuota, maxJournalMsgCount, maxJournalStateLines, namesConfig} = do
|
||||
serverActive <- newTVarIO True
|
||||
server <- newServer
|
||||
msgStore_ <- case serverStoreCfg of
|
||||
@@ -740,7 +626,6 @@ 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,
|
||||
@@ -757,8 +642,7 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp
|
||||
sockets,
|
||||
clientSeq,
|
||||
proxyAgent,
|
||||
namesEnv,
|
||||
addrStats
|
||||
namesEnv
|
||||
}
|
||||
where
|
||||
loadStoreLog :: StoreQueueClass q => (RecipientId -> QueueRec -> IO q) -> FilePath -> STMQueueStore q -> IO ()
|
||||
|
||||
@@ -578,7 +578,6 @@ 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,
|
||||
|
||||
@@ -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, addressStatsIniContent, onOff)
|
||||
import Simplex.Messaging.Server.CLI (SignAlgorithm, onOff)
|
||||
import Simplex.Messaging.Server.Env.STM
|
||||
import Simplex.Messaging.Server.Expiration (ExpirationConfig (..))
|
||||
import Simplex.Messaging.Server.Information (Entity (..), ServerPublicInfo (..))
|
||||
@@ -176,9 +176,7 @@ iniFileContent cfgPath logPath opts host basicAuth controlPortPwds =
|
||||
\disconnect = on\n"
|
||||
<> ("ttl = " <> tshow (ttl defaultInactiveClientExpiration) <> "\n")
|
||||
<> ("check_interval = " <> tshow (checkInterval defaultInactiveClientExpiration))
|
||||
<> "\n\n"
|
||||
<> addressStatsIniContent
|
||||
<> "\n\
|
||||
<> "\n\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")
|
||||
|
||||
@@ -110,9 +110,10 @@ 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)" (oldMsg, batchSize)
|
||||
DB.query db "CALL expire_old_messages(?,?,?,0,0,0)" (oldQueue, oldMsg, batchSize)
|
||||
where
|
||||
st = dbStore $ queueStore_ ms
|
||||
oldQueue = 0 :: Int64 -- expire all queues
|
||||
oldMsg = now - ttl
|
||||
batchSize = 10000 :: Int
|
||||
toMessageStats (expiredMsgsCount, storedMsgsCount, storedQueues) =
|
||||
|
||||
@@ -20,9 +20,7 @@ import Control.Logger.Simple (logError)
|
||||
import Data.Bifunctor (first)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeLatin1)
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Protocol (NameErrorType (..), NameQuery, NameResponse)
|
||||
import Simplex.Messaging.Protocol (NameErrorType (..), NameRecord)
|
||||
import Simplex.Messaging.Server.Names.HttpResolver
|
||||
( ResolverEnv,
|
||||
ResolverError (..),
|
||||
@@ -32,6 +30,7 @@ import Simplex.Messaging.Server.Names.HttpResolver
|
||||
newResolverEnv,
|
||||
resolveHttp,
|
||||
)
|
||||
import Simplex.Messaging.SimplexName (SimplexDomain, fullDomainName)
|
||||
import System.Timeout (timeout)
|
||||
|
||||
data NamesConfig = NamesConfig
|
||||
@@ -59,9 +58,9 @@ pingEndpoint :: NamesEnv -> IO (Either ResolverError ())
|
||||
pingEndpoint NamesEnv {resolverEnv, config} =
|
||||
fromMaybe (Left ResolverTimeout) <$> timeout (resolverTimeoutMs config * 1000) (healthHttp resolverEnv)
|
||||
|
||||
resolveName :: NamesEnv -> NameQuery -> IO (Either NameErrorType NameResponse)
|
||||
resolveName env q = do
|
||||
r <- E.try (timeout (resolverTimeoutMs (config env) * 1000) (fetch env q))
|
||||
resolveName :: NamesEnv -> SimplexDomain -> IO (Either NameErrorType NameRecord)
|
||||
resolveName env d = do
|
||||
r <- E.try (timeout (resolverTimeoutMs (config env) * 1000) (fetch env d))
|
||||
case r of
|
||||
Right result -> pure (fromMaybe (Left (RESOLVER "timeout")) result)
|
||||
Left e
|
||||
@@ -70,12 +69,14 @@ resolveName env q = do
|
||||
logError $ "[NAMES] resolver fetch raised " <> T.pack (E.displayException e)
|
||||
pure (Left (RESOLVER "resolver error"))
|
||||
|
||||
fetch :: NamesEnv -> NameQuery -> IO (Either NameErrorType NameResponse)
|
||||
fetch NamesEnv {resolverEnv} q =
|
||||
first mapResolverError <$> resolveHttp resolverEnv (decodeLatin1 $ smpEncode q)
|
||||
fetch :: NamesEnv -> SimplexDomain -> IO (Either NameErrorType NameRecord)
|
||||
fetch NamesEnv {resolverEnv} d =
|
||||
first mapResolverError <$> resolveHttp resolverEnv (fullDomainName d)
|
||||
|
||||
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"
|
||||
|
||||
@@ -8,12 +8,10 @@
|
||||
--
|
||||
-- The Python REST resolver (see scripts/resolver/snrc-resolve.py) exposes
|
||||
--
|
||||
-- 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
|
||||
-- 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
|
||||
--
|
||||
-- Boundary properties:
|
||||
-- * Response body read with `brReadSome maxResponseBytes` — adversarial
|
||||
@@ -59,7 +57,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 (NameResponse)
|
||||
import Simplex.Messaging.Names.Record (NameRecord)
|
||||
|
||||
data RpcAuth = AuthBearer Text | AuthBasic Text Text
|
||||
|
||||
@@ -110,12 +108,14 @@ authHeader = \case
|
||||
let encoded = BAE.convertToBase BAE.Base64 (encodeUtf8 u <> ":" <> encodeUtf8 p) :: ByteString
|
||||
in ("Authorization", "Basic " <> encoded)
|
||||
|
||||
-- | 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 =
|
||||
-- | 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 =
|
||||
(>>= first InvalidJson . J.eitherDecodeStrict . BL.toStrict)
|
||||
<$> httpGet env ("/v2/resolve/" <> B.unpack (urlEncode True (encodeUtf8 q)))
|
||||
<$> httpGet env ("/resolve/" <> B.unpack (urlEncode True (encodeUtf8 name)))
|
||||
|
||||
-- | GET <baseUrl>/health; success = reachable with status < 400. The body is
|
||||
-- size-capped but NOT decoded — the probe only checks reachability.
|
||||
|
||||
@@ -14,15 +14,12 @@ 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
|
||||
@@ -49,8 +46,7 @@ data RealTimeMetrics = RealTimeMetrics
|
||||
deliveredTimes :: TimeBuckets,
|
||||
smpSubs :: RTSubscriberMetrics,
|
||||
ntfSubs :: RTSubscriberMetrics,
|
||||
loadedCounts :: LoadedQueueCounts,
|
||||
addressHistograms :: Maybe (Map SMPAddrCounter AddrHistogram)
|
||||
loadedCounts :: LoadedQueueCounts
|
||||
}
|
||||
|
||||
data RTSubscriberMetrics = RTSubscriberMetrics
|
||||
@@ -63,7 +59,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 <> clientAddresses <> info
|
||||
time <> queues <> subscriptions <> messages <> ntfMessages <> ntfs <> relays <> services <> names <> info
|
||||
where
|
||||
ServerMetrics {statsData, activeQueueCounts = ps, activeNtfCounts = psNtf, entityCounts, rtsOptions} = sm
|
||||
RealTimeMetrics
|
||||
@@ -74,8 +70,7 @@ prometheusMetrics sm rtm ts =
|
||||
deliveredTimes,
|
||||
smpSubs,
|
||||
ntfSubs,
|
||||
loadedCounts,
|
||||
addressHistograms
|
||||
loadedCounts
|
||||
} = rtm
|
||||
ServerStatsData
|
||||
{ _fromTime,
|
||||
@@ -474,11 +469,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 resolved, or availability answered.\n\
|
||||
\# HELP simplex_smp_names_success NameRecord successfully resolved and returned.\n\
|
||||
\# TYPE simplex_smp_names_success counter\n\
|
||||
\simplex_smp_names_success " <> mshow _rslvSucc <> "\n# rslvSucc\n\
|
||||
\\n\
|
||||
\# HELP simplex_smp_names_not_found Answers a client below v22 reads as NOT_FOUND.\n\
|
||||
\# HELP simplex_smp_names_not_found Name not registered (resolver returned 404 / 400).\n\
|
||||
\# TYPE simplex_smp_names_not_found counter\n\
|
||||
\simplex_smp_names_not_found " <> mshow _rslvNotFound <> "\n# rslvNotFound\n\
|
||||
\\n\
|
||||
@@ -490,7 +485,6 @@ 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\
|
||||
|
||||
@@ -159,8 +159,7 @@ instance StoreQueueClass q => QueueStoreClass q (PostgresQueueStore q) where
|
||||
db
|
||||
[sql|
|
||||
SELECT
|
||||
-- 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) 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,
|
||||
|
||||
@@ -20,9 +20,7 @@ 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),
|
||||
("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)
|
||||
("20250915_queue_ids_hash", m20250915_queue_ids_hash, Just down_m20250915_queue_ids_hash)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
@@ -590,147 +588,3 @@ 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);
|
||||
|]
|
||||
|
||||
@@ -1,6 +1,5 @@
|
||||
|
||||
|
||||
|
||||
SET statement_timeout = 0;
|
||||
SET lock_timeout = 0;
|
||||
SET idle_in_transaction_session_timeout = 0;
|
||||
@@ -57,7 +56,7 @@ $$;
|
||||
|
||||
|
||||
|
||||
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)
|
||||
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)
|
||||
LANGUAGE plpgsql
|
||||
AS $$
|
||||
DECLARE
|
||||
@@ -74,6 +73,7 @@ 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,8 +397,7 @@ 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');
|
||||
);
|
||||
|
||||
|
||||
|
||||
@@ -442,8 +441,7 @@ 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');
|
||||
);
|
||||
|
||||
|
||||
|
||||
@@ -455,8 +453,7 @@ 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');
|
||||
);
|
||||
|
||||
|
||||
|
||||
@@ -497,18 +494,10 @@ 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);
|
||||
|
||||
|
||||
@@ -525,6 +514,10 @@ 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);
|
||||
|
||||
|
||||
@@ -556,4 +549,3 @@ ALTER TABLE ONLY smp_server.msg_queues
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -10,21 +10,14 @@ 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)
|
||||
@@ -77,20 +70,6 @@ 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
|
||||
@@ -129,15 +108,12 @@ instance Encoding SimplexDomain where
|
||||
smpP = strP
|
||||
|
||||
fullDomainName :: SimplexDomain -> Text
|
||||
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
|
||||
fullDomainName SimplexDomain {nameTLD, domain, subDomain} = T.intercalate "." (reverse subDomain ++ [domain] ++ tld')
|
||||
where
|
||||
tld' = case nameTLD of
|
||||
TLDSimplex -> ["simplex"]
|
||||
TLDTesting -> ["testing"]
|
||||
TLDWeb -> []
|
||||
|
||||
shortNameInfoStr :: SimplexNameInfo -> Text
|
||||
shortNameInfoStr = \case
|
||||
|
||||
@@ -53,7 +53,6 @@ module Simplex.Messaging.Transport
|
||||
rcvServiceSMPVersion,
|
||||
namesSMPVersion,
|
||||
serverInfoSMPVersion,
|
||||
nameAvailSMPVersion,
|
||||
simplexMQVersion,
|
||||
smpBlockSize,
|
||||
TransportConfig (..),
|
||||
@@ -176,7 +175,6 @@ 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)
|
||||
|
||||
data SMPVersion
|
||||
|
||||
@@ -213,11 +211,6 @@ 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
|
||||
|
||||
minClientSMPRelayVersion :: VersionSMP
|
||||
minClientSMPRelayVersion = VersionSMP 14
|
||||
|
||||
@@ -225,20 +218,20 @@ minServerSMPRelayVersion :: VersionSMP
|
||||
minServerSMPRelayVersion = VersionSMP 14
|
||||
|
||||
currentClientSMPRelayVersion :: VersionSMP
|
||||
currentClientSMPRelayVersion = VersionSMP 22
|
||||
currentClientSMPRelayVersion = VersionSMP 21
|
||||
|
||||
currentServerSMPRelayVersion :: VersionSMP
|
||||
currentServerSMPRelayVersion = VersionSMP 22
|
||||
currentServerSMPRelayVersion = VersionSMP 21
|
||||
|
||||
-- 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 (22)
|
||||
-- for this release because a proxied RSLV only carries availability from
|
||||
-- nameAvailSMPVersion (22), so the one-version anti-fingerprinting buffer does
|
||||
-- not apply yet; it reappears once the current version advances past 22.
|
||||
-- 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.
|
||||
proxiedSMPRelayVersion :: VersionSMP
|
||||
proxiedSMPRelayVersion = VersionSMP 22
|
||||
proxiedSMPRelayVersion = VersionSMP 20
|
||||
|
||||
-- minimal supported protocol version is 14
|
||||
supportedClientSMPRelayVRange :: VersionRangeSMP
|
||||
|
||||
@@ -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 ()) (\_ _ handler -> handler) $ \_sniUsed sessionId sessionALPN r sendResponse -> do
|
||||
runHTTP2Server started http2Port bufferSize serverSupported srvCreds Nothing transportConfig Nothing (const $ pure ()) $ \_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 ()) -> (Socket -> SessionId -> IO () -> IO ()) -> (SNICredentialUsed -> HTTP2ServerFunc) -> IO ()
|
||||
runHTTP2Server started port bufferSize srvSupported srvCreds httpCreds_ transportConfig expCfg_ clientFinished withConnection = runHTTP2ServerWith_ expCfg_ clientFinished bufferSize setup
|
||||
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
|
||||
where
|
||||
setup handler = do
|
||||
ss <- newSocketState
|
||||
let combinedCreds = TLSServerCredential {credential = srvCreds, sniCredential = httpCreds_}
|
||||
runTransportServerState_ ss started port srvSupported combinedCreds transportConfig $ \sock h@(_, tls) -> withConnection sock (tlsUniq tls) (handler h)
|
||||
runTransportServerState_ ss started port srvSupported combinedCreds transportConfig $ \_ -> handler
|
||||
|
||||
-- HTTP2 server can be run on both client and server TLS connections.
|
||||
runHTTP2ServerWith :: BufferSize -> ((TLS p -> IO ()) -> a) -> HTTP2ServerFunc -> a
|
||||
|
||||
@@ -53,7 +53,6 @@ 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
|
||||
@@ -363,7 +362,6 @@ 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
|
||||
@@ -419,18 +417,6 @@ 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
|
||||
@@ -473,9 +459,9 @@ testPqX3dhProposeAgain _ = do
|
||||
|
||||
compatibleRatchets :: (RatchetInitParams, x) -> (RatchetInitParams, x) -> Expectation
|
||||
compatibleRatchets
|
||||
(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
|
||||
(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
|
||||
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
|
||||
|
||||
@@ -204,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
|
||||
@@ -293,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)
|
||||
|
||||
@@ -442,9 +442,6 @@ 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)
|
||||
@@ -584,9 +581,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 "getConnectionVerifyCodes" $
|
||||
it "should return the same codes for both peers" $
|
||||
withSmpServer ps testConnectionVerifyCodes
|
||||
describe "getRatchetAdHash" $
|
||||
it "should return the same data for both peers" $
|
||||
withSmpServer ps testRatchetAdHash
|
||||
describe "Delivery receipts" $ do
|
||||
it "should send and receive delivery receipt" $ withSmpServer ps testDeliveryReceipts
|
||||
it "send delivery receipts concurrently with messages" $ testDeliveryReceiptsConcurrent ps
|
||||
@@ -758,7 +755,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
|
||||
@@ -987,12 +984,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
|
||||
@@ -1056,7 +1053,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
|
||||
@@ -1064,9 +1061,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
|
||||
@@ -1096,10 +1093,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
|
||||
@@ -1121,10 +1118,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
|
||||
@@ -1152,7 +1149,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
|
||||
|
||||
@@ -1195,11 +1192,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
|
||||
@@ -1219,10 +1216,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
|
||||
@@ -1247,12 +1244,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
|
||||
@@ -1293,10 +1290,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"
|
||||
@@ -1306,9 +1303,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 ()
|
||||
@@ -1318,9 +1315,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 ()
|
||||
@@ -1433,7 +1430,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
|
||||
@@ -1592,7 +1589,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
|
||||
@@ -1662,7 +1659,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
|
||||
@@ -1684,10 +1681,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
|
||||
@@ -1767,7 +1764,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
|
||||
@@ -1795,7 +1792,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
|
||||
@@ -1837,7 +1834,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
|
||||
@@ -1890,7 +1887,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
|
||||
@@ -2049,7 +2046,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
|
||||
@@ -2487,49 +2484,6 @@ 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
|
||||
@@ -2795,7 +2749,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
|
||||
@@ -3077,7 +3031,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
|
||||
@@ -3147,7 +3101,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"
|
||||
@@ -3175,7 +3129,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"
|
||||
@@ -3205,7 +3159,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
|
||||
@@ -3486,7 +3440,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
|
||||
@@ -4069,23 +4023,13 @@ testServerInformation =
|
||||
serverCountry = Nothing
|
||||
}
|
||||
|
||||
testConnectionVerifyCodes :: HasCallStack => IO ()
|
||||
testConnectionVerifyCodes =
|
||||
testRatchetAdHash :: HasCallStack => IO ()
|
||||
testRatchetAdHash =
|
||||
withAgentClients2 $ \a b -> runRight_ $ do
|
||||
(aId, bId) <- makeConnection a b
|
||||
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
|
||||
ad1 <- getConnectionRatchetAdHash a bId
|
||||
ad2 <- getConnectionRatchetAdHash b aId
|
||||
liftIO $ ad1 `shouldBe` ad2
|
||||
|
||||
testDeliveryReceipts :: HasCallStack => IO ()
|
||||
testDeliveryReceipts =
|
||||
@@ -4674,7 +4618,8 @@ testServerMultipleIdentities =
|
||||
testE2ERatchetParams12
|
||||
|
||||
testWaitForUserNetwork :: IO ()
|
||||
testWaitForUserNetwork = withAgent 1 aCfg initAgentServers testDB $ \a -> do
|
||||
testWaitForUserNetwork = do
|
||||
a <- getSMPAgentClient' 1 aCfg initAgentServers testDB
|
||||
noNetworkDelay a
|
||||
setUserNetworkInfo a $ UserNetworkInfo UNNone False
|
||||
networkDelay a 100000
|
||||
@@ -4691,7 +4636,8 @@ testWaitForUserNetwork = withAgent 1 aCfg initAgentServers testDB $ \a -> do
|
||||
aCfg = agentCfg {userNetworkInterval = 100000, userOfflineDelay = 0}
|
||||
|
||||
testDoNotResetOnlineToOffline :: IO ()
|
||||
testDoNotResetOnlineToOffline = withAgent 1 aCfg initAgentServers testDB $ \a -> do
|
||||
testDoNotResetOnlineToOffline = do
|
||||
a <- getSMPAgentClient' 1 aCfg initAgentServers testDB
|
||||
noNetworkDelay a
|
||||
setUserNetworkInfo a $ UserNetworkInfo UNWifi False
|
||||
networkDelay a 100000
|
||||
@@ -4712,7 +4658,8 @@ testDoNotResetOnlineToOffline = withAgent 1 aCfg initAgentServers testDB $ \a ->
|
||||
aCfg = agentCfg {userNetworkInterval = 100000, userOfflineDelay = 0.1}
|
||||
|
||||
testResumeMultipleThreads :: IO ()
|
||||
testResumeMultipleThreads = withAgent 1 aCfg initAgentServers testDB $ \a -> do
|
||||
testResumeMultipleThreads = do
|
||||
a <- getSMPAgentClient' 1 aCfg initAgentServers testDB
|
||||
noNetworkDelay a
|
||||
setUserNetworkInfo a $ UserNetworkInfo UNNone False
|
||||
vs <-
|
||||
|
||||
@@ -14,6 +14,7 @@ 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)
|
||||
@@ -21,7 +22,7 @@ import NamesResolverServer (memCfg, memCfg2, memProxyCfg, withNames)
|
||||
import qualified NamesResolverServer as NRS
|
||||
import SMPAgentClient
|
||||
import SMPClient
|
||||
import SMPNamesTests (availableBody, registeredBody, testNameRecord)
|
||||
import SMPNamesTests (testNameRecord)
|
||||
import Simplex.Messaging.Agent (resolveSimplexName)
|
||||
import Simplex.Messaging.Agent.Client (AgentClient)
|
||||
import Simplex.Messaging.Agent.Env.SQLite (InitialAgentServers (..), ServerCfg, ServerRoles (..), presetServerCfg)
|
||||
@@ -70,13 +71,13 @@ withNoNameServers k = withAgent 1 agentCfg (oneSrv (proxySrvCfg testSMPServer))
|
||||
resolveNameTests :: Spec
|
||||
resolveNameTests = do
|
||||
describe "direct path (SPMNever)" $
|
||||
it "a resolver error propagates as SMP host (NAME RESOLVER)" testDirectResolverErr
|
||||
it "404 propagates as SMP host (NAME NOT_FOUND)" testDirectNotFound
|
||||
describe "proxy path (SPMAlways)" $
|
||||
it "a resolver error propagates via proxy as SMP <proxyHost> (NAME RESOLVER)" testProxyResolverErr
|
||||
it "404 from resolver propagates via proxy as SMP <proxyHost> (NAME NOT_FOUND)" testProxyNotFound
|
||||
describe "TLDTesting path" $
|
||||
it "NAME RESOLVER for TLDTesting too" testTestingTldResolverErr
|
||||
it "NAME NOT_FOUND for TLDTesting too" testTestingTldNotFound
|
||||
describe "TLDWeb path" $
|
||||
it "NAME RESOLVER for TLDWeb too" testWebTldResolverErr
|
||||
it "NAME NOT_FOUND for TLDWeb too" testWebTldNotFound
|
||||
describe "no resolver configured" $
|
||||
it "answers NAME NO_RESOLVER" testNoResolver
|
||||
describe "no names servers (names role off everywhere)" $
|
||||
@@ -85,50 +86,38 @@ 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
|
||||
|
||||
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 =
|
||||
testDirectNotFound :: HasCallStack => IO ()
|
||||
testDirectNotFound =
|
||||
withDirectResolver (status404, "{}") $ \c -> do
|
||||
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDSimplex "alice" [])
|
||||
case r of
|
||||
Left (SMP _ (SMP.NAME (SMP.RESOLVER _))) -> pure ()
|
||||
_ -> expectationFailure $ "expected Left (SMP _ (NAME (RESOLVER _))), got: " <> show r
|
||||
Left (SMP _ (SMP.NAME SMP.NOT_FOUND)) -> pure ()
|
||||
_ -> expectationFailure $ "expected Left (SMP _ (NAME NOT_FOUND)), got: " <> show r
|
||||
|
||||
testProxyResolverErr :: HasCallStack => IO ()
|
||||
testProxyResolverErr =
|
||||
testProxyNotFound :: HasCallStack => IO ()
|
||||
testProxyNotFound =
|
||||
withProxyAndResolver (status404, "{}") $ \c -> do
|
||||
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDSimplex "alice" [])
|
||||
case r of
|
||||
Left (SMP host (SMP.NAME (SMP.RESOLVER _))) | testPort `isInfixOf` host -> pure ()
|
||||
_ -> expectationFailure $ "expected Left (SMP <proxyHost:" <> testPort <> "> (NAME (RESOLVER _))), got: " <> show r
|
||||
Left (SMP host (SMP.NAME SMP.NOT_FOUND)) | testPort `isInfixOf` host -> pure ()
|
||||
_ -> expectationFailure $ "expected Left (SMP <proxyHost:" <> testPort <> "> (NAME NOT_FOUND)), got: " <> show r
|
||||
|
||||
testTestingTldResolverErr :: HasCallStack => IO ()
|
||||
testTestingTldResolverErr =
|
||||
testTestingTldNotFound :: HasCallStack => IO ()
|
||||
testTestingTldNotFound =
|
||||
withDirectResolver (status404, "{}") $ \c -> do
|
||||
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDTesting "bob" [])
|
||||
case r of
|
||||
Left (SMP _ (SMP.NAME (SMP.RESOLVER _))) -> pure ()
|
||||
_ -> expectationFailure $ "expected Left (SMP _ (NAME (RESOLVER _))), got: " <> show r
|
||||
Left (SMP _ (SMP.NAME SMP.NOT_FOUND)) -> pure ()
|
||||
_ -> expectationFailure $ "expected Left (SMP _ (NAME NOT_FOUND)), got: " <> show r
|
||||
|
||||
testWebTldResolverErr :: HasCallStack => IO ()
|
||||
testWebTldResolverErr =
|
||||
testWebTldNotFound :: HasCallStack => IO ()
|
||||
testWebTldNotFound =
|
||||
withDirectResolver (status404, "{}") $ \c -> do
|
||||
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDWeb "example.com" [])
|
||||
case r of
|
||||
Left (SMP _ (SMP.NAME (SMP.RESOLVER _))) -> pure ()
|
||||
_ -> expectationFailure $ "expected Left (SMP _ (NAME (RESOLVER _))), got: " <> show r
|
||||
Left (SMP _ (SMP.NAME SMP.NOT_FOUND)) -> pure ()
|
||||
_ -> expectationFailure $ "expected Left (SMP _ (NAME NOT_FOUND)), got: " <> show r
|
||||
|
||||
testNoResolver :: HasCallStack => IO ()
|
||||
testNoResolver =
|
||||
@@ -156,8 +145,8 @@ testBackendError =
|
||||
|
||||
testDirectSuccess :: HasCallStack => IO ()
|
||||
testDirectSuccess =
|
||||
withDirectResolver (status200, registeredBody testNameRecord) $ \c -> do
|
||||
withDirectResolver (status200, J.encode testNameRecord) $ \c -> do
|
||||
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDSimplex "alice" [])
|
||||
case r of
|
||||
Right SMP.NameResponse {registration = SMP.NRRegistered {nameRecord}} -> nameRecord `shouldBe` testNameRecord
|
||||
_ -> expectationFailure $ "expected Right NRRegistered, got: " <> show r
|
||||
Right nr -> nr `shouldBe` testNameRecord
|
||||
_ -> expectationFailure $ "expected Right NameRecord, got: " <> show r
|
||||
|
||||
@@ -743,11 +743,9 @@ testGetNextRcvChunkToDownload st = do
|
||||
withTransaction st $ \db -> do
|
||||
Right Nothing <- getNextRcvChunkToDownload db xftpServer1 86400
|
||||
|
||||
Right fId1 <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing) True
|
||||
Right _ <- startPreparedRcvFile db fId1
|
||||
Right _ <- createRcvFile db g 1 rcvFileDescr1 "filepath" "filepath" (CryptoFile "filepath" Nothing) True
|
||||
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"
|
||||
@@ -785,7 +783,6 @@ testGetNextSndFileToPrepare st = do
|
||||
-- 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 Nothing
|
||||
Right _ <- startPreparedSndFile db fId2
|
||||
DB.execute_ db "UPDATE snd_files SET status = 'new' WHERE snd_file_id = 2"
|
||||
|
||||
-- Left e <- getNextSndFileToPrepare db 86400
|
||||
|
||||
@@ -71,7 +71,9 @@ initServers =
|
||||
}
|
||||
|
||||
testChooseDifferentOperator :: IO ()
|
||||
testChooseDifferentOperator = withAgent 1 agentCfg initServers testDB $ \c -> runRight_ $ do
|
||||
testChooseDifferentOperator = do
|
||||
c <- getSMPAgentClient' 1 agentCfg initServers testDB
|
||||
runRight_ $ do
|
||||
-- chooses the only operator with storage role
|
||||
srv1 <- withAgentEnv c $ getNextServer c 1 storageSrvs []
|
||||
liftIO $ srv1 == testOp1Srv1 || srv1 == testOp1Srv2 `shouldBe` True
|
||||
|
||||
@@ -108,8 +108,6 @@ 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 ()))
|
||||
@@ -236,8 +234,6 @@ 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]
|
||||
@@ -256,8 +252,6 @@ 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]
|
||||
|
||||
@@ -1,326 +0,0 @@
|
||||
{-# 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
|
||||
@@ -14,11 +14,8 @@ import Util
|
||||
retryIntervalTests :: Spec
|
||||
retryIntervalTests = do
|
||||
describe "Retry interval with 2 modes and lock" $ do
|
||||
testRetryIntervalSameMode withRetryNewLock2
|
||||
testRetryIntervalSwitchMode withRetryNewLock2
|
||||
describe "Retry interval with 2 modes" $ do
|
||||
testRetryIntervalSameMode withRetryInterval2
|
||||
testRetryIntervalSwitchMode withRetryInterval2
|
||||
testRetryIntervalSameMode
|
||||
testRetryIntervalSwitchMode
|
||||
describe "Foreground retry interval" $ do
|
||||
testRetryForeground
|
||||
testRetryToBackground
|
||||
@@ -44,18 +41,14 @@ testFastRI =
|
||||
maxInterval = 40000
|
||||
}
|
||||
|
||||
type WithRetry2 = RetryInterval2 -> (RI2State -> (RetryIntervalMode -> IO ()) -> IO ()) -> IO ()
|
||||
|
||||
withRetryNewLock2 :: WithRetry2
|
||||
withRetryNewLock2 ri action = newEmptyTMVarIO >>= \lock -> withRetryLock2 ri lock action
|
||||
|
||||
testRetryIntervalSameMode :: WithRetry2 -> Spec
|
||||
testRetryIntervalSameMode withRetry =
|
||||
testRetryIntervalSameMode :: Spec
|
||||
testRetryIntervalSameMode =
|
||||
it "should increase elapased time and interval when the mode stays the same" $ do
|
||||
lock <- newEmptyTMVarIO
|
||||
intervals <- newTVarIO []
|
||||
reportedIntervals <- newTVarIO []
|
||||
ts <- newTVarIO =<< getCurrentTime
|
||||
withRetry testRI $ \(RI2State slow fast) loop -> do
|
||||
withRetryLock2 testRI lock $ \(RI2State slow fast) loop -> do
|
||||
ints <- addInterval intervals ts
|
||||
atomically $ modifyTVar' reportedIntervals ((slow, fast) :)
|
||||
when (length ints < 9) $ loop RIFast
|
||||
@@ -72,13 +65,14 @@ testRetryIntervalSameMode withRetry =
|
||||
(20000, 40000)
|
||||
]
|
||||
|
||||
testRetryIntervalSwitchMode :: WithRetry2 -> Spec
|
||||
testRetryIntervalSwitchMode withRetry =
|
||||
testRetryIntervalSwitchMode :: Spec
|
||||
testRetryIntervalSwitchMode =
|
||||
it "should increase elapased time and interval when the mode switches" $ do
|
||||
lock <- newEmptyTMVarIO
|
||||
intervals <- newTVarIO []
|
||||
reportedIntervals <- newTVarIO []
|
||||
ts <- newTVarIO =<< getCurrentTime
|
||||
withRetry testRI $ \(RI2State slow fast) loop -> do
|
||||
withRetryLock2 testRI lock $ \(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
|
||||
|
||||
@@ -47,12 +47,10 @@ 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, "{}")
|
||||
("v2" : "resolve" : _) -> (st, body)
|
||||
("resolve" : _) -> (st, body)
|
||||
_ -> (notFound404, "{}")
|
||||
|
||||
testNamesConfig :: Int -> NamesConfig
|
||||
|
||||
@@ -48,7 +48,6 @@ 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
|
||||
@@ -156,7 +155,6 @@ ntfServerCfg =
|
||||
serverStatsBackupFile = Nothing,
|
||||
prometheusInterval = Nothing,
|
||||
prometheusMetricsFile = ntfTestPrometheusMetricsFile,
|
||||
addressStats = Just AddressStatsConfig {period = 1},
|
||||
ntfServerVRange = supportedServerNTFVRange,
|
||||
transportConfig = mkTransportServerConfig True (Just alpnSupportedNTFHandshakes) False,
|
||||
startOptions = defaultStartOptions
|
||||
|
||||
+16
-136
@@ -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,18 +26,14 @@ import SMPClient
|
||||
import Simplex.Messaging.Client
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding.String (strDecode)
|
||||
import SMPNamesTests (availableBody, registeredBody, reservedBody, resolved, testNameRecord, testPricing)
|
||||
import SMPNamesTests (testNameRecord)
|
||||
import Simplex.Messaging.Protocol
|
||||
( BrokerMsg (..),
|
||||
Cmd (..),
|
||||
Command (..),
|
||||
CorrId (..),
|
||||
ErrorType (..),
|
||||
NameQuery (..),
|
||||
NameRegistration (..),
|
||||
NameResponse (..),
|
||||
NameErrorType (..),
|
||||
NameReservedReason (..),
|
||||
SParty (..),
|
||||
Transmission,
|
||||
TransmissionForAuth (..),
|
||||
@@ -61,11 +57,6 @@ 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 _ ->
|
||||
@@ -74,7 +65,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 (NQDomain d)))
|
||||
let TransmissionForAuth {tToSend} = encodeTransmissionForAuth params (CorrId corrId, NoEntity, Cmd SResolver (RSLV d))
|
||||
[Right ()] <- tPut h (Right (Nothing, tToSend) :| [])
|
||||
r :| _ <- tGetClient h
|
||||
pure r
|
||||
@@ -82,36 +73,23 @@ sendRslv h@THandle {params} corrId d = do
|
||||
rslvTests :: Spec
|
||||
rslvTests = do
|
||||
describe "RSLV direct (non-forwarded)" $ do
|
||||
it "resolver without the v2 route (404) -> NAME RESOLVER, not NOT_FOUND" testRslvBackendNotFound
|
||||
it "resolver replies 404 -> NAME NOT_FOUND (reached, not CMD PROHIBITED)" 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 RESOLVER))" testRslvForwarded
|
||||
it "PFWD-wrapped RSLV reaches resolver via proxy (PCEProtocolError (NAME NOT_FOUND))" 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 (RESOLVER "HTTP 404")))
|
||||
resp `shouldBe` Right (ERR (NAME NOT_FOUND))
|
||||
|
||||
testRslvBackendHttpErr :: IO ()
|
||||
testRslvBackendHttpErr =
|
||||
@@ -129,7 +107,7 @@ testRslvDisabled =
|
||||
|
||||
testRslvVersion :: IO ()
|
||||
testRslvVersion =
|
||||
withResolverServer (status200, registeredBody testNameRecord) $ do
|
||||
withResolverServer (status200, J.encode testNameRecord) $ do
|
||||
g <- C.newRandom
|
||||
ts <- getCurrentTime
|
||||
let srv = SMPServer testHost testPort testKeyHash
|
||||
@@ -141,7 +119,7 @@ testRslvVersion =
|
||||
Left (PCETransportError TEVersion) -> pure ()
|
||||
_ -> expectationFailure $ "expected Left (PCETransportError TEVersion), got: " <> show r
|
||||
|
||||
forwardedResolveAlice :: IO (Either SMPClientError (Either ProxyClientError SMP.NameResponse))
|
||||
forwardedResolveAlice :: IO (Either SMPClientError (Either ProxyClientError SMP.NameRecord))
|
||||
forwardedResolveAlice = do
|
||||
g <- C.newRandom
|
||||
ts <- getCurrentTime
|
||||
@@ -157,123 +135,25 @@ testRslvForwarded :: IO ()
|
||||
testRslvForwarded =
|
||||
withProxyAndResolver (status404, "{}") $
|
||||
forwardedResolveAlice >>= \r -> case r of
|
||||
Left (PCEProtocolError (SMP.NAME (SMP.RESOLVER _))) -> pure ()
|
||||
_ -> expectationFailure $ "expected Left (PCEProtocolError (NAME (RESOLVER _))), got: " <> show r
|
||||
Left (PCEProtocolError (SMP.NAME SMP.NOT_FOUND)) -> pure ()
|
||||
_ -> expectationFailure $ "expected Left (PCEProtocolError (NAME NOT_FOUND)), got: " <> show r
|
||||
|
||||
testRslvForwardedSuccess :: IO ()
|
||||
testRslvForwardedSuccess =
|
||||
withProxyAndResolver (status200, registeredBody testNameRecord) $
|
||||
withProxyAndResolver (status200, J.encode testNameRecord) $
|
||||
forwardedResolveAlice >>= \r -> case r of
|
||||
Right (Right NameResponse {registration = NRRegistered {nameRecord}}) -> nameRecord `shouldBe` testNameRecord
|
||||
_ -> expectationFailure $ "expected Right (Right NRRegistered), got: " <> show r
|
||||
Right (Right nr) -> nr `shouldBe` testNameRecord
|
||||
_ -> expectationFailure $ "expected Right (Right NameRecord), got: " <> show r
|
||||
|
||||
testRslvSuccess :: IO ()
|
||||
testRslvSuccess =
|
||||
withResolverServer (status200, registeredBody testNameRecord) $
|
||||
withResolverServer (status200, J.encode testNameRecord) $
|
||||
testSMPClient @TLS $ \h -> do
|
||||
(corrId, _entId, resp) <- sendRslv h "rs07" (domain "alice.simplex")
|
||||
corrId `shouldBe` CorrId "rs07"
|
||||
case resp of
|
||||
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
|
||||
Right (RNAME nr) -> nr `shouldBe` testNameRecord
|
||||
_ -> expectationFailure $ "expected Right (RNAME ..), got: " <> show resp
|
||||
|
||||
runExceptT' :: Show e => ExceptT e IO a -> IO a
|
||||
runExceptT' a = runExceptT a >>= either (fail . show) pure
|
||||
|
||||
@@ -18,7 +18,6 @@ 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 qualified Data.X509 as X
|
||||
import qualified Data.X509.Validation as XV
|
||||
@@ -32,19 +31,16 @@ import qualified Simplex.Messaging.Crypto as C
|
||||
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
|
||||
@@ -88,12 +84,6 @@ ntfTestPort = "6001"
|
||||
ntfTestPort2 :: ServiceName
|
||||
ntfTestPort2 = "6002"
|
||||
|
||||
testControlPort :: ServiceName
|
||||
testControlPort = "5226"
|
||||
|
||||
testControlPortUserAuth :: BasicAuth
|
||||
testControlPortUserAuth = "user_password"
|
||||
|
||||
testKeyHash :: C.KeyHash
|
||||
testKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI="
|
||||
|
||||
@@ -271,7 +261,6 @@ cfgMS msType = withStoreCfg (testServerStoreConfig msType) $ \serverStoreCfg ->
|
||||
serverStatsBackupFile = Nothing,
|
||||
prometheusInterval = Nothing,
|
||||
prometheusMetricsFile = testPrometheusMetricsFile,
|
||||
addressStats = Just AddressStatsConfig {period = 1},
|
||||
pendingENDInterval = 500000,
|
||||
ntfDeliveryInterval = 200000,
|
||||
smpCredentials =
|
||||
@@ -407,22 +396,6 @@ 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
|
||||
|
||||
|
||||
+16
-130
@@ -3,7 +3,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module SMPNamesTests (smpNamesTests, testNameRecord, testPricing, registeredBody, availableBody, reservedBody, responseBody, resolved) where
|
||||
module SMPNamesTests (smpNamesTests, testNameRecord) where
|
||||
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
@@ -11,14 +11,13 @@ 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 (Command (..), ErrorType (..), NameErrorType (..), NamePricing (..), NameQuery (..), NameRecord (..), NameRegistration (..), NameResponse (..), NameReservedReason (..), ProtocolEncoding (..), USDCents (..))
|
||||
import Simplex.Messaging.Protocol (ErrorType (..), NameErrorType (..), NameRecord (..))
|
||||
import Simplex.Messaging.Server.Main (validateUrl)
|
||||
import Simplex.Messaging.Server.Names
|
||||
( NamesConfig (..),
|
||||
@@ -28,9 +27,7 @@ import Simplex.Messaging.Server.Names
|
||||
resolveName,
|
||||
)
|
||||
import Simplex.Messaging.Server.Names.HttpResolver (ResolverError (..))
|
||||
import Simplex.Messaging.SimplexName (SimplexDomain (..), SimplexTLD (..), labelHash)
|
||||
import Simplex.Messaging.SystemTime (RoundedSystemTime (..))
|
||||
import Simplex.Messaging.Transport (nameAvailSMPVersion, serverInfoSMPVersion)
|
||||
import Simplex.Messaging.SimplexName (SimplexDomain (..), SimplexTLD (..))
|
||||
import Test.Hspec
|
||||
|
||||
testNameRecord :: NameRecord
|
||||
@@ -50,41 +47,12 @@ 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
|
||||
|
||||
@@ -133,87 +101,8 @@ 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
|
||||
@@ -249,26 +138,23 @@ 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 the registration on 200 OK" $
|
||||
withResolverServer (resolveResp status200 (registeredBody testNameRecord)) $ \port _ -> do
|
||||
it "returns NameRecord on 200 OK" $
|
||||
withResolverServer (resolveResp status200 (J.encode testNameRecord)) $ \port _ -> do
|
||||
env <- newNamesEnv (testNamesConfig port)
|
||||
resolveName env aliceDomain `shouldReturn` Right (resolved registeredAlice)
|
||||
resolveName env aliceDomain `shouldReturn` Right testNameRecord
|
||||
|
||||
-- /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)" $
|
||||
it "returns NOT_FOUND on 404" $
|
||||
withResolverServer (resolveResp status404 "{}") $ \port _ -> do
|
||||
env <- newNamesEnv (testNamesConfig port)
|
||||
resolveName env aliceDomain `shouldReturn` Left (RESOLVER "HTTP 404")
|
||||
resolveName env aliceDomain `shouldReturn` Left NOT_FOUND
|
||||
|
||||
it "returns RESOLVER on 400 (TLD not configured)" $
|
||||
it "returns NOT_FOUND on 400 (unknown TLD)" $
|
||||
withResolverServer (resolveResp status400 "{}") $ \port _ -> do
|
||||
env <- newNamesEnv (testNamesConfig port)
|
||||
resolveName env aliceDomain `shouldReturn` Left (RESOLVER "HTTP 400")
|
||||
resolveName env aliceDomain `shouldReturn` Left NOT_FOUND
|
||||
|
||||
it "returns RESOLVER on 502 (upstream failure)" $
|
||||
withResolverServer (resolveResp status502 "{}") $ \port _ -> do
|
||||
@@ -285,31 +171,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 NameRegistration shape" $
|
||||
it "returns RESOLVER when JSON parses but isn't a NameRecord 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 (registeredBody testNameRecord)) $ \port _ -> do
|
||||
withResolverServerDelayed 1500 (resolveResp status200 (J.encode 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 (registeredBody testNameRecord)) $ \port reqs -> do
|
||||
withResolverServer (resolveResp status200 (J.encode 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 (registeredBody testNameRecord)) $ \port reqs -> do
|
||||
withResolverServer (resolveResp status200 (J.encode testNameRecord)) $ \port reqs -> do
|
||||
env <- newNamesEnv (testNamesConfig port)
|
||||
_ <- resolveName env aliceDomain
|
||||
readIORef reqs `shouldReturn` [["v2", "resolve", "alice.simplex"]]
|
||||
readIORef reqs `shouldReturn` [["resolve", "alice.simplex"]]
|
||||
|
||||
where
|
||||
aliceDomain = NQDomain SimplexDomain {nameTLD = TLDSimplex, domain = "alice", subDomain = []}
|
||||
aliceDomain = SimplexDomain {nameTLD = TLDSimplex, domain = "alice", subDomain = []}
|
||||
|
||||
healthSpec :: Spec
|
||||
healthSpec = do
|
||||
|
||||
+3
-27
@@ -33,13 +33,11 @@ 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
|
||||
@@ -151,29 +149,7 @@ 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
|
||||
@@ -253,7 +229,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
|
||||
@@ -309,7 +285,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 <-
|
||||
@@ -368,7 +344,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
|
||||
|
||||
@@ -47,7 +47,6 @@ 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)
|
||||
@@ -97,7 +96,6 @@ 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
|
||||
@@ -1256,27 +1254,6 @@ 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
|
||||
|
||||
@@ -7,7 +7,6 @@ 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
|
||||
@@ -84,7 +83,6 @@ 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
|
||||
|
||||
+1
-53
@@ -34,7 +34,7 @@ import Simplex.FileTransfer.Server.Env (AFStoreType, XFTPServerConfig (..), defa
|
||||
import Simplex.FileTransfer.Server.Store (STMFileStore)
|
||||
import Simplex.FileTransfer.Transport (XFTPErrorType (AUTH))
|
||||
import Simplex.FileTransfer.Types (RcvFileId, SndFileId)
|
||||
import Simplex.Messaging.Agent (AgentClient, testProtocolServer, xftpDeleteRcvFile, xftpDeleteSndFileInternal, xftpDeleteSndFileRemote, xftpPrepareReceiveFile, xftpPrepareSendFile, xftpReceiveFile, xftpSendDescription, xftpStartReceiveFile, xftpStartSendFile, xftpStartWorkers)
|
||||
import Simplex.Messaging.Agent (AgentClient, testProtocolServer, xftpDeleteRcvFile, xftpDeleteSndFileInternal, xftpDeleteSndFileRemote, xftpReceiveFile, xftpSendDescription, xftpStartWorkers)
|
||||
import qualified Simplex.Messaging.Agent as XA
|
||||
import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..))
|
||||
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, xftpCfg)
|
||||
@@ -84,8 +84,6 @@ xftpAgentTests =
|
||||
it "should send and receive with encrypted local files" testXFTPAgentSendReceiveEncrypted
|
||||
it "should send and receive large file with a redirect" testXFTPAgentSendReceiveRedirect
|
||||
it "should send and receive small file without a redirect" testXFTPAgentSendReceiveNoRedirect
|
||||
it "should receive prepared file only after it is started" testXFTPAgentPrepareReceive
|
||||
it "should send prepared file only after it is started" testXFTPAgentPrepareSend
|
||||
it "should extend storage time with an entitlement proof and report the granted expiry" $ \_ -> testXFTPAgentEntitlement
|
||||
describe "sending and receiving with version negotiation" $ beforeWith (const (pure ())) testXFTPAgentSendReceiveMatrix
|
||||
it "should resume receiving file after restart" $ \_ -> testXFTPAgentReceiveRestore
|
||||
@@ -280,56 +278,6 @@ testXFTPAgentSendReceiveNoRedirect = withXFTPServer $ do
|
||||
inBytes <- B.readFile filePathIn
|
||||
B.readFile out `shouldReturn` inBytes
|
||||
|
||||
testXFTPAgentPrepareReceive :: HasCallStack => AFStoreType -> IO ()
|
||||
testXFTPAgentPrepareReceive = withXFTPServer $ do
|
||||
filePath <- createRandomFile
|
||||
(_, _, rfd1, rfd2) <- withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ testSend sndr filePath
|
||||
rfId2 <- withAgent 2 agentCfg initAgentServers testDB2 $ \rcp -> runRight $ do
|
||||
xftpStartWorkers rcp (Just recipientFiles)
|
||||
rfId1 <- xftpReceiveFile rcp 1 rfd1 Nothing True
|
||||
rfId2 <- xftpPrepareReceiveFile rcp 1 rfd2 Nothing True
|
||||
rfProgress rcp $ mb 18
|
||||
("", rfId1', RFDONE _) <- rfGet rcp
|
||||
liftIO $ do
|
||||
rfId1' `shouldBe` rfId1
|
||||
timeout 300000 (rfGet rcp) `shouldReturn` Nothing
|
||||
pure rfId2
|
||||
withAgent 3 agentCfg initAgentServers testDB2 $ \rcp' -> runRight_ $ do
|
||||
xftpStartWorkers rcp' (Just recipientFiles)
|
||||
liftIO $ timeout 300000 (rfGet rcp') `shouldReturn` Nothing
|
||||
xftpStartReceiveFile rcp' rfId2
|
||||
rfProgress rcp' $ mb 18
|
||||
("", rfId2', RFDONE path) <- rfGet rcp'
|
||||
liftIO $ do
|
||||
rfId2' `shouldBe` rfId2
|
||||
file <- B.readFile filePath
|
||||
B.readFile path `shouldReturn` file
|
||||
|
||||
testXFTPAgentPrepareSend :: HasCallStack => AFStoreType -> IO ()
|
||||
testXFTPAgentPrepareSend = withXFTPServer $ do
|
||||
filePath1 <- createRandomFile' "testfile1"
|
||||
filePath2 <- createRandomFile' "testfile2"
|
||||
sfId2 <- withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ do
|
||||
xftpStartWorkers sndr (Just senderFiles)
|
||||
sfId1 <- xftpSendFile sndr 1 (CF.plain filePath1) 1
|
||||
sfId2 <- xftpPrepareSendFile sndr 1 (CF.plain filePath2) 1 Nothing
|
||||
sfProgress sndr $ mb 18
|
||||
("", sfId1', SFDONE _ _) <- sfGet sndr
|
||||
liftIO $ do
|
||||
sfId1' `shouldBe` sfId1
|
||||
timeout 300000 (sfGet sndr) `shouldReturn` Nothing
|
||||
pure sfId2
|
||||
rfd <- withAgent 2 agentCfg initAgentServers testDB $ \sndr' -> runRight $ do
|
||||
xftpStartWorkers sndr' (Just senderFiles)
|
||||
liftIO $ timeout 300000 (sfGet sndr') `shouldReturn` Nothing
|
||||
xftpStartSendFile sndr' sfId2
|
||||
sfProgress sndr' $ mb 18
|
||||
("", sfId2', SFDONE _ [rfd]) <- sfGet sndr'
|
||||
liftIO $ sfId2' `shouldBe` sfId2
|
||||
pure rfd
|
||||
withAgent 3 agentCfg initAgentServers testDB2 $ \rcp ->
|
||||
runRight_ . void $ testReceive rcp rfd filePath2
|
||||
|
||||
testXFTPAgentSendReceiveMatrix :: Spec
|
||||
testXFTPAgentSendReceiveMatrix = do
|
||||
describe "old server" $ do
|
||||
|
||||
@@ -24,7 +24,6 @@ import qualified Simplex.Messaging.Agent as A
|
||||
import Simplex.Messaging.Agent.Protocol (UserId)
|
||||
import Simplex.Messaging.Crypto.File (CryptoFile)
|
||||
import Simplex.Messaging.Protocol (XFTPServer)
|
||||
import Simplex.Messaging.Server.AddressStats (AddressStatsConfig (..))
|
||||
import Simplex.Messaging.Transport.HTTP2 (httpALPN)
|
||||
import Simplex.Messaging.Transport.Server
|
||||
import Test.Hspec hiding (fit, it)
|
||||
@@ -209,7 +208,6 @@ testXFTPServerConfig =
|
||||
serverStatsBackupFile = Nothing,
|
||||
prometheusInterval = Nothing,
|
||||
prometheusMetricsFile = xftpTestPrometheusMetricsFile,
|
||||
addressStats = Just AddressStatsConfig {period = 1},
|
||||
transportConfig = mkTransportServerConfig True (Just alpnSupportedXFTPhandshakes) False,
|
||||
responseDelay = 0,
|
||||
webStaticPath = Nothing
|
||||
|
||||
+51
-22
@@ -28,7 +28,6 @@ import qualified Data.X509 as X
|
||||
import Data.X509.Validation (Fingerprint (..), getFingerprint)
|
||||
import Network.HPACK.Token (tokenKey)
|
||||
import qualified Network.HTTP2.Client as H2
|
||||
import SMPClient (controlPortCommand, testControlPort, testControlPortUserAuth, withControlPort)
|
||||
import ServerTests (logSize)
|
||||
import Simplex.FileTransfer.Client hiding (createXFTPChunk)
|
||||
import qualified Simplex.FileTransfer.Client as A
|
||||
@@ -40,8 +39,7 @@ import Simplex.Messaging.Client (ProtocolClientError (..))
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import qualified Simplex.Messaging.Crypto.Lazy as LC
|
||||
import Simplex.Messaging.Encoding (smpDecode, smpEncode)
|
||||
import Simplex.Messaging.Protocol (BasicAuth (..), EntityId (..), RecipientId, SenderId, pattern NoEntity)
|
||||
import Simplex.Messaging.Server.AddressStats (AddressStatsConfig (..), defaultAddressStatsPeriod)
|
||||
import Simplex.Messaging.Protocol (BasicAuth, EntityId (..), RecipientId, SenderId, pattern NoEntity)
|
||||
import Simplex.Messaging.Server.Expiration (ExpirationConfig (..))
|
||||
import Simplex.Messaging.Transport (CertChainPubKey (..), TLS (..), TransportPeer (..), defaultSupportedParams, defaultSupportedParamsHTTPS)
|
||||
import Simplex.Messaging.Transport.Client (TransportClientConfig (..), TransportHost (..), defaultTransportClientConfig, runTLSTransportClient)
|
||||
@@ -65,12 +63,13 @@ xftpServerTests =
|
||||
it "should create, add recipients, upload and receive file chunk" testFileChunkDeliveryAddRecipients
|
||||
it "should delete file chunk (1 client)" testFileChunkDelete
|
||||
it "should delete file chunk (2 clients)" testFileChunkDelete2
|
||||
it "should acknowledge file chunk reception (1 client)" testFileChunkAck
|
||||
it "should acknowledge file chunk reception (2 clients)" testFileChunkAck2
|
||||
it "should not allow chunks of wrong size" testWrongChunkSize
|
||||
it "should expire chunks after set interval" testFileChunkExpiration
|
||||
it "should disconnect inactive clients" testInactiveClientExpiration
|
||||
it "should not allow uploading chunks after specified storage quota" testFileStorageQuota
|
||||
it "should store file records to log and restore them after server restart" testFileLog
|
||||
it "should count commands, transfers and recipients by client address" testFileAddressStats
|
||||
describe "XFTP basic auth" $ do
|
||||
-- allow FNEW | server auth | clnt auth | success
|
||||
it "prohibited without basic auth" $ testFileBasicAuth True (Just "pwd") Nothing False
|
||||
@@ -185,6 +184,33 @@ runTestFileChunkDelete s r = do
|
||||
deleteXFTPChunk s spKey sId
|
||||
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
|
||||
|
||||
testFileChunkAck :: AFStoreType -> Expectation
|
||||
testFileChunkAck = xftpTest $ \c -> runRight_ $ runTestFileChunkAck c c
|
||||
|
||||
testFileChunkAck2 :: AFStoreType -> Expectation
|
||||
testFileChunkAck2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkAck s r
|
||||
|
||||
runTestFileChunkAck :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO ()
|
||||
runTestFileChunkAck s r = do
|
||||
g <- liftIO C.newRandom
|
||||
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
(rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
||||
bytes <- liftIO $ createTestChunk testChunkPath
|
||||
digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
|
||||
let file = FileInfo {sndKey, size = chSize, digest}
|
||||
chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
|
||||
(sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] Nothing
|
||||
uploadXFTPChunk s spKey sId chunkSpec
|
||||
|
||||
downloadXFTPChunk g r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
|
||||
liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
|
||||
ackXFTPChunk r rpKey rId
|
||||
liftIO $ readChunk sId `shouldReturn` bytes
|
||||
downloadXFTPChunk g r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest)
|
||||
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
|
||||
ackXFTPChunk r rpKey rId
|
||||
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
|
||||
|
||||
testWrongChunkSize :: AFStoreType -> Expectation
|
||||
testWrongChunkSize = xftpTest $ \c -> do
|
||||
g <- C.newRandom
|
||||
@@ -310,12 +336,32 @@ testFileLog _ = do
|
||||
|
||||
threadDelay 100000
|
||||
|
||||
withXFTPServerStoreLogOn $ \_ -> testXFTPClient $ \c -> runRight_ $ do
|
||||
rId1 <- liftIO $ readTVarIO rIdVar1
|
||||
rId2 <- liftIO $ readTVarIO rIdVar2
|
||||
-- recipient 1 can download, acknowledges - +1 to log
|
||||
download g c rpKey1 rId1 digest bytes
|
||||
ackXFTPChunk c rpKey1 rId1
|
||||
-- recipient 2 can download
|
||||
download g c rpKey2 rId2 digest bytes
|
||||
logSize testXFTPLogFile `shouldReturn` 4
|
||||
logSize testXFTPStatsBackupFile `shouldReturn` 15
|
||||
|
||||
threadDelay 100000
|
||||
|
||||
withXFTPServerStoreLogOn $ \_ -> pure () -- ack is compacted - -1 from log
|
||||
logSize testXFTPLogFile `shouldReturn` 3
|
||||
|
||||
threadDelay 100000
|
||||
|
||||
withXFTPServerStoreLogOn $ \_ -> testXFTPClient $ \c -> runRight_ $ do
|
||||
sId <- liftIO $ readTVarIO sIdVar
|
||||
rId1 <- liftIO $ readTVarIO rIdVar1
|
||||
rId2 <- liftIO $ readTVarIO rIdVar2
|
||||
-- recipients can download
|
||||
-- recipient 1 can't download due to previous acknowledgement
|
||||
download g c rpKey1 rId1 digest bytes
|
||||
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
|
||||
-- recipient 2 can download
|
||||
download g c rpKey2 rId2 digest bytes
|
||||
-- sender can delete - +1 to log
|
||||
deleteXFTPChunk c spKey sId
|
||||
@@ -337,23 +383,6 @@ testFileLog _ = do
|
||||
downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
|
||||
liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes
|
||||
|
||||
testFileAddressStats :: AFStoreType -> Expectation
|
||||
testFileAddressStats fsType =
|
||||
withXFTPServerConfigOn (updateXFTPCfg (cfgFS fsType) $ \c -> c {addressStats, controlPort = Just testControlPort, controlPortUserAuth = Just testControlPortUserAuth}) $ \_ -> do
|
||||
ts <- getCurrentTime
|
||||
runRight_ $ do
|
||||
c <- ExceptT $ getXFTPClient (1, "xftp://[email protected]:8000", Nothing) testXFTPClientConfig [] ts (\_ -> pure Nothing) (\_ -> pure ())
|
||||
runTestFileChunkDelivery c c
|
||||
withControlPort $ \h -> do
|
||||
controlPortCommand h ("auth " <> unBasicAuth testControlPortUserAuth) 1 `shouldReturn` ["Current role is CPRUser"]
|
||||
controlPortCommand h "addresses errors" 1 `shouldReturn` ["address,previous,current"]
|
||||
forM_ counts $ \(counter, n) ->
|
||||
controlPortCommand h ("addresses " <> counter) 2 `shouldReturn` ["address,previous,current", "127.0.0.1,0," <> n]
|
||||
where
|
||||
addressStats = Just AddressStatsConfig {period = defaultAddressStatsPeriod}
|
||||
counts :: [(ByteString, ByteString)]
|
||||
counts = [("connections", "1"), ("FNEW", "2"), ("FPUT", "2"), ("FGET", "2"), ("recipients", "2"), ("upload_kb", "128"), ("download_kb", "256")]
|
||||
|
||||
testFileBasicAuth :: Bool -> Maybe BasicAuth -> Maybe BasicAuth -> Bool -> AFStoreType -> IO ()
|
||||
testFileBasicAuth allowNewFiles newFileBasicAuth clntAuth success fsType =
|
||||
withXFTPServerConfigOn (updateXFTPCfg (cfgFS fsType) $ \c -> c {allowNewFiles, newFileBasicAuth}) $
|
||||
|
||||
Reference in New Issue
Block a user