diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,60 @@ +# Changelog for plexus-synapse + +## 4.0.0 + +Everything since 3.17.3 (3.17.4 was never published; its change is listed here). + +### Breaking + +- **IR 3.0, on the plexus 0.7 schema.** Requires `plexus-protocol >= 0.6`. + A method's `returns`, `error`, `progress` and `cardinality` are read from + its schema, never guessed; servers on the published 0.7.0 line are still + read, cardinality taken from the method's own `streaming` flag. A title + collision (two types under one title) refuses that activation by name + (`-i` exits 65 and says what was left out) instead of failing the whole + walk. +- **Holder protocol 4.** The connection holder's socket is + `$XDG_RUNTIME_DIR/synapse/holder-4.sock`. A 4.0 run never uses or + replaces a 3.x holder (`holder-2.sock`), nor the reverse; the two run + side by side. +- **Schema cache moved** to `$XDG_CACHE_HOME/synapse/schemas-4` + (`~/.cache/synapse/schemas-4`). 3.x's `schemas` directory is never read, + so a 4.0 run and a rolled-back 3.x never share an entry. The first 4.0 + run against a service fetches its schemas again. +- **A failed stream exits non-zero.** An error item, or a data item whose + content has `type: error`, sets exit status 1. Services report their + failures in band; scripts that relied on exit 0 after such a stream will + now see 1. +- **One holder per user**, not one per address and agent. The agent rides + in each request; a connection whose server is gone is let go at once; at + most 256 connections are held, the longest idle closed first; the newest + synapse takes over holding. + +### Added + +- **Streaming input (`Input`, plexus-wire spec/10).** `--input -` (stdin) + or `--input @FILE` sends a method's input half: lines, NDJSON items, or + raw bytes as binary frames (`--chunk N`, 4096 by default, at most + 16 MiB), sent as the service grants credit, ended at EOF, carried through + the holder. A disconnect is reported with sent / acked / unacked counts + and never resent (exit 69); typed closes exit 70, 65 or 77, a failed read + 74. `--progress` prints sent / acked / credit on stderr once a second. A + flag whose name a method parameter already has (`input`, `chunk`, + `progress`) becomes `--input-stream`, `--input-chunk` or + `--input-progress`. The IR reads a bytes input as string/binary. +- **The service's own `ir` first.** When a service's root schema lists an + `ir` method, synapse asks it for the whole IR in one call instead of one + schema call per activation; otherwise it walks the raw schemas as before. + A 0.7.0 service spends no call on it. +- The server's own error message is shown and kept; an unknown error kind + is rendered `kind: message`, and a missing grant as the Rust side writes + it. Re-sign-in and cache repair work against both 0.8 and 0.7.0 servers. + +### Changed + +- `cabal.project` no longer lists `../plexus-protocol`; it comes from + Hackage. +- The suites that need a live service (`cli-test`, `websocket-raw-test`, + `ir-test`, `bidir-integration-test`) are opt-in behind the manual flag + `live-tests` (`cabal test -f live-tests`), so a default `cabal test` + needs nothing running. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1199 @@ +# Synapse + +**A CLI that writes itself from your API.** + +Synapse is the command-line frontend for [Plexus RPC](../plexus-protocol/) — a streaming JSON-RPC 2.0 protocol built for LLM orchestration. Define methods in Rust, and Synapse discovers them at runtime: commands, help text, parameter validation, and output rendering all come from the schema. No codegen, no static config. + +``` + ┌─────────────┐ + │ Substrate │ Rust backend service + │ (Plexus) │ hosts activations + └──────┬──────┘ + │ WebSocket JSON-RPC 2.0 + │ streaming responses + ┌──────┴──────┐ + │ Synapse │ Haskell CLI + │ discovers │ builds commands from schema + │ & invokes │ renders streaming output + └─────────────┘ +``` + +## Two problem domains synapse solves + +1. **Schema-driven invocation.** Method discovery, parameter parsing, help text, and output rendering are all derived live from the backend's JSON Schema. No codegen, no static config — change the backend, the CLI follows. + +2. **Credential lifecycle.** Per-backend defaults at `~/.plexus//defaults.json` hold cookies and headers as **credential-reference URIs** (`literal:`, `env://`, `file://`, `keychain://`) resolved at request time. JWT decoding surfaces expiry inline (`expired 16d ago`), legacy `~/.plexus/tokens/` files auto-migrate, and the `_self` subcommand lets you inspect, set, and rotate credentials without ever pasting them into a shell. See [Credentials & Headers](#credentials--headers). + +## The Full Picture: Define → Call + +### 1. Define a method in Rust + +An **activation** is a namespace of related methods. You define one by annotating an impl block: + +```rust +use schemars::JsonSchema; +use serde::{Deserialize, Serialize}; + +// Event type — what the method streams back +#[derive(Debug, Clone, Serialize, Deserialize, JsonSchema)] +#[serde(tag = "event", rename_all = "snake_case")] +pub enum EchoEvent { + Echo { message: String, count: u32 }, +} + +// The activation +pub struct Echo; + +#[plexus_macros::activation( + namespace = "echo", + version = "1.0.0", + description = "Echo messages back" +)] +impl Echo { + #[plexus_macros::method( + description = "Echo a message back the specified number of times", + params( + message = "The message to echo", + count = "Number of times to repeat (default: 1)" + ) + )] + async fn echo( + &self, + message: String, + count: u32, + ) -> impl Stream + Send + 'static { + stream! { + for i in 0..count { + yield EchoEvent::Echo { + message: message.clone(), + count: i + 1, + }; + } + } + } + + #[plexus_macros::method( + description = "Echo a message once", + params(message = "The message to echo") + )] + async fn once( + &self, + message: String, + ) -> impl Stream + Send + 'static { + stream! { + yield EchoEvent::Echo { message, count: 1 }; + } + } +} +``` + +The macro generates the JSON-RPC server, `Activation` trait impl, method enum, and JSON Schemas — all from the function signatures and `JsonSchema` derives. Register it with the service: + +```rust +let service = DynamicService::new("substrate") + .register(Echo::new()) + .register(Health::new()) + .register(Cone::new()); +``` + +That's the entire backend. No route tables, no handler boilerplate, no schema files. + +### 2. Call it from Synapse + +```bash +# Install +cd synapse && cabal install + +# Synapse discovers the echo activation and its methods automatically +$ synapse substrate echo once --message "hello" +message: hello +count: 1 + +$ synapse substrate echo echo --message "hello" --count 3 +message: hello +count: 1 + +message: hello +count: 2 + +message: hello +count: 3 +``` + +Every method you add to the Rust backend is immediately available as a CLI command. The parameter names, types, descriptions, and validation all come from the schema. + +### 3. See what's on the wire + +```bash +# Dry-run: show the JSON-RPC request without sending +$ synapse --dry-run substrate echo echo --message "hello" --count 3 +{"method":"echo.echo","params":{"message":"hello","count":3}} + +# JSON mode: see the raw stream items +$ synapse --json substrate echo echo --message "hello" --count 3 +{"type":"data","content":{"event":"echo","message":"hello","count":1}} +{"type":"data","content":{"event":"echo","message":"hello","count":2}} +{"type":"data","content":{"event":"echo","message":"hello","count":3}} +{"type":"complete"} + +# Fetch the JSON Schema for the activation +$ synapse --schema substrate echo +{"namespace":"echo","methods":[...]} +``` + +## The Registry + +Plexus backends register themselves with a **registry** — a central service that tracks what's running and where. Synapse talks to the registry by default (at `localhost:4444`), so you never need to know host:port pairs for individual backends. You just use the backend by name: + +```bash +# This just works — the registry resolves "substrate" to its host:port +synapse substrate echo once --message "hello" +``` + +When you run `synapse` with no arguments, it queries the registry and lists everything available: + +```bash +$ synapse +Available backends: + substrate 127.0.0.1:4444 [OK] + lforge 127.0.0.1:4447 [OK] + secrets 127.0.0.1:4446 [OK] +``` + +If your backend isn't showing up, it needs to register with the registry. Synapse also auto-registers backends it connects to directly — so if you point at a non-default port once, it becomes available by name for future calls: + +```bash +# Direct connection (also registers with the registry at :4444) +synapse -P 4447 lforge hyperforge repos_list --org juggernaut + +# Now this works without -P +synapse lforge hyperforge repos_list --org juggernaut +``` + +The key mental model: **don't think in terms of hosts and ports.** Register your backends, then use them by name. The registry is the source of truth. + +## A service behind TLS: `--url wss://…` (SCAFFOLD-21, 3.15.0) + +A hosted app sits behind a proxy that terminates TLS and routes its socket +at a path — every app on the house's edge is `wss://.menger.sh/ws`. +Name it with `--url`, before the backend name like every global option: + +```bash +synapse --url wss://hostdemo.menger.sh/ws hostdemo greeter hello --name Ada +synapse --url wss://hostdemo.menger.sh/ws -j hostdemo greeter count --to 3 +synapse --url wss://hostdemo.menger.sh/ws -s hostdemo greeter # the schema +synapse --url wss://hostdemo.menger.sh/ws # the backend there, [OK] +synapse -H hostdemo.menger.sh --tls --path /ws hostdemo greeter hello --name Ada # the same address +``` + +| option | meaning | +| -- | -- | +| `--url ws[s]://HOST[:PORT][/PATH]` | the whole address; the port defaults to the scheme's (80, 443), the path to `/`. Not with `-H`/`-P`/`--tls`/`--path`; `http(s)://` is refused with the `ws(s)://` it means | +| `--tls` | dial `wss://` at `-H`/`-P` (port 443 unless `-P`) | +| `--path PATH` | the socket's path at `-H`/`-P` (default `/`) | +| `--cacert FILE` | with wss, also trust the CA certificate(s) in this PEM file (repeatable) | + +**The certificate is always verified**: the chain against the system's trust +store (the distribution's bundle; `SYSTEM_CERTIFICATE_PATH` points synapse at +another directory or file) and the name against the host, which is also sent +as SNI. A failed check fails the handshake before any of the request — a +token included — is sent. There is no switch that skips the check: for a local +CA (a throwaway proxy, `caddy … tls internal`), pass its root with `--cacert`. + +**Everything rides the same address**: the `_info` probe, calls, streams and +their reconnects (SYNAPSE-20 — the outage line names the URL), `-s`, `-i`, +`_find`, bidirectional requests and their `respond`, `_login` / `_logout` and the +session every later call carries. The upgrade's `Host` is the host alone on 443 +(`host:port` otherwise). A registry lists plain `ws://HOST:PORT` backends, so an +address behind TLS or on a path is never auto-registered: name it each time, +or put `--url` in a shell alias. + +**Sessions are kept per URL.** A plain `ws://HOST:PORT/` keeps the key it +always had (`~/.plexus/sessions/HOST_PORT/`, keychain `backend=HOST:PORT`), so +no stored session moves. Any other address is keyed by its URL with the port +written — `~/.plexus/sessions/wss_hostdemo.menger.sh_443_ws/AGENT.json`, +keychain `backend=wss://hostdemo.menger.sh:443/ws` — so a ws and a wss backend +on one host, or two paths, never share a session. Sign in with the options +the calls use: + +```bash +synapse --url wss://app.example/ws _login app --key builder --as builder +synapse --url wss://app.example/ws app tickets health # carries builder's session +``` + +An agent's key proof names the server's socket origin as its audience: +`ws://HOST:PORT` on a plain address (as before), `wss://HOST` (`:PORT` when +not 443) behind TLS — what a service run with `--public-url https://HOST` accepts +(plexus-login's `socket_urls`). The path is not part of it. + +## Progressive Discovery + +Once you're connected, just start typing. Synapse navigates the backend like a filesystem — each level shows what's available, so you never need external docs: + +```bash +# What can substrate do? +$ synapse substrate + arbor Tree-structured conversation storage + bash Execute bash commands + cone Conversational AI sessions + echo Echo messages back + health Health check endpoint + +# What methods does echo have? +$ synapse substrate echo + echo Echo a message back the specified number of times + once Echo a message once + +# What does cone chat need? (auto-help when required params are missing) +$ synapse substrate cone chat +chat - Conversational interaction with a cone + + --identifier.type (required) + Discriminator for cone lookup (by_id, by_name) + + --identifier.name (required if type=by_name) + --prompt (required) + User message to send + +# Inspect the raw JSON Schema for an activation +$ synapse --schema substrate cone +``` + +### Help and search: `_find` + +A listing (`synapse -P 4455 menger`, `… menger tickets`) is one line per +activation and method; a method's page (`… tickets set_status --help`) is its +usage, aligned options and examples (SYNAPSE-12, SYNAPSE-13). When you don't +know the name, search for it (SYNAPSE-17): + +```bash +$ synapse -P 4455 _find menger comit +5 matches for 'comit' (as 'commit') in menger + +METHODS + tickets link_commits Link commits to a ticket, or to many + tickets unlink_commits Unlink commits from a ticket + +PARAMETERS + deployments record [--commits ] Every commit in previous..revision… + tickets link_commits --commits Commit references, in link order + tickets unlink_commits --commits Commit references to remove… + +Run 'synapse -P 4455 menger tickets link_commits --help' for its options. +``` + +`synapse [OPTIONS] _find [activation…] [--limit N] [--methods | --params]` + +- Every method and parameter whose name or description matches **all** the + words, best first: an exact name, then a name's prefix (or a `snake_case` + segment's), then an abbreviation (`setpar` → `set_parent`, prefixes of its + segments in order) or a typo (one edit for 4–7 letters, two beyond), then a + word of a description. Ties: the shorter path, then alphabetical. +- Grouped `METHODS` · `PARAMETERS` · `MENTIONED IN` (found only in a + description; left out for a method already listed above). A parameter line is + its method, its flag as the method's page shows it (`[brackets]` when + optional) and its description, with `[values: …]` under it. +- The header says what a typo or an abbreviation was taken as; on a terminal + the matched characters are bold (piped, or with `NO_COLOR`, plain text). +- Activation names before the words narrow it: `_find menger tickets setpar`. + `--limit N` (default 20; the footer says how many more), `--methods` / + `--params` for one group. Nothing found: the three nearest names, exit 1. +- `-j` (before `_find`): one JSON object per hit — `kind` (method | param), + `path`, `param`, `type`, `required`, `description`, `values`, `group`, + `score`, `matched`. +- Under login it searches the caller's view of the schema: a method the caller + can't see is never a hit. The IR is kept in `~/.cache/synapse/ir` under the + root schema's hash (and the caller's view), so a search costs one schema call + while nothing has changed; `--no-cache` walks the backend again. + +## Parameters + +Synapse parses flags into typed JSON using the schema's IR: + +```bash +# Simple flags +synapse substrate echo echo --message "hello" --count 3 + +# Dotted keys for nested objects +synapse substrate cone chat \ + --identifier.type by_name \ + --identifier.name my-assistant \ + --prompt "hello" + +# Lists — repeated flags or comma-separated (see Lists below) +synapse substrate tags set --tags backend --tags critical +synapse substrate tags set --tags backend,critical,urgent +synapse substrate tags set --tags '"red, green",blue' # an element with a comma + +# Boolean flags (bare flag = true) +synapse substrate cone create --ephemeral +synapse substrate cone create --ephemeral=false + +# A value may begin with dashes; --key=value works too +synapse substrate echo once --message "--- starts with dashes" +synapse substrate echo once --message @note.md + +# Raw JSON override +synapse substrate cone chat -p '{ + "identifier": {"type": "by_name", "name": "my-assistant"}, + "prompt": "hello" +}' +``` + +Path parameters (`--path`, `--working_dir`, etc.) expand `~`, resolve relative paths, and substitute `$ENV` variables automatically. **No other value is touched**: `--body 'costs $HOME'` sends `costs $HOME`. (Before 3.14.2 every value had `$VAR` substituted — a ticket body read from a file with `--body "$(cat body.md)"` lost its literal `$HOME`, `$PATH`, … The shell already expands what you leave unquoted, so synapse doing it again only ever rewrote text you had protected.) + +### Flag values + +Once synapse has found the method, it reads each flag by its parameter's type: + +| typed | read as | +| -- | -- | +| `--body VALUE` | the next argument is the value, whatever it begins with: `---`, `--force`, `-5`, `--`, or nothing (`''`) | +| `--body=VALUE` | everything after the first `=`, which may be empty or contain `=` | +| `--body @body.md` | the file's contents, UTF-8, exactly as they are (3.14.8, SYNAPSE-10): no argument carries the value, so a body may be as large as the backend accepts; `~/` and a relative path resolve as the shell's would; a file that cannot be read is a refusal naming the flag and the path | +| `--body -` | standard input, read once however many values ask for it; it cannot be combined with `--bidir-mode json`, which reads stdin too | +| `--handle @@alice` | the text `@alice`: one `@` is dropped, so a value that really begins with `@` can still be sent | +| `--summary` (a boolean) | `true`; it takes the next argument only when that is `true` or `false` (or `1`, `0`), so `--summary --limit 3` is two flags | +| `--summary=false` | `false` | +| `--no-such x` (names no parameter) | `Unknown parameter: --no-such`, nothing is sent; such a flag takes the next argument unless it begins with `--` | + +So a markdown body with frontmatter passes as itself: `--body @body.md`, or `--body "$(cat body.md)"` while it is under the shell's 128 KB argument cap. The same sources serve `-p`: `-p @params.json` and `-p -`. Only the flag's name is normalized (`--blocked-by` is `blocked_by`), never its value. An argument that no flag takes (`--summary yes`) is an error, and nothing is sent. `--help` is always help, even right after a flag: to send the text `--help`, write `--body=--help`. Synapse's own options (`-P`, `-n`, `--json`, …) still go before the backend name. + +**Changed in 3.14.1.** Through 3.14.0 a value that began with `--` was read as the next flag (`--body "---…"` failed with `Unknown parameter: --_`), any flag followed by another flag was bare whatever its type, and `--body=…` was read as a flag named `body=…`. + +### Lists + +A list parameter takes its elements one flag at a time, several to a flag, or both. When the elements are scalars (strings, integers, numbers, booleans, or a named type that is one of those, such as an id or a string enum), each flag value is read as one comma-separated record, with double quotes for an element that contains a comma: + +| flag value as synapse receives it | elements | +| -- | -- | +| `a,b,c` | `a` `b` `c` | +| `a` | `a` | +| `"a,b,c,d","e,f,g"` | `a,b,c,d` and `e,f,g` — a double-quoted element keeps its commas | +| `"say ""hi""",b` | `say "hi"` and `b` — `""` inside quotes is one quote | +| `a, b ,c` | `a` `b` `c` — space around an unquoted element is dropped | +| `a,,b,` | `a` `b` — an empty unquoted element is dropped | +| `"",a` | the empty string and `a` | +| `"a,b` or `"a"x,b` | an error naming the parameter and the value; nothing is sent | + +Repeated flags append in order: `--tags a,b --tags c` is `a` `b` `c`. Elements are then typed as before (`--ids 1,2,3` sends `[1,2,3]` for an integer list). A list of objects, of lists, or of untyped values is not split — each flag value is one element, since JSON has commas of its own. Nothing else splits: a comma in `--title` is just a comma, and `-p '{…}'` is sent as written. ` --help` marks each list parameter with the forms it takes. + +**The shell removes double quotes before synapse runs**, so an element that contains a comma needs its quotes protected by single quotes: + +| typed | what synapse receives | +| -- | -- | +| `--commits a,b,c,e` | `a,b,c,e` — four elements | +| `--multi "a,b,c,d","e,f,g"` | `a,b,c,d,e,f,g` — seven elements; the shell dropped the quotes | +| `--multi '"a,b,c,d","e,f,g"'` | `"a,b,c,d","e,f,g"` — two elements | + +**Changed in 3.14.0.** Through 3.13 every flag value was exactly one element, commas included (`--tags a,b` sent `["a,b"]`). Now a single element that contains a comma must be quoted (`--tags '"a,b"'`), and a value that begins with `"` is read as a quoted element. + +## Credentials & Headers + +Synapse sends a JWT as `Cookie: access_token=` on WebSocket upgrade when one is available, plus any extra cookies or headers you specify. All of these come from a single per-backend defaults file with a priority chain for per-invocation overrides. + +### Defaults store + +Each backend has a JSON file at `~/.plexus//defaults.json` holding default cookies and headers. Values are **credential-reference URIs**, not raw secrets — synapse resolves them at request time. + +```json +{ + "version": 1, + "defaults": { + "cookies": { + "access_token": "literal:eyJhbGc..." + }, + "headers": { + "X-API-Key": "env://MY_API_KEY" + } + }, + "scopes": {} +} +``` + +Supported schemes: + +| Scheme | Example | Meaning | +|---|---|---| +| `literal:` | `literal:eyJ...` | Raw value verbatim after the colon. | +| `env://` | `env://MY_JWT` | Read from environment variable. | +| `file://` | `file:///abs/path` | File contents (trailing newline stripped). | +| `keychain://` | `keychain://uscis/access_token` | OS keychain item (macOS via `security` CLI; Linux/Windows return a "not implemented" error). | + +File mode is content-aware: `0600` if any `literal:` value is present, `0644` if the file is a pure manifest of references. + +#### Threat model for `keychain://` + +The keychain resolver shells out to `/usr/bin/security`. Items it creates have ACLs scoped to the `security` binary itself, not to synapse — meaning **any process running as your user can read them silently** by shelling out to `security` with the matching service/account. What `keychain://` actually protects against: + +- Other users on the same machine +- Plaintext-on-disk leaks (the file contains only URIs; `defaults.json` becomes commit-safe when no `literal:` refs are present) +- Disk theft (the keychain DB is encrypted at rest, unlocked at login) + +What it does **not** protect against: + +- Any process running as you that knows the service/account (`security find-generic-password -s plexus -a <…> -w` works without a prompt) +- A compromised synapse binary + +This is the standard tradeoff for "shell out to `security`" tools (cargo, gcloud, aws-cli all do the same). If you need per-process sandboxing, the upgrade path is to use the Security framework C API directly with code-signing-anchored ACLs — not implemented in v1. + +### Managing defaults: the `_self` subcommand + +```bash +# Inspect current state — decodes JWTs, flags expired tokens +synapse _self show + +# Set a value (auto-wrapped as literal: unless you provide a scheme) +synapse _self set cookie access_token "eyJ..." +synapse _self set header X-API-Key "env://MY_API_KEY" + +# Read from stdin (always literal:, bypasses the scheme heuristic) +cat my-jwt.txt | synapse _self set-from-stdin cookie access_token + +# Import a JWT file into cookies.access_token +synapse _self import-token ~/Downloads/jwt.txt + +# Resolve a single value (debug): prints the resolved concrete value +synapse _self resolve cookie access_token + +# Remove entries +synapse _self unset cookie access_token +synapse _self clear --yes +``` + +`show` decodes JWT-shaped values and prints `alg`, `kid`, `iss`, `aud`, `sub`, `exp` (with human-relative rendering like `"expired 15d 23h ago"` or `"valid for 4m 32s"`), `iat`, `preferred_username`, `email`. Signatures are never printed. + +### Per-invocation overrides + +Four CLI paths populate credentials at call time, highest priority first: + +```bash +# --token takes a JWT, sends it as Cookie: access_token= +synapse --token eyJ... + +# SYNAPSE_TOKEN env +SYNAPSE_TOKEN=eyJ... synapse + +# --token-file reads from a path +synapse --token-file ~/tokens/uscis + +# --cookie / --header add arbitrary key/values on the upgrade request +synapse --cookie session=abc --header X-Trace-Id=xyz +``` + +Invocation flags override the defaults store per key. CLI flags apply only to that one call; they don't write to disk. + +### Legacy token file + +The pre-SELF convention was `~/.plexus/tokens/` holding a raw JWT. On the first `loadDefaults` call for a backend that has a legacy file but no `defaults.json`, synapse auto-migrates: the JWT becomes `cookies.access_token = literal:` in the new file, and the legacy file is deleted. An INFO log line names both paths and suggests upgrading to keychain storage. + +## Output Rendering + +Synapse renders streaming responses through a Mustache template pipeline: + +```bash +# Default: schema-aware pretty output +synapse substrate health check +status: healthy +uptime: 12345 + +# --raw: content JSON only (skip template rendering) +synapse --raw substrate health check +{"status":"healthy","uptime":12345} + +# --json: full JSON-RPC stream items +synapse --json substrate health check +{"type":"data","content":{"status":"healthy","uptime":12345}} +``` + +Templates are resolved in order: `.substrate/templates/{namespace}/{method}.mustache` (project-local) → `~/.config/synapse/templates/` (user) → YAML-like fallback. + +Generate templates from the schema: + +```bash +synapse --generate-templates substrate +``` + +### The answer in a file: `-o FILE` (SYNAPSE-39, 3.17.3) + +An answer you mean to read goes to a file, then you read the file — never +through a filter that may stop reading early (a `grep` that cuts a list short, +a `head` that closes on a write): + +```bash +synapse -P 4455 -o /tmp/t.json -j menger tickets list --summary true +synapse -P 4455 --output /tmp/t.txt menger tickets get --id MENGER-12 +``` + +- `-o FILE` / `--output FILE` is a global option (before the service name, + as `-j`). What the call prints goes to FILE instead of stdout, in the same + form a pipe would get (`-j` lines with `-j`, the rendered answer without); + stdout gets nothing, stderr what it always gets. +- It is written to a temporary file beside FILE and renamed over FILE when + the call ends with 0, so a reader never sees half an answer. FILE is + `0600` (an answer may carry a session token — `session login`). +- A call that ends with anything else leaves no FILE — an older FILE is + removed too, so nothing stale is read as this call's answer — and no + temporary file. The exit code is the call's (75, 77, 69…). +- A stream (`watch`) has no end: its items are appended to FILE and flushed + as each comes. A stream that fails keeps what it wrote. +- A write's answer is written whole, whoever reads it. +- What must be seen while the call waits goes to **stderr**, not FILE: a + two-way request (the interactive prompt, `--bidir-mode json`'s and + `respond`'s request lines — the answer still goes to FILE), and under + `-j` an error or a refusal (its `-j` line goes with the failed run's FILE, + so a refused call says why on stderr and exits 77). +- `-o -` is stdout. A FILE that cannot be made (no such directory, a + directory) is said on stderr and the run **exits 73** before anything is + sent; a write to it that fails later (a full disk, a file size limit) is + no outage — the call ends, unretried — and the run **exits 74**. +- A SIGTERM or SIGHUP ends the run as a failed one (143, 129): no FILE and + no temporary file. A SIGKILL can leave the temporary file + (`FILE.tmp`) behind. + +## Outages: reconnecting (SYNAPSE-20) + +synapse rides out a backend that goes away — a restart, a promote, a +network blip — for **ten minutes** by default. + +- **A lost connection is noticed**: the server closing it, a reset, or + silence. While a call is open, synapse pings after 15 s with nothing heard + and counts the connection lost when 10 s more pass without an answer + (`PLEXUS_KEEPALIVE=IDLE[,TIMEOUT]` in seconds, `0` for none). A call is + never left waiting on a dead socket. +- **It retries for the window**: 0.5 s, doubling, to 15 s between tries. + `--reconnect-for 10m` (`90s`, `1h`, `0` = never; or + `SYNAPSE_RECONNECT_FOR`) sets how long. A backend that is down when synapse + starts is waited for the same way (a wrong port that answers something + other than Plexus fails at once). Progress goes to **stderr only**: + + ``` + synapse: connection to 127.0.0.1:4455 lost (the connection was closed) — reconnecting for up to 10m + synapse: retrying 127.0.0.1:4455 in 4s (4s of 10m) + synapse: reconnected to 127.0.0.1:4455 after 8s + ``` + +- **A read is sent again; a write is not.** A method is a read when its + schema's `group` is `read` (else when its name is a read's: `get`, `list`, + `watch`, …); anything else, and anything bidirectional, is a write. A + write whose request went out before the connection was lost may have + happened, so synapse says so and **exits 75** (`connection to … lost + before an answer — the write may have happened; check before sending it + again`). A write that never left (the backend was down when it was + sent) is sent once the backend is back. +- **A stream resumes.** `watch`, `await_reply` and any other streaming read + are subscribed again with the same params. A method that takes `since` + (menger's `await_reply`) gets `since` = the unix time the call began + unless you gave one, so an answer given during the outage is still + delivered. Under `-j` a line marks the resume, in the stream on stdout: + + ```json + {"type":"reconnected","outage_secs":8,"attempts":4,"since":1792204276} + ``` + + (`since` only when the resumed call carried it.) The resumed stream + starts as a new call does — `await_reply` says `waiting` again. Without + `since`, events during the gap may be missing: re-read what you need. + Other modes say it on stderr. +- **After the window**, synapse **exits 69** with the reason (`… unreachable + for 10m (connection refused) — giving up`). It never hangs. +- **A closed stdout is not an outage** (SYNAPSE-26, 3.17.2). When the + reader of synapse's stdout goes — `… | head -1`, `… | grep -m1` — synapse + stops at once and **exits 141** (what a shell says of a filter its pipe + closed on), saying nothing: no retry, no reconnect, a stream unsubscribed, + a write sent once. Whatever window `--reconnect-for` sets, and on `-j` and + the plain printer alike. (Before 3.17.2 the EPIPE was taken for a lost + connection and a write was sent again for as long as the pipe stayed + closed.) The socket's own broken pipe — the service gone — is still an + outage. A stream notices its reader is gone only when it next prints: once + `tickets watch | head -1` has its line, synapse keeps running until the + next event arrives, then exits 141 — with no event, it waits. A run + already ending with a code of its own — 75, 77, 69 — keeps it; 141 only + replaces a success. + +Many agents' calls at once ride out a restart too (SYNAPSE-15): a call +whose stored session the restart ended signs in again from its key under a +lock on that session, and a call that waited for the lock takes the session +the first one made. Sixteen or thirty-two parallel calls after a restart +sign in once and all succeed; a connection refused for the server's +connection limits (429) is waited out like any outage. + +| exit | meaning | +| -- | -- | +| 69 | the backend stayed unreachable for the whole window | +| 75 | a write went out and its answer never came — it may have happened | +| 77 | the service refused the call (AUTH-8) | +| 73 | `-o FILE` could not be made (SYNAPSE-39): nothing was sent | +| 74 | a write to `-o`'s FILE failed (SYNAPSE-39): the call ended there | +| 141 | stdout's reader closed the pipe (SYNAPSE-26): nothing more was sent | + +Through the connection holder (SYNAPSE-28, below) all of this holds as it is. + +## One round trip a call (SYNAPSE-28, 3.16.0) + +A call costs one round trip and the server's time. Against app.menger.sh +(77 ms away) `tickets health` takes **81 ms**, where it took 4.6 s. + +``` +$ synapse --url wss://app.menger.sh/ws --as builder menger tickets health # the first: 2.6 s +$ synapse --url wss://app.menger.sh/ws --as builder menger tickets health # every one after: 81 ms +``` + +Two things make it so: + +- **A connection held between runs**, as ssh's ControlMaster holds one. The + first call starts a holder (`synapse _hold`, a process of synapse's own) + that keeps the signed-in WebSocket open and listens on a unix socket: + `$XDG_RUNTIME_DIR/synapse/holder-4.sock` (0600, in a 0700 directory of + yours). Later runs hand it their requests and read the replies back, so + the TCP, TLS and upgrade handshakes (about 0.3 s to a hosted service) are + paid once. Since 3.17.4 it is **one holder for all your calls** + (SYNAPSE-40, below), a connection in it per address and agent (`--as`), + never shared between agents; it exits after **10 minutes** holding nothing + (`--hold-for 30m`, or `SYNAPSE_HOLD_FOR`). `--no-hold` (`SYNAPSE_NO_HOLD=1`) + skips it: that run dials one connection of its own and closes it. A call + that brings its own credential (`-t`, `--token-file`, `--cookie`, + `--header`, `PLEXUS_SESSION`) never uses a holder. +- **Send first, check on failure.** synapse keeps what a call needs from the + backend in `~/.cache/synapse/schemas-4/` (`$XDG_CACHE_HOME`): where the + backend is, its `_info` as your agent was answered, each activation's + schema (`PATH@VERSION-HASH.json`, pinned by `PATH.pin`) and a **plan** per + method (its schema, its activation's deprecation, the types its flags parse + by: kilobytes, where menger's `tickets` schema is 2.6 MB). A call to a + method it has a plan for is built from the plan and sent: no probe, no + schema fetch. The probe and the fetch run, on the same connection, only + when that fails as the schema explains: a method or flag the cache does not + know, or the server refusing what the cache said (a method it does not + have, under the AUTH gate one only admin holds; params with a field + missing, unknown or of another type). Those refusals come before the + method runs, so the call is then sent again, a write too; the plans it + misled are forgotten. Help, listings, `-s`, `-i` and `_find` always read + the server. + +Everything else is as before. Outages are ridden out by the same rules, a +read sent again and a write never resent blind (exits 69 and 75), because +the holder reports a lost connection, and whether the request had gone out, +exactly as a connection of the run's own would. A session that ended is made +again from the key by the run, and the holder dials a connection with the +new one beside the old, closing the old when idle. A run that goes away +mid-stream (Ctrl-C) ends its call at the server. Twenty runs starting at +once share one connection, and the reads they all ask first (the schema, +`_info`) are asked once. + +Measured against app.menger.sh (ping 77 ms), 2026-10-22: + +| | 3.15.0 | 3.16.0 | +| -- | -- | -- | +| `tickets health`, warm | 4,615 ms | 81 ms | +| `tickets queued`, warm | 7,398 ms | 84 ms | +| 20 `tickets health` at once, warm | 31.6 s | 107 ms | +| the first call (no holder, nothing cached) | — | 2.6 s | +| the first call after the holder exited (cache warm) | — | 380 ms | +| `--no-hold`, cache warm | — | 382 ms | +| 20 at once, no holder, nothing cached | — | 3.1 s | + +The 0.9 s that went before every call in 3.15.0 was a second `_info` probe, +made anonymously on a connection of its own to check the name the first +probe had already answered; a run now probes at most once. + +## One holder for the user (SYNAPSE-40, 3.17.4) + +Through 3.17.3 the holder was one process per address and agent, each +living its 10 idle minutes after its server had gone; a test loop calling +throwaway servers on fresh ports left one per port, 1,634 of them (24.9 GB) +on 2026-11-02. Now one process holds every connection your runs keep, +however many services and agents you call — `synapse _hold`, at +`$XDG_RUNTIME_DIR/synapse/holder-4.sock` — and inside it a connection per +address, agent and credential. A call as one agent never rides another +agent's connection, even when neither carries a credential; a session made +again from the key is a connection beside the old one, which closes once +idle. + +- **A connection whose server is gone is let go at once.** A server that + stops closes its end; the holder notices within a second (a close or a + reset ends the connection's reader; a peer gone silent is caught by the + keepalive, 15 s idle + 10 s) and holds nothing for it from then on. The + next call dials again, and a dial that fails holds nothing, so riding out + an outage stays the run's (SYNAPSE-20: a read sent again, a write never + resent blind, exits 69 and 75). +- **Idle, closed.** A connection is kept idle for the `--hold-for` of the + last call on it (10 minutes unless the call says), then closed; the + holder exits once it has held nothing, with no call, for its own + `--hold-for` (the run that started it said). +- **A cap**: 256 connections (`SYNAPSE_HOLD_MAX`, read when the holder + starts; 0: none). Past it the one idle longest is closed first; one + carrying a call never is, so a burst of open calls may pass it until they + end. A live connection costs the holder about 96 kB (403 held: 17.2 MB → + 55.8 MB), so at the cap it stays under about 45 MB. +- **What it holds**: `synapse _hold status` prints it as JSON — its pid, + version and protocol, the cap, and each connection's address, agent, + calls under way and seconds idle (never a credential); exit 1 when no + holder answers. +- **SIGTERM / SIGHUP** stop it taking runs at once and give the calls under + way ten seconds; a stream still open then is told its connection was + lost and resumes through the next holder (SYNAPSE-20). +- **The newest synapse holds.** The holder says its version when it takes a + request; a run of a newer synapse then puts its own holder in its place + (the old one lets go of the socket at once, closes what is idle, + finishes what it carries and exits), and a run of an older one never + replaces a newer, so the newest in use serves every run and two never + take turns. +- **What it takes from the run that starts it**: nothing it does not need. + It starts in `/` (it keeps no directory in use), without the run's + `PLEXUS_KEY`, `PLEXUS_SESSION`, `SYNAPSE_TOKEN` or `PLEXUS_KEEPALIVE` + (one run's keepalive would be every connection's). It does keep that + run's other environment (`SYSTEM_CERTIFICATE_PATH`, say) and its cgroup: + a holder first started inside a systemd unit stops with the unit, and + the calls it carried then end as an outage does (a read sent again, a + write that went out exit 75). + +The socket's name carries the holder's protocol (2): a synapse that changes +the wire or what the holder does bumps it and gets a holder of its own. +synapse 3.16.0 to 3.17.3 keep their holder per address and agent +(`ADDRESS@AGENT-VERSION.sock`, in the same directory), which this one never +opens, removes or answers, so a pinned older binary goes on as it was. A +loop over throwaway servers still sets `SYNAPSE_NO_HOLD=1` while any agent +there runs one. + +Measured on 2026-11-02 (hold-test, the built synapse against mock services +in the test's process): + +| | 3.17.3 | 3.17.4 | +| -- | -- | -- | +| holders, 3 addresses × 2 agents | 6 | 1 | +| holders, a loop of 20 calls to 20 short-lived servers | 20 | 1 | +| a loop of 500 calls to 500 short-lived servers | — | 1 holder, 103 s; RSS 29.8 MB at call 50, 31.2 MB at 500; nothing held 10 s on | +| connections held to stopped servers, 10 s on | each holder's, for 10 min | 0 (let go within a second) | + +## A stream in: `--input` (BIDIR-18) + +A method with an input half (`Input`, plexus-wire spec/10: its schema +has `input` beside `params`) takes a stream in beside its stream out. +stdin (`--input -`) or a file (`--input @path`) is that stream: + +```bash +tail -f build.log | synapse --url wss://app.menger.sh/ws --as runner menger runs append_log --run 41 --input - +synapse -P 4460 svc ingest tokens --run r1 --input @tokens.jsonl +arecord -q -f S16_LE -r 16000 -c 1 | synapse -P 4460 voice listen --input - --chunk 640 +# stderr, at the end or on a disconnect: +# input: sent 1,204 items in 1,204 frames · acked through seq 1,179 · 25 unacked +``` + +- **What an item is** comes from the item's schema: a string is a line; an + `Input` (`"x-plexus-binary": true`) is the bytes as they come, up + to `--chunk N` (4096 unless said, at most 16 MiB) a frame — what the + source has is sent, never held to fill a chunk — each a WebSocket binary frame + (`[0x01][subscription u64][seq u64][payload]`); anything else is NDJSON, + one JSON value a line — a line that is not one is named by its number, + no frame carries it, the call is ended and synapse exits 65. +- **Under credit**: items are read only as the service grants credit, so + with none, synapse reads nothing more and the pipe in front of it is the + buffer — its memory stays flat however far the writer runs ahead. What is + ready goes out together (up to 256 items a frame), and a whole line goes + out while the next is still arriving. At the end of the input, + `.end` — at once, credit or none; only the end of the input ends it + (a failed read ends the call with exit 74, no `end`). The answer prints + as any call's. +- **Never sent twice** (spec/10: no resume). A connection lost during the + call is said on stderr every time, with what was sent and acked, and the + run exits 69. A typed close exits by its kind: `past_credit` 70 (a bug in + synapse), `invalid_input` / `out_of_sequence` / `too_much_input` 65, an + input closed for a revoked or ended sign-in 77. +- `--progress` prints sent / acked / credit on stderr once a second; `-n` + prints the open frame and the first input frame and sends nothing; a + method's `--help` and `_find` say it takes a stream in. A parameter named + `input` keeps `--input` (the stream is then `--input-stream`; `--chunk` + and `--progress` likewise become `--input-chunk` / `--input-progress`). +- The frames go through the connection holder (holder protocol 4) or, with + `--no-hold`, on the run's own socket — the same frames either way. + +## Code Generation + +Synapse emits a structured Intermediate Representation for building typed clients: + +```bash +$ synapse --emit-ir conformance > conformance.ir.json +``` + +IR 3.0 (plexus 0.7) carries each method's contract as its schema states it: +its item type (`mdReturns`), its error type when it can say no (`mdError`), +its progress type when it reports progress (`mdProgress`), and whether it +yields one item or many (`mdCardinality`). An excerpt of RETURNS-7's +conformance fixture, whose whole IR is +`plexus-macros/fixtures/conformance/expected/ir.json`: + +```json +{ + "irVersion": "3.0", + "irTypes": { + "conformance.Loaded": { + "tdKind": {"tag": "KindStruct", "ksFields": [ + {"fdName": "items", "fdRequired": true, "fdType": {"tag": "RefPrimitive", "contents": ["integer", "uint32"]}} + ]} + }, + "conformance.LoadError": { + "tdKind": {"tag": "KindEnum", "keDiscriminator": "type", "keVariants": [ + {"vdName": "too_many", "vdFields": [ + {"fdName": "max", "fdRequired": true, "fdType": {"tag": "RefPrimitive", "contents": ["integer", "uint32"]}}, + {"fdName": "n", "fdRequired": true, "fdType": {"tag": "RefPrimitive", "contents": ["integer", "uint32"]}} + ]} + ]} + } + }, + "irMethods": { + "conformance.load": { + "mdCardinality": "many", + "mdParams": [ + {"pdName": "n", "pdType": {"tag": "RefPrimitive", "contents": ["integer", "uint32"]}, "pdRequired": true} + ], + "mdReturns": {"tag": "RefNamed", "contents": {"qnNamespace": "conformance", "qnLocalName": "Loaded"}}, + "mdError": {"tag": "RefNamed", "contents": {"qnNamespace": "conformance", "qnLocalName": "LoadError"}}, + "mdProgress": {"tag": "RefNamed", "contents": {"qnNamespace": "conformance", "qnLocalName": "LoadStep"}} + } + } +} +``` + +Nothing is inferred: `mdCardinality` is the schema's `cardinality`, and every +`RefNamed` has a `TypeDef` — a struct, a tagged enum (`keDiscriminator` is the +property every variant gives a `const`, whatever it is called; a newtype +variant over a struct carries the struct's fields), a string enum or an alias. +One title in one namespace is one type: two methods whose schemas give a title +the same shape share one `TypeDef`, and two shapes under one title fail the +build, naming both methods. Identical types in different namespaces are then +deduplicated (prefer the parent namespace, then the shortest). + +### IR 2.1: read whole, or refused by name (SYNAPSE-CC-8, 3.17.0) + +Every schema is read whole or refused; nothing is dropped. The reader +(`src/Synapse/IR/Read.hs`) is pure: a value and the refusals met. + +- **Unions.** A `oneOf` / `anyOf` is a string enum (every member an `enum` + or a `const` of strings: `TransitionField` is `status, kind, archive`), a + tagged enum (`KindEnum`, `keDiscriminator` the property every member gives + a string `const` — `type`, `kind`, `event`, …; a newtype variant carries + its struct's fields), an externally tagged enum (`keRepr: "external"`, + `keDiscriminator: ""`: `{"browser": {…}}`), an untagged union of named + types (`keRepr: "untagged"`, each variant's `vdRef`), or a nullable + (`RefOptional`). `keRepr` is left out when internal, so 2.0's enums read + as before. Any other union is refused, naming the member it could not read. +- **Refusals.** `irRefusals` lists each site the IR cannot type + (`rfSite`, `rfKeyword`, `rfVariant`, `rfDetail`; left out when empty). + Where a refused site stood the IR says `RefUnknown`; a refused type is left + out and its uses say `RefUnknown`. With refusals, `synapse -i` still prints + the IR on stdout, names each site on stderr and **exits 65**; no generator + may run on it. Calls, help, flags and `_find` ignore refusals. +- **Sites** are `[.].`, `()`, + ` returns`, with `[]` (element), `?` (optional), `{}` (map + value) and `.N` (tuple element): `tickets.Component.preview[].0`. +- **The JSON type.** A `serde_json::Value` is a type, not a gap: `true`, + `{}`, annotations only, `type` naming all six JSON types (`["null", + "boolean", "number", "string", "array", "object"]`, as plexus-core writes + it since SYNAPSE-CC-9) or a `$ref` to a definition named `Json` is + `RefJson` (`{"tag": "RefJson"}`): `JsonValue` / `Json` / + `serde_json::Value` in a client. Still refused: a bare `{"type": + "object"}` (neither properties nor additionalProperties), an array with no + items, a type list that is neither one type (± null) nor all six. IR 2.0's + `RefAny` reads as `RefJson`. +- **New refs.** `RefMap V` (an object with `additionalProperties: V` and no + properties), `RefTuple [..]` (`prefixItems` with `minItems = maxItems` = + its length), `RefRefined base {minimum, maxLength, …}` (only a bound the + format does not imply: `minimum: 0` on a `uint64` adds nothing), and + `RefChild ""` (a static or dynamic child's return: its client). An + rpc method with no `returns` is refused at ` returns`. +- **Injected params** (`x-plexus-source` other than `rpc`) are not in + `mdParams`: they are `mdInjected` (`ipName`, `ipSource` verbatim, + `ipDescription`; left out when empty). Help still shows them. +- **`mdInput`** is a method's `input` schema as a type, reserved for + BIDIR-6; left out when absent (no server sends it yet). +- **The closed keyword list.** A schema in a type position uses only `type + $ref properties required additionalProperties items prefixItems oneOf + anyOf enum const format minimum maximum exclusiveMinimum exclusiveMaximum + minLength maxLength pattern minItems maxItems default description title + examples deprecated $schema $defs definitions x-plexus-source + x-plexus-values`, and `allOf` as IR 3.0 reads it (`allOf: [X]` is X; + `allOf: [{"$ref": S}]` beside a tag is a newtype variant over S); any + other (`multipleOf`, an `allOf` of more, …) is refused by name. +- **Where a shared type lives.** The same type (name and structure) in + several namespaces is kept once, in the namespace whose methods and types + refer to it most; a tie goes to the namespace that is an ancestor of the + others, then the shortest name, then alphabetical; the protocol root `""` + only when no generated namespace has a copy. +- **Caches.** A plan or a `_find` catalogue holding another IR version + (3.16.0's 2.0) is not read; it is built again. + +`bench/IRBench.hs` (`cabal bench ir-bench`) times the builder alone over +menger's 2026-10-29 schemas (`test/fixtures/ir-coverage`), with no network; +`ir-coverage-test` holds one fixture per construct, menger whole (21 +refusals; the IR equal to `menger-2026-10-29.ir-2.1.json`), and the guard +that every construct 2.0 already typed serializes as before. + +### Servers on the published 0.7.0 line (RETURNS-36) + +synapse 4.0 reads plexus 0.8's schema and frames strictly, and the +published 0.7.0 line's too, by what that server itself declares +(plexus-protocol 0.6, as plexus-core's child seam reads an old peer): a +method with `streaming` and no `cardinality` is many when the flag is +true, else one, and its missing `returns` is `{}`; an error frame with no +typed `error` is typed from its `error_kind`, else its `code` (its fields +kept); a progress frame with no `content` is `Note {message, +percentage}`. A method that states neither `cardinality` nor `streaming` +is refused. `--emit-ir` against a 0.7.0 server writes IR 3.0 with those +cardinalities. + +### Where IR 3.0 is built (RETURNS-36) + +- The types and the version: `src/Synapse/IR/Types.hs` — `IR`, + `MethodDef` (`mdReturns`, `mdError`, `mdProgress`, `mdCardinality`), + `TypeDef`/`TypeKind`/`TypeRef`, and `currentIrVersion = "3.0"`, which + `emptyIR` and the metadata's `gmIrVersion` carry. +- The reader: `src/Synapse/IR/Read.hs` (`readRoot`, `readDefs`, + `readType`, `rootNamed`) — each schema position read whole or refused. +- The builder: `src/Synapse/IR/Builder.hs` — `buildIR` (a walk), + `buildIRFromSchema backend path schema` (pure: one `PluginSchema`, no + metadata), `finalizeIR` (placement, dangling refs to `RefUnknown`, + refusals sorted), `checkTitles` (one title, one type: `TitleCollision`). +- The golden: `test/IR3Spec.hs` builds `buildIRFromSchema "conformance" + ["conformance"]` from `plexus-macros/fixtures/conformance/expected/schema.json` + and compares it byte for byte (keys sorted, two-space indent, one + newline) with `ir.json` beside it; `CONFORMANCE_FIXTURE_DIR` points it + at a copy, `SYNAPSE_GOLDEN_ACCEPT=1` rewrites `ir.json`. + +## Client Generation (synapse-cc) + +[**synapse-cc**](../synapse-cc/) (Synapse Compiler Collection) is a separate project that consumes Synapse's IR to produce typed client libraries. It imports plexus-synapse as a library, generates IR from a live backend, pipes it through [service-codegen](../service-codegen/) (a stateless Rust code generator), then handles merging, dependencies, building, and testing. + +```bash +synapse-cc init # scaffold synapse.config.json +synapse-cc build # generate typed client from config +synapse-cc watch substrate # rebuild on schema changes +``` + +The generated client gives you typed methods matching the backend 1:1: + +```typescript +const client = new SubstrateClient("ws://localhost:4444"); + +for await (const event of client.echo.echo({ message: "hello", count: 3 })) { + console.log(event.message, event.count); +} +``` + +Three-way merge preserves user edits across regeneration. See the [synapse-cc architecture doc](docs/architecture/16673264336036332543_synapse-cc-pipeline.md) for the full pipeline, config format, and caching strategy. + +## Error Messages + +```bash +$ synapse substrate invalid-plugin +Command not found: 'invalid-plugin' at substrate + +Available at substrate: + Methods: + schema - Get schema information + health - Health check endpoint + + Child plugins: + arbor - Tree-structured conversation storage + bash - Execute bash commands + cone - Conversational AI sessions + +$ synapse substrate cone chat --mesage "hello" +Unknown parameter: --mesage + +Did you mean: --message? +``` + +## Debugging & Testing + +Synapse provides built-in tools for debugging connections and validating protocol compliance. + +### Connection Debugging + +Test the complete connection stack (TCP → HTTP → WebSocket → RPC): + +```bash +synapse _self debug localhost 5001 substrate +``` + +This tests each layer sequentially: +- **TCP**: Can we reach the port? +- **HTTP**: Does the server respond to HTTP? +- **WebSocket**: Can we upgrade to WebSocket? +- **RPC**: Can we call `_info`? + +### Protocol Validation + +Run the full protocol compliance test suite: + +```bash +synapse _self validate localhost 5001 substrate +``` + +This calls the `_debug.*` endpoints (enabled with `PLEXUS_DEBUG=true` on the server) and validates: +- StreamDone messages are sent +- Metadata structure is correct +- Field naming follows conventions +- Progress percentages are in range + +### Test Arbitrary Methods + +Test any method with protocol validation: + +```bash +# Use CLI flags for connection settings +synapse -P 5001 _self test substrate.ping.pong --message "test" + +# Test with schema validation +synapse -P 5001 _self test substrate.echo.echo --message "hello" --count 3 + +# Allow unknown parameters (warns but passes through) +synapse -P 5001 _self test --allow-unknown substrate.echo.echo --fake "value" + +# Use raw JSON (skips schema validation) +synapse -P 5001 _self test --raw '{"message":"hello"}' substrate.echo.echo +``` + +**Important**: Connection settings come from `-H`/`--host` (default: `127.0.0.1`) and `-P`/`--port` (default: `4444`) flags, not positional arguments. This ensures the test uses the same connection that discovery validated. + +### Port Scanning + +Discover backends running on common ports: + +```bash +synapse _self scan +# Scans ports 4440-4459 for Plexus backends +``` + +## Architecture + +Synapse treats the plugin hierarchy as a **category** and implements operations as **algebras** over recursion schemes: + +```haskell +type SynapseM = ExceptT SynapseError (ReaderT SynapseEnv IO) + +-- Navigate to a path (paramorphism — fold with access to original structure) +navigate :: Path -> SynapseM SchemaView + +-- Walk the full tree (hylomorphism — fused unfold + fold, no intermediate tree) +walkSchema :: (SchemaF a -> SynapseM a) -> Path -> SynapseM a + +-- Build IR (hylomorphism with parallel child fetching) +buildIR :: Path -> SynapseM IR +``` + +The base functor: + +```haskell +data SchemaF a + = PluginF PluginSchema Path [a] -- Interior node (namespace with children) + | MethodF MethodSchema Text Path -- Leaf (invocable method) +``` + +Schemas are fetched lazily during navigation, cached by content hash, with cycle detection for recursive plugin graphs. + +## Project Structure + +``` +synapse/ + app/Main.hs # CLI entry, two-phase arg parsing, dispatch + src/Synapse/ + Monad.hs # SynapseM effect stack, error types + Transport.hs # WebSocket JSON-RPC bridge + Schema/ + Types.hs # Path, PluginSchema, MethodSchema, NavError + Functor.hs # SchemaF base functor, Fix + Algebra/ + Recursion.hs # cata, ana, hylo, para, apo (pure + monadic) + Navigate.hs # Path navigation (paramorphism) + Walk.hs # Tree walking (hylomorphism) + Render.hs # Schema → text rendering + CLI/ + Parse.hs # IR-driven --flag parsing → typed JSON + Help.hs # Auto-generated help from IR + Transform.hs # Path expansion, env var substitution + Template.hs # Mustache template generation from IR + IR/ + Types.hs # IR, TypeDef, MethodDef, TypeRef + Builder.hs # Schema → IR (hylomorphism + type dedup) + Backend/ + Discovery.hs # Registry discovery, health checks + Self/ + Commands.hs # _self meta-commands (scan, templates) + +../plexus-protocol/ # Shared Plexus types (sibling package) +``` + +## Docker + +Synapse can be run in a Docker container for easy deployment and testing. + +### Build Docker Image + +```bash +# From the synapse directory +docker build -t synapse:latest . + +# Or use docker-compose +docker-compose build +``` + +### Run with Docker + +```bash +# Show help +docker run --rm synapse:latest + +# Call a method (requires --network host to access local backends) +docker run --rm --network host synapse:latest substrate echo.echo --message "hello" + +# Enable debug logging +docker run --rm --network host -e LOG_LEVEL=debug synapse:latest substrate hash + +# Connect to remote backend +docker run --rm synapse:latest -H 192.168.1.100 -P 5001 backend method + +# Run protocol validation +docker run --rm --network host synapse:latest _self debug localhost 4444 substrate +``` + +### Docker Compose + +```bash +# Show help +docker-compose run --rm synapse + +# Run a method +docker-compose run --rm synapse synapse substrate echo.echo --message "hello" + +# Debug connection +BACKEND=substrate PLEXUS_PORT=4444 docker-compose --profile debug up + +# With environment variables +LOG_LEVEL=debug docker-compose run --rm synapse synapse substrate hash +``` + +### Image Details + +- **Base**: debian:bookworm-slim (minimal runtime) +- **Size**: ~200MB (multi-stage build) +- **User**: Non-root user (uid 1000) +- **Default log level**: error (quiet mode) +- **Network**: Use `--network host` to access localhost backends + +## Development + +```bash +cabal build # Build +cabal test # Run tests (needs backend on localhost:4444) +cabal install # Install synapse binary +cabal build -f build-examples # Build optional examples +scripts/naming-gate.sh # The naming gate: each line that says the retired word (-c: the count) +``` + +A Plexus backend is a *service* (NAMING-9; `~/AGENTS.md` "Naming"): +`test-suite naming-gate` runs the gate, so `cabal test` fails the day the +retired word is written again. + +## License + +MIT diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -71,7 +71,7 @@ import qualified Synapse.CLI.Parse as Parse import Synapse.IR.Types (IR, irMethods, irRefusals, MethodDef) import qualified Synapse.IR.Types as IRT -import Plexus.Schema.Recursive (DeprecationInfo) +import Plexus.Schema.Recursive (Cardinality(..), DeprecationInfo) import qualified Data.Map.Strict as Map import qualified Synapse.CLI.Template as TemplateIR import Synapse.Deprecation (emitActivationWarning, emitMethodWarning) @@ -101,6 +101,9 @@ import qualified Synapse.Identity.Store as Store import System.Exit (ExitCode(..), exitWith) import qualified Synapse.Find as Find +import qualified Synapse.Input as In +import Control.Monad (forM_) +import System.Directory (getCurrentDirectory) import Synapse.IR.Cache (newIRCache, defaultCacheConfig) -- ============================================================================ @@ -902,7 +905,9 @@ Right () -> do -- AUTH-8: a refusal was shown — the call did not happen refused' <- Session.wasRefused - if refused' then exitWith (ExitFailure refusedExit) else exitSuccess + if refused' then exitWith (ExitFailure refusedExit) else do + failed <- Session.hasFailed + if failed then exitFailure else exitSuccess where isStaleError = \case Left (StaleSchema _) -> True @@ -996,18 +1001,14 @@ pure v isStaleItem :: ServiceStreamItem -> Bool -isStaleItem item = case itemRefusal item of - Just r -> refusalRoles r == ["admin"] - Nothing -> case item of - ServiceError _ _ msg _ -> any (`T.isInfixOf` msg) - [ "Method not found", "Activation not found", "Unknown method", "method not found" - , "errCode = -32601", "missing field", "unknown field", "invalid type", "unknown variant" ] - _ -> False +isStaleItem = SS.isStaleItem --- | SYNAPSE-28: route every call through the connection holder for its --- address and agent (started by the first run), or — with --no-hold, a --- credential of the call's own, or no holder to be had — over one --- connection of this process's own. +-- | SYNAPSE-28: route every call through the connection holder (started +-- by the first run), or — with --no-hold, a credential of the call's own, +-- or no holder to be had — over one connection of this process's own. +-- SYNAPSE-40: one holder for the user, every address and agent; each call +-- names the agent it is made as, and the holder keeps a connection per +-- address, agent and credential. installCallRouter :: SynapseOpts -> IO () installCallRouter opts = do noHoldEnv <- lookupEnv "SYNAPSE_NO_HOLD" @@ -1024,20 +1025,22 @@ || explicit || holdFor <= 0 st <- Store.systemStoreEnv asked <- askedAgent opts - let version = T.pack (showVersion Meta.version) - cp = soEndpoint opts + sock <- Hold.holderSocketPath + let cp = soEndpoint opts viaRegistry = Store.addressKey cp == Store.addressKey (plainAt defaultHost defaultPort) - socketFor cfg = do + agentFor cfg = do let ep = endpointOfConfig cfg -- the run's own address is held — or, reached through the -- registry, whatever it names; a registry the run only glances at -- (the auto-registration's probe) is not if not viaRegistry && Store.addressKey ep /= Store.addressKey cp then pure Nothing else do agent <- maybe (Store.readDefaultAgent st ep) (pure . Just) asked - Just <$> Hold.socketPathFor version (E.dirName ep) (fromMaybe "anonymous" agent) + pure (Just (fromMaybe "anonymous" agent)) _ <- Hold.installRouter Hold.RouterOpts - { Hold.roHold = if off then Nothing else Just socketFor - , Hold.roHoldFor = holdFor } + { Hold.roHold = if off then Nothing else Just agentFor + , Hold.roSocket = sock + , Hold.roHoldFor = holdFor + , Hold.roVersion = T.pack (showVersion Meta.version) } pure () -- | The address a plexus-protocol config dials. @@ -1051,14 +1054,30 @@ } -- | SYNAPSE-28: @synapse _hold --socket PATH --hold-for SECS@ — the --- connection holder (a run starts it; it exits when idle). +-- connection holder (a run starts it; it exits when it has held nothing +-- for SECS). SYNAPSE-40: one for the user; it keeps at most +-- @SYNAPSE_HOLD_MAX@ connections (256; 0: no cap), the longest idle closed +-- first. @synapse _hold status@ prints what it holds (JSON: each +-- connection's address, agent, calls and seconds idle — never a +-- credential), or exits 1 when no holder answers. runHold :: [Text] -> IO () runHold rest = case rest of ["--socket", path, "--hold-for", secs] - | Just d <- (readMaybe (T.unpack secs) :: Maybe Double) -> - Hold.runHolder Hold.HoldOpts { Hold.hoSocket = T.unpack path, Hold.hoHoldFor = d } + | Just d <- (readMaybe (T.unpack secs) :: Maybe Double) -> do + capEnv <- lookupEnv "SYNAPSE_HOLD_MAX" + let cap = fromMaybe Hold.defaultCap (capEnv >>= \c -> readMaybe c >>= \n -> if n >= 0 then Just n else Nothing) + Hold.runHolder (Hold.holdOpts (T.unpack path) d) + { Hold.hoCap = cap, Hold.hoVersion = T.pack (showVersion Meta.version) } + ["status"] -> do + sock <- Hold.holderSocketPath + st <- Hold.holderStatus sock + case st of + Just v -> LBS.putStrLn (encode v) >> exitSuccess + Nothing -> do + hPutStrLn stderr ("synapse: no holder answers at " <> sock) + exitWith (ExitFailure 1) _ -> do - hPutStrLn stderr "synapse _hold --socket PATH --hold-for SECS (started by synapse itself)" + hPutStrLn stderr "synapse _hold status | _hold --socket PATH --hold-for SECS (started by synapse itself)" exitWith (ExitFailure 2) -- | AUTH-8: the exit status of a call the service refused (sysexits' EX_NOPERM). @@ -1105,7 +1124,7 @@ Nothing -> do -- Parse path and inline params (--key value pairs) - let (pathSegs, rawParams, flagArgs, helpRequested) = parsePathAndParams argPath + let (pathSegs, rawParams, flagArgs0, helpRequested) = parsePathAndParams argPath -- Normal Plexus RPC routing -- Apply parameter transformations (path expansion, env vars) @@ -1115,12 +1134,31 @@ -- read once and kept for the second pass below sourceEnv <- liftIO $ mkSourceEnv (teCwd transformEnv) (teHome transformEnv) let fromSources pairs = liftIO (expandSources sourceEnv pairs) >>= either (throwParse . renderSourceError) pure - sourcedParams <- if helpRequested then pure rawParams else fromSources rawParams + -- BIDIR-18: an input stream's flag (--input -, --input @FILE) + -- names a stream, read as the call runs — never read here; a + -- parameter of that name is read below, once the method is known + let streamFlag (k, _) = k `elem` ["input", "input_stream"] + keepStreamFlags pairs = do + expanded <- fromSources (filter (not . streamFlag) pairs) + let go [] _ = [] + go (p : ps) es | streamFlag p = p : go ps es + go (_ : ps) (e : es) = e : go ps es + go (_ : ps) [] = go ps [] + pure (go pairs expanded) + -- the stream flags' values read now: for a method that has + -- no input half, they are a parameter's + expandStreamFlags pairs = do + expanded <- fromSources (filter streamFlag pairs) + let go [] _ = [] + go (p : ps) (e : es) | streamFlag p = e : go ps es + go (p : ps) es = p : go ps es + pure (go pairs expanded) + sourcedParams <- if helpRequested then pure rawParams else keepStreamFlags rawParams inlineParams <- liftIO $ transformParams transformEnv defaultTransformers sourcedParams -- Mode 1.5: Respond subcommand (agent sends a response to a pending bidir request) if not (null pathSegs) && head pathSegs == "respond" - then handleRespondCommand sourcedParams + then expandStreamFlags sourcedParams >>= handleRespondCommand -- Mode 2: Schema request else if soSchema @@ -1155,7 +1193,12 @@ unless (null refusals) $ liftIO $ do TIO.hPutStrLn stderr $ "synapse: refused \x2014 " <> T.pack (show (length refusals)) <> " site" <> (if length refusals == 1 then "" else "s") - <> " the IR cannot type (irRefusals); nothing was dropped:" + <> " the IR cannot type (irRefusals); " + -- RETURNS-36: a title collision leaves its activation + -- out (Builder.pluginIRRefusing); say which + <> (case [ irSite r | r <- refusals, irKeyword r == "title" ] of + [] -> "nothing was dropped:" + out -> "left out: " <> T.intercalate ", " out <> " (two types under one title):") let w = maximum (map (T.length . irSite) refusals) kw = maximum (map (T.length . irKeyword) refusals) mapM_ (\r -> TIO.hPutStrLn stderr $ " " <> T.justifyLeft w ' ' (irSite r) <> " " @@ -1206,6 +1249,14 @@ -- Landed on a method: invoke or show help ViewMethod method path -> do let fullPath = T.intercalate "." path + -- BIDIR-18: a method with an input half takes its + -- stream (--input -/@FILE), --chunk and --progress + -- out of the flags before its parameters are paired + (inputFlags, flagArgs) <- case methodInput method of + Nothing -> pure (Nothing, flagArgs0) + Just _ -> case In.takeInputFlags (methodInputNames method) (methodFlagArity method) flagArgs0 of + Left e -> throwParse e + Right (f, rest) -> pure (Just f, rest) -- IR-15: emit stderr deprecation warnings right before any -- real invocation. Dedupe is per-process-lifetime, so this @@ -1261,12 +1312,13 @@ -- 2. Parameter parsing (methods with params) let needsIR = helpRequested || isJust (methodParams method) + || isJust (methodInput method) || isJust soParams || not (null inlineParams) -- Fast path: parameter-less method with no help requested if not needsIR - then fireDeprecationWarnings >> keepPlan Nothing >> invokeMethod sourceEnv method path (object []) + then fireDeprecationWarnings >> keepPlan Nothing >> invokeMethod sourceEnv inputFlags method path (object []) else do -- Build IR for this method's namespace -- (SYNAPSE-28: the plan's, when it has one) @@ -1322,7 +1374,13 @@ Nothing | cached -> stale "a method the cache's IR lacks" Nothing -> -- Fallback to flat object if method not in IR - pure $ buildParamsObject inlineParams + -- BIDIR-18: an input method's own flags are no + -- parameter; any other's --input is + case methodInput method of + Just _ -> let names = methodInputNames method + own (k, _) = k `elem` map (T.replace "-" "_") [In.inStream names, In.inChunk names, In.inProgress names] + in pure $ buildParamsObject (filter (not . own) inlineParams) + Nothing -> buildParamsObject <$> expandStreamFlags inlineParams | otherwise -> pure $ object [] -- Merge: user params override schema defaults let params = mergeParams schemaDefaults userParams @@ -1331,8 +1389,15 @@ then do backend <- asks seBackend liftIO $ LBS.putStrLn $ encodeDryRun backend (init path) (last path) params + -- BIDIR-18: and the first input frame it would send + forM_ (methodInput method) $ \schema -> do + (_, kind, chunk, _, src) <- inputCall fullPath method schema inputFlags + first <- liftIO $ In.dryRunFrame backend kind chunk src + case first of + Right frame -> liftIO $ TIO.putStrLn frame + Left e -> throwParse e -- Show help when: method has required params AND user provided no params - else if hasRequiredParams method && userParams == object [] && null inlineParams + else if hasRequiredParams method && userParams == object [] && null inlineParams && isNothing inputFlags then if cached then stale "help" else do -- Render help from IR case Map.lookup fullPath (irMethods ir) of @@ -1345,7 +1410,7 @@ -- Fallback: method not in IR, use basic info liftIO $ TIO.putStrLn $ T.intercalate "." path <> " - " <> methodDescription method -- IR-15: fire stderr deprecation warnings before real invocation. - else fireDeprecationWarnings >> keepPlan (Just ir) >> invokeMethod sourceEnv method path params + else fireDeprecationWarnings >> keepPlan (Just ir) >> invokeMethod sourceEnv inputFlags method path params where -- AUTH-8: what the _info probe at this address answered (view, auth) currentInfo :: SynapseM (Maybe BackendInfo) @@ -1443,7 +1508,29 @@ Left err -> throwParse $ "Invalid --response JSON: " <> T.pack err Right (resp :: Response Value) -> sendResponse requestId resp - invokeMethod srcEnv method path params = do + -- BIDIR-18: what an input call reads and how: the flag's name, the + -- item's kind, the chunk, --progress, the source. No stream named is + -- refused before anything is sent, naming the flag. + inputCall dotted method schema inputFlags = do + let names = methodInputNames method + flag = In.inStream names + kind = In.itemKind schema + flags <- maybe (pure (In.InputFlags Nothing Nothing False)) pure inputFlags + src <- case In.ifSource flags of + Nothing -> throwParse $ dotted <> " takes a stream in: give it with --" <> flag + <> " - (stdin) or --" <> flag <> " @FILE" + Just v -> do + cwd <- liftIO getCurrentDirectory + home <- liftIO $ (Just <$> getHomeDirectory) `E.catch` \(_ :: E.SomeException) -> pure Nothing + either throwParse pure (In.sourceOf flag cwd home v) + case src of + In.FromFile p -> do + ok <- liftIO $ doesFileExist p + if ok then pure () else throwParse ("--" <> flag <> " @" <> T.pack p <> ": no such file") + In.FromStdin -> pure () + pure (flag, kind, maybe In.defaultChunk id (In.ifChunk flags), In.ifProgress flags, src) + + invokeMethod srcEnv inputFlags method path params = do let namespacePath = init path -- path without method name let methodName' = last path -- Set method path hint for template resolution @@ -1512,9 +1599,28 @@ pure (Just (mergeUpgradeHeaders (seToken env') (seCookies env') (seHeaders env'))) -- SYNAPSE-39: a stream has no end to wait for — with -o, its items -- go to FILE itself, each as it comes - when (methodStreaming method) $ liftIO Output.streaming - -- Use bidirectional streaming handler - invokeStreamingWithBidir + when (methodCardinality method == CardinalityMany) $ liftIO Output.streaming + case methodInput method of + -- BIDIR-18: a method with an input half: its stream from stdin or a + -- file, under credit, never sent twice. While no credit has come + -- (nothing read), an item may be held back to run the call again + -- as any call's is; after, every item is printed as it is. + Just schema -> do + (_, kind, chunk, progress, src) <- inputCall (T.intercalate "." path) method schema inputFlags + when (src == In.FromStdin && stdinTaken) $ + throwParse "a value was read from stdin (-), so the input stream cannot read it too; give the value as @FILE" + let printer' untouched item = do + fresh <- untouched + if fresh then printer item else do + case item of + ServiceData{} -> Session.notePrinted + _ -> pure () + printResult soJson soRaw rendererCfg' item + invokeWithInput (Reconnect.callShape method) refreshAuth kind chunk progress src + namespacePath methodName' params printer' + Nothing -> + -- Use bidirectional streaming handler + invokeStreamingWithBidir (Reconnect.callShape method) refreshAuth resumed @@ -1583,6 +1689,32 @@ _ -> throwParse "JSON-RPC must have 'method' field" _ -> throwParse "JSON-RPC must be an object" +-- | BIDIR-18: what a method's input flags are called, given its +-- parameters (a parameter named @input@ keeps @--input@; the stream is +-- then @--input-stream@). +methodInputNames :: MethodSchema -> In.InputNames +methodInputNames m = In.inputNames $ case methodParams m of + Just (Object o) | Just (Object props) <- KM.lookup "properties" o -> map K.toText (KM.keys props) + _ -> [] + +-- | BIDIR-18: how a method's flag takes its value, from its schema — a +-- boolean only a boolean word, any other parameter the next argument, an +-- unknown flag the next unless it is a flag (as 'Parse.flagArity' reads +-- the IR; the input flags are taken out before the IR is built). +methodFlagArity :: MethodSchema -> Text -> In.FlagArity +methodFlagArity m key = case methodParams m of + Just (Object o) | Just (Object props) <- KM.lookup "properties" o + , Just prop <- KM.lookup (K.fromText (T.takeWhile (/= '.') key)) props -> + if isBoolean prop && not ("." `T.isInfixOf` key) then In.TakesBoolean else In.TakesNext + _ -> In.TakesUnlessFlag + where + isBoolean = \case + Object p -> case KM.lookup "type" p of + Just (String "boolean") -> True + Just (Array ts) -> String "boolean" `elem` ts && all (`elem` [String "boolean", String "null"]) ts + _ -> False + _ -> False + -- | Build JSON object from key-value pairs buildParamsObject :: [(Text, Text)] -> Value buildParamsObject pairs = object @@ -1654,12 +1786,15 @@ , " --cacert FILE trusts a local CA too. Sessions are kept per" , " URL, so _login and every call take the same options" , "" - , "A connection held between runs (SYNAPSE-28):" - , " the first call to a backend starts a holder that keeps the signed-in socket" - , " open ($XDG_RUNTIME_DIR/synapse/, one per address and agent); later calls cost" - , " one round trip. It exits after --hold-for (10m) with nothing to do; --no-hold" - , " dials a connection of the run's own. A call is sent from the schema cache" - , " (~/.cache/synapse/schemas) and checked against the server only when it fails" + , "A connection held between runs (SYNAPSE-28, SYNAPSE-40):" + , " the first call starts the holder, one process for all your calls" + , " ($XDG_RUNTIME_DIR/synapse/holder-4.sock), which keeps a signed-in socket per" + , " address and agent; later calls cost one round trip. A socket whose server is" + , " gone is let go at once, one idle for --hold-for (10m) closed, past 256 the" + , " longest idle first; the holder exits when it has held nothing for --hold-for." + , " --no-hold dials a connection of the run's own; synapse _hold status says what" + , " is held. A call is sent from the schema cache (~/.cache/synapse/schemas-4) and" + , " checked against the server only when it fails" , "" , "Meta-commands:" , "" @@ -1902,7 +2037,7 @@ -- SYNAPSE-39: under -o the -j line goes with FILE when the run fails, -- so the refusal is said on stderr too toFile <- Output.active - if json then LBS.putStrLn (encode item) else pure () + if json then LBS.putStrLn (jsonLine item) else pure () if not json || toFile then do ceiling' <- Session.currentCeiling TIO.hPutStr stderr (renderRefusal ceiling' r) @@ -1913,10 +2048,18 @@ case item of ServiceError _ _ err _ | json, toFile -> hPutStrLn stderr $ "Error: " <> T.unpack err _ -> pure () + if itemFailed item then Session.noteFailed else pure () printResult' json raw cfg item +-- | Did this item say the call failed? An error item, or data whose content +-- is an event of @type: error@ (a service's in-band error). +itemFailed :: ServiceStreamItem -> Bool +itemFailed (ServiceError _ _ _ _) = True +itemFailed (ServiceData _ _ _ (Object o)) = KM.lookup "type" o == Just (String "error") +itemFailed _ = False + printResult' :: Bool -> Bool -> RendererConfig -> ServiceStreamItem -> IO () -printResult' True _ _ item = LBS.putStrLn $ encode item +printResult' True _ _ item = LBS.putStrLn $ jsonLine item printResult' _ True _ item = case item of -- Raw mode: just output the content ServiceData _ _ _ dat -> do diff --git a/plexus-synapse.cabal b/plexus-synapse.cabal --- a/plexus-synapse.cabal +++ b/plexus-synapse.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: plexus-synapse -version: 3.17.3 +version: 4.0.0 synopsis: Schema-driven CLI for Plexus RPC servers description: Synapse is the command-line frontend for Plexus RPC. It discovers a server's methods at runtime and builds its commands, help text, @@ -14,6 +14,8 @@ category: Network build-type: Simple tested-with: GHC == 9.8.4, GHC == 9.12.4 +extra-doc-files: README.md + CHANGELOG.md flag build-examples description: Build example programs (schema-discovery) @@ -28,6 +30,16 @@ default: False manual: True +flag live-tests + description: Build the suites that need a live service: cli-test, + websocket-raw-test and ir-test (a substrate and registry on + 127.0.0.1:4444; cli-test also a synapse binary at a fixed + dist-newstyle path) and bidir-integration-test (a backend + named in --test-options). Opt-in, so a default `cabal test` + needs nothing running. Enable with: cabal test -f live-tests + default: False + manual: True + library exposed-modules: Synapse.Schema.Types @@ -85,11 +97,15 @@ Synapse.Auth Synapse.Auth.Loopback Synapse.Hold + Synapse.Input Synapse.SchemaStore + other-modules: Paths_plexus_synapse + autogen-modules: Paths_plexus_synapse build-depends: base >= 4.17 && < 5, - -- SYNAPSE-28: setCallRouter, substrateRpcSub, unsubscribe - plexus-protocol >= 0.5.5, + -- SYNAPSE-28: setCallRouter, substrateRpcSub, unsubscribe; RETURNS-12: + -- the plexus 0.7 schema and envelope + plexus-protocol >= 0.6 && < 0.7, aeson >= 2.0 && < 2.3, aeson-pretty >= 0.8 && < 0.9, text >= 2.0 && < 2.2, @@ -232,6 +248,8 @@ default-extensions: OverloadedStrings ghc-options: -threaded + if !flag(live-tests) + buildable: False test-suite ir-test type: exitcode-stdio-1.0 @@ -252,6 +270,8 @@ LambdaCase RecordWildCards ghc-options: -threaded + if !flag(live-tests) + buildable: False test-suite schema-decode-test type: exitcode-stdio-1.0 @@ -388,6 +408,8 @@ default-extensions: OverloadedStrings ghc-options: -threaded + if !flag(live-tests) + buildable: False test-suite bidir-test type: exitcode-stdio-1.0 @@ -423,6 +445,8 @@ OverloadedStrings RecordWildCards ghc-options: -threaded + if !flag(live-tests) + buildable: False test-suite stream-tracker-test type: exitcode-stdio-1.0 @@ -528,6 +552,33 @@ OverloadedStrings ghc-options: -threaded +test-suite ir3-test + -- RETURNS-13: IR 3.0. The golden test reads RETURNS-7's conformance + -- fixture by sibling path (../plexus-macros/fixtures/conformance/expected/) + -- and compares the IR built from its schema.json with its ir.json; + -- SYNAPSE_GOLDEN_ACCEPT=1 rewrites ir.json instead. Then one test per row + -- of the ticket's Required behavior table. + type: exitcode-stdio-1.0 + main-is: IR3Spec.hs + build-depends: + base >= 4.17 && < 5, + plexus-protocol, + plexus-synapse, + aeson >= 2.2 && < 2.3, + aeson-pretty >= 0.8 && < 0.9, + aeson-qq >= 0.8 && < 0.9, + bytestring >= 0.11 && < 0.13, + containers >= 0.6 && < 0.8, + filepath >= 1.4 && < 1.6, + text >= 2.0 && < 2.2, + hspec >= 2.10 && < 2.12 + hs-source-dirs: test + default-language: GHC2021 + default-extensions: + OverloadedStrings + LambdaCase + ghc-options: -threaded + test-suite keychain-test -- SELF-8 keychain tests. Opt-in via `-f build-keychain-tests` because -- they shell out to macOS `security` and touch the real keychain. @@ -554,7 +605,7 @@ -- service in miniature (test/MockService.hs) on ports of their own. type: exitcode-stdio-1.0 main-is: AuthSpec.hs - other-modules: MockService + other-modules: MockService, Plexus07 build-depends: base >= 4.17 && < 5, plexus-protocol, @@ -582,7 +633,7 @@ -- terminal and piped; a caller's view; the IR cache's hash check. type: exitcode-stdio-1.0 main-is: FindSpec.hs - other-modules: MockService + other-modules: MockService, Plexus07 build-depends: base >= 4.17 && < 5, plexus-synapse, @@ -635,10 +686,14 @@ -- at the mock service), a stream abandoned is unsubscribed, the holder exits -- idle; and the built synapse, end to end: cold fills the cache on one -- connection, warm opens none and fetches nothing, --no-hold opens one, - -- a renamed method falls back and answers. + -- a renamed method falls back and answers. SYNAPSE-40: one holder process + -- for the user (counted in /proc), a connection per address and agent, + -- one whose server stopped let go within 10 s, the cap closing the longest + -- idle first, and a loop against short-lived servers (SYNAPSE40_LOOP, + -- 500) through one holder whose memory stays flat. type: exitcode-stdio-1.0 main-is: HoldSpec.hs - other-modules: MockService + other-modules: MockService, Plexus07 build-tool-depends: plexus-synapse:synapse build-depends: base >= 4.17 && < 5, @@ -647,12 +702,14 @@ aeson >= 2.2 && < 2.3, async >= 2.2 && < 2.3, bytestring >= 0.11 && < 0.13, + containers >= 0.6 && < 0.8, directory >= 1.3 && < 1.4, filepath >= 1.4 && < 1.6, network >= 3.1 && < 3.3, process >= 1.6 && < 1.7, temporary >= 1.3 && < 1.4, text >= 2.0 && < 2.2, + unix >= 2.7 && < 2.9, vector >= 0.12 && < 0.14, websockets >= 0.13 && < 0.14, hspec >= 2.10 && < 2.12 @@ -662,6 +719,37 @@ OverloadedStrings ghc-options: -threaded +test-suite input-test + -- BIDIR-18: a call with an input half — the built synapse against the + -- mock service's stream activation: lines and NDJSON as items, a bad line + -- named and never carried, stdin not read past credit (memory flat), + -- bytes as binary frames, a disconnect said and never resent (69), the + -- typed closes' exits (70, 65, 77), --input-stream, -n, help and _find. + type: exitcode-stdio-1.0 + main-is: InputSpec.hs + other-modules: MockService, Plexus07 + build-tool-depends: plexus-synapse:synapse + build-depends: + base >= 4.17 && < 5, + aeson >= 2.2 && < 2.3, + bytestring >= 0.11 && < 0.13, + containers >= 0.6 && < 0.8, + directory >= 1.3 && < 1.4, + filepath >= 1.4 && < 1.6, + network >= 3.1 && < 3.3, + process >= 1.6 && < 1.7, + temporary >= 1.3 && < 1.4, + text >= 2.0 && < 2.2, + unix >= 2.7 && < 2.9, + vector >= 0.12 && < 0.14, + websockets >= 0.13 && < 0.14, + hspec >= 2.10 && < 2.12 + hs-source-dirs: test + default-language: GHC2021 + default-extensions: + OverloadedStrings + ghc-options: -threaded + test-suite pipe-test -- SYNAPSE-26: a closed stdout is not an outage — the built synapse, its -- stdout a pipe whose reader closes early (… | head -1): a write sent @@ -670,12 +758,13 @@ -- resent, a write that went out exit 75). type: exitcode-stdio-1.0 main-is: PipeSpec.hs - other-modules: MockService + other-modules: MockService, Plexus07 build-tool-depends: plexus-synapse:synapse build-depends: base >= 4.17 && < 5, aeson >= 2.2 && < 2.3, bytestring >= 0.11 && < 0.13, + containers >= 0.6 && < 0.8, directory >= 1.3 && < 1.4, filepath >= 1.4 && < 1.6, network >= 3.1 && < 3.3, @@ -700,12 +789,13 @@ -- nothing sent. type: exitcode-stdio-1.0 main-is: OutputSpec.hs - other-modules: MockService + other-modules: MockService, Plexus07 build-tool-depends: plexus-synapse:synapse build-depends: base >= 4.17 && < 5, aeson >= 2.2 && < 2.3, bytestring >= 0.11 && < 0.13, + containers >= 0.6 && < 0.8, directory >= 1.3 && < 1.4, filepath >= 1.4 && < 1.6, network >= 3.1 && < 3.3, @@ -747,7 +837,7 @@ -- name refused at the handshake. Pending without openssl. type: exitcode-stdio-1.0 main-is: TlsSpec.hs - other-modules: MockService + other-modules: MockService, Plexus07 build-depends: base >= 4.17 && < 5, plexus-protocol, @@ -755,6 +845,7 @@ aeson >= 2.2 && < 2.3, base64-bytestring >= 1.2 && < 1.3, bytestring >= 0.11 && < 0.13, + containers >= 0.6 && < 0.8, directory >= 1.3 && < 1.4, filepath >= 1.4 && < 1.6, katip >= 0.8 && < 0.9, @@ -778,7 +869,7 @@ -- 20 times from memory — median, p90, bytes allocated per build. type: exitcode-stdio-1.0 main-is: IRBench.hs - other-modules: IRFixture + other-modules: IRFixture, Plexus07 build-depends: base >= 4.17 && < 5, plexus-synapse, @@ -803,7 +894,7 @@ -- bare object: exit 65. type: exitcode-stdio-1.0 main-is: IRCoverageSpec.hs - other-modules: IRFixture, MockService + other-modules: IRFixture, MockService, Plexus07 build-tool-depends: plexus-synapse:synapse build-depends: base >= 4.17 && < 5, diff --git a/src/Synapse/Algebra/Recursion.hs b/src/Synapse/Algebra/Recursion.hs --- a/src/Synapse/Algebra/Recursion.hs +++ b/src/Synapse/Algebra/Recursion.hs @@ -196,6 +196,10 @@ -- SYNAPSE-28: a run sending from the cache asks the server -- for what the cache lacks; it never skips it Left err | cacheCannotAnswer err -> pure (Left err) + -- RETURNS-13: a child whose schema builds no IR (two shapes + -- under one title) fails the walk; it is never skipped as a + -- fetch that failed + Left err@(ValidationError _) -> pure (Left err) Left err -> do hPutStrLn stderr $ "[synapse] warning: skipping plugin (fetch failed): " ++ show err pure (Right Nothing) diff --git a/src/Synapse/CLI/Help.hs b/src/Synapse/CLI/Help.hs --- a/src/Synapse/CLI/Help.hs +++ b/src/Synapse/CLI/Help.hs @@ -89,6 +89,7 @@ import Synapse.IR.Types import Synapse.Algebra.Render (deprecationMarker, formatDeprecationLine, fitText) import Synapse.CLI.Parse (isScalarElement) +import qualified Synapse.Input as In -- ============================================================================ -- Configuration @@ -168,6 +169,7 @@ , [""] , usageLines , optionsBlock + , inputBlock , exampleBlock , requiresBlock ] @@ -195,7 +197,39 @@ optional = [p | p <- callerParams, not (pdRequired p)] usageLines = - [ "Usage: " <> T.unwords ([invoke] ++ map usageFlag required ++ ["[OPTIONS]" | not (null optional)]) ] + [ "Usage: " <> T.unwords ([invoke] ++ map usageFlag required + ++ [ "--" <> In.inStream inNames <> " <-|@FILE>" | hasInput ] + ++ ["[OPTIONS]" | not (null optional)]) ] + + -- BIDIR-18: a method with an input half takes a stream in + inSchema = mpSchema >>= methodInput + hasInput = isJust (mdInput md) || isJust inSchema + inNames = In.inputNames (map pdName (mdParams md)) + inKind = case inSchema of + Just sch -> In.itemKind sch + Nothing -> case mdInput md of + Just (RefPrimitive "string" (Just "binary")) -> In.ItemBytes + Just (RefPrimitive "string" _) -> In.ItemString + _ -> In.ItemJson + inType = case (inKind, mdInput md) of + (In.ItemBytes, _) -> "bytes" + (_, Just t) -> flagType ir t + (In.ItemString, Nothing) -> "string" + (_, Nothing) -> "JSON" + inputBlock + | not hasInput = [] + | otherwise = + [ "", "Input (a stream in, sent as the service grants credit):" ] + ++ hangAt inCol (" --" <> In.inStream inNames <> " <-|@FILE>") + (wrapWords (max 20 (width - inCol)) $ "stdin (-) or a file (@FILE) of " <> inType <> " items: " <> case inKind of + In.ItemBytes -> "the bytes as they are, cut into --" <> In.inChunk inNames <> " bytes, each a binary frame" + In.ItemString -> "one line, one item" + In.ItemJson -> "one JSON value a line (NDJSON); a line that is not one is named and nothing carries it") + ++ [ l | inKind == In.ItemBytes + , l <- hangAt inCol (" [--" <> In.inChunk inNames <> " ]") + ["bytes a binary frame (default " <> T.pack (show In.defaultChunk) <> ")"] ] + ++ hangAt inCol (" [--" <> In.inProgress inNames <> "]") ["sent, acked and credit on stderr, once a second"] + inCol = 2 + 24 usageFlag p = flagOf p <> " <" <> T.toUpper (pdName p) <> ">" optionsBlock @@ -251,7 +285,8 @@ exampleLines i ex = [ "" | i > 0 ] ++ maybe [] (\n -> [" # " <> n]) (exampleNote ex) - ++ [" " <> renderExample mpProgram mpTarget md (exampleParams ex)] + ++ [" " <> renderExample mpProgram mpTarget md (exampleParams ex) + <> (if hasInput then " --" <> In.inStream inNames <> " -" else "")] -- AUTH-8: in a caller's view, the grant and where it is held. requiresBlock = case mpSchema of diff --git a/src/Synapse/CLI/Parse.hs b/src/Synapse/CLI/Parse.hs --- a/src/Synapse/CLI/Parse.hs +++ b/src/Synapse/CLI/Parse.hs @@ -66,6 +66,8 @@ ( -- * Command line parsePathAndParams , pairFlags + , FlagArity(..) + , takeFlag -- * Parsing , parseParams diff --git a/src/Synapse/Find.hs b/src/Synapse/Find.hs --- a/src/Synapse/Find.hs +++ b/src/Synapse/Find.hs @@ -67,7 +67,8 @@ import Data.Char (isAlphaNum) import Data.List (sortOn, foldl') import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) +import Data.Maybe (fromMaybe, isJust, listToMaybe, mapMaybe) +import qualified Synapse.Input as In import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T @@ -515,7 +516,10 @@ row h = case enParam (hitEntry h) of Nothing -> let descW = max minDesc (width - col1) - in [ T.stripEnd (" " <> locCell h <> descCell h descW (methodText (enMethod (hitEntry h)))) ] + m = enMethod (hitEntry h) + in T.stripEnd (" " <> locCell h <> descCell h descW (methodText m)) + -- BIDIR-18: a method with an input half says how its stream is given + : [ T.replicate col1 " " <> inputLine frIR m | isJust (mdInput m) ] Just p -> let descW = max minDesc (width - col2) label = flagLabel frIR p @@ -635,6 +639,23 @@ locW = maximum (0 : map (T.length . entryLocation) near) desc e = fromMaybe "" (mdDescription (enMethod e)) +-- | BIDIR-18: what a method's input half is called and takes. +inputNamesOf :: MethodDef -> In.InputNames +inputNamesOf m = In.inputNames (map pdName (mdParams m)) + +-- | The item type of an input, as a flag shows a type (bytes, which the IR +-- does not type, as such). +inputType :: IR -> TypeRef -> Text +inputType ir = \case + RefPrimitive "string" (Just "binary") -> "bytes" + RefUnknown -> "any" + t -> flagType ir t + +-- | @takes a stream in: --input -|@FILE, Item items@ +inputLine :: IR -> MethodDef -> Text +inputLine ir m = "takes a stream in: --" <> In.inStream (inputNamesOf m) <> " -|@FILE" + <> maybe "" (\t -> ", " <> inputType ir t <> " items") (mdInput m) + -- | One hit as JSON, for @-j@. hitJson :: IR -> Hit -> Value hitJson ir h = object $ @@ -649,6 +670,8 @@ , "description" .= fromMaybe "" (pdDescription p) ] ++ maybe [] (\vs -> ["values" .= vs]) (paramValuesOf ir p) Nothing -> [ "description" .= fromMaybe "" (mdDescription m) ] + ++ [ "input" .= object [ "flag" .= ("--" <> In.inStream (inputNamesOf m)), "item" .= inputType ir t ] + | Just t <- [mdInput m] ] ++ [ "group" .= (case hitGroup h of { Methods -> "methods"; Parameters -> "parameters"; Mentioned -> "mentioned" } :: Text) , "score" .= (fromIntegral (round (hitScore h * 100) :: Int) / 100 :: Double) diff --git a/src/Synapse/Hold.hs b/src/Synapse/Hold.hs --- a/src/Synapse/Hold.hs +++ b/src/Synapse/Hold.hs @@ -3,21 +3,27 @@ {-# LANGUAGE ScopedTypeVariables #-} -- | SYNAPSE-28: a call costs one round trip and the server's time. +-- SYNAPSE-40: and one process holds every connection a user's runs keep. -- -- Every call synapse makes goes through plexus-protocol's -- 'ST.setCallRouter' hook to one of two places: -- --- * __the holder__ — a process of synapse's own (@synapse _hold@), one per --- backend address and agent, in the manner of ssh's ControlMaster. It --- keeps the signed-in WebSocket open between runs and listens on a unix --- socket (@$XDG_RUNTIME_DIR/synapse/ADDRESS\@AGENT-VERSION.sock@, 0600, --- in a 0700 directory). A run hands it each request and reads the reply --- back, so a warm call costs local IPC and one round trip. The first run --- starts it; it exits after @--hold-for@ (10 minutes) with nothing to do. +-- * __the holder__ — a process of synapse's own (@synapse _hold@), __one +-- per user__ (and per 'holdProtocol'), in the manner of ssh's +-- ControlMaster. It keeps signed-in WebSockets open between runs, one per +-- address, agent and credential, and listens on a unix socket +-- (@$XDG_RUNTIME_DIR/synapse/holder-4.sock@, 0600, in a 0700 directory). +-- A run hands it each request, with the agent it calls as, and reads the +-- reply back, so a warm call costs local IPC and one round trip. The +-- first run starts it. A connection whose server has gone is let go at +-- once (within the second); one idle for @--hold-for@ (10 minutes) is +-- closed; past 'defaultCap' connections the one idle longest is closed +-- first; and the holder exits once it has held nothing and served nothing +-- for @--hold-for@. -- * __the multiplexer__ in this process ('Mux') — what the holder itself -- runs, and what a run uses with @--no-hold@ or when no holder can be --- had: one connection per address and credential, every call of the --- run on it (JSON-RPC carries many by id), never one per call. +-- had: one connection per address, agent and credential, every call of +-- the run on it (JSON-RPC carries many by id), never one per call. -- -- Either way a failure reads as it did before: a lost connection is -- 'LostConnection' (with whether the request had gone out), a failed dial @@ -27,23 +33,43 @@ -- changed (a session made again from the key) is a new connection in the -- holder, beside the old one until it is idle; the holder never signs in -- by itself. +-- +-- SYNAPSE-28's rule that a call never rides another agent's connection +-- holds by the key: the agent is part of it, so two agents with the same +-- credential (none at all, say) still have a connection each. +-- +-- Older synapse binaries (3.16.0 to 3.17.3) keep a holder per address and +-- agent at @ADDRESS\@AGENT-VERSION.sock@ in the same directory; nothing +-- here opens, removes or answers those, so they go on working beside it. module Synapse.Hold ( -- * The multiplexer Mux , newMux + , newMuxWith , muxCall + , muxCallAs + , muxCallDuplex , muxActive , muxConnections + , Held(..) + , muxHolding -- * The holder , HoldOpts(..) + , holdOpts , runHolder - , socketPathFor + , holdProtocol + , holderSocketPath , defaultHoldFor + , defaultCap -- * Through the holder , holderCall + , holderCallAs + , holderCallDuplex + , holderStatus , HolderGone(..) + , olderThan -- * The router , RouterOpts(..) @@ -51,12 +77,12 @@ , routedCall ) where -import Control.Concurrent (forkIO, threadDelay, myThreadId) -import Control.Concurrent.Async (async, cancel, waitCatch, withAsync) +import Control.Concurrent (forkIO, forkIOWithUnmask, threadDelay) +import Control.Concurrent.Async (async, asyncWithUnmask, cancel, wait, waitCatch, withAsync) import Control.Concurrent.MVar import Control.Concurrent.STM import Control.Exception -import Control.Monad (forever, unless, void, when) +import Control.Monad (forM, forM_, forever, unless, void, when) import Data.Aeson hiding (Key) import qualified Data.Aeson.KeyMap as KM import qualified Data.ByteString as BS @@ -64,68 +90,107 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.CaseInsensitive as CI import Data.IORef +import Data.List (sortOn) import qualified Data.Map.Strict as Map -import Data.Maybe (isJust) +import Data.Maybe (fromMaybe, isJust) import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Text.Read (readMaybe) +import Foreign.C.Error (Errno(..), eAGAIN, throwErrnoIfMinus1RetryMayBlock_) import Foreign.C.Types (CInt(..)) import GHC.Clock (getMonotonicTime) +import GHC.IO.Exception (IOException(..)) import qualified Network.Socket as N import qualified Network.Socket.ByteString as NB import qualified Streaming.Prelude as S -import System.Directory (createDirectoryIfMissing, doesDirectoryExist, getTemporaryDirectory, removeFile) -import System.Environment (getExecutablePath, lookupEnv) +import System.Directory (createDirectoryIfMissing, doesDirectoryExist, getTemporaryDirectory, makeAbsolute, removeFile) +import System.Environment (getEnvironment, getExecutablePath, lookupEnv) import System.Exit (exitSuccess) import System.FilePath ((), takeDirectory) import System.IO (hClose, IOMode(..), openFile) import System.Posix.Files (setFileMode, getFileStatus, fileID, fileOwner, fileMode) import Data.Bits ((.&.)) import System.Posix.IO (closeFd, createFile) +import System.Posix.Process (getProcessID) import System.Posix.Signals (installHandler, sigTERM, sigHUP, Handler(..)) import System.Posix.User (getRealUserID) -import System.Process (CreateProcess(..), StdStream(..), createProcess, proc) +import System.Process (CreateProcess(..), StdStream(..), createProcess, getProcessExitCode, proc) import System.Timeout (timeout) -import Foreign.C.Error (throwErrnoIfMinus1RetryMayBlock_) -import Plexus.Client (SubstrateConfig(..), SubstrateConnection, LostConnection(..), TlsOptions(..), connect, disconnect, connectionLost, substrateRpcSub, unsubscribe) +import Plexus.Client (SubstrateConfig(..), SubstrateConnection, LostConnection(..), TlsOptions(..), connect, disconnect, connectionLost, substrateRpcDuplex, unsubscribe) +import Plexus.Input (InputHalf(..), InputPort(..), inputSignal, inputSignalValue) import qualified Plexus.Transport as ST +import qualified Synapse.Input as In import Plexus.Types (PlexusStreamItem(..)) -- ============================================================================ -- The multiplexer -- ============================================================================ --- | Where and as whom: a config with its backend left out (the backend --- names methods; it does not change the connection). -type ConnKey = SubstrateConfig +-- | Where, as whom and with what: the agent the call is made as, and the +-- config with its backend left out (the backend names methods; it does not +-- change the connection) — its address and the credential its headers +-- carry. SYNAPSE-40: the agent is in the key, so a call as one agent never +-- rides another agent's connection, however alike their credentials. +data ConnKey = ConnKey + { ckAgent :: Text + , ckConfig :: SubstrateConfig + } + deriving (Eq, Ord) -keyOf :: SubstrateConfig -> ConnKey -keyOf c = c { substrateBackend = "" } +keyOf :: Text -> SubstrateConfig -> ConnKey +keyOf agent c = ConnKey agent c { substrateBackend = "" } -- | One connection and the calls on it. data Upstream = Upstream { upConn :: SubstrateConnection , upInflight :: TVar Int - , upLastUsed :: IORef Double + , upClosing :: TVar Bool -- ^ SYNAPSE-40: being let go; no call picks it + , upLastUsed :: TVar Double -- ^ when a call last took or gave back a slot on it + , upHoldFor :: IORef Double -- ^ SYNAPSE-40: how long it may sit idle — the --hold-for of the last call on it , upSerial :: Int } --- | Connections by address and credential, shared by every call. +-- | Connections by agent, address and credential, shared by every call. data Mux = Mux { muxUps :: MVar (Map.Map ConnKey [Upstream]) - , muxDialing :: MVar (Map.Map ConnKey (MVar ())) + , muxDialing :: MVar (Map.Map ConnKey (MVar (), Int)) + -- ^ one dial at a time per key; an entry lives while someone dials or waits , muxBusy :: TVar Int -- ^ calls under way , muxLast :: IORef Double -- ^ when the last call ended (or began) - , muxSerial :: IORef Int -- ^ connections opened (for tests, and the holder's log) + , muxSerial :: IORef Int -- ^ connections opened (for tests, and the holder's status) , muxShared :: MVar (Map.Map (ConnKey, Text, BS.ByteString) (MVar (Either SomeException [PlexusStreamItem]))) -- ^ schema and _info reads under way, each asked once however many wait + , muxCap :: Int + -- ^ SYNAPSE-40: the most connections kept at once (0: no cap) + , muxIdle :: Double + -- ^ how long a connection may sit idle when its call does not say } +-- | A multiplexer with the default cap. newMux :: IO Mux -newMux = do +newMux = newMuxWith defaultCap defaultHoldFor + +-- | A multiplexer keeping at most this many connections (0: no cap), each +-- idle for at most the seconds unless its call says otherwise. +newMuxWith :: Int -> Double -> IO Mux +newMuxWith cap idle = do now <- getMonotonicTime - Mux <$> newMVar Map.empty <*> newMVar Map.empty <*> newTVarIO 0 <*> newIORef now <*> newIORef 0 <*> newMVar Map.empty + Mux <$> newMVar Map.empty <*> newMVar Map.empty <*> newTVarIO 0 <*> newIORef now <*> newIORef 0 + <*> newMVar Map.empty <*> pure (max 0 cap) <*> pure idle +-- | SYNAPSE-40: the most connections the holder keeps. A live connection +-- costs it about 96 kB (measured: 403 held to live services, 17.2 MB with +-- 3 → 55.8 MB, hold-test's "what its cap is set by"), so at 256 the holder +-- stays under about 45 MB — three of SYNAPSE-28's holders, where a loop +-- left 1,634 of them — while 256 is twenty times the 13 live connections +-- this machine's agents held when SYNAPSE-40 was filed. Past it, the +-- connection idle longest is closed first; one carrying a call never is, +-- so a burst of open calls may pass the cap until they end. +defaultCap :: Int +defaultCap = 256 + -- | Calls under way, and when the last one ended. muxActive :: Mux -> IO (Int, Double) muxActive m = (,) <$> readTVarIO (muxBusy m) <*> readIORef (muxLast m) @@ -134,21 +199,58 @@ muxConnections :: Mux -> IO Int muxConnections = readIORef . muxSerial +-- | SYNAPSE-40: a connection held, as the holder's status shows it — its +-- address and agent, never its credential. +data Held = Held + { heldConfig :: SubstrateConfig -- ^ with its headers left out + , heldAgent :: Text + , heldCalls :: Int + , heldIdle :: Double -- ^ seconds since a call last ended on it + } + +-- | The connections held now. +muxHolding :: Mux -> IO [Held] +muxHolding mux = do + now <- getMonotonicTime + ups <- readMVar (muxUps mux) + forM [ (k, u) | (k, us) <- Map.toList ups, u <- us ] $ \(k, u) -> do + n <- readTVarIO (upInflight u) + l <- readTVarIO (upLastUsed u) + pure Held { heldConfig = (ckConfig k) { substrateHeaders = [] }, heldAgent = ckAgent k + , heldCalls = n, heldIdle = max 0 (now - l) } + -- | Calls one connection carries before another is opened beside it -- (menger refuses past 256 open calls on one connection, ACCESS-29). perConnection :: Int perConnection = 200 --- | One call on the shared connection for its address and credential — --- dialed when there is none (one dial at a time per key), dropped when it --- is found dead. A call this side abandons (its thread cancelled, or its --- consumer failing) is unsubscribed, so a held connection never fills up --- with streams no one reads. +-- | One call on the shared connection for its address and credential, as +-- no agent in particular (a run's own multiplexer: the run is one agent). muxCall :: Mux -> SubstrateConfig -> ST.CallRoute -muxCall mux cfg onSub method params onItem - | shareable method params = shared mux cfg onSub method params onItem - | otherwise = muxCall' mux cfg onSub method params onItem +muxCall mux cfg = muxCallAs mux "" Nothing cfg Nothing +-- | BIDIR-18: 'muxCall' for a call that may carry an input half. +muxCallDuplex :: Mux -> SubstrateConfig -> ST.DuplexRoute +muxCallDuplex mux = muxCallAs mux "" Nothing + +-- | One call, as the agent, on the shared connection for its address and +-- credential — dialed when there is none (one dial at a time per key), +-- dropped when it is found dead — kept afterwards for the call's +-- @--hold-for@ (else the multiplexer's). A call this side abandons (its +-- thread cancelled, or its consumer failing) is unsubscribed, so a held +-- connection never fills up with streams no one reads. +-- +-- BIDIR-18: a call with an input half carries it on the same connection +-- (spec/10: only the socket that holds the call may send its input), and +-- is never shared. +muxCallAs :: Mux -> Text -> Maybe Double -> SubstrateConfig -> ST.DuplexRoute +muxCallAs mux agent hf cfg half onSub method params onItem + | Nothing <- half, shareable method params = shared mux key idle onSub method params onItem + | otherwise = muxCall' mux key idle half onSub method params onItem + where + key = keyOf agent cfg + idle = fromMaybe (muxIdle mux) hf + -- | A read every run asks the same of, and asks first: a schema -- (@.call@ of @….schema@) or @_info@. Twenty runs starting at once -- (a cold cache) wait on one answer — menger's @tickets@ schema is 2.6 MB — @@ -159,30 +261,33 @@ _ -> False -- | The read asked once: the first asks it, the rest are given what it was --- answered (or how it failed), each told it was taken first. -shared :: Mux -> SubstrateConfig -> ST.CallRoute -shared mux cfg onSub method params onItem = do - let key = (keyOf cfg, method, LBS.toStrict (encode params)) +-- answered (or how it failed), each told it was taken first. The first +-- asker's answer is always given to the rest, however its own call ends +-- (its run going away included), so none of them waits for ever. +shared :: Mux -> ConnKey -> Double -> ST.CallRoute +shared mux ck idle onSub method params onItem = mask $ \restore -> do + let key = (ck, method, LBS.toStrict (encode params)) mine <- newEmptyMVar existing <- modifyMVar (muxShared mux) $ \m -> case Map.lookup key m of Just w -> pure (m, Just w) Nothing -> pure (Map.insert key mine m, Nothing) case existing of - Just waiting -> readMVar waiting >>= \case + Just waiting -> restore $ readMVar waiting >>= \case Right items -> onSub >> mapM_ onItem items -- the first run went away (its call cancelled): ask for this one - Left e | Just (_ :: SomeAsyncException) <- fromException e -> muxCall' mux cfg onSub method params onItem + Left e | Just (_ :: SomeAsyncException) <- fromException e -> muxCall' mux ck idle Nothing onSub method params onItem Left e -> throwIO e Nothing -> do acc <- newIORef [] - r <- try (muxCall' mux cfg onSub method params (\i -> modifyIORef' acc (i :) >> onItem i)) - items <- reverse <$> readIORef acc - modifyMVar_ (muxShared mux) (pure . Map.delete key) - putMVar mine (either Left (const (Right items)) r) + r <- try (restore (muxCall' mux ck idle Nothing onSub method params (\i -> modifyIORef' acc (i :) >> onItem i))) + uninterruptibleMask_ $ do + items <- reverse <$> readIORef acc + modifyMVar_ (muxShared mux) (pure . Map.delete key) + putMVar mine (either Left (const (Right items)) r) either throwIO pure r -muxCall' :: Mux -> SubstrateConfig -> ST.CallRoute -muxCall' mux cfg onSub method params onItem = do +muxCall' :: Mux -> ConnKey -> Double -> ST.DuplexRoute +muxCall' mux key idle half onSub method params onItem = do now <- getMonotonicTime writeIORef (muxLast mux) now bracket_ (atomically (modifyTVar' (muxBusy mux) (+ 1))) @@ -190,10 +295,10 @@ getMonotonicTime >>= writeIORef (muxLast mux)) $ attempt True where - key = keyOf cfg + -- the slot taken on a connection is given back however the call ends + -- (bracket: never a connection counted busy for ever, so never idle) attempt again = do - up <- acquire mux key cfg - r <- try (onUpstream up) `finally` release up + (up, r) <- bracket (acquire mux key idle) release (\up -> (,) up <$> try (onUpstream up)) case r of -- the connection had died idle: nothing was sent, so once more on a -- fresh one (plexus-protocol's freshIfUnsent, here) @@ -213,7 +318,7 @@ StreamError{} -> writeIORef finished True _ -> pure () onItem i - S.mapM_ deliver (substrateRpcSub (upConn up) onS method params) + S.mapM_ deliver (substrateRpcDuplex (upConn up) half onS method params) `onException` do s <- readIORef sub f <- readIORef finished @@ -222,105 +327,231 @@ `catch` \(_ :: SomeException) -> pure () _ -> pure () --- | A live connection for the key with room on it, or a new one. -acquire :: Mux -> ConnKey -> SubstrateConfig -> IO Upstream -acquire mux key cfg = do +-- | A live connection for the key with room on it, or a new one — room +-- made for it first when the multiplexer holds its cap. +acquire :: Mux -> ConnKey -> Double -> IO Upstream +acquire mux key idle = do picked <- pick case picked of Just up -> pure up - Nothing -> do - lock <- modifyMVar (muxDialing mux) $ \m -> case Map.lookup key m of - Just l -> pure (m, l) - Nothing -> do - l <- newMVar () - pure (Map.insert key l m, l) - withMVar lock $ \() -> do - again <- pick - case again of - Just up -> pure up - Nothing -> do - conn <- connect cfg { substrateBackend = "" } + Nothing -> withDialLock mux key $ do + again <- pick + case again of + Just up -> pure up + Nothing -> mask $ \restore -> do + when (muxCap mux > 0) $ restore (trimTo mux (muxCap mux - 1)) + conn <- restore (dialKept (ckConfig key)) + -- held from the moment it is made: nothing between the dial and + -- the map may leave it open and held by no one + uninterruptibleMask_ $ do n <- atomicModifyIORef' (muxSerial mux) (\k -> (k + 1, k + 1)) inflight <- newTVarIO 1 - used <- newIORef =<< getMonotonicTime - let up = Upstream conn inflight used n + closing <- newTVarIO False + used <- newTVarIO =<< getMonotonicTime + held <- newIORef idle + let up = Upstream conn inflight closing used held n modifyMVar_ (muxUps mux) (pure . Map.insertWith (flip (++)) key [up]) pure up where pick = do ups <- Map.findWithDefault [] key <$> readMVar (muxUps mux) - alive <- filterAlive ups - when (length alive /= length ups) $ - modifyMVar_ (muxUps mux) (pure . Map.adjust (const alive) key) let try' [] = pure Nothing try' (u : us) = do - ok <- atomically $ do + gone <- connectionLost (upConn u) + when (isJust gone) $ drop' mux key u + now <- getMonotonicTime + ok <- if isJust gone then pure False else atomically $ do + closing <- readTVar (upClosing u) n <- readTVar (upInflight u) - if n < perConnection then True <$ writeTVar (upInflight u) (n + 1) else pure False + if not closing && n < perConnection + then True <$ (writeTVar (upInflight u) (n + 1) >> writeTVar (upLastUsed u) now) + else pure False + when ok $ writeIORef (upHoldFor u) idle if ok then pure (Just u) else try' us - try' alive - filterAlive = fmap concat . mapM (\u -> do - g <- connectionLost (upConn u) - pure [u | not (isJust g)]) + try' ups +-- | Dial in a thread of its own. A call cancelled while its connection is +-- being made (its run went away) leaves the dial to finish and the +-- connection closed — never open, answering pings, and held by no one. +dialKept :: SubstrateConfig -> IO SubstrateConnection +dialKept cfg = do + -- unmasked: the dial's own threads (reader, keepalive) start as any would + d <- asyncWithUnmask (\unmask -> unmask (connect cfg)) + wait d `onException` void (forkIO (waitCatch d >>= either (const (pure ())) + (\c -> disconnect c `catch` \(_ :: SomeException) -> pure ()))) + +-- | One dial at a time for the key; the lock is forgotten once no one +-- holds or waits for it (a holder serving a thousand throwaway ports keeps +-- no trace of them). +withDialLock :: Mux -> ConnKey -> IO a -> IO a +withDialLock mux key act = do + lock <- modifyMVar (muxDialing mux) $ \m -> case Map.lookup key m of + Just (l, n) -> pure (Map.insert key (l, n + 1) m, l) + Nothing -> do + l <- newMVar () + pure (Map.insert key (l, 1) m, l) + withMVar lock (const act) `finally` + modifyMVar_ (muxDialing mux) + (pure . Map.update (\(l, n) -> if n <= 1 then Nothing else Just (l, n - 1)) key) + +-- | Give back a call's slot, stamped in the same transaction: no sweep +-- sees it free with the time it was taken. release :: Upstream -> IO () release up = do - atomically (modifyTVar' (upInflight up) (subtract 1)) - getMonotonicTime >>= writeIORef (upLastUsed up) + now <- getMonotonicTime + atomically $ do + writeTVar (upLastUsed up) now + modifyTVar' (upInflight up) (subtract 1) +-- | Let the connection go: no call picks it from now on, it leaves the map +-- (and its key, when it was the last), and it is closed off this thread (a +-- close never holds the holder up). drop' :: Mux -> ConnKey -> Upstream -> IO () -drop' mux key up = do - modifyMVar_ (muxUps mux) (pure . Map.adjust (filter ((/= upSerial up) . upSerial)) key) - disconnect (upConn up) `catch` \(_ :: SomeException) -> pure () +drop' mux key up = uninterruptibleMask_ $ do + -- whole or not at all: a connection marked closing but left in the map + -- would be picked by no call, closed by no sweep, and keep the holder up + atomically (writeTVar (upClosing up) True) + modifyMVar_ (muxUps mux) $ pure . Map.update + (\us -> case filter ((/= upSerial up) . upSerial) us of { [] -> Nothing; rest -> Just rest }) key + void $ forkIOWithUnmask $ \unmask -> unmask (disconnect (upConn up)) `catch` \(_ :: SomeException) -> pure () --- | Close the connections nothing uses: idle ones for an address whose --- credential has since changed (a session made again), and any idle for --- longer than @maxIdle@. -sweep :: Mux -> Double -> IO () -sweep mux maxIdle = do +-- | Claim a connection nothing is on (and, by its last use, idle as the +-- test says), to close it: a call that picks it at the same moment wins, +-- and it is kept. +claimIdle :: (Double -> Bool) -> Upstream -> IO Bool +claimIdle idleEnough up = atomically $ do + n <- readTVar (upInflight up) + closing <- readTVar (upClosing up) + l <- readTVar (upLastUsed up) + if n == 0 && not closing && idleEnough l then True <$ writeTVar (upClosing up) True else pure False + +-- | Close it if it is free and idle as the test says. +closeIfIdle :: Mux -> ConnKey -> Upstream -> (Double -> Bool) -> IO () +closeIfIdle mux k u idleEnough = uninterruptibleMask_ $ do + ok <- claimIdle idleEnough u + when ok $ drop' mux k u + +-- | Close idle connections, the one idle longest first, until at most +-- @limit@ are held (a connection carrying a call is never closed for it). +trimTo :: Mux -> Int -> IO () +trimTo mux limit = do + ups <- readMVar (muxUps mux) + let held = [ (k, u) | (k, us) <- Map.toList ups, u <- us ] + excess = length held - max 0 limit + when (excess > 0) $ do + stamped <- forM held $ \(k, u) -> (\l -> (l, k, u)) <$> readTVarIO (upLastUsed u) + let close' 0 _ = pure () + close' _ [] = pure () + close' n ((_, k, u) : rest) = do + ok <- uninterruptibleMask_ $ do + c <- claimIdle (const True) u + c <$ when c (drop' mux k u) + if ok then close' (n - 1 :: Int) rest else close' n rest + close' excess (sortOn (\(l, _, _) -> l) stamped) + +-- | Let go what is not worth holding: at once, a connection whose server +-- has gone (closed, reset, or silent past the keepalive: plexus-protocol +-- has filled its 'connectionLost'); when idle, one superseded by a newer +-- credential of the same agent at the same address (a session made again), +-- and one idle for longer than its @--hold-for@ (or than @override@, a +-- draining holder's 0); and past the cap, the idle longest first. +sweep :: Mux -> Maybe Double -> IO () +sweep mux override = do now <- getMonotonicTime ups <- readMVar (muxUps mux) - -- per address, the credential used last is kept - stamped <- mapM (\(k, us) -> do - ls <- mapM (readIORef . upLastUsed) us - pure (k, us, if null ls then 0 else maximum ls)) (Map.toList ups) - let place k = (substrateHost k, substratePort k, substratePath k, substrateTls k) - latest = Map.fromListWith max [(place k, t) | (k, _, t) <- stamped] - mapM_ (\(k, us, t) -> mapM_ (\u -> do - n <- readTVarIO (upInflight u) - l <- readIORef (upLastUsed u) - let superseded = Map.lookup (place k) latest > Just t && now - l > 5 - when (n == 0 && (superseded || now - l > maxIdle)) $ drop' mux k u) us) stamped + facts <- forM [ (k, u) | (k, us) <- Map.toList ups, u <- us ] $ \(k, u) -> do + gone <- connectionLost (upConn u) + l <- readTVarIO (upLastUsed u) + hf <- maybe (readIORef (upHoldFor u)) pure override + pure (k, u, isJust gone, l, hf) + -- per agent and address, the credential used last is kept + let place k = let c = ckConfig k + in (ckAgent k, substrateHost c, substratePort c, substratePath c, substrateTls c) + lastOfKey = Map.fromListWith max [ (k, l) | (k, _, _, l, _) <- facts ] + latest = Map.fromListWith max [ (place k, l) | (k, l) <- Map.toList lastOfKey ] + forM_ facts $ \(k, u, dead, _, hf) -> + if dead then drop' mux k u else do + let superseded = Map.lookup (place k) latest > Map.lookup k lastOfKey + -- decided on the last use read with the claim, so a call that just + -- ended is never taken for one idle since before it began + closeIfIdle mux k u (\l -> (superseded && now - l > 5) || now - l > hf) + when (muxCap mux > 0) $ trimTo mux (muxCap mux) +-- | How many connections are held. +heldCount :: Mux -> IO Int +heldCount mux = sum . map length . Map.elems <$> readMVar (muxUps mux) + -- ============================================================================ -- The wire between a run and its holder -- ============================================================================ -- -- One request per unix connection, a line of JSON each way: -- --- run → holder {"host","port","path","tls","ca","headers","method","params"} --- holder → run {"t":"taken"} the request is read; it goes out now +-- run → holder {"agent","hold_for","host","port","path","tls","ca","headers","method","params"} +-- holder → run {"t":"taken","v"} the request is read; it goes out now +-- (v: the holder's synapse version) -- {"t":"sub"} the server took the call -- {"t":"item","i":ITEM} each item, as the server sent it -- {"t":"end"} the call ended -- {"t":"lost","why","sent"} the connection went (LostConnection) -- {"t":"error","why"} any other failure (a refused dial) -- +-- BIDIR-18, a call with an input half (the request has "input":true): +-- holder → run {"t":"sig","s":SIGNAL} credit, ack or input_closed, as the +-- server sent it (after "sub") +-- run → holder {"in":{"seq","items"}} one .input frame +-- b SEQ LEN one binary frame: this line (not +-- JSON: a voice call sends 50 a second), +-- then LEN bytes of payload as they are +-- {"end":{"seq"}} .end +-- The holder builds each frame with the call's subscription and sends it +-- on the call's own connection; the run numbers them and keeps the credit. +-- +-- run → holder {"status":true} +-- holder → run {"t":"status","protocol","version","pid","cap","hold_for", +-- "clients","calls","held":[{"host","port","path","tls", +-- "agent","calls","idle"}, …]} never a credential +-- +-- run → holder {"drain":true} (sent holding the socket's lock) +-- holder → run {"t":"draining"} it has let go of the socket; it +-- finishes what it carries, closes +-- what is idle, and exits +-- -- A run that goes away mid-call closes its socket; the holder cancels the -- call (unsubscribing it). -encodeRequest :: SubstrateConfig -> Text -> Value -> Value -encodeRequest c method params = object - [ "host" .= substrateHost c, "port" .= substratePort c, "path" .= substratePath c +-- | SYNAPSE-40: the holder's protocol — the wire above and what the holder +-- does with a request. It names the socket, so a run only ever talks to a +-- holder that reads it as it means it; bump it with any change to either +-- (the relay of items included: a holder built against another +-- plexus-protocol relays its 'PlexusStreamItem'). 1 was SYNAPSE-28's holder +-- per address and agent (@ADDRESS\@AGENT-VERSION.sock@, synapse 3.16.0 to +-- 3.17.3); 2 is one holder per user, the agent in each request (3.17.4); +-- 3 is 2 relaying plexus 0.8's items (RETURNS-36, synapse 4.0: the typed +-- error and progress), so a 4.0 holder never serves a 3.x run nor the +-- reverse; 4 is 3 carrying a call's input half (BIDIR-18: "input", "sig", +-- "in", "bin", "end"), so a run with input never meets a holder that +-- would drop it. +holdProtocol :: Int +holdProtocol = 4 + +encodeRequest :: Text -> Maybe Double -> Bool -> SubstrateConfig -> Text -> Value -> Value +encodeRequest agent holdFor input c method params = object $ + [ "hold_for" .= h | Just h <- [holdFor] ] ++ + [ "input" .= True | input ] ++ + [ "agent" .= agent + , "host" .= substrateHost c, "port" .= substratePort c, "path" .= substratePath c , "tls" .= isJust (substrateTls c) , "ca" .= maybe [] tlsCaFiles (substrateTls c) , "headers" .= [ [latin1 (CI.original k), latin1 v] | (k, v) <- substrateHeaders c ] , "method" .= method, "params" .= params ] where latin1 = T.pack . BS8.unpack -decodeRequest :: Value -> Maybe (SubstrateConfig, Text, Value) +decodeRequest :: Value -> Maybe (Text, Maybe Double, Bool, SubstrateConfig, Text, Value) decodeRequest = \case Object o -> do + let agent = case KM.lookup "agent" o of { Just (String a) -> a; _ -> "" } + holdFor = case KM.lookup "hold_for" o of { Just (Number n) | n > 0 -> Just (realToFrac n); _ -> Nothing } String host <- KM.lookup "host" o port <- num =<< KM.lookup "port" o String path <- KM.lookup "path" o @@ -331,7 +562,8 @@ let params = maybe Null id (KM.lookup "params" o) bytes = BS8.pack . T.unpack headers <- mapM (\case { [k, v] -> Just (CI.mk (bytes k), bytes v); _ -> Nothing }) (hs :: [[Text]]) - pure ( SubstrateConfig + pure ( agent, holdFor, KM.lookup "input" o == Just (Bool True) + , SubstrateConfig { substrateHost = T.unpack host, substratePort = port, substratePath = T.unpack path , substrateBackend = "", substrateHeaders = headers , substrateTls = if tls then Just (TlsOptions ca) else Nothing } @@ -345,6 +577,14 @@ Success a -> Just a Error _ -> Nothing +isStatusRequest, isDrainRequest :: Value -> Bool +isStatusRequest = \case + Object o -> KM.lookup "status" o == Just (Bool True) + _ -> False +isDrainRequest = \case + Object o -> KM.lookup "drain" o == Just (Bool True) + _ -> False + -- | Lines from a socket. data LineReader = LineReader N.Socket (IORef BS.ByteString) @@ -367,6 +607,30 @@ then pure Nothing else writeIORef buf (b <> chunk) >> go +-- | BIDIR-18: exactly @n@ bytes after the line just read (a binary +-- frame's payload), or Nothing when the socket ends first. +readExact :: LineReader -> Int -> IO (Maybe BS.ByteString) +readExact (LineReader s buf) n = do + b <- readIORef buf + if BS.length b >= n + then do + writeIORef buf (BS.drop n b) + pure (Just (BS.take n b)) + else do + writeIORef buf BS.empty + -- the pieces kept apart and joined once: a large payload is copied + -- once, not again with every piece + go [b] (BS.length b) + where + go acc have + | have >= n = do + let whole = BS.concat (reverse acc) + writeIORef buf (BS.drop n whole) + pure (Just (BS.take n whole)) + | otherwise = do + chunk <- NB.recv s (min (n - have) (4 * 1024 * 1024) `max` 65536) `catch` \(_ :: IOException) -> pure BS.empty + if BS.null chunk then pure Nothing else go (chunk : acc) (have + BS.length chunk) + sendLine :: N.Socket -> Value -> IO () sendLine s v = NB.sendAll s (LBS.toStrict (encode v) <> "\n") @@ -376,96 +640,209 @@ data HoldOpts = HoldOpts { hoSocket :: FilePath - , hoHoldFor :: Double -- ^ seconds with nothing to do before it exits + , hoHoldFor :: Double -- ^ seconds holding nothing, with nothing to do, before it exits + , hoCap :: Int -- ^ the most connections kept at once (0: no cap) + , hoVersion :: Text -- ^ the synapse it is (its status says so) } +-- | A holder at the socket, idle for the seconds, with the default cap. +holdOpts :: FilePath -> Double -> HoldOpts +holdOpts sock secs = HoldOpts { hoSocket = sock, hoHoldFor = secs, hoCap = defaultCap, hoVersion = "" } + -- | Ten minutes. defaultHoldFor :: Double defaultHoldFor = 600 --- | Serve the socket until idle for 'hoHoldFor', then remove it and exit. +-- | Serve the socket until it has held nothing, with no run on it, for +-- 'hoHoldFor'; then remove it and exit. SIGTERM / SIGHUP: stop taking +-- runs at once, give the calls under way ten seconds to end, and go (a +-- stream still open then is told its connection was lost, and resumes as +-- SYNAPSE-20 says). Told to drain (a newer synapse is taking its place): +-- let go of the socket at once, close what is idle, finish what is open, +-- and go. runHolder :: HoldOpts -> IO () runHolder HoldOpts{..} = do - mux <- newMux + -- a holder that started slowly may find another serving the socket by + -- now: that one stays, this one goes + already <- answers hoSocket + when already exitSuccess + mux <- newMuxWith hoCap hoHoldFor clients <- newTVarIO (0 :: Int) lastSeen <- newIORef =<< getMonotonicTime + draining <- newIORef False lsock <- N.socket N.AF_UNIX N.Stream N.defaultProtocol privateDir (takeDirectory hoSocket) removeIfExists hoSocket N.bind lsock (N.SockAddrUnix hoSocket) setFileMode hoSocket 0o600 - N.listen lsock 128 + -- one holder takes every run of the user's: a long queue, so a burst of + -- runs never finds it full (and takes it for gone) + N.listen lsock (max 128 N.maxListenQueue) ours <- fileID <$> getFileStatus hoSocket + pid <- getProcessID done <- newEmptyMVar - let shutdown = do - withLock (hoSocket <> ".lock") $ do - N.close lsock `catch` \(_ :: SomeException) -> pure () - -- only our own socket: another holder may have replaced it - st <- try (getFileStatus hoSocket) - case st of - Right s | fileID s == ours -> removeIfExists hoSocket - Left (_ :: SomeException) -> pure () - _ -> pure () - -- what was taken before the close is finished first - atomically $ readTVar clients >>= \n -> check (n == 0) + let unlink = do + N.close lsock `catch` \(_ :: SomeException) -> pure () + -- only our own socket: another holder may have replaced it + st <- try (getFileStatus hoSocket) + case st of + Right s | fileID s == ours -> removeIfExists hoSocket + Left (_ :: SomeException) -> pure () + _ -> pure () + close' = withLock (hoSocket <> ".lock") unlink + -- the run asking holds the lock: let go of the socket under it + drain = unlink >> writeIORef draining True + touch = getMonotonicTime >>= writeIORef lastSeen + -- what was taken before the close is finished first: however long + -- that takes when idle, ten seconds when told to go + shutdown grace = do + close' + let drained = atomically $ readTVar clients >>= \n -> check (n == 0) + maybe drained (\secs -> void (timeout (round (secs * 1000000 :: Double)) drained)) grace void (tryPutMVar done ()) - main' <- myThreadId - _ <- installHandler sigTERM (Catch (void (forkIO shutdown))) Nothing - _ <- installHandler sigHUP (Catch (void (forkIO shutdown))) Nothing + status = do + held <- muxHolding mux + n <- readTVarIO clients + (busy, _) <- muxActive mux + pure $ object + [ "t" .= ("status" :: Text), "protocol" .= holdProtocol, "version" .= hoVersion + , "pid" .= (fromIntegral pid :: Int), "cap" .= hoCap, "hold_for" .= hoHoldFor + , "clients" .= (n - 1 :: Int) -- the one asking is not counted + , "calls" .= busy + , "held" .= [ object [ "host" .= substrateHost c, "port" .= substratePort c, "path" .= substratePath c + , "tls" .= isJust (substrateTls c), "agent" .= heldAgent h + , "calls" .= heldCalls h, "idle" .= (fromIntegral (round (heldIdle h * 10) :: Int) / 10 :: Double) ] + | h <- held, let c = heldConfig h ] ] + _ <- installHandler sigTERM (Catch (void (forkIO (shutdown (Just 10))))) Nothing + _ <- installHandler sigHUP (Catch (void (forkIO (shutdown (Just 10))))) Nothing + -- a status asked, or a run only seeing that a holder answers, is no + -- activity: only a call keeps a holder that holds nothing _ <- forkIO $ forever $ do r <- try (N.accept lsock) case r of Left (_ :: SomeException) -> threadDelay 100000 Right (s, _) -> do atomically (modifyTVar' clients (+ 1)) - getMonotonicTime >>= writeIORef lastSeen void $ forkIO $ - serveClient mux s `finally` do + serveClient mux (Served status drain touch hoVersion) s `finally` do N.close s `catch` \(_ :: SomeException) -> pure () - getMonotonicTime >>= writeIORef lastSeen atomically (modifyTVar' clients (subtract 1)) _ <- forkIO $ forever $ do threadDelay 1000000 - sweep mux hoHoldFor + d <- readIORef draining + sweep mux (if d then Just 0 else Nothing) n <- readTVarIO clients (busy, lastCall) <- muxActive mux + held <- heldCount mux seen <- readIORef lastSeen now <- getMonotonicTime - when (n == 0 && busy == 0 && now - max seen lastCall >= hoHoldFor) shutdown - _ <- pure main' + when (n == 0 && busy == 0 && held == 0 && (d || now - max seen lastCall >= hoHoldFor)) (shutdown Nothing) takeMVar done exitSuccess +-- | What a request may ask of the holder beside a call. +data Served = Served + { svStatus :: IO Value -- ^ what it holds + , svDrain :: IO () -- ^ let go of the socket and wind down + , svTouch :: IO () -- ^ a call came or went + , svVersion :: Text -- ^ the synapse the holder is + + } + -- | One run's request: read it, say it is taken, relay the call, say how --- it ended. The run closing its end cancels the call. -serveClient :: Mux -> N.Socket -> IO () -serveClient mux s = do +-- it ended — or, asked for it, the status, or drain. The run closing its +-- end cancels the call. +serveClient :: Mux -> Served -> N.Socket -> IO () +serveClient mux sv s = do rd <- newLineReader s line <- timeout 30000000 (readLine rd) case line >>= id >>= decodeStrict of Nothing -> pure () + Just v | isStatusRequest v -> svStatus sv >>= sendLine s + Just v | isDrainRequest v -> do + svDrain sv + sendLine s (object ["t" .= ("draining" :: Text)]) Just v -> case decodeRequest v of Nothing -> sendLine s (object ["t" .= ("error" :: Text), "why" .= ("synapse holder: a request it cannot read" :: Text)]) - Just (cfg, method, params) -> do - sendLine s (object ["t" .= ("taken" :: Text)]) - let call = muxCall mux cfg + Just (agent, holdFor, input, cfg, method, params) -> flip finally (svTouch sv) $ do + svTouch sv + sendLine s (object ["t" .= ("taken" :: Text), "v" .= svVersion sv]) + -- BIDIR-18: the call's input port, once the server has taken it; + -- what the run sends for it goes out on the call's connection + port <- newEmptyMVar + failed <- newEmptyMVar + let half | input = Just InputHalf + { ihPort = void . tryPutMVar port + , ihSignal = \g -> sendLine s (object ["t" .= ("sig" :: Text), "s" .= inputSignalValue g]) } + | otherwise = Nothing + call = muxCallAs mux agent holdFor cfg half (sendLine s (object ["t" .= ("sub" :: Text)])) method params (\i -> sendLine s (object ["t" .= ("item" :: Text), "i" .= i])) withAsync call $ \a -> do - -- the run going away (its end closed) ends the call + -- the run going away (its end closed) ends the call; with an + -- input half, the run's frames are relayed until then watcher <- async $ do - _ <- readLine rd + r <- try (relayInput rd port) + case r of + Left (e :: SomeException) + | Just (_ :: SomeAsyncException) <- fromException e -> throwIO e + -- a frame the connection could not take: the call reports the loss + | Just (_ :: LostConnection) <- fromException e -> void (readLine rd) + -- anything else ends the call, said + | otherwise -> void (tryPutMVar failed ("synapse holder: the input failed: " <> T.pack (show e))) + Right Nothing -> pure () + Right (Just why) -> void (tryPutMVar failed why) cancel a r <- waitCatch a cancel watcher + bad <- tryTakeMVar failed let reply = case r of + _ | Just why <- bad -> object ["t" .= ("error" :: Text), "why" .= why] Right () -> object ["t" .= ("end" :: Text)] Left e | Just (LostConnection why sent) <- fromException e -> object ["t" .= ("lost" :: Text), "why" .= why, "sent" .= sent] Left e -> object ["t" .= ("error" :: Text), "why" .= errorText e] sendLine s reply `catch` \(_ :: SomeException) -> pure () +-- | BIDIR-18: the run's input frames, each sent on the call's connection +-- through its port, until the run's end closes ('Nothing') or it sends +-- what the holder cannot read (why, and the call is ended). +relayInput :: LineReader -> MVar InputPort -> IO (Maybe Text) +relayInput rd port = loop + where + loop = do + line <- readLine rd + case line of + Nothing -> pure Nothing + Just l + | Just rest <- BS8.stripPrefix "b " l + , Just (sq, rest') <- BS8.readInt rest + , Just (' ', lenText) <- BS8.uncons rest' + , Just (len, "") <- BS8.readInt lenText + , sq >= 0, len >= 0 -> if len > In.maxChunk + then pure (Just ("synapse holder: a binary frame of " <> T.pack (show len) + <> " bytes is past the " <> T.pack (show In.maxChunk) <> " a frame may carry")) + else do + payload <- readExact rd len + case payload of + Nothing -> pure Nothing + Just bytes -> do + p <- readMVar port + ipBinary p (fromIntegral sq) bytes >> loop + Just l -> case decodeStrict l of + Just (Object o) + | Just (Object f) <- KM.lookup "in" o, Just sq <- seqOf f, Just (Array items) <- KM.lookup "items" f -> do + p <- readMVar port + ipItems p sq (foldr (:) [] items) >> loop + | Just (Object f) <- KM.lookup "end" o, Just sq <- seqOf f -> do + p <- readMVar port + ipEnd p sq >> loop + _ -> pure (Just "synapse holder: an input frame it cannot read") + seqOf f = case KM.lookup "seq" f of + Just (Number n) | n >= 0 -> Just (round n) + _ -> Nothing + -- | An exception as the run should rethrow it: an error call's message as -- it is ('connect' reports a failed dial as one), anything else shown. errorText :: SomeException -> Text @@ -483,18 +860,58 @@ instance Exception HolderGone --- | One call through the holder at the socket. Throws 'HolderGone' when --- the holder cannot be reached or closes before taking the request (the --- request did not go out); after that, what the holder reports. -holderCall :: FilePath -> SubstrateConfig -> ST.CallRoute -holderCall path cfg onSub method params onItem = do - s <- N.socket N.AF_UNIX N.Stream N.defaultProtocol +-- | A connection to the holder's socket. A queue that is full answers +-- EAGAIN: that is a holder, busy, so it is tried again (for a second) +-- rather than taken for none. +openHolder :: FilePath -> IO N.Socket +openHolder path = go (50 :: Int) + where + go n = do + s <- N.socket N.AF_UNIX N.Stream N.defaultProtocol + r <- try (N.connect s (N.SockAddrUnix path)) + case r of + Right () -> pure s + Left (e :: SomeException) -> do + N.close s `catch` \(_ :: SomeException) -> pure () + if busy e && n > 0 then threadDelay 20000 >> go (n - 1) else throwIO e + +-- | EAGAIN: the listener's queue is full. +busy :: SomeException -> Bool +busy e = case fromException e of + Just io -> fmap Errno (ioe_errno io) == Just eAGAIN + Nothing -> False + +-- | One call through the holder at the socket, as the agent. Throws +-- 'HolderGone' when the holder cannot be reached or closes before taking +-- the request (the request did not go out); after that, what the holder +-- reports. +holderCall :: FilePath -> Text -> SubstrateConfig -> ST.CallRoute +holderCall path agent cfg = holderCallDuplex path agent Nothing (const (pure ())) cfg Nothing + +-- | 'holderCall', the connection kept for @holdFor@ seconds idle (else the +-- holder's own @--hold-for@), and @onTaken@ told the holder's synapse +-- version when it takes the request. +-- +-- BIDIR-18: with an input half, the half's port writes the frames to the +-- holder (it sends them on the call's connection), and the holder's +-- relayed signals reach the half. +holderCallAs :: FilePath -> Text -> Maybe Double -> (Text -> IO ()) -> SubstrateConfig -> ST.CallRoute +holderCallAs path agent holdFor onTaken cfg = holderCallDuplex path agent holdFor onTaken cfg Nothing + +-- | 'holderCallAs' for a call that may carry an input half. +holderCallDuplex :: FilePath -> Text -> Maybe Double -> (Text -> IO ()) -> SubstrateConfig -> ST.DuplexRoute +holderCallDuplex path agent holdFor onTaken cfg0 half onSub method params onItem = do + -- a CA file named relative to this run's directory is named whole: the + -- holder runs in / and serves every run + cfg <- case substrateTls cfg0 of + Just t -> (\fs -> cfg0 { substrateTls = Just t { tlsCaFiles = fs } }) <$> mapM makeAbsolute (tlsCaFiles t) + Nothing -> pure cfg0 + c <- try (openHolder path) + s <- case c of + Left (e :: SomeException) -> throwIO (HolderGone (T.pack (show e))) + Right s -> pure s flip finally (N.close s `catch` \(_ :: SomeException) -> pure ()) $ do - c <- try (N.connect s (N.SockAddrUnix path)) - case c of - Left (e :: SomeException) -> throwIO (HolderGone (T.pack (show e))) - Right () -> pure () - sent <- try (sendLine s (encodeRequest cfg method params)) + sent <- try (sendLine s (encodeRequest agent holdFor (isJust half) cfg method params)) case sent of Left (e :: SomeException) -> throwIO (HolderGone (T.pack (show e))) Right () -> pure () @@ -506,8 +923,17 @@ | taken -> throwIO (LostConnection "the connection holder went away" True) | otherwise -> throwIO (HolderGone "the holder closed before taking the request") Just (Object o) -> case KM.lookup "t" o of - Just (String "taken") -> loop True - Just (String "sub") -> onSub >> loop True + Just (String "taken") -> do + mapM_ (\case { String v -> onTaken v; _ -> pure () }) (KM.lookup "v" o) + loop True + Just (String "sub") -> do + mapM_ (\h -> ihPort h (holderPort s)) half + onSub >> loop True + Just (String "sig") -> do + case KM.lookup "s" o >>= inputSignal of + Just g -> mapM_ (\h -> ihSignal h g) half + Nothing -> pure () + loop True Just (String "item") -> do case fromJSON <$> KM.lookup "i" o of Just (Success i) -> onItem i @@ -524,22 +950,75 @@ Just _ -> loop taken loop False --- | The holder's socket for an address and agent: --- @$XDG_RUNTIME_DIR/synapse/DIR\@AGENT-VERSION.sock@ (a temporary --- directory of the user's own without one). A name too long for a unix --- socket is shortened to a hash of itself. -socketPathFor :: Text -> FilePath -> Text -> IO FilePath -socketPathFor version addrDir agent = do - base <- runtimeDir - let name = addrDir <> "@" <> T.unpack (safe agent) <> "-" <> T.unpack version <> ".sock" - full = base name - pure $ if length full < 100 then full else base (show (fnv (T.pack name)) <> ".sock") +-- | BIDIR-18: a call's input port through the holder: each frame a line +-- to it (a binary one, its line and then its payload). A write the +-- holder's socket refuses is the call's connection lost — the frame may +-- not have gone, and nothing is sent again. +holderPort :: N.Socket -> InputPort +holderPort s = InputPort + { ipItems = \sq items -> relay (sendLine s (object ["in" .= object ["seq" .= sq, "items" .= items]])) + , ipBinary = \sq payload -> relay $ NB.sendMany s + [ BS8.pack ("b " <> show sq <> " " <> show (BS.length payload) <> "\n"), payload ] + , ipEnd = \sq -> relay (sendLine s (object ["end" .= object ["seq" .= sq]])) + } where - safe = T.map (\ch -> if ch `elem` ("/\\\0" :: String) then '_' else ch) - -- a stable hash of the name (polynomial, mod 2^61-1): only its length matters here - fnv :: Text -> Integer - fnv = T.foldl' (\h ch -> (h * 131 + fromIntegral (fromEnum ch)) `mod` 2305843009213693951) 7 + relay act = act `catch` \(e :: IOException) -> + throwIO (LostConnection ("the connection holder went away (" <> T.pack (show e) <> ")") True) +-- | SYNAPSE-40: what the holder at the socket holds, as it says +-- (@{"t":"status", …}@), or Nothing when no holder answers there. +holderStatus :: FilePath -> IO (Maybe Value) +holderStatus path = do + r <- try $ bracket (openHolder path) N.close $ \s -> do + sendLine s (object ["status" .= True]) + rd <- newLineReader s + timeout 5000000 (readLine rd) + pure $ case r of + Right (Just (Just line)) | Just v@(Object o) <- decodeStrict line + , KM.lookup "t" o == Just (String "status") -> Just v + Left (_ :: SomeException) -> Nothing + _ -> Nothing + +-- | SYNAPSE-40: is synapse version @a@ older than @b@? (Unreadable: no.) +olderThan :: Text -> Text -> Bool +olderThan a b = case (parts a, parts b) of + (Just x, Just y) -> x < y + _ -> False + where + parts :: Text -> Maybe [Int] + parts v = case T.splitOn "." (T.strip v) of + [""] -> Nothing + ps -> mapM (readMaybe . T.unpack) ps + +-- | SYNAPSE-40: a run newer than the holder puts its own in its place. +-- Under the socket's lock, the holder is asked its version again; still +-- older, it is told to drain (it lets go of the socket at once, closes +-- what is idle, finishes what is open, and exits), and this run's binary +-- starts in its stead. A run of an older synapse never replaces a newer +-- holder, so the newest in use serves every run and two never take turns. +replaceHolder :: FilePath -> Double -> Text -> IO () +replaceHolder path holdFor ours = void $ (try :: IO a -> IO (Either SomeException a)) $ do + privateDir (takeDirectory path) + withLock (path <> ".lock") $ do + st <- holderStatus path + case st of + Just (Object o) | Just (String v) <- KM.lookup "version" o, olderThan v ours -> do + drained <- try $ bracket (openHolder path) N.close $ \s -> do + sendLine s (object ["drain" .= True]) + rd <- newLineReader s + timeout 5000000 (readLine rd) + case drained of + Right (Just (Just _)) -> void (spawnHolder path holdFor) + Left (_ :: SomeException) -> pure () + _ -> pure () + _ -> pure () + +-- | SYNAPSE-40: the one holder's socket: +-- @$XDG_RUNTIME_DIR/synapse/holder-4.sock@ (a temporary directory of the +-- user's own without one) — one per user and 'holdProtocol'. +holderSocketPath :: IO FilePath +holderSocketPath = ( ("holder-" <> show holdProtocol <> ".sock")) <$> runtimeDir + runtimeDir :: IO FilePath runtimeDir = do x <- lookupEnv "XDG_RUNTIME_DIR" @@ -551,19 +1030,29 @@ pure (tmp ("synapse-" <> show uid)) -- | Start the holder for the socket unless one answers there, under the --- socket's lock (so parallel first runs start one), and wait for it. +-- socket's lock (so parallel first runs start one), and wait for it — up +-- to 3 s, or until it has exited without answering (a socket it could not +-- bind), so a run never waits on a holder that is not coming. ensureHolder :: FilePath -> Double -> IO Bool ensureHolder path holdFor = do privateDir (takeDirectory path) withLock (path <> ".lock") $ do up <- answers path - if up then pure True else do + if up then pure True else spawnHolder path holdFor + +-- | Start a holder at the socket and wait for it (the socket's lock held). +spawnHolder :: FilePath -> Double -> IO Bool +spawnHolder path holdFor = do removeIfExists path exe <- getExecutablePath devnull <- openFile "/dev/null" ReadWriteMode logH <- openFile (path <> ".log") WriteMode setFileMode (path <> ".log") 0o600 procfs <- doesDirectoryExist "/proc/self/fd" + -- SYNAPSE-40: the one holder outlives the run that starts it, so it + -- takes nothing of that run's it does not need: not its directory (a + -- worktree it would keep in use), nor a secret in its environment + env <- filter ((`notElem` notForTheHolder) . fst) <$> getEnvironment let args = ["_hold", "--socket", path, "--hold-for", show holdFor] -- the holder keeps nothing of the run's but its own socket: every -- descriptor past stderr is closed before it starts. close_fds @@ -572,17 +1061,28 @@ spawn | procfs = (proc "/bin/sh" (["-c", closeOpenFds, "synapse-hold", exe] ++ args)) { close_fds = False } | otherwise = (proc exe args) { close_fds = True } - _ <- createProcess spawn + (_, _, _, ph) <- createProcess spawn { std_in = UseHandle devnull, std_out = UseHandle devnull, std_err = UseHandle logH - , new_session = True } + , new_session = True, cwd = Just "/", env = Just env } hClose devnull hClose logH let wait (0 :: Int) = pure False wait n = do ok <- answers path - if ok then pure True else threadDelay 5000 >> wait (n - 1) + if ok then pure True else do + ended <- getProcessExitCode ph + case ended of + Just _ -> pure False + Nothing -> threadDelay 5000 >> wait (n - 1) wait 600 -- 3 s +-- | What a run may carry in its environment that the holder must not take: +-- a key's seed, a session, a token (the holder signs nothing in; every +-- request brings its credential), and one run's keepalive (off, say), which +-- would be every connection's. +notForTheHolder :: [String] +notForTheHolder = ["PLEXUS_KEY", "PLEXUS_SESSION", "SYNAPSE_TOKEN", "PLEXUS_KEEPALIVE"] + -- | A shell's start for the holder: close every descriptor past stderr -- that is open, then exec the holder (the arguments after @$0@). closeOpenFds :: String @@ -591,56 +1091,73 @@ , "case $n in 0|1|2|*[!0-9]*) ;; *) eval \"exec $n>&-\" 2>/dev/null ;; esac; done; " , "exec \"$@\"" ] --- | Does something accept on the socket? +-- | Does a holder accept on the socket? One whose queue is full (EAGAIN +-- past 'openHolder''s second) is there, busy: never replaced for it. answers :: FilePath -> IO Bool answers path = do - s <- N.socket N.AF_UNIX N.Stream N.defaultProtocol - r <- try (N.connect s (N.SockAddrUnix path)) - N.close s `catch` \(_ :: SomeException) -> pure () - pure (either (\(_ :: SomeException) -> False) (const True) r) + r <- try (openHolder path) + case r of + Right s -> True <$ (N.close s `catch` \(_ :: SomeException) -> pure ()) + Left e -> pure (busy e) -- ============================================================================ -- The router -- ============================================================================ data RouterOpts = RouterOpts - { roHold :: Maybe (SubstrateConfig -> IO (Maybe FilePath)) - -- ^ the holder's socket for a call's address (and the run's agent), or - -- Nothing for an address this run does not hold (a registry it only + { roHold :: Maybe (SubstrateConfig -> IO (Maybe Text)) + -- ^ the agent a call to this address is made as, through the holder, + -- or Nothing for an address this run does not hold (a registry it only -- glances at); Nothing at all: this process's multiplexer alone -- (@--no-hold@) - , roHoldFor :: Double + , roSocket :: FilePath -- ^ the holder's socket ('holderSocketPath') + , roHoldFor :: Double -- ^ how long a connection is kept idle, sent with each call + , roVersion :: Text -- ^ this synapse's version: an older holder is replaced } --- | Route every call of this process: through the holder for its address --- (started when there is none), else on this process's own shared --- connection. +-- | Route every call of this process: through the holder (started when +-- there is none), else on this process's own shared connection. installRouter :: RouterOpts -> IO Mux installRouter ro = do mux <- newMux broken <- newIORef False - paths <- newIORef Map.empty - ST.setCallRouter (\cfg -> Just (routedCall ro mux broken paths cfg)) + agents <- newIORef Map.empty + replaced <- newIORef False + ST.setDuplexRouter (\cfg -> Just (routedCall ro mux broken agents replaced cfg)) pure mux -routedCall :: RouterOpts -> Mux -> IORef Bool -> IORef (Map.Map ConnKey (Maybe FilePath)) -> SubstrateConfig -> ST.CallRoute -routedCall ro mux broken paths cfg onSub method params onItem = do +routedCall :: RouterOpts -> Mux -> IORef Bool -> IORef (Map.Map ConnKey (Maybe Text)) -> IORef Bool -> SubstrateConfig -> ST.DuplexRoute +routedCall ro mux broken agents replaced cfg half onSub method params onItem = do b <- readIORef broken - held <- case roHold ro of - Just socketFor | not b -> do - known <- Map.lookup (keyOf cfg) <$> readIORef paths - p <- maybe (socketFor cfg) pure known - modifyIORef' paths (Map.insert (keyOf cfg) p) - pure p + agent <- case roHold ro of + Just agentFor | not b -> do + let k = keyOf "" cfg + known <- Map.lookup k <$> readIORef agents + a <- maybe (agentFor cfg) pure known + modifyIORef' agents (Map.insert k a) + pure a _ -> pure Nothing - -- the socket's directory must be this user's alone (0700, owned by it) - ours <- maybe (pure False) (dirIsOurs . takeDirectory) held - case held of - Just path | ours -> do - let via = holderCall path cfg onSub method params onItem + -- the socket's directory must be this user's alone (0700, owned by it), + -- and the path short enough for a unix socket (107 bytes) + let path = roSocket ro + fits = BS.length (TE.encodeUtf8 (T.pack path)) < 108 + ours <- if fits then maybe (pure False) (const (dirIsOurs (takeDirectory path))) agent else pure False + case agent of + Just a | ours -> do + seen <- newIORef Nothing + let via = holderCallDuplex path a (Just (roHoldFor ro)) (writeIORef seen . Just) cfg half onSub method params onItem + -- an older holder answered: once a run, this run's takes its place + newer = do + v <- readIORef seen + done <- readIORef replaced + case v of + Just old | not done, olderThan old (roVersion ro) -> do + writeIORef replaced True + replaceHolder path (roHoldFor ro) (roVersion ro) + _ -> pure () r <- try via case r of - Right () -> pure () + Right () -> newer Left (HolderGone _) -> do ok <- ensureHolder path (roHoldFor ro) if not ok then local' else do @@ -648,12 +1165,12 @@ case r' of Right () -> pure () Left (HolderGone _) -> local' - _ -> muxCall mux cfg onSub method params onItem + _ -> muxCallDuplex mux cfg half onSub method params onItem where -- no holder to be had: this process's own connection, for the rest of it local' = do writeIORef broken True - muxCall mux cfg onSub method params onItem + muxCallDuplex mux cfg half onSub method params onItem -- ============================================================================ -- Files diff --git a/src/Synapse/IR/Builder.hs b/src/Synapse/IR/Builder.hs --- a/src/Synapse/IR/Builder.hs +++ b/src/Synapse/IR/Builder.hs @@ -3,20 +3,36 @@ -- | IR Builder - walks schema tree and constructs the IR -- --- Uses the existing schema walker with a custom algebra that: --- 1. Reads types from $defs in methodParams, methodReturns and methodInput --- — whole, or refused by name (SYNAPSE-CC-8: "Synapse.IR.Read") --- 2. Deduplicates types by content hash, placing each shared type in the --- namespace that refers to it most (SYNAPSE-CC-8) --- 3. Infers streaming from return type structure --- 4. Builds method definitions with type references; server-injected params --- go to 'mdInjected', never 'mdParams' +-- IR 3.0 (plexus 0.7, RETURNS-13) over 2.1's reader (SYNAPSE-CC-8). The +-- schema walker runs a custom algebra that, for every method, reads from +-- the schema, never guessing: +-- +-- 1. its item type (@returns@), error type (@error@) and progress type +-- (@progress@), each a 'TypeRef' — a 'RefNamed' with a 'TypeDef', or a +-- primitive / array / optional / JSON ref — and its params and @input@; +-- every type in them read whole, or refused by name ("Synapse.IR.Read"); +-- 2. its cardinality (@cardinality@), as is ('mdCardinality'); +-- 3. its params, server-injected ones going to 'mdInjected', never +-- 'mdParams'. +-- +-- One title in one namespace is one type: two methods whose schemas give a +-- name the same shape share one 'TypeDef'; two shapes under one name fail +-- the build ('TitleCollision'), naming both methods. Identical types in +-- different namespaces are then deduplicated, each placed in the namespace +-- that refers to it most (SYNAPSE-CC-8). module Synapse.IR.Builder ( -- * Building IR buildIR , buildIRRaw + , buildIRFromSchema + , buildIRFromSchemas , finalizeIR + -- * Errors + , IRBuildError(..) + , TypeSource(..) + , renderIRBuildError + -- * Extraction (for testing) , extractTypesFromSchema , extractMethodDef @@ -24,6 +40,9 @@ , schemaToTypeRef ) where +import Control.Applicative ((<|>)) +import Control.Monad (foldM) +import Control.Monad.Except (throwError) import Control.Monad.IO.Class (liftIO) import Control.Monad.Reader (asks) import Data.Aeson (Value(..)) @@ -43,6 +62,7 @@ import Synapse.Schema.Types import Synapse.Schema.Functor (SchemaF(..)) import Synapse.Algebra.Walk (walkSchemaPar) +import Synapse.Transport (fetchServiceIR, rootSchemaKnown) import Synapse.Monad import Synapse.IR.Types hiding (QualifiedName(..), qualifiedNameFull) import Synapse.IR.Types (QualifiedName(..), qualifiedNameFull, synapseVersion) @@ -50,6 +70,54 @@ import Plexus.Schema.Recursive (DeprecationInfo, ParamSchema(..), paramValues) -- ============================================================================ +-- Errors +-- ============================================================================ + +-- | Why no IR can be built from a schema. +data IRBuildError + = TitleCollision + { tcNamespace :: Text -- ^ The namespace both types are in + , tcTitle :: Text -- ^ The name they share + , tcFirst :: TypeSource -- ^ Where the first shape was read + , tcSecond :: TypeSource -- ^ Where the second, different, shape was read + } + -- ^ Two different shapes carry one name in one namespace (RETURNS-13). + -- One name in one namespace is one Rust type, so this is a conflict + -- the activation's author resolves; the IR never picks one. + | MissingSchema + { msPath :: Path -- ^ A walk's root no schema was given for + } + -- ^ RETURNS-40: 'buildIRFromSchemas' was asked for a root it has no + -- schema of (a walk from there would fail its first fetch). + deriving stock (Show, Eq) + +-- | Where a 'TypeDef' was read: a method, and which of its schemas. +data TypeSource = TypeSource + { tsMethod :: Text -- ^ The method's name + , tsSchema :: Text -- ^ @"params"@, @"returns"@, @"error"@, @"progress"@ or @"input"@ + } + deriving stock (Show, Eq) + +-- | One line, naming the title and both methods. +renderIRBuildError :: IRBuildError -> Text +renderIRBuildError TitleCollision{..} = + "IR: two different types are titled \"" <> tcTitle <> "\" in namespace " + <> renderNamespace tcNamespace <> ": " <> renderSource tcFirst + <> " and " <> renderSource tcSecond + <> ". One title in one namespace is one type; rename one of them." + where + renderNamespace ns + | T.null ns = "(root)" + | otherwise = "\"" <> ns <> "\"" + renderSource TypeSource{..} = "method " <> tsMethod <> " (" <> tsSchema <> ")" +renderIRBuildError MissingSchema{..} = + "IR: no schema at " <> (if null msPath then "the root" else T.intercalate "." msPath) + +-- | Raise an 'IRBuildError' in 'SynapseM'. +liftBuild :: Either IRBuildError a -> SynapseM a +liftBuild = either (throwError . ValidationError . renderIRBuildError) pure + +-- ============================================================================ -- Building IR -- ============================================================================ @@ -75,10 +143,30 @@ -- After walking, deduplicate types that have identical structure -- Accepts generator info strings in "tool:version" format -- Uses parallel schema fetching for better performance +-- +-- RETURNS-40: a service that writes its own IR (@.ir@, plexus-core +-- 0.8: its own schema lists @ir@, read from the run's memo or the schema +-- cache when they have it) is asked for it first, one call for the whole walk; its IR is the +-- one this walk would build from the same schemas. The walk is made only +-- for a service with no @ir@ (every 0.7.0 one), or from the schema cache +-- alone (SYNAPSE-28), which has no server to ask. buildIR :: [Text] -> Path -> SynapseM IR buildIR generatorInfoStrs path = do backend <- asks seBackend - raw <- walkSchemaPar irAlgebra path + src <- asks seSchemaSource + served <- case src of + FromServer _ -> do + -- review #5: asked only of a service whose own schema lists `ir` + -- (every 0.7.0 one lists none: no call is spent on it) + root <- rootSchemaKnown + if maybe False (any ((== "ir") . methodName) . psMethods) root + then fetchServiceIR path + else pure Nothing + FromCache _ -> pure Nothing + built <- case served of + Just (Right ir) -> pure ir + Just (Left why) -> throwError (ValidationError why) + Nothing -> finalizeIR <$> walkSchemaPar irAlgebra path -- Parse generator info and add synapse itself let parsedGens = mapMaybe parseGeneratorInfo generatorInfoStrs @@ -95,7 +183,7 @@ , gmIrVersion = irVersion emptyIR } - pure $ finalizeIR raw + pure built { irBackend = backend , irMetadata = Just metadata } @@ -104,6 +192,57 @@ buildIRRaw :: Path -> SynapseM IR buildIRRaw = walkSchemaPar irAlgebra +-- | Build IR from one plugin schema, with no backend: what 'buildIR' builds +-- for a walk that starts at @path@ and finds this schema there, children +-- aside (they are summaries; nothing fetches them). 'irMetadata' is +-- 'Nothing' — the toolchain and the clock are 'buildIR''s to record — so +-- the result is a pure function of its arguments (RETURNS-13: the +-- conformance fixture's golden @ir.json@ is built with it, and RETURNS-40's +-- server-side IR is held equal to it). +buildIRFromSchema + :: Text -- ^ Backend name ('irBackend') + -> Path -- ^ The path the schema sits at; its namespace is the path joined with "." + -> PluginSchema + -> Either IRBuildError IR +buildIRFromSchema backend path schema = do + raw <- pluginIR path schema [] + pure $ (finalizeIR raw) + { irBackend = backend + , irMetadata = Nothing + } + +-- | RETURNS-40: what 'buildIR' builds for a walk from each of @roots@, +-- with every schema it would fetch given (by path, the root at @[]@), +-- less 'irMetadata': the walk's own fold — a node's IR from its schema and +-- its children's, in its @children@ order, a child no schema is given for +-- skipped as a walk skips one whose fetch failed — each root's IR merged +-- left to right, then 'finalizeIR'. A node whose schemas put two shapes +-- under one title is refused as the walk refuses it ('pluginIRRefusing'), +-- so only a root with no schema fails. One root is exactly what +-- @synapse -i @ prints. The IR a service writes itself +-- (plexus-core's @.ir@) is held equal to it. +buildIRFromSchemas + :: Text -- ^ Backend name ('irBackend') + -> [Path] -- ^ The walks' roots + -> Map Path PluginSchema -- ^ Every schema the walks read, by path + -> Either IRBuildError IR +buildIRFromSchemas backend roots schemas = do + irs <- traverse walk roots + let raw = foldr mergeIR emptyIR irs + pure $ (finalizeIR raw) + { irBackend = backend + , irMetadata = Nothing + } + where + walk path = case Map.lookup path schemas of + Nothing -> Left (MissingSchema path) + Just schema -> do + let kids = [ path ++ [csNamespace c] | c <- fromMaybe [] (psChildren schema), Map.member (path ++ [csNamespace c]) schemas ] + childIRs <- traverse walk kids + -- the walk's own node: a title collision refuses the activation, + -- not the walk (RETURNS-36 review #9) + pure (pluginIRRefusing path schema childIRs) + -- | SYNAPSE-CC-8: the walk's IR made whole — shared types deduplicated and -- placed where they are referred to most, every ref that names no type -- turned to 'RefUnknown' (and refused, unless the type it names was), the @@ -122,14 +261,50 @@ -- - Build method definitions -- - Merge with child results irAlgebra :: SchemaF IR -> SynapseM IR -irAlgebra (PluginF schema path childIRs) = do +irAlgebra (PluginF schema path childIRs) = pure (pluginIRRefusing path schema childIRs) + +irAlgebra (MethodF method namespace path) = liftBuild $ do + -- Single method node (shouldn't happen in normal walk, but handle it) + let fullPath = T.intercalate "." path + ((types, mdef), refusals) <- extractMethodDefR namespace fullPath method + pure $ IR + { irVersion = irVersion emptyIR -- Use version from emptyIR + , irBackend = irBackend emptyIR -- Will be set by buildIR + , irHash = Nothing -- Methods don't carry hash + , irMetadata = Nothing -- Will be set by buildIR + , irTypes = types + , irMethods = Map.singleton fullPath mdef + , irPlugins = Map.singleton namespace [methodName method] + , irPluginHashes = Nothing -- Methods don't have plugin-level hashes + , irPluginRequests = Nothing -- Methods don't carry request schemas + , irPluginRoles = Nothing -- Methods don't carry roles + , irRefusals = refusals + } + +-- | RETURNS-36 review (#9): one plugin node as the walk builds it. A plugin +-- whose schemas put two shapes under one title ('TitleCollision') is +-- refused, not the walk: its methods and types are left out, a refusal at +-- its namespace names both sites, and its children are built as ever. A +-- refusal makes @-i@ exit 65, as any does. +pluginIRRefusing :: Path -> PluginSchema -> [IR] -> IR +pluginIRRefusing path schema childIRs = case pluginIR path schema childIRs of + Right ir -> ir + Left err -> + let bare = either (const emptyIR) id (pluginIR path schema { psMethods = [] } childIRs) + site = T.intercalate "." path + why = maybe (renderIRBuildError err) id (T.stripPrefix "IR: " (renderIRBuildError err)) + in bare { irRefusals = Refusal site "title" Nothing (why <> " The activation is left out.") : irRefusals bare } + +-- | One plugin node: its own types and methods, merged with its children's. +pluginIR :: Path -> PluginSchema -> [IR] -> Either IRBuildError IR +pluginIR path schema childIRs = do -- Use full path as namespace to avoid collisions -- e.g., "hyperforge.workspace.repos" instead of just "repos" let namespace = T.intercalate "." path pathPrefix = namespace -- Same as namespace -- Extract types and methods from this plugin - let (localTypes, localMethods, localRefusals) = extractFromPlugin namespace pathPrefix schema + (localTypes, localMethods, localRefusals) <- extractFromPlugin namespace pathPrefix schema -- Merge with children let childIR = foldr mergeIR emptyIR childIRs @@ -145,14 +320,12 @@ childHashes = fromMaybe Map.empty (irPluginHashes childIR) allHashes = Map.insert namespace hashInfo childHashes - -- REQ-5: capture per-plugin PlexusRequest schema (psRequest from wire schema). - -- HEADERS-1 stub: plexus-protocol's PluginSchema does not yet expose - -- psRequest (cross-repo patch pending). Treat as always-Nothing so the - -- synapse binary builds; REQ-5 rendering becomes a no-op until the field - -- lands in plexus-protocol. - let _ = schema -- suppress unused-binding warning when REQ-5 is stubbed - childRequests = fromMaybe Map.empty (irPluginRequests childIR) - allRequests = childRequests + -- REQ-5: capture per-plugin PlexusRequest schema (psRequest from the wire + -- schema, CONTEXT-5 — HEADERS-1's stub is gone now plexus-protocol reads it). + let childRequests = fromMaybe Map.empty (irPluginRequests childIR) + allRequests = case psRequest schema of + Just reqV -> Map.insert namespace reqV childRequests + Nothing -> childRequests pure $ IR { irVersion = irVersion emptyIR -- Use version from emptyIR @@ -171,24 +344,6 @@ , irRefusals = localRefusals <> irRefusals childIR } -irAlgebra (MethodF method namespace path) = do - -- Single method node (shouldn't happen in normal walk, but handle it) - let fullPath = T.intercalate "." path - let ((types, mdef), refusals) = extractMethodDefR namespace fullPath method - pure $ IR - { irVersion = irVersion emptyIR -- Use version from emptyIR - , irBackend = irBackend emptyIR -- Will be set by buildIR - , irHash = Nothing -- Methods don't carry hash - , irMetadata = Nothing -- Will be set by buildIR - , irTypes = types - , irMethods = Map.singleton fullPath mdef - , irPlugins = Map.singleton namespace [methodName method] - , irPluginHashes = Nothing -- Methods don't have plugin-level hashes - , irPluginRequests = Nothing -- Methods don't carry request schemas - , irPluginRoles = Nothing -- Methods don't carry roles - , irRefusals = refusals - } - -- ============================================================================ -- Type Deduplication and Placement -- ============================================================================ @@ -263,7 +418,8 @@ names = concatMap methodNames (Map.elems (irMethods ir)) ++ concatMap (kindNames . tdKind) (Map.elems (irTypes ir)) methodNames md = concatMap refKeys - (map pdType (mdParams md) ++ [mdReturns md] ++ maybe [] pure (mdInput md) ++ maybe [] pure (mdBidirType md)) + (map pdType (mdParams md) ++ [mdReturns md] ++ maybe [] pure (mdError md) ++ maybe [] pure (mdProgress md) + ++ maybe [] pure (mdInput md) ++ maybe [] pure (mdBidirType md)) kindNames = \case KindStruct fs -> concatMap (refKeys . fdType) fs KindEnum _ vs _ -> concatMap (\v -> concatMap (refKeys . fdType) (vdFields v) ++ maybe [] refKeys (vdRef v)) vs @@ -316,6 +472,8 @@ updateMethodRefs redirects md = md { mdParams = map (updateParamRefs redirects) (mdParams md) , mdReturns = updateTypeRef redirects (mdReturns md) + , mdError = fmap (updateTypeRef redirects) (mdError md) + , mdProgress = fmap (updateTypeRef redirects) (mdProgress md) , mdBidirType = fmap (updateTypeRef redirects) (mdBidirType md) , mdInput = fmap (updateTypeRef redirects) (mdInput md) -- mdRole, mdBidirResponse*: left unchanged via record-update syntax @@ -409,10 +567,14 @@ let path = mdFullPath md ps = [ let (t, rs) = fix (siteParam path (pdName p)) (pdType p) in (p { pdType = t }, rs) | p <- mdParams md ] (ret, rr) = fix (siteReturns path) (mdReturns md) - (inp, ri) = case mdInput md of + optional site = \case Nothing -> (Nothing, []) - Just x -> let (x', rs) = fix (siteInput path) x in (Just x', rs) - in (md { mdParams = map fst ps, mdReturns = ret, mdInput = inp }, concatMap snd ps ++ rr ++ ri) + Just x -> let (x', rs) = fix site x in (Just x', rs) + (err, re) = optional (siteError path) (mdError md) + (prog, rp) = optional (siteProgress path) (mdProgress md) + (inp, ri) = optional (siteInput path) (mdInput md) + in ( md { mdParams = map fst ps, mdReturns = ret, mdError = err, mdProgress = prog, mdInput = inp } + , concatMap snd ps ++ rr ++ re ++ rp ++ ri ) types' = Map.mapWithKey fixType (irTypes ir) methods' = Map.map fixMethod (irMethods ir) in ( ir { irTypes = Map.map fst types', irMethods = Map.map fst methods' } @@ -424,10 +586,13 @@ -- | Extract all types and methods from a plugin schema -- Types are namespace-qualified to avoid collisions (e.g., "cone.ListResult") -extractFromPlugin :: Text -> Text -> PluginSchema -> (Map Text TypeDef, Map Text MethodDef, [Refusal]) -extractFromPlugin namespace pathPrefix schema = +-- +-- Fails when two of its schemas give one name two shapes ('TitleCollision'). +extractFromPlugin :: Text -> Text -> PluginSchema -> Either IRBuildError (Map Text TypeDef, Map Text MethodDef, [Refusal]) +extractFromPlugin namespace pathPrefix schema = do + checkTitles namespace (psMethods schema) let -- every method's documents share one namespace's $defs: read once - docs = [ o | m <- psMethods schema, Just (Object o) <- [methodParams m, methodReturns m, methodInput m] ] + docs = [ o | m <- psMethods schema, (_, Object o) <- methodDocs m ] shared = sharedDoc namespace docs ((defs, results), refusals) = runRead $ do ds <- readDefs shared @@ -435,23 +600,108 @@ pure (ds, rs) allTypes = Map.unions (defs : map fst results) allMethods = Map.fromList [ (mdFullPath m, m) | (_, m) <- results ] - in (allTypes, allMethods, refusals) + pure (allTypes, allMethods, refusals) -- | Extract types and method def from a single method (its refusals dropped: -- 'extractMethodDefR' keeps them). -extractMethodDef :: Text -> Text -> MethodSchema -> (Map Text TypeDef, MethodDef) -extractMethodDef namespace pathPrefix = fst . extractMethodDefR namespace pathPrefix +-- +-- Fails when two of the method's own schemas give one name two shapes. +extractMethodDef :: Text -> Text -> MethodSchema -> Either IRBuildError (Map Text TypeDef, MethodDef) +extractMethodDef namespace pathPrefix = fmap fst . extractMethodDefR namespace pathPrefix -- | Extract types and method def from a single method, and every site the -- reader refused on the way. -extractMethodDefR :: Text -> Text -> MethodSchema -> ((Map Text TypeDef, MethodDef), [Refusal]) -extractMethodDefR = extractMethodDefIn Nothing +extractMethodDefR :: Text -> Text -> MethodSchema -> Either IRBuildError ((Map Text TypeDef, MethodDef), [Refusal]) +extractMethodDefR namespace pathPrefix method = do + checkTitles namespace [method] + pure (extractMethodDefIn Nothing namespace pathPrefix method) -- | 'extractMethodDefR', its $defs read from a namespace's shared document -- when one is given (and so not read here), else from its own documents. extractMethodDefIn :: Maybe Doc -> Text -> Text -> MethodSchema -> ((Map Text TypeDef, MethodDef), [Refusal]) extractMethodDefIn shared namespace pathPrefix = runRead . methodDefRead shared namespace pathPrefix +-- | A method's schema documents, each by the name 'TypeSource' gives it. +methodDocs :: MethodSchema -> [(Text, Value)] +methodDocs m = + [ (k, v) + | (k, Just v) <- + [ ("params", methodParams m) + , ("returns", Just (methodReturns m)) + , ("error", methodError m) + , ("progress", methodProgress m) + , ("input", methodInput m) + ] + ] + +-- | The fallback name of a method's untitled named root, by schema. +rootFallback :: MethodSchema -> Text -> Text +rootFallback m = \case + "returns" -> methodName m <> "Result" + "error" -> methodName m <> "Error" + "progress" -> methodName m <> "Progress" + "input" -> methodName m <> "Input" + other -> methodName m <> other + +-- ============================================================================ +-- One name, one type (RETURNS-13) +-- ============================================================================ + +-- | RETURNS-13: one name in one namespace is one type. Every name the +-- methods' schemas define — each @$defs@ entry, and each named root +-- ('rootNamed') — in the methods' order, then params, returns, error, +-- progress, input; where two give a name different bodies, both are read +-- (each in its own document) and their kinds compared, descriptions aside. +-- Two shapes are a 'TitleCollision' naming the first and the second; the +-- same shape is one type (the reader keeps the first). +-- +-- The bodies are compared as JSON first, so a namespace whose methods +-- carry the same @$defs@ again and again (as schemars writes them) costs +-- one equality test a copy, not a read. +checkTitles :: Text -> [MethodSchema] -> Either IRBuildError () +checkTitles namespace methods = mapM_ checkName (Map.toList byName) + where + byName :: Map Text [(Value, KM.KeyMap Value, TypeSource)] + byName = Map.fromListWith (flip (++)) + [ (name, [(body, docObj, TypeSource (methodName m) which)]) + | m <- methods + , (which, doc@(Object docObj)) <- methodDocs m + , (name, body) <- defsOf docObj ++ rootOf m which doc + ] + defsOf docObj = case KM.lookup "$defs" docObj <|> KM.lookup "definitions" docObj of + Just (Object d) -> [ (K.toText k, v) | (k, v) <- KM.toList d ] + _ -> [] + rootOf m which doc + | which == "params" = [] + | otherwise = maybe [] pure (rootNamed (rootFallback m which) doc) + + checkName (name, occurrences) = case occurrences of + [] -> Right () + (first : rest) -> () <$ foldM (compareWith name) (first, Nothing) rest + + -- the first occurrence, and its kind once read + compareWith name (first@(b0, d0, s0), k0) (b, d, s) + | b == b0 = Right (first, k0) + | otherwise = + let kind0 = maybe (readKindIn namespace d0 name b0) id k0 + kind = readKindIn namespace d name b + in if sameShape kind0 kind + then Right (first, Just kind0) + else Left TitleCollision + { tcNamespace = namespace, tcTitle = name, tcFirst = s0, tcSecond = s } + +-- | Two readings of a name are one type when they agree on everything but +-- their documentation. +sameShape :: Maybe TypeKind -> Maybe TypeKind -> Bool +sameShape a b = fmap undocumented a == fmap undocumented b + where + undocumented = \case + KindStruct fields -> KindStruct (map field fields) + KindEnum disc variants repr -> KindEnum disc (map variant variants) repr + other -> other + field fd = fd { fdDescription = Nothing } + variant vd = vd { vdDescription = Nothing, vdFields = map field (vdFields vd) } + methodDefRead :: Maybe Doc -> Text -> Text -> MethodSchema -> SchemaRead (Map Text TypeDef, MethodDef) methodDefRead shared namespace pathPrefix method = do let name = methodName method @@ -465,23 +715,28 @@ readParams shared namespace fullPath (methodParams method) (methodParamSchemas method) -- Returns: a child's is its client (SYNAPSE-CC-8's RefChild); an rpc - -- method's is read whole, and its absence is refused. - RootRead returnTypes returnRef streaming <- case methodRole method of - MethodRoleRpc -> case methodReturns method of - Just v -> readRoot shared namespace (siteReturns fullPath) (name <> "Result") v - Nothing -> do - refuse (siteReturns fullPath) "returns" Nothing "an rpc method with no returns schema" - pure (RootRead Map.empty RefUnknown False) + -- method's is read whole (plexus 0.7: every method states it). + RootRead returnTypes returnRef <- case methodRole method of + MethodRoleRpc -> + readRoot shared namespace (siteReturns fullPath) (rootFallback method "returns") (methodReturns method) _child -> do defs <- case (shared, methodReturns method) of - (Nothing, Just (Object o)) -> readDefs (docOf namespace o) + (Nothing, Object o) -> readDefs (docOf namespace o) _ -> pure Map.empty - pure (RootRead defs (RefChild fullPath) False) + pure (RootRead defs (RefChild fullPath)) - -- Input: reserved for BIDIR-6; read when a server says it. - inputRead <- traverse (readRoot shared namespace (siteInput fullPath) (name <> "Input")) (methodInput method) + -- RETURNS-13: the rest of the contract — the error type of a + -- Result item and the progress type P, each its own document. + errorRead <- traverse (readRoot shared namespace (siteError fullPath) (rootFallback method "error")) (methodError method) + progressRead <- traverse (readRoot shared namespace (siteProgress fullPath) (rootFallback method "progress")) (methodProgress method) - let allTypes = Map.unions [paramTypes, returnTypes, maybe Map.empty rrTypes inputRead] + -- Input (BIDIR-6): read when a server says it. BIDIR-18 / BIDIR-19: an + -- Input item (`x-plexus-binary`) is a string of format "binary" + -- (`RefPrimitive "string" (Just "binary")`, as service-codegen reads it). + inputRead <- traverse (readRoot shared namespace (siteInput fullPath) (rootFallback method "input") . binaryInput) (methodInput method) + + let allTypes = Map.unions + [paramTypes, returnTypes, maybe Map.empty rrTypes errorRead, maybe Map.empty rrTypes progressRead, maybe Map.empty rrTypes inputRead] pure ( allTypes , MethodDef @@ -489,9 +744,12 @@ , mdFullPath = fullPath , mdNamespace = namespace , mdDescription = Just (methodDescription method) - , mdStreaming = streaming , mdParams = params , mdReturns = returnRef + , mdError = rrRef <$> errorRead + , mdProgress = rrRef <$> progressRead + , mdCardinality = methodCardinality method + -- RETURNS-13: the schema's cardinality, never inferred , mdBidirType = inferBidirType method , mdBidirResponseType = Nothing -- TODO: could extract from response_type title , mdBidirResponseSchema = methodResponseType method @@ -609,3 +867,14 @@ extractTypesFromSchema :: Text -> Value -> Map Text TypeDef extractTypesFromSchema namespace (Object o) = fst (runRead (readDefs (docOf namespace o))) extractTypesFromSchema _ _ = Map.empty + +-- | BIDIR-18: an @Input@ item schema (@"x-plexus-binary": true@, +-- with its @contentEncoding@ and @contentMediaType@) as the IR reads it: +-- @{"type":"string","format":"binary"}@, its description kept. Anything +-- else is itself. +binaryInput :: Value -> Value +binaryInput = \case + Object o | KM.lookup "x-plexus-binary" o == Just (Bool True) -> Object $ KM.fromList $ + [("type", String "string"), ("format", String "binary")] + ++ [ ("description", d) | Just d <- [KM.lookup "description" o] ] + v -> v diff --git a/src/Synapse/IR/Read.hs b/src/Synapse/IR/Read.hs --- a/src/Synapse/IR/Read.hs +++ b/src/Synapse/IR/Read.hs @@ -31,11 +31,15 @@ , readDefs , readRoot , RootRead(..) + , rootNamed + , readKindIn -- * Type positions , readType -- * Sites , siteParam , siteReturns + , siteError + , siteProgress , siteInput -- * The vocabulary , knownKeywords @@ -96,9 +100,10 @@ (# (), s { rsRefusals = Refusal site kw variant detail : rsRefusals s } #) -- | A named root read before. One name in one namespace is one type: the --- first schema read under it is the type, as the first of a name in --- @$defs@ is (and as IR 2.0 kept it), so a later root of the same name is --- not read again (comparing the schemas cost more than the read). +-- builder refuses two shapes under one name before reading +-- (RETURNS-13's 'Synapse.IR.Builder.TitleCollision'), so the first schema +-- read under a name stands for every later root of it, which is not read +-- again. rootSeen :: Text -> Value -> SchemaRead (Maybe (Maybe TypeKind)) rootSeen site _ = SchemaRead $ \s -> case Map.lookup site (rsRoots s) of Just (_, k) -> (# Just k, s #) @@ -120,23 +125,27 @@ data Doc = Doc { docNamespace :: Text , docDefs :: KM.KeyMap Value + , docRoot :: Maybe Text -- ^ The root's name: what @"$ref": "#"@ names (RETURNS-13) } docOf :: Text -> KM.KeyMap Value -> Doc -docOf ns o = Doc ns $ case KM.lookup "$defs" o of - Just (Object d) -> d - _ -> case KM.lookup "definitions" o of - Just (Object d) -> d - _ -> KM.empty +docOf ns o = Doc ns defs Nothing + where + defs = case KM.lookup "$defs" o of + Just (Object d) -> d + _ -> case KM.lookup "definitions" o of + Just (Object d) -> d + _ -> KM.empty -- | One namespace's documents as one: every @$defs@ entry of them, the -- first of each name winning (as the types the builder kept always did). -- Read once, a namespace's definitions are read once, not once a method. sharedDoc :: Text -> [KM.KeyMap Value] -> Doc -sharedDoc ns docs = Doc ns (foldl (\acc o -> KM.union acc (docDefs (docOf ns o))) KM.empty docs) +sharedDoc ns docs = Doc ns (foldl (\acc o -> KM.union acc (docDefs (docOf ns o))) KM.empty docs) Nothing -- | The definition a @$ref@ names, in this document. lookupDef :: Doc -> Text -> Maybe Value +lookupDef _ "#" = Nothing lookupDef doc ref = KM.lookup (K.fromText (refName ref)) (docDefs doc) refName :: Text -> Text @@ -145,6 +154,10 @@ [] -> ref qualified :: Doc -> Text -> TypeRef +qualified doc "#" = case docRoot doc of + -- RETURNS-13: @"#"@ is the document's root, by its name + Just root -> RefNamed QualifiedName { qnNamespace = docNamespace doc, qnLocalName = root } + Nothing -> RefNamed QualifiedName { qnNamespace = docNamespace doc, qnLocalName = "#" } qualified doc ref = RefNamed QualifiedName { qnNamespace = docNamespace doc, qnLocalName = refName ref } typeSite :: Doc -> Text -> Text @@ -156,6 +169,12 @@ siteReturns :: Text -> Text siteReturns path = path <> " returns" +siteError :: Text -> Text +siteError path = path <> " error" + +siteProgress :: Text -> Text +siteProgress path = path <> " progress" + siteInput :: Text -> Text siteInput path = path <> " input" @@ -168,7 +187,7 @@ knownKeywords :: Set.Set Text knownKeywords = Set.fromList [ "type", "$ref", "properties", "required", "additionalProperties", "items", "prefixItems" - , "oneOf", "anyOf", "enum", "const", "format" + , "oneOf", "anyOf", "allOf", "enum", "const", "format" , "minimum", "maximum", "exclusiveMinimum", "exclusiveMaximum" , "minLength", "maxLength", "pattern", "minItems", "maxItems" , "default", "description", "title", "examples", "deprecated" @@ -193,7 +212,7 @@ isJsonSchema :: KM.KeyMap Value -> Bool isJsonSchema o = not (any (`KM.member` o) structural) || allSix where - structural = ["type", "$ref", "properties", "additionalProperties", "items", "prefixItems", "oneOf", "anyOf", "enum", "const"] + structural = ["type", "$ref", "properties", "additionalProperties", "items", "prefixItems", "oneOf", "anyOf", "allOf", "enum", "const"] allSix = case KM.lookup "type" o of Just (Array ts) -> Set.fromList [ t | String t <- V.toList ts ] == jsonTypes @@ -232,6 +251,10 @@ readTypeObject :: Doc -> Text -> KM.KeyMap Value -> SchemaRead TypeRef readTypeObject doc site o | Just (String ref) <- KM.lookup "$ref" o = pure (if isJsonRef ref then RefJson else qualified doc ref) + | Just members <- allOfOf o = case members of + -- RETURNS-13: @allOf [X]@ is X (draft-07 tooling wraps a ref so) + [x] | not (any (`KM.member` o) ["properties", "type", "oneOf", "anyOf"]) -> readType doc site x + _ -> unknownAt site "allOf" Nothing "allOf is read only as one schema, or beside a tag as a newtype variant's struct" | Just (kw, members) <- unionOf o = readInlineUnion doc site kw members | Just (Array ts) <- KM.lookup "type" o = let types = [ t | String t <- V.toList ts ] @@ -357,6 +380,21 @@ -- Unions -- ============================================================================ +-- | A schema's @allOf@ members. +allOfOf :: KM.KeyMap Value -> Maybe [Value] +allOfOf o = case KM.lookup "allOf" o of + Just (Array ms) -> Just (V.toList ms) + _ -> Nothing + +-- | What a newtype variant (or a struct) wraps: a @$ref@ beside its +-- properties (2020-12), or @allOf [{"$ref": …}]@ (draft-07) — RETURNS-13. +wrappedRef :: KM.KeyMap Value -> Maybe Value +wrappedRef m = case KM.lookup "$ref" m of + Just r -> Just r + Nothing -> case allOfOf m of + Just [Object x] | Just r@(String _) <- KM.lookup "$ref" x -> Just r + _ -> Nothing + -- | A schema's union: its keyword and members. unionOf :: KM.KeyMap Value -> Maybe (Text, [Value]) unionOf o = case (KM.lookup "oneOf" o, KM.lookup "anyOf" o) of @@ -475,7 +513,7 @@ | Just (Object props) <- KM.lookup "properties" m = Just VariantShape { vsProps = [ (K.toText k, v) | (k, v) <- KM.toList props ] , vsRequired = requiredOf m - , vsWrapped = KM.lookup "$ref" m + , vsWrapped = wrappedRef m , vsDesc = descriptionOf member } variantShape _ _ _ = Nothing @@ -654,7 +692,7 @@ when (maybe False (\ap -> ap /= Bool False) (KM.lookup "additionalProperties" o)) $ refuse site "additionalProperties" Nothing "a map beside properties (a flattened map) has no IR form" fields <- fieldsOf doc site (requiredOf o) (propsOf o) - wrapped <- case KM.lookup "$ref" o of + wrapped <- case wrappedRef o of Nothing -> pure [] Just w -> wrappedFields doc site w pure (Just (KindStruct (nubBy (\a b -> fdName a == fdName b) (fields ++ wrapped)))) @@ -679,29 +717,56 @@ -- A document's root -- ============================================================================ --- | What a document's root (a method's @returns@ or @input@) reads as. +-- | What a document's root (a method's @returns@, @error@, @progress@ or +-- @input@) reads as. data RootRead = RootRead { rrTypes :: Map Text TypeDef -- ^ its @$defs@, and the root's own type when it is named , rrRef :: TypeRef -- ^ the root as a ref - , rrStreaming :: Bool -- ^ a union of more than one non-error variant } +-- | A document's root as a type of its own, when it is one: its name (its +-- title, else @fallback@) and its schema less its @$defs@. A struct, an +-- enum and a union (not a nullable) are named; so is a @$ref@ under a +-- title of its own, as an alias (RETURNS-13). Anything else — a +-- primitive, an array, a nullable, @{}@ — is a plain ref, whatever +-- schemars titles it (@String@, @Array_of_T@). +rootNamed :: Text -> Value -> Maybe (Text, Value) +rootNamed fallback = \case + Object o + | named -> Just (name, body) + | Just (String ref) <- KM.lookup "$ref" o, not (KM.member "properties" o) + , Just t <- title, t /= refName ref, ref /= "#" -> Just (t, body) + where + title = case KM.lookup "title" o of + Just (String t) | not (T.null t) -> Just t + _ -> Nothing + name = fromMaybe fallback title + named = isJust (unionOf o) && isNothing (nullableMember (maybe [] snd (unionOf o))) + || KM.member "properties" o + || KM.member "enum" o + body = Object (KM.delete "$defs" (KM.delete "definitions" o)) + _ -> Nothing + +-- | A named type's kind read alone, in its own document (a method's schema +-- whose @$defs@ its refs resolve against), its refusals dropped: what the +-- builder compares when two schemas give one name two different bodies. +readKindIn :: Text -> KM.KeyMap Value -> Text -> Value -> Maybe TypeKind +readKindIn namespace docObj name v = + let doc = (docOf namespace docObj) { docRoot = Just name } + in fst (runRead (readKind doc (typeSite doc name) v)) + -- | A document's root: a titled (or else @fallback@-named) struct, enum or --- union is a type of its own; anything else is the plain ref. +-- union, or a titled @$ref@, is a type of its own ('rootNamed'); anything +-- else is the plain ref. Nothing is inferred from it: a method's +-- cardinality is its schema's (RETURNS-13). readRoot :: Maybe Doc -> Text -> Text -> Text -> Value -> SchemaRead RootRead readRoot shared namespace site fallback = \case - Object o -> do - let doc = maybe (docOf namespace o) id shared - name = case KM.lookup "title" o of - Just (String t) | not (T.null t) -> t - _ -> fallback - named = isJust (unionOf o) && isNothing (nullableMember (maybe [] snd (unionOf o))) - || KM.member "properties" o - || KM.member "enum" o - defs <- maybe (readDefs doc) (const (pure Map.empty)) shared - if named - then do - let body = Object (KM.delete "$defs" (KM.delete "definitions" o)) + v@(Object o) -> do + let doc0 = maybe (docOf namespace o) id shared + defs <- maybe (readDefs doc0) (const (pure Map.empty)) shared + case rootNamed fallback v of + Just (name, body) -> do + let doc = doc0 { docRoot = Just name } tsite = typeSite doc name seen <- rootSeen tsite body kind <- case seen of @@ -717,16 +782,11 @@ pure RootRead { rrTypes = Map.insert (tdFullName td) td defs , rrRef = ref - , rrStreaming = streams k } - Nothing -> pure RootRead { rrTypes = defs, rrRef = RefUnknown, rrStreaming = False } - else do - ref <- readType doc site (Object (KM.delete "$defs" (KM.delete "definitions" o))) - pure RootRead { rrTypes = defs, rrRef = ref, rrStreaming = False } + Nothing -> pure RootRead { rrTypes = defs, rrRef = RefUnknown } + Nothing -> do + ref <- readType doc0 site (Object (KM.delete "$defs" (KM.delete "definitions" o))) + pure RootRead { rrTypes = defs, rrRef = ref } other -> do - ref <- readType (Doc namespace KM.empty) site other - pure RootRead { rrTypes = Map.empty, rrRef = ref, rrStreaming = False } - where - streams = \case - KindEnum _ vs Internal -> length (filter ((/= "error") . vdName) vs) > 1 - _ -> False + ref <- readType (Doc namespace KM.empty Nothing) site other + pure RootRead { rrTypes = Map.empty, rrRef = ref } diff --git a/src/Synapse/IR/Types.hs b/src/Synapse/IR/Types.hs --- a/src/Synapse/IR/Types.hs +++ b/src/Synapse/IR/Types.hs @@ -19,7 +19,9 @@ -- -- - Types are hoisted to top level and deduplicated by name -- - Methods reference types by name, not inline definitions --- - Streaming is inferred from return type structure +-- - A method's contract is read from its schema, never inferred: its item +-- type ('mdReturns'), error type ('mdError'), progress type +-- ('mdProgress') and cardinality ('mdCardinality') — IR 3.0, plexus 0.7 -- - Discriminated unions are first-class module Synapse.IR.Types ( -- * Top-level IR @@ -47,6 +49,7 @@ -- * Method Definitions , MethodDef(..) , MethodRole(..) + , Cardinality(..) , ParamDef(..) , InjectedParam(..) @@ -64,10 +67,6 @@ , TypeRef(..) , typeRefName , typeRefChildren - - -- * Utilities - , isStreaming - , inferStreaming ) where import Control.Applicative ((<|>)) @@ -81,17 +80,20 @@ import Data.Maybe (catMaybes) import Data.Text (Text) import qualified Data.Text as T +import Data.Version (showVersion) import GHC.Generics (Generic) -import Plexus.Schema.Recursive (DeprecationInfo(..), MethodRole(..)) +import Paths_plexus_synapse (version) +import Plexus.Schema.Recursive (Cardinality(..), DeprecationInfo(..), MethodRole(..)) -- ============================================================================ -- Version Information -- ============================================================================ --- | Synapse version (from cabal file: plexus-synapse.cabal) +-- | Synapse's own package version (@plexus-synapse.cabal@'s @version@), as +-- recorded in 'GenerationMetadata'. synapseVersion :: Text -synapseVersion = "0.2.0.0" +synapseVersion = T.pack (showVersion version) -- ============================================================================ -- Generation Metadata @@ -185,10 +187,12 @@ <*> o .:? "irPluginRoles" <*> o .:? "irRefusals" .!= [] --- | The IR format this synapse writes (SYNAPSE-CC-8). A cache holding any --- other is discarded and built again. +-- | The IR format this synapse writes: 3.0 (RETURNS-13: a method's returns, +-- error, progress and cardinality, read from the plexus 0.7 schema) over +-- 2.1's forms (SYNAPSE-CC-8). A cache holding any other is discarded and +-- built again. currentIrVersion :: Text -currentIrVersion = "2.1" +currentIrVersion = "3.0" -- ============================================================================ -- IR 2.1: refusals, injected params, refinements @@ -284,7 +288,7 @@ -- | Empty IR for folding emptyIR :: IR emptyIR = IR - { irVersion = currentIrVersion -- 2.1: SYNAPSE-CC-8 (2.0: TypeRef uses structured QualifiedName) + { irVersion = currentIrVersion -- 3.0: MethodDef carries returns · error · progress · cardinality (plexus 0.7); 2.1's SYNAPSE-CC-8 forms kept , irBackend = "" -- Will be set by buildIR , irHash = Nothing , irMetadata = Nothing @@ -349,7 +353,7 @@ { ksFields :: [FieldDef] -- ^ Struct fields } | KindEnum - { keDiscriminator :: Text -- ^ Field that discriminates (e.g., "type"); @""@ when not 'Internal' + { keDiscriminator :: Text -- ^ The tag: the property whose @const@ every variant carries (e.g., "type", "kind"); @""@ when not 'Internal' , keVariants :: [VariantDef] -- ^ Possible variants , keRepr :: EnumRepr -- ^ SYNAPSE-CC-8: internal (omitted), external or untagged } @@ -388,7 +392,7 @@ data VariantDef = VariantDef { vdName :: Text -- ^ Variant name (the discriminator value) , vdDescription :: Maybe Text -- ^ Documentation - , vdFields :: [FieldDef] -- ^ Fields specific to this variant + , vdFields :: [FieldDef] -- ^ The variant's fields, the tag aside; a newtype variant over a struct carries the struct's fields , vdRef :: Maybe TypeRef -- ^ SYNAPSE-CC-8: an untagged variant's type (omitted when absent) } deriving stock (Show, Eq, Generic) @@ -404,14 +408,32 @@ -- ============================================================================ -- | A method definition +-- +-- IR 3.0: a method's contract is four facts read from its 0.7 +-- 'Plexus.Schema.Recursive.MethodSchema', never inferred — its item type +-- ('mdReturns'), its error type when it can say no ('mdError'), its +-- progress type when it reports progress ('mdProgress'), and whether it +-- yields one item or many ('mdCardinality'). Every 'RefNamed' among them +-- has a 'TypeDef' in 'irTypes'. data MethodDef = MethodDef { mdName :: Text -- ^ Method name (e.g., "chat") , mdFullPath :: Text -- ^ Full path (e.g., "cone.chat") , mdNamespace :: Text -- ^ Parent namespace (e.g., "cone") , mdDescription :: Maybe Text -- ^ Documentation - , mdStreaming :: Bool -- ^ Does this method stream multiple events? , mdParams :: [ParamDef] -- ^ Input parameters - , mdReturns :: TypeRef -- ^ Return type reference + , mdReturns :: TypeRef + -- ^ The item type @T@: what one success carries (for @Result@ or + -- @Progress@, @T@ alone). From @MethodSchema.returns@. + , mdError :: Maybe TypeRef + -- ^ The error type @E@ of a @Result@ item — what the activation + -- says when it says no. 'Nothing' when the method is infallible. + -- From @MethodSchema.error@. + , mdProgress :: Maybe TypeRef + -- ^ The progress type @P@ its progress frames carry. 'Nothing' when the + -- method reports no progress. From @MethodSchema.progress@. + , mdCardinality :: Cardinality + -- ^ One item or many. From @MethodSchema.cardinality@ — never inferred + -- from the shape of 'mdReturns'. , mdBidirType :: Maybe TypeRef -- ^ Bidirectional channel type parameter T, when the method uses -- BidirChannel, StandardResponse>. @@ -466,21 +488,24 @@ deriving stock (Show, Eq, Generic) -- | Manual JSON instances so @mdRole@ defaults to 'MethodRoleRpc' when --- deserializing pre-IR-12 IR JSON (same back-compat posture as the --- Rust @#[serde(default)]@ on @MethodDef.md_role@ in service-codegen). +-- absent (same posture as the Rust @#[serde(default)]@ on +-- @MethodDef.md_role@ in service-codegen). -- --- All other fields preserve the generic derivation defaults (field --- names used verbatim as JSON keys; @Maybe@ fields omitted when --- @Nothing@ to match aeson's legacy behaviour). +-- Field names are the JSON keys; a 'Nothing' is written as @null@, as +-- the generic derivation always has. @mdCardinality@ is @"one"@ / +-- @"many"@ (the schema's own spelling) and is required: IR 3.0 does not +-- read 2.0's @mdStreaming@ (RETURNS-1 decision 12, no back-compat). instance ToJSON MethodDef where toJSON MethodDef{..} = object $ [ "mdName" .= mdName , "mdFullPath" .= mdFullPath , "mdNamespace" .= mdNamespace , "mdDescription" .= mdDescription - , "mdStreaming" .= mdStreaming , "mdParams" .= mdParams , "mdReturns" .= mdReturns + , "mdError" .= mdError + , "mdProgress" .= mdProgress + , "mdCardinality" .= mdCardinality , "mdBidirType" .= mdBidirType , "mdBidirResponseType" .= mdBidirResponseType , "mdBidirResponseSchema" .= mdBidirResponseSchema @@ -502,9 +527,11 @@ <*> o .: "mdFullPath" <*> o .: "mdNamespace" <*> o .:? "mdDescription" - <*> o .: "mdStreaming" <*> o .: "mdParams" <*> o .: "mdReturns" + <*> o .:? "mdError" + <*> o .:? "mdProgress" + <*> o .: "mdCardinality" <*> o .:? "mdBidirType" <*> o .:? "mdBidirResponseType" <*> o .:? "mdBidirResponseSchema" @@ -627,23 +654,3 @@ typeRefName :: TypeRef -> Maybe Text typeRefName (RefNamed qn) = Just (qualifiedNameFull qn) typeRefName _ = Nothing - --- ============================================================================ --- Utilities --- ============================================================================ - --- | Check if a method definition is streaming -isStreaming :: MethodDef -> Bool -isStreaming = mdStreaming - --- | Infer streaming from a return type's structure --- A method is streaming if its return type is an enum with more than 2 variants --- (more than 1 success variant + error variant) -inferStreaming :: TypeDef -> Bool -inferStreaming td = case tdKind td of - KindEnum _ variants _ -> - let nonErrorVariants = filter (not . isErrorVariant) variants - in length nonErrorVariants > 1 - _ -> False - where - isErrorVariant v = vdName v == "error" diff --git a/src/Synapse/Identity/Session.hs b/src/Synapse/Identity/Session.hs --- a/src/Synapse/Identity/Session.hs +++ b/src/Synapse/Identity/Session.hs @@ -48,6 +48,8 @@ , printedAny , noteRefused , wasRefused + , noteFailed + , hasFailed , currentCeiling ) where @@ -458,11 +460,13 @@ -- | The in-band error a service answers a call whose session has ended with. isSessionEndedItem :: ServiceStreamItem -> Bool -isSessionEndedItem = \case +isSessionEndedItem item = case item of ServiceData _ _ _ (Object o) | KM.lookup "type" o == Just (String "error") , Just (String m) <- KM.lookup "message" o -> isSessionEndedText m - ServiceError _ _ e _ -> isSessionEndedText e + -- RETURNS-36 re-review #6: main's text on any error item — the server's + -- message, and so the typed unauthenticated's reason where there is one + ServiceError _ _ m _ -> isSessionEndedText m _ -> False isSessionEndedText :: Text -> Bool @@ -509,6 +513,18 @@ wasRefused :: IO Bool wasRefused = readIORef refusedRef + +-- | A stream said its call failed: an error item, or a data item whose +-- content is an event of @type: error@. The call exits non-zero. +{-# NOINLINE failedRef #-} +failedRef :: IORef Bool +failedRef = unsafePerformIO (newIORef False) + +noteFailed :: IO () +noteFailed = writeIORef failedRef True + +hasFailed :: IO Bool +hasFailed = readIORef failedRef -- | AUTH-8: the ceiling of the session this process carries, as asked at -- login (@editor\@MENGER-12@ each) — what a refusal that names none is diff --git a/src/Synapse/Input.hs b/src/Synapse/Input.hs new file mode 100644 --- /dev/null +++ b/src/Synapse/Input.hs @@ -0,0 +1,589 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | BIDIR-18: synapse calls a method with an input half (@Input@, +-- plexus-wire spec/10). +-- +-- stdin (@--input -@) or a file (@--input \@path@) is the stream in: +-- +-- * a string item: one line, one item; +-- * a bytes item (@"x-plexus-binary": true@, @Input@): the bytes cut +-- into @--chunk N@ (4096 unless said), each one WebSocket binary frame; +-- * anything else: NDJSON, one JSON value a line — a line that does not +-- decode is an error naming its line number, and no frame carries it. +-- +-- Items are read only while the callee's credit allows: with no credit, +-- nothing more is read, so the pipe in front of synapse is the buffer and +-- synapse's memory stays flat however far the writer runs ahead. What is +-- ready goes out together, up to 256 items (or about 1 MiB) a frame. At +-- the end of the input, @.end@; the output prints until its terminal +-- item, as any call's. +-- +-- Nothing is sent twice (spec/10: no resume; the owner, 2026-11-01: +-- buffer locally, delete only as a last resort, always warn on a +-- disconnect). A connection lost during the call is said on stderr every +-- time, with what was sent and what the callee acknowledged, and the run +-- exits 69. A typed close exits by its kind: @past_credit@ 70 (synapse's +-- own bug), @invalid_input@, @out_of_sequence@, @too_much_input@ 65, a +-- revoked or ended sign-in 77. +module Synapse.Input + ( -- * The flags + InputNames(..) + , FlagArity(..) + , inputNames + , InputFlags(..) + , takeInputFlags + , defaultChunk + , maxChunk + + -- * The source + , InputSource(..) + , sourceOf + , ItemKind(..) + , itemKind + + -- * Feeding a call + , Tally(..) + , Fed(..) + , withInputFeed + , renderTally + , closeExit + , inputRefusal + + -- * A dry run + , dryRunFrame + ) where + +import Control.Concurrent (forkIO, threadDelay) +import Control.Concurrent.Async (async, cancel, waitCatch, waitEitherCatch, withAsync) +import Control.Concurrent.STM +import Control.Exception (Exception, SomeException, IOException, catch, fromException, throwIO, try) +import Control.Monad (forM_, unless, void, when) +import Data.Aeson (Value(..), eitherDecodeStrict', encode, object, (.=)) +import qualified Data.Aeson.KeyMap as KM +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy.Char8 as LBS8 +import Data.Char (isSpace) +import Data.IORef +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe, isJust) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.IO as TIO +import Data.Word (Word64) +import Numeric (showHex) +import System.FilePath ((), isRelative) +import System.IO.Error (isEOFError) +import System.IO (Handle, IOMode(..), hClose, hFlush, hReady, hSetBinaryMode, openBinaryFile, stderr, stdin) + +import Plexus.Client (LostConnection(..)) +import Synapse.CLI.Parse (FlagArity(..), takeFlag) +import Plexus.Input +import Plexus.Types (PlexusStreamItem(..)) +import qualified Plexus.RemoteError as RE + +-- --------------------------------------------------------------------------- +-- The flags + +-- | What the input's flags are called for a method: @--input@, @--chunk@, +-- @--progress@ — or, when a parameter of the method already has one of +-- those names, @--input-stream@, @--input-chunk@, @--input-progress@ (the +-- parameter keeps its flag). +data InputNames = InputNames + { inStream :: Text + , inChunk :: Text + , inProgress :: Text + } deriving (Eq, Show) + +-- | The names, given the method's parameter names. +inputNames :: [Text] -> InputNames +inputNames params = InputNames + { inStream = pick "input" "input-stream" + , inChunk = pick "chunk" "input-chunk" + , inProgress = pick "progress" "input-progress" + } + where + pick plain other = if plain `elem` params then other else plain + +-- | What the input's flags said. +data InputFlags = InputFlags + { ifSource :: Maybe Text -- ^ @-@ or @\@path@ (Nothing: not given) + , ifChunk :: Maybe Int + , ifProgress :: Bool + } deriving (Eq, Show) + +-- | The most bytes one binary frame carries (and the holder relays): 16 MiB. +maxChunk :: Int +maxChunk = 16 * 1024 * 1024 + +-- | 4096 bytes a binary frame unless @--chunk@ says. +defaultChunk :: Int +defaultChunk = 4096 + +-- | Take the input's flags out of a method's flag arguments (as +-- 'Synapse.CLI.Parse.parsePathAndParams' gave them): what they said, and +-- the arguments left for the method's parameters. @--input@ and @--chunk@ +-- take the next argument whatever it begins with (@-@ is stdin), or +-- @=value@; @--progress@ is a switch (@=true@ / @=false@ too). Any other +-- flag keeps the value its parameter takes (@arity@, by its normalized +-- key), so a value that reads @--input@ is that parameter's, never the +-- stream's flag. +takeInputFlags :: InputNames -> (Text -> FlagArity) -> [Text] -> Either Text (InputFlags, [Text]) +takeInputFlags names arity = go (InputFlags Nothing Nothing False) [] + where + go acc rest [] = Right (acc, reverse rest) + go acc rest (x : xs) = case T.stripPrefix "--" x of + Just flag + | (key, eq) <- T.breakOn "=" flag, norm key == norm (inStream names) -> + withValue key eq xs $ \v xs' -> go acc { ifSource = Just v } rest xs' + | (key, eq) <- T.breakOn "=" flag, norm key == norm (inChunk names) -> + withValue key eq xs $ \v xs' -> case reads (T.unpack v) of + [(n, "")] | n > 0 && n <= maxChunk -> go acc { ifChunk = Just n } rest xs' + _ -> Left ("--" <> key <> " takes a number of bytes (1 to " <> T.pack (show maxChunk) <> "), not '" <> v <> "'") + | (key, eq) <- T.breakOn "=" flag, norm key == norm (inProgress names) -> + case T.drop 1 eq of + _ | T.null eq -> go acc { ifProgress = True } rest xs + v | v `elem` ["true", "1"] -> go acc { ifProgress = True } rest xs + | v `elem` ["false", "0"] -> go acc { ifProgress = False } rest xs + | otherwise -> Left ("--" <> key <> " is a switch (true or false), not '" <> v <> "'") + | otherwise -> + let (_, _, n) = takeFlag arity flag xs + (taken, xs') = splitAt n xs + in go acc (reverse taken ++ x : rest) xs' + _ -> go acc (x : rest) xs + withValue key eq xs k + | not (T.null eq) = k (T.drop 1 eq) xs + | (v : xs') <- xs = k v xs' + | otherwise = Left ("--" <> key <> " takes a value: - (stdin) or @FILE") + norm = T.replace "_" "-" + +-- --------------------------------------------------------------------------- +-- The source + +-- | Where the items come from. +data InputSource = FromStdin | FromFile FilePath + deriving (Eq, Show) + +-- | @-@ is stdin, @\@path@ a file (@~/@ and a relative path resolved as +-- SYNAPSE-10's @\@file@ are); anything else is refused, naming the flag. +sourceOf :: Text -> FilePath -> Maybe FilePath -> Text -> Either Text InputSource +sourceOf flag cwd home v + | v == "-" = Right FromStdin + | Just p <- T.stripPrefix "@" v, not (T.null p), not ("@" `T.isPrefixOf` p) = Right (FromFile (resolve (T.unpack p))) + | otherwise = Left ("--" <> flag <> " takes - (stdin) or @FILE, not '" <> v <> "'") + where + resolve ('~' : '/' : rest) | Just h <- home = h rest + resolve p | isRelative p = cwd p + | otherwise = p + +-- | Items read from a handle. +data Reader = Reader + { rdNext :: IO (Maybe Item) -- ^ the next item, waiting for it; Nothing at the end + , rdTry :: IO Next -- ^ the next item if it is whole now, never waiting + , rdAtEnd :: IO Bool -- ^ the source is known to be over, no item read for it + } + +data Item = JsonItem Value Int | BytesItem BS.ByteString + +-- | What 'rdTry' found. +data Next = Got Item | Ended | NotYet + +-- | A line that is not an item: its number and why. +data BadLine = BadLine Int Text + deriving Show + +instance Exception BadLine + +-- | The source as items. Only the end of the source ends it: any other +-- failure to read is raised (the call is ended, nothing more sent). Lines +-- are cut from what the source has given so far, so a whole line is sent +-- while the next is still arriving; bytes are what the source has, up to +-- the chunk, never waiting to fill one (a live source's 20 ms go as they +-- come). +newReader :: ItemKind -> Int -> Handle -> IO Reader +newReader kind chunk h = do + hSetBinaryMode h True + lineNo <- newIORef (0 :: Int) + buf <- newIORef BS.empty + eof <- newIORef False + let -- more of the source, waiting for it; at the end, eof + fill = do + b <- BS.hGetSome h 8192 -- what the handle holds: no more read ahead of credit + if BS.null b then writeIORef eof True else modifyIORef' buf (<> b) + -- the source has bytes (or its end) for a read that will not wait; + -- a failure here is said by that read + readable = hReady h `catch` \(_ :: IOException) -> pure True + cut = do + b <- readIORef buf + case BS8.elemIndex '\n' b of + Just i -> do + writeIORef buf (BS.drop (i + 1) b) + Just <$> numbered (BS.take i b) + Nothing -> pure Nothing + lastLine = do + b <- readIORef buf + writeIORef buf BS.empty + if BS.null b then pure Nothing else Just <$> numbered b + numbered l = do + n <- atomicModifyIORef' lineNo (\k -> (k + 1, k + 1)) + pure (n, stripCr l) + lineWaiting = cut >>= \case + Just l -> pure (Just l) + Nothing -> readIORef eof >>= \case + True -> lastLine + False -> fill >> lineWaiting + lineNow = cut >>= \case + Just l -> pure (Got' l) + Nothing -> readIORef eof >>= \case + True -> maybe Ended' Got' <$> lastLine + False -> readable >>= \case + True -> fill >> lineNow + False -> pure NotYet' + item (n, l) = case kind of + ItemString -> case TE.decodeUtf8' l of + Right t -> pure (Just (JsonItem (String t) (BS.length l))) + Left _ -> throwIO (BadLine n "not UTF-8 text") + _ | BS8.all isSpace l -> pure Nothing -- a blank line between values is none + | otherwise -> case eitherDecodeStrict' l of + Right v -> pure (Just (JsonItem v (BS.length l))) + Left e -> throwIO (BadLine n (T.pack e)) + nextLine = lineWaiting >>= \case + Nothing -> pure Nothing + Just l -> item l >>= maybe nextLine (pure . Just) + tryLine = lineNow >>= \case + Got' l -> item l >>= maybe tryLine (pure . Got) + Ended' -> pure Ended + NotYet' -> pure NotYet + nextBytes = readIORef eof >>= \case + True -> pure Nothing + False -> do + b <- BS.hGetSome h chunk + if BS.null b then writeIORef eof True >> pure Nothing else pure (Just (BytesItem b)) + atEnd = do + b <- readIORef buf + e <- readIORef eof + if not (BS.null b) then pure False + else if e then pure True + -- hReady says the end without taking an item: it raises it + else (False <$ hReady h) `catch` \(err :: IOException) -> pure (isEOFError err) + pure Reader + { rdNext = case kind of + ItemBytes -> nextBytes + _ -> nextLine + , rdTry = case kind of + ItemBytes -> maybe Ended Got <$> nextBytes -- never asked: a bytes item is a frame + _ -> tryLine + , rdAtEnd = atEnd } + where + stripCr l | not (BS.null l), BS8.last l == '\r' = BS.init l + | otherwise = l + +-- | A line as 'newReader' finds it without waiting. +data Line = Got' (Int, BS.ByteString) | Ended' | NotYet' + +openSource :: InputSource -> IO Handle +openSource = \case + FromStdin -> pure stdin + FromFile p -> openBinaryFile p ReadMode + +-- --------------------------------------------------------------------------- +-- Feeding a call + +-- | What the input half did: what went out, and what the callee said. +data Tally = Tally + { tItems :: !Integer -- ^ items sent + , tFrames :: !Integer -- ^ frames sent (JSON and binary) + , tAcked :: !(Maybe Integer) -- ^ the last frame the callee consumed + , tUnacked :: !Integer -- ^ items sent and not yet acknowledged + , tCredit :: !Integer -- ^ credit left + , tEnded :: !Bool -- ^ @end@ went out + , tClosed :: !(Maybe (Text, Maybe Integer)) -- ^ @input_closed {reason, ack}@ + } deriving (Eq, Show) + +-- | How the input half ended, beside the call's own ending. +data Fed + = FedAll -- ^ the input ended and @end@ went out, or the callee closed it + | FedBadLine Int Text -- ^ a line that is not an item: nothing carried it; the call was ended + | FedFailed Text -- ^ the source could not be read + deriving (Eq, Show) + +data FeedState = FeedState + { fsPort :: TMVar InputPort + , fsCredit :: TVar Integer + , fsClosed :: TVar (Maybe (Text, Maybe Integer)) + , fsAcked :: TVar (Maybe Integer) + , fsItems :: TVar Integer + , fsFrames :: TVar Integer + , fsThrough :: TVar (Map.Map Integer Integer) -- ^ frame seq → items sent through it, for frames not yet acked + , fsAckedItems :: TVar Integer -- ^ items in the frames acked + , fsEnded :: TVar Bool + , fsDone :: TVar Bool -- ^ the call is over: stop + , fsGranted :: TVar Bool -- ^ a credit came: the source may have been read + } + +-- | The most items, and about the most bytes, one @.input@ carries. +-- | Whose turn it is in the feeding. +data Turn = Go | Stop | Over | Poll + +frameItems, frameBytes :: Int +frameItems = 256 +frameBytes = 1024 * 1024 + +-- | Run a call with its input fed from the source. @call@ makes the call +-- with the half it is given (through a route that hands the half its port +-- once the server has taken the call). The source is opened first (a file +-- that cannot be read is refused before anything is sent). Returns how the +-- call ended (its own exception kept), how the feeding ended, and the +-- tally. A bad line cancels the call. @call@ is also given whether the +-- source is untouched yet (no credit has come, so nothing was read): a +-- call refused then may be made again without losing an item. +withInputFeed + :: ItemKind -> Int -> Bool -> InputSource + -> ((InputHalf, IO Bool) -> IO a) + -> IO (Either SomeException a, Fed, Tally) +withInputFeed kind chunk progress src call = do + h <- openSource src + rd <- newReader kind chunk h + st <- FeedState <$> newEmptyTMVarIO <*> newTVarIO 0 <*> newTVarIO Nothing <*> newTVarIO Nothing + <*> newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO Map.empty <*> newTVarIO 0 <*> newTVarIO False <*> newTVarIO False <*> newTVarIO False + let half = InputHalf + { ihPort = atomically . void . tryPutTMVar (fsPort st) + , ihSignal = signal st } + feeder <- async (feed kind rd st) + ticker <- if progress then Just <$> async (tick st) else pure Nothing + callA <- async (call (half, not <$> readTVarIO (fsGranted st))) + first <- waitEitherCatch feeder callA + (result, fed) <- case first of + -- the call ended first: the feeder may be blocked reading the source, + -- which no exception interrupts — it is let go, not waited for + Right r -> do + atomically (writeTVar (fsDone st) True) + void (forkIO (cancel feeder)) + pure (r, FedAll) + Left (Right ()) -> do + r <- waitCatch callA + pure (r, FedAll) + Left (Left e) + | Just (BadLine n why) <- fromException e -> do + -- nothing carried the line: the call ends here, unsubscribed + cancel callA + r <- waitCatch callA + pure (r, FedBadLine n why) + | Just (_ :: LostConnection) <- fromException e -> do + -- a frame the connection would not take: the call reports why + r <- waitCatch callA + pure (r, FedAll) + | otherwise -> do + cancel callA + r <- waitCatch callA + pure (r, FedFailed (T.pack (show e))) + atomically (writeTVar (fsDone st) True) + mapM_ cancel ticker + case src of + FromFile _ -> hClose h `catch` \(_ :: SomeException) -> pure () + FromStdin -> pure () + t <- tallyOf st + pure (result, fed, t) + +-- | What the callee said, kept for the feeder. +signal :: FeedState -> InputSignal -> IO () +signal st = \case + InputCredit n -> atomically $ do + writeTVar (fsGranted st) True + modifyTVar' (fsCredit st) (+ max 0 n) + InputAck sq -> atomically (acked sq) + InputClosed reason ack -> atomically $ do + writeTVar (fsClosed st) (Just (reason, ack)) + forM_ ack acked + where + -- every frame through sq consumed: its items counted, its entry let go + acked sq = do + writeTVar (fsAcked st) (Just sq) + through <- readTVar (fsThrough st) + forM_ (Map.lookupLE sq through) $ \(_, n) -> modifyTVar' (fsAckedItems st) (max n) + writeTVar (fsThrough st) (snd (Map.split sq through)) + +-- | The feeding: wait for the port and for credit; read what credit +-- allows (the first item waits for the source, the rest only what is +-- ready); send it as one frame (a bytes item as a binary frame of its +-- own); at the end of the source, @end@. The callee closing the half stops +-- it, reading no more. +feed :: ItemKind -> Reader -> FeedState -> IO () +feed _kind rd st = do + port <- atomically (readTMVar (fsPort st)) + let loop sq = do + turn <- waitTurn + case turn of + Stop -> pure () + -- the source is over with no credit left: end carries no item + Over -> end port sq + Go -> do + first <- rdNext rd + case first of + Nothing -> end port sq + Just (BytesItem b) -> do + stillOpen <- open' + when stillOpen $ do + sent sq 1 + ipBinary port sq b + loop (sq + 1) + Just (JsonItem v n) -> gather port sq [v] 1 n + -- credit, or the call over, or (looked at every 50 ms while there is + -- no credit) the source over + waitTurn = do + timer <- registerDelay 50000 + t <- atomically $ + (do done <- readTVar (fsDone st) + closed <- readTVar (fsClosed st) + check (done || isJust closed) + pure Stop) + `orElse` (readTVar (fsCredit st) >>= check . (> 0) >> pure Go) + `orElse` (readTVar timer >>= check >> pure Poll) + case t of + Poll -> rdAtEnd rd >>= \over -> if over then pure Over else waitTurn + other -> pure other + -- more of what is whole now, within the credit and the frame's size; + -- what is gathered goes out as soon as nothing more is + gather port sq acc count size = do + c <- readTVarIO (fsCredit st) + if not (c > fromIntegral count && count < frameItems && size < frameBytes) + then flush port sq acc count >> loop (sq + 1) + else do + -- the items before a bad line go out as read; the bad one never does + next <- rdTry rd `catch` \(e :: BadLine) -> flush port sq acc count >> throwIO e + case next of + Got (JsonItem v n) -> gather port sq (v : acc) (count + 1) (size + n) + Got (BytesItem _) -> flush port sq acc count >> loop (sq + 1) -- never: one kind a source + NotYet -> flush port sq acc count >> loop (sq + 1) + Ended -> do + flush port sq acc count + end port (sq + 1) + flush port sq acc count = do + stillOpen <- open' + when stillOpen $ do + sent sq count + ipItems port sq (reverse acc) + end port sq = do + stillOpen <- open' + when stillOpen $ do + ipEnd port sq + atomically (writeTVar (fsEnded st) True) + open' = atomically $ (&&) <$> (not <$> readTVar (fsDone st)) <*> (not . isJust <$> readTVar (fsClosed st)) + -- counted as it goes out (before the send: an ack can only follow + -- it, and a frame whose send failed may have gone, so it is unacked) + sent sq count = atomically $ do + modifyTVar' (fsCredit st) (subtract (fromIntegral count)) + total <- (+ fromIntegral count) <$> readTVar (fsItems st) + writeTVar (fsItems st) total + modifyTVar' (fsFrames st) (+ 1) + modifyTVar' (fsThrough st) (Map.insert (toInteger sq) total) + loop (0 :: Word64) + +tallyOf :: FeedState -> IO Tally +tallyOf st = atomically $ do + items <- readTVar (fsItems st) + frames <- readTVar (fsFrames st) + acked <- readTVar (fsAcked st) + ackedItems <- readTVar (fsAckedItems st) + credit <- readTVar (fsCredit st) + ended <- readTVar (fsEnded st) + closed <- readTVar (fsClosed st) + pure Tally { tItems = items, tFrames = frames, tAcked = acked + , tUnacked = max 0 (items - ackedItems) + , tCredit = credit, tEnded = ended, tClosed = closed } + +-- | @--progress@: the tally on stderr once a second. +tick :: FeedState -> IO () +tick st = loop + where + loop = do + threadDelay 1000000 + t <- tallyOf st + TIO.hPutStrLn stderr (renderTally t <> " · credit " <> commas (tCredit t)) + hFlush stderr + loop + +-- | @input: sent 1,204 items in 1,204 frames · acked through seq 1,179 · 25 unacked@ +renderTally :: Tally -> Text +renderTally t = "input: sent " <> commas (tItems t) <> " item" <> plural (tItems t) + <> " in " <> commas (tFrames t) <> " frame" <> plural (tFrames t) + <> " · " <> maybe "nothing acked" (\a -> "acked through seq " <> commas a) (tAcked t) + <> " · " <> commas (tUnacked t) <> " unacked" + where plural n = if n == 1 then "" else "s" + +commas :: Integer -> Text +commas n + | n < 0 = "-" <> commas (negate n) + | otherwise = T.reverse (T.intercalate "," (T.chunksOf 3 (T.reverse (T.pack (show n))))) + +-- | A typed close of the input half on an error item: its @error_kind@ and +-- the frame it names. +inputRefusal :: PlexusStreamItem -> Maybe (Text, Maybe Integer) +inputRefusal = \case + StreamErrorWith _ _ err _ _ beside + | Just kind <- kindOf err beside, kind `elem` inputKinds -> Just (kind, seqOf err beside) + _ -> Nothing + where + inputKinds = ["past_credit", "invalid_input", "out_of_sequence", "too_much_input"] + kindOf err beside = case KM.lookup "error_kind" beside of + Just (String k) -> Just k + _ -> case err of + RE.Other k _ -> Just k + _ -> Nothing + seqOf err beside = case KM.lookup "seq" beside of + Just (Number n) -> Just (round n) + _ -> case err of + RE.Other _ fields | Just (Number n) <- KM.lookup "seq" fields -> Just (round n) + _ -> Nothing + +-- | The exit a close calls for: @past_credit@ 70 (EX_SOFTWARE: synapse +-- sent past what it was granted — its own bug); @invalid_input@, +-- @out_of_sequence@, @too_much_input@ 65 (EX_DATAERR); an input closed +-- because the sign-in was revoked, signed out or expired 77. +closeExit :: Maybe (Text, Maybe Integer) -> Maybe (Text, Maybe Integer) -> Maybe (Int, Text) +closeExit refusal closed = case (refusal, closed) of + (Just ("past_credit", sq), _) -> Just (70, "the service says synapse sent past its credit" <> at sq <> " — a bug in synapse") + (Just (kind, sq), _) -> Just (65, "the service refused the input (" <> kind <> ")" <> at sq) + (Nothing, Just (reason, _)) + | reason `elem` ["revoked", "signed_out", "expired", "forbidden", "unauthenticated"] -> + Just (77, "the service closed the input: " <> reason <> " — sign in again (_login)") + _ -> Nothing + where + at = maybe "" (\s -> " at frame " <> commas s) + +-- --------------------------------------------------------------------------- +-- A dry run + +-- | @-n@: the first input frame the call would send — a JSON one with its +-- items (the subscription @null@: the server names it when it takes the +-- call), a binary one as its header in hex and its length — or @end@ for +-- an empty source. Reads one item of the source. +dryRunFrame :: Text -> ItemKind -> Int -> InputSource -> IO (Either Text Text) +dryRunFrame ns kind chunk src = do + h <- openSource src + rd <- newReader kind chunk h + r <- try (rdNext rd) + case src of + FromFile _ -> hClose h `catch` \(_ :: SomeException) -> pure () + FromStdin -> pure () + pure $ case r of + Left (BadLine n why) -> Left (lineError n why) + Right Nothing -> Right (frame "end" []) + Right (Just (JsonItem v _)) -> Right (frame "input" ["items" .= [v]]) + Right (Just (BytesItem b)) -> Right $ + "binary: " <> hex 0x01 2 <> " " <> hex 0 16 <> " " <> hex 0 16 <> " + " <> commas (toInteger (BS.length b)) <> " bytes" + <> " ([0x01][subscription u64][seq u64][payload]; the subscription is the call's)" + where + -- the subscription null: the server names it when it takes the call + frame verb extra = TE.decodeUtf8 $ LBS8.toStrict $ encode $ object + [ "jsonrpc" .= ("2.0" :: Text), "method" .= (ns <> "." <> verb) + , "params" .= object (["subscription" .= Null, "seq" .= (0 :: Int)] ++ extra) ] + hex :: Integer -> Int -> Text + hex n w = let s = T.pack (showHex n "") in T.replicate (w - T.length s) "0" <> s + +-- | How a bad line is said. +lineError :: Int -> Text -> Text +lineError n why = "input line " <> commas (toInteger n) <> " is not an item: " <> why diff --git a/src/Synapse/Reconnect.hs b/src/Synapse/Reconnect.hs --- a/src/Synapse/Reconnect.hs +++ b/src/Synapse/Reconnect.hs @@ -90,7 +90,7 @@ import System.IO.Unsafe (unsafePerformIO) import System.Posix.Process (exitImmediately) -import Plexus.Schema.Recursive (MethodSchema(..)) +import Plexus.Schema.Recursive (Cardinality(..), MethodSchema(..)) import qualified Plexus.Types as PT -- --------------------------------------------------------------------------- @@ -152,7 +152,7 @@ -- and anything bidirectional — is a write, never sent twice. callShape :: MethodSchema -> CallShape callShape m = CallShape - { csStream = methodStreaming m + { csStream = methodCardinality m == CardinalityMany , csRead = not (methodBidirectional m) && isRead , csSince = takesSince (methodParams m) } diff --git a/src/Synapse/Schema/Types.hs b/src/Synapse/Schema/Types.hs --- a/src/Synapse/Schema/Types.hs +++ b/src/Synapse/Schema/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} -- | Core types for Synapse -- @@ -31,6 +32,8 @@ , pattern ServiceData , pattern ServiceProgress , pattern ServiceError + , serviceErrorMessage + , jsonLine , pattern ServiceDone , pattern ServiceGuidance , pattern ServiceRequest @@ -43,11 +46,17 @@ , SelectOption(..) ) where -import Data.Aeson (Value) +import Data.Aeson (Value(..), encode, object, toJSON, (.=)) +import qualified Data.Aeson.KeyMap as KM +import qualified Data.ByteString.Lazy as LBS import Data.Text (Text) +import qualified Data.Text.Encoding as TE import Data.Int (Int64) +import Data.Scientific (toRealFloat) import GHC.Generics (Generic) +import Plexus.RemoteError (renderRemoteError) + -- Re-export from plexus-protocol import Plexus.Schema.Recursive ( PluginSchema(..) @@ -71,6 +80,8 @@ , Response(..) , StandardResponse , SelectOption(..) + , StreamMetadata(..) + , itemErrorMessage ) -- | A path through the plugin tree (sequence of namespace segments) @@ -112,13 +123,60 @@ pattern ServiceData :: Text -> Provenance -> Text -> Value -> ServiceStreamItem pattern ServiceData hash prov contentType content = StreamData hash prov contentType content --- | Pattern synonym for progress events +-- | Pattern synonym for progress events: a message and a percentage. +-- +-- Matching only (plexus 0.7: a progress frame carries the method's typed +-- progress value). The default progress type, @Note@, gives its +-- @message@ and @percentage@; any other value gives its JSON as the +-- message. RETURNS-14 renders typed progress properly. pattern ServiceProgress :: Text -> Provenance -> Text -> Maybe Double -> ServiceStreamItem -pattern ServiceProgress hash prov msg pct = StreamProgress hash prov msg pct +pattern ServiceProgress hash prov msg pct <- StreamProgress hash prov _ (progressMessage -> (msg, pct)) --- | Pattern synonym for error events +-- | Pattern synonym for error events: the call failure as one line. +-- +-- Matching only. The line is the server's own @message@ when the frame +-- has one (as plexus-core writes it on every error frame, and as main read +-- it — RETURNS-36 review), else the typed error's 'renderRemoteError' line. pattern ServiceError :: Text -> Provenance -> Text -> Bool -> ServiceStreamItem -pattern ServiceError hash prov err recoverable = StreamError hash prov err recoverable +pattern ServiceError hash prov err recoverable <- (serviceErrorView -> Just (hash, prov, err, recoverable)) + +serviceErrorView :: ServiceStreamItem -> Maybe (Text, Provenance, Text, Bool) +serviceErrorView item = case item of + StreamError hash prov _ rec -> (\m -> (hash, prov, m, rec)) <$> serviceErrorMessage item + _ -> Nothing + +-- | An error item's line: the server's @message@, else the typed error's. +serviceErrorMessage :: ServiceStreamItem -> Maybe Text +serviceErrorMessage item = case item of + StreamError _ _ err _ -> Just (maybe (renderRemoteError err) id (itemErrorMessage item)) + _ -> Nothing + +-- | RETURNS-36 review: an item as @-j@ prints it — as plexus-protocol +-- writes it, but a progress item whose content is the default progress +-- type, a Note (@message@, @percentage@), as main printed one: +-- @{type, metadata, message, percentage}@. +jsonLine :: ServiceStreamItem -> LBS.ByteString +jsonLine item = case item of + StreamProgress hash prov _ (Object o) + | Just (String msg) <- KM.lookup "message" o + , all (`elem` ["message", "percentage"]) (KM.keys o) -> + encode $ object + [ "type" .= ("progress" :: Text) + , "metadata" .= StreamMetadata prov hash 0 + , "message" .= msg + , "percentage" .= maybe Null id (KM.lookup "percentage" o) ] + _ -> encode (toJSON item) + +-- | A progress value as the 0.6-style message and percentage. +progressMessage :: Value -> (Text, Maybe Double) +progressMessage (Object o) + | Just (String msg) <- KM.lookup "message" o = + ( msg + , case KM.lookup "percentage" o of + Just (Number n) -> Just (toRealFloat n) + _ -> Nothing + ) +progressMessage v = (TE.decodeUtf8 (LBS.toStrict (encode v)), Nothing) -- | Pattern synonym for done events pattern ServiceDone :: Text -> Provenance -> ServiceStreamItem diff --git a/src/Synapse/SchemaStore.hs b/src/Synapse/SchemaStore.hs --- a/src/Synapse/SchemaStore.hs +++ b/src/Synapse/SchemaStore.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -5,7 +6,7 @@ -- | SYNAPSE-28: what a call needs from a backend's schema, kept on disk so -- a call sends first and checks only on failure. -- --- Under @$XDG_CACHE_HOME/synapse/schemas@ (@~/.cache/synapse/schemas@): +-- Under @$XDG_CACHE_HOME/synapse/schemas-4@ (@~/.cache/synapse/schemas-4@; 3.x's @schemas@ is never read): -- -- @ -- routes/CONNECTION-POINT/BACKEND.json where BACKEND is reached from there @@ -46,6 +47,8 @@ -- * Forgetting , forget + -- * A cache misled (SYNAPSE-28; RETURNS-36 review) + , isStaleItem ) where import Control.Exception (SomeException, catch, try) @@ -69,20 +72,34 @@ import Synapse.Endpoint (Endpoint(..), dirName) import Synapse.Identity.Store (writePrivateFile) import Synapse.IR.Types +import Plexus.Auth (Refusal(..)) +import Plexus.RemoteError (ParamProblem(..), RemoteError(..)) +import Plexus.Types (itemRefusal, pattern StreamError) +import Synapse.Schema.Types (ServiceStreamItem, pattern ServiceError) -- | One backend's cache, as one agent sees it at one address. newtype Store = Store { storeDir :: FilePath } deriving (Eq, Show) --- | @$XDG_CACHE_HOME/synapse/schemas@, else @~/.cache/synapse/schemas@. +-- | @$XDG_CACHE_HOME/synapse/schemas-4@, else @~/.cache/synapse/schemas-4@ +-- ('cacheLayout'). schemasRoot :: IO FilePath schemasRoot = do x <- lookupEnv "XDG_CACHE_HOME" base <- case x of Just d | not (null d) -> pure d _ -> ( ".cache") <$> getHomeDirectory - pure (base "synapse" "schemas") + pure (base "synapse" ("schemas-" <> show cacheLayout)) +-- | RETURNS-36 review (#10): the layout of what the store keeps. 4.0 keeps +-- plexus 0.8's schemas (a method's cardinality, never 0.6's streaming) +-- and plans over IR 3.0, which a 3.x synapse would misread; so 4.0 keeps +-- them under @schemas-4@, which no 3.x reads, and never reads 3.x's +-- @schemas@. Bump it with any change a synapse of the other layout would +-- misread. +cacheLayout :: Int +cacheLayout = 4 + storeFor :: Endpoint -> Text -> Text -> IO Store storeFor ep agent backend = do root <- schemasRoot @@ -248,3 +265,32 @@ forM_ ps $ \f -> rm (plans f) where rm p = removeFile p `catch` \(_ :: SomeException) -> pure () + +-- ============================================================================ +-- A cache misled +-- ============================================================================ + +-- | SYNAPSE-28: an answer that says the cache misled the call — the server +-- refused before the method ran: a refusal only an admin holds (a method +-- admin-only, unlisted), a method or activation not found, a param the +-- server does not take or misses. RETURNS-36 review: by the typed error +-- (a 0.8 server's, or a 0.7.0 frame's read from its fields), and by the +-- server's words — both phrasings, main's ("missing field") and 0.8's +-- ("missing `id`"). +isStaleItem :: ServiceStreamItem -> Bool +isStaleItem item = case itemRefusal item of + Just r -> refusalRoles r == ["admin"] + Nothing -> case item of + StreamError _ _ err _ | typedStale err -> True + ServiceError _ _ msg _ -> any (`T.isInfixOf` msg) staleWords + _ -> False + where + typedStale = \case + MethodNotFound _ _ -> True + ActivationNotFound _ -> True + InvalidParams _ Missing -> True + InvalidParams _ (Malformed d) -> any (`T.isInfixOf` d) staleWords + _ -> False + staleWords = + [ "Method not found", "Activation not found", "Unknown method", "method not found", "activation not found" + , "errCode = -32601", "missing field", "missing `", "unknown field", "invalid type", "unknown variant" ] diff --git a/src/Synapse/Transport.hs b/src/Synapse/Transport.hs --- a/src/Synapse/Transport.hs +++ b/src/Synapse/Transport.hs @@ -8,6 +8,8 @@ ( -- * Schema Fetching fetchSchema , fetchSchemaAt + , fetchServiceIR + , rootSchemaKnown , fetchMethodSchema -- * Method Invocation (collected) @@ -17,6 +19,7 @@ -- * Method Invocation (streaming) , invokeStreaming , invokeStreamingWithBidir + , invokeWithInput -- * Bidirectional Response , sendResponse @@ -31,7 +34,8 @@ import qualified Data.Map.Strict as Map import qualified Synapse.SchemaStore as Store import Control.Monad.Reader (asks) -import Data.Aeson (Value) +import Data.Aeson (Value(..), Result(..), fromJSON, object, (.=)) +import qualified Data.Aeson.KeyMap as KM import qualified Data.ByteString.Char8 as BS8 import qualified Data.CaseInsensitive as CI import qualified Data.List as List @@ -45,9 +49,16 @@ import Synapse.Schema.Types import Synapse.Monad +import Synapse.IR.Types (IR(..), currentIrVersion) import Synapse.Endpoint (substrateConfig) import qualified Synapse.Log as Log import qualified Synapse.Reconnect as R +import qualified Synapse.Input as In +import Control.Exception (throwIO) +import Control.Monad (forM_) +import qualified Data.Text.IO as TIO +import System.Exit (ExitCode(..), exitWith) +import System.IO (hFlush, stderr) -- | Fetch the root schema fetchSchema :: SynapseM PluginSchema @@ -147,6 +158,68 @@ liftIO $ modifyIORef' memo (Map.insert path schema) pure schema +-- | RETURNS-40: the service's own IR of the walk from @path@ — one call, +-- @.ir@ with the path as its namespace (none: the whole +-- service). @Just (Right ir)@ when it wrote one of this synapse's IR +-- version; @Just (Left why)@ when it refused (a namespace it has not, a +-- schema of its own it could not read — a title collision is no refusal: +-- its walk refuses that activation into the IR, as this one's does); +-- @Nothing@ when it has no @ir@ (every +-- service on the published 0.7.0 line, whose answer is a call failure) or +-- answered anything else — the caller walks the raw schemas then. +fetchServiceIR :: Path -> SynapseM (Maybe (Either Text IR)) +fetchServiceIR path = do + logger <- getLogger + cfg <- getConfig + let params = if null path then object [] else object ["namespaces" .= [T.intercalate "." path]] + -- asked once, never ridden out (R.retrying): a service that cannot be + -- reached now is the walk's to wait for, which reads what it can from the + -- run's memo and the cache and rides out the rest + result <- liftIO $ ST.invokeMethod cfg [] "ir" params + let answer = case result of + Left _ -> Nothing + Right items -> case [ d | PT.StreamData _ _ _ d <- items ] of + (Object o : _) + | Just ok <- KM.lookup "ok" o, Success ir <- fromJSON ok, irVersion ir == currentIrVersion -> Just (Right ir) + | Just (Object e) <- KM.lookup "err" o -> Just (Left (case KM.lookup "message" e of + Just (String m) -> m + _ -> "the service wrote no IR")) + _ -> Nothing + Log.logDebug logger Log.SubsystemSchema $ "The service's ir at " <> showPath path <> ": " + <> maybe "none (walking the schemas)" (either ("refused: " <>) (const "used")) answer + pure answer + +-- | RETURNS-40 review #5: the service's own schema, as cheaply as this run +-- has it — the run's memo, else the schema cache on disk, else fetched +-- once, never ridden out (a service that cannot be reached now is the +-- walk's to wait for), and memoized: a walk from the root reads it from +-- there. 'Nothing' when it cannot be had. +rootSchemaKnown :: SynapseM (Maybe PluginSchema) +rootSchemaKnown = do + memo <- asks seFetched + known <- liftIO $ Map.lookup [] <$> readIORef memo + case known of + Just s -> pure (Just s) + Nothing -> do + src <- asks seSchemaSource + stored <- case src of + FromServer (Just st) -> liftIO (Store.readSchema st []) + FromCache st -> liftIO (Store.readSchema st []) + FromServer Nothing -> pure Nothing + case stored of + Just s -> pure (Just s) + Nothing -> do + cfg <- getConfig + fetched <- liftIO (ST.fetchSchemaAt cfg []) + case fetched of + Left _ -> pure Nothing + Right s -> do + liftIO $ modifyIORef' memo (Map.insert [] s) + case src of + FromServer (Just st) -> liftIO (Store.writeSchema st [] s) + _ -> pure () + pure (Just s) + -- | A path as a message names it. showPath :: Path -> Text showPath [] = "the root" @@ -334,6 +407,89 @@ getPort (PT.ConnectionRefused _ p) _ = p getPort (PT.ConnectionTimeout _ p) _ = p getPort _ c = substratePort c + +-- | BIDIR-18: a method with an input half, its input fed from the source +-- (spec/10) as the callee's credit allows. Never sent twice: a connection +-- lost once the call went out is said on stderr with what was sent and +-- acknowledged, and the run exits 69 (a call that never left is tried +-- again in the reconnect window, as any). The printer is told whether the +-- input is still untouched (no credit came, so nothing was read): only +-- then may it hold an item back to run the call again. At the end, the +-- tally on stderr; a typed close exits by its kind ('In.closeExit'), a +-- line that is not an item 65. +invokeWithInput + :: R.CallShape + -> IO (Maybe WS.Headers) + -> In.ItemKind -> Int -> Bool -> In.InputSource + -> Path + -> Text + -> Value + -> (IO Bool -> PT.PlexusStreamItem -> IO ()) + -> SynapseM () +invokeWithInput shape0 refreshAuth kind chunk progress src namespacePath method params onItem = do + cfg <- getConfig + cfgRef <- liftIO $ newIORef cfg + refusal <- liftIO $ newIORef Nothing + let shape = shape0 { R.csRead = False, R.csSince = False } + whereTo = whereOf cfg + reauth = refreshAuth >>= \case + Just hs -> True <$ modifyIORef' cfgRef (\c -> c { substrateHeaders = hs }) + Nothing -> pure False + say t = TIO.hPutStrLn stderr ("synapse: " <> t) >> hFlush stderr + tally t = TIO.hPutStrLn stderr (In.renderTally t) >> hFlush stderr + run (half, untouched) = do + let item i = do + case In.inputRefusal i of + Just r -> modifyIORef' refusal (maybe (Just r) Just) + Nothing -> pure () + case i of + PT.StreamRequest{} -> pure () -- an input call answers no request + _ -> onItem untouched i + attempt ps subscribed h = do + c <- readIORef cfgRef + ST.invokeMethodDuplex c half subscribed namespacePath method ps h + R.resilientCall whereTo shape attempt reauth params (const (pure ())) item + (r, fed, t) <- liftIO $ In.withInputFeed kind chunk progress src run + ending <- liftIO $ either throwIO pure r + refused <- liftIO $ readIORef refusal + let lost why = liftIO $ do + say $ "connection to " <> whereTo <> " lost during the call (" <> why + <> ") — its input is not sent again (spec/10: no resume)" + tally t + exitWith (ExitFailure R.exitUnreachable) + case (fed, ending) of + (In.FedBadLine n why, _) -> liftIO $ do + say $ "input line " <> T.pack (show n) <> " is not an item: " <> why + <> " — no frame carried it; the call was ended" + tally t + exitWith (ExitFailure 65) + (In.FedFailed why, _) -> liftIO $ do + say $ "the input could not be read (" <> why <> ") — the call was ended" + tally t + exitWith (ExitFailure 74) + (_, R.WriteUnknown why) -> lost why + (_, R.Failed e@(PT.ConnectionLost why True)) + | R.isOutage e -> lost why + (_, R.GaveUp window why) + | In.tFrames t > 0 || In.tEnded t -> lost why + | otherwise -> liftIO (R.reportEnding whereTo (R.GaveUp window why)) >> pure () + (_, R.OutputClosed) -> liftIO (R.reportEnding whereTo R.OutputClosed) >> pure () + (_, R.Failed e) -> do + liftIO (tally t) + backend <- asks seBackend + throwTransportWith TransportContext + { tcMessage = transportErrorToText e + , tcHost = T.pack (substrateHost cfg) + , tcPort = substratePort cfg + , tcBackend = backend + , tcPath = namespacePath ++ [method] + , tcCategory = transportErrorToCategory e + } + (_, R.Finished) -> liftIO $ do + tally t + forM_ (In.closeExit refused (In.tClosed t)) $ \(code, why) -> do + say why + exitWith (ExitFailure code) -- | SYNAPSE-20: @host:port@, for what synapse says about an outage -- (SCAFFOLD-21: the URL, for an address behind TLS or on a path). diff --git a/test/AuthSpec.hs b/test/AuthSpec.hs --- a/test/AuthSpec.hs +++ b/test/AuthSpec.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} -- | AUTH-8: synapse shows each caller its own server. -- @@ -35,6 +36,7 @@ import Test.Hspec import Plexus.Auth +import Plexus.RemoteError (DenyReason(..), RemoteError(..), renderRemoteError) import Plexus.Schema.Recursive (ChildSummary(..), MethodSchema(..), PluginSchema(..), MethodRole(..), hasAuthColumns) import Plexus.Types (PlexusStreamItem(..), itemRefusal) import Synapse.Endpoint (plainAt) @@ -43,9 +45,12 @@ import Synapse.Auth.Loopback import Synapse.Identity.Proof (generateSeed) import qualified Synapse.Identity.Session as Session +import qualified Synapse.SchemaStore as Store +import Synapse.Schema.Types (jsonLine, pattern ServiceError) import qualified Synapse.Log as Log import MockService +import Plexus07 (methodWithContract, withContract) main :: IO () main = do @@ -62,8 +67,10 @@ -- Fixtures -- ============================================================================ +-- | A fixture as plexus 0.7 states it (RETURNS-36: each method's +-- cardinality and returns; 'withContract'), parsed. parse :: A.FromJSON a => Value -> a -parse v = case fromJSON v of +parse v0 = let v = withContract v0 in case fromJSON v of Success x -> x Error e -> error e @@ -99,12 +106,17 @@ , whoName = Just "worker-1", whoAgent = Just "worker-1" , whoMemberships = [("editor", "MENGER")], whoCeiling = ["editor@MENGER-12"] } --- AUTH-2's refusal, as the subscription notification's result carries it +-- AUTH-2's refusal, as the subscription notification's result carries it: +-- plexus 0.7's typed error (RETURNS-36: a missing grant is a forbidden +-- RemoteError) with AUTH-2's own fields beside it refusalItem :: Value -refusalItem = [aesonQQ|{"type":"error","error_kind":"forbidden", +refusalItem = [aesonQQ|{"type":"error","recoverable":false, + "message":"needs tickets.set_status on IDENTITY","code":"-32003", + "error":{"kind":"forbidden","reason":"missing_grant","grant":"tickets.set_status","scope":"IDENTITY", + "roles":["editor","admin"],"held_on":["MENGER"]}, + "error_kind":"forbidden", "grant":"tickets.set_status","scope":"IDENTITY", "roles":["editor","admin"],"held_on":["MENGER"], - "message":"needs tickets.set_status on IDENTITY", "metadata":{"provenance":["menger"],"plexus_hash":"h","timestamp":0}}|] logger :: IO Log.Logger @@ -139,7 +151,8 @@ "children":[{"namespace":"auth","methods":[{"name":"providers","public":true},{"name":"login","public":true}]}]}|] :: PluginSchema map csNamespace (maybe [] id (psChildren root)) `shouldBe` ["auth"] psVersion root `shouldBe` "" - let m = parse [aesonQQ|{"name":"login","public":true}|] :: MethodSchema + -- RETURNS-36: a 0.7 method states its contract even in the anonymous view + let m = parse (methodWithContract [aesonQQ|{"name":"login","public":true}|]) :: MethodSchema (methodName m, methodPublic m, methodDescription m, methodRole m) `shouldBe` ("login", True, "", MethodRoleRpc) it "writes the new fields back only when present" $ do let v = toJSON (methodNamed "set_status" todaysTickets) @@ -174,18 +187,30 @@ , refusalRoles = ["editor", "admin"], refusalHeldOn = ["MENGER"], refusalCeiling = [] , refusalMessage = "needs tickets.set_status on IDENTITY" } case item of - StreamError _ _ msg _ -> msg `shouldBe` "needs tickets.set_status on IDENTITY" + StreamError _ _ err _ -> do + err `shouldBe` Forbidden (MissingGrant "tickets.set_status" "IDENTITY" ["editor", "admin"] ["MENGER"]) + renderRemoteError err `shouldBe` "forbidden: needs `tickets.set_status` on `IDENTITY`" _ -> expectationFailure "a refusal is still an error item" + -- the review (RETURNS-36 #1): callers read the server's line, as main did + case item of + ServiceError _ _ msg _ -> msg `shouldBe` "needs tickets.set_status on IDENTITY" + _ -> expectationFailure "a refusal is still an error item" + it "the typed error alone names the same refusal" $ do + let typed = parse [aesonQQ|{"type":"error","recoverable":false, + "error":{"kind":"forbidden","reason":"missing_grant","grant":"tickets.set_status","scope":"IDENTITY", + "roles":["editor","admin"],"held_on":["MENGER"]}, + "metadata":{"provenance":["menger"],"plexus_hash":"h","timestamp":0}}|] :: PlexusStreamItem + itemRefusal typed `shouldBe` itemRefusal (parse refusalItem :: PlexusStreamItem) it "parses as written in the ticket, without metadata" $ do let bare = parse [aesonQQ|{"type":"error","error_kind":"forbidden","grant":"tickets.set_status", "scope":"IDENTITY","roles":["editor","admin"],"held_on":["MENGER"], - "message":"needs tickets.set_status on IDENTITY"}|] :: PlexusStreamItem + "error":{"kind":"forbidden","reason":"missing_grant","grant":"tickets.set_status","scope":"IDENTITY"}}|] :: PlexusStreamItem fmap refusalGrant (itemRefusal bare) `shouldBe` Just (Just "tickets.set_status") it "any other error has no refusal, and builds as before" $ do - let plain = parse [aesonQQ|{"type":"error","message":"Activation not found: auth", + let plain = parse [aesonQQ|{"type":"error","error":{"kind":"activation_not_found","activation":"auth"}, "metadata":{"provenance":["menger"],"plexus_hash":"h","timestamp":0},"recoverable":false}|] itemRefusal plain `shouldBe` Nothing - itemRefusal (StreamError "h" (parse [aesonQQ|["m"]|]) "boom" False) `shouldBe` Nothing + itemRefusal (StreamError "h" (parse [aesonQQ|["m"]|]) (Execution "boom") False) `shouldBe` Nothing it "keeps a refusal's fields when written back" $ do let item = parse refusalItem :: PlexusStreamItem fmap itemRefusal (decode (A.encode item)) `shouldBe` Just (itemRefusal item) @@ -196,6 +221,76 @@ fmap refusalMessage (itemRefusal d) `shouldBe` Just "needs tickets.create on MENGER" parseRefusal [aesonQQ|{"error_kind":"forbidden"}|] `shouldBe` Just (Refusal Nothing Nothing [] [] [] "forbidden") parseRefusal [aesonQQ|{"error_kind":"invalid_params","message":"x"}|] `shouldBe` Nothing + + -- the review (RETURNS-36 #1, #7): what synapse reads off an error frame is + -- the server's message; an ended session is the typed unauthenticated + -- with the server's reason (main's text otherwise); a cache misled is a + -- not-found or a param the server does not take, typed or in its words; + -- -j prints a Note progress as main did + describe "the server's line (RETURNS-36 review)" $ do + let meta = [aesonQQ|{"provenance":["menger"],"plexus_hash":"h","timestamp":0}|] + frame08 msg code err kind = parse (A.object + [ "type" A..= ("error" :: Text), "metadata" A..= meta, "recoverable" A..= False + , "message" A..= (msg :: Text), "code" A..= (code :: Text), "error" A..= (err :: Value) + , "error_kind" A..= (kind :: Text) ]) :: PlexusStreamItem + frame070 msg code = parse (A.object + [ "type" A..= ("error" :: Text), "metadata" A..= meta, "recoverable" A..= False + , "message" A..= (msg :: Text), "code" A..= (code :: Text) ]) :: PlexusStreamItem + signedOut08 = frame08 "Authentication required: you have signed out: sign in again" "-32001" + [aesonQQ|{"kind":"unauthenticated"}|] "unauthenticated" + missingId08 = frame08 "Invalid params: missing field: id" "-32602" + [aesonQQ|{"kind":"invalid_params","param":"id","problem":"missing"}|] "invalid_params" + notFound08 = parse (A.object + [ "type" A..= ("error" :: Text), "metadata" A..= meta, "recoverable" A..= False + , "message" A..= ("Method not found: tickets.get" :: Text), "code" A..= ("-32601" :: Text) + , "error" A..= [aesonQQ|{"kind":"method_not_found","activation":"tickets","method":"get"}|] ]) :: PlexusStreamItem + it "ServiceError gives the server's message" $ do + case signedOut08 of + ServiceError _ _ m _ -> m `shouldBe` "Authentication required: you have signed out: sign in again" + _ -> expectationFailure "an error" + case frame070 "boom" "-32000" of + ServiceError _ _ m _ -> m `shouldBe` "boom" + _ -> expectationFailure "an error" + it "a frame without message: the typed error's line, an unknown kind's too" $ do + let bare err = parse (A.object [ "type" A..= ("error" :: Text), "metadata" A..= meta, "recoverable" A..= False + , "error" A..= (err :: Value) ]) :: PlexusStreamItem + case bare [aesonQQ|{"kind":"unauthenticated"}|] of + ServiceError _ _ m _ -> m `shouldBe` "unauthenticated: credentials required" + _ -> expectationFailure "an error" + case bare [aesonQQ|{"kind":"too_many_writes","retry_after_ms":250,"message":"slow down"}|] of + ServiceError _ _ m _ -> m `shouldBe` "too_many_writes: slow down" + _ -> expectationFailure "an error" + Store.isStaleItem (bare [aesonQQ|{"kind":"too_many_connections","max":64}|]) `shouldBe` False + it "a signed-out or expired session is ended, 0.8 or 0.7.0" $ do + Session.isSessionEndedItem signedOut08 `shouldBe` True + Session.isSessionEndedItem (frame08 "Authentication required: your sign-in has expired: sign in again" "-32001" + [aesonQQ|{"kind":"unauthenticated"}|] "unauthenticated") `shouldBe` True + Session.isSessionEndedItem (frame070 "Authentication required: you have signed out: sign in again" "-32001") `shouldBe` True + -- re-review #6: main's behaviour wins — the text on any error, as main + -- matched it, beside the typed unauthenticated's reason + it "an unauthenticated call without that reason is not ended; any error saying it is, as main read it" $ do + Session.isSessionEndedItem (frame08 "Authentication required: credentials required" "-32001" + [aesonQQ|{"kind":"unauthenticated"}|] "unauthenticated") `shouldBe` False + Session.isSessionEndedItem (frame08 "you have signed out" "-32000" + [aesonQQ|{"kind":"execution","message":"you have signed out"}|] "") `shouldBe` True + it "a cache misled: a missing or unknown param, a method not found — 0.8 and 0.7.0" $ do + Store.isStaleItem missingId08 `shouldBe` True + Store.isStaleItem notFound08 `shouldBe` True + Store.isStaleItem (frame070 "Invalid params: missing field: id" "-32602") `shouldBe` True + Store.isStaleItem (frame070 "Method not found: tickets.get" "-32601") `shouldBe` True + Store.isStaleItem (frame08 "Invalid params: unknown field `sumary`, expected one of `id`" "-32602" + [aesonQQ|{"kind":"invalid_params","problem":"malformed","detail":"unknown field `sumary`, expected one of `id`"}|] "invalid_params") + `shouldBe` True + Store.isStaleItem (frame08 "Execution error: boom" "-32000" [aesonQQ|{"kind":"execution","message":"boom"}|] "") `shouldBe` False + it "-j prints a Note progress as main did, other content as content" $ do + let progress c = parse (A.object [ "type" A..= ("progress" :: Text), "metadata" A..= meta + , "content_type" A..= ("tickets.import" :: Text), "content" A..= (c :: Value) ]) :: PlexusStreamItem + line = decode . jsonLine :: PlexusStreamItem -> Maybe Value + line (progress [aesonQQ|{"message":"half","percentage":50.0}|]) `shouldBe` Just [aesonQQ| + {"type":"progress","metadata":{"provenance":["menger"],"plexus_hash":"h","timestamp":0},"message":"half","percentage":50.0}|] + line (progress [aesonQQ|{"message":"started"}|]) `shouldBe` Just [aesonQQ| + {"type":"progress","metadata":{"provenance":["menger"],"plexus_hash":"h","timestamp":0},"message":"started","percentage":null}|] + line (progress [aesonQQ|{"type":"batch","done":1,"of":3}|]) `shouldBe` Just (toJSON (progress [aesonQQ|{"type":"batch","done":1,"of":3}|])) describe "the anonymous page" $ do it "renders the ticket's transcript" $ do diff --git a/test/BidirIntegrationSpec.hs b/test/BidirIntegrationSpec.hs --- a/test/BidirIntegrationSpec.hs +++ b/test/BidirIntegrationSpec.hs @@ -97,7 +97,7 @@ describe "Bidirectional type inference" $ do it "mdBidirType is Nothing for non-bidirectional methods" $ do -- Find methods that are NOT streaming and likely not bidirectional - let nonStreamingMethods = filter (not . mdStreaming) (Map.elems $ irMethods ir) + let nonStreamingMethods = filter ((/= CardinalityMany) . mdCardinality) (Map.elems $ irMethods ir) -- Check a sample (if any exist) case take 1 nonStreamingMethods of [] -> pending -- No non-streaming methods to test @@ -170,7 +170,7 @@ it "bidirectional methods are streaming (typically)" $ do let bidirMethods = filter (isJust . mdBidirType) (Map.elems $ irMethods ir) forM_ bidirMethods $ \method -> - if mdStreaming method + if mdCardinality method == CardinalityMany then pure () -- Expected - bidir usually requires streaming else putStrLn $ " Note: Bidirectional method " <> T.unpack (mdFullPath method) <> " is NOT streaming (unusual but valid)" @@ -232,7 +232,7 @@ it "reports bidirectional coverage statistics" $ do let allMethods = Map.elems $ irMethods ir let bidirMethods = filter (isJust . mdBidirType) allMethods - let streamingMethods = filter mdStreaming allMethods + let streamingMethods = filter ((== CardinalityMany) . mdCardinality) allMethods putStrLn "\n Bidirectional Statistics:" putStrLn $ " Total methods: " <> show (length allMethods) @@ -265,4 +265,4 @@ mdBidirType method `shouldSatisfy` (\case { Just RefJson -> True; _ -> False }) it (T.unpack methodPath <> " is a streaming method") $ - mdStreaming method `shouldBe` True + mdCardinality method `shouldBe` CardinalityMany diff --git a/test/DeprecationSpec.hs b/test/DeprecationSpec.hs --- a/test/DeprecationSpec.hs +++ b/test/DeprecationSpec.hs @@ -26,7 +26,8 @@ import Test.Hspec import Plexus.Schema.Recursive - ( DeprecationInfo(..) + ( Cardinality(..) + , DeprecationInfo(..) , MethodRole(..) , MethodSchema(..) , ParamSchema(..) @@ -46,7 +47,7 @@ , formatMethodWarningLine , resetDeprecationStateForTesting ) -import Synapse.IR.Builder (extractMethodDef) +import Synapse.IR.Builder (extractMethodDef, renderIRBuildError) import Synapse.IR.Types (IR(..), emptyIR) -- --------------------------------------------------------------------------- @@ -59,9 +60,12 @@ , methodDescription = "Relocate a document." , methodHash = "hash-move-doc" , methodParams = Nothing - , methodReturns = Nothing - , methodStreaming = False + , methodReturns = object [] + , methodError = Nothing + , methodProgress = Nothing + , methodCardinality = CardinalityOne , methodBidirectional = False + , methodHttpMethod = "POST" , methodRequestType = Nothing , methodResponseType = Nothing , methodDeprecation = Nothing @@ -88,11 +92,12 @@ , psVersion = "1.0" , psDescription = "Document activation" , psLongDescription = Nothing + , psSelfHash = Nothing , psHash = "hash-docs" , psMethods = [deprecatedMethod, plainMethod] , psChildren = Nothing , psDeprecation = Nothing - , psRoles = Nothing, psView = Nothing + , psRequest = Nothing, psRoles = Nothing, psView = Nothing } deprecatedPlugin :: PluginSchema @@ -167,7 +172,8 @@ -- 'pdDeprecation' lives, lifted there by 'extractMethodDef'). helpFixture :: (IR, T.Text) helpFixture = - let (_types, mdef) = extractMethodDef "docs" "docs" methodWithDeprecatedParam + let mdef = either (error . T.unpack . renderIRBuildError) snd + (extractMethodDef "docs" "docs" methodWithDeprecatedParam) fullPath = "docs.relocate" ir = emptyIR { irMethods = Map.singleton fullPath mdef } in (ir, renderMethodHelp ir mdef) diff --git a/test/FindSpec.hs b/test/FindSpec.hs --- a/test/FindSpec.hs +++ b/test/FindSpec.hs @@ -101,8 +101,8 @@ method :: Text -> Text -> Text -> MethodDef method ns name desc = MethodDef { mdName = name, mdFullPath = ns <> "." <> name, mdNamespace = ns - , mdDescription = Just desc, mdStreaming = False, mdParams = [] - , mdReturns = RefUnknown, mdBidirType = Nothing, mdBidirResponseType = Nothing + , mdDescription = Just desc, mdParams = [] + , mdReturns = RefUnknown, mdError = Nothing, mdProgress = Nothing, mdCardinality = CardinalityOne, mdBidirType = Nothing, mdBidirResponseType = Nothing , mdBidirResponseSchema = Nothing, mdRole = MethodRoleRpc , mdGrant = Nothing, mdTarget = Nothing, mdLongDescription = Nothing , mdInjected = [], mdInput = Nothing diff --git a/test/HoldSpec.hs b/test/HoldSpec.hs --- a/test/HoldSpec.hs +++ b/test/HoldSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -15,26 +16,45 @@ -- exactly one; a method the service renamed falls back to the probe and the -- fetch, then answers; a method the service no longer has is refused after -- the fallback, as it always was. +-- * SYNAPSE-40, the built synapse again: one holder process for the user, +-- however many addresses and agents call, a connection for each (address, +-- agent), never one shared by two agents; a connection whose server +-- stopped is gone within 10 s while the rest are kept; the cap closes the +-- longest idle first; and a loop of calls against short-lived servers +-- (@SYNAPSE40_LOOP@, 500) runs through one holder that holds nothing 10 s +-- after the last server stops, its memory flat. What the holder holds is +-- asked of it on its socket (@{"status":true}@); every holder a test +-- started is stopped by pid when the test ends. module Main (main) where import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.Async (mapConcurrently, async, cancel) -import Control.Exception (SomeException, try, fromException) -import Control.Monad (forM_, replicateM_, void) +import Control.Exception (SomeException, bracket, finally, try, fromException) +import Control.Monad (filterM, forM, forM_, forever, replicateM_, void, when) +import Data.Char (isDigit) +import Data.List (isInfixOf, isPrefixOf, isSuffixOf, nub, sort) import Data.Maybe (isJust) -import Data.Aeson (Value(..)) +import Data.Aeson (Value(..), decodeStrict) import qualified Data.Aeson.KeyMap as KM +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 import Data.IORef import qualified Data.Text as T -import System.Directory (doesFileExist, createDirectoryIfMissing, findExecutable) -import System.Environment (getEnvironment) +import qualified Data.Vector as V +import GHC.Clock (getMonotonicTime) +import qualified Network.Socket as N +import qualified Network.Socket.ByteString as NB +import System.Directory (doesDirectoryExist, doesFileExist, createDirectoryIfMissing, findExecutable, getSymbolicLinkTarget, listDirectory) +import System.Environment (getEnvironment, lookupEnv) import System.Exit (ExitCode(..)) -import System.FilePath (()) +import System.FilePath ((), takeFileName) import System.IO.Temp (withSystemTempDirectory) +import System.Posix.Signals (signalProcess, sigKILL, sigTERM) import System.Process (CreateProcess(..), proc, readCreateProcessWithExitCode) import Test.Hspec import Plexus.Client (SubstrateConfig(..), LostConnection(..), defaultConfig) +import Plexus.Input (InputHalf(..), InputPort(..), InputSignal(..)) import Plexus.Types (PlexusStreamItem(..)) import qualified Synapse.Hold as Hold @@ -84,10 +104,10 @@ it "serves many runs' requests on one connection" $ withSystemTempDirectory "hold" $ \dir -> withMockService todaysService $ \port -> do let sock = dir "h.sock" - _ <- forkIO $ Hold.runHolder (Hold.HoldOpts sock 30) `catchAll` const (pure ()) + _ <- forkIO $ Hold.runHolder (Hold.holdOpts sock 30) `catchAll` const (pure ()) waitFor (doesFileExist sock) before <- readIORef connectionsAccepted - let call = collect (Hold.holderCall sock (serviceAt port)) "menger.call" (getTicket "MENGER-12") + let call = collect (Hold.holderCall sock "a1" (serviceAt port)) "menger.call" (getTicket "MENGER-12") replicateM_ 3 (call >>= (`shouldSatisfy` any isTicket)) rs <- mapConcurrently (const call) [1 .. 20 :: Int] all (any isTicket) rs `shouldBe` True @@ -97,21 +117,21 @@ it "relays each item as the service sent it, and the end" $ withSystemTempDirectory "hold" $ \dir -> withMockService todaysService $ \port -> do let sock = dir "h.sock" - _ <- forkIO $ Hold.runHolder (Hold.HoldOpts sock 30) `catchAll` const (pure ()) + _ <- forkIO $ Hold.runHolder (Hold.holdOpts sock 30) `catchAll` const (pure ()) waitFor (doesFileExist sock) direct <- Hold.newMux viaMux <- collect (Hold.muxCall direct (serviceAt port)) "menger.call" (getTicket "MENGER-12") - viaHolder <- collect (Hold.holderCall sock (serviceAt port)) "menger.call" (getTicket "MENGER-12") + viaHolder <- collect (Hold.holderCall sock "a1" (serviceAt port)) "menger.call" (getTicket "MENGER-12") viaHolder `shouldBe` viaMux it "ends the call of a run that goes away mid-stream" $ withSystemTempDirectory "hold" $ \dir -> withMockService todaysService $ \port -> do writeIORef unsubscribes [] let sock = dir "h.sock" - _ <- forkIO $ Hold.runHolder (Hold.HoldOpts sock 30) `catchAll` const (pure ()) + _ <- forkIO $ Hold.runHolder (Hold.holdOpts sock 30) `catchAll` const (pure ()) waitFor (doesFileExist sock) got <- newEmptyFlag - a <- async $ Hold.holderCall sock (serviceAt port) (pure ()) "menger.call" watch (\_ -> setFlag got) + a <- async $ Hold.holderCall sock "a1" (serviceAt port) (pure ()) "menger.call" watch (\_ -> setFlag got) waitFlag got cancel a waitFor ((== 1) . length <$> readIORef unsubscribes) @@ -119,9 +139,9 @@ it "says a dial it could not make as connect does, so the run reads an outage" $ withSystemTempDirectory "hold" $ \dir -> do let sock = dir "h.sock" - _ <- forkIO $ Hold.runHolder (Hold.HoldOpts sock 30) `catchAll` const (pure ()) + _ <- forkIO $ Hold.runHolder (Hold.holdOpts sock 30) `catchAll` const (pure ()) waitFor (doesFileExist sock) - r <- try (collect (Hold.holderCall sock (serviceAt 1)) "menger.call" (getTicket "X")) + r <- try (collect (Hold.holderCall sock "a1" (serviceAt 1)) "menger.call" (getTicket "X")) case r of Left (e :: SomeException) -> do show e `shouldContain` "Connection failed" @@ -131,47 +151,224 @@ it "carries a bidirectional request and its answer" $ withSystemTempDirectory "hold" $ \dir -> withMockService todaysService $ \port -> do let sock = dir "h.sock" - _ <- forkIO $ Hold.runHolder (Hold.HoldOpts sock 30) `catchAll` const (pure ()) + _ <- forkIO $ Hold.runHolder (Hold.holdOpts sock 30) `catchAll` const (pure ()) waitFor (doesFileExist sock) answered <- newIORef Nothing let onItem i = case i of - StreamRequest {} -> void $ collect (Hold.holderCall sock (serviceAt port)) "menger.respond" + StreamRequest {} -> void $ collect (Hold.holderCall sock "a1" (serviceAt port)) "menger.respond" (Object (KM.fromList [ ("request_id", String "req-1") , ("response_data", Object (KM.fromList [("type", String "confirmed"), ("value", Bool True)])) ])) StreamData _ _ "tickets.ask" v -> writeIORef answered (Just v) _ -> pure () - Hold.holderCall sock (serviceAt port) (pure ()) "menger.call" (Object (KM.fromList [("method", String "tickets.ask")])) onItem + Hold.holderCall sock "a1" (serviceAt port) (pure ()) "menger.call" (Object (KM.fromList [("method", String "tickets.ask")])) onItem readIORef answered >>= (`shouldSatisfy` isJust) - it "exits when idle, and takes its socket with it" $ + it "exits when it has held nothing for --hold-for, and takes its socket with it" $ withSystemTempDirectory "hold" $ \dir -> do let sock = dir "h.sock" - _ <- forkIO $ Hold.runHolder (Hold.HoldOpts sock 1) `catchAll` const (pure ()) + _ <- forkIO $ Hold.runHolder (Hold.holdOpts sock 1) `catchAll` const (pure ()) waitFor (doesFileExist sock) waitFor (not <$> doesFileExist sock) - describe "a socket per address and agent" $ do - it "names the address, the agent and the version" $ do - p <- Hold.socketPathFor "3.17.1" "wss_app.menger.sh_443_ws" "builder" - p `shouldContain` "wss_app.menger.sh_443_ws@builder-3.17.1.sock" - q <- Hold.socketPathFor "3.17.1" "wss_app.menger.sh_443_ws" "pipeline" - q `shouldNotBe` p - it "stays short enough for a unix socket" $ do - p <- Hold.socketPathFor "3.17.1" (replicate 120 'h') "builder" - length p `shouldSatisfy` (< 108) + it "closes a connection idle for --hold-for, then exits" $ + withSystemTempDirectory "hold" $ \dir -> withMockService todaysService $ \port -> do + let sock = dir "h.sock" + _ <- forkIO $ Hold.runHolder (Hold.holdOpts sock 1) `catchAll` const (pure ()) + waitFor (doesFileExist sock) + collect (Hold.holderCall sock "a1" (serviceAt port)) "menger.call" (getTicket "MENGER-12") >>= (`shouldSatisfy` any isTicket) + waitFor (not <$> doesFileExist sock) + describe "the holder, one for every address and agent (SYNAPSE-40)" $ do + it "keeps a connection per agent at one address, never one for two" $ + withHolder 30 0 $ \sock -> withMockService todaysService $ \port -> do + c0 <- readIORef connectionsAccepted + forM_ ["a1", "a2", "a1", "a2"] $ \a -> + collect (Hold.holderCall sock a (serviceAt port)) "menger.call" (getTicket "MENGER-12") >>= (`shouldSatisfy` any isTicket) + c1 <- readIORef connectionsAccepted + (c1 - c0) `shouldBe` 2 + fmap (sort . heldOf) <$> Hold.holderStatus sock `shouldReturn` Just [(port, "a1"), (port, "a2")] + + it "keeps a connection per credential too, as a re-login makes one" $ + withHolder 30 0 $ \sock -> withMockService todaysService $ \port -> do + c0 <- readIORef connectionsAccepted + let as tok = (serviceAt port) { substrateHeaders = [("Authorization", "Bearer " <> tok)] } + forM_ ["t1", "t2", "t1"] $ \tok -> + collect (Hold.holderCall sock "a1" (as tok)) "menger.call" (getTicket "MENGER-12") >>= (`shouldSatisfy` any isTicket) + c1 <- readIORef connectionsAccepted + (c1 - c0) `shouldBe` 2 + + it "lets a connection go within two seconds of its server stopping, and keeps the others" $ + withHolder 30 0 $ \sock -> withMockService todaysService $ \live -> do + let call port = collect (Hold.holderCall sock "a1" (serviceAt port)) "menger.call" (getTicket "MENGER-12") + call live >>= (`shouldSatisfy` any isTicket) + gone <- withEphemeralService todaysService $ \port -> do + call port >>= (`shouldSatisfy` any isTicket) + fmap (sort . map fst . heldOf) <$> Hold.holderStatus sock `shouldReturn` Just (sort [live, port]) + pure port + t0 <- getMonotonicTime + waitFor (maybe False ((== [live]) . map fst . heldOf) <$> Hold.holderStatus sock) + t1 <- getMonotonicTime + (t1 - t0) `shouldSatisfy` (< 2.5) + gone `shouldNotBe` live + + it "dials again, on the next call, an address whose server came back" $ + withHolder 30 0 $ \sock -> do + port <- withEphemeralService todaysService $ \p -> do + collect (Hold.holderCall sock "a1" (serviceAt p)) "menger.call" (getTicket "MENGER-12") >>= (`shouldSatisfy` any isTicket) + pure p + waitFor (maybe False (null . heldOf) <$> Hold.holderStatus sock) + withMockServiceOn port $ + collect (Hold.holderCall sock "a1" (serviceAt port)) "menger.call" (getTicket "MENGER-12") >>= (`shouldSatisfy` any isTicket) + + it "closes the connection idle longest when it holds its cap, never one carrying a call" $ + withHolder 30 2 $ \sock -> withServices 4 $ \ps -> case ps of + [s1, s2, s3, s4] -> do + let call p = collect (Hold.holderCall sock "a1" (serviceAt p)) "menger.call" (getTicket "MENGER-12") >>= (`shouldSatisfy` any isTicket) + held = fmap (sort . map fst . heldOf) <$> Hold.holderStatus sock + -- s1 carries a stream throughout: never the one closed + got <- newEmptyFlag + w <- async $ Hold.holderCall sock "a1" (serviceAt s1) (pure ()) "menger.call" watch (\_ -> setFlag got) + waitFlag got + call s2 + call s3 + held `shouldReturn` Just (sort [s1, s3]) + call s4 + held `shouldReturn` Just (sort [s1, s4]) + cancel w + _ -> expectationFailure "four services" + + it "leaves nothing open for a run that went away while its connection was being made" $ + withHolder 30 0 $ \sock -> withMockService todaysService $ \port -> do + o0 <- readIORef connectionsOpen + writeIORef upgradeDelay 1000000 + a <- async $ collect (Hold.holderCall sock "a1" (serviceAt port)) "menger.call" (getTicket "MENGER-12") + threadDelay 300000 -- the dial is under way + cancel a + writeIORef upgradeDelay 0 + -- the dial ends a moment on: closed at once, nothing open, nothing held + threadDelay 1000000 + waitFor ((== o0) <$> readIORef connectionsOpen) + fmap heldOf <$> Hold.holderStatus sock `shouldReturn` Just [] + + it "keeps a connection only as long as its call's --hold-for says" $ + withHolder 60 0 $ \sock -> withMockService todaysService $ \port -> do + collect (Hold.holderCallAs sock "a1" (Just 1) (const (pure ())) (serviceAt port)) "menger.call" (getTicket "MENGER-12") + >>= (`shouldSatisfy` any isTicket) + fmap heldOf <$> Hold.holderStatus sock `shouldReturn` Just [(port, "a1")] + waitFor (maybe False (null . heldOf) <$> Hold.holderStatus sock) + + it "exits when it holds nothing however often its status is asked" $ + withSystemTempDirectory "hold" $ \dir -> do + let sock = dir "h.sock" + _ <- forkIO $ Hold.runHolder (Hold.holdOpts sock 1) `catchAll` const (pure ()) + waitFor (doesFileExist sock) + poller <- async $ forever $ Hold.holderStatus sock >> threadDelay 200000 + waitFor (not <$> doesFileExist sock) + cancel poller + + it "says what it holds, never a credential" $ + withHolder 30 0 $ \sock -> withMockService todaysService $ \port -> do + let cfg = (serviceAt port) { substrateHeaders = [("Authorization", "Bearer mgs_s3cret")] } + collect (Hold.holderCall sock "a1" cfg) "menger.call" (getTicket "MENGER-12") >>= (`shouldSatisfy` any isTicket) + st <- Hold.holderStatus sock + fmap heldOf st `shouldBe` Just [(port, "a1")] + show st `shouldNotContain` "s3cret" + + -- BIDIR-18: a call's input half rides the call's connection — through + -- the holder (protocol 4: "sig", "in", "bin", "end") and on a run's own + describe "a call with an input half" $ do + let carries name route = it ("carries text and binary input frames " <> name) $ + withMockService todaysService $ \port -> do + writeIORef schemaOverride (Just inputSchemas) + resetInput defaultInputPlan + (textItems, textSigs) <- duplexCall (route port) "stream.lines" $ \p -> do + ipItems p 0 [String "one", String "two"] + ipItems p 1 [String "three"] + ipEnd p 2 + any isTaken textItems `shouldBe` True + textSigs `shouldSatisfy` any (\case { InputCredit 64 -> True; _ -> False }) + textSigs `shouldSatisfy` any (\case { InputAck 1 -> True; _ -> False }) + rs <- readIORef inputReceived + rs `shouldBe` [ReceivedJson 0 [String "one", String "two"], ReceivedJson 1 [String "three"], ReceivedEnd 2] + resetInput defaultInputPlan + (binItems, _) <- duplexCall (route port) "stream.audio" $ \p -> do + ipBinary p 0 (BS.pack [1, 2, 3]) + ipBinary p 1 (BS.replicate 640 9) + ipEnd p 2 + any isTaken binItems `shouldBe` True + rs' <- readIORef inputReceived + [ (sq, BS.length b) | ReceivedBinary _ sq b <- rs' ] `shouldBe` [(0, 3), (1, 640)] + [ sq | ReceivedEnd sq <- rs' ] `shouldBe` [2] + readIORef inputViolations `shouldReturn` [] + writeIORef schemaOverride Nothing + -- review of BIDIR-18: the holder reads a binary frame's line strictly + -- and refuses one past 16 MiB, ending the call with why + forM_ [ ("b 0 20000000", "past the"), ("b 0x5", "cannot read"), ("b 0 5 6", "cannot read") ] $ \(line, says) -> + it ("refuses the binary frame line " <> show line <> ", ending the call with an error") $ + withHolder 30 0 $ \sock -> withMockService todaysService $ \port -> do + writeIORef schemaOverride (Just inputSchemas) + resetInput defaultInputPlan + s <- N.socket N.AF_UNIX N.Stream N.defaultProtocol + N.connect s (N.SockAddrUnix sock) + NB.sendAll s $ BS8.pack $ "{\"agent\":\"a1\",\"input\":true,\"host\":\"127.0.0.1\",\"port\":" <> show port + <> ",\"path\":\"/ws\",\"tls\":false,\"ca\":[],\"headers\":[],\"method\":\"menger.call\",\"params\":{\"method\":\"stream.audio\"}}\n" + let readUntil acc = do + chunk <- NB.recv s 65536 + let acc' = acc <> chunk + if BS.null chunk || any (BS8.isInfixOf "\"t\":\"error\"") (BS8.lines acc') || any (BS8.isInfixOf "\"t\":\"end\"") (BS8.lines acc') + then pure acc' else readUntil acc' + readSub acc = do + chunk <- NB.recv s 65536 + let acc' = acc <> chunk + if BS.null chunk || BS8.isInfixOf "\"t\":\"sub\"" acc' then pure acc' else readSub acc' + _ <- readSub "" + NB.sendAll s (BS8.pack (line <> "\n")) + out <- readUntil "" + N.close s + let errs = [ l | l <- BS8.lines out, BS8.isInfixOf "\"t\":\"error\"" l ] + map BS8.unpack errs `shouldSatisfy` any (says `isInfixOf`) + rs <- readIORef inputReceived + [ r | r@ReceivedBinary {} <- rs ] `shouldBe` [] + writeIORef schemaOverride Nothing + carries "through the holder" $ \port half -> \onSub m ps onItem -> withHolderOnce $ \sock -> + Hold.holderCallDuplex sock "a1" Nothing (const (pure ())) (serviceAt port) half onSub m ps onItem + carries "on the run's own connection (--no-hold)" $ \port half -> \onSub m ps onItem -> do + mux <- Hold.newMux + Hold.muxCallDuplex mux (serviceAt port) half onSub m ps onItem + + describe "one socket for the user" $ do + -- RETURNS-36: 4.0 changes the items the holder relays (plexus 0.8's + -- typed error and progress), so its holder is protocol 3, apart from + -- 3.17.x's (2) + it "is holder-4.sock in the runtime directory, whatever the address or agent" $ do + p <- Hold.holderSocketPath + takeFileName p `shouldBe` "holder-4.sock" + Hold.holdProtocol `shouldBe` 4 + describe "the CLI, sending first" $ do synapse <- runIO (findExecutable "synapse") case synapse of Nothing -> it "(the synapse executable is not on PATH)" $ pendingWith "cabal test puts it there" Just exe -> cliSpec exe + describe "one holder for the user (SYNAPSE-40)" $ do + synapse <- runIO (findExecutable "synapse") + case synapse of + Nothing -> it "(the synapse executable is not on PATH)" $ pendingWith "cabal test puts it there" + Just exe -> oneHolderSpec exe + cliSpec :: FilePath -> Spec cliSpec exe = do it "is this build" $ do (_, out, _) <- readCreateProcessWithExitCode (proc exe ["--version"]) "" - out `shouldStartWith` "3.17" + out `shouldStartWith` "4.0" + -- re-review #5: help names the holder's socket as it is + it "help names holder-4.sock" $ do + (_, out, err) <- readCreateProcessWithExitCode (proc exe ["--help"]) "" + (out <> err) `shouldContain` "holder-4.sock" + (out <> err) `shouldNotContain` "holder-3.sock" + it "answers cold, fills the cache, and opens one connection for the probe, the schema and the call" $ withRun $ \run _ -> do c0 <- readIORef connectionsAccepted @@ -259,7 +456,312 @@ run' extra args = readCreateProcessWithExitCode (proc exe (extra ++ ["--url", "ws://127.0.0.1:" <> show port <> "/ws", "menger"] ++ args)) { env = Just env } "" writeIORef renamedGet False - act (run' []) run' + act (run' []) run' `finally` stopHolders dir + +-- | SYNAPSE-40: the built synapse, every run as the user it is, through one +-- holder (each test a home and runtime directory of its own, the holder told +-- to wait 60 s, so what it lets go it lets go by itself). +oneHolderSpec :: FilePath -> Spec +oneHolderSpec exe = do + it "runs one holder process however many addresses and agents call, with a connection for each" $ + withHome [] $ \dir env -> withServices 3 $ \ps -> do + forM_ ps $ \p -> forM_ ["a1", "a2"] $ \a -> do + (code, out, _) <- runIn exe env ["--as", a] p + code `shouldBe` ExitSuccess + out `shouldContain` "MENGER-12" + length <$> holdersUnder dir `shouldReturn` 1 + st <- holderStatusIn dir + fmap (sort . heldOf) st `shouldBe` Right (sort [ (p, a) | p <- ps, a <- ["a1", "a2"] ]) + + it "never lets two agents share a connection to one address" $ + withHome [] $ \dir env -> withMockService todaysService $ \p -> do + c0 <- readIORef connectionsAccepted + forM_ ["a1", "a2", "a1", "a2"] $ \a -> do + (code, _, _) <- runIn exe env ["--as", a] p + code `shouldBe` ExitSuccess + c1 <- readIORef connectionsAccepted + (c1 - c0) `shouldBe` 2 + st <- holderStatusIn dir + fmap (sort . heldOf) st `shouldBe` Right [(p, "a1"), (p, "a2")] + + it "lets a connection go within 10 s of its server stopping, and keeps the others" $ + withHome [] $ \dir env -> withMockService todaysService $ \live -> do + (code0, _, _) <- runIn exe env [] live + code0 `shouldBe` ExitSuccess + forM_ [1 .. 3 :: Int] $ \_ -> withEphemeralService todaysService $ \p -> do + (code, out, _) <- runIn exe env [] p + code `shouldBe` ExitSuccess + out `shouldContain` "MENGER-12" + -- all three have stopped: within 10 s the holder holds the live one alone + st <- waitStatus 10 (\v -> map fst (heldOf v) == [live]) dir + fmap (map fst . heldOf) st `shouldBe` Right [live] + length <$> holdersUnder dir `shouldReturn` 1 + + it "holds no more than its cap, closing the longest idle first" $ + withHome [("SYNAPSE_HOLD_MAX", "3")] $ \dir env -> withServices 6 $ \ps -> case ps of + [s1, s2, s3, s4, s5, s6] -> do + let call p = runIn exe env [] p >>= \(code, _, _) -> code `shouldBe` ExitSuccess + held = fmap (sort . map fst . heldOf) <$> holderStatusIn dir + mapM_ call [s1, s2, s3, s4, s5] + held `shouldReturn` Right (sort [s3, s4, s5]) + call s3 -- s3 is the one used last now + call s6 -- and s4 the one idle longest + held `shouldReturn` Right (sort [s3, s5, s6]) + _ -> expectationFailure "six services" + + it "puts its own holder in the place of an older one, never of a newer one" $ do + (_, v, _) <- readCreateProcessWithExitCode (proc exe ["--version"]) "" + let ours = takeWhile (/= '\n') v + sockIn dir = dir "run" "synapse" ("holder-" <> show Hold.holdProtocol <> ".sock") + versionIn dir = fmap (\st -> case st of { Object o | Just (String x) <- KM.lookup "version" o -> T.unpack x; _ -> "" }) <$> holderStatusIn dir + -- an older holder (3.16.0, here in this process) is drained and replaced by the run's + withHome [] $ \dir env -> withMockService todaysService $ \port -> do + _ <- forkIO $ Hold.runHolder (Hold.holdOpts (sockIn dir) 30) { Hold.hoVersion = "3.16.0" } `catchAll` const (pure ()) + waitFor (doesFileExist (sockIn dir)) + (code, out, _) <- runIn exe env [] port + (code, "MENGER-12" `isInfixOf` out) `shouldBe` (ExitSuccess, True) + versionIn dir `shouldReturn` Right ours + hs <- holdersUnder dir + length hs `shouldBe` 1 + -- and the next run keeps it: no turns taken + (code', _, _) <- runIn exe env [] port + code' `shouldBe` ExitSuccess + holdersUnder dir `shouldReturn` hs + -- a newer one (99.0.0) serves the run and stays + withHome [] $ \dir env -> withMockService todaysService $ \port -> do + _ <- forkIO $ Hold.runHolder (Hold.holdOpts (sockIn dir) 30) { Hold.hoVersion = "99.0.0" } `catchAll` const (pure ()) + waitFor (doesFileExist (sockIn dir)) + (code, out, _) <- runIn exe env [] port + (code, "MENGER-12" `isInfixOf` out) `shouldBe` (ExitSuccess, True) + versionIn dir `shouldReturn` Right "99.0.0" + holdersUnder dir `shouldReturn` [] + + -- RETURNS-36: a 3.x holder (protocol 2, holder-2.sock) is neither used nor + -- replaced by 4.0: the run holds on a socket of its own protocol, and the + -- 3.x holder is left as it was, for the 3.x runs + it "never reuses nor replaces a 3.x holder (protocol 2)" $ + withHome [] $ \dir env -> withMockService todaysService $ \port -> do + let old = dir "run" "synapse" "holder-2.sock" + _ <- forkIO $ Hold.runHolder (Hold.holdOpts old 30) { Hold.hoVersion = "3.17.4" } `catchAll` const (pure ()) + waitFor (doesFileExist old) + (code, out, _) <- runIn exe env [] port + (code, "MENGER-12" `isInfixOf` out) `shouldBe` (ExitSuccess, True) + let version = fmap (\st -> case st of { Object o | Just (String x) <- KM.lookup "version" o -> T.unpack x; _ -> "" }) + version <$> askStatus old `shouldReturn` Right "3.17.4" + fmap heldOf <$> askStatus old `shouldReturn` Right [] + doesFileExist (dir "run" "synapse" ("holder-" <> show Hold.holdProtocol <> ".sock")) `shouldReturn` True + + it "starts its holder in /, without the run's keepalive or secrets" $ + withHome [("PLEXUS_KEEPALIVE", "off"), ("SYNAPSE40_MARK", "kept")] $ \dir env -> withMockService todaysService $ \port -> do + (code, _, _) <- runIn exe env [] port + code `shouldBe` ExitSuccess + hs <- holdersUnder dir + case hs of + [h] -> do + environ <- map BS8.unpack . BS.split 0 <$> BS.readFile ("/proc" show h "environ") + getSymbolicLinkTarget ("/proc" show h "cwd") `shouldReturn` "/" + any ("PLEXUS_KEEPALIVE=" `isPrefixOf`) environ `shouldBe` False + ("SYNAPSE40_MARK=kept" `elem` environ) `shouldBe` True + other -> expectationFailure ("holders: " <> show other) + + it "keeps a live connection for about 100 kB (what its cap is set by)" $ do + n <- maybe 100 read <$> lookupEnv "SYNAPSE40_HELD" + withHome [("SYNAPSE_HOLD_MAX", "0"), ("SYNAPSE_HOLD_FOR", "600s")] $ \dir env -> withServices (n + 3) $ \ps -> do + let call p = runIn exe env [] p >>= \(code, _, _) -> code `shouldBe` ExitSuccess + (warm, rest) = splitAt 3 ps + mapM_ call warm + hs <- holdersUnder dir + case hs of + [h] -> do + r0 <- rssKb h + mapM_ call rest + r1 <- rssKb h + st <- holderStatusIn dir + fmap (length . heldOf) st `shouldBe` Right (n + 3) + let per = (r1 - r0) `div` n + putStrLn $ " " <> show (n + 3) <> " connections held: " <> show r0 <> " kB with 3, " + <> show r1 <> " kB with " <> show (n + 3) <> ": about " <> show per <> " kB each" + per `shouldSatisfy` (< 200) + other -> expectationFailure ("holders: " <> show other) + + it "runs a loop of calls against short-lived servers through one holder, which holds nothing 10 s on, its memory flat" $ do + n <- maybe 500 read <$> lookupEnv "SYNAPSE40_LOOP" + withHome [] $ \dir env -> do + seen <- newIORef [] + samples <- newIORef [] + t0 <- getMonotonicTime + forM_ [1 .. n :: Int] $ \i -> do + withEphemeralService todaysService $ \p -> do + (code, out, err) <- runIn exe env [] p + when (code /= ExitSuccess || not ("MENGER-12" `isInfixOf` out)) $ + expectationFailure ("call " <> show i <> ": " <> show code <> " " <> err) + hs <- holdersUnder dir + modifyIORef' seen (nub . (hs ++)) + when (i `mod` max 1 (n `div` 10) == 0) $ case hs of + [h] -> do + rss <- rssKb h + st <- holderStatusIn dir + modifyIORef' samples (++ [(i, rss, either (const (-1)) (length . heldOf) st)]) + _ -> pure () + t1 <- getMonotonicTime + pids <- readIORef seen + length pids `shouldBe` 1 + st <- waitStatus 10 (null . heldOf) dir + fmap heldOf st `shouldBe` Right [] + ss <- readIORef samples + putStrLn $ " " <> show n <> " calls against " <> show n <> " servers in " + <> show (round (t1 - t0) :: Int) <> " s; holder " <> show pids + <> "; (call, RSS kB, connections held): " <> show ss + case ss of + (_ : (_, early, _) : _) -> do + let (_, late, _) = last ss + -- flat: what it had grown to by a fifth of the way, within 4 MB, at the end + late `shouldSatisfy` (<= early + 4096) + _ -> pure () + -- never more held than the servers that stopped in its last second or so + maximum (0 : [ h | (_, _, h) <- ss ]) `shouldSatisfy` (<= 20) + +-- | SYNAPSE-40: a home, a cache and a runtime directory of the test's own, +-- and the environment a run is given there (no keychain, a holder that +-- waits 60 s unless told otherwise); every holder a run started there is +-- stopped by pid when the action ends. +withHome :: [(String, String)] -> (FilePath -> [(String, String)] -> IO a) -> IO a +withHome extra act = withSystemTempDirectory "synapse40" $ \dir -> do + forM_ ["home", "cache", "run"] $ \d -> createDirectoryIfMissing True (dir d) + env0 <- getEnvironment + let ours = ["HOME", "XDG_CACHE_HOME", "XDG_RUNTIME_DIR", "SYNAPSE_AS", "PLEXUS_SESSION" + , "SYNAPSE_NO_HOLD", "SYNAPSE_HOLD_FOR", "SYNAPSE_HOLD_MAX"] + env = [ (k, v) | (k, v) <- env0, k `notElem` ours ] + ++ [ ("HOME", dir "home"), ("XDG_CACHE_HOME", dir "cache"), ("XDG_RUNTIME_DIR", dir "run") + , ("PLEXUS_KEYCHAIN", "off") ] + ++ [ ("SYNAPSE_HOLD_FOR", "60s") | "SYNAPSE_HOLD_FOR" `notElem` map fst extra ] + ++ extra + act dir env `finally` stopHolders dir + +-- | One run of the built synapse: @tickets get@ at the service on the port. +runIn :: FilePath -> [(String, String)] -> [String] -> Int -> IO (ExitCode, String, String) +runIn exe env extra port = readCreateProcessWithExitCode + (proc exe (extra ++ ["--url", "ws://127.0.0.1:" <> show port <> "/ws", "menger", "tickets", "get", "--id", "MENGER-12"])) + { env = Just env } "" + +-- | Services on fresh ports, all up for the action. +withServices :: Int -> ([Int] -> IO a) -> IO a +withServices 0 act = act [] +withServices k act = withMockService todaysService $ \p -> withServices (k - 1) (act . (p :)) + +-- | The holder processes (pids) whose socket lies under the directory. +holdersUnder :: FilePath -> IO [Int] +holdersUnder dir = do + pids <- filter (all isDigit) <$> listDirectory "/proc" + fmap concat $ forM pids $ \p -> do + r <- try (BS.readFile ("/proc" p "cmdline")) + pure $ case r of + Left (_ :: SomeException) -> [] + Right bs -> + let args = map BS8.unpack (BS.split 0 bs) + in [ read p | "_hold" `elem` args, any (dir `isInfixOf`) args ] + +-- | Stop every holder under the directory, by pid: SIGTERM, then SIGKILL +-- for any still there 3 s on. +stopHolders :: FilePath -> IO () +stopHolders dir = do + ps <- holdersUnder dir + forM_ ps $ \p -> void (try (signalProcess sigTERM (fromIntegral p)) :: IO (Either SomeException ())) + let alive p = doesDirectoryExist ("/proc" show p) + wait (0 :: Int) = pure () + wait k = do + left <- filterM alive ps + if null left then pure () else threadDelay 50000 >> wait (k - 1) + wait 60 + left <- holdersUnder dir + forM_ left $ \p -> void (try (signalProcess sigKILL (fromIntegral p)) :: IO (Either SomeException ())) + +-- | A process's resident memory, in kB. +rssKb :: Int -> IO Int +rssKb pid = do + s <- BS8.unpack <$> BS.readFile ("/proc" show pid "status") + pure $ case [ read (words l !! 1) | l <- lines s, "VmRSS:" `isPrefixOf` l ] of + (kb : _) -> kb + [] -> 0 + +-- | What the holder under the directory says it holds: its one socket, +-- asked for its status. +holderStatusIn :: FilePath -> IO (Either String Value) +holderStatusIn dir = do + let sdir = dir "run" "synapse" + r <- try (listDirectory sdir) + case filter (".sock" `isSuffixOf`) (either (\(_ :: SomeException) -> []) id r) of + [one] -> askStatus (sdir one) + other -> pure (Left ("not one holder's socket: " <> show other)) + +-- | The holder's status: @{"status":true}@ sent, a line of JSON back, +-- @{"t":"status", "held": [{"host", "port", "agent", …}, …], …}@. +askStatus :: FilePath -> IO (Either String Value) +askStatus path = do + r <- try $ bracket (N.socket N.AF_UNIX N.Stream N.defaultProtocol) N.close $ \s -> do + N.connect s (N.SockAddrUnix path) + NB.sendAll s "{\"status\":true}\n" + let go acc = do + chunk <- NB.recv s 65536 + if BS.null chunk || BS8.elem '\n' chunk then pure (acc <> chunk) else go (acc <> chunk) + BS8.takeWhile (/= '\n') <$> go BS.empty + pure $ case r of + Left (e :: SomeException) -> Left (show e) + Right line -> case decodeStrict line of + Just v@(Object o) | KM.lookup "t" o == Just (String "status") -> Right v + _ -> Left ("not a status: " <> BS8.unpack line) + +-- | Ask until the status satisfies the test, or the seconds run out; the +-- last answer. +waitStatus :: Double -> (Value -> Bool) -> FilePath -> IO (Either String Value) +waitStatus secs ok dir = do + t0 <- getMonotonicTime + let go = do + st <- holderStatusIn dir + now <- getMonotonicTime + case st of + Right v | ok v -> pure st + _ | now - t0 >= secs -> pure st + | otherwise -> threadDelay 200000 >> go + go + +-- | The connections a status says are held: (port, agent) each. +heldOf :: Value -> [(Int, T.Text)] +heldOf (Object o) | Just (Array hs) <- KM.lookup "held" o = + [ (round n, a) | Object h <- V.toList hs + , Just (Number n) <- [KM.lookup "port" h], Just (String a) <- [KM.lookup "agent" h] ] +heldOf _ = [] + +-- | A holder in this process for the action: its socket, waiting the +-- seconds, keeping at most the cap (0: none). +withHolder :: Double -> Int -> (FilePath -> IO a) -> IO a +withHolder secs cap act = withSystemTempDirectory "hold" $ \dir -> do + let sock = dir "h.sock" + _ <- forkIO $ Hold.runHolder (Hold.holdOpts sock secs) { Hold.hoCap = cap } `catchAll` const (pure ()) + waitFor (doesFileExist sock) + act sock + +-- | BIDIR-18: one call with an input half on the route: once the port is +-- handed over, @feed@ sends its frames; the items and the signals, as they +-- came. +duplexCall :: (Maybe InputHalf -> IO () -> T.Text -> Value -> (PlexusStreamItem -> IO ()) -> IO ()) + -> T.Text -> (InputPort -> IO ()) -> IO ([PlexusStreamItem], [InputSignal]) +duplexCall route inner feed = do + items <- newIORef [] + sigs <- newIORef [] + let half = InputHalf + { ihPort = \p -> void (forkIO (threadDelay 50000 >> feed p)) + , ihSignal = \g -> modifyIORef' sigs (++ [g]) } + route (Just half) (pure ()) "menger.call" (Object (KM.fromList [("method", String inner)])) (\i -> modifyIORef' items (++ [i])) + (,) <$> readIORef items <*> readIORef sigs + +isTaken :: PlexusStreamItem -> Bool +isTaken (StreamData _ _ _ (Object o)) = KM.lookup "type" o == Just (String "taken") +isTaken _ = False + +-- | A holder in this process for one call. +withHolderOnce :: (FilePath -> IO a) -> IO a +withHolderOnce = withHolder 30 0 -- --------------------------------------------------------------------------- diff --git a/test/IR12MethodRoleSpec.hs b/test/IR12MethodRoleSpec.hs --- a/test/IR12MethodRoleSpec.hs +++ b/test/IR12MethodRoleSpec.hs @@ -33,7 +33,8 @@ import qualified Data.Map.Strict as Map import Synapse.IR.Builder (extractMethodDef) import Synapse.IR.Types - ( IR(..) + ( Cardinality(..) + , IR(..) , emptyIR , MethodDef(..) , TypeRef(..) @@ -46,9 +47,11 @@ , mdFullPath = "solar.planet" , mdNamespace = "solar" , mdDescription = Just "Fetch a planet child by name." - , mdStreaming = False , mdParams = [] , mdReturns = RefJson + , mdError = Nothing + , mdProgress = Nothing + , mdCardinality = CardinalityOne , mdBidirType = Nothing , mdBidirResponseType = Nothing , mdBidirResponseSchema = Nothing @@ -60,31 +63,34 @@ , mdInput = Nothing } --- | Build a JSON @MethodSchema@ with an optional @role@ key. Passing --- 'Nothing' produces the pre-IR shape (no @role@ key at all). +-- | Build a 0.7 JSON @MethodSchema@ with an optional @role@ key. Passing +-- 'Nothing' produces the pre-IR shape (no @role@ key at all). @returns@ +-- and @cardinality@ are required since plexus 0.7. methodSchemaJson :: Maybe Value -> Value methodSchemaJson mRole = let base = [ "name" .= ("planet" :: String) , "description" .= ("Fetch a planet child by name." :: String) , "hash" .= ("h-planet" :: String) + , "returns" .= object [] + , "cardinality" .= ("one" :: String) ] in object $ case mRole of Nothing -> base Just role -> ("role" .= role) : base --- | A hand-written pre-IR-12 MethodDef JSON blob: same field names as --- the generic derivation produces, minus @mdRole@. Exercising the --- back-compat path of synapse's manual @FromJSON MethodDef@ instance. +-- | A hand-written IR 3.0 MethodDef JSON blob without @mdRole@ (as +-- pre-IR-12 producers wrote it). Exercising the default of synapse's +-- manual @FromJSON MethodDef@ instance. preIrMethodDefJson :: Value preIrMethodDefJson = object [ "mdName" .= ("planet" :: String) , "mdFullPath" .= ("solar.planet" :: String) , "mdNamespace" .= ("solar" :: String) , "mdDescription" .= Aeson.Null - , "mdStreaming" .= False , "mdParams" .= ([] :: [Value]) , "mdReturns" .= object [ "tag" .= ("RefAny" :: String) ] + , "mdCardinality" .= ("one" :: String) ] main :: IO () @@ -184,10 +190,11 @@ [ "name" .= ("set_status" :: String) , "description" .= ("Change a ticket's status" :: String) , "hash" .= ("h" :: String) + , "returns" .= object [], "cardinality" .= ("one" :: String) ] <> extra lifted j = case Aeson.fromJSON j :: Aeson.Result MethodSchema of Aeson.Error e -> error e - Aeson.Success ms -> snd (extractMethodDef "tickets" "tickets" ms) + Aeson.Success ms -> either (error . show) snd (extractMethodDef "tickets" "tickets" ms) keysOf v = case v of Object o -> o _ -> KM.empty diff --git a/test/IR3Spec.hs b/test/IR3Spec.hs new file mode 100644 --- /dev/null +++ b/test/IR3Spec.hs @@ -0,0 +1,577 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +-- | IR 3.0 (RETURNS-13): a method's contract — item, error and progress +-- types and its cardinality — read from its plexus 0.7 schema, never +-- guessed; no two shapes under one title. +-- +-- * The golden test builds IR from RETURNS-7's conformance fixture +-- (@../plexus-macros/fixtures/conformance/expected/schema.json@, by +-- sibling path) with 'buildIRFromSchema' and compares it, byte for byte, +-- with the checked-in @expected/ir.json@ beside it. Run with +-- @SYNAPSE_GOLDEN_ACCEPT=1@ to (re)write that file instead. +-- * Then one test per row of RETURNS-13's Required behavior table. +-- * RETURNS-40: the IR of a whole service, built from every schema the +-- walk reads ('buildIRFromSchemas') — the fixture +-- @../plexus-macros/fixtures/ir-service/expected/@: @schemas.json@ in, +-- @ir.json@ (the service), @ir.alpha.json@ (its @alpha@ subtree) and +-- @clash.ir.json@ (a title collision refuses its activation) and +-- @clash.one.error.txt@ (the one-plugin entry still fails) out. The service writes +-- its own IR (@.ir@, plexus-core), held equal to these files. +-- @SYNAPSE_GOLDEN_ACCEPT=1@ rewrites them too. +module Main where + +import Control.Monad (forM_, unless) +import Data.Aeson (Value(..), eitherDecode, object, (.=)) +import qualified Data.Aeson as Aeson +import Data.Aeson.Encode.Pretty (Config(..), Indent(..), defConfig, encodePretty') +import qualified Data.Aeson.KeyMap as KM +import Data.Aeson.QQ.Simple (aesonQQ) +import qualified Data.ByteString.Lazy as LBS +import Data.List (isInfixOf) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import System.Environment (lookupEnv) +import System.FilePath (()) +import Test.Hspec + +import Plexus.Schema.Recursive (MethodSchema(..), PluginSchema(..)) +import Synapse.IR.Builder + ( IRBuildError(..) + , TypeSource(..) + , buildIRFromSchema + , buildIRFromSchemas + , renderIRBuildError + ) +import Synapse.IR.Types + +-- ============================================================================ +-- The fixture +-- ============================================================================ + +-- | The fixture's directory: by sibling path, or wherever +-- @CONFORMANCE_FIXTURE_DIR@ says (a copy, to check an ir.json before it +-- is committed beside the fixture). +fixtureDirIO :: IO FilePath +fixtureDirIO = maybe (".." "plexus-macros" "fixtures" "conformance" "expected") id + <$> lookupEnv "CONFORMANCE_FIXTURE_DIR" + +-- | The fixture's IR: the activation at path @conformance@ — what +-- @synapse -i conformance@ builds when a backend serves it there +-- (less 'irMetadata', the toolchain and the clock). +fixtureIR :: PluginSchema -> Either IRBuildError IR +fixtureIR = buildIRFromSchema "conformance" ["conformance"] + +-- | The bytes @ir.json@ holds: keys sorted, two-space indent, one trailing +-- newline. +renderIR :: IR -> LBS.ByteString +renderIR ir = encodePretty' defConfig { confIndent = Spaces 2, confCompare = compare } ir <> "\n" + +main :: IO () +main = do + fixtureDir <- fixtureDirIO + let schemaPath = fixtureDir "schema.json" + irPath = fixtureDir "ir.json" + schemaBytes <- LBS.readFile schemaPath + schema <- either (fail . ((schemaPath <> ": ") <>)) pure (eitherDecode schemaBytes) + ir <- either (fail . T.unpack . renderIRBuildError) pure (fixtureIR schema) + accept <- lookupEnv "SYNAPSE_GOLDEN_ACCEPT" + case accept of + Just "1" -> do + LBS.writeFile irPath (renderIR ir) + putStrLn $ "wrote " <> irPath + _ -> pure () + golden <- LBS.readFile irPath + service <- serviceGoldens (accept == Just "1") + hard <- hardGoldens (accept == Just "1") + hspec $ do + goldenSpec schemaPath irPath ir golden + tableSpec ir + service + hard + +-- | RETURNS-40's review: the reviewer's hard shapes (generics, recursion, +-- every serde enum form, a dotted $defs name, flattening, every number's +-- default, one title with two docs in two namespaces), served by +-- plexus-core's tests/ir_serving.rs and kept beside it +-- (@../plexus-core/tests/fixtures/ir-hard/@, or @IR_HARD_FIXTURE_DIR@): +-- @schemas.json@ in; @ir.json@, @ir.alpha.json@ and @ir.beta-inner.json@ +-- out — the IR plexus-core's service writes is held to them. +hardGoldens :: Bool -> IO Spec +hardGoldens acceptIt = do + dir <- maybe (".." "plexus-core" "tests" "fixtures" "ir-hard") id <$> lookupEnv "IR_HARD_FIXTURE_DIR" + schemas <- readSchemas (dir "schemas.json") + let builds = + [ ("ir.json", buildIRFromSchemas "xsvc" [[]] schemas) + , ("ir.alpha.json", buildIRFromSchemas "xsvc" [["alpha"]] schemas) + , ("ir.beta-inner.json", buildIRFromSchemas "xsvc" [["beta"], ["alpha", "inner"]] schemas) + ] + irs <- traverse (\(file, built) -> (,) file <$> either (fail . T.unpack . renderIRBuildError) pure built) builds + if acceptIt then mapM_ (\(file, ir) -> LBS.writeFile (dir file) (renderIR ir) >> putStrLn ("wrote " <> dir file)) irs else pure () + goldens <- traverse (\(file, ir) -> (\g -> (file, ir, g)) <$> LBS.readFile (dir file)) irs + pure $ describe "golden: the reviewer's hard shapes (RETURNS-40)" $ + forM_ goldens $ \(file, ir, g) -> do + it (file <> " byte for byte") $ + unless (renderIR ir == g) $ expectationFailure ("IR built from " <> dir "schemas.json differs from " <> file) + it (file <> ": no RefNamed dangles") $ + danglingRefs ir `shouldBe` [] + +-- ============================================================================ +-- RETURNS-40: a whole service's IR +-- ============================================================================ + +-- | The service fixture's directory: by sibling path, or wherever +-- @IR_SERVICE_FIXTURE_DIR@ says. +serviceDirIO :: IO FilePath +serviceDirIO = maybe (".." "plexus-macros" "fixtures" "ir-service" "expected") id + <$> lookupEnv "IR_SERVICE_FIXTURE_DIR" + +-- | Schemas by dotted path (@""@ the root), as the fixture keeps them. +readSchemas :: FilePath -> IO (Map.Map [Text] PluginSchema) +readSchemas path = do + bytes <- LBS.readFile path + byName <- either (fail . ((path <> ": ") <>)) pure (eitherDecode bytes) :: IO (Map.Map Text PluginSchema) + pure (Map.mapKeys (\k -> if T.null k then [] else T.splitOn "." k) byName) + +-- | Each golden of the service fixture: built, written when accepting, and +-- compared byte for byte. +serviceGoldens :: Bool -> IO Spec +serviceGoldens acceptIt = do + dir <- serviceDirIO + schemas <- readSchemas (dir "schemas.json") + clash <- readSchemas (dir "clash.schemas.json") + let builds = + [ ("ir.json", "the whole service", buildIRFromSchemas "irsvc" [[]] schemas) + , ("ir.alpha.json", "its alpha subtree", buildIRFromSchemas "irsvc" [["alpha"]] schemas) + , ("clash.ir.json", "the clash service", buildIRFromSchemas "clashsvc" [[]] clash) + ] + -- RETURNS-36 review #9: the walk refuses the colliding activation and + -- goes on; the one-plugin entry still fails + clashOne = case Map.lookup ["clash"] clash of + Just s -> either (\e -> LBS.fromStrict (TE.encodeUtf8 (renderIRBuildError e)) <> "\n") (const "built") (buildIRFromSchema "clashsvc" ["clash"] s) + Nothing -> "no clash schema" + irs <- traverse (\(file, what, built) -> do + ir <- either (fail . T.unpack . renderIRBuildError) pure built + pure (file, what, ir)) builds + if acceptIt + then do + mapM_ (\(file, _, ir) -> LBS.writeFile (dir file) (renderIR ir) >> putStrLn ("wrote " <> dir file)) irs + LBS.writeFile (dir "clash.one.error.txt") clashOne + else pure () + goldens <- traverse (\(file, what, ir) -> (\g -> (file, what, ir, g)) <$> LBS.readFile (dir file)) irs + clashGolden <- LBS.readFile (dir "clash.one.error.txt") + pure $ describe "golden: the ir-service fixture's IR (RETURNS-40)" $ do + forM_ goldens $ \(file, what, ir, g) -> do + it (what <> " equals " <> file <> " byte for byte") $ + unless (renderIR ir == g) $ expectationFailure $ + "IR built from " <> dir "schemas.json" <> " differs from " <> file + <> " (regenerate with SYNAPSE_GOLDEN_ACCEPT=1 and read the diff)" + -- (Not "decodes back to the same IR": the root's call.params has + -- "default": null, which the IR writes as pdDefault null — the same + -- null an absent default writes — and reads back as no default.) + it (what <> ": " <> file <> " decodes") $ + (eitherDecode g :: Either String IR) `shouldSatisfy` either (const False) (const True) + it (what <> ": no RefNamed dangles") $ + danglingRefs ir `shouldBe` [] + it "the whole service carries the reader's refusals" $ + case [ ir | (f, _, ir, _) <- goldens, f == "ir.json" ] of + (ir : _) -> null (irRefusals ir) `shouldBe` False + [] -> expectationFailure "no ir.json" + it "the clash service's walk refuses clash (keyword title, both sites named) and builds the rest" $ + case [ ir | (f, _, ir, _) <- goldens, f == "clash.ir.json" ] of + (ir : _) -> do + [ rfSite r | r <- irRefusals ir, rfKeyword r == "title" ] `shouldBe` ["clash"] + [ m | m <- Map.keys (irMethods ir), "clash." `T.isPrefixOf` m ] `shouldBe` [] + Map.member "" (irPlugins ir) `shouldBe` True + [] -> expectationFailure "no clash.ir.json" + it "the clash plugin alone (buildIRFromSchema) still fails, as clash.one.error.txt says" $ + clashOne `shouldBe` clashGolden + +-- ============================================================================ +-- Golden +-- ============================================================================ + +goldenSpec :: FilePath -> FilePath -> IR -> LBS.ByteString -> Spec +goldenSpec schemaPath irPath ir golden = describe "golden: the conformance fixture's IR" $ do + it "equals expected/ir.json byte for byte" $ + unless (renderIR ir == golden) $ expectationFailure $ + "IR built from " <> schemaPath <> " differs from " <> irPath + <> " (regenerate with SYNAPSE_GOLDEN_ACCEPT=1 and read the diff)" + + it "expected/ir.json decodes back to the same IR" $ + eitherDecode golden `shouldBe` Right ir + + it "is IR 3.0" $ + irVersion ir `shouldBe` "3.0" + + it "has every method of the schema, keyed by full path" $ + Map.keys (irMethods ir) `shouldBe` + [ "conformance.count", "conformance.load", "conformance.lookup", "conformance.ping" + , "conformance.scan", "conformance.schema", "conformance.warm" ] + + it "carries the schema's own hash for the plugin" $ do + -- the fixture's hash moves with every change to the fixture (RETURNS-10); + -- read it from schema.json rather than pin one + schema <- either fail pure . eitherDecode =<< LBS.readFile schemaPath + fmap phiHash (Map.lookup "conformance" =<< irPluginHashes ir) `shouldBe` Just (psHash schema) + + it "no MethodDef carries mdStreaming" $ + forM_ (Map.elems (irMethods ir)) $ \md -> case Aeson.toJSON md of + Object o -> KM.member "mdStreaming" o `shouldBe` False + other -> expectationFailure ("not an object: " <> show other) + + it "no RefNamed dangles" $ + danglingRefs ir `shouldBe` [] + + it "reports synapse's own version" $ + synapseVersion `shouldBe` "4.0.0" + +-- ============================================================================ +-- The Required behavior table, one row at a time +-- ============================================================================ + +tableSpec :: IR -> Spec +tableSpec fixture = describe "IR 3.0 Required behavior" $ do + + describe "cardinality: one / many → mdCardinality, never inferred" $ do + it "reads the fixture's cardinalities as they are" $ do + let card m = mdCardinality <$> Map.lookup ("conformance." <> m) (irMethods fixture) + map card ["ping", "lookup", "schema"] `shouldBe` replicate 3 (Just CardinalityOne) + map card ["count", "scan", "load", "warm"] `shouldBe` replicate 4 (Just CardinalityMany) + + it "a many-variant item type of a one method stays one (no variant counting)" $ do + md <- single [aesonQQ|{ + "name": "status", "description": "", "hash": "h", + "returns": { "title": "Status", "oneOf": [ + { "type": "object", "properties": { "type": { "type": "string", "const": "a" } }, "required": ["type"] }, + { "type": "object", "properties": { "type": { "type": "string", "const": "b" } }, "required": ["type"] }, + { "type": "object", "properties": { "type": { "type": "string", "const": "c" } }, "required": ["type"] } ] }, + "cardinality": "one" }|] + mdCardinality md `shouldBe` CardinalityOne + + it "a struct item type of a many method stays many" $ do + md <- single (withReturns "many" pongSchema) + mdCardinality md `shouldBe` CardinalityMany + + describe "returns (any schema form) → a RefNamed with a TypeDef, or a primitive / array / optional ref" $ do + it "a struct: the fixture's ping returns conformance.Pong, a struct" $ do + fmap mdReturns (Map.lookup "conformance.ping" (irMethods fixture)) + `shouldBe` Just (named "conformance" "Pong") + kindOf fixture "conformance.Pong" `shouldBe` Just (KindStruct + [ FieldDef "message" (RefPrimitive "string" Nothing) Nothing True Nothing ]) + + it "a tagged enum" $ do + ir <- build [withReturns "one" [aesonQQ|{ "title": "Shape", "oneOf": [ + { "type": "object", "properties": { "r": { "type": "number" }, "type": { "type": "string", "const": "circle" } }, "required": ["type", "r"] }, + { "type": "object", "properties": { "type": { "type": "string", "const": "dot" } }, "required": ["type"] } ] }|]] + returnsOf ir `shouldBe` named "t" "Shape" + kindOf ir "t.Shape" `shouldBe` Just (taggedEnum "type" + [ variant "circle" Nothing [FieldDef "r" (RefPrimitive "number" Nothing) Nothing True Nothing] + , variant "dot" Nothing [] ]) + + it "a string enum" $ do + ir <- build [withReturns "one" [aesonQQ|{ "title": "Level", "type": "string", "enum": ["low", "high"] }|]] + returnsOf ir `shouldBe` named "t" "Level" + kindOf ir "t.Level" `shouldBe` Just (KindStringEnum ["low", "high"]) + + it "a string enum written as consts" $ do + ir <- build [withReturns "one" [aesonQQ|{ "title": "Level", "oneOf": [ + { "type": "string", "const": "low", "description": "Low." }, + { "type": "string", "const": "high", "description": "High." } ] }|]] + kindOf ir "t.Level" `shouldBe` Just (KindStringEnum ["low", "high"]) + + it "an alias: a titled $ref" $ do + ir <- build [withReturns "one" [aesonQQ|{ "title": "Wrapper", "$ref": "#/$defs/Pong", + "$defs": { "Pong": { "type": "object", "properties": { "message": { "type": "string" } }, "required": ["message"] } } }|]] + returnsOf ir `shouldBe` named "t" "Wrapper" + kindOf ir "t.Wrapper" `shouldBe` Just (KindAlias (named "t" "Pong")) + fmap isStruct (kindOf ir "t.Pong") `shouldBe` Just True + + it "a primitive, whatever schemars titles it" $ do + ir <- build [ withReturns "one" [aesonQQ|{ "title": "String", "type": "string" }|] + , withReturnsNamed "n" "one" [aesonQQ|{ "title": "uint32", "type": "integer", "format": "uint32", "minimum": 0 }|] ] + returnsOf ir `shouldBe` RefPrimitive "string" Nothing + fmap mdReturns (Map.lookup "t.n" (irMethods ir)) `shouldBe` Just (RefPrimitive "integer" (Just "uint32")) + Map.keys (irTypes ir) `shouldBe` [] + + it "an array of a named type" $ do + ir <- build [withReturns "one" [aesonQQ|{ "title": "Array_of_Pong", "type": "array", "items": { "$ref": "#/$defs/Pong" }, + "$defs": { "Pong": { "type": "object", "properties": { "message": { "type": "string" } }, "required": ["message"] } } }|]] + returnsOf ir `shouldBe` RefArray (named "t" "Pong") + fmap isStruct (kindOf ir "t.Pong") `shouldBe` Just True + + it "an optional named type" $ do + ir <- build [withReturns "one" [aesonQQ|{ "title": "Nullable_Pong", "anyOf": [ { "$ref": "#/$defs/Pong" }, { "type": "null" } ], + "$defs": { "Pong": { "type": "object", "properties": { "message": { "type": "string" } }, "required": ["message"] } } }|]] + returnsOf ir `shouldBe` RefOptional (named "t" "Pong") + fmap isStruct (kindOf ir "t.Pong") `shouldBe` Just True + + it "any value ({}): the JSON type (IR 2.1's RefJson)" $ do + ir <- build [withReturns "one" [aesonQQ|{}|]] + returnsOf ir `shouldBe` RefJson + Map.keys (irTypes ir) `shouldBe` [] + + it "the fixture's schema method: SchemaResult, an untagged union of its members (IR 2.1's untagged form); its members are TypeDefs" $ do + fmap mdReturns (Map.lookup "conformance.schema" (irMethods fixture)) + `shouldBe` Just (named "conformance" "SchemaResult") + kindOf fixture "conformance.SchemaResult" `shouldBe` Just (untaggedEnum + [ ("PluginSchema", named "conformance" "PluginSchema"), ("MethodSchema", named "conformance" "MethodSchema") ]) + fmap isStruct (kindOf fixture "conformance.PluginSchema") `shouldBe` Just True + fmap isStruct (kindOf fixture "conformance.MethodSchema") `shouldBe` Just True + + it "an untagged union is IR 2.1's untagged enum, each variant its type, never a partial enum" $ do + ir <- build [withReturns "one" [aesonQQ|{ "title": "Either", "anyOf": [ { "$ref": "#/$defs/A" }, { "$ref": "#/$defs/B" } ], + "$defs": { "A": { "type": "object", "properties": { "a": { "type": "string" } }, "required": ["a"] }, + "B": { "type": "object", "properties": { "b": { "type": "string" } }, "required": ["b"] } } }|]] + returnsOf ir `shouldBe` named "t" "Either" + kindOf ir "t.Either" `shouldBe` Just (untaggedEnum [("A", named "t" "A"), ("B", named "t" "B")]) + danglingRefs ir `shouldBe` [] + + describe "error present → mdError = Just ref with TypeDef; absent → Nothing" $ do + it "lookup's error is conformance.LookupError, a tagged enum" $ do + fmap mdError (Map.lookup "conformance.lookup" (irMethods fixture)) + `shouldBe` Just (Just (named "conformance" "LookupError")) + kindOf fixture "conformance.LookupError" `shouldBe` Just (taggedEnum "type" + [ variant "not_found" Nothing [FieldDef "id" (RefPrimitive "string" Nothing) Nothing True Nothing] ]) + + it "scan's and load's errors have TypeDefs" $ do + fmap mdError (Map.lookup "conformance.scan" (irMethods fixture)) `shouldBe` Just (Just (named "conformance" "ScanError")) + fmap mdError (Map.lookup "conformance.load" (irMethods fixture)) `shouldBe` Just (Just (named "conformance" "LoadError")) + Map.member "conformance.ScanError" (irTypes fixture) `shouldBe` True + Map.member "conformance.LoadError" (irTypes fixture) `shouldBe` True + + it "an infallible method has none" $ + forM_ ["ping", "count", "warm", "schema"] $ \m -> + fmap mdError (Map.lookup ("conformance." <> m) (irMethods fixture)) `shouldBe` Just Nothing + + describe "progress present → mdProgress = Just ref with TypeDef; absent → Nothing" $ do + it "load's progress is conformance.LoadStep, a tagged enum" $ do + fmap mdProgress (Map.lookup "conformance.load" (irMethods fixture)) + `shouldBe` Just (Just (named "conformance" "LoadStep")) + kindOf fixture "conformance.LoadStep" `shouldBe` Just (taggedEnum "type" + [ variant "batch" Nothing + [ FieldDef "done" (RefPrimitive "integer" (Just "uint32")) Nothing True Nothing + , FieldDef "of" (RefPrimitive "integer" (Just "uint32")) Nothing True Nothing ] ]) + + it "warm's progress is conformance.Note, the default" $ do + fmap mdProgress (Map.lookup "conformance.warm" (irMethods fixture)) + `shouldBe` Just (Just (named "conformance" "Note")) + fmap isStruct (kindOf fixture "conformance.Note") `shouldBe` Just True + + it "a method that reports no progress has none" $ + forM_ ["ping", "lookup", "count", "scan", "schema"] $ \m -> + fmap mdProgress (Map.lookup ("conformance." <> m) (irMethods fixture)) `shouldBe` Just Nothing + + describe "tagged enum with any tag name → keDiscriminator = the property whose const every variant carries" $ do + it "plexus-core's MethodRole (in the fixture's SchemaResult) is tagged by kind" $ + kindOf fixture "conformance.MethodRole" `shouldBe` Just (taggedEnum "kind" + [ variant "rpc" Nothing [] + , variant "static_child" Nothing [] + , variant "dynamic_child" Nothing + [ FieldDef "list_method" (RefOptional (RefPrimitive "string" Nothing)) Nothing False Nothing + , FieldDef "search_method" (RefOptional (RefPrimitive "string" Nothing)) Nothing False Nothing ] ]) + + it "a tag called kind" $ do + ir <- build [withReturns "one" [aesonQQ|{ "title": "Event", "oneOf": [ + { "type": "object", "properties": { "kind": { "type": "string", "const": "created" }, "id": { "type": "string" } }, "required": ["kind", "id"] }, + { "type": "object", "properties": { "kind": { "type": "string", "const": "deleted" } }, "required": ["kind"] } ] }|]] + kindOf ir "t.Event" `shouldBe` Just (taggedEnum "kind" + [ variant "created" Nothing [FieldDef "id" (RefPrimitive "string" Nothing) Nothing True Nothing] + , variant "deleted" Nothing [] ]) + + it "an adjacently tagged enum: the tag, with its content a field" $ do + ir <- build [withReturns "one" [aesonQQ|{ "title": "Msg", "oneOf": [ + { "type": "object", "properties": { "t": { "type": "string", "const": "text" }, "c": { "type": "string" } }, "required": ["t", "c"] }, + { "type": "object", "properties": { "t": { "type": "string", "const": "count" }, "c": { "type": "integer" } }, "required": ["t", "c"] } ] }|]] + kindOf ir "t.Msg" `shouldBe` Just (taggedEnum "t" + [ variant "text" Nothing [FieldDef "c" (RefPrimitive "string" Nothing) Nothing True Nothing] + , variant "count" Nothing [FieldDef "c" (RefPrimitive "integer" Nothing) Nothing True Nothing] ]) + + it "variants by $ref" $ do + ir <- build [withReturns "one" [aesonQQ|{ "title": "Event", "oneOf": [ { "$ref": "#/$defs/Up" }, { "$ref": "#/$defs/Down" } ], + "$defs": { + "Up": { "type": "object", "properties": { "op": { "type": "string", "const": "up" }, "by": { "type": "integer" } }, "required": ["op", "by"] }, + "Down": { "type": "object", "properties": { "op": { "type": "string", "const": "down" } }, "required": ["op"] } } }|]] + kindOf ir "t.Event" `shouldBe` Just (taggedEnum "op" + [ variant "up" Nothing [FieldDef "by" (RefPrimitive "integer" Nothing) Nothing True Nothing] + , variant "down" Nothing [] ]) + + describe "newtype variant over a struct → variant fields = the struct's fields (from $defs)" $ do + it "the 2020-12 form: $ref beside the tag" $ do + ir <- build [withReturns "one" [aesonQQ|{ "title": "Event", "oneOf": [ + { "type": "object", "properties": { "type": { "type": "string", "const": "moved" } }, "$ref": "#/$defs/Move", "required": ["type"] }, + { "type": "object", "properties": { "type": { "type": "string", "const": "stopped" } }, "required": ["type"] } ], + "$defs": { "Move": { "type": "object", "properties": { "x": { "type": "integer" }, "note": { "type": ["string", "null"] } }, "required": ["x"] } } }|]] + kindOf ir "t.Event" `shouldBe` Just (taggedEnum "type" + [ variant "moved" Nothing + [ FieldDef "note" (RefOptional (RefPrimitive "string" Nothing)) Nothing False Nothing + , FieldDef "x" (RefPrimitive "integer" Nothing) Nothing True Nothing ] + , variant "stopped" Nothing [] ]) + + it "the allOf form" $ do + ir <- build [withReturns "one" [aesonQQ|{ "title": "Event", "oneOf": [ + { "type": "object", "properties": { "type": { "type": "string", "const": "moved" } }, "allOf": [ { "$ref": "#/$defs/Move" } ], "required": ["type"] } ], + "$defs": { "Move": { "type": "object", "properties": { "x": { "type": "integer" } }, "required": ["x"] } } }|]] + kindOf ir "t.Event" `shouldBe` Just (taggedEnum "type" + [ variant "moved" Nothing [FieldDef "x" (RefPrimitive "integer" Nothing) Nothing True Nothing] ]) + + it "a newtype variant over something with no fields is not a silent partial enum: the site is refused (IR 2.1)" $ do + ir <- build [withReturns "one" [aesonQQ|{ "title": "Event", "oneOf": [ + { "type": "object", "properties": { "type": { "type": "string", "const": "named" } }, "$ref": "#/$defs/Name", "required": ["type"] } ], + "$defs": { "Name": { "type": "string" } } }|]] + map rfSite (irRefusals ir) `shouldBe` ["t.Event.named"] + + describe "field not in required → fdRequired = False" $ do + it "in a struct: Note's percentage" $ + kindOf fixture "conformance.Note" `shouldBe` Just (KindStruct + [ FieldDef "message" (RefPrimitive "string" Nothing) (Just "What is happening, for a human.") True Nothing + , FieldDef "percentage" (RefOptional (RefPrimitive "number" (Just "float"))) + (Just "Completion, `0.0`–`100.0`, when the method can say.") False Nothing ]) + + it "in a variant" $ do + ir <- build [withReturns "one" [aesonQQ|{ "title": "Event", "oneOf": [ + { "type": "object", "properties": { "type": { "type": "string", "const": "seen" }, "at": { "type": "integer" }, "by": { "type": "string" } }, "required": ["type", "at"] } ] }|]] + kindOf ir "t.Event" `shouldBe` Just (taggedEnum "type" + [ variant "seen" Nothing + [ FieldDef "at" (RefPrimitive "integer" Nothing) Nothing True Nothing + , FieldDef "by" (RefPrimitive "string" Nothing) Nothing False Nothing ] ]) + + describe "same title, same shape, two methods → one TypeDef" $ do + it "two methods returning Pong, one of them through $defs" $ do + ir <- build + [ withReturnsNamed "a" "one" pongSchema + , withReturnsNamed "b" "many" [aesonQQ|{ "title": "Array_of_Pong", "type": "array", "items": { "$ref": "#/$defs/Pong" }, + "$defs": { "Pong": { "description": "What ping answers.", "type": "object", "properties": { "message": { "type": "string" } }, "required": ["message"] } } }|] ] + Map.keys (irTypes ir) `shouldBe` ["t.Pong"] + fmap mdReturns (Map.lookup "t.a" (irMethods ir)) `shouldBe` Just (named "t" "Pong") + fmap mdReturns (Map.lookup "t.b" (irMethods ir)) `shouldBe` Just (RefArray (named "t" "Pong")) + + describe "same title, different shapes, one namespace → build fails naming the two methods and the title" $ do + it "fails" $ do + let result = buildIn "t" + [ withReturnsNamed "first" "one" pongSchema + , withReturnsNamed "second" "one" [aesonQQ|{ "title": "Pong", "type": "object", "properties": { "reply": { "type": "integer" } }, "required": ["reply"] }|] ] + result `shouldBe` Left TitleCollision + { tcNamespace = "t" + , tcTitle = "Pong" + , tcFirst = TypeSource "first" "returns" + , tcSecond = TypeSource "second" "returns" } + case result of + Left err -> do + let msg = T.unpack (renderIRBuildError err) + msg `shouldSatisfy` isInfixOf "\"Pong\"" + msg `shouldSatisfy` isInfixOf "method first (returns)" + msg `shouldSatisfy` isInfixOf "method second (returns)" + Right _ -> pure () + + it "fails across a method's error and another's params $defs" $ do + let result = buildIn "t" + [ [aesonQQ|{ "name": "put", "description": "", "hash": "h", "cardinality": "one", "returns": {}, + "params": { "type": "object", "properties": { "why": { "$ref": "#/$defs/Why" } }, "required": ["why"], + "$defs": { "Why": { "type": "string", "enum": ["a", "b"] } } } }|] + , [aesonQQ|{ "name": "get", "description": "", "hash": "h", "cardinality": "one", "returns": {}, + "error": { "title": "Why", "type": "string", "enum": ["c"] } }|] ] + result `shouldBe` Left TitleCollision + { tcNamespace = "t" + , tcTitle = "Why" + , tcFirst = TypeSource "put" "params" + , tcSecond = TypeSource "get" "error" } + + it "the same title in two namespaces is two types" $ do + a <- either (fail . T.unpack . renderIRBuildError) pure (buildIn "a" [withReturns "one" pongSchema]) + b <- either (fail . T.unpack . renderIRBuildError) pure + (buildIn "b" [withReturns "one" [aesonQQ|{ "title": "Pong", "type": "object", "properties": { "reply": { "type": "integer" } }, "required": ["reply"] }|]]) + Map.keys (irTypes (mergeIR a b)) `shouldBe` ["a.Pong", "b.Pong"] + +-- ============================================================================ +-- Helpers +-- ============================================================================ + +pongSchema :: Value +pongSchema = [aesonQQ|{ "$schema": "https://json-schema.org/draft/2020-12/schema", "title": "Pong", "description": "What ping answers.", + "type": "object", "properties": { "message": { "type": "string" } }, "required": ["message"] }|] + +-- | A method @m@ with this cardinality and @returns@. +withReturns :: Text -> Value -> Value +withReturns = withReturnsNamed "m" + +withReturnsNamed :: Text -> Text -> Value -> Value +withReturnsNamed name card returns = object + [ "name" .= name, "description" .= ("" :: Text), "hash" .= ("h" :: Text) + , "returns" .= returns, "cardinality" .= card ] + +-- | A plugin in namespace @ns@ holding these 0.7 method schemas, as IR. +buildIn :: Text -> [Value] -> Either IRBuildError IR +buildIn ns methods = case traverse Aeson.fromJSON methods of + Aeson.Error e -> error ("bad MethodSchema: " <> e) + Aeson.Success ms -> buildIRFromSchema "test" [ns] PluginSchema + { psNamespace = ns, psVersion = "1", psDescription = "", psLongDescription = Nothing + , psSelfHash = Nothing, psHash = "h", psMethods = ms, psChildren = Nothing + , psDeprecation = Nothing, psRequest = Nothing, psRoles = Nothing, psView = Nothing } + +build :: [Value] -> IO IR +build = either (fail . T.unpack . renderIRBuildError) pure . buildIn "t" + +single :: Value -> IO MethodDef +single m = do + ir <- build [m] + case Map.elems (irMethods ir) of + [md] -> pure md + mds -> fail ("expected one method, got " <> show (length mds)) + +returnsOf :: IR -> TypeRef +returnsOf ir = maybe RefUnknown mdReturns (Map.lookup "t.m" (irMethods ir)) + +named :: Text -> Text -> TypeRef +named ns n = RefNamed (QualifiedName ns n) + +-- | An internally tagged enum's kind (IR 2.1's 'KindEnum' carries its +-- representation; a tagged variant has no 'vdRef'). +taggedEnum :: Text -> [VariantDef] -> TypeKind +taggedEnum tag vs = KindEnum tag vs Internal + +-- | A tagged variant: its name, description and fields. +variant :: Text -> Maybe Text -> [FieldDef] -> VariantDef +variant name desc fields = VariantDef name desc fields Nothing + +-- | IR 2.1's untagged union: each variant named by its type, its 'vdRef'. +untaggedEnum :: [(Text, TypeRef)] -> TypeKind +untaggedEnum vs = KindEnum "" [ VariantDef n Nothing [] (Just t) | (n, t) <- vs ] Untagged + +-- | A type's kind, descriptions aside (of its fields and variants too). +kindOf :: IR -> Text -> Maybe TypeKind +kindOf ir name = undocumented . tdKind <$> Map.lookup name (irTypes ir) + where + undocumented = \case + KindStruct fs -> KindStruct (map field fs) + KindEnum d vs r -> KindEnum d [ v { vdDescription = Nothing, vdFields = map field (vdFields v) } | v <- vs ] r + k -> k + field f + | name == "conformance.Note" = f -- this row checks the field docs too + | otherwise = f { fdDescription = Nothing } + +isStruct :: TypeKind -> Bool +isStruct KindStruct{} = True +isStruct _ = False + +-- | Every RefNamed in the IR's methods and types with no TypeDef. +danglingRefs :: IR -> [Text] +danglingRefs ir = + [ n | r <- concatMap methodRefs (Map.elems (irMethods ir)) ++ concatMap typeRefs (Map.elems (irTypes ir)) + , n <- names r, not (Map.member n (irTypes ir)) ] + where + methodRefs md = mdReturns md : maybe [] pure (mdError md) ++ maybe [] pure (mdProgress md) ++ map pdType (mdParams md) + typeRefs td = case tdKind td of + KindStruct fs -> map fdType fs + KindEnum _ vs _ -> map fdType (concatMap vdFields vs) ++ [ t | Just t <- map vdRef vs ] + KindAlias t -> [t] + _ -> [] + -- as irTypes keys a type: the root's are ".Name" (qualifiedNameFull + -- would say "Name") + names = \case + RefNamed qn -> [qnNamespace qn <> "." <> qnLocalName qn] + RefArray t -> names t + RefOptional t -> names t + _ -> [] diff --git a/test/IRCoverageSpec.hs b/test/IRCoverageSpec.hs --- a/test/IRCoverageSpec.hs +++ b/test/IRCoverageSpec.hs @@ -13,13 +13,13 @@ import Control.Monad (forM_, unless, when) import qualified Codec.Compression.GZip as GZ -import Data.Aeson (Value(..), eitherDecode, encode, toJSON) +import Data.Aeson (Value(..), eitherDecode, encode, toJSON, (.=)) import qualified Data.Aeson as Aeson import Data.Aeson.Encode.Pretty (Config(..), defConfig, encodePretty') import qualified Data.Aeson.Key as K import qualified Data.Aeson.KeyMap as KM import qualified Data.ByteString.Lazy.Char8 as BL -import Data.IORef (writeIORef) +import Data.IORef (readIORef, writeIORef) import Data.List (isInfixOf, sort) import qualified Data.Map.Strict as Map import Data.Maybe (isJust) @@ -27,7 +27,7 @@ import Data.Text (Text) import qualified Data.Text as T import System.Directory (createDirectoryIfMissing, doesFileExist, findExecutable) -import System.Environment (getEnvironment, lookupEnv) +import System.Environment (getEnvironment, lookupEnv, setEnv, unsetEnv) import System.Exit (ExitCode(..)) import System.FilePath (()) import System.IO.Temp (withSystemTempDirectory) @@ -35,10 +35,13 @@ import Test.Hspec import Synapse.IR.Types -import Synapse.SchemaStore (Plan(..), Store(..), readPlan, writePlan) +import Synapse.SchemaStore (Plan(..), Store(..), readPlan, schemasRoot, storeFor, writePlan) +import Synapse.Endpoint (plainAt) import Plexus.Schema.Recursive (MethodSchema(..)) import IRFixture +import Plexus07 (methodAs07, withContract) +import Synapse.IR.Builder (IRBuildError(..), TypeSource(..), buildIRFromSchema) import MockService main :: IO () @@ -110,10 +113,18 @@ mdReturns <$> method ir "tickets.inputs" `shouldBe` Just (RefChild "tickets.inputs") irRefusals ir `shouldBe` [] - it "an rpc method with no returns is refused" $ do - ir <- irOf "no-returns.json" ["x"] - irRefusals ir `shouldBe` [Refusal "x.schema returns" "returns" Nothing "an rpc method with no returns schema"] - mdReturns <$> method ir "x.schema" `shouldBe` Just RefUnknown + -- RETURNS-36: plexus 0.7 requires returns, so such a method is no 0.7 + -- schema at all: refused by plexus-protocol before the builder sees it + it "an rpc method with no returns is no 0.7 schema: it does not parse" $ do + Right rows <- eitherDecode <$> BL.readFile (fixtures "no-returns.json") :: IO (Either String [Value]) + let methodsOf = \case + Object r | Just (Object sch) <- KM.lookup "schema" r, Just (Array ms) <- KM.lookup "methods" sch -> foldr (:) [] ms + _ -> [] + ms = map methodAs07 (concatMap methodsOf rows) + ms `shouldNotBe` [] + forM_ ms $ \m -> case Aeson.fromJSON m :: Aeson.Result MethodSchema of + Aeson.Error e -> e `shouldContain` "returns" + Aeson.Success _ -> expectationFailure "a method with no returns parsed" it "a struct root is a type, and no RefNamed dangles" $ do ir <- irOf "hashes.json" ["tickets"] @@ -130,6 +141,16 @@ , InjectedParam "user" (obj [("from", "auth"), ("resolver", "self.access.verify")]) Nothing ] irRefusals ir `shouldBe` [] + it "mdInput: an Input item is a string of format binary, refused nowhere (BIDIR-18/19)" $ do + ir <- irOf "input.json" ["tickets"] + irRefusals ir `shouldBe` [] + mdInput <$> method ir "tickets.audio" `shouldBe` Just (Just (RefPrimitive "string" (Just "binary"))) + let Just audio = method ir "tickets.audio" + encode (mdInput audio) `shouldBe` "{\"contents\":[\"string\",\"binary\"],\"tag\":\"RefPrimitive\"}" + -- the bench server's ingest.items: its titled object a named type + mdInput <$> method ir "tickets.items" `shouldBe` Just (Just (named "tickets" "Item")) + kindOf ir "tickets.Item" `shouldSatisfy` isJust + it "mdInput: the schema's input as a type; absent, no key" $ do ir <- irOf "input.json" ["tickets"] mdInput <$> method ir "tickets.chat" `shouldBe` Just (Just (named "tickets" "Token")) @@ -139,10 +160,10 @@ encode plain `shouldNotSatisfy` (contains "mdInjected") kindOf ir "tickets.Token" `shouldSatisfy` isJust -- plexus-protocol reads it, and writes it back only when present - let Right ms = Aeson.eitherDecode "{\"name\":\"chat\",\"input\":{\"type\":\"string\"}}" :: Either String MethodSchema + let Right ms = Aeson.eitherDecode "{\"name\":\"chat\",\"returns\":{},\"cardinality\":\"one\",\"input\":{\"type\":\"string\"}}" :: Either String MethodSchema methodInput ms `shouldBe` Just (obj [("type", "string")]) encode ms `shouldSatisfy` (contains "\"input\"") - let Right bare = Aeson.eitherDecode "{\"name\":\"plain\"}" :: Either String MethodSchema + let Right bare = Aeson.eitherDecode "{\"name\":\"plain\",\"returns\":{},\"cardinality\":\"one\"}" :: Either String MethodSchema encode bare `shouldNotSatisfy` (contains "\"input\"") describe "the JSON type (a serde_json::Value)" $ do @@ -226,11 +247,63 @@ typesLeftOut = [ r | r <- Set.toList refused, not (Map.member r (irTypes ir)), not (T.any (`elem` (" (" :: String)) r) ] [ s | s <- unknownSites ir, not (Set.member s refused), null typesLeftOut ] `shouldBe` [] + -- RETURNS-36: synapse 4.0 reads the published 0.7.0 line too. The capture + -- as menger served it — no cardinality, a streaming flag on each method — + -- builds IR 3.0 whose every cardinality is that method's own flag. + describe "menger, 2026-10-29, as served (0.7.0)" $ + it "every method's mdCardinality is its own streaming flag" $ do + rows <- map (either error id . eitherDecode) . filter (not . BL.null) . BL.lines . GZ.decompress <$> BL.readFile menger20261029 :: IO [Value] + let served = [ (p, sch) + | Object r <- rows, Just pv <- [KM.lookup "path" r], Aeson.Success p <- [Aeson.fromJSON pv] + , Just sch <- [KM.lookup "schema" r] ] + flags = [ (T.intercalate "." p <> "." <> n, st) + | (p, Object sch) <- served, Just (Array ms) <- [KM.lookup "methods" sch] + , Object m <- foldr (:) [] ms, Just (String n) <- [KM.lookup "name" m] + , let st = KM.lookup "streaming" m == Just (Bool True) ] + schemas <- mapM (\(p, v) -> case Aeson.fromJSON v of + Aeson.Success sch -> pure (p, sch) + Aeson.Error e -> fail (T.unpack (T.intercalate "." p) <> ": " <> e)) served + env <- envWithSchemas "menger" schemas + ir <- buildFixtureIR env [] + length flags `shouldSatisfy` (> 100) + -- chats.inputs is refused whole (two types titled Message), so not here + [ (path, st) | (path, st) <- flags, not ("chats.inputs." `T.isPrefixOf` path) + , fmap mdCardinality (Map.lookup path (irMethods ir)) /= Just (if st then CardinalityMany else CardinalityOne) ] + `shouldBe` [] + describe "menger, 2026-10-29, whole" $ do - it "is refused at exactly the walk's 21 sites; the root's carriers are the JSON type" $ do + -- RETURNS-13: one title in one namespace is one type. The capture's + -- chats.inputs names two (Message: the vocabulary's string in params, + -- the chat's message in returns); 2.1 kept the first, 3.0 refuses: the + -- one plugin's build fails, and the walk refuses that activation, naming + -- both, and goes on (the review, #9). + it "as captured, chats.inputs puts two types under Message: the build fails naming both" $ do + rows <- map (either error id . eitherDecode) . filter (not . BL.null) . BL.lines . GZ.decompress <$> BL.readFile menger20261029 :: IO [Value] + let inputs = [ sch | Object r <- rows, KM.lookup "path" r == Just (toJSON (["chats", "inputs"] :: [Text])), Just sch <- [KM.lookup "schema" r] ] + [schema] <- pure [ ps | v <- inputs, Aeson.Success ps <- [Aeson.fromJSON (withContract v)] ] + case buildIRFromSchema "menger" ["chats", "inputs"] schema of + Left err -> do + (tcNamespace err, tcTitle err) `shouldBe` ("chats.inputs", "Message") + (tcFirst err, tcSecond err) `shouldBe` (TypeSource "list" "params", TypeSource "list" "returns") + Right _ -> expectationFailure "two types under one title built" + it "the walk refuses chats.inputs, naming both sites, leaves it out, and goes on" $ do ir <- mengerIR - map (\r -> (rfSite r, rfKeyword r)) (irRefusals ir) `shouldBe` expectedMengerRefusals - sort (unknownSites ir) `shouldBe` sort (map fst expectedMengerRefusals) + [ (rfSite r, rfKeyword r) | r <- irRefusals ir ] `shouldBe` [("chats.inputs", "title")] + [ rfDetail r | r <- irRefusals ir ] `shouldSatisfy` all (\d -> all (`T.isInfixOf` d) ["\"Message\"", "method list (params)", "method list (returns)"]) + [ k | k <- Map.keys (irMethods ir), "chats.inputs." `T.isPrefixOf` k ] `shouldBe` [] + [ k | k <- Map.keys (irTypes ir), "chats.inputs." `T.isPrefixOf` k ] `shouldBe` [] + Map.member "chats.post" (irMethods ir) `shouldBe` True + Map.member "tickets.get" (irMethods ir) `shouldBe` True + + -- RETURNS-36: 2.1 refused the walk at the 21 schema methods' returns, + -- which 0.6 left unstated; a 0.7 schema states every method's returns + -- (the captures are given `{}` for them, 'withContract'), so those + -- return the JSON type (chats.inputs' aside: it is refused whole). + it "the 20 schema methods 2.1 refused return the JSON type; the root's carriers are the JSON type" $ do + ir <- mengerIR + unknownSites ir `shouldBe` [] + let schemaMethods = [ T.dropEnd (T.length " returns") site | (site, _) <- expectedMengerRefusals, site /= "chats.inputs.schema returns" ] + [ mdReturns <$> Map.lookup m (irMethods ir) | m <- schemaMethods ] `shouldBe` replicate 20 (Just RefJson) danglingRefs ir `shouldBe` [] param ir ".call" "params" `shouldBe` Just RefJson fieldType ir ".PlexusStreamItem" "data" "content" `shouldBe` Just RefJson @@ -250,12 +323,13 @@ `shouldBe` [RefArray (RefTuple [RefPrimitive "string" Nothing, RefPrimitive "string" Nothing])] kindOf ir ".PluginHashes" `shouldSatisfy` isJust -- no injected param is a param any more: 88 auth, 88 user - length [ () | md <- Map.elems (irMethods ir), ip <- mdInjected md ] `shouldBe` 176 + -- (chats.inputs' 10 aside: it is refused whole) + length [ () | md <- Map.elems (irMethods ir), ip <- mdInjected md ] `shouldBe` 166 [ pdName p | md <- Map.elems (irMethods ir), p <- mdParams md, pdName p `elem` ["auth", "user"] ] `shouldBe` [] - it "equals its golden (menger-2026-10-29.ir-2.1.json)" $ do + it "equals its golden (menger-2026-10-29.ir-3.0.json)" $ do ir <- mengerIR - let golden = fixtures "menger-2026-10-29.ir-2.1.json" + let golden = fixtures "menger-2026-10-29.ir-3.0.json" bytes = encodePretty' defConfig { confCompare = compare } ir { irMetadata = Nothing } write <- lookupEnv "IR_GOLDEN_WRITE" exists <- doesFileExist golden @@ -277,6 +351,7 @@ let typeMismatches = [ "type " <> T.unpack key <> " changed:\n old " <> show (norm v) <> "\n new " <> show (map norm candidates) | (k, v) <- KM.toList oldTypes, not (changedIn20 v) + , not ("chats.inputs." `T.isPrefixOf` K.toText k) -- refused whole in 3.0 , let key = K.toText k local = T.takeWhileEnd (/= '.') key candidates = case Map.lookup key newTypes of @@ -287,25 +362,43 @@ Nothing -> moved n == moved v , not (any same candidates) ] moved = norm . dropKeys ["tdNamespace", "tdDescription"] - -- methods: the same JSON but for the keys 2.1 adds and the injected params it moves + -- methods: the same JSON but for the keys 2.1 adds and the injected + -- params it moves, and 3.0's contract in place of 2.0's streaming + -- guess (RETURNS-13: mdError, mdProgress, mdCardinality; the 2026-10-29 + -- schemas state no error or progress) methodMismatches = [ "method " <> T.unpack key <> ":\n old " <> show old' <> "\n new " <> show new' | (k, v) <- KM.toList oldMethods , let key = K.toText k - old' = norm (dropInjected v) - new' = maybe Null (norm . dropKeys ["mdInjected", "mdInput"] . toJSON) (Map.lookup key (irMethods ir)) - , not (changedIn20 (dropInjected v)), old' /= new' ] + old' = norm (dropKeys ["mdStreaming"] (dropInjected v)) + new' = maybe Null (norm . dropKeys ["mdInjected", "mdInput", "mdError", "mdProgress", "mdCardinality"] . toJSON) (Map.lookup key (irMethods ir)) + , not (changedIn20 (dropInjected v)), old' /= new' + -- chats.inputs is refused whole in 3.0 (two types titled Message) + , not ("chats.inputs." `T.isPrefixOf` key) ] + -- the name IRFixture gave chats.inputs' params' Message, back mapM_ putStrLn (take 5 (typeMismatches ++ methodMismatches)) (length typeMismatches, length methodMismatches) `shouldBe` (0, 0) -- and the guard is not vacuous: most of 2.0 was typed length [ () | (_, v) <- KM.toList oldTypes, not (changedIn20 v) ] `shouldSatisfy` (> 150) length [ () | (_, v) <- KM.toList oldMethods, not (changedIn20 (dropInjected v)) ] `shouldSatisfy` (> 100) - describe "caches another synapse wrote" $ + describe "caches another synapse wrote" $ do + -- RETURNS-36 review (#10): 4.0's schemas and plans (plexus 0.8's + -- shape: cardinality, no streaming) are kept apart from 3.x's + -- (~/.cache/synapse/schemas), so a rollback to synapse.prev never reads + -- an entry 4.0 wrote, nor 4.0 one of 3.x's + it "4.0 keeps its schema cache in a directory of its own layout, never 3.x's" $ + withSystemTempDirectory "r36-cache" $ \dir -> do + setEnv "XDG_CACHE_HOME" dir + root <- schemasRoot + st <- storeFor (plainAt "127.0.0.1" 4455) "builder" "menger" + unsetEnv "XDG_CACHE_HOME" + root `shouldBe` dir "synapse" "schemas-4" + storeDir st `shouldStartWith` (dir "synapse" "schemas-4" "") it "a plan whose IR is 2.0 (3.16.0's) is read as no plan" $ withSystemTempDirectory "cc8-store" $ \dir -> do let st = Store dir - Right ms = Aeson.eitherDecode "{\"name\":\"get\"}" :: Either String MethodSchema + Right ms = Aeson.eitherDecode "{\"name\":\"get\",\"returns\":{},\"cardinality\":\"one\"}" :: Either String MethodSchema plan v = Plan ms ["tickets", "get"] Nothing (Just emptyIR { irVersion = v }) createDirectoryIfMissing True (dir "plans") writePlan st ["tickets", "get"] (plan "2.0") @@ -317,29 +410,120 @@ exe <- runIO builtSynapse case exe of Nothing -> it "against a service with a bare object" $ pendingWith "the built synapse is not on PATH (cabal test puts it there)" - Just bin -> it "against a service with a bare object: the IR on stdout, the site on stderr, exit 65" $ do - rows <- loadSchemasValues (fixtures "untyped.json") + Just bin -> do let root = Object (KM.fromList [ ("namespace", String "menger"), ("version", String "1.0.0"), ("description", String "root") , ("hash", String "r-cc8"), ("methods", Array mempty) , ("children", toJSON [ Object (KM.fromList [("namespace", String "tickets"), ("description", String "t"), ("hash", String "t-cc8")]) ]) ]) - writeIORef schemaOverride (Just (("", root) : rows)) - withSystemTempDirectory "cc8-cli" $ \dir -> withMockService todaysService $ \port -> do - forM_ ["home", "cache", "run"] $ \d -> createDirectoryIfMissing True (dir d) - env0 <- getEnvironment - let env = [ (k, v) | (k, v) <- env0, k `notElem` ["HOME", "XDG_CACHE_HOME", "XDG_RUNTIME_DIR", "SYNAPSE_AS", "PLEXUS_SESSION"] ] - ++ [ ("HOME", dir "home"), ("XDG_CACHE_HOME", dir "cache"), ("XDG_RUNTIME_DIR", dir "run") - , ("PLEXUS_KEYCHAIN", "off"), ("SYNAPSE_HOLD_FOR", "3s") ] - (code, out, err) <- readCreateProcessWithExitCode - (proc bin ["--url", "ws://127.0.0.1:" <> show port <> "/ws", "-i", "menger"]) { env = Just env } "" - writeIORef schemaOverride Nothing + emitIR rows = do + writeIORef schemaOverride (Just (("", root) : rows)) + withSystemTempDirectory "cc8-cli" $ \dir -> withMockService todaysService $ \port -> do + forM_ ["home", "cache", "run"] $ \d -> createDirectoryIfMissing True (dir d) + env0 <- getEnvironment + let env = [ (k, v) | (k, v) <- env0, k `notElem` ["HOME", "XDG_CACHE_HOME", "XDG_RUNTIME_DIR", "SYNAPSE_AS", "PLEXUS_SESSION"] ] + ++ [ ("HOME", dir "home"), ("XDG_CACHE_HOME", dir "cache"), ("XDG_RUNTIME_DIR", dir "run") + , ("PLEXUS_KEYCHAIN", "off"), ("SYNAPSE_HOLD_FOR", "3s") ] + r <- readCreateProcessWithExitCode + (proc bin ["--url", "ws://127.0.0.1:" <> show port <> "/ws", "-i", "menger"]) { env = Just env } "" + writeIORef schemaOverride Nothing + pure r + it "against a service with a bare object: the IR on stdout, the site on stderr, exit 65" $ do + rows <- loadSchemasValues (fixtures "untyped.json") + (code, out, err) <- emitIR rows code `shouldBe` ExitFailure 65 err `shouldSatisfy` ("tickets.Thing.bare" `isInfixOf`) err `shouldSatisfy` ("neither properties nor additionalProperties" `isInfixOf`) + -- nothing was left out: main's header + err `shouldSatisfy` ("nothing was dropped" `isInfixOf`) case eitherDecode (BL.pack out) :: Either String IR of Left e -> expectationFailure ("stdout is not an IR: " <> e <> "\n" <> take 400 out) Right ir -> map rfSite (irRefusals ir) `shouldBe` ["tickets.Thing.bare", "tickets.Thing.list[]", "tickets.Thing.mixed"] + -- RETURNS-36 review: a title collision leaves its activation out, so + -- the header says so, by namespace, and never "nothing was dropped" + it "against a service with two types under one title: the header says which activation was left out, exit 65" $ do + let pong props = object07 ["title" .= ("Pong" :: Text), "type" .= ("object" :: Text), "properties" .= props] + method n props = object07 [ "name" .= (n :: Text), "description" .= n, "hash" .= (n <> "0"), "streaming" .= False + , "returns" .= pong props ] + tickets = object07 + [ "namespace" .= ("tickets" :: Text), "version" .= ("1" :: Text), "description" .= ("t" :: Text), "hash" .= ("t-cc8" :: Text) + , "methods" .= [ method "a" (object07 ["message" .= object07 ["type" .= ("string" :: Text)]]) + , method "b" (object07 ["reply" .= object07 ["type" .= ("integer" :: Text)]]) ] ] + (code, out, err) <- emitIR [("tickets", tickets)] + code `shouldBe` ExitFailure 65 + err `shouldNotSatisfy` ("nothing was dropped" `isInfixOf`) + err `shouldSatisfy` ("left out: tickets" `isInfixOf`) + case eitherDecode (BL.pack out) :: Either String IR of + Left e -> expectationFailure ("stdout is not an IR: " <> e <> "\n" <> take 400 out) + Right ir -> map (\r -> (rfSite r, rfKeyword r)) (irRefusals ir) `shouldBe` [("tickets", "title")] + -- RETURNS-40: synapse asks the service for its IR first — one call — and + -- walks the raw schemas only when the service has no `ir`. + describe "synapse -i, a service that writes its IR" $ do + exe <- runIO builtSynapse + case exe of + Nothing -> it "asks ir" $ pendingWith "the built synapse is not on PATH (cabal test puts it there)" + Just bin -> do + let runI args = withSystemTempDirectory "r40-cli" $ \dir -> withMockService todaysService $ \port -> do + forM_ ["home", "cache", "run"] $ \d -> createDirectoryIfMissing True (dir d) + env0 <- getEnvironment + let env = [ (k, v) | (k, v) <- env0, k `notElem` ["HOME", "XDG_CACHE_HOME", "XDG_RUNTIME_DIR", "SYNAPSE_AS", "PLEXUS_SESSION"] ] + ++ [ ("HOME", dir "home"), ("XDG_CACHE_HOME", dir "cache"), ("XDG_RUNTIME_DIR", dir "run") + , ("PLEXUS_KEYCHAIN", "off"), ("SYNAPSE_HOLD_FOR", "3s") ] + writeIORef callsMade [] + writeIORef irAsked [] + r <- readCreateProcessWithExitCode + (proc bin (["--url", "ws://127.0.0.1:" <> show port <> "/ws", "-i", "menger"] <> args)) { env = Just env } "" + calls <- readIORef callsMade + asked <- readIORef irAsked + pure (r, calls, asked) + served = emptyIR + { irBackend = "theirs", irHash = Just "h-r40" + , irPlugins = Map.fromList [("tickets", ["get"])] + , irRefusals = [] } + sameIR a b = (irTypes a, irMethods a, irPlugins a, irHash a, irRefusals a) `shouldBe` (irTypes b, irMethods b, irPlugins b, irHash b, irRefusals b) + it "the root lists ir: its schema, then one call to ir, and its IR — named for the backend, with synapse's metadata" $ do + writeIORef irAnswer (Just (Aeson.object ["ok" Aeson..= served])) + ((code, out, err), calls, asked) <- runI [] + writeIORef irAnswer Nothing + (code, err) `shouldBe` (ExitSuccess, "") + calls `shouldBe` ["menger.schema", "menger.ir"] + asked `shouldBe` [Aeson.object []] + case eitherDecode (BL.pack out) :: Either String IR of + Left e -> expectationFailure ("stdout is not an IR: " <> e) + Right ir -> do + ir `sameIR` served + irBackend ir `shouldBe` "menger" + irMetadata ir `shouldSatisfy` isJust + it "a path is the namespace asked for" $ do + writeIORef irAnswer (Just (Aeson.object ["ok" Aeson..= served])) + (_, calls, asked) <- runI ["tickets"] + writeIORef irAnswer Nothing + calls `shouldBe` ["menger.schema", "menger.ir"] + asked `shouldBe` [Aeson.object ["namespaces" Aeson..= (["tickets"] :: [Text])]] + it "a refusal is the service's, said in its words, and nothing walked" $ do + writeIORef irAnswer (Just (Aeson.object ["err" Aeson..= Aeson.object + [ "type" Aeson..= ("not_found" :: Text), "namespace" Aeson..= ("delta" :: Text) + , "message" Aeson..= ("no namespace delta in this service" :: Text) ]])) + ((code, _, err), calls, _) <- runI [] + writeIORef irAnswer Nothing + code `shouldNotBe` ExitSuccess + err `shouldSatisfy` ("no namespace delta in this service" `isInfixOf`) + calls `shouldBe` ["menger.schema", "menger.ir"] + it "an IR of another version is not read: the walk builds it" $ do + writeIORef irAnswer (Just (Aeson.object ["ok" Aeson..= served { irVersion = "2.1" }])) + ((code, out, _), calls, _) <- runI [] + writeIORef irAnswer Nothing + code `shouldBe` ExitSuccess + take 2 calls `shouldBe` ["menger.schema", "menger.ir"] + fmap irVersion (eitherDecode (BL.pack out) :: Either String IR) `shouldBe` Right currentIrVersion + it "a root that lists no ir (0.7.0): no call to ir, the walk as before" $ do + ((code, out, _), calls, _) <- runI [] + code `shouldBe` ExitSuccess + calls `shouldSatisfy` notElem "menger.ir" + take 1 calls `shouldBe` ["menger.schema"] + length (filter (".schema" `T.isSuffixOf`) calls) `shouldSatisfy` (> 1) + fmap irVersion (eitherDecode (BL.pack out) :: Either String IR) `shouldBe` Right currentIrVersion + -- --------------------------------------------------------------------------- fixtures :: FilePath @@ -355,7 +539,7 @@ smallFixtures = [ ("transition-field.json", ["tickets"]), ("answer-source.json", ["tickets"]), ("reply.json", ["tickets"]) , ("hash-event.json", ["tickets"]), ("login-flow.json", ["auth"]), ("schema-result.json", ["tickets"]) - , ("unreadable-oneof.json", ["tickets"]), ("static-child.json", ["tickets"]), ("no-returns.json", ["x"]) + , ("unreadable-oneof.json", ["tickets"]), ("static-child.json", ["tickets"]) , ("hashes.json", ["tickets"]), ("injected.json", ["tickets"]) , ("untyped.json", ["tickets"]), ("json.json", ["tickets"]), ("theme-map.json", ["themes"]) , ("component-preview.json", ["tickets"]), ("bounds.json", ["tickets"]), ("allof.json", ["tickets"]) @@ -374,6 +558,9 @@ named :: Text -> Text -> TypeRef named ns n = RefNamed (QualifiedName ns n) + +object07 :: [(K.Key, Value)] -> Value +object07 = Object . KM.fromList obj :: [(Text, Text)] -> Value obj kvs = Object (KM.fromList [ (K.fromText k, String v) | (k, v) <- kvs ]) diff --git a/test/IRFixture.hs b/test/IRFixture.hs --- a/test/IRFixture.hs +++ b/test/IRFixture.hs @@ -24,6 +24,7 @@ import Data.Text (Text) import qualified Katip +import Plexus07 (withContract) import Synapse.IR.Builder (buildIR) import Synapse.IR.Types (IR) import qualified Synapse.Log as Log @@ -35,8 +36,13 @@ data Row = Row Path PluginSchema +-- | RETURNS-36: a row's schema as plexus 0.7 states it ('withContract': its +-- methods' cardinality, and returns where a fixture states none; the +-- captures are 0.6's). The capture's types are read as served. instance FromJSON Row where - parseJSON = withObject "Row" $ \o -> Row <$> o .: "path" <*> o .: "schema" + parseJSON = withObject "Row" $ \o -> do + v <- o .: "schema" + Row <$> o .: "path" <*> parseJSON (withContract v) -- | Every schema of a fixture, by path: a @.jsonl.gz@ one row a line -- (gunzipped), a @.json@ an array of rows. diff --git a/test/IRSpec.hs b/test/IRSpec.hs --- a/test/IRSpec.hs +++ b/test/IRSpec.hs @@ -89,7 +89,7 @@ irSpec ir = do describe "Schema fetching" $ do it "builds IR from root" $ - irVersion ir `shouldBe` "2.0" + irVersion ir `shouldBe` "3.0" it "IR contains methods" $ Map.size (irMethods ir) `shouldSatisfy` (> 0) diff --git a/test/InputSpec.hs b/test/InputSpec.hs new file mode 100644 --- /dev/null +++ b/test/InputSpec.hs @@ -0,0 +1,317 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | BIDIR-18: synapse calls a method with an input half (plexus-wire +-- spec/10). The built synapse, end to end against the mock service's +-- @stream@ activation (a home, a cache and a runtime directory of the +-- test's own), the frames counted where they land: +-- +-- * lines as string items, NDJSON as object items, a bad line named by its +-- number and never carried; +-- * stdin not read past the credit (a service granting 4 and never acking), +-- and synapse's memory flat while the writer runs ahead; +-- * bytes as binary frames — header, payload, @--chunk@, the call's seq; +-- * a disconnect said on stderr with the counts, exit 69, the call never +-- made again; +-- * the typed closes' exits: 70, 65, 77; +-- * a parameter named @input@ keeps its flag (the stream is +-- @--input-stream@); no stream given is refused before anything is sent; +-- @-n@ prints the open frame and the first input frame. +module Main (main) where + +import Control.Concurrent (forkIO, threadDelay) +import Control.Exception (SomeException, finally, try) +import Control.Monad (forM_) +import Data.Aeson +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy.Char8 as LBS8 +import Data.IORef +import Data.List (isInfixOf, isPrefixOf) +import Data.Text (Text) +import qualified Data.Text as T +import System.Directory (createDirectoryIfMissing, findExecutable, listDirectory) +import System.Environment (getEnvironment) +import System.Exit (ExitCode(..)) +import System.FilePath (()) +import System.IO (hClose, hFlush, hSetBinaryMode, hSetBuffering, BufferMode(..)) +import System.Timeout (timeout) +import System.IO.Temp (withSystemTempDirectory) +import System.Posix.Signals (signalProcess, sigKILL, sigTERM) +import System.Process +import Test.Hspec + +import MockService + +main :: IO () +main = hspec $ do + synapse <- runIO (findExecutable "synapse") + case synapse of + Nothing -> it "(the synapse executable is not on PATH)" $ pendingWith "cabal test puts it there" + Just exe -> inputSpec exe + +inputSpec :: FilePath -> Spec +inputSpec exe = describe "a call with an input half (BIDIR-18)" $ do + forM_ [(["--no-hold"], "on its own socket"), ([], "through the holder")] $ \(how, label) -> describe label $ do + it "sends lines as string items, one a line, an empty one too" $ withRun $ \run dir -> do + writeFile (dir "log.txt") "first\n\nthird\n" + (code, out, err) <- run how ["stream", "lines", "--input", "@" <> dir "log.txt"] "" + code `shouldBe` ExitSuccess + out `shouldContain` "items: 3" + err `shouldContain` "input: sent 3 items in 1 frame" + itemsReceived `shouldReturn` [String "first", String "", String "third"] + ends `shouldReturn` [1] + readIORef inputViolations `shouldReturn` [] + -- through the holder: a holder process under this test's runtime directory + holders <- holdersUnder dir + (if null how then length holders `shouldBe` 1 else holders `shouldBe` []) + + it "sends NDJSON as object items, in order, under credit (10,000 from stdin)" $ withRun $ \run _ -> do + let items = [ object ["at" .= i, "pad" .= ("p" <> show i)] | i <- [1 .. 10000 :: Int] ] + (code, out, err) <- run how ["stream", "ingest", "--input", "-"] (unlines (map (LBS8.unpack . encode) items)) + code `shouldBe` ExitSuccess + out `shouldContain` "items: 10000" + err `shouldContain` "input: sent 10,000 items" + err `shouldContain` "0 unacked" + itemsReceived `shouldReturn` items + readIORef inputViolations `shouldReturn` [] + + it "sends bytes as binary frames: the header, --chunk bytes each, seq counting every frame" $ withRun $ \run dir -> do + let bytes = BS.pack [0 .. 22] + BS.writeFile (dir "audio.raw") bytes + (code, _, err) <- run how ["stream", "audio", "--input", "@" <> dir "audio.raw", "--chunk", "5"] "" + (code, err) `shouldSatisfy` ((== ExitSuccess) . fst) + rs <- readIORef inputReceived + let bins = [ (sub, sq, p) | ReceivedBinary sub sq p <- rs ] + map (\(_, sq, _) -> sq) bins `shouldBe` [0 .. 4] + map (\(_, _, p) -> BS.length p) bins `shouldBe` [5, 5, 5, 5, 3] + BS.concat [ p | (_, _, p) <- bins ] `shouldBe` bytes + length (filter (\(sub, _, _) -> sub == firstSub bins) bins) `shouldBe` 5 + [ sq | ReceivedEnd sq <- rs ] `shouldBe` [5] + readIORef inputViolations `shouldReturn` [] + + it "names a line that is not JSON by its number; no frame carries it, and the call ends (65)" $ withRun $ \run dir -> do + writeFile (dir "bad.jsonl") $ unlines + [ "{\"at\":1,\"pad\":\"a\"}", "{\"at\":2,\"pad\":\"b\"}", "{\"at\":3,", "{\"at\":4,\"pad\":\"d\"}" ] + (code, _, err) <- run ["--no-hold"] ["stream", "ingest", "--input", "@" <> dir "bad.jsonl"] "" + code `shouldBe` ExitFailure 65 + err `shouldContain` "input line 3 is not an item" + got <- itemsReceived + got `shouldNotSatisfy` any (\v -> v == object ["at" .= (4 :: Int), "pad" .= ("d" :: Text)]) + length got `shouldSatisfy` (<= 2) + ends `shouldReturn` [] + + -- review of BIDIR-18: only the end of the source ends the input + it "ends the call on a read that fails (exit 74), sending no end" $ withRun $ \run _ -> do + (code, _, err) <- run ["--no-hold"] ["stream", "lines", "--input", "@/proc/self/mem"] "" + code `shouldBe` ExitFailure 74 + err `shouldContain` "could not be read" + ends `shouldReturn` [] + + it "sends end when the source is over though no credit is left" $ + withRunPlan defaultInputPlan { planWindow = 2, planStingy = True } $ \run dir _ _ -> do + writeFile (dir "two.txt") "a\nb\n" + r <- timeout 15000000 (run ["--no-hold"] ["stream", "lines", "--input", "@" <> dir "two.txt"] "") + fmap (\(c, _, _) -> c) r `shouldBe` Just ExitSuccess + itemsReceived `shouldReturn` [String "a", String "b"] + length <$> ends `shouldReturn` 1 + + forM_ [("lines", "a\nb", "a line whole while the next is still arriving"), ("audio", "0123456789", "bytes as they come, short of --chunk")] $ \(m, sent, label) -> + it ("sends " <> label <> " (a live source)") $ withRunPlan defaultInputPlan $ \_ _ env port -> do + (Just hin, Just hout, Just herr, ph) <- createProcess + (proc exe ["--no-hold", "--url", "ws://127.0.0.1:" <> show port <> "/ws", "menger", "stream", m, "--input", "-", "--chunk", "640"]) + { env = Just env, std_in = CreatePipe, std_err = CreatePipe, std_out = CreatePipe } + hSetBinaryMode hin True + BS.hPut hin (BS8.pack sent) >> hFlush hin + got <- waitUntil 10 $ do + rs <- readIORef inputReceived + pure $ if m == "lines" then [ is | ReceivedJson _ is <- rs ] == [[String "a"]] + else [ p | ReceivedBinary _ _ p <- rs ] == [BS8.pack sent] + rs <- readIORef inputReceived + hClose hin + _ <- waitForProcess ph + mapM_ (\h -> hClose h `catchAny` \_ -> pure ()) [hout, herr] + (got, rs) `shouldSatisfy` fst + + it "keeps a value that reads --progress for the parameter it follows" $ withRun $ \run dir -> do + writeFile (dir "log.txt") "one\n" + (code, out, _) <- run ["--no-hold"] ["stream", "tagged", "--input", "--progress", "--input-stream", "@" <> dir "log.txt"] "" + code `shouldBe` ExitSuccess + out `shouldContain` "tag: --progress" + + it "reads no more of stdin than the credit allows, its memory flat (a service granting 4, never acking)" $ + withRunPlan defaultInputPlan { planWindow = 4, planStingy = True } $ \_ _ env port -> do + written <- newIORef (0 :: Int) + (Just hin, Just hout, Just herr, ph) <- createProcess (proc exe (["--no-hold", "--url", "ws://127.0.0.1:" <> show port <> "/ws", "menger", "stream", "lines", "--input", "-"])) + { env = Just env, std_in = CreatePipe, std_err = CreatePipe, std_out = CreatePipe } + hSetBinaryMode hin True + hSetBuffering hin NoBuffering + let line = BS8.pack (replicate 1023 'x' <> "\n") + _ <- forkIO $ (let go = BS.hPut hin line >> modifyIORef' written (+ 1) >> go in go) + `catchAny` \_ -> pure () + Just pid <- getPid ph + threadDelay 1500000 + alive <- getProcessExitCode ph + case alive of + Just c -> do + e <- BS.hGetContents herr + expectationFailure ("synapse ended (" <> show c <> "): " <> BS8.unpack e) + Nothing -> pure () + rss1 <- rssKb (show pid) + threadDelay 3000000 + rss2 <- rssKb (show pid) + n <- readIORef written + got <- itemsReceived + signalProcess sigTERM pid `catchAny` \_ -> pure () + _ <- waitForProcess ph + mapM_ (\h -> hClose h `catchAny` \_ -> pure ()) [herr, hout] + putStrLn (" " <> show n <> " lines of 1 KiB written in 4.5 s; synapse RSS " <> show rss1 <> " kB at 1.5 s, " <> show rss2 <> " kB at 4.5 s") + length got `shouldBe` 4 + -- 4 items, the read buffer synapse holds (32 KiB), and the pipe's + -- 64 KiB: nothing like the writer's endless stream + n `shouldSatisfy` (< 4 + 32 + 64 + 16) + abs (rss2 - rss1) `shouldSatisfy` (<= 1024) + readIORef inputViolations `shouldReturn` [] + + it "says a disconnect on stderr with what was sent and acked, exits 69, and never makes the call again" $ + withRunPlan defaultInputPlan { planDropAfter = Just 3 } $ \run dir _ _ -> do + writeFile (dir "many.jsonl") $ unlines [ "{\"at\":" <> show i <> ",\"pad\":\"x\"}" | i <- [1 .. 5000 :: Int] ] + writeIORef callsMade [] + (code, _, err) <- run ["--no-hold"] ["stream", "ingest", "--input", "@" <> dir "many.jsonl"] "" + code `shouldBe` ExitFailure 69 + err `shouldContain` "lost during the call" + err `shouldContain` "not sent again" + err `shouldContain` "input: sent " + err `shouldContain` "unacked" + calls <- readIORef callsMade + length (filter (== "stream.ingest") calls) `shouldBe` 1 + + forM_ [ ("past_credit", 70, "a bug in synapse"), ("invalid_input", 65, "refused the input (invalid_input) at frame 0") + , ("too_much_input", 65, "too_much_input"), ("out_of_sequence", 65, "out_of_sequence") ] $ \(kind, exit, says) -> + it ("exits " <> show exit <> " when the service closes the input with " <> T.unpack kind) $ + withRunPlan defaultInputPlan { planRefuse = Just (1, kind) } $ \run dir _ _ -> do + writeFile (dir "two.txt") "a\nb\n" + (code, _, err) <- run ["--no-hold"] ["stream", "lines", "--input", "@" <> dir "two.txt"] "" + code `shouldBe` ExitFailure exit + err `shouldContain` says + err `shouldContain` "input: sent" + + it "exits 77 when the service closes the input for a revoked sign-in" $ + withRunPlan defaultInputPlan { planClose = Just (1, "revoked") } $ \run dir _ _ -> do + writeFile (dir "two.txt") "a\nb\n" + (code, _, err) <- run ["--no-hold"] ["stream", "lines", "--input", "@" <> dir "two.txt"] "" + code `shouldBe` ExitFailure 77 + err `shouldContain` "revoked" + + it "keeps --input for a parameter named input; the stream is --input-stream" $ withRun $ \run dir -> do + writeFile (dir "log.txt") "one\ntwo\n" + (code, out, _) <- run ["--no-hold"] ["stream", "tagged", "--input", "t1", "--input-stream", "@" <> dir "log.txt"] "" + code `shouldBe` ExitSuccess + out `shouldContain` "tag: t1" + itemsReceived `shouldReturn` [String "one", String "two"] + + it "refuses a call with no stream named, before anything is sent, naming the flag" $ withRun $ \run _ -> do + writeIORef callsMade [] + (code, _, err) <- run ["--no-hold"] ["stream", "lines"] "" + code `shouldNotBe` ExitSuccess + err `shouldContain` "--input -" + calls <- readIORef callsMade + filter (\c -> "stream." `T.isPrefixOf` c && not (".schema" `T.isSuffixOf` c)) calls `shouldBe` [] + + it "-n prints the open frame and the first input frame, and sends nothing" $ withRun $ \run dir -> do + writeFile (dir "log.txt") "hello\nworld\n" + writeIORef callsMade [] + (code, out, _) <- run ["--no-hold", "-n"] ["stream", "lines", "--input", "@" <> dir "log.txt"] "" + code `shouldBe` ExitSuccess + case lines out of + [open, first] -> do + open `shouldContain` "\"method\":\"menger.call\"" + first `shouldContain` "\"method\":\"menger.input\"" + first `shouldContain` "\"items\":[\"hello\"]" + other -> expectationFailure ("two lines, not " <> show other) + BS.writeFile (dir "a.raw") (BS.replicate 700 7) + (_, out', _) <- run ["--no-hold", "-n"] ["stream", "audio", "--input", "@" <> dir "a.raw", "--chunk", "640"] "" + out' `shouldContain` "binary: 01 0000000000000000 0000000000000000 + 640 bytes" + calls <- readIORef callsMade + filter (\c -> "stream." `T.isPrefixOf` c && not (".schema" `T.isSuffixOf` c)) calls `shouldBe` [] + + it "--help says the input: its item type, binary or not, --input and --chunk" $ withRun $ \run _ -> do + (_, out, _) <- run ["--no-hold"] ["stream", "audio", "--help"] "" + out `shouldContain` "--input <-|@FILE>" + out `shouldContain` "bytes items" + out `shouldContain` "binary frame" + out `shouldContain` "[--chunk ]" + (_, out2, _) <- run ["--no-hold"] ["stream", "ingest", "--help"] "" + out2 `shouldContain` "Item items" + out2 `shouldContain` "NDJSON" + (_, found, _) <- run ["--no-hold"] ["_find", "raw", "bytes"] "" + found `shouldContain` "takes a stream in: --input -|@FILE" + where + withRun act = withRunPlan defaultInputPlan (\run dir _ _ -> act run dir) + withRunPlan plan act = withSystemTempDirectory "b18" $ \dir -> withMockService todaysService $ \port -> do + forM_ ["home", "cache", "run"] $ \d -> createDirectoryIfMissing True (dir d) + env0 <- getEnvironment + let env = [ (k, v) | (k, v) <- env0, k `notElem` ["HOME", "XDG_CACHE_HOME", "XDG_RUNTIME_DIR", "SYNAPSE_AS", "PLEXUS_SESSION", "SYNAPSE_NO_HOLD"] ] + ++ [ ("HOME", dir "home"), ("XDG_CACHE_HOME", dir "cache"), ("XDG_RUNTIME_DIR", dir "run") + , ("PLEXUS_KEYCHAIN", "off"), ("SYNAPSE_HOLD_FOR", "5s"), ("SYNAPSE_RECONNECT_FOR", "3s") ] + url = ["--url", "ws://127.0.0.1:" <> show port <> "/ws"] + run' globals args input = readCreateProcessWithExitCode + (proc exe (globals ++ url ++ case args of + ("_find" : rest) -> "_find" : "menger" : rest + _ -> "menger" : args)) { env = Just env } input + writeIORef schemaOverride (Just inputSchemas) + resetInput plan + (act run' dir env port `finally` (writeIORef schemaOverride Nothing >> stopHolders dir)) + +-- | The items every JSON frame carried, in order. +itemsReceived :: IO [Value] +itemsReceived = do + rs <- readIORef inputReceived + pure (concat [ is | ReceivedJson _ is <- rs ]) + +-- | The seq of every @end@. +ends :: IO [Integer] +ends = do + rs <- readIORef inputReceived + pure [ toInteger sq | ReceivedEnd sq <- rs ] + +firstSub :: [(a, b, c)] -> a +firstSub ((s, _, _) : _) = s +firstSub [] = error "no binary frame" + +-- | A process's resident memory, in KiB (VmRSS). +rssKb :: String -> IO Int +rssKb pid = do + st <- BS8.readFile ("/proc" pid "status") + case [ l | l <- BS8.lines st, "VmRSS:" `BS8.isPrefixOf` l ] of + (l : _) -> pure (read (BS8.unpack (BS8.words l !! 1))) + [] -> fail ("no VmRSS for " <> pid <> ": " <> BS8.unpack st) + +-- | Wait up to the seconds for the condition. +waitUntil :: Int -> IO Bool -> IO Bool +waitUntil secs cond = go (secs * 20) + where + go 0 = cond + go n = cond >>= \ok -> if ok then pure True else threadDelay 50000 >> go (n - 1 :: Int) + +-- | The holder processes whose socket lies under the directory. +holdersUnder :: FilePath -> IO [String] +holdersUnder dir = do + pids <- filter (all (`elem` ['0' .. '9'])) <$> listDirectory "/proc" + fmap concat $ mapM (\p -> do + r <- try (BS.readFile ("/proc" p "cmdline")) :: IO (Either SomeException BS.ByteString) + pure [ p | Right bs <- [r], let args = map BS8.unpack (BS.split 0 bs), "_hold" `elem` args, any (dir `isInfixOf`) args ]) pids + +-- | Stop every holder whose socket lies under the directory. +stopHolders :: FilePath -> IO () +stopHolders dir = do + pids <- filter (all (`elem` ['0' .. '9'])) <$> listDirectory "/proc" + forM_ pids $ \p -> do + r <- try (BS.readFile ("/proc" p "cmdline")) :: IO (Either SomeException BS.ByteString) + case r of + Right bs | let args = map BS8.unpack (BS.split 0 bs), "_hold" `elem` args, any (dir `isInfixOf`) args -> + signalProcess sigKILL (read p) `catchAny` \_ -> pure () + _ -> pure () + +catchAny :: IO a -> (SomeException -> IO a) -> IO a +catchAny act h = try act >>= either h pure diff --git a/test/MockService.hs b/test/MockService.hs --- a/test/MockService.hs +++ b/test/MockService.hs @@ -17,6 +17,8 @@ , ViewMode(..) , todaysService , withMockService + , withEphemeralService + , withMockServiceOn , serveMockService , mockCode , mockState @@ -29,21 +31,43 @@ , renamedGet -- * SYNAPSE-CC-8: a service serving schemas a test gives it , schemaOverride + -- * SYNAPSE-40: a dial that takes its time, and what is left open + , upgradeDelay + , connectionsOpen -- * SYNAPSE-26: what a closed stdout cost the service , callsMade , floodsEnded , dropNext + -- * RETURNS-36: a service on the published 0.7.0 line + , served070 + -- * RETURNS-40: a service that writes its own IR + , irAnswer + , irAsked + -- * BIDIR-18: methods with an input half + , InputPlan(..) + , defaultInputPlan + , inputPlan + , inputSchemas + , Received(..) + , inputReceived + , inputViolations + , resetInput ) where import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, tryPutMVar, tryTakeMVar) import System.Timeout (timeout) -import Control.Exception (SomeException, bracket, try) +import Control.Exception (SomeException, bracket, finally, try) import Control.Monad (forever, void) import Data.Aeson import qualified Data.Aeson.Key as K import qualified Data.Aeson.KeyMap as KM +import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as LBS +import Data.Bits (shiftL, (.|.)) +import qualified Data.Map.Strict as Map +import Data.Word (Word64) import Data.IORef import Data.Text (Text) import qualified Data.Text as T @@ -55,6 +79,8 @@ import System.IO (hFlush, stdout) import System.IO.Unsafe (unsafePerformIO) +import Plexus07 (withContract) + data ViewMode = NoView | AnonymousView | CallerView deriving (Eq, Show) @@ -107,6 +133,17 @@ schemaOverride :: IORef (Maybe [(Text, Value)]) schemaOverride = unsafePerformIO (newIORef Nothing) +-- | SYNAPSE-40: microseconds each service waits before it answers a +-- WebSocket upgrade (a dial under way that long). +{-# NOINLINE upgradeDelay #-} +upgradeDelay :: IORef Int +upgradeDelay = unsafePerformIO (newIORef 0) + +-- | SYNAPSE-40: WebSocket connections open at the services now. +{-# NOINLINE connectionsOpen #-} +connectionsOpen :: IORef Int +connectionsOpen = unsafePerformIO (newIORef 0) + -- | SYNAPSE-26: the method of every @menger.call@ the services took, in order. {-# NOINLINE callsMade #-} callsMade :: IORef [Text] @@ -124,6 +161,119 @@ dropNext :: IORef [Text] dropNext = unsafePerformIO (newIORef []) +-- | RETURNS-36: when set, the services answer as one on the published 0.7.0 +-- line does — every schema as written (a method's @streaming@, no +-- @cardinality@), every error frame spec/05's fields alone (@message@, +-- @code@, @error_kind@ and a refusal's fields, no typed @error@). +{-# NOINLINE served070 #-} +served070 :: IORef Bool +served070 = unsafePerformIO (newIORef False) + +-- | RETURNS-40: when set, the service writes its own IR: @menger.ir@ +-- answers this (@{"ok": IR}@ or @{"err": …}@) as plexus 0.8's does. Unset, +-- it has no @ir@ — every 0.7.0 service — and the call fails as an unknown +-- method does. +{-# NOINLINE irAnswer #-} +irAnswer :: IORef (Maybe Value) +irAnswer = unsafePerformIO (newIORef Nothing) + +-- | RETURNS-40: the params of every @menger.ir@ the services took, in order. +{-# NOINLINE irAsked #-} +irAsked :: IORef [Value] +irAsked = unsafePerformIO (newIORef []) + +-- | BIDIR-18: how the services answer a call's input half. +data InputPlan = InputPlan + { planWindow :: Int + -- ^ the first credit, and the window: past half of it consumed, an + -- @ack@ and a @credit@ for what was consumed + , planStingy :: Bool + -- ^ grant the first window and nothing more, never ack + , planRefuse :: Maybe (Int, Text) + -- ^ at this many frames, refuse with this @error_kind@ (naming the frame) + , planClose :: Maybe (Int, Text) + -- ^ at this many frames, @input_closed {reason}@, then an error item + , planDropAfter :: Maybe Int + -- ^ at this many frames, close the socket + } deriving (Eq, Show) + +defaultInputPlan :: InputPlan +defaultInputPlan = InputPlan 64 False Nothing Nothing Nothing + +{-# NOINLINE inputPlan #-} +inputPlan :: IORef InputPlan +inputPlan = unsafePerformIO (newIORef defaultInputPlan) + +-- | One input frame as a service took it. +data Received + = ReceivedJson Word64 [Value] -- ^ @menger.input {seq, items}@ + | ReceivedBinary Word64 Word64 BS.ByteString -- ^ a binary frame: subscription, seq, payload + | ReceivedEnd Word64 -- ^ @menger.end {seq}@ + deriving (Eq, Show) + +-- | BIDIR-18: every input frame the services took, in order. +{-# NOINLINE inputReceived #-} +inputReceived :: IORef [Received] +inputReceived = unsafePerformIO (newIORef []) + +-- | BIDIR-18: what a client did that spec/10 forbids (past credit, out of +-- sequence, a malformed binary frame), each said. +{-# NOINLINE inputViolations #-} +inputViolations :: IORef [Text] +inputViolations = unsafePerformIO (newIORef []) + +resetInput :: InputPlan -> IO () +resetInput plan = do + writeIORef inputPlan plan + writeIORef inputReceived [] + writeIORef inputViolations [] + +-- | BIDIR-18: a root with a @stream@ activation beside @tickets@, whose +-- methods take a stream in — for 'schemaOverride'. +inputSchemas :: [(Text, Value)] +inputSchemas = + [ ("", object + [ "namespace" .= ("menger" :: Text), "version" .= ("1.0.0" :: Text), "description" .= ("Central routing" :: Text) + , "hash" .= ("r-input" :: Text) + , "children" .= + [ object ["namespace" .= ("tickets" :: Text), "description" .= ("Plans as data" :: Text), "hash" .= ("t0" :: Text)] + , object ["namespace" .= ("stream" :: Text), "description" .= ("Streams in" :: Text), "hash" .= ("s0" :: Text)] ] ]) + , ("stream", object + [ "namespace" .= ("stream" :: Text), "version" .= ("0.1.0" :: Text), "hash" .= ("s0" :: Text) + , "description" .= ("Streams in" :: Text) + , "methods" .= + [ m "lines" "A log, a line an item" (object ["type" .= ("string" :: Text)]) Nothing + , m "ingest" "Items in, an object each" item Nothing + , m "audio" "Raw bytes in" bytesSchema Nothing + , m "tagged" "Lines in, beside a parameter named input" (object ["type" .= ("string" :: Text)]) + (Just (object ["type" .= ("object" :: Text), "required" .= (["input"] :: [Text]), "properties" .= object + ["input" .= object ["type" .= ("string" :: Text), "description" .= ("A tag" :: Text)]]])) + ] ]) ] + where + m :: Text -> Text -> Value -> Maybe Value -> Value + m n d inp ps = object $ + [ "name" .= (n :: Text), "description" .= (d :: Text), "hash" .= (n <> "0") + , "returns" .= object [], "input" .= inp ] ++ [ "params" .= p | Just p <- [ps] ] + item = object + [ "type" .= ("object" :: Text), "title" .= ("Item" :: Text), "required" .= (["at", "pad"] :: [Text]) + , "properties" .= object ["at" .= object ["type" .= ("integer" :: Text)], "pad" .= object ["type" .= ("string" :: Text)]] ] + bytesSchema = object + [ "type" .= ("string" :: Text), "contentEncoding" .= ("base64" :: Text) + , "contentMediaType" .= ("application/octet-stream" :: Text), "x-plexus-binary" .= True ] + +-- | One call's input half at the service. +data InputCall = InputCall + { icEmit :: Value -> IO () + , icMeta :: Value + , icMethod :: Text + , icNext :: IORef Word64 -- ^ the next frame expected + , icItems :: IORef Int -- ^ items taken + , icGranted :: IORef Int -- ^ items granted in all + , icUngiven :: IORef Int -- ^ items consumed and not yet granted back + , icTag :: Maybe Text -- ^ the call's own param named input, if it had one + , icOver :: IORef Bool -- ^ the half is closed (refused, closed) + } + mockCode, mockState :: Text mockCode = "c_19ab" mockState = "s_7f2c" @@ -138,9 +288,44 @@ N.bind sock (N.SockAddrInet 0 (N.tupleToHostAddress (127, 0, 0, 1))) N.listen sock 16 port <- fromIntegral <$> N.socketPort sock - void $ forkIO $ acceptLoop sc sock + void $ forkIO $ acceptLoop (const (pure ())) sc sock pure (sock, port) +-- | SYNAPSE-40: today's service on a port already chosen (one a stopped +-- service had: a server come back). +withMockServiceOn :: Int -> IO a -> IO a +withMockServiceOn port act = bracket open N.close (const act) + where + open = do + sock <- N.socket N.AF_INET N.Stream N.defaultProtocol + N.setSocketOption sock N.ReuseAddr 1 + N.bind sock (N.SockAddrInet (fromIntegral port) (N.tupleToHostAddress (127, 0, 0, 1))) + N.listen sock 16 + void $ forkIO $ acceptLoop (const (pure ())) todaysService sock + pure sock + +-- | SYNAPSE-40: a service that stops as a process does. When the action +-- ends, its listener closes and so does every connection it accepted (a +-- FIN, as the kernel sends for a process that exits), so a client still +-- holding one sees its server go. +withEphemeralService :: Scenario -> (Int -> IO a) -> IO a +withEphemeralService sc act = do + accepted <- newIORef [] + bracket (open accepted) (stop accepted) (\(_, port) -> act port) + where + open accepted = do + sock <- N.socket N.AF_INET N.Stream N.defaultProtocol + N.setSocketOption sock N.ReuseAddr 1 + N.bind sock (N.SockAddrInet 0 (N.tupleToHostAddress (127, 0, 0, 1))) + N.listen sock 16 + port <- fromIntegral <$> N.socketPort sock + void $ forkIO $ acceptLoop (\c -> atomicModifyIORef' accepted (\cs -> (c : cs, ()))) sc sock + pure (sock, port) + stop accepted (sock, _) = do + N.close sock + cs <- readIORef accepted + mapM_ (\c -> void (try (N.shutdown c N.ShutdownBoth) :: IO (Either SomeException ()))) cs + -- | Serve until killed, printing the port (for transcripts by hand). serveMockService :: Scenario -> IO () serveMockService sc = withMockService sc $ \port -> do @@ -148,33 +333,41 @@ hFlush stdout forever (threadDelay 1000000) -acceptLoop :: Scenario -> N.Socket -> IO () -acceptLoop sc sock = do +acceptLoop :: (N.Socket -> IO ()) -> Scenario -> N.Socket -> IO () +acceptLoop onAccept sc sock = do r <- try (N.accept sock) case r of Left (_ :: SomeException) -> pure () -- the service was closed Right (conn, _) -> do + onAccept conn void $ forkIO $ do _ <- try (session conn) :: IO (Either SomeException ()) N.close conn - acceptLoop sc sock + acceptLoop onAccept sc sock where session conn = do pending <- WS.makePendingConnection conn WS.defaultConnectionOptions -- the credential the upgrade carried, if any let bearer = lookup "Authorization" (WS.requestHeaders (WS.pendingRequest pending)) + readIORef upgradeDelay >>= \d -> if d > 0 then threadDelay d else pure () c <- WS.acceptRequest pending atomicModifyIORef' connectionsAccepted (\n -> (n + 1, ())) + atomicModifyIORef' connectionsOpen (\n -> (n + 1, ())) next <- newIORef (100 :: Int) - forever $ do - msg <- WS.receiveData c - case decode msg of - Just (Object o) -> handle sc c next (isBearer bearer) o - _ -> pure () + inputs <- newIORef Map.empty + flip finally (atomicModifyIORef' connectionsOpen (\n -> (n - 1, ()))) $ forever $ do + dm <- WS.receiveDataMessage c + case dm of + WS.Binary bytes -> binaryInput inputs (LBS.toStrict bytes) + WS.Text msg _ -> case decode msg of + Just (Object o) + | str "method" o `elem` ["menger.input", "menger.end"] -> jsonInput inputs o + | otherwise -> handle sc c next inputs (isBearer bearer) o + _ -> pure () isBearer = maybe False (BS8.isPrefixOf "Bearer ") -handle :: Scenario -> WS.Connection -> IORef Int -> Bool -> Object -> IO () -handle sc c next signedIn o = do +handle :: Scenario -> WS.Connection -> IORef Int -> IORef (Map.Map Int InputCall) -> Bool -> Object -> IO () +handle sc c next inputs signedIn o = do let rid = KM.lookup "id" o method = str "method" o params = case KM.lookup "params" o of { Just (Object p) -> p; _ -> KM.empty } @@ -183,24 +376,35 @@ then do atomicModifyIORef' unsubscribes (\us -> (maybe Null id (KM.lookup "params" o) : us, ())) send (object ["jsonrpc" .= ("2.0" :: Text), "id" .= rid, "result" .= True]) - else handleCall sc c next signedIn o rid method params + else handleCall sc c next inputs signedIn o rid method params where send :: Value -> IO () send = WS.sendTextData c . encode -handleCall :: Scenario -> WS.Connection -> IORef Int -> Bool -> Object -> Maybe Value -> Text -> Object -> IO () -handleCall sc c next signedIn _o rid method params = do +handleCall :: Scenario -> WS.Connection -> IORef Int -> IORef (Map.Map Int InputCall) -> Bool -> Object -> Maybe Value -> Text -> Object -> IO () +handleCall sc c next inputs signedIn _o rid method params = do sub <- atomicModifyIORef' next (\n -> (n + 1, n)) send (object ["jsonrpc" .= ("2.0" :: Text), "id" .= rid, "result" .= sub]) let emit item = send (object [ "jsonrpc" .= ("2.0" :: Text), "method" .= ("subscription" :: Text) , "params" .= object ["subscription" .= sub, "result" .= item] ]) meta = object ["provenance" .= (["menger"] :: [Text]), "plexus_hash" .= ("h0" :: Text), "timestamp" .= (0 :: Int)] + -- RETURNS-36: a schema as plexus 0.7 states it (its methods' cardinality and returns) dat :: Text -> Value -> IO () - dat ct v = emit (object ["type" .= ("data" :: Text), "metadata" .= meta, "content_type" .= ct, "content" .= v]) + dat ct v = do + as070 <- readIORef served070 + emit (object ["type" .= ("data" :: Text), "metadata" .= meta, "content_type" .= ct + , "content" .= (if ".schema" `T.isSuffixOf` ct && not as070 then withContract v else v)]) + -- RETURNS-36: plexus 0.7's error frame — the typed RemoteError the + -- message names, and AUTH-2's refusal fields beside it err :: Text -> [(K.Key, Value)] -> IO () - err m extra = emit (Object (KM.fromList ( - [("type", "error"), ("metadata", meta), ("message", String m), ("recoverable", Bool False)] <> extra))) + err m extra = do + as070 <- readIORef served070 + -- as plexus-core writes it: message, code and spec/05's fields + -- always; 0.8's typed error beside them (the 0.7.0 line has none) + emit (Object (KM.fromList ( + [("type", "error"), ("metadata", meta), ("message", String m), ("code", String (code070 m extra)), ("recoverable", Bool False)] + <> [ ("error", remoteError m extra) | not as070 ] <> extra))) done = emit (object ["type" .= ("done" :: Text), "metadata" .= meta]) case method of "_info" -> do @@ -241,6 +445,21 @@ "tickets.ask" -> void $ forkIO (askBack emit meta dat err >> done) -- SYNAPSE-28: a stream that never ends by itself (until unsubscribed) "tickets.watch" -> dat "tickets.watch" (object ["type" .= ("watching" :: Text)]) + -- BIDIR-18: a method with an input half: credit at once, then the + -- frames as they come (jsonInput, binaryInput) + _ | inner `elem` ["stream.lines", "stream.ingest", "stream.audio", "stream.tagged"] -> do + plan <- readIORef inputPlan + ic <- InputCall emit meta inner <$> newIORef 0 <*> newIORef 0 <*> newIORef (planWindow plan) + <*> newIORef 0 <*> pure (case KM.lookup "input" args of { Just (String t) -> Just t; _ -> Nothing }) + <*> newIORef False + atomicModifyIORef' inputs (\m -> (Map.insert sub ic m, ())) + emit (object ["type" .= ("credit" :: Text), "n" .= planWindow plan]) + "menger.ir" -> do + atomicModifyIORef' irAsked (\as -> (as ++ [maybe (Object KM.empty) id (KM.lookup "params" params)], ())) + answer <- readIORef irAnswer + case answer of + Just v -> dat "menger.ir" v >> done + Nothing -> err "Method not found: menger.ir" [] >> done "tickets.get" | renamed -> err "Method not found: tickets.get" [] >> done "tickets.fetch" | renamed -> callMethod sc signedIn "tickets.get" args dat err >> done "tickets.schema" | renamed, scView sc /= AnonymousView, not (scCatalog sc) -> @@ -255,6 +474,123 @@ send :: Value -> IO () send = WS.sendTextData c . encode +-- | BIDIR-18: a JSON input frame or end, for the call it names. +jsonInput :: IORef (Map.Map Int InputCall) -> Object -> IO () +jsonInput inputs o = do + let params = case KM.lookup "params" o of { Just (Object p) -> p; _ -> KM.empty } + num k = case KM.lookup k params of { Just (Number n) -> Just (round n); _ -> Nothing } + case (num "subscription", num "seq") of + (Just sub, Just sq) -> do + calls <- readIORef inputs + case Map.lookup sub calls of + Nothing -> violation ("a frame for no call: " <> T.pack (show sub)) + Just ic + | str "method" o == "menger.end" -> do + atomicModifyIORef' inputReceived (\rs -> (rs ++ [ReceivedEnd (fromIntegral sq)], ())) + expected <- readIORef (icNext ic) + if fromIntegral sq /= expected then violation ("end seq " <> T.pack (show sq) <> ", frames " <> T.pack (show expected)) else pure () + finish ic + | otherwise -> do + let items = case KM.lookup "items" params of { Just (Array a) -> V.toList a; _ -> [] } + atomicModifyIORef' inputReceived (\rs -> (rs ++ [ReceivedJson (fromIntegral sq) items], ())) + taken ic (fromIntegral sq) (length items) + _ -> violation "an input frame without subscription or seq" + +-- | BIDIR-18: a binary input frame: @[0x01][subscription u64][seq u64][payload]@. +binaryInput :: IORef (Map.Map Int InputCall) -> BS.ByteString -> IO () +binaryInput inputs bytes + | BS.length bytes < 17 || BS.head bytes /= 0x01 = violation "a malformed binary frame" + | otherwise = do + let word b = foldl (\acc x -> (acc `shiftL` 8) .|. fromIntegral x) (0 :: Word64) (BS.unpack b) + sub = word (BS.take 8 (BS.drop 1 bytes)) + sq = word (BS.take 8 (BS.drop 9 bytes)) + payload = BS.drop 17 bytes + atomicModifyIORef' inputReceived (\rs -> (rs ++ [ReceivedBinary sub sq payload], ())) + calls <- readIORef inputs + case Map.lookup (fromIntegral sub) calls of + Nothing -> violation ("a binary frame for no call: " <> T.pack (show sub)) + Just ic -> taken ic sq 1 + +violation :: Text -> IO () +violation v = atomicModifyIORef' inputViolations (\vs -> (vs ++ [v], ())) + +-- | Frame @sq@ of @n@ items taken: checked against the sequence and the +-- credit, then acked and credited as the plan says. +taken :: InputCall -> Word64 -> Int -> IO () +taken ic sq n = do + over <- readIORef (icOver ic) + if over then pure () else do + plan <- readIORef inputPlan + expected <- readIORef (icNext ic) + if sq /= expected then violation ("out of sequence: " <> T.pack (show sq) <> ", expected " <> T.pack (show expected)) else pure () + writeIORef (icNext ic) (sq + 1) + total <- atomicModifyIORef' (icItems ic) (\k -> (k + n, k + n)) + granted <- readIORef (icGranted ic) + if total > granted then violation ("past credit: " <> T.pack (show total) <> " of " <> T.pack (show granted)) else pure () + let frames = fromIntegral (sq + 1) + errorItem kind = icEmit ic (object + [ "type" .= ("error" :: Text), "metadata" .= icMeta ic, "message" .= ("input refused: " <> kind) + , "code" .= ("-32602" :: Text), "error_kind" .= kind, "recoverable" .= False, "seq" .= sq ]) + case (planDropAfter plan, planRefuse plan, planClose plan) of + (Just k, _, _) | frames >= k -> ioError (userError "dropped mid-input") + (_, Just (k, kind), _) | frames >= k -> do + writeIORef (icOver ic) True + icEmit ic (object ["type" .= ("input_closed" :: Text), "reason" .= kind]) + errorItem kind + (_, _, Just (k, reason)) | frames >= k -> do + writeIORef (icOver ic) True + icEmit ic (object ["type" .= ("input_closed" :: Text), "reason" .= reason, "ack" .= sq]) + icEmit ic (object + [ "type" .= ("error" :: Text), "metadata" .= icMeta ic, "message" .= ("the call was asked again: " <> reason) + , "code" .= ("-32001" :: Text), "error_kind" .= ("unauthenticated" :: Text), "recoverable" .= False ]) + _ | planStingy plan -> pure () + | otherwise -> do + ungiven <- atomicModifyIORef' (icUngiven ic) (\u -> (u + n, u + n)) + if ungiven * 2 >= planWindow plan + then do + writeIORef (icUngiven ic) 0 + modifyIORef' (icGranted ic) (+ ungiven) + icEmit ic (object ["type" .= ("ack" :: Text), "seq" .= sq]) + icEmit ic (object ["type" .= ("credit" :: Text), "n" .= ungiven]) + else pure () + +-- | The input ended: the last ack, what was taken, done. +finish :: InputCall -> IO () +finish ic = do + n <- readIORef (icItems ic) + next <- readIORef (icNext ic) + if next > 0 then icEmit ic (object ["type" .= ("ack" :: Text), "seq" .= (next - 1)]) else pure () + icEmit ic (object + [ "type" .= ("data" :: Text), "metadata" .= icMeta ic, "content_type" .= icMethod ic + , "content" .= object (["type" .= ("taken" :: Text), "items" .= n, "frames" .= next] ++ [ "tag" .= t | Just t <- [icTag ic] ]) ]) + icEmit ic (object ["type" .= ("done" :: Text), "metadata" .= icMeta ic]) + +-- | RETURNS-36: the plexus 0.7 'RemoteError' an error the mock answers is: +-- a refusal (AUTH-2's fields) a missing grant, a "Method not found: a.m" or +-- "Activation not found: a" one of those, anything else an execution failure. +remoteError :: Text -> [(K.Key, Value)] -> Value +remoteError m extra + | lookup "error_kind" extra == Just (String "forbidden") = object + [ "kind" .= ("forbidden" :: Text), "reason" .= ("missing_grant" :: Text) + , "grant" .= field "grant", "scope" .= field "scope" + , "roles" .= maybe (toJSON ([] :: [Text])) id (lookup "roles" extra) + , "held_on" .= maybe (toJSON ([] :: [Text])) id (lookup "held_on" extra) ] + | Just rest <- T.stripPrefix "Method not found: " m + , (a, dm) <- T.breakOnEnd "." rest, not (T.null a) = object + [ "kind" .= ("method_not_found" :: Text), "activation" .= T.dropEnd 1 a, "method" .= dm ] + | Just a <- T.stripPrefix "Activation not found: " m = object + [ "kind" .= ("activation_not_found" :: Text), "activation" .= a ] + | otherwise = object [ "kind" .= ("execution" :: Text), "message" .= m ] + where + field k = maybe (String "") id (lookup k extra) + +-- | The JSON-RPC code a service puts on an error frame (spec/05). +code070 :: Text -> [(K.Key, Value)] -> Text +code070 m extra + | lookup "error_kind" extra == Just (String "forbidden") = "-32003" + | "not found" `T.isInfixOf` m = "-32601" + | otherwise = "-32000" + -- | SCAFFOLD-21: the answers to 'askBack's requests (@menger.respond@'s -- @response_data@), as they arrive on any connection. {-# NOINLINE responses #-} @@ -299,7 +635,10 @@ -> (Text -> Value -> IO ()) -> (Text -> [(K.Key, Value)] -> IO ()) -> IO () callMethod' sc _signedIn inner args dat err = case inner of - "menger.schema" -> dat "menger.schema" (rootSchema sc) + "menger.schema" -> do + -- RETURNS-40: a service that writes its IR lists `ir` among its own methods + answer <- readIORef irAnswer + dat "menger.schema" (maybe id (const withIr) answer (rootSchema sc)) "tickets.schema" | scCatalog sc -> do Just (Object o) <- decodeFileStrict "test/fixtures/find-tickets.json" dat "tickets.schema" (Object (catalogView sc o)) @@ -370,6 +709,16 @@ _ <- NB.recv sock' 4096 N.close sock' +-- | RETURNS-40: a root schema with the `ir` method beside its own. +withIr :: Value -> Value +withIr (Object o) = Object (KM.insert "methods" (Array (V.snoc ms irMethod)) o) + where + ms = case KM.lookup "methods" o of { Just (Array a) -> a; _ -> mempty } + irMethod = object + [ "name" .= ("ir" :: Text), "description" .= ("The service's IR" :: Text), "hash" .= ("ir0" :: Text) + , "cardinality" .= ("one" :: Text), "returns" .= object [] ] +withIr v = v + rootSchema :: Scenario -> Value rootSchema sc = object $ [ "namespace" .= ("menger" :: Text), "version" .= ("1.0.0" :: Text) @@ -395,7 +744,7 @@ , "methods" .= [ m "providers" "The ways in this server offers" , m "login" "Sign in \x2014 a person through the browser, an agent with its key" , m "signup" "Create an account, or ask for access" ] ] - where m n d = object ["name" .= (n :: Text), "description" .= (d :: Text), "hash" .= (n <> "0"), "public" .= True] + where m n d = object ["name" .= (n :: Text), "description" .= (d :: Text), "hash" .= (n <> "0"), "public" .= True, "returns" .= object []] ticketsSchema :: Scenario -> Value ticketsSchema sc = object $ @@ -409,7 +758,7 @@ where caller = scView sc == CallerView method (n, d, held, target) = object $ - [ "name" .= (n :: Text), "description" .= (d :: Text), "hash" .= (n <> "0") + [ "name" .= (n :: Text), "description" .= (d :: Text), "hash" .= (n <> "0"), "returns" .= object [] , "params" .= object ["type" .= ("object" :: Text), "required" .= (["id"] :: [Text]), "properties" .= object ["id" .= object ["type" .= ("string" :: Text), "description" .= ("Ticket id, e.g. MNG-2" :: Text)]]] ] <> (if caller then [ "grant" .= ("tickets." <> n), "held_on" .= (held :: [Text]) ] <> maybe [] (\t -> ["target" .= (t :: Text)]) target else []) diff --git a/test/OutputSpec.hs b/test/OutputSpec.hs --- a/test/OutputSpec.hs +++ b/test/OutputSpec.hs @@ -55,7 +55,7 @@ outputSpec exe = describe "synapse -o FILE (SYNAPSE-39)" $ do it "is this build" $ do (_, out, _) <- readProcessWithExitCode exe ["--version"] "" - out `shouldStartWith` "3.17.3" + out `shouldStartWith` "4.0.0" forM_ [ ([], "", ["tickets", "get", "--id", "MENGER-12"]) , (["-j"], " with -j", ["tickets", "get", "--id", "MENGER-12"]) @@ -211,6 +211,43 @@ err `shouldContain` "tickets.set_status" doesFileExist file >>= (`shouldBe` False) leftovers dir "answer.out" >>= (`shouldBe` []) + + -- RETURNS-36: synapse 4.0 reads the published 0.7.0 line too — every + -- server running today: its methods' streaming flags, its error frames' + -- spec/05 fields + describe "against a service on the published 0.7.0 line" $ do + let as070 act = do + writeIORef served070 True + r <- try act + writeIORef served070 False + either (\(e :: SomeException) -> ioError (userError (show e))) pure r + it "an answer, and the same in FILE" $ as070 $ + withRun $ \dir spawn -> do + (code0, onStdout, err0) <- reading (spawn []) ["tickets", "get", "--id", "MENGER-12"] + (code0, err0) `shouldBe` (ExitSuccess, "") + onStdout `shouldContain` "MENGER-12" + let file = dir "answer.out" + (code, out, err) <- reading (spawn ["-o", file]) ["tickets", "get", "--id", "MENGER-12"] + (code, out, err) `shouldBe` (ExitSuccess, "", "") + readFile file >>= (`shouldBe` onStdout) + it "a stream's items in FILE (its streaming flag says many)" $ as070 $ + withRun $ \dir spawn -> do + let file = dir "answer.out" + (Just inp, Just out, Just err, ph) <- createProcess (spawn ["-j", "-o", file] ["tickets", "flood"]) + hClose inp + got <- waitUpTo 10 (doesFileExist file >>= \e -> if e then ("\"tick\"" `isInfixOf`) <$> readFile' file else pure False) + terminateProcess ph + _ <- timeout 5000000 (waitForProcess ph) + _ <- BS.hGetContents out + _ <- BS.hGetContents err + got `shouldBe` True + it "a refusal: exit 77, the grant said" $ as070 $ + withRunS (Scenario CallerView False True mockState False) $ \dir spawn -> do + let file = dir "answer.out" + (code, out, err) <- reading (spawn ["-j", "-o", file]) ["tickets", "set_status", "--id", "IDENTITY-3"] + (code, out) `shouldBe` (ExitFailure 77, "") + err `shouldContain` "tickets.set_status" + doesFileExist file >>= (`shouldBe` False) it "a two-way request's line goes to stderr, its answer to FILE" $ withRun $ \dir spawn -> do diff --git a/test/ParseSpec.hs b/test/ParseSpec.hs --- a/test/ParseSpec.hs +++ b/test/ParseSpec.hs @@ -55,7 +55,7 @@ describe "buildParamValue with arrays" $ do let emptyIR = IR - { irVersion = "2.0" + { irVersion = "3.0" , irHash = Nothing , irTypes = Map.empty , irMethods = Map.empty @@ -343,9 +343,11 @@ , mdFullPath = "t.create" , mdNamespace = "t" , mdDescription = Nothing - , mdStreaming = False , mdParams = params , mdReturns = RefJson + , mdError = Nothing + , mdProgress = Nothing + , mdCardinality = CardinalityOne , mdBidirType = Nothing , mdBidirResponseType = Nothing , mdBidirResponseSchema = Nothing diff --git a/test/PipeSpec.hs b/test/PipeSpec.hs --- a/test/PipeSpec.hs +++ b/test/PipeSpec.hs @@ -47,7 +47,7 @@ pipeSpec exe = describe "a closed stdout (SYNAPSE-26)" $ do it "is this build" $ do (_, out, _) <- readProcessWithExitCode exe ["--version"] "" - out `shouldStartWith` "3.17" + out `shouldStartWith` "4.0" -- one reader takes a byte and closes, one closes before anything is -- printed diff --git a/test/Plexus07.hs b/test/Plexus07.hs new file mode 100644 --- /dev/null +++ b/test/Plexus07.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + +-- | RETURNS-36: the test fixtures captured from 0.6-shaped services (menger's +-- schemas of 2026-10-15 and 2026-10-29, the mock service's own), as plexus +-- 0.7 states them. +-- +-- plexus 0.7 (RETURNS-1) states a method's cardinality where 0.6 had a +-- streaming flag, and synapse reads 0.7 only. The fixtures stay as they +-- were captured; 'asPlexus07' says each method's @cardinality@ — +-- @"many"@ where it said @streaming: true@, else @"one"@ — and drops the +-- flag. Nothing else moves: a method with no @returns@ stays without one +-- (and is no 0.7 schema). +module Plexus07 + ( asPlexus07 + , methodAs07 + , withContract + , methodWithContract + , renameParamsDef + ) where + +import Data.Aeson (Value(..)) +import qualified Data.Aeson.Key as K +import qualified Data.Aeson.KeyMap as KM +import Data.Text (Text) + +-- | A plugin schema — or a fixture's rows (@[{"path", "schema"}]@) — with +-- every method as 0.7 states it, its children's too. +asPlexus07 :: Value -> Value +asPlexus07 = \case + Object o -> Object (KM.mapWithKey key o) + Array a -> Array (fmap asPlexus07 a) + v -> v + where + key k v = case (k, v) of + ("methods", Array ms) -> Array (fmap methodAs07 ms) + ("schema", _) -> asPlexus07 v + ("children", Array cs) -> Array (fmap asPlexus07 cs) + _ -> v + +-- | One method schema as 0.7 states it. +methodAs07 :: Value -> Value +methodAs07 = \case + Object m | not (KM.member "cardinality" m) -> + let card = if KM.lookup "streaming" m == Just (Bool True) then "many" else "one" + in Object (KM.insert "cardinality" (String card) (KM.delete "streaming" m)) + Object m -> Object (KM.delete "streaming" m) + v -> v + +-- | 'asPlexus07', and each method that states no @returns@ (a fixture +-- written for a test of something else: auth's fields, help) given +-- @returns: {}@ — any JSON — as a 0.7 schema must state one. +withContract :: Value -> Value +withContract = \case + Object o -> Object (KM.mapWithKey key o) + Array a -> Array (fmap withContract a) + v -> v + where + key k v = case (k, v) of + ("methods", Array ms) -> Array (fmap methodWithContract ms) + ("schema", _) -> withContract v + ("children", Array cs) -> Array (fmap withContract cs) + _ -> v + +-- | One method as 'withContract' states it. +methodWithContract :: Value -> Value +methodWithContract v = case methodAs07 v of + Object m | not (KM.member "returns" m) -> Object (KM.insert "returns" (Object KM.empty) m) + m -> m + +-- | In every method's params of a plugin schema, the @$defs@ entry @from@ +-- renamed @to@, and every @$ref@ to it. +renameParamsDef :: Text -> Text -> Value -> Value +renameParamsDef from to = \case + Object o -> Object (KM.mapWithKey (\k v -> if k == "methods" then onMethods v else v) o) + v -> v + where + onMethods (Array ms) = Array (fmap onMethod ms) + onMethods v = v + onMethod (Object m) = Object (KM.mapWithKey (\k v -> if k == "params" then rename v else v) m) + onMethod v = v + fromRef = String ("#/$defs/" <> from) + rename = \case + Object o -> Object (KM.fromList [ (key k, rename v) | (k, v) <- KM.toList o ]) + Array a -> Array (fmap rename a) + v | v == fromRef -> String ("#/$defs/" <> to) + v -> v + key k = if k == K.fromText from then K.fromText to else k diff --git a/test/ReconnectSpec.hs b/test/ReconnectSpec.hs --- a/test/ReconnectSpec.hs +++ b/test/ReconnectSpec.hs @@ -34,7 +34,7 @@ import Test.Hspec import Plexus.Client (SubstrateConfig(..)) -import Plexus.Schema.Recursive (MethodSchema(..), MethodRole(..)) +import Plexus.Schema.Recursive (Cardinality(..), MethodSchema(..), MethodRole(..)) import qualified Plexus.Transport as ST import qualified Plexus.Types as PT import Synapse.Reconnect @@ -151,7 +151,8 @@ method :: Text -> Maybe Text -> Maybe Value -> MethodSchema method name grp params = MethodSchema { methodName = name, methodDescription = "", methodHash = "h", methodParams = params - , methodReturns = Nothing, methodStreaming = False, methodBidirectional = False + , methodReturns = Object mempty, methodError = Nothing, methodProgress = Nothing + , methodCardinality = CardinalityOne, methodBidirectional = False, methodHttpMethod = "POST" , methodRequestType = Nothing, methodResponseType = Nothing, methodDeprecation = Nothing , methodParamSchemas = Nothing, methodRole = MethodRoleRpc, methodLongDescription = Nothing , methodGrant = Nothing, methodTarget = Nothing, methodHeldOn = Nothing, methodPublic = False @@ -216,7 +217,7 @@ withService [Answer] $ \h -> do sock <- holderSocket acc <- newIORef (0 :: Int) - Hold.holderCall sock (cfgFor (servicePort h)) (pure ()) "t.call" (object ["method" .= ("t.m" :: Text)]) + Hold.holderCall sock "test" (cfgFor (servicePort h)) (pure ()) "t.call" (object ["method" .= ("t.m" :: Text)]) (\i -> if isData i then modifyIORef' acc (+ 1) else pure ()) readIORef acc `shouldReturn` 1 outageSpec @@ -365,11 +366,11 @@ throughHolder :: IO () throughHolder = do sock <- holderSocket - _ <- forkIO $ Hold.runHolder (Hold.HoldOpts sock 600) `catch'` () + _ <- forkIO $ Hold.runHolder (Hold.holdOpts sock 600) `catch'` () let wait (0 :: Int) = pure () wait n = doesFileExist sock >>= \ok -> if ok then pure () else threadDelay 20000 >> wait (n - 1) wait 250 - _ <- Hold.installRouter Hold.RouterOpts { Hold.roHold = Just (const (pure (Just sock))), Hold.roHoldFor = 600 } + _ <- Hold.installRouter Hold.RouterOpts { Hold.roHold = Just (const (pure (Just "test"))), Hold.roSocket = sock, Hold.roHoldFor = 600, Hold.roVersion = "" } pure () where catch' act v = void (try act :: IO (Either SomeException ())) >> pure v diff --git a/test/RenderSpec.hs b/test/RenderSpec.hs --- a/test/RenderSpec.hs +++ b/test/RenderSpec.hs @@ -13,7 +13,7 @@ -- service that says none of the new fields still renders sensibly. module Main (main) where -import Data.Aeson (Value) +import Data.Aeson (Value(..)) import Data.Aeson.QQ.Simple (aesonQQ) import qualified Data.Map.Strict as Map import Data.Maybe (fromJust) @@ -22,7 +22,7 @@ import qualified Data.Text.IO as TIO import Test.Hspec -import Plexus.Schema.Recursive (ChildSummary(..), MethodExample(..), MethodRole(..), MethodSchema(..), PluginSchema(..)) +import Plexus.Schema.Recursive (Cardinality(..), ChildSummary(..), MethodExample(..), MethodRole(..), MethodSchema(..), PluginSchema(..)) import Synapse.Algebra.Render (Listing(..), renderListing, renderSchema, defaultStyle, summarize, fitText) import Synapse.CLI.Help (MethodPage(..), renderMethodPage, renderExample, shellQuote) import Synapse.IR.Builder (extractMethodDef) @@ -31,7 +31,8 @@ method :: Text -> Text -> Maybe Value -> MethodSchema method name desc params = MethodSchema { methodName = name, methodDescription = desc, methodHash = "h", methodParams = params - , methodReturns = Nothing, methodStreaming = True, methodBidirectional = False + , methodReturns = Object mempty, methodError = Nothing, methodProgress = Nothing + , methodCardinality = CardinalityMany, methodBidirectional = False, methodHttpMethod = "POST" , methodRequestType = Nothing, methodResponseType = Nothing, methodDeprecation = Nothing , methodParamSchemas = Nothing, methodRole = MethodRoleRpc , methodLongDescription = Nothing, methodGrant = Nothing, methodTarget = Nothing, methodHeldOn = Nothing, methodPublic = False @@ -127,7 +128,7 @@ pageOf :: Bool -> MethodSchema -> (MethodDef, Text) pageOf caller ms = - let (types, md) = extractMethodDef "tickets" "tickets" ms + let (types, md) = either (error . show) id (extractMethodDef "tickets" "tickets" ms) ir = emptyIR { irMethods = Map.singleton (mdFullPath md) md, irTypes = types } page = MethodPage { mpProgram = "synapse -P 4455", mpTarget = "menger tickets " <> methodName ms @@ -143,7 +144,7 @@ "properties": {"id": {"type": "string", "description": "Ticket id, e.g. MNG-2"}, "status": {"type": "string", "description": "New status"}}, "required": ["id", "status"]}|])) - (types, md) = extractMethodDef "tickets" "tickets" old + (types, md) = either (error . show) id (extractMethodDef "tickets" "tickets" old) ir = emptyIR { irMethods = Map.singleton (mdFullPath md) md, irTypes = types } page = MethodPage { mpProgram = "synapse", mpTarget = "menger tickets set_status", mpSchema = Nothing, mpCaller = False } in renderMethodPage page ir md diff --git a/test/Req8RenderSpec.hs b/test/Req8RenderSpec.hs --- a/test/Req8RenderSpec.hs +++ b/test/Req8RenderSpec.hs @@ -35,6 +35,7 @@ , psVersion = "1.0.0" , psDescription = "Test service" , psLongDescription = Nothing + , psSelfHash = Nothing , psHash = "h1" , psMethods = [method1] , psChildren = Nothing @@ -47,9 +48,12 @@ , methodDescription = "List things" , methodHash = "h2" , methodParams = Just paramsSchema - , methodReturns = Nothing - , methodStreaming = False + , methodReturns = [aesonQQ|{}|] + , methodError = Nothing + , methodProgress = Nothing + , methodCardinality = Plexus.Schema.Recursive.CardinalityOne , methodBidirectional = False + , methodHttpMethod = "POST" , methodRequestType = Nothing , methodResponseType = Nothing , methodDeprecation = Nothing @@ -96,7 +100,7 @@ putStrLn $ " [FAIL] " <> name <> ": " <> reason IORef.modifyIORef' failures (+ 1) - let (types, md) = extractMethodDef "svc" "svc" (head (psMethods fixture)) + let (types, md) = either (error . show) id (extractMethodDef "svc" "svc" (head (psMethods fixture))) ir = emptyIR { irMethods = Map.singleton (mdFullPath md) md, irTypes = types } out = renderMethodHelp ir md