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..86fdb44912 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 JSON-RPC calls to an Ethereum endpoint to read `NameRecord` data; the lookup key reaches that endpoint. Operators MUST run the endpoint themselves (loopback Reth + Nimbus, or a self-hosted central deployment) — sharing one endpoint across multiple operators collapses the two-server privacy property because the endpoint 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,95 @@ 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 queries the SNRC contract +on Ethereum via a JSON-RPC endpoint; alternative backings (different chains, +DHT, etc.) are valid as long as they return 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 — the SNRC contract address 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), extracts the TLD, and looks +up the expected SNRC contract address in its INI whitelist +(`registry_tld_simplex`, `registry_tld_testing`, `registry_tld_all`). +`registry_tld_all` is the catch-all used when no TLD-specific entry matches +the requested TLD (and the only entry that can resolve web domains). If no +whitelist entry matches the TLD, or if the client-supplied `contract` differs +from the configured address, the server replies with `ERR AUTH` without +contacting the chain. This lets one names router safely host multiple TLDs +(each backed by its own SNRC contract) and reject clients pointing at a +contract the operator doesn't run. + +The names router responds with either a `NAME` response carrying the resolved +record, or `ERR AUTH` collapsing every failure mode (name not found, malformed +name, TLD not in whitelist, contract mismatch, names role disabled, RPC +unreachable, decode error, timeout). The wire code does not distinguish +between these — stats counters MAY be exposed out-of-band for operator +observability (`bad_name` is incremented for validation/whitelist failures, +distinct from `not_found` for valid lookups with no on-chain 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 | +|---|---|---| +| `displayName` | string | ≤ 255 bytes UTF-8 | +| `owner` | string | `"0x"` followed by 40 lowercase hex characters (20 raw bytes) | +| `channelLinks` | array of strings | each ≤ 1024 bytes UTF-8; combined count of `channelLinks + contactLinks` ≤ 8 | +| `contactLinks` | array of strings | each ≤ 1024 bytes UTF-8; combined count cap shared with `channelLinks` | +| `adminAddress` | string or null | ≤ 255 bytes UTF-8; senders MUST emit `null` when unset; receivers MUST also accept absent keys as unset | +| `adminEmail` | string or null | ≤ 255 bytes UTF-8; senders MUST emit `null` when unset; receivers MUST also accept absent keys as unset | +| `expiry` | integer | Int64 Unix seconds, MUST be ≥ 0; `0` means "never expires" | +| `isTest` | boolean | true on testnet deployments | + +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` (8 × 1024-byte links plus +maximal admin / display strings) JSON-encodes to roughly 9 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..08c8b96252 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -141,6 +141,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 +262,9 @@ 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.Eth.RPC + Simplex.Messaging.Server.Names.Eth.SNRC Simplex.Messaging.Server.NtfStore Simplex.Messaging.Server.Prometheus Simplex.Messaging.Server.QueueStore @@ -355,7 +359,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.* @@ -508,6 +515,7 @@ test-suite simplexmq-test ServerTests SMPAgentClient SMPClient + SMPNamesTests SMPProxyTests Util XFTPAgent diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 36c72de0e7..f518c7b0d8 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -123,6 +123,7 @@ module Simplex.Messaging.Agent.Protocol ConnectionLink (..), AConnectionLink (..), SimplexNameInfo (..), + SimplexNameDomain (..), SimplexTLD (..), SimplexNameType (..), ConnShortLink (..), @@ -236,6 +237,7 @@ import Simplex.Messaging.Crypto.Ratchet ) import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String +import Simplex.Messaging.SimplexName (SimplexNameDomain (..), SimplexNameInfo (..), SimplexNameType (..), SimplexTLD (..), fullDomainName, shortNameInfoStr) import Simplex.Messaging.Parsers import Simplex.Messaging.Protocol ( AProtocolType, @@ -1530,61 +1532,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, - 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 - -instance StrEncoding SimplexNameInfo where - strEncode info = "simplex:/name" <> strEncode (nameType info) <> encodeUtf8 (fullDomainName info) - strP = optional "simplex:/name" *> (strP >>= nameP) <|> nameP NTPublicGroup - where - nameP nt = parseName nt . safeDecodeUtf8 <$?> A.takeWhile1 (not . A.isSpace) - parseName nt s = AT.parseOnly (nameLabelP `AT.sepBy1` AT.char '.' <* AT.endOfInput) s >>= mkNameInfo nt - nameLabelP = T.intercalate "-" <$> AT.takeWhile1 (\c -> isNameLetter c || isDigit c) `AT.sepBy1` AT.char '-' - isNameLetter c = isAlpha c && not (c >= '\x00c0' && c <= '\x024f') - mkNameInfo nt labels = case reverse labels of - [] -> Left "empty name" - [name] - | nt == NTPublicGroup -> Right $ SimplexNameInfo nt TLDSimplex name [] - | otherwise -> Left "contact name requires TLD" - tld : name : sub -> Right $ case tld of - "simplex" -> SimplexNameInfo nt TLDSimplex name sub - "testing" -> SimplexNameInfo nt TLDTesting name sub - _ -> SimplexNameInfo nt TLDWeb (T.intercalate "." labels) [] - -fullDomainName :: SimplexNameInfo -> Text -fullDomainName SimplexNameInfo {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, nameTLD = TLDSimplex, domain, subDomain = []} -> "#" <> domain - info -> pfx <> fullDomainName info - where - pfx = case nameType info of - NTPublicGroup -> "#" - NTContact -> "@" - data AConnShortLink = forall m. ConnectionModeI m => ACSL (SConnectionMode m) (ConnShortLink m) instance Eq AConnShortLink where @@ -2263,8 +2210,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 ''SimplexNameInfo) diff --git a/src/Simplex/Messaging/Encoding.hs b/src/Simplex/Messaging/Encoding.hs index d069e5518a..b5b51ab900 100644 --- a/src/Simplex/Messaging/Encoding.hs +++ b/src/Simplex/Messaging/Encoding.hs @@ -15,6 +15,7 @@ module Simplex.Messaging.Encoding smpEncodeList, smpListP, lenEncode, + lenP, ) where diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index fa58d88439..197b1fc96b 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -163,6 +163,14 @@ module Simplex.Messaging.Protocol EncTransmission (..), FwdResponse (..), FwdTransmission (..), + RslvRequest (..), + NameRecord (..), + NameOwner, + mkNameOwner, + unNameOwner, + NameLink, + mkNameLink, + unNameLink, MsgFlags (..), initialSMPClientVersion, currentSMPClientVersion, @@ -225,6 +233,7 @@ where import Control.Applicative (optional, (<|>)) import Control.Exception (Exception, SomeException, displayException, fromException) +import Control.Monad (when) import Control.Monad.Except import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson as J @@ -237,6 +246,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as B64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import qualified Data.ByteArray.Encoding as BAE import qualified Data.ByteString.Lazy as LB import Data.Char (isPrint, isSpace) import Data.Constraint (Dict (..)) @@ -246,11 +256,11 @@ import Data.Kind import Data.List (foldl') import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L -import Data.Maybe (isJust, isNothing) +import Data.Maybe (fromMaybe, isJust, isNothing) import Data.String import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Encoding (decodeLatin1, encodeUtf8) +import Data.Text.Encoding (decodeLatin1, decodeUtf8', encodeUtf8) import Data.Time.Clock.System (SystemTime (..), systemToUTCTime) import Data.Type.Equality import Data.Word (Word8, Word16) @@ -343,6 +353,7 @@ data Party | LinkClient | ProxiedClient | ProxyService + | Resolver deriving (Show) -- | Singleton types for SMP protocol clients @@ -357,6 +368,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 +381,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 +408,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 +488,7 @@ partyClientRole = \case SSenderLink -> Just SRMessaging SProxiedClient -> Just SRMessaging SProxyService -> Just SRProxy + SResolver -> Nothing {-# INLINE partyClientRole #-} partyServiceRole :: ServiceParty p => SParty p -> SMPServiceRole @@ -550,6 +566,18 @@ type LinkId = QueueId -- | SMP queue ID on the server. type QueueId = EntityId +-- | Name resolution request. The client sends the canonical SimplexNameDomain +-- (TLD always explicit) plus the SNRC contract address it expects the server +-- to query. The server parses the domain (validating syntax) and checks the +-- supplied contract against its INI whitelist before reading the chain — so a +-- single names router can safely host multiple TLDs (each backed by its own +-- SNRC contract) and reject clients that ask for the wrong one. +data RslvRequest = RslvRequest + { name :: Text, + contract :: NameOwner + } + deriving (Eq, Show) + -- | Parameterized type for SMP protocol commands from all clients. data Command (p :: Party) where -- SMP recipient commands @@ -597,6 +625,8 @@ data Command (p :: Party) where -- - entity ID: empty -- - corrId: unique correlation ID between proxy and relay, also used as a nonce to encrypt forwarded transmission RFWD :: EncFwdTransmission -> Command ProxyService -- use CorrId as CbNonce, proxy to relay + -- Name resolution: forwarded-only via PFWD. Server reads SNRC contract via Ethereum JSON-RPC. + RSLV :: RslvRequest -> Command Resolver deriving instance Show (Command p) @@ -705,6 +735,107 @@ instance Encoding FwdTransmission where newtype EncFwdTransmission = EncFwdTransmission ByteString deriving (Show) +-- | 20-byte Ethereum address (NameRecord owner). Bare constructor not exported; +-- use `mkNameOwner` to enforce the 20-byte invariant. +newtype NameOwner = NameOwner ByteString + deriving (Eq, Show) + +mkNameOwner :: ByteString -> Either String NameOwner +mkNameOwner bs + | B.length bs == 20 = Right (NameOwner bs) + | otherwise = Left "NameOwner must be 20 bytes" + +unNameOwner :: NameOwner -> ByteString +unNameOwner (NameOwner bs) = bs +{-# INLINE unNameOwner #-} + +instance J.ToJSON NameOwner where + toJSON (NameOwner bs) = J.String $ "0x" <> decodeLatin1 (BAE.convertToBase BAE.Base16 bs) + +instance J.FromJSON NameOwner where + parseJSON = J.withText "NameOwner" $ \t -> do + -- Accept "0x" and "0X" prefixes (matches Server/Main.hs:parseEthAddr via fromHex). + let hex = fromMaybe t (T.stripPrefix "0x" t <|> T.stripPrefix "0X" t) + case BAE.convertFromBase BAE.Base16 (encodeUtf8 hex) of + Left e -> fail e + Right bs -> either fail pure (mkNameOwner bs) + +instance J.ToJSON RslvRequest where + toJSON RslvRequest {name, contract} = J.object ["name" J..= name, "contract" J..= contract] + toEncoding RslvRequest {name, contract} = J.pairs ("name" J..= name <> "contract" J..= contract) + +instance J.FromJSON RslvRequest where + parseJSON = J.withObject "RslvRequest" $ \o -> do + name <- o J..: "name" + contract <- o J..: "contract" + pure RslvRequest {name, contract} + +-- | A name-record link (channel or contact). Bare constructor not exported; +-- use `mkNameLink` to enforce the ≤1024-byte UTF-8 invariant. +newtype NameLink = NameLink Text + deriving (Eq, Show) + +mkNameLink :: Text -> Either String NameLink +mkNameLink t + | B.length (encodeUtf8 t) <= 1024 = Right (NameLink t) + | otherwise = Left "NameLink too long" + +unNameLink :: NameLink -> Text +unNameLink (NameLink t) = t +{-# INLINE unNameLink #-} + +instance J.ToJSON NameLink where + toJSON (NameLink t) = J.toJSON t + +instance J.FromJSON NameLink where + parseJSON = J.withText "NameLink" (either fail pure . mkNameLink) + +-- | Resolved name record returned by the names role. +-- Wire format is JSON — change requires an SMP version bump. +data NameRecord = NameRecord + { nrDisplayName :: Text, + nrOwner :: NameOwner, + nrChannelLinks :: [NameLink], + nrContactLinks :: [NameLink], + nrAdminAddress :: Maybe Text, + nrAdminEmail :: Maybe Text, + nrExpiry :: Int64, -- Unix seconds, ≥ 0 + nrIsTest :: Bool + } + deriving (Eq, Show) + +instance J.ToJSON NameRecord where + toJSON NameRecord {nrDisplayName, nrOwner, nrChannelLinks, nrContactLinks, nrAdminAddress, nrAdminEmail, nrExpiry, nrIsTest} = + J.object + [ "displayName" J..= nrDisplayName, + "owner" J..= nrOwner, + "channelLinks" J..= nrChannelLinks, + "contactLinks" J..= nrContactLinks, + "adminAddress" J..= nrAdminAddress, + "adminEmail" J..= nrAdminEmail, + "expiry" J..= nrExpiry, + "isTest" J..= nrIsTest + ] + +instance J.FromJSON NameRecord where + parseJSON = J.withObject "NameRecord" $ \o -> do + nrDisplayName <- o J..: "displayName" >>= capUtf8 "displayName" 255 + nrOwner <- o J..: "owner" + nrChannelLinks <- o J..: "channelLinks" + nrContactLinks <- o J..: "contactLinks" + when (length nrChannelLinks + length nrContactLinks > 8) $ + fail "combined channelLinks + contactLinks > 8" + nrAdminAddress <- o J..:? "adminAddress" >>= traverse (capUtf8 "adminAddress" 255) + nrAdminEmail <- o J..:? "adminEmail" >>= traverse (capUtf8 "adminEmail" 255) + nrExpiry <- o J..: "expiry" + when (nrExpiry < 0) $ fail "expiry must be non-negative" + nrIsTest <- o J..: "isTest" + pure NameRecord {nrDisplayName, nrOwner, nrChannelLinks, nrContactLinks, nrAdminAddress, nrAdminEmail, nrExpiry, nrIsTest} + where + capUtf8 fld lim t + | B.length (encodeUtf8 t) <= lim = pure t + | otherwise = fail $ fld <> " exceeds " <> show lim <> " bytes UTF-8" + data BrokerMsg where -- SMP broker messages (responses, client messages, notifications) IDS :: QueueIdsKeys -> BrokerMsg @@ -732,6 +863,8 @@ data BrokerMsg where OK :: BrokerMsg ERR :: ErrorType -> BrokerMsg PONG :: BrokerMsg + -- Name resolution response. Returned only for forwarded RSLV. + NAME :: NameRecord -> BrokerMsg deriving (Eq, Show) data RcvMessage = RcvMessage @@ -942,6 +1075,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 +1102,7 @@ data BrokerMsgTag | OK_ | ERR_ | PONG_ + | NAME_ deriving (Show) class ProtocolMsgTag t where @@ -1004,6 +1139,7 @@ instance PartyI p => Encoding (CommandTag p) where RFWD_ -> "RFWD" NSUB_ -> "NSUB" NSUBS_ -> "NSUBS" + RSLV_ -> "RSLV" smpP = messageTagP instance ProtocolMsgTag CmdTag where @@ -1032,6 +1168,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 +1198,7 @@ instance Encoding BrokerMsgTag where OK_ -> "OK" ERR_ -> "ERR" PONG_ -> "PONG" + NAME_ -> "NAME" smpP = messageTagP instance ProtocolMsgTag BrokerMsgTag where @@ -1083,6 +1221,7 @@ instance ProtocolMsgTag BrokerMsgTag where "OK" -> Just OK_ "ERR" -> Just ERR_ "PONG" -> Just PONG_ + "NAME" -> Just NAME_ _ -> Nothing -- | SMP message body format @@ -1792,6 +1931,9 @@ instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where PRXY host auth_ -> e (PRXY_, ' ', host, auth_) PFWD fwdV pubKey (EncTransmission s) -> e (PFWD_, ' ', fwdV, pubKey, Tail s) RFWD (EncFwdTransmission s) -> e (RFWD_, ' ', Tail s) + RSLV req + | v >= namesSMPVersion -> e (RSLV_, ' ', Tail (LB.toStrict (J.encode req))) + | otherwise -> e (ERR_, ' ', AUTH) -- pre-v20: shouldn't reach here, degrade to AUTH where e :: Encoding a => a -> ByteString e = smpEncode @@ -1816,6 +1958,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 +2042,11 @@ instance ProtocolEncoding SMPVersion ErrorType Cmd where CT SNotifierService NSUBS_ | v >= rcvServiceSMPVersion -> Cmd SNotifierService <$> (NSUBS <$> _smpP <*> smpP) | otherwise -> pure $ Cmd SNotifierService $ NSUBS (-1) mempty + CT SResolver RSLV_ + | v >= namesSMPVersion -> do + Tail bs <- _smpP + either fail (pure . Cmd SResolver . RSLV) (J.eitherDecodeStrict bs) + | otherwise -> fail "RSLV requires namesSMPVersion" fromProtocolError = fromProtocolError @SMPVersion @ErrorType @BrokerMsg {-# INLINE fromProtocolError #-} @@ -1945,6 +2093,9 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where | v < clientNoticesSMPVersion -> BLOCKED info {notice = Nothing} _ -> err PONG -> e PONG_ + NAME rec + | v >= namesSMPVersion -> e (NAME_, ' ', Tail (LB.toStrict (J.encode rec))) + | otherwise -> e (ERR_, ' ', AUTH) -- pre-v20: shouldn't reach here, degrade to AUTH where e :: Encoding a => a -> ByteString e = smpEncode @@ -1992,6 +2143,11 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where OK_ -> pure OK ERR_ -> ERR <$> _smpP PONG_ -> pure PONG + NAME_ + | v >= namesSMPVersion -> do + Tail bs <- _smpP + either fail (pure . NAME) (J.eitherDecodeStrict bs) + | otherwise -> fail "NAME requires namesSMPVersion" where serviceRespP resp | v >= rcvServiceSMPVersion = resp <$> _smpP <*> smpP @@ -2014,6 +2170,7 @@ instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where PKEY {} -> noEntityMsg RRES _ -> noEntityMsg ALLS -> noEntityMsg + NAME _ -> noEntityMsg -- other broker responses must have queue ID _ | B.null entId -> Left $ CMD NO_ENTITY diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index 1b7d920ac5..6fa7bf611b 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 (ResolveError (..), closeNamesEnv, resolveName, verifyRslv) import Simplex.Messaging.Server.MsgStore.STM import Simplex.Messaging.Server.MsgStore.Types import Simplex.Messaging.Server.NtfStore @@ -245,7 +246,9 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt saveServerStats closeServer :: M s () - closeServer = asks (smpAgent . proxyAgent) >>= liftIO . closeSMPClientAgent + closeServer = do + asks (smpAgent . proxyAgent) >>= liftIO . closeSMPClientAgent + asks namesEnv >>= liftIO . mapM_ closeNamesEnv serverThread :: forall sub. String -> @@ -513,7 +516,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 +579,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 +653,7 @@ smpServer started cfg@ServerConfig {transports, transportConfig = tCfg, startOpt ] <> showServiceStats rcvServices' <> showServiceStats ntfServices' + <> showNameResolverStats rslvStats' ) liftIO $ threadDelay' interval where @@ -656,6 +661,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, _rslvBadName, _rslvEthErrs, _rslvDisabled} = + map tshow [_rslvReqs, _rslvSucc, _rslvNotFound, _rslvBadName, _rslvEthErrs, _rslvDisabled] prometheusMetricsThread_ :: ServerConfig s -> [M s ()] prometheusMetricsThread_ ServerConfig {prometheusInterval = Just interval, prometheusMetricsFile} = @@ -1149,8 +1156,8 @@ receive h@THandle {params = THandleParams {thAuth, sessionId}} ms Client {rcvQ, updateBatchStats stats cmd -- even if nothing is verified let queueId (_, _, (_, qId, _)) = qId qs <- getQueueRecs ms p $ map queueId ts' - zipWithM (\t -> verified stats t . verifyLoadedQueue service thAuth t) ts' qs - _ -> mapM (\t -> verified stats t =<< verifyTransmission ms service thAuth t) ts' + zipWithM (\t -> verified stats t . verifyLoadedQueue False service thAuth t) ts' qs + _ -> mapM (\t -> verified stats t =<< verifyTransmission False ms service thAuth t) ts' mapM_ (atomically . writeTBQueue rcvQ) $ L.nonEmpty cmds pure $ errs ++ errs' [] -> pure errs @@ -1230,19 +1237,19 @@ data VerificationResult s = VRVerified (Maybe (StoreQueue s, QueueRec)) | VRFail -- - the queue or party key do not exist. -- In all cases, the time of the verification should depend only on the provided authorization type, -- a dummy key is used to run verification in the last two cases, and failure is returned irrespective of the result. -verifyTransmission :: forall s. MsgStoreClass s => s -> Maybe THPeerClientService -> Maybe (THandleAuth 'TServer) -> SignedTransmission Cmd -> IO (VerificationResult s) -verifyTransmission ms service thAuth t@(_, _, (_, queueId, Cmd p _)) = case queueParty p of - Just Dict -> verifyLoadedQueue service thAuth t <$> getQueueRec ms p queueId - Nothing -> pure $ verifyQueueTransmission service thAuth t Nothing - -verifyLoadedQueue :: Maybe THPeerClientService -> Maybe (THandleAuth 'TServer) -> SignedTransmission Cmd -> Either ErrorType (StoreQueue s, QueueRec) -> VerificationResult s -verifyLoadedQueue service thAuth t@(tAuth, authorized, (corrId, _, _)) = \case - Right q -> verifyQueueTransmission service thAuth t (Just q) +verifyTransmission :: forall s. MsgStoreClass s => Bool -> s -> Maybe THPeerClientService -> Maybe (THandleAuth 'TServer) -> SignedTransmission Cmd -> IO (VerificationResult s) +verifyTransmission forwarded ms service thAuth t@(_, _, (_, queueId, Cmd p _)) = case queueParty p of + Just Dict -> verifyLoadedQueue forwarded service thAuth t <$> getQueueRec ms p queueId + Nothing -> pure $ verifyQueueTransmission forwarded service thAuth t Nothing + +verifyLoadedQueue :: Bool -> Maybe THPeerClientService -> Maybe (THandleAuth 'TServer) -> SignedTransmission Cmd -> Either ErrorType (StoreQueue s, QueueRec) -> VerificationResult s +verifyLoadedQueue forwarded service thAuth t@(tAuth, authorized, (corrId, _, _)) = \case + Right q -> verifyQueueTransmission forwarded service thAuth t (Just q) Left AUTH -> dummyVerifyCmd thAuth tAuth authorized corrId `seq` VRFailed AUTH Left e -> VRFailed e -verifyQueueTransmission :: forall s. Maybe THPeerClientService -> Maybe (THandleAuth 'TServer) -> SignedTransmission Cmd -> Maybe (StoreQueue s, QueueRec) -> VerificationResult s -verifyQueueTransmission service thAuth (tAuth, authorized, (corrId, entId, command@(Cmd p cmd))) q_ +verifyQueueTransmission :: forall s. Bool -> Maybe THPeerClientService -> Maybe (THandleAuth 'TServer) -> SignedTransmission Cmd -> Maybe (StoreQueue s, QueueRec) -> VerificationResult s +verifyQueueTransmission forwarded service thAuth (tAuth, authorized, (corrId, entId, command@(Cmd p cmd))) q_ | not checkRole = VRFailed $ CMD PROHIBITED | not verifyServiceSig = VRFailed SERVICE | otherwise = vc p cmd @@ -1262,6 +1269,9 @@ verifyQueueTransmission service thAuth (tAuth, authorized, (corrId, entId, comma vc SNotifierService NSUBS {} = verifyServiceCmd vc SProxiedClient _ = VRVerified Nothing vc SProxyService (RFWD _) = VRVerified Nothing + vc SResolver (RSLV _) + | forwarded = VRVerified Nothing + | otherwise = VRFailed $ CMD PROHIBITED checkRole = case (service, partyClientRole p) of (Just THClientService {serviceRole}, Just role) -> serviceRole == role _ -> True @@ -1486,6 +1496,18 @@ 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 req) -> do + st <- asks (rslvStats . serverStats) + incStat (rslvReqs st) + (selector, msg) <- asks namesEnv >>= \case + Nothing -> pure (rslvDisabled, ERR AUTH) + Just nenv -> case verifyRslv nenv req of + Nothing -> pure (rslvBadName, ERR AUTH) + Just (addr, d) -> liftIO (resolveName nenv addr d) <&> \case + Right rec -> (rslvSucc, NAME rec) + Left NotFound -> (rslvNotFound, ERR AUTH) + Left _ -> (rslvEthErrs, ERR AUTH) + 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 @@ -2126,7 +2148,7 @@ client rejectOrVerify clntThAuth = \case Left (corrId', entId', e) -> pure $ Left (corrId', entId', ERR e) Right t'@(_, _, t''@(corrId', entId', cmd')) - | allowed -> liftIO $ verified <$> verifyTransmission ms Nothing clntThAuth t' + | allowed -> liftIO $ verified <$> verifyTransmission True ms Nothing clntThAuth t' | otherwise -> pure $ Left (corrId', entId', ERR $ CMD PROHIBITED) where allowed = case cmd' of @@ -2134,6 +2156,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 +2240,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..a23963b1c4 100644 --- a/src/Simplex/Messaging/Server/Env/STM.hs +++ b/src/Simplex/Messaging/Server/Env/STM.hs @@ -115,6 +115,9 @@ import Simplex.Messaging.Server.Information import Simplex.Messaging.Server.MsgStore.Journal import Simplex.Messaging.Server.MsgStore.STM import Simplex.Messaging.Server.MsgStore.Types +import Simplex.Messaging.Server.Names (NamesConfig (..), NamesEnv, newNamesEnv, pingEndpoint) +import Simplex.Messaging.Server.Names.Eth.RPC (scrubUrl) +import Simplex.Messaging.Util (tshow) import Simplex.Messaging.Server.NtfStore import Simplex.Messaging.Server.QueueStore import Simplex.Messaging.Server.QueueStore.Postgres.Config @@ -197,6 +200,8 @@ 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, -- | server public information information :: Maybe ServerPublicInfo, startOptions :: StartOptions @@ -272,7 +277,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 +564,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} = do serverActive <- newTVarIO True server <- newServer msgStore_ <- case serverStoreCfg of @@ -603,6 +609,20 @@ 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 -> do + logInfo $ "[NAMES] resolver enabled, endpoint=" <> scrubUrl (ethereumEndpoint 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 AUTH until reachable): " <> tshow e + pure (Just env) pure Env { serverActive, @@ -618,7 +638,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..8968cbd342 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -76,6 +76,10 @@ 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 Network.URI (URI (..), URIAuth (..), parseAbsoluteURI) +import Simplex.Messaging.Protocol (mkNameOwner, NameOwner) +import Simplex.Messaging.Server.Names (NamesConfig (..), RpcAuth (..), TldRegistries (..)) +import Simplex.Messaging.Server.Names.Eth.RPC (fromHex) import Simplex.Messaging.Server.QueueStore.Postgres.Config import Simplex.Messaging.Server.StoreLog.ReadWrite (readQueueStore) import Simplex.Messaging.Transport (supportedProxyClientSMPRelayVRange, alpnSupportedSMPHandshakes, supportedServerSMPRelayVRange) @@ -605,6 +609,7 @@ smpServerCLI_ generateSite serveStaticFiles attachStaticFiles cfgPath logPath = }, allowSMPProxy = True, serverClientConcurrency = readIniDefault defaultProxyClientConcurrency "PROXY" "client_concurrency" ini, + namesConfig = readNamesConfig ini, information = serverPublicInfo ini, startOptions } @@ -796,6 +801,97 @@ 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 rpcAuth_ = either (error . ("[NAMES] rpc_auth: " <>)) Just . parseRpcAuth =<< eitherToMaybe (lookupValue "NAMES" "rpc_auth" ini) + endpoint = requiredText "ethereum_endpoint" + registries = readTldRegistries + in Just + NamesConfig + { ethereumEndpoint = either (error . ("[NAMES] ethereum_endpoint: " <>)) id (validateUrl endpoint rpcAuth_), + tldRegistries = registries, + rpcAuth = rpcAuth_, + rpcTimeoutMs = readIniDefault 3000 "NAMES" "rpc_timeout_ms" ini, + rpcMaxResponseBytes = readIniDefault 262144 "NAMES" "rpc_max_response_bytes" ini, + rpcMaxConcurrency = readIniDefault 8 "NAMES" "rpc_max_concurrency" ini + } + where + enabled = fromMaybe False (iniOnOff "NAMES" "enable" ini) + requiredText key = + either (error . (("[NAMES] " <> T.unpack key <> " is required: ") <>)) id $ + lookupValue "NAMES" key ini + readTldRegistries = + let regs = TldRegistries + { tldSimplex = optionalAddr "registry_tld_simplex", + tldTesting = optionalAddr "registry_tld_testing", + tldAll = optionalAddr "registry_tld_all" + } + in case (tldSimplex regs, tldTesting regs, tldAll regs) of + (Nothing, Nothing, Nothing) -> + error "[NAMES] at least one of registry_tld_simplex, registry_tld_testing, registry_tld_all is required" + _ -> regs + optionalAddr key = + either (error . (("[NAMES] " <> T.unpack key <> ": ") <>)) Just . parseEthAddr =<< eitherToMaybe (lookupValue "NAMES" key ini) + +-- | Validate the ethereum_endpoint URL: +-- * scheme must be http: or https: +-- * authority (host) must be present and non-empty +-- * port MUST be explicit (rejects http://host without :8545 to avoid +-- accidentally hitting :80 when Reth listens on :8545) +-- * userinfo (user:pass@) MUST NOT be present (credentials belong in +-- rpc_auth so they don't leak via Host header or logs) +-- * query and fragment MUST NOT be present +-- * https requires rpc_auth on non-loopback hosts (operator misconfig +-- guard — a public HTTPS endpoint without auth is almost always wrong) +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) + when (null (uriRegName ua)) $ Left "empty host" + unless (null (uriUserInfo ua)) $ Left "userinfo (user:pass@) not allowed; use rpc_auth instead" + case uriPort ua of + "" -> Left "explicit port required (e.g. http://host:8545)" + ':' : portStr -> case readMaybe portStr of + Just n | n >= 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" + unless (null (uriFragment uri)) $ Left "fragment not allowed" + let path = uriPath uri + unless (path == "" || path == "/") $ + Left "URL path not allowed; API keys embedded in the path leak to logs — use rpc_auth instead" + when (scheme == "https:" && not (isLoopback (uriRegName ua)) && isNothing auth_) $ + Left "https endpoint on a non-loopback host requires rpc_auth" + Right url + where + isLoopback h = h == "127.0.0.1" || h == "localhost" || h == "[::1]" + +-- | Parse a 20-byte Ethereum address as text "0x[hex40]" or "[hex40]". +-- EIP-55 mixed-case checksum verification is a follow-up. +parseEthAddr :: Text -> Either String NameOwner +parseEthAddr t = do + bs <- fromHex (encodeUtf8 t) + if B.length bs == 20 + then mkNameOwner bs + else Left "expected a 20-byte address (40 hex characters, optionally 0x-prefixed)" + +-- | 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..c5ac52cad3 100644 --- a/src/Simplex/Messaging/Server/Main/Init.hs +++ b/src/Simplex/Messaging/Server/Main/Init.hs @@ -155,6 +155,30 @@ 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 (SNRC on Ethereum).\n\ + \# Requires an Ethereum JSON-RPC endpoint (Reth+Nimbus). See deployment guide.\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\ + \# ethereum_endpoint: http://127.0.0.1:8545\n\ + \# Central Reth via Caddy:\n\ + \# ethereum_endpoint: https://eth.simplex.chat:443\n\ + \# rpc_auth: basic :\n\ + \# Per-TLD SNRC contract whitelist. At least one entry must be set.\n\ + \# Each RSLV carries the contract address the client wants queried;\n\ + \# the server only accepts it if it matches the address configured for\n\ + \# that TLD (or registry_tld_all as catch-all for any unspecified TLD,\n\ + \# including web domains).\n\ + \# registry_tld_simplex: 0x\n\ + \# registry_tld_testing: 0x\n\ + \# registry_tld_all: 0x\n\ + \# rpc_timeout_ms: 3000\n\ + \# rpc_max_response_bytes: 262144\n\ + \# rpc_max_concurrency: 8\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..da0fd19556 --- /dev/null +++ b/src/Simplex/Messaging/Server/Names.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} + +-- | Public-namespace resolver. Each RSLV becomes one eth_call to the +-- Ethereum endpoint with the contract address selected by the requested +-- TLD, bounded by rpcMaxConcurrency and rpcTimeoutMs. Zero-owner / expired +-- records map to NotFound. +-- +-- Transport details live in Names.Eth.RPC (HTTP + JSON-RPC + auth); +-- Keccak-256 namehash and SNRC ABI decoder live in Names.Eth.SNRC. +module Simplex.Messaging.Server.Names + ( NamesConfig (..), + TldRegistries (..), + RpcAuth (..), + NamesEnv (..), + EthCall, + ResolveError (..), + newNamesEnv, + newNamesEnvWith, + closeNamesEnv, + lookupTldAddress, + pingEndpoint, + resolveName, + verifyRslv, + ) +where + +import Control.Applicative ((<|>)) +import Control.Monad (guard, unless, when) +import qualified Control.Exception as E +import Control.Logger.Simple (logError) +import Data.ByteString.Char8 (ByteString) +import Data.IORef (IORef, atomicModifyIORef', newIORef) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Time.Clock.POSIX (getPOSIXTime) +import Simplex.Messaging.Encoding.String (strDecode) +import Simplex.Messaging.Protocol (NameOwner, NameRecord (..), RslvRequest (..), unNameOwner) +import Simplex.Messaging.Server.Names.Eth.RPC (EthRpcEnv, EthRpcError (..), RpcAuth (..), closeEthRpcEnv, ethCallReal, newEthRpcEnv) +import Simplex.Messaging.Server.Names.Eth.SNRC (decodeAddress, decodeGetRecord, encodeGetRecord, isZeroOwner, namehash) +import Simplex.Messaging.SimplexName (SimplexNameDomain (..), SimplexTLD (..), fullDomainName) +import System.Timeout (timeout) + +-- | TLD-keyed SNRC contract whitelist. Each RSLV carries the contract +-- address the client wants queried; the server only accepts it if it +-- matches the address configured for that TLD (or `tldAll` as catch-all). +-- This lets one names router host multiple TLDs (each backed by its own +-- SNRC contract) and reject clients pointing at a contract the operator +-- doesn't run. +data TldRegistries = TldRegistries + { tldSimplex :: Maybe NameOwner, + tldTesting :: Maybe NameOwner, + tldAll :: Maybe NameOwner + } + deriving (Show) + +data NamesConfig = NamesConfig + { ethereumEndpoint :: Text, + tldRegistries :: TldRegistries, + rpcAuth :: Maybe RpcAuth, + rpcTimeoutMs :: Int, + rpcMaxResponseBytes :: Int, + rpcMaxConcurrency :: Int + } + deriving (Show) + +data ResolveError + = NotFound + | EthHttpErr + | EthRpcErr {rpcCode :: Int, rpcMessage :: Text} + | EthDecodeErr + | TimedOut + deriving (Eq, Show) + +-- | Test seam: a function from (to, data) -> raw return bytes or error. +-- Production wires this to ethCallReal; tests substitute a stub. +type EthCall = ByteString -> ByteString -> IO (Either EthRpcError ByteString) + +data NamesEnv = NamesEnv + { config :: NamesConfig, + ethCall :: EthCall, + rpcEnv :: Maybe EthRpcEnv, -- Nothing for test stubs + -- One-shot guard so the placeholder-decoder warning logs once per process, + -- not once per RSLV. + placeholderWarned :: IORef Bool + } + +newNamesEnv :: NamesConfig -> IO NamesEnv +newNamesEnv cfg = do + rpc <- newEthRpcEnv (ethereumEndpoint cfg) (rpcAuth cfg) (rpcMaxResponseBytes cfg) (rpcMaxConcurrency cfg) + newNamesEnvWith cfg (ethCallReal rpc) (Just rpc) + +-- | Allocate resolver with an injected ethCall (test seam). +newNamesEnvWith :: NamesConfig -> EthCall -> Maybe EthRpcEnv -> IO NamesEnv +newNamesEnvWith config ethCall rpcEnv = do + placeholderWarned <- newIORef False + pure NamesEnv {config, ethCall, rpcEnv, placeholderWarned} + +closeNamesEnv :: NamesEnv -> IO () +closeNamesEnv NamesEnv {rpcEnv} = mapM_ closeEthRpcEnv rpcEnv + +-- | Look up the expected SNRC contract address for a TLD. TLD-specific +-- entry takes precedence; `tldAll` is the catch-all. `TLDWeb` has no +-- TLD-specific entry — it always resolves through `tldAll` if set. +lookupTldAddress :: TldRegistries -> SimplexTLD -> Maybe NameOwner +lookupTldAddress TldRegistries {tldSimplex, tldTesting, tldAll} = \case + TLDSimplex -> tldSimplex <|> tldAll + TLDTesting -> tldTesting <|> tldAll + TLDWeb -> tldAll + +-- | Parse the client-supplied domain, look up the TLD's expected contract, +-- and verify the client-supplied contract matches. Returns the verified +-- (address, parsed-domain) pair, or `Nothing` if any check fails — the +-- handler maps this to `ERR AUTH` and increments `rslvBadName`. +verifyRslv :: NamesEnv -> RslvRequest -> Maybe (NameOwner, SimplexNameDomain) +verifyRslv NamesEnv {config} RslvRequest {name, contract} = case strDecode (encodeUtf8 name) of + Left _ -> Nothing + Right d -> do + expected <- lookupTldAddress (tldRegistries config) (nameTLD d) + guard (expected == contract) + pure (expected, d) + +-- | Reach the configured endpoint with a harmless probe call to confirm +-- network reachability. Uses any configured contract address (the parser +-- guarantees at least one is set). Returns Left only on transport-level +-- failures; JSON-RPC errors (misconfigured address etc.) are treated as +-- "endpoint reachable" — that distinction surfaces later via rslvEthErrs. +pingEndpoint :: NamesEnv -> IO (Either EthRpcError ()) +pingEndpoint NamesEnv {ethCall, config} = case anyAddress (tldRegistries config) of + Nothing -> pure (Right ()) + Just addr -> + ethCall (unNameOwner addr) (encodeGetRecord (namehash "")) >>= \case + Left e@(HttpFailure _) -> pure (Left e) + Left e@(HttpStatusErr _) -> pure (Left e) + _ -> pure (Right ()) + where + anyAddress TldRegistries {tldSimplex, tldTesting, tldAll} = + tldSimplex <|> tldTesting <|> tldAll + +-- | Resolve a verified (contract, domain) pair with an rpcTimeoutMs +-- ceiling. Synchronous exceptions are caught and logged; async exceptions +-- propagate. +resolveName :: NamesEnv -> NameOwner -> SimplexNameDomain -> IO (Either ResolveError NameRecord) +resolveName env contract d = do + r <- E.try (timeout (rpcTimeoutMs (config env) * 1000) (fetch env contract d)) + case r of + Right result -> pure (fromMaybe (Left TimedOut) 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 EthHttpErr) + +fetch :: NamesEnv -> NameOwner -> SimplexNameDomain -> IO (Either ResolveError NameRecord) +fetch env@NamesEnv {ethCall} contract d = + ethCall (unNameOwner contract) (encodeGetRecord (namehash (encodeUtf8 (fullDomainName d)))) >>= \case + Left e -> pure (Left (mapEthRpcError e)) + Right ret -> case decodeGetRecord ret of + Right Nothing -> notFoundWithPlaceholderWarn ret + Right (Just rec) -> checkExpiry rec + Left _ -> pure (Left EthDecodeErr) + where + -- decodeGetRecord is currently a placeholder: it returns Right Nothing + -- for BOTH "zero-owner sentinel" (real NotFound) and "non-zero owner + -- with real data but no ABI decoder yet". Inspect the owner slot + -- directly to distinguish, and surface the latter once per process so + -- an operator who enables [NAMES] against a working SNRC contract sees + -- the resolver is functionally stubbed. + notFoundWithPlaceholderWarn ret = do + case decodeAddress 32 ret of + Right owner -> unless (isZeroOwner owner) (warnPlaceholderOnce env) + Left _ -> pure () + pure (Left NotFound) + -- Defense in depth: the SNRC contract should already return the + -- zero-owner sentinel for expired records, but a buggy / pre-upgrade + -- contract might not. nrExpiry == 0 means "never expires" (reserved + -- names); any positive expiry in the past is treated as NotFound. + checkExpiry rec = do + nowSec <- floor <$> getPOSIXTime + pure $ + if nrExpiry rec /= 0 && nrExpiry rec < nowSec + then Left NotFound + else Right rec + +warnPlaceholderOnce :: NamesEnv -> IO () +warnPlaceholderOnce NamesEnv {placeholderWarned} = do + first <- atomicModifyIORef' placeholderWarned (\w -> (True, not w)) + when first $ + logError + "[NAMES] decodeGetRecord placeholder hit — SNRC ABI codec not finalised; \ + \every non-zero-owner record returns NotFound until the decoder ships" + +-- | Collapse the JSON-RPC transport-layer error space into the resolver's +-- public error space. +mapEthRpcError :: EthRpcError -> ResolveError +mapEthRpcError = \case + HttpFailure _ -> EthHttpErr + HttpStatusErr _ -> EthHttpErr + BodyTooLarge -> EthDecodeErr + InvalidJson _ -> EthDecodeErr + JsonRpcErr c m -> EthRpcErr {rpcCode = c, rpcMessage = m} diff --git a/src/Simplex/Messaging/Server/Names/Eth/RPC.hs b/src/Simplex/Messaging/Server/Names/Eth/RPC.hs new file mode 100644 index 0000000000..d7d4bdb729 --- /dev/null +++ b/src/Simplex/Messaging/Server/Names/Eth/RPC.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} + +-- | Ethereum JSON-RPC HTTP transport for the resolver. +-- +-- Boundary properties: +-- * Response body read with `brReadSome rpcMaxResponseBytes` — adversarial +-- endpoints cannot exhaust memory with multi-GB bodies. +-- * Concurrency cap via QSem — bursts of cache-miss traffic cannot exhaust +-- the http-client connection pool. +-- * Authorization header attached only when configured. +module Simplex.Messaging.Server.Names.Eth.RPC + ( RpcAuth (..), + EthRpcEnv (..), + EthRpcError (..), + newEthRpcEnv, + closeEthRpcEnv, + ethCallReal, + fromHex, + scrubUrl, + ) +where + +import Control.Applicative ((<|>)) +import Control.Concurrent.QSem (QSem, newQSem, signalQSem, waitQSem) +import qualified Control.Exception as E +import Control.Exception (bracket_) +import qualified Data.Aeson as J +import qualified Data.Aeson.Types as J +import qualified Data.ByteArray.Encoding as BAE +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy as BL +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Network.HTTP.Client + ( HttpException, + Manager, + Request, + RequestBody (..), + brReadSome, + closeManager, + method, + parseRequest, + requestBody, + requestHeaders, + responseBody, + responseStatus, + withResponse, + ) +import qualified Network.HTTP.Client as HC +import Network.HTTP.Client.TLS (tlsManagerSettings) +import qualified Network.HTTP.Types as HT + +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 EthRpcEnv = EthRpcEnv + { manager :: Manager, + request :: Request, + sem :: QSem, + maxResponseBytes :: Int + } + +data EthRpcError + = HttpFailure HttpException + | HttpStatusErr Int + | BodyTooLarge + | InvalidJson String + | JsonRpcErr Int Text + deriving (Show) + +-- | Build a Request from a (validated) ethereum_endpoint URL. +buildRequest :: Text -> Maybe RpcAuth -> IO Request +buildRequest endpoint auth_ = do + req <- parseRequest (T.unpack endpoint) + pure $ + req + { method = "POST", + requestHeaders = + ("Content-Type", "application/json") + : maybe [] (pure . authHeader) auth_ + } + +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) + +newEthRpcEnv :: Text -> Maybe RpcAuth -> Int -> Int -> IO EthRpcEnv +newEthRpcEnv endpoint auth_ maxResponseBytes maxConcurrency = do + manager <- HC.newManager tlsManagerSettings + request <- buildRequest endpoint auth_ + sem <- newQSem maxConcurrency + pure EthRpcEnv {manager, request, sem, maxResponseBytes} + +closeEthRpcEnv :: EthRpcEnv -> IO () +closeEthRpcEnv EthRpcEnv {manager} = closeManager manager + +-- | Make a single eth_call. `to` is the contract address (20 raw bytes); +-- `dat` is the ABI-encoded call data. Returns the contract return bytes. +ethCallReal :: EthRpcEnv -> ByteString -> ByteString -> IO (Either EthRpcError ByteString) +ethCallReal EthRpcEnv {manager, request, sem, maxResponseBytes} to dat = + bracket_ (waitQSem sem) (signalQSem sem) $ do + let body = J.encode (rpcEnvelope to dat) + req = request {requestBody = RequestBodyLBS body} + result <- E.try $ withResponse req manager $ \res -> do + let status = responseStatus res + if HT.statusCode status >= 400 + then pure (Left (HttpStatusErr (HT.statusCode status))) + else do + bs <- brReadSome (responseBody res) (maxResponseBytes + 1) + if BL.length bs > fromIntegral maxResponseBytes + then pure (Left BodyTooLarge) + else pure (parseResult (BL.toStrict bs)) + pure (either (Left . HttpFailure) id result) + +rpcEnvelope :: ByteString -> ByteString -> J.Value +rpcEnvelope to dat = + J.object + [ "jsonrpc" J..= ("2.0" :: Text), + "id" J..= (1 :: Int), + "method" J..= ("eth_call" :: Text), + "params" + J..= [ J.object + [ "to" J..= toHex to, + "data" J..= toHex dat + ], + J.String "latest" + ] + ] + +parseResult :: ByteString -> Either EthRpcError ByteString +parseResult bs = case J.eitherDecodeStrict bs of + Left e -> Left (InvalidJson e) + Right (v :: J.Value) -> case J.parseEither parser v of + Left e -> Left (InvalidJson e) + Right r -> r + where + parser :: J.Value -> J.Parser (Either EthRpcError ByteString) + parser = J.withObject "rpc" $ \o -> do + mErr :: Maybe J.Value <- o J..:? "error" + case mErr of + Just (J.Object eo) -> do + code <- (eo J..: "code") <|> pure (-1 :: Int) + msg <- (eo J..: "message") <|> pure ("rpc error" :: Text) + pure (Left (JsonRpcErr code msg)) + _ -> do + result :: Text <- o J..: "result" + case fromHex (encodeUtf8 result) of + Right b -> pure (Right b) + Left e -> pure (Left (InvalidJson e)) + +toHex :: ByteString -> Text +toHex bs = T.pack $ "0x" <> concatMap byte (B.unpack bs) + where + byte c = + let n = fromEnum c + (h, l) = quotRem n 16 + in [hexChar h, hexChar l] + hexChar n + | n < 10 = toEnum (fromEnum '0' + n) + | otherwise = toEnum (fromEnum 'a' + n - 10) + +fromHex :: ByteString -> Either String ByteString +fromHex bs0 = + let bs = case B.stripPrefix "0x" bs0 of + Just rest -> rest + Nothing -> case B.stripPrefix "0X" bs0 of + Just rest -> rest + Nothing -> bs0 + in if B.null bs + then Right B.empty + else + if odd (B.length bs) || not (B.all isHex bs) + then Left "invalid hex" + else Right (decodeHex bs) + where + isHex c = (c >= '0' && c <= '9') || (c >= 'a' && c <= 'f') || (c >= 'A' && c <= 'F') + +decodeHex :: ByteString -> ByteString +decodeHex = B.pack . go + where + go s + | B.null s = [] + | otherwise = + let hi = digit (B.head s) + lo = digit (B.index s 1) + in toEnum (16 * hi + lo) : go (B.drop 2 s) + digit c + | c >= '0' && c <= '9' = fromEnum c - fromEnum '0' + | c >= 'a' && c <= 'f' = 10 + fromEnum c - fromEnum 'a' + | otherwise = 10 + fromEnum c - fromEnum 'A' + +-- | 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/Names/Eth/SNRC.hs b/src/Simplex/Messaging/Server/Names/Eth/SNRC.hs new file mode 100644 index 0000000000..adf3d2d5e4 --- /dev/null +++ b/src/Simplex/Messaging/Server/Names/Eth/SNRC.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} + +-- | SNRC contract codec: Keccak-256 namehash + bounded Solidity ABI decoder. +-- +-- IMPORTANT: Ethereum uses Keccak-256, NOT NIST SHA3-256. +-- +-- ABI safety invariants (enforced before any allocation): +-- 1. offset + 32 <= buf.length (head read in-bounds) +-- 2. offset + 32 + length <= buf.length (body in-bounds) +-- 3. offset >= headEnd (no backward jumps) +-- 4. every length <= per-field cap (bounded allocations) +-- 5. string[] outer count * 32 + offset <= buf.length (array head fits) +-- 6. recursion depth <= 2 (no deep nesting) +-- 7. uint256 -> Int64 fails if any high 24 bytes non-zero (range check) +-- 8. UTF-8 via decodeUtf8' returns AbiBadUtf8 (no partial bytes) +module Simplex.Messaging.Server.Names.Eth.SNRC + ( -- * Namehash + keccak256, + namehash, + + -- * SNRC eth_call payload + snrcSelector, + encodeGetRecord, + + -- * ABI decoding + AbiError (..), + decodeGetRecord, + decodeWord256Int64, + decodeAddress, + decodeString, + decodeUtf8Text, + decodeStringArray, + isZeroOwner, + ) +where + +import Crypto.Hash (Digest, Keccak_256, hash) +import qualified Data.ByteArray as BA +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Int (Int64) +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8') +import Simplex.Messaging.Protocol (NameOwner, NameRecord, mkNameOwner, unNameOwner) + +-- | ABI-decode failure modes (caller collapses to ResolveError EthDecodeErr). +data AbiError + = AbiTruncated + | AbiOversized + | AbiBackwardOffset + | AbiNonZeroHighBytes + | AbiBadUtf8 + | AbiDepthExceeded + | AbiInvariantViolated String + deriving (Eq, Show) + +-- | Keccak-256 (Ethereum variant), NOT SHA3-256. +keccak256 :: ByteString -> ByteString +keccak256 = BA.convert . (hash :: ByteString -> Digest Keccak_256) +{-# INLINE keccak256 #-} + +-- | ENS / SNRC namehash: recursive keccak256 over reversed labels. +-- Empty name -> 32 zero bytes; "a.b.c" -> keccak(keccak(keccak(0 ++ keccak "c") ++ keccak "b") ++ keccak "a"). +namehash :: ByteString -> ByteString +namehash name + | B.null name = zeroNode + | otherwise = foldr step zeroNode (B.split '.' name) + where + zeroNode = B.replicate 32 '\NUL' + step label acc = keccak256 (acc <> keccak256 label) + +-- | First 4 bytes of keccak("getRecord(bytes32)"). Confirm signature +-- against the Part 1 SNRC contract before merging. +snrcSelector :: ByteString +snrcSelector = B.take 4 (keccak256 "getRecord(bytes32)") + +-- | Build the eth_call `data` parameter for getRecord(lookupKey). +encodeGetRecord :: ByteString -> ByteString +encodeGetRecord node32 + | B.length node32 == 32 = snrcSelector <> node32 + | otherwise = snrcSelector <> padLeft32 node32 + +padLeft32 :: ByteString -> ByteString +padLeft32 bs + | n >= 32 = B.take 32 bs + | otherwise = B.replicate (32 - n) '\NUL' <> bs + where + n = B.length bs + +-- | Read a uint256 at byte offset, fail if it doesn't fit in *signed* Int64. +-- Rejects both (a) any non-zero byte in the high 24 bytes and (b) the high +-- bit of the low 8 bytes being set — the latter is essential because Int64 +-- would otherwise sign-flip a uint64 value into a negative integer, silently +-- corrupting downstream length math. +decodeWord256Int64 :: Int -> ByteString -> Either AbiError Int64 +decodeWord256Int64 off buf + | off + 32 > B.length buf = Left AbiTruncated + | B.any (/= '\NUL') (B.take 24 (B.drop off buf)) = Left AbiNonZeroHighBytes + | B.index buf (off + 24) >= '\x80' = Left AbiNonZeroHighBytes + | otherwise = Right $ B.foldl shiftIn 0 (B.take 8 (B.drop (off + 24) buf)) + where + shiftIn :: Int64 -> Char -> Int64 + shiftIn !acc c = (acc * 256) + fromIntegral (fromEnum c :: Int) +{-# INLINE decodeWord256Int64 #-} + +-- | Read an Ethereum address at byte offset (uint256 with high 12 bytes zero). +decodeAddress :: Int -> ByteString -> Either AbiError NameOwner +decodeAddress off buf + | off + 32 > B.length buf = Left AbiTruncated + | B.any (/= toEnum 0) (B.take 12 (B.drop off buf)) = Left (AbiInvariantViolated "address has non-zero high 12 bytes") + | otherwise = case mkNameOwner (B.take 20 (B.drop (off + 12) buf)) of + Right addr -> Right addr + Left e -> Left (AbiInvariantViolated e) + +-- | Decode a Solidity `string` whose data starts at byte offset `off`. +-- Returns raw bytes; UTF-8 validity is the caller's choice (use +-- `decodeUtf8Text` if a Text is required). +decodeString :: Int -> Int -> Int -> ByteString -> Either AbiError ByteString +decodeString headEnd off cap buf + | off < headEnd = Left AbiBackwardOffset + | off + 32 > B.length buf = Left AbiTruncated + | otherwise = do + n <- decodeWord256Int64 off buf + let len = fromIntegral n :: Int + if len > cap + then Left AbiOversized + else + if off + 32 + len > B.length buf + then Left AbiTruncated + else Right $ B.take len (B.drop (off + 32) buf) + +-- | Decode a Solidity `string` as Text, failing with AbiBadUtf8 on +-- invalid UTF-8. This is what NameRecord decoder composition will use. +decodeUtf8Text :: Int -> Int -> Int -> ByteString -> Either AbiError Text +decodeUtf8Text headEnd off cap buf = do + raw <- decodeString headEnd off cap buf + either (const (Left AbiBadUtf8)) Right (decodeUtf8' raw) + +-- | Decode a Solidity `string[]` at byte offset `off`. Each element capped +-- at `byteCap` bytes, total element count capped at `cntCap`. Depth must be +-- < 2 (recurses one level into decodeString). +decodeStringArray :: Int -> Int -> Int -> Int -> Int -> ByteString -> Either AbiError [ByteString] +decodeStringArray depth headEnd off cntCap byteCap buf + | depth >= 2 = Left AbiDepthExceeded + | off < headEnd = Left AbiBackwardOffset + | off + 32 > B.length buf = Left AbiTruncated + | otherwise = do + n <- decodeWord256Int64 off buf + let cnt = fromIntegral n :: Int + if cnt > cntCap + then Left AbiOversized + else + let arrHead = off + 32 + arrHeadEnd = arrHead + cnt * 32 + in if arrHeadEnd > B.length buf + then Left AbiTruncated + else collectN 0 cnt arrHead arrHeadEnd [] + where + collectN i n base hd acc + | i >= n = Right (reverse acc) + | otherwise = do + relOff <- decodeWord256Int64 (base + i * 32) buf + let absOff = base + fromIntegral relOff + s <- decodeString hd absOff byteCap buf + collectN (i + 1) n base hd (s : acc) + +-- | Decode the ABI-encoded return value of getRecord(bytes32) into a NameRecord. +-- Zero-owner (0x000...000) is reported as Right Nothing so the caller maps it +-- to NotFound (ENS-style sentinel). +-- +-- PLACEHOLDER: returns Right Nothing for any non-zero owner until the Part 1 +-- SNRC contract ABI is finalised. All ABI primitives above are production-ready; +-- only the field-layout-aware composition is pending. +decodeGetRecord :: ByteString -> Either AbiError (Maybe NameRecord) +decodeGetRecord buf + | B.length buf < 32 * 8 = Left AbiTruncated + | otherwise = case decodeAddress 32 buf of + Left e -> Left e + Right owner + | isZeroOwner owner -> Right Nothing + | otherwise -> Right Nothing -- placeholder until SNRC ABI is finalised + +isZeroOwner :: NameOwner -> Bool +isZeroOwner = (== B.replicate 20 '\NUL') . unNameOwner diff --git a/src/Simplex/Messaging/Server/Prometheus.hs b/src/Simplex/Messaging/Server/Prometheus.hs index 32e8bd9a10..3367873538 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,35 @@ 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, _rslvBadName, _rslvEthErrs, _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 Lookup key has no corresponding NameRecord on chain (zero-owner sentinel).\n\ + \# TYPE simplex_smp_names_not_found counter\n\ + \simplex_smp_names_not_found " <> mshow _rslvNotFound <> "\n# rslvNotFound\n\ + \\n\ + \# HELP simplex_smp_names_bad_name Client sent malformed domain, TLD outside whitelist, or wrong contract address.\n\ + \# TYPE simplex_smp_names_bad_name counter\n\ + \simplex_smp_names_bad_name " <> mshow _rslvBadName <> "\n# rslvBadName\n\ + \\n\ + \# HELP simplex_smp_names_eth_errs Ethereum endpoint or ABI errors.\n\ + \# TYPE simplex_smp_names_eth_errs counter\n\ + \simplex_smp_names_eth_errs " <> mshow _rslvEthErrs <> "\n# rslvEthErrs\n\ + \\n\ + \# HELP simplex_smp_names_disabled RSLV requests rejected because the names role is disabled.\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..b7dd239eb2 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,100 @@ 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, + rslvBadName :: IORef Int, + rslvEthErrs :: IORef Int, + rslvDisabled :: IORef Int + } + +newNameResolverStats :: IO NameResolverStats +newNameResolverStats = do + rslvReqs <- newIORef 0 + rslvSucc <- newIORef 0 + rslvNotFound <- newIORef 0 + rslvBadName <- newIORef 0 + rslvEthErrs <- newIORef 0 + rslvDisabled <- newIORef 0 + pure NameResolverStats {rslvReqs, rslvSucc, rslvNotFound, rslvBadName, rslvEthErrs, rslvDisabled} + +data NameResolverStatsData = NameResolverStatsData + { _rslvReqs :: Int, + _rslvSucc :: Int, + _rslvNotFound :: Int, + _rslvBadName :: Int, + _rslvEthErrs :: Int, + _rslvDisabled :: Int + } + deriving (Show) + +newNameResolverStatsData :: NameResolverStatsData +newNameResolverStatsData = + NameResolverStatsData + { _rslvReqs = 0, + _rslvSucc = 0, + _rslvNotFound = 0, + _rslvBadName = 0, + _rslvEthErrs = 0, + _rslvDisabled = 0 + } + +getNameResolverStatsData :: NameResolverStats -> IO NameResolverStatsData +getNameResolverStatsData s = do + _rslvReqs <- readIORef $ rslvReqs s + _rslvSucc <- readIORef $ rslvSucc s + _rslvNotFound <- readIORef $ rslvNotFound s + _rslvBadName <- readIORef $ rslvBadName s + _rslvEthErrs <- readIORef $ rslvEthErrs s + _rslvDisabled <- readIORef $ rslvDisabled s + pure NameResolverStatsData {_rslvReqs, _rslvSucc, _rslvNotFound, _rslvBadName, _rslvEthErrs, _rslvDisabled} + +getResetNameResolverStatsData :: NameResolverStats -> IO NameResolverStatsData +getResetNameResolverStatsData s = do + _rslvReqs <- atomicSwapIORef (rslvReqs s) 0 + _rslvSucc <- atomicSwapIORef (rslvSucc s) 0 + _rslvNotFound <- atomicSwapIORef (rslvNotFound s) 0 + _rslvBadName <- atomicSwapIORef (rslvBadName s) 0 + _rslvEthErrs <- atomicSwapIORef (rslvEthErrs s) 0 + _rslvDisabled <- atomicSwapIORef (rslvDisabled s) 0 + pure NameResolverStatsData {_rslvReqs, _rslvSucc, _rslvNotFound, _rslvBadName, _rslvEthErrs, _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 (rslvBadName s) $! _rslvBadName d + writeIORef (rslvEthErrs s) $! _rslvEthErrs d + writeIORef (rslvDisabled s) $! _rslvDisabled d + +instance StrEncoding NameResolverStatsData where + strEncode NameResolverStatsData {_rslvReqs, _rslvSucc, _rslvNotFound, _rslvBadName, _rslvEthErrs, _rslvDisabled} = + "reqs=" + <> strEncode _rslvReqs + <> "\nsucc=" + <> strEncode _rslvSucc + <> "\nnotFound=" + <> strEncode _rslvNotFound + <> "\nethErrs=" + <> strEncode _rslvEthErrs + <> "\ndisabled=" + <> strEncode _rslvDisabled + <> "\nbadName=" + <> strEncode _rslvBadName + strP = do + _rslvReqs <- "reqs=" *> strP <* A.endOfLine + _rslvSucc <- "succ=" *> strP <* A.endOfLine + _rslvNotFound <- "notFound=" *> strP <* A.endOfLine + _rslvEthErrs <- "ethErrs=" *> strP <* A.endOfLine + _rslvDisabled <- "disabled=" *> strP + -- badName= was added after the initial release; old stats files may omit it. + _rslvBadName <- (A.endOfLine *> "badName=" *> strP) <|> pure 0 + pure NameResolverStatsData {_rslvReqs, _rslvSucc, _rslvNotFound, _rslvBadName, _rslvEthErrs, _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..cfb700470c --- /dev/null +++ b/src/Simplex/Messaging/SimplexName.hs @@ -0,0 +1,108 @@ +{-# 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.Char (isAlpha, isDigit) +import Data.Functor (($>)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +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 + 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 -> "@" + +$(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/SMPClient.hs b/tests/SMPClient.hs index d043fd3c86..2ee9b509f0 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -278,6 +278,7 @@ cfgMS msType = withStoreCfg (testServerStoreConfig msType) $ \serverStoreCfg -> smpAgentCfg = defaultSMPClientAgentConfig {persistErrorInterval = 1}, -- seconds allowSMPProxy = False, serverClientConcurrency = 2, + namesConfig = Nothing, information = Nothing, startOptions = defaultStartOptions } diff --git a/tests/SMPNamesTests.hs b/tests/SMPNamesTests.hs new file mode 100644 index 0000000000..a78196186e --- /dev/null +++ b/tests/SMPNamesTests.hs @@ -0,0 +1,337 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module SMPNamesTests (smpNamesTests) where + +import qualified Crypto.Hash as Crypton +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteArray as BA +import Data.Either (isLeft, isRight) +import Data.IORef (atomicModifyIORef', newIORef, readIORef) +import qualified Data.Text as T +import qualified Data.Aeson as J +import qualified Data.ByteString.Lazy as LB +import Simplex.Messaging.Protocol + ( NameOwner, + NameRecord (..), + RslvRequest (..), + mkNameLink, + mkNameOwner, + unNameLink, + unNameOwner, + ) +import Simplex.Messaging.Server.Names + ( NamesConfig (..), + ResolveError (..), + TldRegistries (..), + lookupTldAddress, + newNamesEnvWith, + resolveName, + verifyRslv, + ) +import Simplex.Messaging.Server.Names.Eth.SNRC + ( AbiError (..), + decodeAddress, + decodeGetRecord, + decodeString, + decodeStringArray, + decodeWord256Int64, + encodeGetRecord, + keccak256, + namehash, + snrcSelector, + ) +import Simplex.Messaging.SimplexName (SimplexNameDomain (..), SimplexTLD (..)) +import Test.Hspec + +-- Reference vectors: +-- keccak256("") = c5d2460186f7233c927e7db2dcc703c0e500b653ca8227b7bfad8045d85a470 +-- keccak256("abc") = 4e03657aea45a94fc7d47ba826c8d667c0d1e6e33a64a036ec44f58fa12d6c45 +-- sha3_256("abc") = 3a985da74fe225b2045c172d6bd390bd855f086e3e9d525b46bfe24511431532 +-- namehash("eth") = 93cdeb708b7545dc668eb9280176169d1c33cfd8ed6f04690a0bcc88a93fc4ae + +keccak256Empty :: ByteString +keccak256Empty = "\xc5\xd2\x46\x01\x86\xf7\x23\x3c\x92\x7e\x7d\xb2\xdc\xc7\x03\xc0\xe5\x00\xb6\x53\xca\x82\x27\x3b\x7b\xfa\xd8\x04\x5d\x85\xa4\x70" + +keccak256Abc :: ByteString +keccak256Abc = "\x4e\x03\x65\x7a\xea\x45\xa9\x4f\xc7\xd4\x7b\xa8\x26\xc8\xd6\x67\xc0\xd1\xe6\xe3\x3a\x64\xa0\x36\xec\x44\xf5\x8f\xa1\x2d\x6c\x45" + +sha3_256Abc :: ByteString +sha3_256Abc = "\x3a\x98\x5d\xa7\x4f\xe2\x25\xb2\x04\x5c\x17\x2d\x6b\xd3\x90\xbd\x85\x5f\x08\x6e\x3e\x9d\x52\x5b\x46\xbf\xe2\x45\x11\x43\x15\x32" + +namehashEth :: ByteString +namehashEth = "\x93\xcd\xeb\x70\x8b\x75\x45\xdc\x66\x8e\xb9\x28\x01\x76\x16\x9d\x1c\x33\xcf\xd8\xed\x6f\x04\x69\x0a\x0b\xcc\x88\xa9\x3f\xc4\xae" + +twentyOnes :: ByteString +twentyOnes = B.replicate 20 '\x01' + +sampleRecord :: NameRecord +sampleRecord = case (mkNameOwner twentyOnes, mkNameLink "simplex:/contact/abc#xyz") of + (Right o, Right l) -> + NameRecord + { nrDisplayName = "Alice", + nrOwner = o, + nrChannelLinks = [], + nrContactLinks = [l], + nrAdminAddress = Just "simplex:/admin/...", + nrAdminEmail = Just "admin@example.org", + nrExpiry = 1735689600, + nrIsTest = False + } + _ -> error "sampleRecord smart ctors failed" + +smpNamesTests :: Spec +smpNamesTests = do + describe "NameRecord encoding (Protocol)" nameRecordEncodingSpec + describe "Smart constructors (NameOwner, NameLink)" smartCtorsSpec + describe "Keccak-256 and namehash" namehashSpec + describe "ABI primitive bounds" abiBoundsSpec + describe "decodeGetRecord (zero-owner sentinel)" zeroOwnerSpec + describe "TLD whitelist + RSLV verification" tldWhitelistSpec + describe "Resolver" resolverSpec + +nameRecordEncodingSpec :: Spec +nameRecordEncodingSpec = do + it "round-trips JSON encode / decode" $ + J.eitherDecodeStrict (LB.toStrict (J.encode sampleRecord)) `shouldBe` Right sampleRecord + + it "rejects negative expiry" $ do + let badBytes = LB.toStrict (J.encode sampleRecord {nrExpiry = -1}) + (J.eitherDecodeStrict badBytes :: Either String NameRecord) `shouldSatisfy` isLeft + + it "enforces combined channel+contact list cap of 8" $ do + let mkLink i = either error id (mkNameLink ("simplex:/contact/" <> T.pack (show (i :: Int)))) + nineLinks = map mkLink [0 .. 8] + overflow = sampleRecord {nrChannelLinks = nineLinks, nrContactLinks = []} + bytes = LB.toStrict (J.encode overflow) + (J.eitherDecodeStrict bytes :: Either String NameRecord) `shouldSatisfy` isLeft + + it "rejects nrDisplayName > 255 bytes UTF-8" $ do + let oversize = sampleRecord {nrDisplayName = T.replicate 256 "x"} + bytes = LB.toStrict (J.encode oversize) + (J.eitherDecodeStrict bytes :: Either String NameRecord) `shouldSatisfy` isLeft + + it "FromJSON NameOwner accepts both 0x and 0X prefixes" $ do + let json p = "\"" <> p <> "0101010101010101010101010101010101010101\"" + (J.eitherDecodeStrict (json "0x") :: Either String NameOwner) `shouldSatisfy` isRight + (J.eitherDecodeStrict (json "0X") :: Either String NameOwner) `shouldSatisfy` isRight + + it "encodes within the proxied transmission budget" $ do + let huge = either error id (mkNameLink (T.replicate 1024 "x")) + wide = + sampleRecord + { nrChannelLinks = replicate 4 huge, + nrContactLinks = replicate 4 huge, + nrDisplayName = T.replicate 255 "n", + nrAdminAddress = Just (T.replicate 255 "a"), + nrAdminEmail = Just (T.replicate 255 "e") + } + LB.length (J.encode wide) < 16224 `shouldBe` True + +smartCtorsSpec :: Spec +smartCtorsSpec = do + it "mkNameOwner accepts exactly 20 bytes" $ do + mkNameOwner twentyOnes `shouldSatisfy` isRight + mkNameOwner (B.replicate 19 '\x01') `shouldSatisfy` isLeft + mkNameOwner (B.replicate 21 '\x01') `shouldSatisfy` isLeft + + it "mkNameLink rejects >1024 UTF-8 bytes" $ do + mkNameLink (T.replicate 1024 "x") `shouldSatisfy` isRight + mkNameLink (T.replicate 1025 "x") `shouldSatisfy` isLeft + -- multibyte UTF-8 counted in bytes, not chars: 600 × 3 = 1800 bytes + mkNameLink (T.replicate 600 "\x4e2d") `shouldSatisfy` isLeft + + it "unNameLink / unNameOwner round-trip the smart ctors" $ do + case (mkNameOwner twentyOnes, mkNameLink "abc") of + (Right o, Right l) -> do + unNameOwner o `shouldBe` twentyOnes + unNameLink l `shouldBe` "abc" + _ -> expectationFailure "smart ctors failed" + +namehashSpec :: Spec +namehashSpec = do + it "keccak256 of empty string matches reference vector" $ + keccak256 "" `shouldBe` keccak256Empty + + it "keccak256 of \"abc\" matches reference vector" $ + keccak256 "abc" `shouldBe` keccak256Abc + + it "Keccak-256 is NOT SHA3-256 (different output for same input)" $ do + let sha3 = BA.convert (Crypton.hash @ByteString @Crypton.SHA3_256 "abc") :: ByteString + sha3 `shouldBe` sha3_256Abc + keccak256 "abc" `shouldNotBe` sha3 + + it "namehash of empty name is 32 zero bytes" $ + namehash "" `shouldBe` B.replicate 32 '\NUL' + + it "namehash of \"eth\" matches ENS reference vector" $ + namehash "eth" `shouldBe` namehashEth + + it "snrcSelector is 4 bytes" $ + B.length snrcSelector `shouldBe` 4 + + it "encodeGetRecord = selector ++ 32-byte node" $ do + let node = namehash "alice.eth" + bytes = encodeGetRecord node + B.length bytes `shouldBe` 36 + B.take 4 bytes `shouldBe` snrcSelector + B.drop 4 bytes `shouldBe` node + +abiBoundsSpec :: Spec +abiBoundsSpec = do + let mkBuf n = B.replicate n '\NUL' + + it "decodeWord256Int64 fails when offset + 32 > buf length" $ + decodeWord256Int64 0 (mkBuf 31) `shouldBe` Left AbiTruncated + + it "decodeWord256Int64 rejects non-zero high 24 bytes (Int64 overflow)" $ do + let buf = B.replicate 23 '\NUL' <> B.singleton '\x01' <> B.replicate 8 '\NUL' + decodeWord256Int64 0 buf `shouldBe` Left AbiNonZeroHighBytes + + it "decodeWord256Int64 rejects sign bit set in low 8 bytes (silent negative)" $ do + -- 0x8000000000000000 would decode to Int64.minBound without the check; + -- downstream length math would then see a negative len and silently + -- return empty bytes from B.take instead of failing. + let buf = B.replicate 24 '\NUL' <> "\x80\x00\x00\x00\x00\x00\x00\x00" + decodeWord256Int64 0 buf `shouldBe` Left AbiNonZeroHighBytes + + it "decodeWord256Int64 succeeds for the max representable positive value" $ do + let buf = B.replicate 24 '\NUL' <> "\x7F\xFF\xFF\xFF\xFF\xFF\xFF\xFF" + decodeWord256Int64 0 buf `shouldBe` Right maxBound + + it "decodeWord256Int64 succeeds for low 8 bytes set" $ do + let buf = B.replicate 24 '\NUL' <> "\x00\x00\x00\x00\x00\x00\x12\x34" + decodeWord256Int64 0 buf `shouldBe` Right 0x1234 + + it "decodeAddress rejects non-zero high 12 bytes" $ do + let buf = B.replicate 11 '\NUL' <> B.singleton '\x01' <> B.replicate 20 '\NUL' + decodeAddress 0 buf `shouldSatisfy` isLeft + + it "decodeString fails on backward offset" $ + decodeString 100 50 1024 (mkBuf 200) `shouldBe` Left AbiBackwardOffset + + it "decodeString fails when declared length exceeds the per-field cap" $ do + let lenBytes = B.replicate 24 '\NUL' <> "\x00\x00\x00\x00\x00\x00\x00\x64" -- length 100 + buf = lenBytes <> B.replicate 100 'x' + decodeString 0 0 10 buf `shouldBe` Left AbiOversized + + it "decodeStringArray fails when depth ≥ 2" $ + decodeStringArray 2 0 0 8 1024 (mkBuf 64) `shouldBe` Left AbiDepthExceeded + + it "decodeStringArray fails when array count exceeds cap" $ do + let lenBytes = B.replicate 24 '\NUL' <> "\x00\x00\x00\x00\x00\x00\x00\x09" -- 9 elements + buf = lenBytes <> B.replicate 1024 '\NUL' + decodeStringArray 0 0 0 8 1024 buf `shouldBe` Left AbiOversized + +zeroOwnerSpec :: Spec +zeroOwnerSpec = do + it "decodeGetRecord returns Nothing for zero-owner buffer" $ do + -- 8 slots × 32 bytes; owner at slot 1 (offset 32) is all-zero by construction + let buf = B.replicate (32 * 8) '\NUL' + decodeGetRecord buf `shouldBe` Right Nothing + + it "decodeGetRecord fails on truncated buffer" $ do + let tiny = B.replicate 31 '\NUL' + decodeGetRecord tiny `shouldBe` Left AbiTruncated + +tldWhitelistSpec :: Spec +tldWhitelistSpec = do + let addr1 = either error id (mkNameOwner twentyOnes) + addr2 = either error id (mkNameOwner (B.replicate 20 '\x02')) + addr3 = either error id (mkNameOwner (B.replicate 20 '\x03')) + + describe "lookupTldAddress" $ do + it "TLD-specific entry takes precedence over _all" $ do + let regs = TldRegistries {tldSimplex = Just addr1, tldTesting = Just addr2, tldAll = Just addr3} + lookupTldAddress regs TLDSimplex `shouldBe` Just addr1 + lookupTldAddress regs TLDTesting `shouldBe` Just addr2 + + it "TLD without specific entry falls back to _all" $ do + let regs = TldRegistries {tldSimplex = Nothing, tldTesting = Nothing, tldAll = Just addr3} + lookupTldAddress regs TLDSimplex `shouldBe` Just addr3 + lookupTldAddress regs TLDTesting `shouldBe` Just addr3 + + it "TLDWeb resolves only through _all" $ do + let regs = TldRegistries {tldSimplex = Just addr1, tldTesting = Just addr2, tldAll = Just addr3} + lookupTldAddress regs TLDWeb `shouldBe` Just addr3 + + it "TLDWeb without _all returns Nothing even if other TLDs are set" $ do + let regs = TldRegistries {tldSimplex = Just addr1, tldTesting = Just addr2, tldAll = Nothing} + lookupTldAddress regs TLDWeb `shouldBe` Nothing + + describe "verifyRslv" $ do + let cfgWith regs = + NamesConfig + { ethereumEndpoint = "http://stub", + tldRegistries = regs, + rpcAuth = Nothing, + rpcTimeoutMs = 1000, + rpcMaxResponseBytes = 65536, + rpcMaxConcurrency = 4 + } + mkEnv regs = newNamesEnvWith (cfgWith regs) (\_ _ -> pure (Right "")) Nothing + + it "accepts a valid name with matching TLD-specific contract" $ do + env <- mkEnv $ TldRegistries {tldSimplex = Just addr1, tldTesting = Nothing, tldAll = Nothing} + let req = RslvRequest {name = "privacy.simplex", contract = addr1} + case verifyRslv env req of + Just (a, d) -> do + a `shouldBe` addr1 + nameTLD d `shouldBe` TLDSimplex + domain d `shouldBe` "privacy" + Nothing -> expectationFailure "expected Just" + + it "rejects mismatched contract address" $ do + env <- mkEnv $ TldRegistries {tldSimplex = Just addr1, tldTesting = Nothing, tldAll = Nothing} + let req = RslvRequest {name = "privacy.simplex", contract = addr2} + verifyRslv env req `shouldBe` Nothing + + it "rejects TLD with no whitelist entry" $ do + env <- mkEnv $ TldRegistries {tldSimplex = Just addr1, tldTesting = Nothing, tldAll = Nothing} + let req = RslvRequest {name = "test.testing", contract = addr1} + verifyRslv env req `shouldBe` Nothing + + it "accepts via _all fallback" $ do + env <- mkEnv $ TldRegistries {tldSimplex = Nothing, tldTesting = Nothing, tldAll = Just addr3} + let req = RslvRequest {name = "test.testing", contract = addr3} + case verifyRslv env req of + Just (a, _) -> a `shouldBe` addr3 + Nothing -> expectationFailure "expected Just" + + it "rejects bare (no-TLD) name (SimplexNameDomain.strP requires TLD)" $ do + env <- mkEnv $ TldRegistries {tldSimplex = Just addr1, tldTesting = Nothing, tldAll = Nothing} + let req = RslvRequest {name = "privacy", contract = addr1} + verifyRslv env req `shouldBe` Nothing + +resolverSpec :: Spec +resolverSpec = do + let mkEnv ethCall = do + let cfg = + NamesConfig + { ethereumEndpoint = "http://stub", + tldRegistries = TldRegistries {tldSimplex = Just (either error id (mkNameOwner twentyOnes)), tldTesting = Nothing, tldAll = Nothing}, + rpcAuth = Nothing, + rpcTimeoutMs = 1000, + rpcMaxResponseBytes = 65536, + rpcMaxConcurrency = 4 + } + newNamesEnvWith cfg ethCall Nothing + aliceDomain = SimplexNameDomain {nameTLD = TLDSimplex, domain = "alice", subDomain = []} + aliceAddr = either error id (mkNameOwner twentyOnes) + + it "maps stub zero-owner response to NotFound" $ do + env <- mkEnv $ \_ _ -> pure (Right (B.replicate (32 * 8) '\NUL')) + r <- resolveName env aliceAddr aliceDomain + r `shouldBe` Left NotFound + + it "every lookup hits the endpoint (no cache)" $ do + callCount <- newIORef (0 :: Int) + env <- mkEnv $ \_ _ -> do + atomicModifyIORef' callCount (\v -> (v + 1, ())) + pure (Right (B.replicate (32 * 8) '\NUL')) + _ <- resolveName env aliceAddr aliceDomain + _ <- resolveName env aliceAddr aliceDomain + n <- readIORef callCount + n `shouldBe` 2 diff --git a/tests/Test.hs b/tests/Test.hs index ae6df6e780..84718a9fcc 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -22,6 +22,7 @@ import FileDescriptionTests (fileDescriptionTests) import GHC.IO.Exception (IOException (..)) import qualified GHC.IO.Exception as IOException import RemoteControl (remoteControlTests) +import SMPNamesTests (smpNamesTests) import SMPProxyTests (smpProxyTests) import ServerTests import Simplex.Messaging.Server.Env.STM (AStoreType (..)) @@ -97,6 +98,7 @@ main = do #endif describe "TSessionSubs tests" tSessionSubsTests describe "Util tests" utilTests + describe "Names resolver tests" smpNamesTests describe "Agent core tests" agentCoreTests #if defined(dbServerPostgres) around_ (postgressBracket testServerDBConnectInfo) $