dandri/simplexmq
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplexmq.git synced 2026-07-02 09:11:57 +00:00
Code Issues Packages Projects Releases Wiki Activity

smp-server: support namespaces (#1784)

Browse Source 
* smp-server: namespaces resolver scaffolding

* smp-server: Names resolver hardening + cleanup

* smp-server: fuse parallel dispatchers

* smp-server: JSON wire format for NameRecord + Names.hs restructure

* smp-server: redact RpcAuth in Show

* smp-server: JSON wire fixups + spec rewrite + small cleanups

* plan: prepend implementation-diverged banner

* move SimplexName into shared module

* smp-server: name + contract whitelist on RSLV

* smp-server: address audit findings (canonical JSON, INI guards, SSRF, TLD case, shutdown)

* smp-server: round 2 audit fixes (label case, response cap, ipv6 link-local)

* smp-server: round 3 audit fixes (SSRF coverage, drop noop closeManager, CSV order)

* smp-server: round 4 audit fixes (0X-hex host, expanded IPv6 forms, pingEndpoint timeout)

* smp-server: hardcode TldRegistries (drop registry_tld_* INI keys)

* smp-server: round 6 audit fixes (IPv6 SSRF, redirects, ASCII labels)

- Reject IPv6 aliases of 169.254.169.254 (IPv4-compatible / IPv4-mapped /
  6to4 / NAT64) via numeric range check on parsed IPv6.
- Disable HTTP redirects on the Eth RPC request.
- Restrict SimplexName labels to ASCII (Cyrillic/Greek/full-width otherwise
  hash to different on-chain records and diverge from UTS-46 registrars).
- pingEndpoint: only JsonRpcErr means "reachable"; transport/decode failures
  fail startup. boundedIniInt: readMaybe over partial read.
- Add 127.0.0.0/8 and 0.0.0.0 to isLoopback.
- Replace hand-rolled hex helpers with Data.ByteArray.Encoding; raise
  managerConnCount to match rpcMaxConcurrency; hex Show for NameOwner.
- Fuse parallel http/https when into unless+case; drop reverse/re-reverse
  in mkDomain TLDWeb; first AbiInvariantViolated; Nothing <$ decodeAddress;
  forM_ (eitherToMaybe ...); >>= chain in NameOwner FromJSON.
- Drop dead imports/exports/pragmas and two restating comments.
- Tests: factor unsafeOwner/unsafeLink, addr1/2/3, testNamesConfig; add
  non-ASCII label rejection coverage.

* namespace: bound parser input to 253 bytes (DoS defense)

The bare-name fallback and bareDomain parser would otherwise consume
arbitrarily many non-space bytes via takeWhile1 before any validation
or length check. A crafted multi-megabyte token would be decoded as
UTF-8 and re-parsed in full before being rejected.

Introduce `boundedNonSpace` (scan with 253-byte cap) at the two
takeWhile1 sites. Inputs longer than 253 bytes leave residue that
parseOnly's implicit endOfInput rejects, so the parser fails fast
without ever allocating the full input.

The bound is the DNS full-domain limit, chosen for being a familiar
ceiling generous enough to cover any realistic SimpleX name (longest
plausible @user.subdomain.simplex stays well under 100 bytes). No
per-label cap — SimpleX names don't go through DNS label resolution
and there's no semantic reason to constrain individual labels.

* namespace: switch to Python HTTP resolver + agent plumbing (#1796)

* namespace: relax resolver_endpoint validation (path prefix, http without auth)

validateUrl gains two operator-friendly relaxations and a regression test:

- Allow a path prefix (e.g. https://gw.example.com:443/snrc) for a resolver
  behind a reverse-proxy sub-path; /resolve/<name> and /health are appended
  (HttpResolver already strips one trailing slash, so root and sub-path
  behave identically). Query/fragment/userinfo stay rejected.

- Off-loopback, reject only http WITH resolver_auth (the Authorization header
  would travel in cleartext). http without auth is now allowed (no secret to
  leak; resolver data is public — also lets dev setups reach a host resolver
  via http://host.docker.internal). https is always allowed, with or without
  auth. Plain http has no response integrity; intended for trusted/local
  networks only.

Exports validateUrl and adds validateUrlSpec (11 cases) to SMPNamesTests.

* namespace: NameRecord links as arrays (multi-link, cap 5)

* namespace: distinct RSLV error responses

RSLV collapsed every non-hit (no resolver, malformed name, not found,
backing-store failure) to ERR AUTH, so a client iterating its configured
servers could not tell "this router has no resolver, try the next" from
"name not registered, stop", and a transient backend error read as an
authoritative miss.

Names capability is runtime config, orthogonal to the linear SMP version
(a future v21 router without [NAMES] must still advertise v21), so it is
signalled by a command-time error like allowSMPProxy, not by the version
range:

  no resolver configured -> ERR CMD PROHIBITED  (client skips, tries next)
  backing-store failure   -> ERR INTERNAL        (transient: retry/surface)
  not found / malformed   -> ERR AUTH            (authoritative "no such name")

Update the protocol spec error table and add agent tests for the
no-resolver (CMD PROHIBITED) and backend-failure (INTERNAL) paths.

* refactor(names): server role + one error type

Addresses epoberezkin's review (PR #1784). Name resolution becomes a
server role like proxy; the agent owns resolution + server selection;
one error type flows through the whole stack.

- ServerRoles gains `names`; UserServers gains `nameSrvs` (opt-in list);
  resolveSimplexName drops the explicit server arg and picks a
  names-capable server via getNextServer.
- RSLV carries SimplexNameDomain (was RslvRequest): no JSON on the wire,
  contract dropped, name validated at parse (invalid -> CMD SYNTAX).
- Version check moves from the encoder to Client.hs (no ERR to server).
- ErrorType.NAME {nameErr :: NameErrorType} (+ AgentErrorType.NAME),
  wire- and JSON-encoded; resolver errors surface with diagnostics.
  Success response renamed NAME -> RNAME to free the collision.
- NameOwner -> EthAddress (record selector); NameRecord derives FromJSON
  and gains field-ordered Encoding; per-field caps removed.
- Remove newEnvWithNames / runSMPServerBlockingWithNames test seams;
  stub resolver folded into ServerConfig.namesResolverCall_.

* test(server): update stats backup line count

NameResolverStatsData adds 6 lines to the server stats backup (the
"rslvStats:" header plus the reqs/succ/notFound/resolverErrs/disabled
fields), so testRestoreMessages' expected stats-backup line count is
95 -> 101.

* feat(names): public-namespace resolution via RSLV/RNAME

SNRC names resolver role: RSLV command -> HTTP resolver -> RNAME record.
Agent owns server selection (ServerRoles.names); NAME error family; async,
concurrency-bounded resolution; length-prefixed extensible wire; spec.

* remove comments

Co-authored-by: Evgeny <evgeny@poberezkin.com>

* simplify

* move tests name

* simplify: text addresses, Tail JSON, drop admitRslv

* fix

* remove spaghetti

* reduce diff

* async again, refactor

* different threads limit for name resolutions

* remove comment

* FromField instance for SimplexNameInfo

* remove comments

* unStrJSON

* add sameConnShortLink

* remove scheme prefix

* remove unused import

* remove connecttarget tests

* remove comment

* comment

---------

Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>
Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com>
This commit is contained in:
sh
2026-07-01 01:54:55 +04:00
committed by GitHub
parent be58967a86
commit 209f7826cb
31 changed files with 2152 additions and 153 deletions
Download Patch File Download Diff File Expand all files Collapse all files
plans/20260522_01_smp_public_namespaces.md
+455
View File
@@ -0,0 +1,455 @@
# Server: SMP support for public namespaces
> **⚠ Implementation diverged from this plan.** Six audit rounds reshaped the
> original design. **The shipped code differs in several load-bearing ways:**
>
> - **Wire format**: `NameRecord` is now JSON (aeson), not the custom binary
> ABNF this plan documents. See `protocol/simplex-messaging.md` §Resolver
> commands and `src/Simplex/Messaging/Protocol.hs` ToJSON/FromJSON instances.
> - **No cache**: the TTL + FIFO + byte-cap cache, in-flight coalescing,
> `psqueues` dep, and `cache_*` INI keys are all gone. Every RSLV becomes
> one `eth_call` bounded by `rpcMaxConcurrency` + `rpcTimeoutMs`. See
> `src/Simplex/Messaging/Server/Names.hs`.
> - **No `allow_dangerous_colocation` flag**: the proxy co-location guard
> was demoted to a startup `logWarn` (the flag was always-on because
> `[PROXY]` has no enable toggle).
> - **Module shape**: `Names/Resolver.hs` was merged into `Names.hs`; only
> `Names/Eth/RPC.hs` and `Names/Eth/SNRC.hs` remain as separate modules.
> - **Test list**: of the 15 specs listed below, ~7 shipped; the rest were
> either superseded by the cache removal (CacheSpec) or deferred
> (ForwardedRslvSpec, MockRpcSpec, StartupGuardSpec, UrlValidationSpec,
> EipChecksumSpec).
>
> Sources of truth: `CHANGELOG.md` (release notes),
> `protocol/simplex-messaging.md` §Resolver commands (wire format),
> `src/Simplex/Messaging/Server/Names*.hs` (implementation). This file is
> retained as historical context; do not treat it as a specification.
Implementation plan for Part 2 of [RFC 2026-05-21-public-namespaces](https://github.com/simplex-chat/simplex-chat/blob/ep/namespace/docs/rfcs/2026-05-21-public-namespaces.md). Adds a forwarded-only `RSLV <lookup_key>` SMP command that returns `NAME <NameRecord>` read from the SNRC contract via a Reth+Nimbus JSON-RPC endpoint. Smp-server becomes name-capable by `[NAMES] enable: on`.
Out of scope: `Simplex.Messaging.Client` API, agent-side resolution flow, `ServerRoles.names` in the agent, default-router list, reverse resolution, multicoin/text records, state proofs.
## Architecture
```mermaid
sequenceDiagram
participant C as Client
participant P as Proxy (storage role)
participant N as Name server (names role)
participant E as Ethereum endpoint<br/>(Reth+Nimbus)
C ->> P: PFWD(enc(RSLV key))
P ->> N: RFWD(enc(RSLV key))
note over N: verifyTransmission True →<br/>vc SResolver (RSLV _) → VRVerified
N ->> N: cache lookup
alt cache miss
N ->> E: eth_call(SNRC, namehash(key))
E -->> N: ABI bytes
note over N: ABI decode + zero-owner check + cache insert
end
N -->> P: RFWD(enc(NAME rec | ERR AUTH))
P -->> C: PRES(enc(NAME rec | ERR AUTH))
```
RSLV is **forwarded-only** — direct RSLV is rejected `CMD PROHIBITED`. This preserves the RFC's two-server resolution: the name server sees the lookup key but never the client's IP, session, or identity.
## Protocol
Shared library: `src/Simplex/Messaging/Protocol.hs` and `src/Simplex/Messaging/Transport.hs`.
**Version.** `Transport.hs:226`: `namesSMPVersion = VersionSMP 20`. Bump `currentClientSMPRelayVersion`, `currentServerSMPRelayVersion`, `proxiedSMPRelayVersion` to 20. Pre-v20 binaries lack the `RSLV_` tag; v20 binaries with sessions negotiated at v < 20 reject `RSLV_` at the parameter parser. The proxied-version bump 18 → 20 is safe (v19's `RecipientService`/`NotifierService` aren't in the forwarded whitelist; v18's `BLOCKED info` is already version-branched at `Protocol.hs:1943`).
**Party kind.** Append `Resolver` to `Party` (line 335); add `SResolver` (line 349), `TestEquality` clause (line 361), `PartyI Resolver` (line 394). `queueParty SResolver = Nothing` (falls through line 412). `partyClientRole SResolver = Nothing`.
**`RSLV` command.**
```haskell
RSLV :: LookupKey -> Command Resolver
newtype LookupKey = LookupKey ByteString
instance Encoding LookupKey where
smpEncode (LookupKey s) = smpEncode s
smpP = do
n <- lenP
when (n > 64) $ fail "LookupKey too large"
LookupKey <$> A.take n
```
Name-syntax validation is client-side per RFC; the server treats the key as opaque bytes. Tag `"RSLV"`, version guard inside `protocolP v (CT SResolver RSLV_)`: `| v >= namesSMPVersion -> Cmd SResolver . RSLV <$> _smpP`.
**Testnet/mainnet selector**: how the `#testnet:name` namespace appears in `LookupKey` bytes is determined by the SNRC contract (Part 1) — confirm with Part 1 before merging.
**`NAME` response.**
```haskell
NAME :: NameRecord -> BrokerMsg
```
Tag `"NAME"`. Symmetric version guards on encode (in `encodeProtocol v`) and decode (in `protocolP v NAME_`): `| v >= namesSMPVersion -> ...`. `NameRecord` has **no `Encoding` typeclass instance** — the typeclass cannot version-branch. Use top-level helpers `nameRecBytes :: VersionSMP -> NameRecord -> ByteString` and `parseNameRec :: VersionSMP -> Parser NameRecord`, mirroring the `IDS QIK` precedent at `Protocol.hs:1912–1979`.
**`NameRecord` schema and wire layout.**
```haskell
data NameRecord = NameRecord
{ nrDisplayName :: Text -- ≤255 bytes UTF-8
, nrOwner :: NameOwner -- 20 raw bytes
, nrChannelLinks :: [NameLink]
, nrContactLinks :: [NameLink]
, nrAdminAddress :: Maybe Text
, nrAdminEmail :: Maybe Text
, nrExpiry :: Int64 -- Unix seconds, ≥ 0
, nrIsTest :: Bool
}
newtype NameOwner = NameOwner ByteString -- bare ctor NOT exported; smart ctor enforces length 20
newtype NameLink = NameLink Text -- bare ctor NOT exported; smart ctor enforces ≤1024 bytes
unNameOwner :: NameOwner -> ByteString
unNameOwner (NameOwner bs) = bs
unNameLink :: NameLink -> Text
unNameLink (NameLink t) = t
```
Field additions are gated by future SMP version bumps (matching the `IDS QIK` precedent at `Protocol.hs:1912–1979`) — no separate record-version field.
| Field | Encoding | Max bytes |
|---|---|---|
| `nrDisplayName` | 1-byte length prefix + UTF-8 | 1 + 255 |
| `nrOwner` | 20 raw bytes, no prefix | 20 |
| `nrChannelLinks`, `nrContactLinks` | 1-byte count + per-element (Word16 BE len + UTF-8); combined cap **8 entries** across both lists | 1 + Σ(2 + ≤1024) |
| `nrAdminAddress`, `nrAdminEmail` | `'0'` or `'1'` + (1-byte length + UTF-8 if `'1'`) | 1 + 1 + 255 |
| `nrExpiry` | two big-endian `Word32` | 8 |
| `nrIsTest` | `'T'` or `'F'` | 1 |
`Encoding NameLink` reads the Word16 length **before** `A.take` allocates — going through the existing `Large` wrapper allows up to 65 535 bytes per element. There is no `Encoding [a]` instance — use `smpEncodeList` / `smpListP` / a bounded variant:
```haskell
smpListPUpTo :: Encoding a => Int -> Parser [a]
smpListPUpTo cap = do
n <- lenP
when (n > cap) $ fail "list too long"
A.count n smpP
parseNameRec _v = do
nrDisplayName <- smpP
nrOwner <- smpP
nrChannelLinks <- smpListPUpTo 8
nrContactLinks <- smpListPUpTo (8 - length nrChannelLinks)
nrAdminAddress <- smpP
nrAdminEmail <- smpP
nrExpiry <- smpP
when (nrExpiry < 0) $ fail "expiry must be non-negative"
nrIsTest <- smpP
pure NameRecord{..}
```
Both list parsers fail at the count step before allocating; the second inherits the residual budget. Canonical encoding by construction: every primitive has exactly one valid byte form — two name servers reading the same SNRC state produce byte-identical responses.
**Wire-size budget.** `paddedProxiedTLength = 16226` is the plaintext input to `cbEncrypt` (`Server.hs:2117`); `pad` reserves 2 bytes → framed transmission ≤ 16 224 bytes. Combined-link cap 8 yields max payload ≈ 9 050 bytes — generous margin.
**Error semantics.** A single wire code: `ERR AUTH`. Per RFC, this collapses every failure (name not found, malformed key, names disabled, RPC unreachable, decode error, timeout). Resolver internally distinguishes the cause for stats only.
**Forwarded-only access.** Direct RSLV is rejected with `CMD PROHIBITED`. The shape of `THAuthServer` alone cannot discriminate direct from forwarded (`Transport.hs:852` sets `sessSecret' = Just _` for every v6+ direct client too). An explicit `forwarded :: Bool` flag is threaded through `verifyTransmission` (see below).
## Server changes
All edits in `src/Simplex/Messaging/Server.hs`.
**`forwarded :: Bool` plumbing.** Three signatures change:
- `verifyTransmission :: Bool -> ...` (line 1233) — direct path passes `False` (lines 1152–1153), forwarded path passes `True` (line 2129).
- `verifyLoadedQueue :: Bool -> ...` (line 1238) — receives the flag from `verifyTransmission` (lines 1235, 1240).
- `verifyQueueTransmission :: Bool -> ...` (line 1244) — receives and uses the flag.
New `vc` clauses inside `verifyQueueTransmission`:
```haskell
vc SResolver (RSLV _) | forwarded = VRVerified Nothing
| otherwise = VRFailed (CMD PROHIBITED)
vc SResolver _ = VRFailed (CMD PROHIBITED) -- defensive catch-all
```
**Forwarded whitelist** (`Server.hs:2132`):
```haskell
Cmd SResolver (RSLV _) -> True
```
**`processCommand` branch** (alongside line 1481):
```haskell
Cmd SResolver (RSLV (LookupKey key)) -> do
st <- asks (rslvStats . serverStats)
incStat (rslvReqs st)
asks namesEnv >>= \case
Nothing -> incStat (rslvDisabled st) $> response (corrId, NoEntity, ERR AUTH)
Just nenv -> liftIO (resolveName nenv key) >>= \case
Right rec -> incStat (rslvSucc st) $> response (corrId, NoEntity, NAME rec)
Left NotFound -> incStat (rslvNotFound st) $> response (corrId, NoEntity, ERR AUTH)
Left _ -> incStat (rslvEthErrs st) $> response (corrId, NoEntity, ERR AUTH)
```
**Shutdown.** Add `closeNamesEnv :: NamesEnv -> IO ()` calling `closeManager`. Wire into `closeServer` (`Server.hs:247`):
```haskell
closeServer = do
asks (smpAgent . proxyAgent) >>= liftIO . closeSMPClientAgent
asks namesEnv >>= liftIO . mapM_ closeNamesEnv
```
In-flight `resolveName` calls during shutdown receive `ConnectionClosed` → `EthHttpErr` → masked-leader cleanup runs → waiters unblock with `ERR AUTH`.
**`incStat` relocation.** Defined at `Server.hs:2220`, currently unexported. Move to `Server/Stats.hs` (one-line transplant + export) so `Resolver.hs` can use it.
**Co-located proxy warning.** `newEnv` logs a startup warning whenever `allowSMPProxy = True` and `namesConfig = Just _`. RSLV is the first slow forwarded command; on a proxy host it can serialise other forwarded commands on the same proxy-relay session up to `rpcTimeoutMs` per cache miss. The warning is not a hard refusal because `[PROXY]` has no `enable: on/off` toggle — proxy is always on for every smp-server. `forkForwardedCmd` async dispatch is the longer-term fix, tracked as a follow-up; once the proxy role is gateable per-server, the warning can be tightened back to a refusal.
## Resolver subtree
New module tree at `src/Simplex/Messaging/Server/Names/`:
| Module | Contents |
|---|---|
| `Names.hs` | Façade — re-exports `NamesConfig`, `NamesEnv`, `ResolveError`, `resolveName`, `newNamesEnv`, `closeNamesEnv`. |
| `Names/Resolver.hs` | All types + cache + in-flight + `resolveName`. Helpers exported directly (no `.Internal` per codebase convention). **Test seam**: `NamesEnv` holds `ethCall` as a function value, so tests construct stubs via `newNamesEnvWith`. |
| `Names/Eth/RPC.hs` | `EthRpcEnv`; `ethCallReal` via `http-client` + `withResponse` + `brReadSome rpcMaxResponseBytes`. JSON-RPC error / HTTP error split. `rpcMaxConcurrency` semaphore. `Authorization` header from `rpcAuth`. |
| `Names/Eth/SNRC.hs` | `EthAddress`, Keccak-256 namehash via `crypton`'s `Crypto.Hash.Algorithms.Keccak_256` (mirroring `Crypto.hs:1023–1025` for SHA3), hand-rolled bounded Solidity ABI codec, `getRecord` with zero-owner detection. **Ethereum's Keccak ≠ NIST SHA3-256.** |
**ABI codec invariants**, enforced before any allocation: `offset + 32 ≤ buf.length`; `offset + 32 + length ≤ buf.length`; `offset ≥ headEnd` (no backward jumps); every length ≤ per-field cap; `string[]` outer length × 32 ≤ buf.length; recursion depth ≤ 2; `uint256 → Int64` rejects if any high 24 bytes non-zero; UTF-8 via `decodeUtf8'` returns `EthDecodeErr`.
**Zero-owner → `NotFound`**: ENS-style resolvers return zeroed records for non-existent names. After ABI decode, if `nrOwner == NameOwner (B.replicate 20 0)` return `Left NotFound`.
**Errors.**
```haskell
data ResolveError = NotFound | EthHttpErr | EthRpcErr { rpcCode :: Int, rpcMessage :: Text }
| EthDecodeErr | TimedOut
```
All collapse to `ERR AUTH`. `EthRpcErr` carries JSON-RPC `error` object — method-not-found (SNRC not deployed at `snrc_address`) is logged immediately on the first error after a recent success: `logError "NAMES: JSON-RPC error from endpoint — check snrc_address: <code> <message>"`. No automatic retry.
**Cache.** TTL + FIFO eviction. `TVar (OrdPSQ LookupKey Word64 NameRecord, Int)` — priority = monotonic-ns at insert; the `Int` is running byte count. `cacheLookup` is one STM transaction (read, expiry-check, expired-delete-with-byte-decrement). `cacheInsert` is one STM transaction: while `size > cacheMaxEntries` OR `bytes + sizeOf(rec) > cacheMaxBytes`, `minView` to drop oldest, then `insert`. Byte counter prevents `100 000 × 9 KB ≈ 900 MB` worst-case blow-up.
**Request coalescing** (async-exception safe via `E.mask`):
```haskell
resolveName env bs = do
let k = LookupKey bs
now <- getMonotonicTimeNSec
atomically (cacheLookup env k now) >>= \case
Just rec -> incStat (rslvCacheHits ...) $> Right rec
Nothing -> do
incStat (rslvCacheMiss ...)
ticket <- atomically $ TM.lookup k (inflight env) >>= \case
Just mv -> pure (Waiter mv)
Nothing -> newEmptyTMVar >>= \mv -> TM.insert k mv (inflight env) $> Leader mv
case ticket of
Waiter mv -> atomically (readTMVar mv)
Leader mv -> E.mask $ \restore -> do
r <- restore (fetchOnceTimed env bs)
`E.catch` \(e :: E.SomeException) -> pure (Left (mapEthErr e))
atomically $ putTMVar mv r >> TM.delete k (inflight env)
case r of Right rec -> atomically (cacheInsert env k now rec); Left _ -> pure ()
pure r
fetchOnceTimed env bs =
System.Timeout.timeout (rpcTimeoutMs (config env) * 1000) (fetchOnce env bs) >>= \case
Just r -> pure r
Nothing -> pure (Left TimedOut)
```
`E.mask` ensures `putTMVar + TM.delete` runs even on async exception; `fetchOnceTimed` runs under `restore` so it remains interruptible. Waiters always see a value; the in-flight TMap entry is always removed.
`fetchOnce`, `mapEthErr`, `scrubUrl`, `cacheLookup`, `cacheInsert` are internal to `Resolver.hs`. `getMonotonicTimeNSec` from `GHC.Clock` — first monotonic-clock use in the codebase; clock-jump safe.
**STM contention.** Cache hits are read-only `readTVar` — STM scales. Cache writes under sustained miss traffic can retry; `CacheSpec` asserts < 5% retry at 4 readers + 1 writer @ 1k RPS. If observed higher, swap `TVar` for `IORef` + `atomicModifyIORef'`.
**Multicoin and text records** are not in `NameRecord`. If Part 1 contract returns them from `getRecord`, extend `NameRecord` and the wire-size budget. **Confirm with Part 1 author before implementing `Eth/SNRC.hs`.**
## Configuration
`ServerConfig` (`Env/STM.hs:142`) gains one field `namesConfig :: Maybe NamesConfig`. `Env` (`Env/STM.hs:261`) gains `namesEnv :: Maybe NamesEnv`. `newEnv` constructs it after `proxyAgent` (line 605) with the co-location guard.
```haskell
data NamesConfig = NamesConfig
{ ethereumEndpoint :: Text -- http(s), no userinfo, explicit port required
, snrcAddress :: NameOwner -- 20 bytes
, rpcAuth :: Maybe RpcAuth -- required when https & non-loopback host
, cacheSeconds :: Int -- 300
, cacheMaxEntries :: Int -- 100000
, cacheMaxBytes :: Int -- 67108864 (64 MB)
, rpcTimeoutMs :: Int -- 3000
, rpcMaxResponseBytes :: Int -- 262144 (256 KB)
, rpcMaxConcurrency :: Int -- 8
}
data RpcAuth = AuthBearer Text | AuthBasic Text Text
```
INI parsing in `Server/Main.hs`:
- `validateUrl` (using new `network-uri` dep): accepts only http(s), non-empty host, **explicit port** (rejects `http://localhost` defaulting to 80 while Reth is on 8545), no userinfo, no query/fragment. Rejects `https://...` without `rpc_auth` when host is non-loopback. On rejection: `logError` + `exitFailure`.
- `parseEthAddr`: accepts `0x[0-9a-fA-F]{40}` and the same without `0x`. Mixed-case → verify EIP-55 checksum and reject mismatch (catches typos).
- `parseRpcAuth`: reads optional `rpc_auth` key; format `bearer <token>` or `basic <user>:<pass>`.
- `scrubUrl`: strips userinfo from all log lines mentioning the endpoint, including inside `mapEthErr`.
- Transition-aware error logging: log immediately on first error after a recent success, then at most hourly while persisting + summary at every stats reset.
Default INI template (`Server/Main/Init.hs`, after `[PROXY]`):
```
[NAMES]
# Public-namespace resolution (SNRC on Ethereum).
# Requires an Ethereum JSON-RPC endpoint (Reth+Nimbus). See deployment guide.
# Cannot be combined with [PROXY] enable: on by default — see allow_dangerous_colocation.
# Restart required to change settings.
enable: off
# Same-host:
# ethereum_endpoint: http://127.0.0.1:8545
# Central Reth via Caddy:
# ethereum_endpoint: https://eth.simplex.chat:443
# rpc_auth: basic <username>:<password>
# snrc_address: 0x0000000000000000000000000000000000000000
# cache_seconds: 300
# cache_max_entries: 100000
# cache_max_bytes: 67108864
# rpc_timeout_ms: 3000
# rpc_max_response_bytes: 262144
# rpc_max_concurrency: 8
# allow_dangerous_colocation: off
```
Upgrade from a pre-v6.6 INI: missing `[NAMES]` section → disabled. No operator action required.
## Operator deployment
Two supported topologies. smp-server is agnostic — only `ethereum_endpoint` changes.
**Topology A (same-host)**: smp-server, Caddy (optional), Reth, Nimbus all on one box. `ethereum_endpoint: http://127.0.0.1:8545`.
**Topology B (central Reth, N smp-server hosts — recommended for fleets)**: one operator runs one eth host with Reth+Nimbus behind Caddy on public HTTPS. Each smp-server has its own credential.
```mermaid
flowchart LR
subgraph eth-host
Caddy["Caddy<br/>(public :443, basic auth)"]
Reth["Reth<br/>(127.0.0.1:8545)"]
Nimbus["Nimbus"]
Caddy --> Reth
Nimbus -- Engine API (jwt.hex) --> Reth
end
subgraph smp-host-1
S1["smp-server #1"]
end
subgraph smp-host-N
SN["smp-server #N"]
end
S1 -- HTTPS + Authorization --> Caddy
SN -- HTTPS + Authorization --> Caddy
Reth <-- Ethereum p2p --> internet
Nimbus <-- beacon sync --> internet
```
Sharing one Reth across **multiple operators** is **not** supported — collapses the RFC's two-server resolution privacy.
**Reth + Nimbus**: Reth (execution layer) holds Ethereum state on ~260 GB pruned NVMe; Nimbus (consensus light client) follows beacon-chain headers. Paired via Engine API on `127.0.0.1:8551` with a shared `jwt.hex`. Recommended Reth flags:
```bash
reth node \
--http.addr 127.0.0.1 \
--http.api eth \ # only eth namespace
--rpc.gascap 50000000 \ # cap gas per eth_call
--rpc.max-response-size 5242880 \ # 5 MB
--http.corsdomain none \
--authrpc.jwtsecret /opt/eth/jwt.hex \
--authrpc.addr 127.0.0.1 --authrpc.port 8551
```
**Caddy + Let's Encrypt + Basic auth** (Topology B):
```caddy
eth.simplex.chat {
basicauth {
smp-server-1 $2a$14$<bcrypt-hash-1>
smp-server-2 $2a$14$<bcrypt-hash-2>
}
log { format filter { wrap json; fields { request>headers>Authorization delete } } }
reverse_proxy 127.0.0.1:8545
}
```
Caddy auto-fetches Let's Encrypt cert. Each smp-server has its own credential; revoking one = delete the line. `Authorization` stripped from access logs. Port 80 needed for the ACME HTTP-01 challenge (use TLS-ALPN-01 or DNS-01 to drop it). The threat being defended against is DoS (SNRC state is public); mTLS would be overkill. WireGuard/Tailscale are alternative network-layer approaches — both compatible with the plan.
**Capacity.** One Reth+Nimbus box handles a realistic operator fleet by 10–1000× margin. Per-smp-server peak RSLV ≈ 1700 RPS (pessimistic); cache hit rate ≥ 95% → ~85 RPS cache miss per smp-server; 10 smp-servers → ~850 RPS aggregate cache miss reaching Reth; Reth `eth_call` throughput on warm NVMe ≈ 1k–10k RPS. Sizing: 8 vCPU, 32 GB RAM, 1 TB NVMe is comfortable. Scale-out path: more Reth+Nimbus pairs, smp-servers round-robin or shard.
## Implementation
**Order**:
1. Protocol: party/SParty/PartyI, RSLV+tag, NAME+tag, NameRecord + helpers, version constants in `Transport.hs`.
2. `verifyTransmission`/`verifyLoadedQueue`/`verifyQueueTransmission` `forwarded :: Bool` flag + `vc SResolver` clauses.
3. Forwarded whitelist + `processCommand` branch + `incStat` move to `Stats.hs`.
4. Env plumbing: `Server/Env/STM.hs`, `Server/Main.hs` INI parse, `Server/Main/Init.hs` template.
5. Resolver subtree: `Eth/SNRC.hs` → `Eth/RPC.hs` → `Resolver.hs`.
6. `NameResolverStats` sub-record + CSV log + Prometheus `names =` block.
7. Replace stub in (3) with real `resolveName`.
8. Tests.
9. `protocol/simplex-messaging.md`: header version line 1 (`19 → 20`), sentence at line 86, version-history list (lines 93–105) v20 entry, TOC (lines 25–68) "Resolver commands" subsection, new section with ABNF + byte layout + error semantics, "Router security requirements" paragraph about names-role outbound HTTP, cross-ref `Transport.hs:226`.
10. `CHANGELOG.md`: v6.6 entry.
**Cabal** (`simplexmq.cabal`): bump `version: 6.6.0.0`. Add to `if !flag(client_library)` block: `http-client >=0.7 && <0.8`, `http-client-tls >=0.3 && <0.4`, `network-uri >=2.6 && <2.7`, `psqueues >=0.2.7 && <0.3`. Expose 4 new `Server.Names.*` modules in the same block. `crypton` already provides `Keccak_256`.
**Files changed**:
| File | Change |
|---|---|
| `Protocol.hs` | Resolver party + RSLV/NAME tags + version guards; `NameRecord` + newtypes + smart ctors; `nameRecBytes`/`parseNameRec`/`smpListPUpTo` helpers (no Encoding NameRecord instance); `LookupKey` parser-side cap |
| `Transport.hs` | `namesSMPVersion = 20`; bump current/proxied SMP versions |
| `Server.hs` | Thread `forwarded :: Bool`; `vc SResolver` clauses; whitelist (2132); Resolver branch in `processCommand` (1481); `closeServer` calls `closeNamesEnv`; CSV log (579–618); **remove** local `incStat` |
| `Server/Env/STM.hs` | `namesConfig` field; `namesEnv` field; `newEnv` constructs `NamesEnv` with co-location guard |
| `Server/Main.hs` | `[NAMES]` parse: `validateUrl`/`parseEthAddr`/`parseRpcAuth`; `scrubUrl` in logs |
| `Server/Main/Init.hs` | `[NAMES]` block in default INI |
| `Server/Stats.hs` | `incStat` moved here + exported; `NameResolverStats` sub-record + helpers; `rslvStats` field |
| `Server/Prometheus.hs` | `names =` metric block |
| `Server/Names.hs` (new) | Façade re-exports |
| `Server/Names/Resolver.hs` (new) | All resolver types + cache + coalescing + `fetchOnceTimed` + `newNamesEnv[With]` + `closeNamesEnv` |
| `Server/Names/Eth/RPC.hs` (new) | `EthRpcEnv`, `ethCallReal` with bounded body + concurrency semaphore + `Authorization` header |
| `Server/Names/Eth/SNRC.hs` (new) | `EthAddress`, Keccak namehash, bounded ABI (8 invariants), `getRecord` with zero-owner detection |
| `simplexmq.cabal` | Bump `6.6.0.0`; 4 new deps + 4 new modules in `if !flag(client_library)` block |
| `protocol/simplex-messaging.md` | Header version, version-history v20 entry, new "Resolver commands" section |
| `CHANGELOG.md` | v6.6 entry |
## Testing
`tests/SMPNamesTests/` registered in `tests/Test.hs:112–151`. Build only when `client_library = False`.
1. **ProtocolEncodingSpec** — `nameRecBytes` ↔ `parseNameRec` round-trip; oversized fields rejected at parse; combined-list cap 8 enforced; negative `nrExpiry` rejected; canonical encoding byte-stable.
2. **MaxSizeSpec** — max `NameRecord` encodes ≤ ~9 KB; `encodeTransmission v ≤ paddedProxiedTLength - 2`; `cbEncrypt` succeeds.
3. **CommandTagSpec** — `"RSLV"`/`"NAME"` parse; v < 20 sessions reject `RSLV_` at parameter parser.
4. **ForwardedGateSpec** — direct RSLV → `CMD PROHIBITED`; forwarded RSLV reaches handler.
5. **ForwardedRslvSpec** — RSLV wrapped in PFWD reaches the handler end-to-end. **Test infra cost**: first protocol-level PFWD test; budget for `runProxiedSmpCommand` helper performing `PRXY`/`PKEY`/`PFWD` manually.
6. **CacheSpec** — hit avoids RPC; TTL expiry forces re-fetch; bytes cap evicts before entries cap on large records; concurrent same-key callers issue one RPC; leader exception → all waiters get `Left _`, TMap entry removed; leader async-cancel → cleanup STM still runs.
7. **AbiSpec** — encode/decode against pinned fixtures (`tests/fixtures/snrc/`); QuickCheck fuzz on random buffers ≤ `rpcMaxResponseBytes` must never crash.
8. **NamehashSpec** — Keccak-256 reference vectors; assert Keccak ≠ SHA3-256.
9. **MockRpcSpec** — fake HTTP server; missing → `EthHttpErr`; slow → `TimedOut`; multi-GB body truncated → `EthDecodeErr`. `rpcAuth = AuthBasic` sends correct header.
10. **Uint256OverflowSpec** — `expiry > Int64.maxBound` → `EthDecodeErr`.
11. **ZeroOwnerSpec** — `owner = 0x000...000` → `NotFound`.
12. **StartupGuardSpec** — `allowSMPProxy + names.enable` aborts; `allow_dangerous_colocation = on` starts with warning.
13. **UrlValidationSpec** — userinfo/scheme/host/port edge cases; rejects `https://` without `rpc_auth` for non-loopback.
14. **EipChecksumSpec** — `parseEthAddr` accepts lower/upper; verifies mixed-case checksum; rejects typos.
15. **AbiBoundsSpec** — each of 8 ABI invariants triggers `EthDecodeErr` without crash/allocation blow-up.
Integration against real Reth+Nimbus mainnet deferred to ops.
## Threat model, scope, coordination
| Actor | Can | Cannot |
|---|---|---|
| Name server | See lookup-key bytes; see query timing; see Eth endpoint URL (operator-self) | See client IP/session; correlate clients across queries |
| Compromised Eth endpoint | Poison this server's cache for one TTL window; see every lookup key the server queries | Bypass two-server agreement (client-side, out of scope) |
| Adversarial client (high-rate unique keys) | Cache-thrash DoS; fill `Manager` connection pool up to `managerConnCount = 8` | Bypass `rpcMaxResponseBytes` or `fetchOnceTimed` |
| Adversarial proxy (slow inner RSLVs) | Block other forwarded commands on that proxy connection up to `rpcTimeoutMs` per miss | Affect other proxy connections |
| Operator with footgun config (https no auth, public Eth RPC) | (rejected at startup, or operator-acknowledged data leak) | — |
Mitigations: caching + coalescing + `rpcTimeoutMs` + `rpcMaxResponseBytes` + `rpcMaxConcurrency`; co-location refused at startup; URL validation; Caddy + auth in front of Reth; Reth's own gas/size caps. Timing side-channels (cache-hit vs miss latency) not mitigated — flagged for post-MVP. State proofs deferred to post-MVP per RFC.
**Cross-repo coordination.** The `simplex-chat` `ep/namespace` branch currently contains only the RFC commit — no agent-side wire-format code yet. This plan's wire format is validated only by simplexmq's own tests until a matching agent PR lands (structurally weak — encoder/decoder bugs are mutually consistent with themselves). Coordinate with the agent-side implementer **before merging** on: exact `NameRecord` field order and types; `LookupKey` namespace-prefix convention; error-code semantics; Part 1 SNRC contract `getRecord` ABI surface.
protocol/simplex-messaging.md
+122 -2
View File
@@ -1,4 +1,4 @@
Version 19, 2025-01-24
Version 20, 2026-05-25
# Simplex Messaging Protocol (SMP)
@@ -67,6 +67,9 @@ Version 19, 2025-01-24
- [Queue deleted notification](#queue-deleted-notification)
- [Error responses](#error-responses)
- [OK response](#ok-response)
- [Resolver commands](#resolver-commands)
- [Resolve name command](#resolve-name-command)
- [Name record response](#name-record-response)
- [Transport connection with the SMP router](#transport-connection-with-the-SMP-router)
- [General transport protocol considerations](#general-transport-protocol-considerations)
- [TLS transport encryption](#tls-transport-encryption)
@@ -83,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 19. 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)
@@ -103,6 +106,7 @@ This document describes SMP protocol version 19. Versions 1-5 are discontinued.
- v17: create notification credentials with NEW command
- v18: support client notices in BLOCKED error
- v19: service subscriptions to messages (SUBS, NSUBS, SOKS, ENDS, ALLS commands)
- v20: public namespaces resolver (RSLV command, RNAME response) — direct or forwarded via PFWD
## Introduction
@@ -424,6 +428,8 @@ Simplex messaging router implementations MUST NOT create, store or send to any o
- Any other information that may compromise privacy or [forward secrecy][4] of communication between clients using simplex messaging routers (the routers cannot compromise forward secrecy of any application layer protocol, such as double ratchet).
Routers with the names role make outbound HTTP calls to a backing resolver service (the reference implementation is `scripts/resolver/snrc-resolve.py`, which in turn makes JSON-RPC calls to an Ethereum endpoint) to read `NameRecord` data; the lookup key reaches that resolver and its upstream RPC endpoint. Operators MUST run both the resolver process and its upstream RPC endpoint themselves (loopback Reth + Nimbus, or a self-hosted central deployment) — sharing them across multiple operators collapses the two-server privacy property because the resolver / RPC operator would see every lookup key across all of them. The names role and the SMP-proxy role MUST NOT be enabled on the same router by default: a client forwarding `RSLV` through a proxy that is also the names router would expose both its connection and the lookup key to one operator, collapsing the two-server privacy property. (Resolution itself runs on a forked thread, so a slow `RSLV` does not serialise other forwarded commands on the session.)
## Message delivery notifications
Supporting message delivery while the client mobile app is not running requires sending push notifications with the device token. All alternative mechanisms for background message delivery are unreliable, particularly on iOS platform.
@@ -1422,6 +1428,120 @@ When the command is successfully executed by the router, it should respond with
ok = %s"OK"
```
### Resolver commands
Resolver commands implement public-namespace name resolution on the names-role
router. A names router translates an opaque lookup key (such as `alice` or
`alice.simplex.eth`) into a `NameRecord` carrying the channel and contact links
the named party publishes.
**Direct or forwarded.** RSLV is an unauthenticated command accepted both
directly from a transport client and inside a `PFWD` block via the SMP proxy;
the client chooses. Forwarded delivery preserves the two-server privacy property
of the resolver design: the names router sees the lookup key but never the
client IP, session, or identity, while the proxy router sees the client
connection but cannot read the encrypted lookup key inside the forwarded
transmission. Direct delivery is simpler but exposes the client's connection to
the names router, so clients SHOULD prefer the forwarded path when proxying is
available.
**Backing store.** This protocol does not prescribe where the names router
reads `NameRecord` from. The reference implementation forwards each RSLV to a
companion REST resolver process (`scripts/resolver/snrc-resolve.py`) that
queries the SNRC contract on Ethereum; alternative backings (different chains,
DHT, etc.) are valid as long as they expose the documented HTTP shape (`GET
/resolve/<name>` returning a `NameRecord` on 200, 404 / 400 for unknown names
or TLDs, 502 for upstream RPC failures) or substitute a different transport
while still returning a `NameRecord` matching the encoding below.
#### Resolve name command
The `RSLV` command carries the canonical fully-qualified name directly as the
payload (not JSON):
```abnf
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.
**Server-side validation.** The names router parses `domain` as a
fully-qualified name (TLD required — bare labels are rejected) and forwards it
to the configured backing resolver, which is the source of truth for which
on-chain registry maps to each TLD.
The names router responds with either an `RNAME` response carrying the resolved
record, or an `ERR NAME` error whose subcode a client iterating across several
configured servers can act on distinctly:
| Response | Condition | Client action |
|---|---|---|
| `RNAME` | record resolved | use it |
| `ERR NAME NOT_FOUND` | name not registered, unknown TLD, or malformed name | authoritative "no such name" — stop |
| `ERR NAME NO_RESOLVER` | this router has no resolver (names role not enabled) | skip this server, try the next |
| `ERR NAME RESOLVER <detail>` | transient failure: backing resolver error (upstream 5xx, transport, timeout, decode) | transient — retry or surface, do not treat as "not found" |
A client SHOULD NOT broadcast a `name` to further servers after a name-capable
router has answered (`NOT_FOUND` or `RESOLVER`), since that router has already
seen the lookup key; `NO_RESOLVER` discloses nothing about the name beyond the
fact that this router cannot resolve, so iterating past it is safe.
#### Name record response
The `RNAME` response carries a JSON-encoded record as the payload:
```abnf
rname = %s"RNAME" SP json-bytes ; json-bytes consumes the remainder of the transmission
```
`json-bytes` MUST be a UTF-8 JSON object with the following schema:
| Field | JSON type | Constraints |
|---|---|---|
| `name` | string | ≤ 255 bytes UTF-8 |
| `nickname` | string | ≤ 255 bytes UTF-8; senders MUST emit the empty string `""` when unset |
| `website` | string | ≤ 255 bytes UTF-8; same empty-string-when-unset rule |
| `location` | string | ≤ 255 bytes UTF-8; same empty-string-when-unset rule |
| `simplexContact` | array of strings | each a SimpleX contact link (primary first); empty array `[]` when unset |
| `simplexChannel` | array of strings | each a SimpleX channel link (primary first); empty array `[]` when unset |
| `eth` | string or null | ≤ 255 bytes UTF-8; senders MUST emit `null` when unset; receivers MUST also accept absent keys as unset |
| `btc` | string or null | ≤ 255 bytes UTF-8; same null / absent rules |
| `xmr` | string or null | ≤ 255 bytes UTF-8; same null / absent rules |
| `dot` | string or null | ≤ 255 bytes UTF-8; same null / absent rules |
| `owner` | string | `"0x"` followed by 40 lowercase hex characters (20 raw bytes) |
| `resolver` | string | `"0x"` followed by 40 lowercase hex characters; the resolver contract address that produced the record |
Text fields (`nickname`, `website`, `location`) use the empty string `""` as
the "unset" sentinel: a backing resolver with no value for the field MUST emit
an empty string, not JSON `null` and not an absent key. Link fields
(`simplexContact`, `simplexChannel`) are arrays, primary link first, and use the
empty array `[]` when unset. Coin fields (`eth`, `btc`, `xmr`, `dot`) use JSON
`null` as the "unset" sentinel and MAY also be absent from the object entirely.
The backing resolver filters records that are expired or otherwise unavailable
(the names router then returns `ERR NAME NOT_FOUND` to the client), so the wire
format carries no expiry field. Testnet-vs-mainnet status is derived from the
queried TLD rather than an in-record flag.
Receivers MUST tolerate extra unknown fields (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
### General transport protocol considerations
simplexmq.cabal
+13
View File
@@ -143,6 +143,7 @@ library
Simplex.Messaging.Crypto.ShortLink
Simplex.Messaging.Encoding
Simplex.Messaging.Encoding.String
Simplex.Messaging.Names.Record
Simplex.Messaging.Notifications.Client
Simplex.Messaging.Notifications.Protocol
Simplex.Messaging.Notifications.Transport
@@ -154,6 +155,7 @@ library
Simplex.Messaging.Server.QueueStore.Postgres.Config
Simplex.Messaging.Server.QueueStore.QueueInfo
Simplex.Messaging.ServiceScheme
Simplex.Messaging.SimplexName
Simplex.Messaging.Session
Simplex.Messaging.SystemTime
Simplex.Messaging.TMap
@@ -274,6 +276,8 @@ library
Simplex.Messaging.Server.MsgStore.Journal.SharedLock
Simplex.Messaging.Server.MsgStore.STM
Simplex.Messaging.Server.MsgStore.Types
Simplex.Messaging.Server.Names
Simplex.Messaging.Server.Names.HttpResolver
Simplex.Messaging.Server.NtfStore
Simplex.Messaging.Server.Prometheus
Simplex.Messaging.Server.QueueStore
@@ -390,7 +394,10 @@ library
build-depends:
case-insensitive ==1.2.*
, hashable ==1.4.*
, http-client >=0.7 && <0.8
, http-client-tls >=0.3 && <0.4
, ini ==0.4.1
, network-uri >=2.6 && <2.7
, optparse-applicative >=0.15 && <0.17
, process ==1.6.*
, temporary ==1.3.*
@@ -524,6 +531,7 @@ test-suite simplexmq-test
AgentTests.EqInstances
AgentTests.FunctionalAPITests
AgentTests.MigrationTests
AgentTests.ResolveNameTests
AgentTests.ServerChoice
AgentTests.ShortLinkTests
CLITests
@@ -540,9 +548,12 @@ test-suite simplexmq-test
CoreTests.VersionRangeTests
FileDescriptionTests
RemoteControl
NamesResolverServer
RSLVTests
ServerTests
SMPAgentClient
SMPClient
SMPNamesTests
SMPProxyTests
Util
XFTPAgent
@@ -623,6 +634,8 @@ test-suite simplexmq-test
, unliftio
, unliftio-core
, unordered-containers
, wai
, warp
, yaml
default-language: Haskell2010
if flag(server_postgres)
src/Simplex/Messaging/Agent.hs
+14
View File
@@ -65,6 +65,7 @@ module Simplex.Messaging.Agent
setConnShortLink,
deleteConnShortLink,
getConnShortLink,
resolveSimplexName,
getConnLinkPrivKey,
deleteLocalInvShortLink,
changeConnectionUser,
@@ -216,6 +217,7 @@ import Simplex.Messaging.Protocol
ErrorType (AUTH),
MsgBody,
MsgFlags (..),
NameRecord,
NtfServer,
ProtoServerWithAuth (..),
ProtocolServer (..),
@@ -440,6 +442,13 @@ getConnShortLink :: AgentClient -> NetworkRequestMode -> UserId -> ConnShortLink
getConnShortLink c = withAgentEnv c .:. getConnShortLink' c
{-# INLINE getConnShortLink #-}
-- | 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 -> SimplexNameDomain -> AE NameRecord
resolveSimplexName c nm userId domain = withAgentEnv c $ resolveSimplexName' c nm userId domain
{-# INLINE resolveSimplexName #-}
getConnLinkPrivKey :: AgentClient -> ConnId -> AE (Maybe C.PrivateKeyEd25519)
getConnLinkPrivKey c = withAgentEnv c . getConnLinkPrivKey' c
{-# INLINE getConnLinkPrivKey #-}
@@ -1182,6 +1191,11 @@ 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 -> SimplexNameDomain -> AM NameRecord
resolveSimplexName' c nm userId domain = do
resolverSrv <- getNextNameServer c userId
resolveName c nm userId resolverSrv domain
changeConnectionUser' :: AgentClient -> UserId -> ConnId -> UserId -> AM ()
changeConnectionUser' c oldUserId connId newUserId = do
SomeConn _ conn <- withStore c (`getConn` connId)
src/Simplex/Messaging/Agent/Client.hs
+25
View File
@@ -68,6 +68,8 @@ module Simplex.Messaging.Agent.Client
deleteQueueLink,
secureGetQueueLink,
getQueueLink,
resolveName,
getNextNameServer,
enableQueueNotifications,
EnableQueueNtfReq (..),
enableQueuesNtfs,
@@ -267,6 +269,7 @@ import Simplex.Messaging.Protocol
NetworkError (..),
MsgFlags (..),
MsgId,
NameRecord,
NtfServer,
NtfServerWithAuth,
ProtoServer,
@@ -1979,6 +1982,28 @@ getQueueLink c nm userId server lnkId =
getViaProxy smp proxySess = proxyGetSMPQueueLink smp nm proxySess lnkId
getDirectly smp = getSMPQueueLink smp nm lnkId
-- | Resolve a public-namespace name. Prefers PFWD (hides client IP from the
-- 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 -> SimplexNameDomain -> AM NameRecord
resolveName c nm userId server domain =
snd <$> sendOrProxySMPCommand c nm userId server "" "RSLV" NoEntity resolveViaProxy resolveDirectly
where
resolveViaProxy smp proxySess = proxyResolveName smp nm proxySess domain
resolveDirectly smp = directResolveName smp nm domain
-- | Pick a names-capable server for the user (the agent owns server selection,
-- accounting for the names role). nameSrvs is opt-in (a plain list); empty means
-- no server resolves names - a declared agent error, never a fallback.
getNextNameServer :: AgentClient -> UserId -> AM SMPServer
getNextNameServer c userId =
liftIO (TM.lookupIO userId (userServers c :: TMap UserId (UserServers 'PSMP))) >>= \case
Just UserServers {nameSrvs} -> case L.nonEmpty nameSrvs of
Just srvs -> protoServer <$> pickServer srvs
Nothing -> throwE NO_NAME_SERVERS
Nothing -> throwE $ INTERNAL "unknown userId - no user servers"
enableQueueNotifications :: AgentClient -> RcvQueue -> SMP.NtfPublicAuthKey -> SMP.RcvNtfPublicDhKey -> AM (SMP.NotifierId, SMP.RcvNtfPublicDhKey)
enableQueueNotifications c rq@RcvQueue {rcvId, rcvPrivateKey} notifierKey rcvNtfPublicDhKey =
withSMPClient c NRMBackground rq "NKEY <nkey>" $ \smp ->
src/Simplex/Messaging/Agent/Env/SQLite.hs
+8 -3
View File
@@ -105,12 +105,13 @@ data ServerCfg p = ServerCfg
data ServerRoles = ServerRoles
{ storage :: Bool,
proxy :: Bool
proxy :: Bool,
names :: Bool
}
deriving (Show)
allRoles :: ServerRoles
allRoles = ServerRoles True True
allRoles = ServerRoles True True True
presetServerCfg :: Bool -> ServerRoles -> Maybe OperatorId -> ProtoServerWithAuth p -> ServerCfg p
presetServerCfg enabled roles operator server =
@@ -119,6 +120,9 @@ presetServerCfg enabled roles operator server =
data UserServers p = UserServers
{ storageSrvs :: NonEmpty (Maybe OperatorId, ProtoServerWithAuth p),
proxySrvs :: NonEmpty (Maybe OperatorId, ProtoServerWithAuth p),
-- name resolution is opt-in: a plain list (NOT NonEmpty, no fallback-to-all).
-- Empty = no servers resolve names = a clean agent error, never falls back.
nameSrvs :: [(Maybe OperatorId, ProtoServerWithAuth p)],
knownHosts :: Set TransportHost
}
@@ -126,9 +130,10 @@ type OperatorId = Int64
-- This function sets all servers as enabled in case all passed servers are disabled.
mkUserServers :: NonEmpty (ServerCfg p) -> UserServers p
mkUserServers srvs = UserServers {storageSrvs = filterSrvs storage, proxySrvs = filterSrvs proxy, knownHosts}
mkUserServers srvs = UserServers {storageSrvs = filterSrvs storage, proxySrvs = filterSrvs proxy, nameSrvs, knownHosts}
where
filterSrvs role = L.map (\ServerCfg {operator, server} -> (operator, server)) $ fromMaybe srvs $ L.nonEmpty $ L.filter (\ServerCfg {enabled, roles} -> enabled && role roles) srvs
nameSrvs = map (\ServerCfg {operator, server} -> (operator, server)) $ L.filter (\ServerCfg {enabled, roles} -> enabled && names roles) srvs
knownHosts = S.unions $ L.map (\ServerCfg {server = ProtoServerWithAuth srv _} -> serverHosts srv) srvs
serverHosts :: ProtocolServer p -> Set TransportHost
src/Simplex/Messaging/Agent/Protocol.hs
+18 -78
View File
@@ -137,7 +137,9 @@ module Simplex.Messaging.Agent.Protocol
validateOwners,
validateLinkOwners,
sameConnReqContact,
sameConnShortLink,
sameShortLinkContact,
sameShortLinkInv,
simplexChat,
connReqUriP',
simplexConnReqUri,
@@ -195,11 +197,10 @@ import qualified Data.Aeson.TH as J
import qualified Data.Aeson.Types as JT
import Data.Attoparsec.ByteString.Char8 (Parser)
import qualified Data.Attoparsec.ByteString.Char8 as A
import qualified Data.Attoparsec.Text as AT
import qualified Data.ByteString.Base64.URL as B64
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Char (isAlpha, isDigit, toLower, toUpper)
import Data.Char (toLower, toUpper)
import Data.Foldable (find)
import Data.Functor (($>))
import Data.Int (Int64)
@@ -237,6 +238,7 @@ import Simplex.Messaging.Crypto.Ratchet
)
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.SimplexName (SimplexNameDomain (..), SimplexNameInfo (..), SimplexNameType (..), SimplexTLD (..), fullDomainName, shortNameInfoStr)
import Simplex.Messaging.Parsers
import Simplex.Messaging.Protocol
( AProtocolType,
@@ -1531,75 +1533,6 @@ instance (Typeable c, ConnectionModeI c) => FromField (ConnShortLink c) where fr
data ContactConnType = CCTContact | CCTChannel | CCTGroup | CCTRelay deriving (Eq, Show)
data SimplexNameInfo = SimplexNameInfo
{ nameType :: SimplexNameType,
nameDomain :: SimplexNameDomain
}
deriving (Eq, Show)
data SimplexNameDomain = SimplexNameDomain
{ nameTLD :: SimplexTLD,
domain :: Text,
subDomain :: [Text] -- parent to child: ["b", "a"] for a.b.domain.simplex
}
deriving (Eq, Show)
data SimplexTLD = TLDSimplex | TLDTesting | TLDWeb
deriving (Eq, Show)
data SimplexNameType = NTPublicGroup | NTContact
deriving (Eq, Show)
instance StrEncoding SimplexNameType where
strEncode = \case
NTPublicGroup -> "#"
NTContact -> "@"
strP = A.char '#' $> NTPublicGroup <|> A.char '@' $> NTContact
nameLabelP :: AT.Parser Text
nameLabelP = T.intercalate "-" <$> AT.takeWhile1 (\c -> isNameLetter c || isDigit c) `AT.sepBy1` AT.char '-'
where
isNameLetter c = isAlpha c && not (c >= '\x00c0' && c <= '\x024f')
instance StrEncoding SimplexNameInfo where
strEncode SimplexNameInfo {nameType, nameDomain} =
"simplex:/name" <> strEncode nameType <> strEncode nameDomain
strP = optional "simplex:/name" *> ((strP >>= infoP) <|> infoP NTPublicGroup)
where
infoP NTPublicGroup = SimplexNameInfo NTPublicGroup <$> (strP <|> bareName)
infoP NTContact = SimplexNameInfo NTContact <$> strP
bareName = parseBare . safeDecodeUtf8 <$?> A.takeWhile1 (not . A.isSpace)
parseBare s = (\name -> SimplexNameDomain TLDSimplex name []) <$> AT.parseOnly (nameLabelP <* AT.endOfInput) s
instance StrEncoding SimplexNameDomain where
strEncode = encodeUtf8 . fullDomainName
strP = parseDomain . safeDecodeUtf8 <$?> A.takeWhile1 (not . A.isSpace)
where
parseDomain s = AT.parseOnly (nameLabelP `AT.sepBy1` AT.char '.' <* AT.endOfInput) s >>= mkDomain
mkDomain labels = case reverse labels of
[] -> Left "empty name"
[_] -> Left "domain requires TLD"
"simplex" : name : sub -> Right $ SimplexNameDomain TLDSimplex name sub
"testing" : name : sub -> Right $ SimplexNameDomain TLDTesting name sub
_ -> Right $ SimplexNameDomain TLDWeb (T.intercalate "." labels) []
fullDomainName :: SimplexNameDomain -> Text
fullDomainName SimplexNameDomain {nameTLD, domain, subDomain} = T.intercalate "." (reverse subDomain ++ [domain] ++ tld')
where
tld' = case nameTLD of
TLDSimplex -> ["simplex"]
TLDTesting -> ["testing"]
TLDWeb -> []
shortNameInfoStr :: SimplexNameInfo -> Text
shortNameInfoStr = \case
SimplexNameInfo {nameType = NTPublicGroup, nameDomain = SimplexNameDomain {nameTLD = TLDSimplex, domain, subDomain = []}} -> "#" <> domain
info -> pfx <> fullDomainName (nameDomain info)
where
pfx = case nameType info of
NTPublicGroup -> "#"
NTContact -> "@"
data AConnShortLink = forall m. ConnectionModeI m => ACSL (SConnectionMode m) (ConnShortLink m)
instance Eq AConnShortLink where
@@ -1801,10 +1734,21 @@ sameConnReqContact (CRContactUri ConnReqUriData {crSmpQueues = qs}) (CRContactUr
where
same (q, q') = sameQAddress (qAddress q) (qAddress q')
sameConnShortLink :: AConnShortLink -> AConnShortLink -> Bool
sameConnShortLink (ACSL m sl) (ACSL m' sl') = case testEquality m m' of
Just Refl -> case sl of
CSLContact {} -> sameShortLinkContact sl sl'
CSLInvitation {} -> sameShortLinkInv sl sl'
Nothing -> False
sameShortLinkContact :: ConnShortLink 'CMContact -> ConnShortLink 'CMContact -> Bool
sameShortLinkContact (CSLContact _ ct srv k) (CSLContact _ ct' srv' k') =
ct == ct' && sameSrvAddr srv srv' && k == k'
sameShortLinkInv :: ConnShortLink 'CMInvitation -> ConnShortLink 'CMInvitation -> Bool
sameShortLinkInv (CSLInvitation _ srv lnkId k) (CSLInvitation _ srv' lnkId' k') =
sameSrvAddr srv srv' && lnkId == lnkId' && k == k'
checkConnMode :: forall t m m'. (ConnectionModeI m, ConnectionModeI m') => t m' -> Either String (t m)
checkConnMode c = case testEquality (sConnectionMode @m) (sConnectionMode @m') of
Just Refl -> Right c
@@ -2067,6 +2011,9 @@ data AgentErrorType
XFTP {serverAddress :: String, xftpErr :: XFTPErrorType}
| -- | XFTP agent errors
FILE {fileErr :: FileErrorType}
| -- | no name-resolving servers configured for the user (agent-origin).
-- Server-origin name errors arrive forwarded as SMP _ (NAME ...) instead.
NO_NAME_SERVERS
| -- | SMP proxy errors
PROXY {proxyServer :: String, relayServer :: String, proxyErr :: ProxyClientError}
| -- | XRCP protocol errors forwarded to agent clients
@@ -2278,10 +2225,3 @@ instance ToJSON ACreatedConnLink where
toEncoding (ACCL _ ccLink) = toEncoding ccLink
toJSON (ACCL _ ccLink) = toJSON ccLink
$(J.deriveJSON (enumJSON $ dropPrefix "TLD") ''SimplexTLD)
$(J.deriveJSON (enumJSON $ dropPrefix "NT") ''SimplexNameType)
$(J.deriveJSON defaultJSON ''SimplexNameDomain)
$(J.deriveJSON defaultJSON ''SimplexNameInfo)
src/Simplex/Messaging/Client.hs
+30
View File
@@ -73,6 +73,8 @@ module Simplex.Messaging.Client
deleteSMPQueues,
connectSMPProxiedRelay,
proxySMPMessage,
proxyResolveName,
directResolveName,
forwardSMPTransmission,
getSMPQueueInfo,
sendProtocolCommand,
@@ -164,6 +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 (SimplexNameDomain)
import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport
@@ -1046,6 +1049,33 @@ sendSMPMessage c nm spKey sId flags msg =
proxySMPMessage :: SMPClient -> NetworkRequestMode -> ProxiedRelay -> Maybe SndPrivateAuthKey -> SenderId -> MsgFlags -> MsgBody -> ExceptT SMPClientError IO (Either ProxyClientError ())
proxySMPMessage c nm proxiedRelay spKey sId flags msg = proxyOKSMPCommand c nm proxiedRelay spKey sId (SEND flags msg)
-- | Resolve a public-namespace name via PFWD. Preferred path - hides the
-- client IP from the resolver. Mirrors `proxySMPMessage`'s shape; routes
-- 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 -> SimplexNameDomain -> ExceptT SMPClientError IO (Either ProxyClientError NameRecord)
proxyResolveName c nm proxiedRelay name
| prVersion proxiedRelay >= namesSMPVersion =
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
-- | Direct (non-PFWD) name resolution. Exposes the client IP to the resolver;
-- callers that want anonymity should use `proxyResolveName` via the standard
-- proxy fallback in the agent. RSLV requires no entity ID or authorization
-- (see `noAuthCmd` in Protocol.hs). Version-gated on the session here, not the
-- encoder, so an old server never receives RSLV.
directResolveName :: SMPClient -> NetworkRequestMode -> SimplexNameDomain -> ExceptT SMPClientError IO NameRecord
directResolveName c nm name
| thVersion (thParams c) >= namesSMPVersion =
sendProtocolCommand c nm Nothing NoEntity (Cmd SResolver (RSLV name)) >>= \case
RNAME nr -> pure nr
r -> throwE $ unexpectedResponse r
| otherwise = throwE $ PCETransportError TEVersion
-- | Acknowledge message delivery (server deletes the message).
--
-- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#acknowledge-message-delivery
src/Simplex/Messaging/Encoding/String.hs
+2 -1
View File
@@ -262,7 +262,8 @@ textParseJSON name = J.withText name $ maybe (fail name) pure . textDecode
--
-- > newtype Key = Key ByteString
-- > deriving (ToJSON, FromJSON) via (StrJSON "Key" Key)
newtype StrJSON (name :: Symbol) a = StrJSON a
newtype StrJSON (name :: Symbol) a = StrJSON {unStrJSON :: a}
deriving (Eq, Show)
instance StrEncoding a => ToJSON (StrJSON name a) where
toJSON (StrJSON a) = strToJSON a
src/Simplex/Messaging/Names/Record.hs
+46
View File
@@ -0,0 +1,46 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
module Simplex.Messaging.Names.Record
( NameRecord (..),
)
where
import qualified Data.Aeson as J
import qualified Data.Aeson.TH as JQ
import Data.Text (Text)
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
-- (server diagnostics) are TH-derived from one Options value, so the Haskell
-- type IS the schema. Text fields use the empty string as the "unset"
-- sentinel; coin fields use JSON null. simplexContact / simplexChannel are
-- arrays of links (primary first, empty when unset) so a name can advertise
-- fallback SMP servers. owner / resolver are 0x-hex Ethereum addresses, kept
-- verbatim as text (the resolver is the source of truth for their validity).
-- The only size bound is the SMP transport block (enforced by the framing).
data NameRecord = NameRecord
{ nrName :: Text,
nrNickname :: Text,
nrWebsite :: Text,
nrLocation :: Text,
nrSimplexContact :: [Text],
nrSimplexChannel :: [Text],
nrEth :: Maybe Text,
nrBtc :: Maybe Text,
nrXmr :: Maybe Text,
nrDot :: Maybe Text,
nrOwner :: Text,
nrResolver :: Text -- resolver address (0x hex) that produced the record
}
deriving (Eq, Show)
-- omitNothingFields False so absent coin fields surface as JSON null (matches
-- the resolver output for unset coins).
$( JQ.deriveJSON
defaultJSON {J.omitNothingFields = False, J.fieldLabelModifier = dropPrefix "nr"}
''NameRecord
)
src/Simplex/Messaging/Protocol.hs
+59 -1
View File
@@ -80,6 +80,7 @@ module Simplex.Messaging.Protocol
ErrorType (..),
CommandError (..),
ProxyError (..),
NameErrorType (..),
BrokerErrorType (..),
NetworkError (..),
BlockingInfo (..),
@@ -163,6 +164,7 @@ module Simplex.Messaging.Protocol
EncTransmission (..),
FwdResponse (..),
FwdTransmission (..),
NameRecord (..),
MsgFlags (..),
initialSMPClientVersion,
currentSMPClientVersion,
@@ -263,10 +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 (NameRecord (..))
import Simplex.Messaging.Parsers
import Simplex.Messaging.Protocol.Types
import Simplex.Messaging.Server.QueueStore.QueueInfo
import Simplex.Messaging.ServiceScheme
import Simplex.Messaging.SimplexName (SimplexNameDomain)
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Client (TransportHost, TransportHosts (..))
import Simplex.Messaging.Util (bshow, eitherToMaybe, safeDecodeUtf8, (<$?>))
@@ -343,6 +347,7 @@ data Party
| LinkClient
| ProxiedClient
| ProxyService
| Resolver
deriving (Show)
-- | Singleton types for SMP protocol clients
@@ -357,6 +362,7 @@ data SParty :: Party -> Type where
SSenderLink :: SParty LinkClient
SProxiedClient :: SParty ProxiedClient
SProxyService :: SParty ProxyService
SResolver :: SParty Resolver
instance TestEquality SParty where
testEquality SCreator SCreator = Just Refl
@@ -369,6 +375,7 @@ instance TestEquality SParty where
testEquality SSenderLink SSenderLink = Just Refl
testEquality SProxiedClient SProxiedClient = Just Refl
testEquality SProxyService SProxyService = Just Refl
testEquality SResolver SResolver = Just Refl
testEquality _ _ = Nothing
deriving instance Show (SParty p)
@@ -395,6 +402,8 @@ instance PartyI ProxiedClient where sParty = SProxiedClient
instance PartyI ProxyService where sParty = SProxyService
instance PartyI Resolver where sParty = SResolver
-- command parties that can read queues
type family QueueParty (p :: Party) :: Constraint where
QueueParty Recipient = ()
@@ -473,6 +482,7 @@ partyClientRole = \case
SSenderLink -> Just SRMessaging
SProxiedClient -> Just SRMessaging
SProxyService -> Just SRProxy
SResolver -> Just SRMessaging
{-# INLINE partyClientRole #-}
partyServiceRole :: ServiceParty p => SParty p -> SMPServiceRole
@@ -597,6 +607,8 @@ data Command (p :: Party) where
-- - entity ID: empty
-- - 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 :: SimplexNameDomain -> Command Resolver
deriving instance Show (Command p)
@@ -732,6 +744,8 @@ data BrokerMsg where
OK :: BrokerMsg
ERR :: ErrorType -> BrokerMsg
PONG :: BrokerMsg
-- Resolved SimpleX name.
RNAME :: NameRecord -> BrokerMsg
deriving (Eq, Show)
data RcvMessage = RcvMessage
@@ -942,6 +956,7 @@ data CommandTag (p :: Party) where
RFWD_ :: CommandTag ProxyService
NSUB_ :: CommandTag Notifier
NSUBS_ :: CommandTag NotifierService
RSLV_ :: CommandTag Resolver
data CmdTag = forall p. PartyI p => CT (SParty p) (CommandTag p)
@@ -968,6 +983,7 @@ data BrokerMsgTag
| OK_
| ERR_
| PONG_
| RNAME_
deriving (Show)
class ProtocolMsgTag t where
@@ -1004,6 +1020,7 @@ instance PartyI p => Encoding (CommandTag p) where
RFWD_ -> "RFWD"
NSUB_ -> "NSUB"
NSUBS_ -> "NSUBS"
RSLV_ -> "RSLV"
smpP = messageTagP
instance ProtocolMsgTag CmdTag where
@@ -1032,6 +1049,7 @@ instance ProtocolMsgTag CmdTag where
"RFWD" -> Just $ CT SProxyService RFWD_
"NSUB" -> Just $ CT SNotifier NSUB_
"NSUBS" -> Just $ CT SNotifierService NSUBS_
"RSLV" -> Just $ CT SResolver RSLV_
_ -> Nothing
instance Encoding CmdTag where
@@ -1061,6 +1079,7 @@ instance Encoding BrokerMsgTag where
OK_ -> "OK"
ERR_ -> "ERR"
PONG_ -> "PONG"
RNAME_ -> "RNAME"
smpP = messageTagP
instance ProtocolMsgTag BrokerMsgTag where
@@ -1083,6 +1102,7 @@ instance ProtocolMsgTag BrokerMsgTag where
"OK" -> Just OK_
"ERR" -> Just ERR_
"PONG" -> Just PONG_
"RNAME" -> Just RNAME_
_ -> Nothing
-- | SMP message body format
@@ -1565,10 +1585,22 @@ data ErrorType
EXPIRED
| -- | internal server error
INTERNAL
| -- | name resolution error
NAME {nameErr :: NameErrorType}
| -- | used internally, never returned by the server (to be removed)
DUPLICATE_ -- not part of SMP protocol, used internally
deriving (Eq, Show)
-- | Name resolution error
data NameErrorType
= -- | the names role / resolver is not configured on this server
NO_RESOLVER
| -- | the name is not registered (resolver returned not-found)
NOT_FOUND
| -- | backing resolver/RPC failure - contains the diagnostic detail
RESOLVER {resolverErr :: Text}
deriving (Eq, Show)
instance StrEncoding ErrorType where
strEncode = \case
BLOCK -> "BLOCK"
@@ -1585,6 +1617,7 @@ instance StrEncoding ErrorType where
LARGE_MSG -> "LARGE_MSG"
EXPIRED -> "EXPIRED"
INTERNAL -> "INTERNAL"
NAME e -> "NAME " <> strEncode e
DUPLICATE_ -> "DUPLICATE_"
strP =
A.choice
@@ -1592,6 +1625,7 @@ instance StrEncoding ErrorType where
"SESSION" $> SESSION,
"CMD " *> (CMD <$> parseRead1),
"PROXY " *> (PROXY <$> strP),
"NAME " *> (NAME <$> strP),
"AUTH" $> AUTH,
"BLOCKED " *> strP,
"SERVICE" $> SERVICE,
@@ -1792,6 +1826,7 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
PRXY host auth_ -> e (PRXY_, ' ', host, auth_)
PFWD fwdV pubKey (EncTransmission s) -> e (PFWD_, ' ', fwdV, pubKey, Tail s)
RFWD (EncFwdTransmission s) -> e (RFWD_, ' ', Tail s)
RSLV d -> e (RSLV_, ' ', d)
where
e :: Encoding a => a -> ByteString
e = smpEncode
@@ -1816,6 +1851,7 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
PRXY {} -> noAuthCmd
PFWD {} -> entityCmd
RFWD _ -> noAuthCmd
RSLV _ -> noAuthCmd
SUB -> serviceCmd
NSUB -> serviceCmd
-- other client commands must have both signature and queue ID
@@ -1899,6 +1935,7 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where
CT SNotifierService NSUBS_
| v >= rcvServiceSMPVersion -> Cmd SNotifierService <$> (NSUBS <$> _smpP <*> smpP)
| otherwise -> pure $ Cmd SNotifierService $ NSUBS (-1) mempty
CT SResolver RSLV_ -> Cmd SResolver . RSLV <$> _smpP <* A.takeByteString
fromProtocolError = fromProtocolError @SMPVersion @ErrorType @BrokerMsg
{-# INLINE fromProtocolError #-}
@@ -1945,6 +1982,7 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
| v < clientNoticesSMPVersion -> BLOCKED info {notice = Nothing}
_ -> err
PONG -> e PONG_
RNAME rec -> e (RNAME_, ' ', Tail $ LB.toStrict $ J.encode rec)
where
e :: Encoding a => a -> ByteString
e = smpEncode
@@ -1992,6 +2030,7 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
OK_ -> pure OK
ERR_ -> ERR <$> _smpP
PONG_ -> pure PONG
RNAME_ -> fmap RNAME . J.eitherDecodeStrict . unTail <$?> _smpP
where
serviceRespP resp
| v >= rcvServiceSMPVersion = resp <$> _smpP <*> smpP
@@ -2014,6 +2053,7 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
PKEY {} -> noEntityMsg
RRES _ -> noEntityMsg
ALLS -> noEntityMsg
RNAME _ -> noEntityMsg
-- other broker responses must have queue ID
_
| B.null entId -> Left $ CMD NO_ENTITY
@@ -2056,6 +2096,7 @@ instance Encoding ErrorType where
NO_MSG -> "NO_MSG"
LARGE_MSG -> "LARGE_MSG"
INTERNAL -> "INTERNAL"
NAME err -> "NAME " <> smpEncode err
DUPLICATE_ -> "DUPLICATE_"
smpP =
@@ -2074,9 +2115,26 @@ instance Encoding ErrorType where
"NO_MSG" -> pure NO_MSG
"LARGE_MSG" -> pure LARGE_MSG
"INTERNAL" -> pure INTERNAL
"NAME" -> NAME <$> _smpP
"DUPLICATE_" -> pure DUPLICATE_
_ -> fail "bad ErrorType"
instance Encoding NameErrorType where
smpEncode = \case
NO_RESOLVER -> "NO_RESOLVER"
NOT_FOUND -> "NOT_FOUND"
RESOLVER e -> "RESOLVER " <> encodeUtf8 e
smpP =
A.takeTill (== ' ') >>= \case
"NO_RESOLVER" -> pure NO_RESOLVER
"NOT_FOUND" -> pure NOT_FOUND
"RESOLVER" -> RESOLVER . safeDecodeUtf8 <$> (A.space *> A.takeByteString)
_ -> fail "bad NameErrorType"
instance StrEncoding NameErrorType where
strEncode = smpEncode
strP = smpP
instance Encoding CommandError where
smpEncode e = case e of
UNKNOWN -> "UNKNOWN"
@@ -2376,4 +2434,4 @@ $(J.deriveJSON (sumTypeJSON id) ''BrokerErrorType)
$(J.deriveJSON defaultJSON ''BlockingInfo)
-- run deriveJSON in one TH splice to allow mutual instance
$(concat <$> mapM @[] (J.deriveJSON (sumTypeJSON id)) [''ProxyError, ''ErrorType])
$(concat <$> mapM @[] (J.deriveJSON (sumTypeJSON id)) [''ProxyError, ''NameErrorType, ''ErrorType])
src/Simplex/Messaging/Server.hs
+77 -40
View File
@@ -65,7 +65,7 @@ import Data.Constraint (Dict (..))
import Data.Dynamic (toDyn)
import Data.Either (fromRight, partitionEithers)
import Data.Foldable (foldrM)
import Data.Functor (($>))
import Data.Functor (($>), (<&>))
import Data.IORef
import Data.Int (Int64)
import qualified Data.IntMap.Strict as IM
@@ -103,11 +103,13 @@ import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol
import Simplex.Messaging.SimplexName (SimplexNameDomain)
import Simplex.Messaging.Server.Control
import Simplex.Messaging.Server.Env.STM as Env
import Simplex.Messaging.Server.Expiration
import Simplex.Messaging.Server.MsgStore
import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore, JournalQueue (..), getJournalQueueMessages)
import Simplex.Messaging.Server.Names (NamesEnv, closeNamesEnv, resolveName)
import Simplex.Messaging.Server.MsgStore.STM
import Simplex.Messaging.Server.MsgStore.Types
import Simplex.Messaging.Server.NtfStore
@@ -245,7 +247,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
saveServerStats
closeServer :: M s ()
closeServer = asks (smpAgent . proxyAgent) >>= liftIO . closeSMPClientAgent
closeServer = do
asks (smpAgent . proxyAgent) >>= liftIO . closeSMPClientAgent
asks namesEnv >>= liftIO . mapM_ closeNamesEnv
serverThread ::
forall sub. String ->
@@ -517,7 +521,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime
liftIO $ putStrLn $ "server stats log enabled: " <> statsFilePath
liftIO $ threadDelay' $ 1000000 * (initialDelay + if initialDelay < 0 then 86400 else 0)
ss@ServerStats {fromTime, qCreated, qSecured, qDeletedAll, qDeletedAllB, qDeletedNew, qDeletedSecured, qSub, qSubAllB, qSubAuth, qSubDuplicate, qSubProhibited, qSubEnd, qSubEndB, ntfCreated, ntfDeleted, ntfDeletedB, ntfSub, ntfSubB, ntfSubAuth, ntfSubDuplicate, msgSent, msgSentAuth, msgSentQuota, msgSentLarge, msgRecv, msgRecvGet, msgGet, msgGetNoMsg, msgGetAuth, msgGetDuplicate, msgGetProhibited, msgExpired, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount, ntfCount, pRelays, pRelaysOwn, pMsgFwds, pMsgFwdsOwn, pMsgFwdsRecv, rcvServices, ntfServices}
ss@ServerStats {fromTime, qCreated, qSecured, qDeletedAll, qDeletedAllB, qDeletedNew, qDeletedSecured, qSub, qSubAllB, qSubAuth, qSubDuplicate, qSubProhibited, qSubEnd, qSubEndB, ntfCreated, ntfDeleted, ntfDeletedB, ntfSub, ntfSubB, ntfSubAuth, ntfSubDuplicate, msgSent, msgSentAuth, msgSentQuota, msgSentLarge, msgRecv, msgRecvGet, msgGet, msgGetNoMsg, msgGetAuth, msgGetDuplicate, msgGetProhibited, msgExpired, activeQueues, msgSentNtf, msgRecvNtf, activeQueuesNtf, qCount, msgCount, ntfCount, pRelays, pRelaysOwn, pMsgFwds, pMsgFwdsOwn, pMsgFwdsRecv, rcvServices, ntfServices, rslvStats}
<- asks serverStats
st <- asks msgStore
EntityCounts {queueCount, notifierCount, rcvServiceCount, ntfServiceCount, rcvServiceQueuesCount, ntfServiceQueuesCount} <-
@@ -580,6 +584,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
qCount' <- readIORef qCount
msgCount' <- readIORef msgCount
ntfCount' <- readIORef ntfCount
rslvStats' <- getResetNameResolverStatsData rslvStats
T.hPutStrLn h $
T.intercalate
","
@@ -653,6 +658,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
]
<> showServiceStats rcvServices'
<> showServiceStats ntfServices'
<> showNameResolverStats rslvStats'
)
liftIO $ threadDelay' interval
where
@@ -660,6 +666,8 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt
map tshow [_pRequests, _pSuccesses, _pErrorsConnect, _pErrorsCompat, _pErrorsOther]
showServiceStats ServiceStatsData {_srvAssocNew, _srvAssocDuplicate, _srvAssocUpdated, _srvAssocRemoved, _srvSubCount, _srvSubDuplicate, _srvSubQueues, _srvSubEnd} =
map tshow [_srvAssocNew, _srvAssocDuplicate, _srvAssocUpdated, _srvAssocRemoved, _srvSubCount, _srvSubDuplicate, _srvSubQueues, _srvSubEnd]
showNameResolverStats NameResolverStatsData {_rslvReqs, _rslvSucc, _rslvNotFound, _rslvResolverErrs, _rslvDisabled} =
map tshow [_rslvReqs, _rslvSucc, _rslvNotFound, _rslvResolverErrs, _rslvDisabled]
prometheusMetricsThread_ :: ServerConfig s -> [M s ()]
prometheusMetricsThread_ ServerConfig {prometheusInterval = Just interval, prometheusMetricsFile} =
@@ -1266,6 +1274,7 @@ verifyQueueTransmission service thAuth (tAuth, authorized, (corrId, entId, comma
vc SNotifierService NSUBS {} = verifyServiceCmd
vc SProxiedClient _ = VRVerified Nothing
vc SProxyService (RFWD _) = VRVerified Nothing
vc SResolver (RSLV _) = VRVerified Nothing
checkRole = case (service, partyClientRole p) of
(Just THClientService {serviceRole}, Just role) -> serviceRole == role
_ -> True
@@ -1463,19 +1472,40 @@ client
Nothing -> inc False pRequests >> inc False pErrorsConnect $> Just (ERR $ PROXY NO_SESSION)
where
forkProxiedCmd :: M s BrokerMsg -> M s (Maybe BrokerMsg)
forkProxiedCmd cmdAction = do
bracket_ wait signal . forkClient clnt (B.unpack $ "client $" <> encode sessionId <> " proxy") $ do
-- commands MUST be processed under a reasonable timeout or the client would halt
cmdAction >>= \t -> atomically $ writeTBQueue sndQ ([(corrId, EntityId sessId, t)], [])
pure Nothing
where
wait = do
ServerConfig {serverClientConcurrency} <- asks config
atomically $ do
used <- readTVar procThreads
when (used >= serverClientConcurrency) retry
writeTVar procThreads $! used + 1
signal = atomically $ modifyTVar' procThreads (\t -> t - 1)
forkProxiedCmd = forkCmd serverClientConcurrency corrId (EntityId sessId)
-- 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
bracket_ wait signal . forkClient clnt (B.unpack $ "client $" <> encode sessionId <> " cmd") $
-- commands MUST be processed under a reasonable timeout or the client would halt
cmdAction >>= \t -> atomically $ writeTBQueue sndQ ([(corrId, entId, t)], [])
pure Nothing
where
wait = do
limit <- asks (concurrency . config)
atomically $ do
used <- readTVar procThreads
when (used >= limit) retry
writeTVar procThreads $! used + 1
signal = atomically $ modifyTVar' procThreads (\t -> t - 1)
rslvNamesEnv :: M s (Maybe NamesEnv)
rslvNamesEnv = do
st <- asks (rslvStats . serverStats)
incStat (rslvReqs st)
asks namesEnv >>= \case
Nothing -> incStat (rslvDisabled st) $> Nothing
Just nenv -> pure (Just nenv)
-- Runs on a forked thread so RSLV does not block other commands;
-- concurrency is limited by serverResolverConcurrency in forkCmd.
resolveNameMsg :: NamesEnv -> SimplexNameDomain -> M s BrokerMsg
resolveNameMsg nenv d = do
st <- asks (rslvStats . serverStats)
(selector, msg) <-
liftIO (resolveName nenv d) <&> \case
Right rec -> (rslvSucc, RNAME rec)
Left e@NOT_FOUND -> (rslvNotFound, ERR $ NAME e)
Left e -> (rslvResolverErrs, ERR $ NAME e)
incStat (selector st) $> msg
transportErr :: TransportError -> ErrorType
transportErr = PROXY . BROKER . TRANSPORT
mkIncProxyStats :: MonadIO m => ProxyStats -> ProxyStats -> OwnServer -> (ProxyStats -> IORef Int) -> m ()
@@ -1489,7 +1519,10 @@ client
SKEY k -> withQueue $ \q qr -> checkMode QMMessaging qr $ secureQueue_ q k
SEND flags msgBody -> response <$> withQueue_ False err (sendMessage flags msgBody)
Cmd SIdleClient PING -> pure $ response (corrId, NoEntity, PONG)
Cmd SProxyService (RFWD encBlock) -> response . (corrId,NoEntity,) <$> processForwardedCommand encBlock
Cmd SProxyService (RFWD encBlock) -> (response . (corrId, NoEntity,) =<<) <$> processForwardedCommand encBlock
Cmd SResolver (RSLV d) -> rslvNamesEnv >>= \case
Nothing -> pure $ response (corrId, NoEntity, ERR (NAME NO_RESOLVER))
Just nenv -> forkCmd serverResolverConcurrency corrId NoEntity (resolveNameMsg nenv d)
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
@@ -2087,8 +2120,8 @@ client
encNMsgMeta = C.cbEncrypt rcvNtfDhSecret ntfNonce (smpEncode msgMeta) 128
pure $ MsgNtf {ntfMsgId = msgId, ntfTs = msgTs, ntfNonce, ntfEncMeta = fromRight "" encNMsgMeta}
processForwardedCommand :: EncFwdTransmission -> M s BrokerMsg
processForwardedCommand (EncFwdTransmission s) = fmap (either ERR RRES) . runExceptT $ do
processForwardedCommand :: EncFwdTransmission -> M s (Maybe BrokerMsg)
processForwardedCommand (EncFwdTransmission s) = fmap (either (Just . ERR) id) . runExceptT $ do
THAuthServer {serverPrivKey, sessSecret'} <- maybe (throwE $ transportErr TENoServerAuth) pure (thAuth thParams')
sessSecret <- maybe (throwE $ transportErr TENoServerAuth) pure sessSecret'
let proxyNonce = C.cbNonce $ bs corrId
@@ -2103,28 +2136,31 @@ client
t :| [] -> pure $ tDecodeServer clntTHParams t
_ -> throwE BLOCK
let clntThAuth = Just $ THAuthServer {serverPrivKey, peerClientService = Nothing, sessSecret' = Just clientSecret}
-- process forwarded command
r <-
lift (rejectOrVerify clntThAuth t') >>= \case
Left r -> pure r
-- rejectOrVerify filters allowed commands, no need to repeat it here.
-- INTERNAL is used because processCommand never returns Nothing for sender commands (could be extracted for better types).
-- `fst` removes empty message that is only returned for `SUB` command
Right t''@(_, (corrId', entId', _)) -> maybe (corrId', entId', ERR INTERNAL) fst <$> lift (processCommand Nothing fwdVersion (Right (M.empty, M.empty, M.empty)) t'')
-- encode response
r' <- case batchTransmissions clntTHParams [Right (Nothing, encodeTransmission clntTHParams r)] of
[] -> throwE INTERNAL -- at least 1 item is guaranteed from NonEmpty/Right
TBError _ _ : _ -> throwE BLOCK
TBTransmission b' _ : _ -> pure b'
TBTransmissions b' _ _ : _ -> pure b'
-- encrypt to client
r2 <- liftEitherWith (const BLOCK) $ EncResponse <$> C.cbEncrypt clientSecret (C.reverseNonce clientNonce) r' paddedProxiedTLength
-- encrypt to proxy
let fr = FwdResponse {fwdCorrId, fwdResponse = r2}
r3 = EncFwdResponse $ C.cbEncryptNoPad sessSecret (C.reverseNonce proxyNonce) (smpEncode fr)
encodeResp r = do
r' <- case batchTransmissions clntTHParams [Right (Nothing, encodeTransmission clntTHParams r)] of
[] -> throwE INTERNAL -- at least 1 item is guaranteed from NonEmpty/Right
TBError _ _ : _ -> throwE BLOCK
TBTransmission b' _ : _ -> pure b'
TBTransmissions b' _ _ : _ -> pure b'
r2 <- liftEitherWith (const BLOCK) $ EncResponse <$> C.cbEncrypt clientSecret (C.reverseNonce clientNonce) r' paddedProxiedTLength
let fr = FwdResponse {fwdCorrId, fwdResponse = r2}
pure $ RRES $ EncFwdResponse $ C.cbEncryptNoPad sessSecret (C.reverseNonce proxyNonce) (smpEncode fr)
-- the inner response, or Nothing if forked (RSLV).
r_ <- lift (rejectOrVerify clntThAuth t') >>= \case
-- rejectOrVerify filters allowed commands, no need to repeat it here.
Left r -> pure $ Just r
Right t''@(_, (corrId', entId', cmd')) -> case cmd' of
Cmd SResolver (RSLV d) -> lift $ rslvNamesEnv >>= \case
Nothing -> pure $ Just (corrId', entId', ERR (NAME NO_RESOLVER))
Just nenv -> forkCmd serverResolverConcurrency corrId NoEntity $ do
msg <- resolveNameMsg nenv d
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.
_ -> Just . maybe (corrId', entId', ERR INTERNAL) fst <$> lift (processCommand Nothing fwdVersion (Right (M.empty, M.empty, M.empty)) t'')
stats <- asks serverStats
incStat $ pMsgFwdsRecv stats
pure r3
traverse encodeResp r_
where
rejectOrVerify :: Maybe (THandleAuth 'TServer) -> SignedTransmissionOrError ErrorType Cmd -> M s (VerifiedTransmissionOrError s)
rejectOrVerify clntThAuth = \case
@@ -2138,6 +2174,7 @@ client
Cmd SSender (SKEY _) -> True
Cmd SSenderLink (LKEY _) -> True
Cmd SSenderLink LGET -> True
Cmd SResolver (RSLV _) -> True
_ -> False
verified = \case
VRVerified q -> Right (q, t'')
@@ -2472,4 +2509,4 @@ restoreServerStats msgStats_ ntfStats = asks (serverStatsBackupFile . config) >>
logNote $ "error restoring server stats: " <> T.pack e
liftIO exitFailure
compareCounts name statsCnt storeCnt =
when (statsCnt /= storeCnt) $ logWarn $ name <> " count differs: stats: " <> tshow statsCnt <> ", store: " <> tshow storeCnt
when (statsCnt /= storeCnt) $ logWarn $ name <> " count differs: stats: " <> tshow statsCnt <> ", store: " <> tshow storeCnt
src/Simplex/Messaging/Server/Env/STM.hs
+28 -4
View File
@@ -67,6 +67,7 @@ module Simplex.Messaging.Server.Env.STM
defaultNtfExpiration,
defaultInactiveClientExpiration,
defaultProxyClientConcurrency,
defaultNameResolverConcurrency,
defaultMaxJournalMsgCount,
defaultMaxJournalStateLines,
defaultIdleQueueInterval,
@@ -115,6 +116,7 @@ import Simplex.Messaging.Server.Information
import Simplex.Messaging.Server.MsgStore.Journal
import Simplex.Messaging.Server.MsgStore.STM
import Simplex.Messaging.Server.MsgStore.Types
import Simplex.Messaging.Server.Names (NamesConfig (..), NamesEnv, newNamesEnv, pingEndpoint)
import Simplex.Messaging.Server.NtfStore
import Simplex.Messaging.Server.QueueStore
import Simplex.Messaging.Server.QueueStore.Postgres.Config
@@ -128,7 +130,7 @@ import Simplex.Messaging.TMap (TMap)
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport (ASrvTransport, SMPVersion, THandleParams, TransportPeer (..), VersionRangeSMP)
import Simplex.Messaging.Transport.Server
import Simplex.Messaging.Util (ifM, whenM, ($>>=))
import Simplex.Messaging.Util (ifM, tshow, whenM, ($>>=))
import System.Directory (doesFileExist)
import System.Exit (exitFailure)
import System.IO (IOMode (..))
@@ -197,6 +199,13 @@ data ServerConfig s = ServerConfig
smpAgentCfg :: SMPClientAgentConfig,
allowSMPProxy :: Bool, -- auth is the same with `newQueueBasicAuth`
serverClientConcurrency :: Int,
-- | max concurrent name resolutions per connection, enforced in forkCmd.
-- Much higher than serverClientConcurrency: forwarded RSLVs from many clients
-- aggregate over a single proxy->relay connection (only servers send proxied
-- requests), so bounding them by the per-client limit would throttle unduly.
serverResolverConcurrency :: Int,
-- | public-namespace resolver config; Nothing disables the names role
namesConfig :: Maybe NamesConfig,
-- | server public information
information :: Maybe ServerPublicInfo,
startOptions :: StartOptions
@@ -243,6 +252,9 @@ defaultInactiveClientExpiration =
defaultProxyClientConcurrency :: Int
defaultProxyClientConcurrency = 32
defaultNameResolverConcurrency :: Int
defaultNameResolverConcurrency = 1000
journalMsgStoreDepth :: Int
journalMsgStoreDepth = 5
@@ -272,7 +284,8 @@ data Env s = Env
serverStats :: ServerStats,
sockets :: TVar [(ServiceName, SocketState)],
clientSeq :: TVar ClientId,
proxyAgent :: ProxyAgent -- senders served on this proxy
proxyAgent :: ProxyAgent, -- senders served on this proxy
namesEnv :: Maybe NamesEnv -- public-namespace resolver, present when [NAMES] enable: on
}
msgStore :: Env s -> s
@@ -558,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} = 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
@@ -603,6 +616,16 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp
sockets <- newTVarIO []
clientSeq <- newTVarIO 0
proxyAgent <- newSMPProxyAgent smpAgentCfg random
namesEnv <- forM namesConfig $ \nc -> do
logInfo $ "[NAMES] resolver enabled, endpoint=" <> T.pack (resolverEndpoint nc)
env <- newNamesEnv nc
-- Probe the endpoint at startup. Don't exitFailure: a flapping network or a
-- resolver host coming up minutes after smp-server should not block the
-- server. Log so operators can spot it.
pingEndpoint env >>= \case
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
pure
Env
{ serverActive,
@@ -618,7 +641,8 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp
serverStats,
sockets,
clientSeq,
proxyAgent
proxyAgent,
namesEnv
}
where
loadStoreLog :: StoreQueueClass q => (RecipientId -> QueueRec -> IO q) -> FilePath -> STMQueueStore q -> IO ()
src/Simplex/Messaging/Server/Main.hs
+64 -1
View File
@@ -34,6 +34,7 @@ module Simplex.Messaging.Server.Main
simplexmqSource,
serverPublicInfo,
validCountryValue,
validateUrl,
printSourceCode,
cliCommandP,
strParse,
@@ -50,7 +51,7 @@ import Data.Char (isAlpha, isAscii, toUpper)
import Data.Either (fromRight)
import Data.Functor (($>))
import Data.Ini (Ini, lookupValue, readIniFile)
import Data.List (find, isPrefixOf)
import Data.List (dropWhileEnd, find, isPrefixOf)
import qualified Data.List.NonEmpty as L
import Data.Maybe (fromMaybe, isJust, isNothing)
import Data.Text (Text)
@@ -66,6 +67,7 @@ import Simplex.Messaging.Client.Agent (SMPClientAgentConfig (..), defaultSMPClie
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (parseAll)
import Network.URI (URI (..), URIAuth (..), parseAbsoluteURI)
import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (ProtoServerWithAuth), pattern SMPServer)
import Simplex.Messaging.Server (AttachHTTP, exportMessages, importMessages, printMessageStats, runSMPServer)
import Simplex.Messaging.Server.CLI
@@ -76,6 +78,7 @@ import Simplex.Messaging.Server.Main.Init
import Simplex.Messaging.Server.Web (EmbeddedWebParams (..), WebHttpsParams (..))
import Simplex.Messaging.Server.MsgStore.Journal (JournalMsgStore (..), QStoreCfg (..), stmQueueStore)
import Simplex.Messaging.Server.MsgStore.Types (MsgStoreClass (..), SQSType (..), SMSType (..), newMsgStore)
import Simplex.Messaging.Server.Names (NamesConfig (..), RpcAuth (..))
import Simplex.Messaging.Server.QueueStore.Postgres.Config
import Simplex.Messaging.Server.StoreLog.ReadWrite (readQueueStore)
import Simplex.Messaging.Transport (supportedProxyClientSMPRelayVRange, alpnSupportedSMPHandshakes, supportedServerSMPRelayVRange)
@@ -605,6 +608,8 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath =
},
allowSMPProxy = True,
serverClientConcurrency = readIniDefault defaultProxyClientConcurrency "PROXY" "client_concurrency" ini,
serverResolverConcurrency = readIniDefault defaultNameResolverConcurrency "NAMES" "resolver_concurrency" ini,
namesConfig = readNamesConfig ini,
information = serverPublicInfo ini,
startOptions
}
@@ -796,6 +801,64 @@ validCountryValue field s
| length s == 2 && all (\c -> isAscii c && isAlpha c) s = Right $ T.pack $ map toUpper s
| otherwise = Left $ "Use ISO3166 2-letter code for " <> field
readNamesConfig :: Ini -> Maybe NamesConfig
readNamesConfig ini
| not enabled = Nothing
| otherwise =
let resolverAuth_ = either (error . ("[NAMES] resolver_auth: " <>)) Just . parseRpcAuth =<< eitherToMaybe (lookupValue "NAMES" "resolver_auth" ini)
endpoint = requiredText "resolver_endpoint"
in Just
NamesConfig
{ resolverEndpoint = either (error . ("[NAMES] resolver_endpoint: " <>)) id (validateUrl endpoint resolverAuth_),
resolverAuth = resolverAuth_,
resolverTimeoutMs = boundedIniInt 3000 100 60000 "resolver_timeout_ms",
resolverMaxResponseBytes = boundedIniInt 16000 1024 16000 "resolver_max_response_bytes"
}
where
enabled = fromMaybe False (iniOnOff "NAMES" "enable" ini)
requiredText key =
either (error . (("[NAMES] " <> T.unpack key <> " is required: ") <>)) id $
lookupValue "NAMES" key ini
boundedIniInt def floor_ ceiling_ key = case lookupValue "NAMES" key ini of
Left _ -> def
Right raw -> case readMaybe (T.unpack (T.strip raw)) of
Nothing ->
error $ "[NAMES] " <> T.unpack key <> ": not an integer (got " <> show raw <> ")"
Just n
| n >= floor_ && n <= ceiling_ -> n
| otherwise ->
error $ "[NAMES] " <> T.unpack key <> " must be in [" <> show floor_ <> ".." <> show ceiling_ <> "] (got " <> show n <> ")"
-- | Validate the resolver_endpoint URL: it must be an absolute http(s) URL with a host.
-- http + resolver_auth to a non-loopback host is rejected.
validateUrl :: Text -> Maybe RpcAuth -> Either String String
validateUrl url auth_ = do
let s = T.unpack url
uri <- maybe (Left "not an absolute URI") Right $ parseAbsoluteURI s
let scheme = uriScheme uri
unless (scheme == "http:" || scheme == "https:") $ Left "scheme must be http or https"
ua <- maybe (Left "missing host") Right (uriAuthority uri)
let host = uriRegName ua
when (null host) $ Left "empty host"
unless (null (uriUserInfo ua)) $ Left "userinfo (user:pass@) not allowed; put credentials in resolver_auth"
when (scheme == "http:" && isJust auth_ && not (isLoopback host)) $
Left "http with resolver_auth on a non-loopback host not allowed (the Authorization header would travel in cleartext); use https, or drop resolver_auth"
Right (dropWhileEnd (== '/') s)
where
isLoopback h = h == "localhost" || h == "127.0.0.1" || h == "[::1]" || h == "0.0.0.0"
-- | Parse an rpc_auth INI value. Scheme keyword is case-insensitive so
-- "Bearer <token>" / "BEARER <token>" (Caddy / RFC 7235 convention) work
-- as well as the lowercase form.
parseRpcAuth :: Text -> Either String RpcAuth
parseRpcAuth t = case T.words t of
[scheme, tok] | T.toLower scheme == "bearer" -> Right $ AuthBearer tok
[scheme, up] | T.toLower scheme == "basic" -> case T.breakOn ":" up of
(u, rest)
| not (T.null u) && ":" `T.isPrefixOf` rest -> Right $ AuthBasic u (T.drop 1 rest)
_ -> Left "basic auth expects user:password"
_ -> Left "expected `bearer <token>` or `basic <user>:<pass>`"
printSourceCode :: Maybe Text -> IO ()
printSourceCode = \case
Just sourceCode -> T.putStrLn $ "Server source code: " <> sourceCode
src/Simplex/Messaging/Server/Main/Init.hs
+16
View File
@@ -154,6 +154,22 @@ iniFileContent cfgPath logPath opts host basicAuth controlPortPwds =
\# socks_mode = onion\n\n\
\# Limit number of threads a client can spawn to process proxy commands in parrallel.\n"
<> ("# client_concurrency = " <> tshow defaultProxyClientConcurrency)
<> "\n\n\
\[NAMES]\n\
\# Public-namespace resolution via the snrc-resolve.py REST resolver.\n\
\# Operator runs the resolver alongside smp-server (default port 8000)\n\
\# with its own Ethereum JSON-RPC endpoint configured in resolver.toml.\n\
\enable: off\n\
\# Same-host:\n\
\# resolver_endpoint: http://127.0.0.1:8000\n\
\# Resolver behind TLS reverse proxy:\n\
\# resolver_endpoint: https://names.simplex.chat:443\n\
\# resolver_auth: basic <username>:<password>\n\
\# resolver_timeout_ms: 3000\n\
\# resolver_max_response_bytes: 16000\n\
\# Max concurrent name resolutions per connection (forwarded RSLVs from many\n\
\# clients share one proxy connection, so this is much higher than PROXY client_concurrency).\n"
<> ("# resolver_concurrency = " <> tshow defaultNameResolverConcurrency)
<> "\n\n\
\[INACTIVE_CLIENTS]\n\
\# TTL and interval to check inactive clients\n\
src/Simplex/Messaging/Server/Names.hs
+84
View File
@@ -0,0 +1,84 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
module Simplex.Messaging.Server.Names
( NamesConfig (..),
RpcAuth (..),
NamesEnv (..),
newNamesEnv,
closeNamesEnv,
pingEndpoint,
resolveName,
)
where
import qualified Control.Exception as E
import Control.Logger.Simple (logError)
import Data.Bifunctor (first)
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Simplex.Messaging.Protocol (NameErrorType (..), NameRecord)
import Simplex.Messaging.Server.Names.HttpResolver
( ResolverEnv,
ResolverError (..),
RpcAuth (..),
closeResolverEnv,
healthHttp,
newResolverEnv,
resolveHttp,
)
import Simplex.Messaging.SimplexName (SimplexNameDomain, fullDomainName)
import System.Timeout (timeout)
data NamesConfig = NamesConfig
{ resolverEndpoint :: String,
resolverAuth :: Maybe RpcAuth,
resolverTimeoutMs :: Int,
resolverMaxResponseBytes :: Int
}
deriving (Show)
data NamesEnv = NamesEnv
{ config :: NamesConfig,
resolverEnv :: ResolverEnv
}
newNamesEnv :: NamesConfig -> IO NamesEnv
newNamesEnv config = do
resolverEnv <- newResolverEnv (resolverEndpoint config) (resolverAuth config) (resolverTimeoutMs config) (resolverMaxResponseBytes config)
pure NamesEnv {config, resolverEnv}
closeNamesEnv :: NamesEnv -> IO ()
closeNamesEnv NamesEnv {resolverEnv} = closeResolverEnv resolverEnv
pingEndpoint :: NamesEnv -> IO (Either ResolverError ())
pingEndpoint NamesEnv {resolverEnv, config} =
fromMaybe (Left ResolverTimeout) <$> timeout (resolverTimeoutMs config * 1000) (healthHttp resolverEnv)
resolveName :: NamesEnv -> SimplexNameDomain -> 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
| Just (_ :: E.SomeAsyncException) <- E.fromException e -> E.throwIO e
| otherwise -> do
logError $ "[NAMES] resolver fetch raised " <> T.pack (E.displayException e)
pure (Left (RESOLVER "resolver error"))
fetch :: NamesEnv -> SimplexNameDomain -> 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"
InvalidJson _ -> RESOLVER "invalid response"
ResolverTimeout -> RESOLVER "timeout"
src/Simplex/Messaging/Server/Names/HttpResolver.hs
+144
View File
@@ -0,0 +1,144 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
-- | HTTP transport for the public-namespace resolver.
--
-- The Python REST resolver (see scripts/resolver/snrc-resolve.py) exposes
--
-- GET /resolve/<name> -> 200 with a NameRecord JSON document
-- 404 / 400 for unknown names / TLDs
-- 502 for upstream RPC failures
-- GET /health -> 200 when the resolver process is ready
--
-- Boundary properties:
-- * Response body read with `brReadSome maxResponseBytes` — adversarial
-- endpoints cannot exhaust memory with multi-GB bodies.
-- * `redirectCount = 0` — a compromised resolver cannot bounce credentials
-- to a private-IP target (SSRF amplification on top of the URL validation
-- performed at config load in Server.Main.validateUrl).
-- * Authorization header attached only when configured.
module Simplex.Messaging.Server.Names.HttpResolver
( RpcAuth (..),
ResolverEnv,
ResolverError (..),
newResolverEnv,
closeResolverEnv,
resolveHttp,
healthHttp,
)
where
import qualified Control.Exception as E
import qualified Data.Aeson as J
import Data.Bifunctor (first)
import qualified Data.ByteArray.Encoding as BAE
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as BL
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Network.HTTP.Client
( HttpException,
Manager,
ManagerSettings (..),
brReadSome,
parseRequest,
redirectCount,
requestHeaders,
responseBody,
responseStatus,
responseTimeoutMicro,
withResponse,
)
import qualified Network.HTTP.Client as HC
import Network.HTTP.Client.TLS (tlsManagerSettings)
import qualified Network.HTTP.Types as HT
import Network.HTTP.Types.URI (urlEncode)
import Simplex.Messaging.Names.Record (NameRecord)
data RpcAuth = AuthBearer Text | AuthBasic Text Text
-- | Redacts the bearer token / basic-auth password so an accidental
-- `show` / `tshow` on NamesConfig never lands secrets in logs.
instance Show RpcAuth where
show (AuthBearer _) = "AuthBearer <redacted>"
show (AuthBasic u _) = "AuthBasic " <> show u <> " <redacted>"
data ResolverEnv = ResolverEnv
{ manager :: Manager,
baseUrl :: String,
authHdr :: [HT.Header],
timeoutMicro :: Int,
maxResponseBytes :: Int
}
data ResolverError
= HttpFailure HttpException
| HttpStatusErr Int
| BodyTooLarge
| InvalidJson String
| ResolverTimeout
deriving (Show)
newResolverEnv :: String -> Maybe RpcAuth -> Int -> Int -> IO ResolverEnv
newResolverEnv baseUrl auth_ timeoutMs maxResponseBytes = do
manager <- HC.newManager tlsManagerSettings {managerConnCount = 10}
pure
ResolverEnv
{ manager,
baseUrl,
authHdr = maybe [] (pure . authHeader) auth_,
timeoutMicro = timeoutMs * 1000,
maxResponseBytes
}
-- | http-client's `closeManager` is a deprecated no-op since 0.5; the
-- manager is released by the GC finalizer on its internal state. Hook kept
-- as a future-cleanup seam.
closeResolverEnv :: ResolverEnv -> IO ()
closeResolverEnv _ = pure ()
authHeader :: RpcAuth -> HT.Header
authHeader = \case
AuthBearer tok -> ("Authorization", "Bearer " <> encodeUtf8 tok)
AuthBasic u p ->
let encoded = BAE.convertToBase BAE.Base64 (encodeUtf8 u <> ":" <> encodeUtf8 p) :: ByteString
in ("Authorization", "Basic " <> encoded)
-- | GET <baseUrl>/resolve/<percent-encoded name>, decoding the 200 body
-- directly into a NameRecord in one pass (no intermediate Aeson Value). The
-- name is percent-encoded (every non-unreserved byte per RFC 3986): the
-- resolver expects raw labels, so slashes/punctuation must not alter the path.
resolveHttp :: ResolverEnv -> Text -> IO (Either ResolverError NameRecord)
resolveHttp env name =
(>>= first InvalidJson . J.eitherDecodeStrict . BL.toStrict)
<$> 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.
healthHttp :: ResolverEnv -> IO (Either ResolverError ())
healthHttp env = (() <$) <$> httpGet env "/health"
-- | GET <baseUrl><path>, returning the response body bytes on status < 400
-- within the size cap. Redirects are disabled and Authorization is attached
-- only when configured.
httpGet :: ResolverEnv -> String -> IO (Either ResolverError BL.ByteString)
httpGet ResolverEnv {manager, baseUrl, authHdr, timeoutMicro, maxResponseBytes} path = do
req0 <- parseRequest (baseUrl <> path)
let req =
req0
{ redirectCount = 0,
requestHeaders = ("Accept", "application/json") : authHdr,
HC.responseTimeout = responseTimeoutMicro timeoutMicro
}
result <- E.try $ withResponse req manager $ \res -> do
let status = HT.statusCode (responseStatus res)
if status >= 400
then pure (Left (HttpStatusErr status))
else do
bs <- brReadSome (responseBody res) (maxResponseBytes + 1)
pure $ if BL.length bs > fromIntegral maxResponseBytes then Left BodyTooLarge else Right bs
pure (either (Left . HttpFailure) id result)
src/Simplex/Messaging/Server/Prometheus.hs
+28 -2
View File
@@ -59,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 <> info
time <> queues <> subscriptions <> messages <> ntfMessages <> ntfs <> relays <> services <> names <> info
where
ServerMetrics {statsData, activeQueueCounts = ps, activeNtfCounts = psNtf, entityCounts, rtsOptions} = sm
RealTimeMetrics
@@ -128,7 +128,8 @@ prometheusMetrics sm rtm ts =
_rcvServicesSubDuplicate,
_qCount,
_msgCount,
_ntfCount
_ntfCount,
_rslvStats
} = statsData
time =
"# Recorded at: " <> T.pack (iso8601Show ts) <> "\n\
@@ -459,6 +460,31 @@ prometheusMetrics sm rtm ts =
\# TYPE simplex_smp_" <> pfx <> "_services_sub_fewer_total gauge\n\
\simplex_smp_" <> pfx <> "_services_sub_fewer_total " <> mshow (_srvSubFewerTotal ss) <> "\n# " <> pfx <> ".srvSubFewerTotal\n\
\\n"
names =
let NameResolverStatsData {_rslvReqs, _rslvSucc, _rslvNotFound, _rslvResolverErrs, _rslvDisabled} = _rslvStats
in "# Names\n\
\# -----\n\
\\n\
\# HELP simplex_smp_names_reqs Total RSLV requests forwarded to this server.\n\
\# TYPE simplex_smp_names_reqs counter\n\
\simplex_smp_names_reqs " <> mshow _rslvReqs <> "\n# rslvReqs\n\
\\n\
\# HELP simplex_smp_names_success NameRecord successfully resolved and returned.\n\
\# TYPE simplex_smp_names_success counter\n\
\simplex_smp_names_success " <> mshow _rslvSucc <> "\n# rslvSucc\n\
\\n\
\# HELP simplex_smp_names_not_found Name not registered (resolver returned 404 / 400).\n\
\# TYPE simplex_smp_names_not_found counter\n\
\simplex_smp_names_not_found " <> mshow _rslvNotFound <> "\n# rslvNotFound\n\
\\n\
\# HELP simplex_smp_names_resolver_errs Resolver backend errors (HTTP 5xx, transport, decode, or timeout).\n\
\# TYPE simplex_smp_names_resolver_errs counter\n\
\simplex_smp_names_resolver_errs " <> mshow _rslvResolverErrs <> "\n# rslvResolverErrs\n\
\\n\
\# HELP simplex_smp_names_disabled RSLV requests rejected because no resolver is configured (names role off).\n\
\# TYPE simplex_smp_names_disabled counter\n\
\simplex_smp_names_disabled " <> mshow _rslvDisabled <> "\n# rslvDisabled\n\
\\n"
info =
"# Info\n\
\# ----\n\
src/Simplex/Messaging/Server/Stats.hs
+110 -6
View File
@@ -39,6 +39,13 @@ module Simplex.Messaging.Server.Stats
setServiceStats,
emptyTimeBuckets,
updateTimeBuckets,
NameResolverStats (..),
NameResolverStatsData (..),
newNameResolverStats,
newNameResolverStatsData,
getNameResolverStatsData,
getResetNameResolverStatsData,
setNameResolverStats,
) where
import Control.Applicative (optional, (<|>))
@@ -123,7 +130,8 @@ data ServerStats = ServerStats
rcvServicesSubDuplicate :: IORef Int,
qCount :: IORef Int,
msgCount :: IORef Int,
ntfCount :: IORef Int
ntfCount :: IORef Int,
rslvStats :: NameResolverStats
}
data ServerStatsData = ServerStatsData
@@ -184,7 +192,8 @@ data ServerStatsData = ServerStatsData
_rcvServicesSubDuplicate :: Int,
_qCount :: Int,
_msgCount :: Int,
_ntfCount :: Int
_ntfCount :: Int,
_rslvStats :: NameResolverStatsData
}
deriving (Show)
@@ -248,6 +257,7 @@ newServerStats ts = do
qCount <- newIORef 0
msgCount <- newIORef 0
ntfCount <- newIORef 0
rslvStats <- newNameResolverStats
pure
ServerStats
{ fromTime,
@@ -307,7 +317,8 @@ newServerStats ts = do
rcvServicesSubDuplicate,
qCount,
msgCount,
ntfCount
ntfCount,
rslvStats
}
getServerStatsData :: ServerStats -> IO ServerStatsData
@@ -370,6 +381,7 @@ getServerStatsData s = do
_qCount <- readIORef $ qCount s
_msgCount <- readIORef $ msgCount s
_ntfCount <- readIORef $ ntfCount s
_rslvStats <- getNameResolverStatsData $ rslvStats s
pure
ServerStatsData
{ _fromTime,
@@ -429,7 +441,8 @@ getServerStatsData s = do
_rcvServicesSubDuplicate,
_qCount,
_msgCount,
_ntfCount
_ntfCount,
_rslvStats
}
-- this function is not thread safe, it is used on server start only
@@ -493,6 +506,7 @@ setServerStats s d = do
writeIORef (qCount s) $! _qCount d
writeIORef (msgCount s) $! _msgCount d
writeIORef (ntfCount s) $! _ntfCount d
setNameResolverStats (rslvStats s) $! _rslvStats d
instance StrEncoding ServerStatsData where
strEncode d =
@@ -557,7 +571,9 @@ instance StrEncoding ServerStatsData where
"rcvServices:",
strEncode (_rcvServices d),
"ntfServices:",
strEncode (_ntfServices d)
strEncode (_ntfServices d),
"rslvStats:",
strEncode (_rslvStats d)
]
strP = do
_fromTime <- "fromTime=" *> strP <* A.endOfLine
@@ -628,6 +644,10 @@ instance StrEncoding ServerStatsData where
_pMsgFwdsRecv <- opt "pMsgFwdsRecv="
_rcvServices <- serviceStatsP "rcvServices:"
_ntfServices <- serviceStatsP "ntfServices:"
_rslvStats <-
optional ("rslvStats:" <* A.endOfLine) >>= \case
Just _ -> strP <* optional A.endOfLine
_ -> pure newNameResolverStatsData
pure
ServerStatsData
{ _fromTime,
@@ -687,7 +707,8 @@ instance StrEncoding ServerStatsData where
_rcvServicesSubDuplicate = 0,
_qCount,
_msgCount = 0,
_ntfCount = 0
_ntfCount = 0,
_rslvStats
}
where
opt s = A.string s *> strP <* A.endOfLine <|> pure 0
@@ -862,6 +883,89 @@ instance StrEncoding ProxyStatsData where
_pErrorsOther <- "errorsOther=" *> strP
pure ProxyStatsData {_pRequests, _pSuccesses, _pErrorsConnect, _pErrorsCompat, _pErrorsOther}
data NameResolverStats = NameResolverStats
{ rslvReqs :: IORef Int,
rslvSucc :: IORef Int,
rslvNotFound :: IORef Int,
rslvResolverErrs :: IORef Int,
rslvDisabled :: IORef Int
}
newNameResolverStats :: IO NameResolverStats
newNameResolverStats = do
rslvReqs <- newIORef 0
rslvSucc <- newIORef 0
rslvNotFound <- newIORef 0
rslvResolverErrs <- newIORef 0
rslvDisabled <- newIORef 0
pure NameResolverStats {rslvReqs, rslvSucc, rslvNotFound, rslvResolverErrs, rslvDisabled}
data NameResolverStatsData = NameResolverStatsData
{ _rslvReqs :: Int,
_rslvSucc :: Int,
_rslvNotFound :: Int,
_rslvResolverErrs :: Int,
_rslvDisabled :: Int
}
deriving (Show)
newNameResolverStatsData :: NameResolverStatsData
newNameResolverStatsData =
NameResolverStatsData
{ _rslvReqs = 0,
_rslvSucc = 0,
_rslvNotFound = 0,
_rslvResolverErrs = 0,
_rslvDisabled = 0
}
getNameResolverStatsData :: NameResolverStats -> IO NameResolverStatsData
getNameResolverStatsData s = do
_rslvReqs <- readIORef $ rslvReqs s
_rslvSucc <- readIORef $ rslvSucc s
_rslvNotFound <- readIORef $ rslvNotFound s
_rslvResolverErrs <- readIORef $ rslvResolverErrs s
_rslvDisabled <- readIORef $ rslvDisabled s
pure NameResolverStatsData {_rslvReqs, _rslvSucc, _rslvNotFound, _rslvResolverErrs, _rslvDisabled}
getResetNameResolverStatsData :: NameResolverStats -> IO NameResolverStatsData
getResetNameResolverStatsData s = do
_rslvReqs <- atomicSwapIORef (rslvReqs s) 0
_rslvSucc <- atomicSwapIORef (rslvSucc s) 0
_rslvNotFound <- atomicSwapIORef (rslvNotFound s) 0
_rslvResolverErrs <- atomicSwapIORef (rslvResolverErrs s) 0
_rslvDisabled <- atomicSwapIORef (rslvDisabled s) 0
pure NameResolverStatsData {_rslvReqs, _rslvSucc, _rslvNotFound, _rslvResolverErrs, _rslvDisabled}
-- not thread safe; used on server start only
setNameResolverStats :: NameResolverStats -> NameResolverStatsData -> IO ()
setNameResolverStats s d = do
writeIORef (rslvReqs s) $! _rslvReqs d
writeIORef (rslvSucc s) $! _rslvSucc d
writeIORef (rslvNotFound s) $! _rslvNotFound d
writeIORef (rslvResolverErrs s) $! _rslvResolverErrs d
writeIORef (rslvDisabled s) $! _rslvDisabled d
instance StrEncoding NameResolverStatsData where
strEncode NameResolverStatsData {_rslvReqs, _rslvSucc, _rslvNotFound, _rslvResolverErrs, _rslvDisabled} =
"reqs="
<> strEncode _rslvReqs
<> "\nsucc="
<> strEncode _rslvSucc
<> "\nnotFound="
<> strEncode _rslvNotFound
<> "\nresolverErrs="
<> strEncode _rslvResolverErrs
<> "\ndisabled="
<> strEncode _rslvDisabled
strP = do
_rslvReqs <- "reqs=" *> strP <* A.endOfLine
_rslvSucc <- "succ=" *> strP <* A.endOfLine
_rslvNotFound <- "notFound=" *> strP <* A.endOfLine
_rslvResolverErrs <- "resolverErrs=" *> strP <* A.endOfLine
_rslvDisabled <- "disabled=" *> strP
pure NameResolverStatsData {_rslvReqs, _rslvSucc, _rslvNotFound, _rslvResolverErrs, _rslvDisabled}
data ServiceStats = ServiceStats
{ srvAssocNew :: IORef Int,
srvAssocDuplicate :: IORef Int,
src/Simplex/Messaging/SimplexName.hs
+137
View File
@@ -0,0 +1,137 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
module Simplex.Messaging.SimplexName
( SimplexNameInfo (..),
SimplexNameDomain (..),
SimplexTLD (..),
SimplexNameType (..),
fullDomainName,
shortNameInfoStr,
)
where
import Control.Applicative (optional, (<|>))
import qualified Data.Aeson.TH as J
import qualified Data.Attoparsec.ByteString.Char8 as A
import qualified Data.Attoparsec.Text as AT
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Char (isDigit)
import Data.Functor (($>))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..), fromTextField_)
import Simplex.Messaging.Encoding (Encoding (..))
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON)
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>))
data SimplexNameInfo = SimplexNameInfo
{ nameType :: SimplexNameType,
nameDomain :: SimplexNameDomain
}
deriving (Eq, Show)
data SimplexNameDomain = SimplexNameDomain
{ nameTLD :: SimplexTLD,
domain :: Text,
subDomain :: [Text] -- parent to child: ["b", "a"] for a.b.domain.simplex
}
deriving (Eq, Show)
data SimplexTLD = TLDSimplex | TLDTesting | TLDWeb
deriving (Eq, Show)
data SimplexNameType = NTPublicGroup | NTContact
deriving (Eq, Show)
instance StrEncoding SimplexNameType where
strEncode = \case
NTPublicGroup -> "#"
NTContact -> "@"
strP = A.char '#' $> NTPublicGroup <|> A.char '@' $> NTContact
nameLabelP :: AT.Parser Text
nameLabelP = do
label <- T.intercalate "-" <$> AT.takeWhile1 (\c -> isNameLetter c || isDigit c) `AT.sepBy1` AT.char '-'
-- DNS label limit: each dot-separated component is at most 63 bytes (labels
-- are ASCII, so character count == byte count)
if T.length label > 63 then fail "name label exceeds 63 bytes" else pure label
where
-- ASCII letters only. SNRC contracts hash byte sequences via keccak; ENS
-- uses UTS-46 + Punycode for IDN, which we do not implement. Admitting
-- Cyrillic / Greek / etc. via Data.Char.isAlpha would (a) make namehash
-- diverge from any IDN-aware registrar and (b) allow homograph spoofing
-- (Cyrillic а vs ASCII a hash to different on-chain records).
isNameLetter c = c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z'
-- | Cap the name at 253 bytes (DNS full-domain limit)
boundedNonSpace :: A.Parser ByteString
boundedNonSpace = do
bs <- A.scan (0 :: Int) $ \i c ->
if i <= 253 && not (A.isSpace c) then Just (i + 1) else Nothing
if B.null bs
then fail "expected non-empty name token"
else if B.length bs > 253 then fail "name exceeds 253 bytes" else pure bs
instance StrEncoding SimplexNameInfo where
strEncode SimplexNameInfo {nameType, nameDomain} =
strEncode nameType <> strEncode nameDomain
strP = optional "simplex:/name" *> ((strP >>= infoP) <|> infoP NTPublicGroup)
where
infoP NTPublicGroup = SimplexNameInfo NTPublicGroup <$> (strP <|> bareName)
infoP NTContact = SimplexNameInfo NTContact <$> strP
bareName = parseBare . safeDecodeUtf8 <$?> boundedNonSpace
parseBare s = (\name -> SimplexNameDomain TLDSimplex (T.toLower name) []) <$> AT.parseOnly (nameLabelP <* AT.endOfInput) s
instance StrEncoding SimplexNameDomain where
strEncode = encodeUtf8 . fullDomainName
strP = parseDomain . safeDecodeUtf8 <$?> boundedNonSpace
where
parseDomain s = AT.parseOnly (nameLabelP `AT.sepBy1` AT.char '.' <* AT.endOfInput) s >>= mkDomain
mkDomain labels = case reverse lowered of
[] -> Left "empty name"
[_] -> Left "domain requires TLD"
"simplex" : name : sub -> Right (SimplexNameDomain TLDSimplex name sub)
"testing" : name : sub -> Right (SimplexNameDomain TLDTesting name sub)
_ -> Right (SimplexNameDomain TLDWeb (T.intercalate "." lowered) [])
where
lowered = map T.toLower labels
instance Encoding SimplexNameDomain where
smpEncode = strEncode
smpP = strP
fullDomainName :: SimplexNameDomain -> Text
fullDomainName SimplexNameDomain {nameTLD, domain, subDomain} = T.intercalate "." (reverse subDomain ++ [domain] ++ tld')
where
tld' = case nameTLD of
TLDSimplex -> ["simplex"]
TLDTesting -> ["testing"]
TLDWeb -> []
shortNameInfoStr :: SimplexNameInfo -> Text
shortNameInfoStr = \case
SimplexNameInfo {nameType = NTPublicGroup, nameDomain = SimplexNameDomain {nameTLD = TLDSimplex, domain, subDomain = []}} -> "#" <> domain
info -> pfx <> fullDomainName (nameDomain info)
where
pfx = case nameType info of
NTPublicGroup -> "#"
NTContact -> "@"
instance ToField SimplexNameInfo where toField = toField . decodeLatin1 . strEncode
instance FromField SimplexNameInfo where fromField = fromTextField_ (eitherToMaybe . strDecode . encodeUtf8)
$(J.deriveJSON (enumJSON $ dropPrefix "TLD") ''SimplexTLD)
$(J.deriveJSON (enumJSON $ dropPrefix "NT") ''SimplexNameType)
$(J.deriveJSON defaultJSON ''SimplexNameDomain)
$(J.deriveJSON defaultJSON ''SimplexNameInfo)
src/Simplex/Messaging/Transport.hs
+14 -8
View File
@@ -57,6 +57,7 @@ module Simplex.Messaging.Transport
newNtfCredsSMPVersion,
clientNoticesSMPVersion,
rcvServiceSMPVersion,
namesSMPVersion,
simplexMQVersion,
smpBlockSize,
TransportConfig (..),
@@ -223,6 +224,9 @@ clientNoticesSMPVersion = VersionSMP 18
rcvServiceSMPVersion :: VersionSMP
rcvServiceSMPVersion = VersionSMP 19
namesSMPVersion :: VersionSMP
namesSMPVersion = VersionSMP 20
minClientSMPRelayVersion :: VersionSMP
minClientSMPRelayVersion = VersionSMP 6
@@ -230,21 +234,23 @@ minServerSMPRelayVersion :: VersionSMP
minServerSMPRelayVersion = VersionSMP 6
currentClientSMPRelayVersion :: VersionSMP
currentClientSMPRelayVersion = VersionSMP 19
currentClientSMPRelayVersion = VersionSMP 20
legacyServerSMPRelayVersion :: VersionSMP
legacyServerSMPRelayVersion = VersionSMP 6
currentServerSMPRelayVersion :: VersionSMP
currentServerSMPRelayVersion = VersionSMP 19
currentServerSMPRelayVersion = VersionSMP 20
-- Max SMP protocol version to be used in e2e encrypted
-- connection between client and server, as defined by SMP proxy.
-- SMP proxy sets it to lower than its current version
-- to prevent client version fingerprinting by the
-- destination relays when clients upgrade at different times.
-- Max SMP protocol version to be used in e2e encrypted connection between
-- client and server, as defined by SMP proxy. Normally set below the current
-- version to prevent client version fingerprinting by the destination relays
-- when clients upgrade at different times. Pinned to the current version (20)
-- for this release because proxied name resolution is gated on namesSMPVersion
-- (20), so the one-version anti-fingerprinting buffer does not apply yet; it
-- reappears once the current version advances past 20.
proxiedSMPRelayVersion :: VersionSMP
proxiedSMPRelayVersion = VersionSMP 18
proxiedSMPRelayVersion = VersionSMP 20
-- minimal supported protocol version is 6
-- TODO remove code that supports sending commands without batching
tests/AgentTests.hs
+2
View File
@@ -12,6 +12,7 @@ import AgentTests.ConnectionRequestTests
import AgentTests.DoubleRatchetTests (doubleRatchetTests)
import AgentTests.FunctionalAPITests (functionalAPITests)
import AgentTests.MigrationTests (migrationTests)
import AgentTests.ResolveNameTests (resolveNameTests)
import AgentTests.ServerChoice (serverChoiceTests)
import AgentTests.ShortLinkTests (shortLinkTests)
import Simplex.Messaging.Server.Env.STM (AStoreType (..))
@@ -37,6 +38,7 @@ agentCoreTests = do
describe "Connection request" connectionRequestTests
describe "Double ratchet tests" doubleRatchetTests
describe "Short link tests" shortLinkTests
describe "resolve names" resolveNameTests
agentTests :: (ASrvTransport, AStoreType) -> Spec
agentTests ps = do
tests/AgentTests/ResolveNameTests.hs
+152
View File
@@ -0,0 +1,152 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
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)
import NamesResolverServer (memCfg, memCfg2, memProxyCfg, withNames)
import qualified NamesResolverServer as NRS
import SMPAgentClient
import SMPClient
import SMPNamesTests (testNameRecord)
import Simplex.Messaging.Agent (resolveSimplexName)
import Simplex.Messaging.Agent.Client (AgentClient)
import Simplex.Messaging.Agent.Env.SQLite (InitialAgentServers (..), ServerCfg, ServerRoles (..), presetServerCfg)
import Simplex.Messaging.Agent.Protocol (AgentErrorType (..))
import Simplex.Messaging.Client (SMPProxyFallback (..), SMPProxyMode (..), pattern NRMInteractive)
import Simplex.Messaging.Protocol (SMPServer)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.SimplexName (SimplexNameDomain (..), SimplexTLD (..))
import Simplex.Messaging.Transport
import Test.Hspec hiding (fit, it)
import Util (it)
nameSrvCfg :: SMPServer -> ServerCfg 'SMP.PSMP
nameSrvCfg = presetServerCfg True ServerRoles {storage = True, proxy = False, names = True} (Just 1) . SMP.noAuthSrv
proxySrvCfg :: SMPServer -> ServerCfg 'SMP.PSMP
proxySrvCfg = presetServerCfg True ServerRoles {storage = True, proxy = True, names = False} (Just 1) . SMP.noAuthSrv
oneSrv :: ServerCfg 'SMP.PSMP -> InitialAgentServers
oneSrv cfg_ = (initAgentServersProxy_ SPMNever SPFProhibit) {smp = [(1, [cfg_])]}
withDirectResolver :: (Status, LB.ByteString) -> (AgentClient -> IO a) -> IO a
withDirectResolver (st, body) k =
NRS.withResolverServer (NRS.resolveResp st body) $ \port _ ->
withSmpServerConfigOn (transport @TLS) (withNames port memCfg) testPort $ \_ ->
withAgent 1 agentCfg (oneSrv (nameSrvCfg testSMPServer)) testDB k
withProxyAndResolver :: (Status, LB.ByteString) -> (AgentClient -> IO a) -> IO a
withProxyAndResolver (st, body) k =
NRS.withResolverServer (NRS.resolveResp st body) $ \port _ ->
withSmpServerConfigOn (transport @TLS) memProxyCfg testPort $ \_ ->
withSmpServerConfigOn (transport @TLS) (withNames port memCfg2) testPort2 $ \_ ->
withAgent 1 agentCfg proxyServers testDB k
where
-- only testSMPServer2 (the resolver) has the names role; testSMPServer is the proxy
proxyServers = (initAgentServersProxy_ SPMAlways SPFProhibit) {smp = [(1, [proxySrvCfg testSMPServer, nameSrvCfg testSMPServer2])]}
withNoResolver :: (AgentClient -> IO a) -> IO a
withNoResolver k =
withSmpServerConfigOn (transport @TLS) memCfg testPort $ \_ ->
withAgent 1 agentCfg (oneSrv (nameSrvCfg testSMPServer)) testDB k
withNoNameServers :: (AgentClient -> IO a) -> IO a
withNoNameServers k = withAgent 1 agentCfg (oneSrv (proxySrvCfg testSMPServer)) testDB k
resolveNameTests :: Spec
resolveNameTests = do
describe "direct path (SPMNever)" $
it "404 propagates as SMP host (NAME NOT_FOUND)" testDirectNotFound
describe "proxy path (SPMAlways)" $
it "404 from resolver propagates via proxy as SMP <proxyHost> (NAME NOT_FOUND)" testProxyNotFound
describe "TLDTesting path" $
it "NAME NOT_FOUND for TLDTesting too" testTestingTldNotFound
describe "TLDWeb path" $
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)" $
it "fails agent-side with NO_NAME_SERVERS" testNoNameServers
describe "backing resolver failure" $
it "surfaces as SMP host (NAME (RESOLVER ..))" testBackendError
describe "success path" $
it "returns NameRecord" testDirectSuccess
testDirectNotFound :: HasCallStack => IO ()
testDirectNotFound =
withDirectResolver (status404, "{}") $ \c -> do
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexNameDomain TLDSimplex "alice" [])
case r of
Left (SMP _ (SMP.NAME SMP.NOT_FOUND)) -> pure ()
_ -> expectationFailure $ "expected Left (SMP _ (NAME NOT_FOUND)), got: " <> show r
testProxyNotFound :: HasCallStack => IO ()
testProxyNotFound =
withProxyAndResolver (status404, "{}") $ \c -> do
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexNameDomain TLDSimplex "alice" [])
case r of
Left (SMP host (SMP.NAME SMP.NOT_FOUND)) | testPort `isInfixOf` host -> pure ()
_ -> expectationFailure $ "expected Left (SMP <proxyHost:" <> testPort <> "> (NAME NOT_FOUND)), got: " <> show r
testTestingTldNotFound :: HasCallStack => IO ()
testTestingTldNotFound =
withDirectResolver (status404, "{}") $ \c -> do
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexNameDomain TLDTesting "bob" [])
case r of
Left (SMP _ (SMP.NAME SMP.NOT_FOUND)) -> pure ()
_ -> expectationFailure $ "expected Left (SMP _ (NAME NOT_FOUND)), got: " <> show r
testWebTldNotFound :: HasCallStack => IO ()
testWebTldNotFound =
withDirectResolver (status404, "{}") $ \c -> do
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexNameDomain TLDWeb "example.com" [])
case r of
Left (SMP _ (SMP.NAME SMP.NOT_FOUND)) -> pure ()
_ -> expectationFailure $ "expected Left (SMP _ (NAME NOT_FOUND)), got: " <> show r
testNoResolver :: HasCallStack => IO ()
testNoResolver =
withNoResolver $ \c -> do
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexNameDomain TLDSimplex "alice" [])
case r of
Left (SMP _ (SMP.NAME SMP.NO_RESOLVER)) -> pure ()
_ -> expectationFailure $ "expected Left (SMP _ (NAME NO_RESOLVER)), got: " <> show r
testNoNameServers :: HasCallStack => IO ()
testNoNameServers =
withNoNameServers $ \c -> do
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexNameDomain TLDSimplex "alice" [])
case r of
Left NO_NAME_SERVERS -> pure ()
_ -> expectationFailure $ "expected Left NO_NAME_SERVERS, got: " <> show r
testBackendError :: HasCallStack => IO ()
testBackendError =
withDirectResolver (status502, "{}") $ \c -> do
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexNameDomain TLDSimplex "alice" [])
case r of
Left (SMP _ (SMP.NAME (SMP.RESOLVER _))) -> pure ()
_ -> expectationFailure $ "expected Left (SMP _ (NAME (RESOLVER ..))), got: " <> show r
testDirectSuccess :: HasCallStack => IO ()
testDirectSuccess =
withDirectResolver (status200, J.encode testNameRecord) $ \c -> do
r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexNameDomain TLDSimplex "alice" [])
case r of
Right nr -> nr `shouldBe` testNameRecord
_ -> expectationFailure $ "expected Right NameRecord, got: " <> show r
tests/AgentTests/ServerChoice.hs
+2 -2
View File
@@ -52,10 +52,10 @@ testSMPServers =
]
storageOnly :: ServerRoles
storageOnly = ServerRoles {storage = True, proxy = False}
storageOnly = ServerRoles {storage = True, proxy = False, names = False}
proxyOnly :: ServerRoles
proxyOnly = ServerRoles {storage = False, proxy = True}
proxyOnly = ServerRoles {storage = False, proxy = True, names = False}
initServers :: InitialAgentServers
initServers =
tests/NamesResolverServer.hs
+81
View File
@@ -0,0 +1,81 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
-- | Name resolver mock
module NamesResolverServer
( withResolverServer,
withResolverServerDelayed,
resolveResp,
testNamesConfig,
memCfg,
memProxyCfg,
memCfg2,
withNames,
)
where
import Control.Concurrent (threadDelay)
import Control.Monad (when)
import qualified Data.ByteString.Lazy as LB
import Data.IORef (IORef, atomicModifyIORef', newIORef)
import Data.Text (Text)
import Network.HTTP.Types (Status, hContentType, notFound404, ok200)
import Network.Wai (Application, pathInfo, responseLBS)
import qualified Network.Wai.Handler.Warp as Warp
import SMPClient (AServerConfig (..), cfgMS, proxyCfgMS, testStoreLogFile2, testStoreMsgsFile2, updateCfg)
import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..), ServerStoreCfg (..), StorePaths (..))
import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..))
import Simplex.Messaging.Server.Names (NamesConfig (..))
-- | Run an action with a local HTTP resolver on a free port.
withResolverServer :: ([Text] -> (Status, LB.ByteString)) -> (Int -> IORef [[Text]] -> IO a) -> IO a
withResolverServer = withResolverServerDelayed 0
withResolverServerDelayed :: Int -> ([Text] -> (Status, LB.ByteString)) -> (Int -> IORef [[Text]] -> IO a) -> IO a
withResolverServerDelayed delayMs handler action = do
reqs <- newIORef []
Warp.withApplication (pure (app reqs)) $ \port -> action port reqs
where
app :: IORef [[Text]] -> Application
app reqs req send = do
atomicModifyIORef' reqs $ \rs -> (rs <> [pathInfo req], ())
when (delayMs > 0) $ threadDelay (delayMs * 1000)
let (st, body) = handler (pathInfo req)
send $ responseLBS st [(hContentType, "application/json")] body
resolveResp :: Status -> LB.ByteString -> [Text] -> (Status, LB.ByteString)
resolveResp st body = \case
["health"] -> (ok200, "{}")
("resolve" : _) -> (st, body)
_ -> (notFound404, "{}")
testNamesConfig :: Int -> NamesConfig
testNamesConfig port =
NamesConfig
{ resolverEndpoint = "http://127.0.0.1:" <> show port,
resolverAuth = Nothing,
resolverTimeoutMs = 1000,
resolverMaxResponseBytes = 65536
}
memCfg :: AServerConfig
memCfg = cfgMS (ASType SQSMemory SMSMemory)
memProxyCfg :: AServerConfig
memProxyCfg = proxyCfgMS (ASType SQSMemory SMSMemory)
memCfg2 :: AServerConfig
memCfg2 = case memCfg of
ASrvCfg qt mt c -> ASrvCfg qt mt c {serverStoreCfg = newStoreCfg (serverStoreCfg c)}
where
newStoreCfg :: ServerStoreCfg s -> ServerStoreCfg s
newStoreCfg = \case
SSCMemory _ -> SSCMemory (Just StorePaths {storeLogFile = testStoreLogFile2, storeMsgsFile = Just testStoreMsgsFile2})
other -> other
withNames :: Int -> AServerConfig -> AServerConfig
withNames port c = updateCfg c $ \cfg_ -> cfg_ {namesConfig = Just (testNamesConfig port)}
tests/RSLVTests.hs
+159
View File
@@ -0,0 +1,159 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
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.List.NonEmpty (NonEmpty (..))
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.Time.Clock (getCurrentTime)
import Network.HTTP.Types (Status, status200, status404, status502)
import NamesResolverServer (memCfg, memCfg2, memProxyCfg, withNames)
import qualified NamesResolverServer as NRS
import SMPClient
import Simplex.Messaging.Client
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String (strDecode)
import SMPNamesTests (testNameRecord)
import Simplex.Messaging.Protocol
( BrokerMsg (..),
Cmd (..),
Command (..),
CorrId (..),
ErrorType (..),
NameErrorType (..),
SParty (..),
Transmission,
TransmissionForAuth (..),
encodeTransmissionForAuth,
pattern SMPServer,
tGetClient,
tPut,
)
import qualified Simplex.Messaging.Protocol as SMP
import Simplex.Messaging.SimplexName (SimplexNameDomain)
import Simplex.Messaging.Transport
import Simplex.Messaging.Version (mkVersionRange)
import Test.Hspec hiding (fit, it)
import Util (it)
domain :: Text -> SimplexNameDomain
domain = either error id . strDecode . encodeUtf8
withResolverServer :: (Status, LB.ByteString) -> IO a -> IO a
withResolverServer (st, body) runTest =
NRS.withResolverServer (NRS.resolveResp st body) $ \port _ ->
withSmpServerConfigOn (transport @TLS) (withNames port memCfg) testPort (const runTest)
withProxyAndResolver :: (Status, LB.ByteString) -> IO a -> IO a
withProxyAndResolver (st, body) runTest =
NRS.withResolverServer (NRS.resolveResp st body) $ \port _ ->
withSmpServerConfigOn (transport @TLS) memProxyCfg testPort $ \_ ->
withSmpServerConfigOn (transport @TLS) (withNames port memCfg2) testPort2 (const runTest)
sendRslv :: Transport c => THandleSMP c 'TClient -> B.ByteString -> SimplexNameDomain -> IO (Transmission (Either ErrorType BrokerMsg))
sendRslv h@THandle {params} corrId d = do
let TransmissionForAuth {tToSend} = encodeTransmissionForAuth params (CorrId corrId, NoEntity, Cmd SResolver (RSLV d))
[Right ()] <- tPut h (Right (Nothing, tToSend) :| [])
r :| _ <- tGetClient h
pure r
rslvTests :: Spec
rslvTests = do
describe "RSLV direct (non-forwarded)" $ do
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 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
testRslvBackendNotFound :: IO ()
testRslvBackendNotFound =
withResolverServer (status404, "{}") $
testSMPClient @TLS $ \h -> do
(corrId, _entId, resp) <- sendRslv h "rs01" (domain "ghost.simplex")
corrId `shouldBe` CorrId "rs01"
resp `shouldBe` Right (ERR (NAME NOT_FOUND))
testRslvBackendHttpErr :: IO ()
testRslvBackendHttpErr =
withResolverServer (status502, "{}") $
testSMPClient @TLS $ \h -> do
(_, _, resp) <- sendRslv h "rs05" (domain "alice.simplex")
resp `shouldBe` Right (ERR (NAME (RESOLVER "HTTP 502")))
testRslvDisabled :: IO ()
testRslvDisabled =
withSmpServerConfigOn (transport @TLS) memCfg testPort $ const $
testSMPClient @TLS $ \h -> do
(_, _, resp) <- sendRslv h "rs06" (domain "alice.simplex")
resp `shouldBe` Right (ERR (NAME NO_RESOLVER))
testRslvVersion :: IO ()
testRslvVersion =
withResolverServer (status200, J.encode testNameRecord) $ do
g <- C.newRandom
ts <- getCurrentTime
let srv = SMPServer testHost testPort testKeyHash
oldCfg = defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion rcvServiceSMPVersion}
pcE <- getProtocolClient g NRMInteractive (1, srv, Nothing) oldCfg [] Nothing ts (\_ -> pure ())
pc <- either (fail . show) pure pcE
r <- runExceptT (directResolveName pc NRMInteractive (domain "alice.simplex"))
case r of
Left (PCETransportError TEVersion) -> pure ()
_ -> expectationFailure $ "expected Left (PCETransportError TEVersion), got: " <> show r
forwardedResolveAlice :: IO (Either SMPClientError (Either ProxyClientError SMP.NameRecord))
forwardedResolveAlice = do
g <- C.newRandom
ts <- getCurrentTime
let proxyServ = SMPServer testHost testPort testKeyHash
relayServ = SMPServer testHost2 testPort2 testKeyHash
cfg' = defaultSMPClientConfig {serverVRange = mkVersionRange minServerSMPRelayVersion currentClientSMPRelayVersion}
pcE <- getProtocolClient g NRMInteractive (1, proxyServ, Nothing) cfg' [] Nothing ts (\_ -> pure ())
pc <- either (fail . show) pure pcE
sess <- runExceptT' (connectSMPProxiedRelay pc NRMInteractive relayServ Nothing)
runExceptT (proxyResolveName pc NRMInteractive sess (domain "alice.simplex"))
testRslvForwarded :: IO ()
testRslvForwarded =
withProxyAndResolver (status404, "{}") $
forwardedResolveAlice >>= \r -> case r of
Left (PCEProtocolError (SMP.NAME SMP.NOT_FOUND)) -> pure ()
_ -> expectationFailure $ "expected Left (PCEProtocolError (NAME NOT_FOUND)), got: " <> show r
testRslvForwardedSuccess :: IO ()
testRslvForwardedSuccess =
withProxyAndResolver (status200, J.encode testNameRecord) $
forwardedResolveAlice >>= \r -> case r of
Right (Right nr) -> nr `shouldBe` testNameRecord
_ -> expectationFailure $ "expected Right (Right NameRecord), got: " <> show r
testRslvSuccess :: IO ()
testRslvSuccess =
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 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
tests/SMPAgentClient.hs
+2 -2
View File
@@ -116,7 +116,7 @@ userServers :: NonEmpty (ProtocolServer p) -> Map UserId (NonEmpty (ServerCfg p)
userServers = userServers' . L.map noAuthSrv
userServers' :: NonEmpty (ProtoServerWithAuth p) -> Map UserId (NonEmpty (ServerCfg p))
userServers' srvs = M.fromList [(1, L.map (presetServerCfg True (ServerRoles True True) (Just 1)) srvs)]
userServers' srvs = M.fromList [(1, L.map (presetServerCfg True (ServerRoles True True True) (Just 1)) srvs)]
noAuthSrvCfg :: ProtocolServer p -> ServerCfg p
noAuthSrvCfg = presetServerCfg True (ServerRoles True True) (Just 1) . noAuthSrv
noAuthSrvCfg = presetServerCfg True (ServerRoles True True True) (Just 1) . noAuthSrv
tests/SMPClient.hs
+2
View File
@@ -278,6 +278,8 @@ cfgMS msType = withStoreCfg (testServerStoreConfig msType) $ \serverStoreCfg ->
smpAgentCfg = defaultSMPClientAgentConfig {persistErrorInterval = 1}, -- seconds
allowSMPProxy = False,
serverClientConcurrency = 2,
serverResolverConcurrency = defaultNameResolverConcurrency,
namesConfig = Nothing,
information = Nothing,
startOptions = defaultStartOptions
}
tests/SMPNamesTests.hs
+251
View File
@@ -0,0 +1,251 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module SMPNamesTests (smpNamesTests, testNameRecord) where
import qualified Data.Aeson as J
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as LB
import Data.Either (isLeft, isRight)
import Data.IORef (readIORef)
import Data.List (sort)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Network.HTTP.Types (status200, status400, status404, status500, status502)
import NamesResolverServer (resolveResp, testNamesConfig, withResolverServer, withResolverServerDelayed)
import Simplex.Messaging.Encoding (smpDecode, smpEncode)
import Simplex.Messaging.Encoding.String (strDecode)
import Simplex.Messaging.Protocol (ErrorType (..), NameErrorType (..), NameRecord (..))
import Simplex.Messaging.Server.Main (validateUrl)
import Simplex.Messaging.Server.Names
( NamesConfig (..),
RpcAuth (..),
newNamesEnv,
pingEndpoint,
resolveName,
)
import Simplex.Messaging.Server.Names.HttpResolver (ResolverError (..))
import Simplex.Messaging.SimplexName (SimplexNameDomain (..), SimplexTLD (..))
import Test.Hspec
testNameRecord :: NameRecord
testNameRecord =
NameRecord
{ nrName = "alice.simplex",
nrNickname = "Alice",
nrWebsite = "https://alice.example",
nrLocation = "Earth",
nrSimplexContact = ["simplex:/contact/abc#xyz"],
nrSimplexChannel = [],
nrEth = Just "0x0000000000000000000000000000000000000001",
nrBtc = Nothing,
nrXmr = Nothing,
nrDot = Nothing,
nrOwner = "0x0101010101010101010101010101010101010101",
nrResolver = "0x0202020202020202020202020202020202020202"
}
smpNamesTests :: Spec
smpNamesTests = do
describe "NameRecord JSON (Protocol)" nameRecordEncodingSpec
describe "ErrorType NAME wire encoding" errorWireSpec
describe "Name parsing (SimplexNameDomain)" parseNameSpec
describe "HTTP resolver" resolverSpec
describe "Resolver health probe" healthSpec
describe "resolver_endpoint validation" validateUrlSpec
nameRecordEncodingSpec :: Spec
nameRecordEncodingSpec = do
it "round-trips JSON encode / decode" $
J.eitherDecodeStrict (LB.toStrict (J.encode testNameRecord)) `shouldBe` Right testNameRecord
it "emits keys in spec-documented order (resolver shape)" $ do
let bytes = LB.toStrict (J.encode testNameRecord)
offset k = B.length (fst (B.breakSubstring k bytes))
offsets =
map
offset
[ "name",
"nickname",
"website",
"location",
"simplexContact",
"simplexChannel",
"eth",
"btc",
"xmr",
"dot",
"owner",
"resolver"
]
offsets `shouldBe` sort offsets
it "emits unset coin fields as null (not absent)" $ do
let bytes = LB.toStrict (J.encode testNameRecord)
B.isInfixOf "\"btc\":null" bytes `shouldBe` True
B.isInfixOf "\"xmr\":null" bytes `shouldBe` True
B.isInfixOf "\"dot\":null" bytes `shouldBe` True
it "emits unset link fields as empty arrays (not null)" $ do
let bytes = LB.toStrict (J.encode testNameRecord)
B.isInfixOf "\"simplexChannel\":[]" bytes `shouldBe` True
B.isInfixOf "\"simplexChannel\":null" bytes `shouldBe` False
errorWireSpec :: Spec
errorWireSpec =
it "ErrorType NAME family round-trips smpEncode / smpDecode" $ do
smpDecode (smpEncode (NAME NO_RESOLVER)) `shouldBe` Right (NAME NO_RESOLVER)
smpDecode (smpEncode (NAME NOT_FOUND)) `shouldBe` Right (NAME NOT_FOUND)
-- RESOLVER detail may contain spaces - must survive the round-trip
smpDecode (smpEncode (NAME (RESOLVER "HTTP 502"))) `shouldBe` Right (NAME (RESOLVER "HTTP 502"))
parseNameSpec :: Spec
parseNameSpec = do
it "accepts a valid simplex-TLD name" $
case parseN "privacy.simplex" of
Right d -> do
nameTLD d `shouldBe` TLDSimplex
domain d `shouldBe` "privacy"
Left e -> expectationFailure ("expected Right, got Left " <> e)
it "normalises case across labels (Alice.SIMPLEX = alice.simplex)" $
parseN "alice.simplex" `shouldBe` parseN "Alice.SIMPLEX"
it "accepts a testing-TLD name" $
case parseN "bob.testing" of
Right d -> nameTLD d `shouldBe` TLDTesting
Left e -> expectationFailure ("expected Right, got Left " <> e)
it "accepts a TLDWeb name (server forwards to resolver, which will likely 404/400)" $
parseN "example.com" `shouldSatisfy` isRight
it "rejects a bare (no-TLD) name" $
parseN "privacy" `shouldSatisfy` isLeft
it "rejects non-ASCII labels (homograph attacks)" $
parseN "\1072lice.simplex" `shouldSatisfy` isLeft
it "rejects oversized inputs (>253 bytes)" $
parseN (T.replicate 254 "a" <> ".simplex") `shouldSatisfy` isLeft
it "rejects a label longer than 63 bytes (DNS label limit)" $
parseN (T.replicate 64 "a" <> ".simplex") `shouldSatisfy` isLeft
it "accepts a label of exactly 63 bytes" $
parseN (T.replicate 63 "a" <> ".simplex") `shouldSatisfy` isRight
where
parseN :: T.Text -> Either String SimplexNameDomain
parseN = strDecode . encodeUtf8
resolverSpec :: Spec
resolverSpec = do
it "returns NameRecord on 200 OK" $
withResolverServer (resolveResp status200 (J.encode testNameRecord)) $ \port _ -> do
env <- newNamesEnv (testNamesConfig port)
resolveName env aliceDomain `shouldReturn` Right testNameRecord
it "returns NOT_FOUND on 404" $
withResolverServer (resolveResp status404 "{}") $ \port _ -> do
env <- newNamesEnv (testNamesConfig port)
resolveName env aliceDomain `shouldReturn` Left NOT_FOUND
it "returns NOT_FOUND on 400 (unknown TLD)" $
withResolverServer (resolveResp status400 "{}") $ \port _ -> do
env <- newNamesEnv (testNamesConfig port)
resolveName env aliceDomain `shouldReturn` Left NOT_FOUND
it "returns RESOLVER on 502 (upstream failure)" $
withResolverServer (resolveResp status502 "{}") $ \port _ -> do
env <- newNamesEnv (testNamesConfig port)
resolveName env aliceDomain `shouldReturn` Left (RESOLVER "HTTP 502")
it "returns RESOLVER when the body exceeds the response cap" $
withResolverServer (resolveResp status200 (LB.fromStrict (B.replicate 500 'x'))) $ \port _ -> do
env <- newNamesEnv (testNamesConfig port) {resolverMaxResponseBytes = 100}
resolveName env aliceDomain `shouldReturn` Left (RESOLVER "response too large")
it "returns RESOLVER on malformed JSON from the resolver" $
withResolverServer (resolveResp status200 "this is not json") $ \port _ -> do
env <- newNamesEnv (testNamesConfig port)
resolveName env aliceDomain `shouldReturn` Left (RESOLVER "invalid response")
it "returns RESOLVER when JSON parses but isn't a NameRecord shape" $
withResolverServer (resolveResp status200 "{}") $ \port _ -> do
env <- newNamesEnv (testNamesConfig port)
resolveName env aliceDomain `shouldReturn` Left (RESOLVER "invalid response")
it "returns RESOLVER (timeout) when the resolver is slower than resolverTimeoutMs" $
withResolverServerDelayed 1500 (resolveResp status200 (J.encode testNameRecord)) $ \port _ -> do
env <- newNamesEnv (testNamesConfig port) {resolverTimeoutMs = 300}
resolveName env aliceDomain `shouldReturn` Left (RESOLVER "timeout")
it "sends one HTTP request per lookup (no cache)" $
withResolverServer (resolveResp status200 (J.encode testNameRecord)) $ \port reqs -> do
env <- newNamesEnv (testNamesConfig port)
_ <- resolveName env aliceDomain
_ <- resolveName env aliceDomain
readIORef reqs >>= \rs -> length rs `shouldBe` 2
it "addresses the resolver with the full canonical domain name" $
withResolverServer (resolveResp status200 (J.encode testNameRecord)) $ \port reqs -> do
env <- newNamesEnv (testNamesConfig port)
_ <- resolveName env aliceDomain
readIORef reqs `shouldReturn` [["resolve", "alice.simplex"]]
where
aliceDomain = SimplexNameDomain {nameTLD = TLDSimplex, domain = "alice", subDomain = []}
healthSpec :: Spec
healthSpec = do
it "pingEndpoint succeeds on a 200 OK /health response" $
withResolverServer (resolveResp status200 "{}") $ \port _ -> do
env <- newNamesEnv (testNamesConfig port)
pingEndpoint env >>= \case
Right () -> pure ()
Left e -> expectationFailure $ "expected Right (), got Left " <> show e
it "pingEndpoint fails on a 500 /health response" $
withResolverServer healthFails $ \port _ -> do
env <- newNamesEnv (testNamesConfig port)
pingEndpoint env >>= \case
Left (HttpStatusErr 500) -> pure ()
r -> expectationFailure $ "expected Left (HttpStatusErr 500), got " <> show r
it "pingEndpoint queries /health" $
withResolverServer (resolveResp status200 "{}") $ \port reqs -> do
env <- newNamesEnv (testNamesConfig port)
_ <- pingEndpoint env
readIORef reqs `shouldReturn` [["health"]]
where
healthFails = \case
["health"] -> (status500, "{}")
_ -> (status404, "{}")
validateUrlSpec :: Spec
validateUrlSpec = do
it "accepts an https URL with a path prefix" $
validateUrl "https://gw.example.com:443/snrc" Nothing `shouldSatisfy` isRight
it "accepts an http URL" $
validateUrl "http://127.0.0.1:8000" Nothing `shouldSatisfy` isRight
it "accepts a URL without an explicit port" $
validateUrl "https://gw.example.com/snrc" Nothing `shouldSatisfy` isRight
it "rejects a relative / non-absolute URI" $
validateUrl "gw.example.com/snrc" Nothing `shouldSatisfy` isLeft
it "rejects a non-http(s) scheme" $
validateUrl "ftp://gw.example.com:21" Nothing `shouldSatisfy` isLeft
it "rejects an empty host" $
validateUrl "http://" Nothing `shouldSatisfy` isLeft
it "accepts https with auth (Authorization is TLS-protected)" $
validateUrl "https://gw.example.com" (Just auth) `shouldSatisfy` isRight
it "accepts loopback http with auth (no cleartext exposure)" $
validateUrl "http://localhost:8000" (Just auth) `shouldSatisfy` isRight
it "rejects non-loopback http with auth (cleartext credential leak)" $
validateUrl "http://gw.example.com:8000" (Just auth) `shouldSatisfy` isLeft
it "rejects URL-embedded userinfo (credentials belong in resolver_auth)" $
validateUrl "https://user:pass@gw.example.com" Nothing `shouldSatisfy` isLeft
it "rejects http+auth to a 127.-prefixed non-loopback host (not real loopback)" $
validateUrl "http://127.evil.com:8000" (Just auth) `shouldSatisfy` isLeft
where
auth = AuthBasic "user" "pass"
tests/ServerTests.hs
+3 -3
View File
@@ -1101,7 +1101,7 @@ testRestoreMessages =
pure ()
rId <- readTVarIO recipientId
logSize testStoreLogFile `shouldReturn` 2
logSize testServerStatsBackupFile `shouldReturn` 95
logSize testServerStatsBackupFile `shouldReturn` 101
Right stats1 <- strDecode <$> B.readFile testServerStatsBackupFile
checkStats stats1 [rId] 5 1
withSmpServerConfigOn at cfg' testPort . runTest t $ \h -> do
@@ -1117,7 +1117,7 @@ testRestoreMessages =
logSize testStoreLogFile `shouldReturn` (if compacting then 1 else 2)
-- the last message is not removed because it was not ACK'd
-- logSize testStoreMsgsFile `shouldReturn` 3
logSize testServerStatsBackupFile `shouldReturn` 95
logSize testServerStatsBackupFile `shouldReturn` 101
Right stats2 <- strDecode <$> B.readFile testServerStatsBackupFile
checkStats stats2 [rId] 5 3
@@ -1135,7 +1135,7 @@ testRestoreMessages =
pure ()
logSize testStoreLogFile `shouldReturn` (if compacting then 1 else 2)
removeFile testStoreLogFile
logSize testServerStatsBackupFile `shouldReturn` 95
logSize testServerStatsBackupFile `shouldReturn` 101
Right stats3 <- strDecode <$> B.readFile testServerStatsBackupFile
checkStats stats3 [rId] 5 5
removeFileIfExists testStoreMsgsFile
tests/Test.hs
+4
View File
@@ -21,7 +21,9 @@ import CoreTests.VersionRangeTests
import FileDescriptionTests (fileDescriptionTests)
import GHC.IO.Exception (IOException (..))
import qualified GHC.IO.Exception as IOException
import RSLVTests (rslvTests)
import RemoteControl (remoteControlTests)
import SMPNamesTests (smpNamesTests)
import SMPProxyTests (smpProxyTests)
import ServerTests
import Simplex.Messaging.Server.Env.STM (AStoreType (..))
@@ -97,6 +99,8 @@ main = do
#endif
describe "TSessionSubs tests" tSessionSubsTests
describe "Util tests" utilTests
describe "Names resolver tests" smpNamesTests
describe "RSLV functional API tests" rslvTests
describe "Agent core tests" agentCoreTests
#if defined(dbServerPostgres)
around_ (postgressBracket testServerDBConnectInfo) $