diff --git a/plans/20260522_01_smp_public_namespaces.md b/plans/20260522_01_smp_public_namespaces.md new file mode 100644 index 0000000000..e95b944ffb --- /dev/null +++ b/plans/20260522_01_smp_public_namespaces.md @@ -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 ` SMP command that returns `NAME ` 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
(Reth+Nimbus) + + C ->> P: PFWD(enc(RSLV key)) + P ->> N: RFWD(enc(RSLV key)) + note over N: verifyTransmission True →
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: "`. 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 ` or `basic :`. +- `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 : +# 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
(public :443, basic auth)"] + Reth["Reth
(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$ + smp-server-2 $2a$14$ + } + 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. diff --git a/protocol/simplex-messaging.md b/protocol/simplex-messaging.md index f1d1f77ce4..716f5ef7f8 100644 --- a/protocol/simplex-messaging.md +++ b/protocol/simplex-messaging.md @@ -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, NAME response) — forwarded-only 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 slow `RSLV` cache miss can serialise other forwarded commands on the same proxy-relay 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,119 @@ 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. + +**Forwarded-only.** RSLV is only valid when delivered inside a `PFWD` block via +the SMP proxy. A direct `RSLV` from a transport client is rejected with +`ERR CMD PROHIBITED`. This 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; the proxy router sees the client connection but cannot +read the encrypted lookup key inside the forwarded transmission. + +**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/` 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 a JSON-encoded request as the payload: + +```abnf +rslv = %s"RSLV" 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 | the canonical fully-qualified name (TLD always explicit, e.g. `"privacy.simplex"`, `"test.testing"`, `"example.com"`); UTF-8 bytes only | +| `contract` | string | `"0x"` followed by 40 lowercase hex characters (20 raw bytes); currently ignored by the server, reserved for future eth-backed implementations that may use it to constrain which on-chain registry the client expects the server to query | + +**Server-side validation.** The names router parses `name` as a fully-qualified +domain (TLD required — bare labels are rejected) and forwards it to the +configured backing resolver. The `contract` field is parsed for forward +compatibility but ignored by the reference implementation: the backing +resolver is the source of truth for which on-chain registry maps to each TLD. + +The names router responds with either a `NAME` response carrying the resolved +record, or one of three error responses that a client iterating across several +configured servers can act on distinctly: + +| Response | Condition | Client action | +|---|---|---| +| `NAME` | record resolved | use it | +| `ERR AUTH` | name not registered, or malformed name | authoritative "no such name" — stop | +| `ERR CMD PROHIBITED` | this router has no resolver (names role not enabled) | skip this server, try the next | +| `ERR INTERNAL` | backing resolver failure (404/400/5xx upstream, transport failure, timeout, decode error) | 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 (`AUTH` or `INTERNAL`), since that router has already seen +the lookup key; `CMD PROHIBITED` discloses nothing about the name beyond the +fact that this router cannot resolve, so iterating past it is safe. Stats +counters MAY be exposed out-of-band for operator observability (`bad_name` is +incremented for validation failures, distinct from `not_found` for valid +lookups with no backing record). + +#### Name record response + +The `NAME` response carries a JSON-encoded record as the payload: + +```abnf +name = %s"NAME" 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` | string | ≤ 1024 bytes UTF-8; same empty-string-when-unset rule | +| `simplexChannel` | string | ≤ 1024 bytes UTF-8; same empty-string-when-unset rule | +| `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`, `simplexContact`, +`simplexChannel`) 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. Coin fields (`eth`, `btc`, `xmr`, `dot`) +use JSON `null` as the "unset" sentinel and MAY also be absent from the +object entirely. + +The server MUST filter records its backing resolver indicates are expired +or otherwise unavailable (returning `ERR AUTH` 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. + +**Canonical encoding.** Two names routers reading the same backing state and +producing the same `NameRecord` MUST emit byte-identical JSON: emit object +keys in the order listed above, integers without decimal points, no +insignificant whitespace. + +**Wire-size budget.** A maximal `nameRecord` (two 1024-byte SimpleX links +plus the other capped strings) JSON-encodes to roughly 4 KB, well under the +SMP proxied transmission budget of 16224 bytes. + ## Transport connection with the SMP router ### General transport protocol considerations diff --git a/simplexmq.cabal b/simplexmq.cabal index 070f680303..a0abf32b52 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -130,6 +130,8 @@ library Simplex.Messaging.Crypto.ShortLink Simplex.Messaging.Encoding Simplex.Messaging.Encoding.String + Simplex.Messaging.Names.EthAddress + Simplex.Messaging.Names.Record Simplex.Messaging.Notifications.Client Simplex.Messaging.Notifications.Protocol Simplex.Messaging.Notifications.Transport @@ -141,6 +143,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 @@ -261,6 +264,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 @@ -355,7 +360,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.* @@ -489,10 +497,12 @@ test-suite simplexmq-test AgentTests.EqInstances AgentTests.FunctionalAPITests AgentTests.MigrationTests + AgentTests.ResolveNameTests AgentTests.ServerChoice AgentTests.ShortLinkTests CLITests CoreTests.BatchingTests + CoreTests.ConnectTargetTests CoreTests.CryptoFileTests CoreTests.CryptoTests CoreTests.EncodingTests @@ -505,9 +515,11 @@ test-suite simplexmq-test CoreTests.VersionRangeTests FileDescriptionTests RemoteControl + RSLVTests ServerTests SMPAgentClient SMPClient + SMPNamesTests SMPProxyTests Util XFTPAgent diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index bd77b892a1..f882ce7aff 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -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) diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index d33794006b..684c78fc77 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -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, @@ -1990,6 +1993,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 $ NAME SMP.NO_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 " $ \smp -> diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index 8e5bf08806..aba4a898a3 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -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 diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index cd8148e45b..803d7220f3 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -122,6 +122,7 @@ module Simplex.Messaging.Agent.Protocol OwnerId, ConnectionLink (..), AConnectionLink (..), + ConnectTarget (..), SimplexNameInfo (..), SimplexNameDomain (..), SimplexTLD (..), @@ -195,11 +196,11 @@ 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 Data.Attoparsec.Combinator (lookAhead) 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,11 +238,13 @@ 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, BrokerErrorType (..), ErrorType, + NameErrorType (..), MsgBody, MsgFlags, MsgId, @@ -1531,75 +1534,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 @@ -1665,6 +1599,24 @@ instance ToJSON AConnectionLink where instance FromJSON AConnectionLink where parseJSON = strParseJSON "AConnectionLink" +data ConnectTarget = CTLink AConnectionLink | CTName SimplexNameInfo + deriving (Eq, Show) + +instance StrEncoding ConnectTarget where + strEncode = \case + CTLink l -> strEncode l + CTName n -> strEncode n + strP = CTName <$> (lookAhead nameStart *> strP) <|> CTLink <$> strP + where + nameStart = "@" <|> "#" <|> "simplex:/name" + +instance ToJSON ConnectTarget where + toEncoding = strToJEncoding + toJSON = strToJSON + +instance FromJSON ConnectTarget where + parseJSON = strParseJSON "ConnectTarget" + instance ConnectionModeI m => StrEncoding (ConnShortLink m) where strEncode = \case CSLInvitation sch srv (SMP.EntityId lnkId) (LinkKey k) -> slEncode sch srv 'i' lnkId k @@ -2067,6 +2019,9 @@ data AgentErrorType XFTP {serverAddress :: String, xftpErr :: XFTPErrorType} | -- | XFTP agent errors FILE {fileErr :: FileErrorType} + | -- | name resolution agent errors (e.g. no name-resolving servers configured). + -- Server-origin name errors arrive forwarded as SMP _ (NAME ...) instead. + NAME {nameErr :: NameErrorType} | -- | SMP proxy errors PROXY {proxyServer :: String, relayServer :: String, proxyErr :: ProxyClientError} | -- | XRCP protocol errors forwarded to agent clients @@ -2278,10 +2233,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) diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 67b31de186..9091db3e11 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -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 diff --git a/src/Simplex/Messaging/Names/EthAddress.hs b/src/Simplex/Messaging/Names/EthAddress.hs new file mode 100644 index 0000000000..83e8944acb --- /dev/null +++ b/src/Simplex/Messaging/Names/EthAddress.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} + +module Simplex.Messaging.Names.EthAddress + ( EthAddress, + mkEthAddress, + unEthAddress, + ) +where + +import Control.Applicative ((<|>)) +import qualified Data.Aeson as J +import qualified Data.ByteArray.Encoding as BAE +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import Data.Text.Encoding (decodeLatin1, encodeUtf8) +import Simplex.Messaging.Encoding (Encoding (..)) + +-- | 20-byte Ethereum address (NameRecord owner / resolver). Bare constructor +-- not exported; use 'mkEthAddress' to enforce the 20-byte invariant. JSON form +-- is "0x"-prefixed lowercase hex (matches the resolver output). +newtype EthAddress = EthAddress {unEthAddress :: ByteString} + deriving (Eq, Show) + +mkEthAddress :: ByteString -> Either String EthAddress +mkEthAddress bs + | B.length bs == 20 = Right (EthAddress bs) + | otherwise = Left "EthAddress must be 20 bytes" + +-- Wire: length-prefixed raw bytes (via the ByteString instance); parse enforces +-- the 20-byte invariant. +instance Encoding EthAddress where + smpEncode = smpEncode . unEthAddress + smpP = smpP >>= either fail pure . mkEthAddress + +instance J.ToJSON EthAddress where + toJSON (EthAddress bs) = J.String $ "0x" <> decodeLatin1 (BAE.convertToBase BAE.Base16 bs) + +instance J.FromJSON EthAddress where + parseJSON = J.withText "EthAddress" $ \t -> do + -- Accept "0x" and "0X" prefixes (matches the server-side hex decoder). + let hex = fromMaybe t (T.stripPrefix "0x" t <|> T.stripPrefix "0X" t) + either fail pure $ BAE.convertFromBase BAE.Base16 (encodeUtf8 hex) >>= mkEthAddress diff --git a/src/Simplex/Messaging/Names/Record.hs b/src/Simplex/Messaging/Names/Record.hs new file mode 100644 index 0000000000..4a78b151a7 --- /dev/null +++ b/src/Simplex/Messaging/Names/Record.hs @@ -0,0 +1,63 @@ +{-# 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.Encoding (Encoding (..), smpEncodeList, smpListP) +import Simplex.Messaging.Names.EthAddress (EthAddress) +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 carry 20-byte EthAddresses (0x hex). +-- 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 :: EthAddress, + nrResolver :: EthAddress -- resolver address 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 + ) + +-- Wire encoding for the SMP NAME response: field-ordered smpEncode, not embedded +-- JSON. Field order = record declaration order. EthAddress encodes as its raw +-- 20 bytes (length-prefixed via the ByteString instance). +instance Encoding NameRecord where + smpEncode NameRecord {nrName, nrNickname, nrWebsite, nrLocation, nrSimplexContact, nrSimplexChannel, nrEth, nrBtc, nrXmr, nrDot, nrOwner, nrResolver} = + smpEncode (nrName, nrNickname, nrWebsite, nrLocation) + <> smpEncodeList nrSimplexContact + <> smpEncodeList nrSimplexChannel + <> smpEncode (nrEth, nrBtc, nrXmr, nrDot, nrOwner, nrResolver) + smpP = do + (nrName, nrNickname, nrWebsite, nrLocation) <- smpP + nrSimplexContact <- smpListP + nrSimplexChannel <- smpListP + (nrEth, nrBtc, nrXmr, nrDot, nrOwner, nrResolver) <- smpP + pure NameRecord {nrName, nrNickname, nrWebsite, nrLocation, nrSimplexContact, nrSimplexChannel, nrEth, nrBtc, nrXmr, nrDot, nrOwner, nrResolver} diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index fa58d88439..5943d2e791 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -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,10 @@ 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 + -- Name resolution. Preferably forwarded via PFWD (hides the client IP from + -- the resolver), but direct RSLV is also accepted. The validated name is the + -- only argument; the server resolves it via its configured resolver. + RSLV :: SimplexNameDomain -> Command Resolver deriving instance Show (Command p) @@ -732,6 +746,9 @@ data BrokerMsg where OK :: BrokerMsg ERR :: ErrorType -> BrokerMsg PONG :: BrokerMsg + -- Name resolution response (success), for direct or forwarded RSLV. + -- Named RNAME so the error family can use ErrorType.NAME. + RNAME :: NameRecord -> BrokerMsg deriving (Eq, Show) data RcvMessage = RcvMessage @@ -942,6 +959,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 +986,7 @@ data BrokerMsgTag | OK_ | ERR_ | PONG_ + | RNAME_ deriving (Show) class ProtocolMsgTag t where @@ -1004,6 +1023,7 @@ instance PartyI p => Encoding (CommandTag p) where RFWD_ -> "RFWD" NSUB_ -> "NSUB" NSUBS_ -> "NSUBS" + RSLV_ -> "RSLV" smpP = messageTagP instance ProtocolMsgTag CmdTag where @@ -1032,6 +1052,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 +1082,7 @@ instance Encoding BrokerMsgTag where OK_ -> "OK" ERR_ -> "ERR" PONG_ -> "PONG" + RNAME_ -> "RNAME" smpP = messageTagP instance ProtocolMsgTag BrokerMsgTag where @@ -1083,6 +1105,7 @@ instance ProtocolMsgTag BrokerMsgTag where "OK" -> Just OK_ "ERR" -> Just ERR_ "PONG" -> Just PONG_ + "RNAME" -> Just RNAME_ _ -> Nothing -- | SMP message body format @@ -1565,10 +1588,27 @@ data ErrorType EXPIRED | -- | internal server error INTERNAL + | -- | name resolution error (Resolver role) - see NameErrorType + 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 errors (the NAME family of ErrorType / AgentErrorType). +-- One vocabulary shared server-side and agent-side so name failures flow +-- through the single error type to chat (as ChatErrorAgent) with diagnostics, +-- mirroring ProxyError. +data NameErrorType + = -- | the names role / resolver is not configured on this server + NO_RESOLVER + | -- | the name is not registered (resolver returned not-found) + NO_NAME + | -- | no name-resolving servers configured (agent-originated only) + NO_SERVERS + | -- | backing resolver/RPC failure - carries the diagnostic detail + RESOLVER {resolverErr :: Text} + deriving (Eq, Show) + instance StrEncoding ErrorType where strEncode = \case BLOCK -> "BLOCK" @@ -1585,6 +1625,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 +1633,7 @@ instance StrEncoding ErrorType where "SESSION" $> SESSION, "CMD " *> (CMD <$> parseRead1), "PROXY " *> (PROXY <$> strP), + "NAME " *> (NAME <$> strP), "AUTH" $> AUTH, "BLOCKED " *> strP, "SERVICE" $> SERVICE, @@ -1792,6 +1834,8 @@ 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) + -- Version gating is the client's job (Client.hs), not the encoder's. + RSLV d -> e (RSLV_, ' ', Tail (strEncode d)) where e :: Encoding a => a -> ByteString e = smpEncode @@ -1816,6 +1860,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 +1944,11 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where CT SNotifierService NSUBS_ | v >= rcvServiceSMPVersion -> Cmd SNotifierService <$> (NSUBS <$> _smpP <*> smpP) | otherwise -> pure $ Cmd SNotifierService $ NSUBS (-1) mempty + -- Name is validated at parse (invalid syntax fails here -> CMD error), + -- so the handler only ever sees a valid SimplexNameDomain. + CT SResolver RSLV_ -> do + Tail bs <- _smpP + either fail (pure . Cmd SResolver . RSLV) (strDecode bs) fromProtocolError = fromProtocolError @SMPVersion @ErrorType @BrokerMsg {-# INLINE fromProtocolError #-} @@ -1945,6 +1995,9 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where | v < clientNoticesSMPVersion -> BLOCKED info {notice = Nothing} _ -> err PONG -> e PONG_ + -- Field-ordered Encoding NameRecord (no JSON on the wire); a response that + -- arrived is already on a supported version, so no version gate. + RNAME rec -> e (RNAME_, ' ', rec) where e :: Encoding a => a -> ByteString e = smpEncode @@ -1992,6 +2045,7 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where OK_ -> pure OK ERR_ -> ERR <$> _smpP PONG_ -> pure PONG + RNAME_ -> RNAME <$> _smpP where serviceRespP resp | v >= rcvServiceSMPVersion = resp <$> _smpP <*> smpP @@ -2014,6 +2068,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 +2111,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 +2130,28 @@ 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" + NO_NAME -> "NO_NAME" + NO_SERVERS -> "NO_SERVERS" + RESOLVER e -> "RESOLVER " <> encodeUtf8 e + smpP = + A.takeTill (== ' ') >>= \case + "NO_RESOLVER" -> pure NO_RESOLVER + "NO_NAME" -> pure NO_NAME + "NO_SERVERS" -> pure NO_SERVERS + "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 +2451,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]) diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 1b7d920ac5..ac2633e0ad 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -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 @@ -108,6 +108,7 @@ 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 (closeNamesEnv, resolveName) import Simplex.Messaging.Server.MsgStore.STM import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.NtfStore @@ -245,7 +246,10 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt saveServerStats closeServer :: M s () - closeServer = asks (smpAgent . proxyAgent) >>= liftIO . closeSMPClientAgent + closeServer = do + pa <- asks (smpAgent . proxyAgent) + ne <- asks namesEnv + liftIO $ closeSMPClientAgent pa `E.finally` mapM_ closeNamesEnv ne serverThread :: forall sub. String -> @@ -513,7 +517,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} <- @@ -576,6 +580,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 "," @@ -649,6 +654,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt ] <> showServiceStats rcvServices' <> showServiceStats ntfServices' + <> showNameResolverStats rslvStats' ) liftIO $ threadDelay' interval where @@ -656,6 +662,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} = @@ -1262,6 +1270,9 @@ verifyQueueTransmission service thAuth (tAuth, authorized, (corrId, entId, comma vc SNotifierService NSUBS {} = verifyServiceCmd vc SProxiedClient _ = VRVerified Nothing vc SProxyService (RFWD _) = VRVerified Nothing + -- RSLV is accepted both forwarded (via PFWD, preferred - hides client IP from resolver) + -- and direct (client->resolver, faster, exposes client IP). Mode is chosen by the client. + vc SResolver (RSLV _) = VRVerified Nothing checkRole = case (service, partyClientRole p) of (Just THClientService {serviceRole}, Just role) -> serviceRole == role _ -> True @@ -1486,6 +1497,19 @@ client 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 SResolver (RSLV d) -> do + st <- asks (rslvStats . serverStats) + incStat (rslvReqs st) + -- The name is validated at command parse (invalid syntax never reaches + -- here), so the handler only maps the resolver outcome to a declared + -- error that reaches the client as ERR (NAME ...). + (selector, msg) <- asks namesEnv >>= \case + Nothing -> pure (rslvDisabled, ERR $ NAME NO_RESOLVER) + Just nenv -> liftIO (resolveName nenv d) <&> \case + Right rec -> (rslvSucc, RNAME rec) + Left e@NO_NAME -> (rslvNotFound, ERR $ NAME e) + Left e -> (rslvResolverErrs, ERR $ NAME e) + incStat (selector st) $> response (corrId, NoEntity, msg) 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 @@ -2134,6 +2158,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'') @@ -2217,10 +2242,6 @@ updateDeletedStats q = do incStat $ qDeletedAll stats liftIO $ atomicModifyIORef'_ (qCount stats) (subtract 1) -incStat :: MonadIO m => IORef Int -> m () -incStat r = liftIO $ atomicModifyIORef'_ r (+ 1) -{-# INLINE incStat #-} - randomId' :: Int -> M s ByteString randomId' n = atomically . C.randomBytes n =<< asks random diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs index 574111c15e..2e212f05ff 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -115,6 +115,8 @@ 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, ResolverCall, newNamesEnv, newNamesEnvWith, pingEndpoint) +import Simplex.Messaging.Server.Names.HttpResolver (scrubUrl) 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,11 @@ data ServerConfig s = ServerConfig smpAgentCfg :: SMPClientAgentConfig, allowSMPProxy :: Bool, -- auth is the same with `newQueueBasicAuth` serverClientConcurrency :: Int, + -- | public-namespace resolver config; Nothing disables the names role + namesConfig :: Maybe NamesConfig, + -- | test seam: inject a stub resolver call instead of the production HTTP + -- resolver + startup probe. Nothing in production (built from namesConfig). + namesResolverCall_ :: Maybe ResolverCall, -- | server public information information :: Maybe ServerPublicInfo, startOptions :: StartOptions @@ -272,7 +279,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 +566,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 {allowSMPProxy, smpCredentials, httpCredentials, serverStoreCfg, smpAgentCfg, information, messageExpiration, idleQueueInterval, msgQueueQuota, maxJournalMsgCount, maxJournalStateLines, namesConfig, namesResolverCall_} = do serverActive <- newTVarIO True server <- newServer msgStore_ <- case serverStoreCfg of @@ -603,6 +611,23 @@ newEnv config@ServerConfig {smpCredentials, httpCredentials, serverStoreCfg, smp sockets <- newTVarIO [] clientSeq <- newTVarIO 0 proxyAgent <- newSMPProxyAgent smpAgentCfg random + namesEnv <- case namesConfig of + Nothing -> pure Nothing + Just nc -> case namesResolverCall_ of + -- test seam: stub resolver, no real HTTP env or startup probe + Just call -> Just <$> newNamesEnvWith nc call Nothing + Nothing -> do + logInfo $ "[NAMES] resolver enabled, endpoint=" <> scrubUrl (resolverEndpoint nc) + when allowSMPProxy $ + logWarn "[NAMES] enable: on on a proxy-role host: slow RSLV calls can serialise other forwarded commands on the same proxy-relay session. For high-volume deployments, run [NAMES] on a separate host." + env <- newNamesEnv nc + -- Probe the endpoint at startup. Don't exitFailure: a flapping + -- network or an Ethereum 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 (Just env) pure Env { serverActive, @@ -618,7 +643,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 () diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index f7461f392b..4842b3c106 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -34,6 +34,7 @@ module Simplex.Messaging.Server.Main simplexmqSource, serverPublicInfo, validCountryValue, + validateUrl, printSourceCode, cliCommandP, strParse, @@ -46,11 +47,11 @@ import Control.Monad import qualified Data.Attoparsec.ByteString.Char8 as A import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B -import Data.Char (isAlpha, isAscii, toUpper) +import Data.Char (isAlpha, isAscii, isDigit, isHexDigit, toLower, toUpper) import Data.Either (fromRight) import Data.Functor (($>)) import Data.Ini (Ini, lookupValue, readIniFile) -import Data.List (find, isPrefixOf) +import Data.List (find, isInfixOf, isPrefixOf) import qualified Data.List.NonEmpty as L import Data.Maybe (fromMaybe, isJust, isNothing) import Data.Text (Text) @@ -66,6 +67,10 @@ 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 qualified Data.IP as IP +import Data.Bits (shiftR, (.&.)) +import Data.Word (Word32) +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 +81,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 +611,8 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = }, allowSMPProxy = True, serverClientConcurrency = readIniDefault defaultProxyClientConcurrency "PROXY" "client_concurrency" ini, + namesConfig = readNamesConfig ini, + namesResolverCall_ = Nothing, -- production builds the resolver from namesConfig information = serverPublicInfo ini, startOptions } @@ -796,6 +804,198 @@ 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", + -- ceiling = SMP transport budget: the NAME response is one SMP + -- transmission (proxied: padded to paddedProxiedTLength = 16226), + -- and the smpEncoded NameRecord is <= its JSON body, so capping + -- the body here guarantees the response always frames. An + -- over-cap body fails as BodyTooLarge -> ERR (NAME (RESOLVER ..)). + 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 + -- Lower bound rejects values that would time-out every RSLV immediately + -- (timeout = 0) or accept zero-length responses (max_response_bytes = 0). + -- The upper bounds defend against operator-misconfig footguns: the response + -- cap is the SMP transport budget (see resolverMaxResponseBytes above), and + -- 60 s is the max RSLV timeout no operator wants exceeded. + 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: +-- * scheme must be http: or https: +-- * authority (host) must be present and non-empty +-- * port MUST be explicit (rejects http://host without :8000 to avoid +-- accidentally hitting :80 when the resolver listens on :8000) +-- * userinfo (user:pass@) MUST NOT be present (credentials belong in +-- resolver_auth so they don't leak via Host header or logs) +-- * query and fragment MUST NOT be present (a base URL with a query/fragment +-- does not compose with the appended /resolve/ and /health paths) +-- * a path prefix IS allowed (e.g. https://gw.example.com:443/snrc for a +-- resolver behind a reverse-proxy sub-path); /resolve/ and /health +-- are appended to it. Do not embed secrets in the path — it appears in +-- logs; put credentials in resolver_auth. +-- * on a non-loopback host, only http WITH resolver_auth is rejected (the +-- Authorization header would travel in cleartext). http without auth is +-- allowed (no secret to leak; resolver data is public — also lets dev +-- setups reach a host resolver via host.docker.internal). https is always +-- allowed, with or without auth. +-- * link-local hosts (169.254.0.0/16, including the cloud metadata IP +-- 169.254.169.254) are rejected unconditionally +validateUrl :: Text -> Maybe RpcAuth -> Either String Text +validateUrl url auth_ = do + uri <- maybe (Left "not an absolute URI") Right $ parseAbsoluteURI (T.unpack url) + let scheme = uriScheme uri + unless (scheme == "http:" || scheme == "https:") $ + Left ("scheme " <> show scheme <> " not supported (use http or https)") + ua <- maybe (Left "missing authority (host)") Right (uriAuthority uri) + let host = uriRegName ua + when (null host) $ Left "empty host" + when (isBareIntegerHost host) $ + Left "bare-integer host not allowed (use a hostname or dotted-quad / bracketed IP); rejects 169.254.169.254 decimal/hex aliases" + when (isObfuscatedIpv4 host) $ + Left "non-canonical IPv4 form not allowed (use dotted-quad decimal 0-255 with no leading zeros); rejects inet_aton hex/octal/compact aliases of 169.254.169.254" + when (isLinkLocal host || isForbiddenIpv6 host) $ + Left "link-local host not allowed (rejects cloud metadata services and IPv6 aliases of 169.254.0.0/16)" + unless (null (uriUserInfo ua)) $ Left "userinfo (user:pass@) not allowed; use resolver_auth instead" + case uriPort ua of + "" -> Left "explicit port required (e.g. http://host:8000)" + ':' : portStr -> case readMaybe portStr of + Just n | (n :: Int) >= 1 && n <= 65535 -> Right () + _ -> Left $ "port " <> portStr <> " out of range (must be 1..65535)" + other -> Left $ "unexpected port syntax: " <> other + unless (null (uriQuery uri)) $ Left "query string not allowed (it does not compose with the appended /resolve/ path)" + unless (null (uriFragment uri)) $ Left "fragment not allowed (fragments are never sent to the server)" + -- A path prefix is allowed and used as the base for /resolve/ and + -- /health (resolver behind a reverse-proxy sub-path). The join in + -- HttpResolver.newResolverEnv strips a single trailing slash, so both + -- ".../snrc" and ".../snrc/" behave identically. Secrets do not belong in + -- the path (it is logged) — use resolver_auth. + -- The only transport-security risk on a non-loopback host is leaking the + -- Authorization header in cleartext, so we reject ONLY http+auth. http + -- without auth is allowed (nothing secret to leak — the resolver serves + -- public name data; this also covers reaching a host resolver via + -- host.docker.internal in dev). https is always fine, with or without auth. + -- NOTE: http without auth has no transport integrity — a network attacker + -- could forge NameRecord responses. Only point at a plaintext resolver on a + -- trusted/local network. + when (not (isLoopback host) && scheme == "http:" && isJust auth_) $ + Left "http with resolver_auth on a non-loopback host not allowed (the Authorization header would be sent in cleartext); use https, or drop resolver_auth for a no-auth resolver" + Right url + where + -- 127.0.0.0/8 and 0.0.0.0 both bind locally on Linux/BSD; treat them all + -- as loopback for the http/auth gate so a misconfigured 0.0.0.0:8545 (or + -- 127.0.0.5) doesn't get an Authorization header sent to a colocated + -- service or silently dropped onto the wire. + isLoopback = \case + "localhost" -> True + "[::1]" -> True + "0.0.0.0" -> True + h -> case parseDottedQuad h of + Just (127, _, _, _) -> True + _ -> False + parseDottedQuad s = case splitOnDot s of + [a, b, c, d] -> (,,,) <$> octet a <*> octet b <*> octet c <*> octet d + _ -> Nothing + where + octet o = case readMaybe o of + Just n | (n :: Int) >= 0 && n <= 255 -> Just n + _ -> Nothing + splitOnDot s = case break (== '.') s of + (chunk, []) -> [chunk] + (chunk, _ : rest) -> chunk : splitOnDot rest + -- IPv4 link-local 169.254.0.0/16 in dotted-quad form. IPv6 forms are + -- delegated to isForbiddenIpv6 which parses the address numerically. + isLinkLocal h = "169.254." `isPrefixOf` h + -- Reject hostnames that look like decimal or `0x`/`0X`-hex integers — + -- glibc's inet_aton accepts both as IPv4 aliases (`2852039166`, + -- `0xa9fea9fe`, `0XA9FEA9FE` all resolve to 169.254.169.254). The literal + -- prefix `0x` / `0X` with no digits after is also rejected: it isn't a + -- legitimate hostname and lets us avoid reasoning about libc's behaviour. + isBareIntegerHost h = case map toLower h of + '0' : 'x' : rest -> all isHexDigit rest + lh -> not (null lh) && all isDigit lh + -- Reject dotted hosts whose every component is numeric (decimal or `0x`-hex) + -- but which aren't strict canonical IPv4 (exactly 4 decimal octets 0..255 with + -- no leading zeros). inet_aton accepts hex octets (`0xA9.0xFE.0xA9.0xFE`), + -- octal octets (`0251.0376.0251.0376`, leading zero), mixed forms + -- (`169.0376.169.254`), and compact 2/3-segment forms (`169.16689638`, + -- `169.254.43518`) as aliases for 169.254.169.254. The literal-prefix check + -- in isLinkLocal misses all of these; this predicate closes the gap. + isObfuscatedIpv4 h + | '.' `notElem` h = False + | otherwise = allNumericParts && not strictCanonical + where + parts = splitOnDot h + allNumericParts = not (null parts) && all isNumericPart parts + isNumericPart p = case map toLower p of + '0' : 'x' : rest@(_ : _) -> all isHexDigit rest + lp@(_ : _) -> all isDigit lp + _ -> False + strictCanonical = length parts == 4 && all isStrictDecOctet parts + isStrictDecOctet "0" = True + isStrictDecOctet p@(c : _) = + c /= '0' && all isDigit p && maybe False (\n -> (n :: Int) <= 255) (readMaybe p) + isStrictDecOctet _ = False + -- Strip the [...] brackets that parseAbsoluteURI keeps on IPv6 hosts, parse + -- as numeric IPv6, and check 128-bit ranges: + -- * fe80::/10 (link-local) + -- * ::1 (loopback) + -- * IPv4-compatible (::/96), IPv4-mapped (::ffff/96), 6to4 (2002::/16), + -- NAT64 WKP (64:ff9b::/96) — when they alias an IPv4 in 169.254.0.0/16 + -- This covers every textual form of those addresses (compressed, uncompressed, + -- mixed dotted-quad embed) because Data.IP normalises before we inspect bits. + isForbiddenIpv6 h = maybe False (isForbiddenIpv6Word . IP.fromIPv6w) $ + stripBrackets h >>= readMaybe + where + stripBrackets ('[' : rest@(_ : _)) | last rest == ']' = Just (init rest) + stripBrackets _ = Nothing + -- Loopback (::1) is intentionally NOT in this list: loopback is gated + -- separately by isLoopback for the http/auth decision. + isForbiddenIpv6Word :: (Word32, Word32, Word32, Word32) -> Bool + isForbiddenIpv6Word (w1, w2, w3, w4) = + linkLocal || compatTo169 || mappedTo169 || sixToFour169 || nat64To169 + where + linkLocal = (w1 `shiftR` 22) == 0x3fa -- fe80::/10 + is169254v4 = (w4 `shiftR` 16) == 0xa9fe + high96Zero = w1 == 0 && w2 == 0 + compatTo169 = high96Zero && w3 == 0 && is169254v4 + mappedTo169 = high96Zero && w3 == 0xffff && is169254v4 + sixToFour169 = (w1 `shiftR` 16) == 0x2002 && (w1 .&. 0xffff) == 0xa9fe + nat64To169 = w1 == 0x0064ff9b && w2 == 0 && w3 == 0 && is169254v4 + +-- | Parse an rpc_auth INI value. Scheme keyword is case-insensitive so +-- "Bearer " / "BEARER " (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 ` or `basic :`" + printSourceCode :: Maybe Text -> IO () printSourceCode = \case Just sourceCode -> T.putStrLn $ "Server source code: " <> sourceCode diff --git a/src/Simplex/Messaging/Server/Main/Init.hs b/src/Simplex/Messaging/Server/Main/Init.hs index 0e3ceb81b4..355615d4f2 100644 --- a/src/Simplex/Messaging/Server/Main/Init.hs +++ b/src/Simplex/Messaging/Server/Main/Init.hs @@ -155,6 +155,22 @@ iniFileContent cfgPath logPath opts host basicAuth controlPortPwds = \# 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\ + \# Co-locating with the proxy role logs a startup advisory: slow RSLV calls can\n\ + \# serialise other forwarded commands on the same proxy-relay session.\n\ + \# For high-volume deployments, run [NAMES] on a separate host.\n\ + \# Restart required to change settings.\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 :\n\ + \# resolver_timeout_ms: 3000\n\ + \# resolver_max_response_bytes: 65536\n\n\ \[INACTIVE_CLIENTS]\n\ \# TTL and interval to check inactive clients\n\ \disconnect = on\n" diff --git a/src/Simplex/Messaging/Server/Names.hs b/src/Simplex/Messaging/Server/Names.hs new file mode 100644 index 0000000000..bb55f92d75 --- /dev/null +++ b/src/Simplex/Messaging/Server/Names.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} + +-- | Public-namespace resolver. Each RSLV becomes one HTTP GET to the +-- configured names resolver service (the Python REST resolver in PR #1795 +-- by default), bounded by resolverTimeoutMs and the maximum response size. +-- The resolver_endpoint URL is operator-supplied; the resolver service is the +-- source of truth for which on-chain registries are queried per TLD. +-- +-- Resolver outcomes map to the protocol's `NameErrorType` so failures reach the +-- client (as `ERR (NAME ...)` -> ChatErrorAgent) instead of being swallowed. +-- +-- HTTP details (URL building, redirects disabled, body cap, auth header) +-- live in Names.HttpResolver. +module Simplex.Messaging.Server.Names + ( NamesConfig (..), + RpcAuth (..), + NamesEnv (..), + ResolverCall, + ResolverCallKind (..), + newNamesEnv, + newNamesEnvWith, + closeNamesEnv, + pingEndpoint, + resolveName, + ) +where + +import qualified Control.Exception as E +import Control.Logger.Simple (logError) +import qualified Data.Aeson as J +import qualified Data.Aeson.Types as JT +import Data.Text (Text) +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 :: Text, + resolverAuth :: Maybe RpcAuth, + resolverTimeoutMs :: Int, + resolverMaxResponseBytes :: Int + } + deriving (Show) + +-- | Test seam: a function from URL path -> JSON value or error. Production +-- wires this to resolveHttp / healthHttp on a real `ResolverEnv`; tests +-- substitute a stub returning canned JSON or a chosen error. +-- +-- The first argument is the HTTP endpoint to hit: `ResolverFetch` for a +-- name lookup, `ResolverHealth` for the startup probe. Tests use the tag +-- to assert which kind of call the server made. +data ResolverCallKind = ResolverFetch Text | ResolverHealth + deriving (Eq, Show) + +-- Re-export so test seams (which need to match on the kind) can use it +-- without depending on the HttpResolver module. + +type ResolverCall = ResolverCallKind -> IO (Either ResolverError J.Value) + +data NamesEnv = NamesEnv + { config :: NamesConfig, + resolverCall :: ResolverCall, + resolverEnv :: Maybe ResolverEnv -- Nothing for test stubs + } + +newNamesEnv :: NamesConfig -> IO NamesEnv +newNamesEnv cfg = do + rEnv <- newResolverEnv (resolverEndpoint cfg) (resolverAuth cfg) (resolverTimeoutMs cfg) (resolverMaxResponseBytes cfg) + newNamesEnvWith cfg (httpResolverCall rEnv) (Just rEnv) + +httpResolverCall :: ResolverEnv -> ResolverCall +httpResolverCall env = \case + ResolverFetch n -> resolveHttp env n + ResolverHealth -> healthHttp env + +-- | Allocate resolver with an injected `resolverCall` (test seam). +newNamesEnvWith :: NamesConfig -> ResolverCall -> Maybe ResolverEnv -> IO NamesEnv +newNamesEnvWith config resolverCall resolverEnv = pure NamesEnv {config, resolverCall, resolverEnv} + +closeNamesEnv :: NamesEnv -> IO () +closeNamesEnv NamesEnv {resolverEnv} = mapM_ closeResolverEnv resolverEnv + +-- | Reach the configured resolver with `GET /health` to confirm reachability +-- at server startup. A non-2xx response or transport failure surfaces as +-- Left so misconfigured deployments fail loudly. Bounded by +-- `resolverTimeoutMs` so a slow-loris endpoint cannot park startup until +-- http-client's default 30 s response timeout fires. +pingEndpoint :: NamesEnv -> IO (Either ResolverError ()) +pingEndpoint NamesEnv {resolverCall, config} = do + r <- timeout (resolverTimeoutMs config * 1000) $ resolverCall ResolverHealth + pure $ case r of + Nothing -> Left (HttpStatusErr 0) -- transport-level timeout (0 is not a real HTTP code) + Just (Left e) -> Left e + Just (Right _) -> Right () + +-- | Resolve a parsed domain via the configured HTTP resolver, with an +-- `resolverTimeoutMs` ceiling. Synchronous exceptions are caught and +-- logged; async exceptions propagate. +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 (maybe (Left (RESOLVER "timeout")) id 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 {resolverCall} d = + resolverCall (ResolverFetch (fullDomainName d)) >>= \case + Left e -> pure (Left (mapResolverError e)) + Right v -> case JT.parseEither J.parseJSON v of + Right nr -> pure (Right nr) + Left _ -> pure (Left (RESOLVER "invalid response")) + +-- | Map the HTTP-layer error space into the protocol NameErrorType. 404 / 400 +-- both map to NO_NAME (name not registered, unknown TLD, or malformed name — +-- indistinguishable from the client's point of view). Everything else is a +-- backend failure surfaced as RESOLVER with a SAFE server-generated diagnostic +-- (kind only - the adversarial response body is never echoed). +mapResolverError :: ResolverError -> NameErrorType +mapResolverError = \case + HttpStatusErr 404 -> NO_NAME + HttpStatusErr 400 -> NO_NAME + HttpStatusErr code -> RESOLVER ("HTTP " <> T.pack (show code)) + HttpFailure _ -> RESOLVER "transport failure" + BodyTooLarge -> RESOLVER "response too large" + InvalidJson _ -> RESOLVER "invalid response" diff --git a/src/Simplex/Messaging/Server/Names/HttpResolver.hs b/src/Simplex/Messaging/Server/Names/HttpResolver.hs new file mode 100644 index 0000000000..ed314c6de1 --- /dev/null +++ b/src/Simplex/Messaging/Server/Names/HttpResolver.hs @@ -0,0 +1,164 @@ +{-# 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/ -> 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, + scrubUrl, + ) +where + +import qualified Control.Exception as E +import qualified Data.Aeson as J +import qualified Data.ByteArray.Encoding as BAE +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Lazy as BL +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeLatin1, encodeUtf8) +import Network.HTTP.Client + ( HttpException, + Manager, + ManagerSettings (..), + Request, + 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) + +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 " + show (AuthBasic u _) = "AuthBasic " <> show u <> " " + +data ResolverEnv = ResolverEnv + { manager :: Manager, + baseUrl :: Text, + authHdr :: [HT.Header], + timeoutMicro :: Int, + maxResponseBytes :: Int + } + +data ResolverError + = HttpFailure HttpException + | HttpStatusErr Int + | BodyTooLarge + | InvalidJson String + deriving (Show) + +newResolverEnv :: Text -> Maybe RpcAuth -> Int -> Int -> IO ResolverEnv +newResolverEnv baseUrl auth_ timeoutMs maxResponseBytes = do + manager <- HC.newManager tlsManagerSettings {managerConnCount = 10} + pure + ResolverEnv + { manager, + baseUrl = stripTrailingSlash 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 /resolve/, return the JSON body on 200. +resolveHttp :: ResolverEnv -> Text -> IO (Either ResolverError J.Value) +resolveHttp env name = doGet env ("/resolve/" <> percentEncode name) + +-- | GET /health, return the JSON body on 200. +healthHttp :: ResolverEnv -> IO (Either ResolverError J.Value) +healthHttp env = doGet env "/health" + +doGet :: ResolverEnv -> Text -> IO (Either ResolverError J.Value) +doGet ResolverEnv {manager, baseUrl, authHdr, timeoutMicro, maxResponseBytes} path = do + req0 <- parseRequest (T.unpack (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) + if BL.length bs > fromIntegral maxResponseBytes + then pure (Left BodyTooLarge) + else case J.eitherDecodeStrict (BL.toStrict bs) of + Left e -> pure (Left (InvalidJson e)) + Right v -> pure (Right v) + pure (either (Left . HttpFailure) id result) + +-- | Percent-encode a name component (path-safe). Aggressive: encode every +-- byte that isn't an unreserved character per RFC 3986. The resolver expects +-- raw labels (e.g., `alice.simplex`); slashes and other ASCII punctuation +-- would change the request path semantics if passed through verbatim. +percentEncode :: Text -> Text +percentEncode = decodeLatin1 . urlEncode True . encodeUtf8 + +stripTrailingSlash :: Text -> Text +stripTrailingSlash t = case T.unsnoc t of + Just (rest, '/') -> rest + _ -> t + +-- | Strip userinfo from a URL so log lines never leak credentials. +scrubUrl :: Text -> Text +scrubUrl url = + let (scheme, rest) = T.breakOn "://" url + in if T.null rest + then url + else + let body = T.drop 3 rest + (host, query) = T.breakOn "/" body + in case T.breakOn "@" host of + (_userinfo, atRest) + | not (T.null atRest) -> scheme <> "://" <> T.drop 1 atRest <> query + _ -> url diff --git a/src/Simplex/Messaging/Server/Prometheus.hs b/src/Simplex/Messaging/Server/Prometheus.hs index 32e8bd9a10..575f699c6e 100644 --- a/src/Simplex/Messaging/Server/Prometheus.hs +++ b/src/Simplex/Messaging/Server/Prometheus.hs @@ -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\ diff --git a/src/Simplex/Messaging/Server/Stats.hs b/src/Simplex/Messaging/Server/Stats.hs index e8291759e6..f6583f6875 100644 --- a/src/Simplex/Messaging/Server/Stats.hs +++ b/src/Simplex/Messaging/Server/Stats.hs @@ -39,9 +39,18 @@ module Simplex.Messaging.Server.Stats setServiceStats, emptyTimeBuckets, updateTimeBuckets, + incStat, + NameResolverStats (..), + NameResolverStatsData (..), + newNameResolverStats, + newNameResolverStatsData, + getNameResolverStatsData, + getResetNameResolverStatsData, + setNameResolverStats, ) where import Control.Applicative (optional, (<|>)) +import Control.Monad.IO.Class (MonadIO, liftIO) import qualified Data.Attoparsec.ByteString.Char8 as A import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B @@ -123,7 +132,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 +194,8 @@ data ServerStatsData = ServerStatsData _rcvServicesSubDuplicate :: Int, _qCount :: Int, _msgCount :: Int, - _ntfCount :: Int + _ntfCount :: Int, + _rslvStats :: NameResolverStatsData } deriving (Show) @@ -248,6 +259,7 @@ newServerStats ts = do qCount <- newIORef 0 msgCount <- newIORef 0 ntfCount <- newIORef 0 + rslvStats <- newNameResolverStats pure ServerStats { fromTime, @@ -307,7 +319,8 @@ newServerStats ts = do rcvServicesSubDuplicate, qCount, msgCount, - ntfCount + ntfCount, + rslvStats } getServerStatsData :: ServerStats -> IO ServerStatsData @@ -370,6 +383,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 +443,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 +508,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 +573,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 +646,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 +709,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 @@ -786,6 +809,10 @@ updatePeriodStats ps (EntityId pId) = do ph = hash pId updatePeriod ref = unlessM (IS.member ph <$> readIORef ref) $ atomicModifyIORef'_ ref $ IS.insert ph +incStat :: MonadIO m => IORef Int -> m () +incStat r = liftIO $ atomicModifyIORef'_ r (+ 1) +{-# INLINE incStat #-} + data ProxyStats = ProxyStats { pRequests :: IORef Int, pSuccesses :: IORef Int, -- includes destination server error responses that will be forwarded to the client @@ -862,6 +889,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, diff --git a/src/Simplex/Messaging/SimplexName.hs b/src/Simplex/Messaging/SimplexName.hs new file mode 100644 index 0000000000..f02ced0bdf --- /dev/null +++ b/src/Simplex/Messaging/SimplexName.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | SimpleX name shape — parsed surface form for `@contact.simplex`, +-- `#group`, and similar. Shared between the agent (which receives names +-- from the user) and the server (which validates them on the RSLV path). +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 (ToField (..)) +import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON) +import Simplex.Messaging.Util (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 = T.intercalate "-" <$> AT.takeWhile1 (\c -> isNameLetter c || isDigit c) `AT.sepBy1` AT.char '-' + 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' + +-- | DoS defense for the bare-name / bare-domain entry points. The outer +-- parser would otherwise `takeWhile1 (not . isSpace)` unbounded, allowing +-- a crafted multi-megabyte token to be decoded and re-parsed before any +-- validation. Cap at 253 bytes (DNS full-domain limit) — generous against +-- any realistic SimpleX name and forces the surrounding `parseOnly` +-- (which requires consuming all input) to fail on oversized inputs. +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 pure bs + +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 <$?> 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 + -- All labels lowercased: DNS labels are case-insensitive, and namehash is + -- byte-defined — preserving original case would make `Alice.simplex` and + -- `alice.simplex` resolve to different on-chain records. A mixed-case TLD + -- would also fall through to TLDWeb and route through the `tldAll` + -- catch-all entry instead of the TLDSimplex registry. + mkDomain labels = case reverse (map T.toLower 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 "." (map T.toLower 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 -> "@" + +-- | Stored as TEXT. The matching `FromField` instance is intentionally not +-- defined: existing consumers want soft-decode semantics (parse failure +-- degrades to `Nothing` rather than failing the row), which doesn't +-- compose with `fromTextField_`. Add a `FromField` instance here only +-- when a consumer wants the row-fail behaviour and document the divide. +instance ToField SimplexNameInfo where toField = toField . decodeLatin1 . strEncode + +$(J.deriveJSON (enumJSON $ dropPrefix "TLD") ''SimplexTLD) + +$(J.deriveJSON (enumJSON $ dropPrefix "NT") ''SimplexNameType) + +$(J.deriveJSON defaultJSON ''SimplexNameDomain) + +$(J.deriveJSON defaultJSON ''SimplexNameInfo) diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index d98453ab8e..2d6229621b 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -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,13 +234,13 @@ 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. @@ -244,7 +248,7 @@ currentServerSMPRelayVersion = VersionSMP 19 -- to prevent client version fingerprinting by the -- destination relays when clients upgrade at different times. proxiedSMPRelayVersion :: VersionSMP -proxiedSMPRelayVersion = VersionSMP 18 +proxiedSMPRelayVersion = VersionSMP 20 -- minimal supported protocol version is 6 -- TODO remove code that supports sending commands without batching diff --git a/tests/AgentTests.hs b/tests/AgentTests.hs index 368e7c0e2e..34d610cd5c 100644 --- a/tests/AgentTests.hs +++ b/tests/AgentTests.hs @@ -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 + resolveNameTests agentTests :: (ASrvTransport, AStoreType) -> Spec agentTests ps = do diff --git a/tests/AgentTests/ResolveNameTests.hs b/tests/AgentTests/ResolveNameTests.hs new file mode 100644 index 0000000000..88c20696da --- /dev/null +++ b/tests/AgentTests/ResolveNameTests.hs @@ -0,0 +1,226 @@ +{-# 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 #-} + +-- | End-to-end tests for `Simplex.Messaging.Agent.resolveSimplexName`. +-- +-- Exercises the agent layer (real `AgentClient`) against an SMP server with a +-- stub `ResolverCall` (set via `ServerConfig.namesResolverCall_`). The agent +-- owns server selection: it picks a names-capable server (ServerRoles.names) +-- from the user's nameSrvs, so the proxy test gives ONLY the resolver server +-- the names role (deterministic selection) and the proxy server the proxy role. +module AgentTests.ResolveNameTests (resolveNameTests) where + +import AgentTests.FunctionalAPITests (withAgent) +import Control.Monad.Except (runExceptT) +import qualified Data.Aeson as J +import Data.List (isInfixOf) +import SMPAgentClient +import SMPClient +import SMPNamesTests (sampleRecord, sampleRecordJSON) +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.Server.Env.STM (AStoreType (..), ServerConfig (..), ServerStoreCfg (..), StorePaths (..)) +import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) +import Simplex.Messaging.Server.Names (NamesConfig (..), ResolverCall, ResolverCallKind (..)) +import Simplex.Messaging.Server.Names.HttpResolver (ResolverError (..)) +import Simplex.Messaging.SimplexName (SimplexNameDomain (..), SimplexTLD (..)) +import Simplex.Messaging.Transport +import Test.Hspec hiding (fit, it) +import Util (it) + +stubNamesConfig :: NamesConfig +stubNamesConfig = + NamesConfig + { resolverEndpoint = "http://stub", + resolverAuth = Nothing, + resolverTimeoutMs = 1000, + resolverMaxResponseBytes = 65536 + } + +-- | 404 stub: resolver returns "not registered". Server -> ERR (NAME NO_NAME). +stubResolverNotFound :: ResolverCall +stubResolverNotFound = \case + ResolverFetch _ -> pure (Left (HttpStatusErr 404)) + ResolverHealth -> pure (Right (J.object [])) + +-- | Success stub: returns the canned NameRecord JSON. +stubResolverSuccess :: ResolverCall +stubResolverSuccess = \case + ResolverFetch _ -> pure (Right sampleRecordJSON) + ResolverHealth -> pure (Right (J.object [])) + +-- | 502 stub: backing resolver fails. Server -> ERR (NAME (RESOLVER "HTTP 502")). +stubResolverError :: ResolverCall +stubResolverError = \case + ResolverFetch _ -> pure (Left (HttpStatusErr 502)) + ResolverHealth -> pure (Right (J.object [])) + +-- | Enable names on a server config with a stub resolver (no real HTTP/probe). +withNames :: ResolverCall -> AServerConfig -> AServerConfig +withNames stub c = updateCfg c $ \cfg_ -> cfg_ {namesConfig = Just stubNamesConfig, namesResolverCall_ = Just stub} + +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 + +-- per-server roles: only the resolver server carries the names role +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 + +-- single-server (operator 1) agent config, direct (no proxy) +oneSrv :: ServerCfg 'SMP.PSMP -> InitialAgentServers +oneSrv cfg_ = (initAgentServersProxy_ SPMNever SPFProhibit) {smp = [(1, [cfg_])]} + +withDirectResolver :: ResolverCall -> (AgentClient -> IO a) -> IO a +withDirectResolver stub k = + withSmpServerConfigOn (transport @TLS) (withNames stub memCfg) testPort $ \_ -> + withAgent 1 agentCfg (oneSrv (nameSrvCfg testSMPServer)) testDB k + +withProxyAndResolver :: ResolverCall -> (AgentClient -> IO a) -> IO a +withProxyAndResolver stub k = + withSmpServerConfigOn (transport @TLS) memProxyCfg testPort $ \_ -> + withSmpServerConfigOn (transport @TLS) (withNames stub 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])]} + +-- | A direct SMP server with NO names role configured (namesEnv = Nothing): the +-- agent still picks it (client-side names role) and the server answers +-- NAME NO_RESOLVER. +withNoResolver :: (AgentClient -> IO a) -> IO a +withNoResolver k = + withSmpServerConfigOn (transport @TLS) memCfg testPort $ \_ -> + withAgent 1 agentCfg (oneSrv (nameSrvCfg testSMPServer)) testDB k + +-- | An agent whose one server has the names role OFF (proxySrvCfg): nameSrvs is +-- empty, but the user exists, so resolution fails agent-side in getNextNameServer +-- with NO_SERVERS (not the unknown-user INTERNAL path) - no server is contacted. +withNoNameServers :: (AgentClient -> IO a) -> IO a +withNoNameServers k = withAgent 1 agentCfg (oneSrv (proxySrvCfg testSMPServer)) testDB k + +-- --------------------------------------------------------------------------- +-- Spec +-- --------------------------------------------------------------------------- + +resolveNameTests :: Spec +resolveNameTests = do + describe "Agent resolveSimplexName" $ do + describe "direct path (SPMNever)" $ + it "404 propagates as SMP host (NAME NO_NAME)" testDirectNotFound + describe "proxy path (SPMAlways)" $ + it "404 from resolver propagates via proxy as SMP (NAME NO_NAME)" testProxyNotFound + describe "TLDTesting path" $ + it "NAME NO_NAME for TLDTesting too" testTestingTldNotFound + describe "TLDWeb path" $ + it "NAME NO_NAME 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 NAME NO_SERVERS" testNoNameServers + describe "backing resolver failure" $ + it "surfaces as SMP host (NAME (RESOLVER ..))" testBackendError + describe "success path" $ + it "returns NameRecord" testDirectSuccess + +-- --------------------------------------------------------------------------- +-- Tests +-- --------------------------------------------------------------------------- + +testDirectNotFound :: HasCallStack => IO () +testDirectNotFound = + withDirectResolver stubResolverNotFound $ \c -> do + r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexNameDomain TLDSimplex "alice" []) + case r of + Left (SMP _ (SMP.NAME SMP.NO_NAME)) -> pure () + _ -> expectationFailure $ "expected Left (SMP _ (NAME NO_NAME)), got: " <> show r + +testProxyNotFound :: HasCallStack => IO () +testProxyNotFound = + withProxyAndResolver stubResolverNotFound $ \c -> do + r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexNameDomain TLDSimplex "alice" []) + case r of + Left (SMP host (SMP.NAME SMP.NO_NAME)) | testPort `isInfixOf` host -> pure () + _ -> expectationFailure $ "expected Left (SMP testPort <> "> (NAME NO_NAME)), got: " <> show r + +testTestingTldNotFound :: HasCallStack => IO () +testTestingTldNotFound = + withDirectResolver stubResolverNotFound $ \c -> do + r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexNameDomain TLDTesting "bob" []) + case r of + Left (SMP _ (SMP.NAME SMP.NO_NAME)) -> pure () + _ -> expectationFailure $ "expected Left (SMP _ (NAME NO_NAME)), got: " <> show r + +testWebTldNotFound :: HasCallStack => IO () +testWebTldNotFound = + withDirectResolver stubResolverNotFound $ \c -> do + r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexNameDomain TLDWeb "example.com" []) + case r of + Left (SMP _ (SMP.NAME SMP.NO_NAME)) -> pure () + _ -> expectationFailure $ "expected Left (SMP _ (NAME NO_NAME)), got: " <> show r + +-- | A router with the names role but no resolver configured answers +-- NAME NO_RESOLVER (distinct from NO_NAME / NO_SERVERS). +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 + +-- | With no names-role servers, resolution fails agent-side (no server is +-- contacted) with the agent-origin AgentErrorType.NAME NO_SERVERS. +testNoNameServers :: HasCallStack => IO () +testNoNameServers = + withNoNameServers $ \c -> do + r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexNameDomain TLDSimplex "alice" []) + case r of + Left (NAME SMP.NO_SERVERS) -> pure () + _ -> expectationFailure $ "expected Left (NAME NO_SERVERS), got: " <> show r + +-- | A backing-resolver failure (502) surfaces as SMP host (NAME (RESOLVER ..)) - +-- a transient error distinct from NO_NAME ("name not registered"). +testBackendError :: HasCallStack => IO () +testBackendError = + withDirectResolver stubResolverError $ \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 stubResolverSuccess $ \c -> do + r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexNameDomain TLDSimplex "alice" []) + case r of + Right nr -> nr `shouldBe` sampleRecord + _ -> expectationFailure $ "expected Right NameRecord, got: " <> show r diff --git a/tests/AgentTests/ServerChoice.hs b/tests/AgentTests/ServerChoice.hs index 8412c6761a..01ceeff16a 100644 --- a/tests/AgentTests/ServerChoice.hs +++ b/tests/AgentTests/ServerChoice.hs @@ -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 = diff --git a/tests/CoreTests/ConnectTargetTests.hs b/tests/CoreTests/ConnectTargetTests.hs new file mode 100644 index 0000000000..a068c6abf8 --- /dev/null +++ b/tests/CoreTests/ConnectTargetTests.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module CoreTests.ConnectTargetTests where + +import AgentTests.ConnectionRequestTests (contactConnRequest, invConnRequest) +import qualified Data.Aeson as J +import Data.Either (isLeft) +import Data.Text.Encoding (decodeUtf8) +import Simplex.Messaging.Agent.Protocol (AConnectionLink (..), ConnectTarget (..), ConnectionLink (..), SConnectionMode (..)) +import Simplex.Messaging.Encoding.String (strDecode, strEncode) +import Test.Hspec hiding (fit, it) +import Util (it) + +connectTargetTests :: Spec +connectTargetTests = describe "ConnectTarget" $ do + describe "CTName (SimpleX name) — canonical wire form prefixes simplex:/name" $ do + it "@alice.simplex encodes as simplex:/name@alice.simplex" $ + "@alice.simplex" `encodesAs` "simplex:/name@alice.simplex" + it "#privacy (bare TLD-less channel) encodes as simplex:/name#privacy.simplex" $ + "#privacy" `encodesAs` "simplex:/name#privacy.simplex" + it "#privacy.simplex encodes as simplex:/name#privacy.simplex" $ + "#privacy.simplex" `encodesAs` "simplex:/name#privacy.simplex" + it "#support.acme.simplex preserves subdomain" $ + "#support.acme.simplex" `encodesAs` "simplex:/name#support.acme.simplex" + it "#PRIVACY (bare uppercase) lowercases to match #privacy" $ + strDecode @ConnectTarget "#PRIVACY" `shouldBe` strDecode @ConnectTarget "#privacy" + it "simplex:/name@alice.simplex round-trips" $ + "simplex:/name@alice.simplex" `encodesAs` "simplex:/name@alice.simplex" + it "simplex:/name#privacy.simplex round-trips" $ + "simplex:/name#privacy.simplex" `encodesAs` "simplex:/name#privacy.simplex" + + describe "CTLink (connection link) round-trips" $ do + it "parses simplex:/contact#… as CTLink and round-trips" $ do + let s = strEncode (ACL SCMContact (CLFull contactConnRequest)) + decodesSuccessfully s + s `encodesAs` s + it "parses simplex:/invitation#… as CTLink" $ do + let s = strEncode (ACL SCMInvitation (CLFull invConnRequest)) + decodesSuccessfully s + + describe "rejects ambiguous bare input at this layer" $ do + it "rejects bare 'alice' — no @, no #, no simplex:/name prefix" $ + strDecode @ConnectTarget "alice" `shouldSatisfy` isLeft + it "rejects empty input" $ + strDecode @ConnectTarget "" `shouldSatisfy` isLeft + it "rejects whitespace input" $ + strDecode @ConnectTarget " " `shouldSatisfy` isLeft + + describe "JSON shape mirrors AConnectionLink (plain string, not tagged sum)" $ do + it "encodes @alice.simplex as a JSON string" $ + case strDecode @ConnectTarget "@alice.simplex" of + Right ct -> J.toJSON ct `shouldBe` J.String "simplex:/name@alice.simplex" + Left e -> expectationFailure $ "strDecode failed: " <> e + it "encodes a CTLink as the canonical link JSON string" $ do + let s = strEncode (ACL SCMContact (CLFull contactConnRequest)) + case strDecode @ConnectTarget s of + Right ct -> J.toJSON ct `shouldBe` J.String (decodeUtf8 s) + Left e -> expectationFailure $ "strDecode failed: " <> e + it "parses JSON string back to ConnectTarget" $ + J.eitherDecode @ConnectTarget "\"@alice.simplex\"" + `shouldSatisfy` either (const False) (const True) + where + encodesAs input canonical = + (strEncode <$> strDecode @ConnectTarget input) `shouldBe` Right canonical + decodesSuccessfully s = + strDecode @ConnectTarget s `shouldSatisfy` either (const False) (const True) diff --git a/tests/RSLVTests.hs b/tests/RSLVTests.hs new file mode 100644 index 0000000000..b2776aa8c6 --- /dev/null +++ b/tests/RSLVTests.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-} + +-- | Functional-API tests for the public-namespace resolver (RSLV). +-- +-- Mocks the resolver at the `resolverCall` layer: tests set a stub via +-- `ServerConfig.namesResolverCall_` (no real HTTP, no startup probe). +-- Tests: +-- * direct RSLV reaches the resolver (not `CMD PROHIBITED`) +-- * `ERR (NAME NO_NAME)` for backend not-found (404 / 400) +-- * `ERR (NAME (RESOLVER ..))` for backend transport errors (HTTP 502) +-- * `ERR (NAME NO_RESOLVER)` when the server has no `namesEnv` (names off) +-- * `RNAME` returned when the resolver returns a valid JSON record +-- * the same paths via PFWD round-trip (proxy + resolver wiring works) +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 Data.List.NonEmpty (NonEmpty (..)) +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import Data.Time.Clock (getCurrentTime) +import SMPClient +import Simplex.Messaging.Client +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Encoding.String (strDecode) +import SMPNamesTests (sampleRecord, sampleRecordJSON) +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.Server.Env.STM (AStoreType (..), ServerConfig (..), ServerStoreCfg (..), StorePaths (..)) +import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) +import Simplex.Messaging.Server.Names + ( NamesConfig (..), + ResolverCall, + ResolverCallKind (..), + ) +import Simplex.Messaging.Server.Names.HttpResolver (ResolverError (..)) +import Simplex.Messaging.SimplexName (SimplexNameDomain) +import Simplex.Messaging.Transport +import Simplex.Messaging.Version (mkVersionRange) +import Test.Hspec hiding (fit, it) +import Util (it) + +-- --------------------------------------------------------------------------- +-- Fixtures +-- --------------------------------------------------------------------------- + +-- | Build a validated SimplexNameDomain from a name string (the RSLV command +-- only carries a parsed domain; invalid names cannot be constructed here - +-- that rejection is tested at the SimplexName parse level). +domain :: Text -> SimplexNameDomain +domain = either error id . strDecode . encodeUtf8 + +stubNamesConfig :: NamesConfig +stubNamesConfig = + NamesConfig + { resolverEndpoint = "http://stub", + resolverAuth = Nothing, + resolverTimeoutMs = 1000, + resolverMaxResponseBytes = 65536 + } + +-- | Default stub: the resolver replies 404. Server maps to NAME NO_NAME. +stubResolverNotFound :: ResolverCall +stubResolverNotFound = \case + ResolverFetch _ -> pure (Left (HttpStatusErr 404)) + ResolverHealth -> pure (Right (J.object [])) + +-- | Stub that returns a 502 upstream failure on resolve. Server maps to +-- NAME (RESOLVER "HTTP 502"). +stubResolverHttpErr :: ResolverCall +stubResolverHttpErr = \case + ResolverFetch _ -> pure (Left (HttpStatusErr 502)) + ResolverHealth -> pure (Right (J.object [])) + +-- | Stub returning a real NameRecord JSON value (success path). +stubResolverSuccess :: ResolverCall +stubResolverSuccess = \case + ResolverFetch _ -> pure (Right sampleRecordJSON) + ResolverHealth -> pure (Right (J.object [])) + +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 + +-- | Enable names on a config with a stub resolver (no real HTTP, no probe). +withNames :: ResolverCall -> AServerConfig -> AServerConfig +withNames stub c = updateCfg c $ \cfg_ -> cfg_ {namesConfig = Just stubNamesConfig, namesResolverCall_ = Just stub} + +withResolverServer :: ResolverCall -> IO a -> IO a +withResolverServer stub = withSmpServerConfigOn (transport @TLS) (withNames stub memCfg) testPort . const + +withProxyAndResolver :: ResolverCall -> IO a -> IO a +withProxyAndResolver stub runTest = + withSmpServerConfigOn (transport @TLS) memProxyCfg testPort $ \_ -> + withSmpServerConfigOn (transport @TLS) (withNames stub 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 + +-- --------------------------------------------------------------------------- +-- Tests +-- --------------------------------------------------------------------------- + +rslvTests :: Spec +rslvTests = do + describe "RSLV direct (non-forwarded)" $ do + it "resolver replies 404 -> NAME NO_NAME (reached, not CMD PROHIBITED)" testRslvBackendNotFound + it "resolver replies 502 -> NAME (RESOLVER ..)" testRslvBackendHttpErr + it "no names config -> NAME NO_RESOLVER" testRslvDisabled + describe "RSLV forwarded (PFWD)" $ do + it "PFWD-wrapped RSLV reaches resolver via proxy (PCEProtocolError (NAME NO_NAME))" testRslvForwarded + describe "RSLV success path (RNAME response)" $ do + it "returns RNAME with NameRecord" testRslvSuccess + +testRslvBackendNotFound :: IO () +testRslvBackendNotFound = + withResolverServer stubResolverNotFound $ + testSMPClient @TLS $ \h -> do + (corrId, _entId, resp) <- sendRslv h "rs01" (domain "ghost.simplex") + corrId `shouldBe` CorrId "rs01" + resp `shouldBe` Right (ERR (NAME NO_NAME)) + +testRslvBackendHttpErr :: IO () +testRslvBackendHttpErr = + withResolverServer stubResolverHttpErr $ + 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)) + +testRslvForwarded :: IO () +testRslvForwarded = + withProxyAndResolver stubResolverNotFound $ 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) + r <- runExceptT (proxyResolveName pc NRMInteractive sess (domain "alice.simplex")) + case r of + Left (PCEProtocolError (SMP.NAME SMP.NO_NAME)) -> pure () + _ -> expectationFailure $ "expected Left (PCEProtocolError (NAME NO_NAME)), got: " <> show r + +testRslvSuccess :: IO () +testRslvSuccess = + withResolverServer stubResolverSuccess $ + 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` sampleRecord + _ -> expectationFailure $ "expected Right (RNAME ..), got: " <> show resp + +runExceptT' :: Show e => ExceptT e IO a -> IO a +runExceptT' a = runExceptT a >>= either (fail . show) pure diff --git a/tests/SMPAgentClient.hs b/tests/SMPAgentClient.hs index 41aab20399..7f3ebb14d7 100644 --- a/tests/SMPAgentClient.hs +++ b/tests/SMPAgentClient.hs @@ -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 diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index d043fd3c86..bf4dcd45b1 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -278,6 +278,8 @@ cfgMS msType = withStoreCfg (testServerStoreConfig msType) $ \serverStoreCfg -> smpAgentCfg = defaultSMPClientAgentConfig {persistErrorInterval = 1}, -- seconds allowSMPProxy = False, serverClientConcurrency = 2, + namesConfig = Nothing, + namesResolverCall_ = Nothing, information = Nothing, startOptions = defaultStartOptions } diff --git a/tests/SMPNamesTests.hs b/tests/SMPNamesTests.hs new file mode 100644 index 0000000000..0b3cfac5e8 --- /dev/null +++ b/tests/SMPNamesTests.hs @@ -0,0 +1,303 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module SMPNamesTests (smpNamesTests, sampleRecord, sampleRecordJSON) 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 (atomicModifyIORef', newIORef, readIORef) +import Data.List (sort) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Simplex.Messaging.Encoding (smpDecode, smpEncode) +import Simplex.Messaging.Encoding.String (strDecode) +import Simplex.Messaging.Names.EthAddress (EthAddress, mkEthAddress, unEthAddress) +import Simplex.Messaging.Protocol (ErrorType (..), NameErrorType (..), NameRecord (..)) +import Simplex.Messaging.Server.Main (validateUrl) +import Simplex.Messaging.Server.Names + ( NamesConfig (..), + ResolverCallKind (..), + RpcAuth (..), + newNamesEnvWith, + pingEndpoint, + resolveName, + ) +import Simplex.Messaging.Server.Names.HttpResolver (ResolverError (..)) +import Simplex.Messaging.SimplexName (SimplexNameDomain (..), SimplexTLD (..)) +import Test.Hspec + +twentyOnes :: B.ByteString +twentyOnes = B.replicate 20 '\x01' + +unsafeAddr :: B.ByteString -> EthAddress +unsafeAddr = either error id . mkEthAddress + +-- | Sample record matching the resolver JSON shape. Text fields use the empty +-- string as the "unset" sentinel; coin fields use Nothing -> JSON null. +sampleRecord :: NameRecord +sampleRecord = + 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 = unsafeAddr twentyOnes, + nrResolver = unsafeAddr (B.replicate 20 '\x02') + } + +-- | JSON value canned by the resolver-stub for the "success" tests. +sampleRecordJSON :: J.Value +sampleRecordJSON = J.toJSON sampleRecord + +testNamesConfig :: NamesConfig +testNamesConfig = + NamesConfig + { resolverEndpoint = "http://stub", + resolverAuth = Nothing, + resolverTimeoutMs = 1000, + resolverMaxResponseBytes = 65536 + } + +smpNamesTests :: Spec +smpNamesTests = do + describe "NameRecord JSON (Protocol)" nameRecordEncodingSpec + describe "Wire encoding (smpEncode)" wireEncodingSpec + describe "Smart constructors (EthAddress)" smartCtorsSpec + 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 sampleRecord)) `shouldBe` Right sampleRecord + + it "emits keys in spec-documented order (resolver shape)" $ do + let bytes = LB.toStrict (J.encode sampleRecord) + 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 sampleRecord) + 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 sampleRecord) + B.isInfixOf "\"simplexChannel\":[]" bytes `shouldBe` True + B.isInfixOf "\"simplexChannel\":null" bytes `shouldBe` False + + it "FromJSON EthAddress accepts both 0x and 0X prefixes" $ do + let json p = "\"" <> p <> "0101010101010101010101010101010101010101\"" + (J.eitherDecodeStrict (json "0x") :: Either String EthAddress) `shouldSatisfy` isRight + (J.eitherDecodeStrict (json "0X") :: Either String EthAddress) `shouldSatisfy` isRight + + it "owner / resolver are emitted as lowercase hex" $ do + -- The resolver returns lowercase hex; encoded form must match. + let mixedCase = unsafeAddr (B.pack ['\xde', '\xad', '\xbe', '\xef'] <> B.replicate 16 '\x00') + bytes = LB.toStrict (J.encode sampleRecord {nrOwner = mixedCase, nrResolver = mixedCase}) + B.isInfixOf "0xdeadbeef" bytes `shouldBe` True + B.isInfixOf "0xDEADBEEF" bytes `shouldBe` False + +-- The RNAME response and ERR (NAME ...) travel as field-ordered smpEncode on +-- the wire (no JSON), so round-trip the new Encoding instances directly. +wireEncodingSpec :: Spec +wireEncodingSpec = do + it "NameRecord round-trips smpEncode / smpDecode" $ + smpDecode (smpEncode sampleRecord) `shouldBe` Right sampleRecord + + it "NameRecord round-trips with multiple links and unset coins" $ do + let r = + sampleRecord + { nrSimplexContact = ["simplex:/contact/a#1", "simplex:/contact/b#2"], + nrSimplexChannel = [], + nrEth = Nothing, + nrBtc = Nothing + } + smpDecode (smpEncode r) `shouldBe` Right r + + it "ErrorType NAME family round-trips smpEncode / smpDecode" $ do + smpDecode (smpEncode (NAME NO_RESOLVER)) `shouldBe` Right (NAME NO_RESOLVER) + smpDecode (smpEncode (NAME NO_NAME)) `shouldBe` Right (NAME NO_NAME) + -- RESOLVER detail may contain spaces - must survive the round-trip + smpDecode (smpEncode (NAME (RESOLVER "HTTP 502"))) `shouldBe` Right (NAME (RESOLVER "HTTP 502")) + +smartCtorsSpec :: Spec +smartCtorsSpec = do + it "mkEthAddress accepts exactly 20 bytes" $ do + mkEthAddress twentyOnes `shouldSatisfy` isRight + mkEthAddress (B.replicate 19 '\x01') `shouldSatisfy` isLeft + mkEthAddress (B.replicate 21 '\x01') `shouldSatisfy` isLeft + + it "unEthAddress round-trips mkEthAddress" $ + case mkEthAddress twentyOnes of + Right o -> unEthAddress o `shouldBe` twentyOnes + Left e -> expectationFailure ("mkEthAddress failed: " <> e) + +-- The RSLV command carries a parsed SimplexNameDomain, so name validation +-- happens at parse (StrEncoding). These exercise that validation directly. +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 + where + parseN :: T.Text -> Either String SimplexNameDomain + parseN = strDecode . encodeUtf8 + +resolverSpec :: Spec +resolverSpec = do + let mkEnv stub = newNamesEnvWith testNamesConfig stub Nothing + aliceDomain = SimplexNameDomain {nameTLD = TLDSimplex, domain = "alice", subDomain = []} + + it "returns NameRecord on 200 OK" $ do + env <- mkEnv (\_ -> pure (Right sampleRecordJSON)) + r <- resolveName env aliceDomain + r `shouldBe` Right sampleRecord + + it "returns NO_NAME on 404" $ do + env <- mkEnv (\_ -> pure (Left (HttpStatusErr 404))) + resolveName env aliceDomain `shouldReturn` Left NO_NAME + + it "returns NO_NAME on 400 (unknown TLD)" $ do + env <- mkEnv (\_ -> pure (Left (HttpStatusErr 400))) + resolveName env aliceDomain `shouldReturn` Left NO_NAME + + it "returns RESOLVER on 502 (upstream failure)" $ do + env <- mkEnv (\_ -> pure (Left (HttpStatusErr 502))) + resolveName env aliceDomain `shouldReturn` Left (RESOLVER "HTTP 502") + + it "returns RESOLVER on transport-layer body-too-large" $ do + env <- mkEnv (\_ -> pure (Left BodyTooLarge)) + resolveName env aliceDomain `shouldReturn` Left (RESOLVER "response too large") + + it "returns RESOLVER on malformed JSON from the resolver" $ do + env <- mkEnv (\_ -> pure (Left (InvalidJson "expected object"))) + resolveName env aliceDomain `shouldReturn` Left (RESOLVER "invalid response") + + it "returns RESOLVER when JSON parses but isn't a NameRecord shape" $ do + env <- mkEnv (\_ -> pure (Right (J.object []))) + resolveName env aliceDomain `shouldReturn` Left (RESOLVER "invalid response") + + it "sends one HTTP request per lookup (no cache)" $ do + callCount <- newIORef (0 :: Int) + env <- mkEnv $ \_ -> do + atomicModifyIORef' callCount (\v -> (v + 1, ())) + pure (Right sampleRecordJSON) + _ <- resolveName env aliceDomain + _ <- resolveName env aliceDomain + readIORef callCount `shouldReturn` 2 + + it "addresses the resolver with the full canonical domain name" $ do + seenName <- newIORef ("" :: T.Text) + env <- + mkEnv $ \case + ResolverFetch n -> do + atomicModifyIORef' seenName (\_ -> (n, ())) + pure (Right sampleRecordJSON) + ResolverHealth -> pure (Right (J.object [])) + _ <- resolveName env aliceDomain + readIORef seenName `shouldReturn` "alice.simplex" + +healthSpec :: Spec +healthSpec = do + let mkEnv stub = newNamesEnvWith testNamesConfig stub Nothing + + it "pingEndpoint succeeds on a 200 OK /health response" $ do + env <- mkEnv (\_ -> pure (Right (J.object []))) + r <- pingEndpoint env + case r of + Right () -> pure () + Left e -> expectationFailure $ "expected Right (), got Left " <> show e + + it "pingEndpoint fails on a 500 /health response" $ do + env <- mkEnv (\_ -> pure (Left (HttpStatusErr 500))) + r <- pingEndpoint env + case r of + Left (HttpStatusErr 500) -> pure () + _ -> expectationFailure $ "expected Left (HttpStatusErr 500), got " <> show r + + it "pingEndpoint routes to ResolverHealth (not ResolverFetch)" $ do + seenKind <- newIORef Nothing + env <- mkEnv $ \k -> do + atomicModifyIORef' seenKind (\_ -> (Just k, ())) + pure (Right (J.object [])) + _ <- pingEndpoint env + readIORef seenKind `shouldReturn` Just ResolverHealth + +validateUrlSpec :: Spec +validateUrlSpec = do + let auth = Just (AuthBasic "user" "pass") + it "accepts https with explicit port and auth (root path)" $ + validateUrl "https://gw.example.com:443" auth `shouldSatisfy` isRight + it "accepts a path prefix (reverse-proxy sub-path)" $ + validateUrl "https://gw.example.com:443/snrc" auth `shouldSatisfy` isRight + it "accepts a path prefix with trailing slash" $ + validateUrl "https://gw.example.com:443/snrc/" auth `shouldSatisfy` isRight + it "rejects a query string" $ + validateUrl "https://gw.example.com:443/snrc?x=1" auth `shouldSatisfy` isLeft + it "rejects a fragment" $ + validateUrl "https://gw.example.com:443/snrc#f" auth `shouldSatisfy` isLeft + it "rejects userinfo (credentials belong in resolver_auth)" $ + validateUrl "https://user:pass@gw.example.com:443" auth `shouldSatisfy` isLeft + it "rejects a missing port" $ + validateUrl "https://gw.example.com/snrc" auth `shouldSatisfy` isLeft + it "accepts https on a non-loopback host without auth (public resolver)" $ + validateUrl "https://gw.example.com:443/snrc" Nothing `shouldSatisfy` isRight + it "accepts http without auth on a non-loopback host (e.g. host.docker.internal)" $ + validateUrl "http://host.docker.internal:9999" Nothing `shouldSatisfy` isRight + it "rejects http WITH auth on a non-loopback host (cleartext credential leak)" $ + validateUrl "http://gw.example.com:9999" auth `shouldSatisfy` isLeft + it "allows loopback http without auth (with a path prefix)" $ + validateUrl "http://localhost:8000/snrc" Nothing `shouldSatisfy` isRight diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 7f342f6ae3..a418cd01dd 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -1100,7 +1100,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 @@ -1116,7 +1116,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 @@ -1134,7 +1134,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 diff --git a/tests/Test.hs b/tests/Test.hs index ae6df6e780..22cc8c03ce 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -8,6 +8,7 @@ import Control.Concurrent (threadDelay) import qualified Control.Exception as E import Control.Logger.Simple import CoreTests.BatchingTests +import CoreTests.ConnectTargetTests import CoreTests.CryptoFileTests import CoreTests.CryptoTests import CoreTests.EncodingTests @@ -21,7 +22,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 (..)) @@ -82,6 +85,7 @@ main = do $ do describe "Core tests" $ do describe "Batching tests" batchingTests + describe "ConnectTarget tests" connectTargetTests describe "Encoding tests" encodingTests describe "Version range" versionRangeTests describe "Encryption tests" cryptoTests @@ -97,6 +101,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) $