plexus-synapse 3.17.3 → 4.0.0

raw patch · 37 files changed

+6008/−554 lines, 37 filesdep ~aesondep ~plexus-protocolPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aeson, plexus-protocol

API changes (from Hackage documentation)

Files

• CHANGELOG.md +60/−0
• README.md +1199/−0
• app/Main.hs +186/−43
• plexus-synapse.cabal +103/−12
• src/Synapse/Algebra/Recursion.hs +4/−0
• src/Synapse/CLI/Help.hs +37/−2
• src/Synapse/CLI/Parse.hs +2/−0
• src/Synapse/Find.hs +25/−2
• src/Synapse/Hold.hs +719/−202
• src/Synapse/IR/Builder.hs +332/−63
• src/Synapse/IR/Read.hs +99/−39
• src/Synapse/IR/Types.hs +50/−43
• src/Synapse/Identity/Session.hs +18/−2
• src/Synapse/Input.hs +589/−0
• src/Synapse/Reconnect.hs +2/−2
• src/Synapse/Schema/Types.hs +63/−5
• src/Synapse/SchemaStore.hs +49/−3
• src/Synapse/Transport.hs +157/−1
• test/AuthSpec.hs +104/−9
• test/BidirIntegrationSpec.hs +4/−4
• test/DeprecationSpec.hs +12/−6
• test/FindSpec.hs +2/−2
• test/HoldSpec.hs +532/−30
• test/IR12MethodRoleSpec.hs +16/−9
• test/IR3Spec.hs +577/−0
• test/IRCoverageSpec.hs +222/−35
• test/IRFixture.hs +7/−1
• test/IRSpec.hs +1/−1
• test/InputSpec.hs +317/−0
• test/MockService.hs +370/−21
• test/OutputSpec.hs +38/−1
• test/ParseSpec.hs +4/−2
• test/PipeSpec.hs +1/−1
• test/Plexus07.hs +88/−0
• test/ReconnectSpec.hs +6/−5
• test/RenderSpec.hs +6/−5
• test/Req8RenderSpec.hs +7/−3

@@ -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<T>`, 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.

@@ -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/<backend>/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/<backend>` 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<Item = EchoEvent> + 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<Item = EchoEvent> + 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://<app>.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 <string> (required)+      Discriminator for cone lookup (by_id, by_name)++  --identifier.name <string> (required if type=by_name)+  --prompt <string> (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 <string[]>]    Every commit in previous..revision…+  tickets link_commits      --commits <string[]>      Commit references, in link order+  tickets unlink_commits    --commits <string[]>      Commit references to remove…++Run 'synapse -P 4455 menger tickets link_commits --help' for its options.+```++`synapse [OPTIONS] _find <backend> [activation…] <words…> [--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. `<method> --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=<jwt>` 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/<backend>/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 <backend> show++# Set a value (auto-wrapped as literal: unless you provide a scheme)+synapse _self <backend> set cookie access_token "eyJ..."+synapse _self <backend> set header X-API-Key "env://MY_API_KEY"++# Read from stdin (always literal:, bypasses the scheme heuristic)+cat my-jwt.txt | synapse _self <backend> set-from-stdin cookie access_token++# Import a JWT file into cookies.access_token+synapse _self <backend> import-token ~/Downloads/jwt.txt++# Resolve a single value (debug): prints the resolved concrete value+synapse _self <backend> resolve cookie access_token++# Remove entries+synapse _self <backend> unset cookie access_token+synapse _self <backend> 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=<jwt>+synapse --token eyJ... <backend> <method>++# SYNAPSE_TOKEN env+SYNAPSE_TOKEN=eyJ... synapse <backend> <method>++# --token-file reads from a path+synapse --token-file ~/tokens/uscis <backend> <method>++# --cookie / --header add arbitrary key/values on the upgrade request+synapse --cookie session=abc --header X-Trace-Id=xyz <backend> <method>+```++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/<backend>` 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:<jwt>` 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<n>.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<T>`, 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<Bytes>` (`"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,+  `<ns>.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 <backend> 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 `<ns.Type>[.<variant>].<field>`, `<method path>(<param>)`,+  `<method path> 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 "<path>"` (a static or dynamic child's return: its client). An+  rpc method with no `returns` is refused at `<path> 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

@@ -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

@@ -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,

@@ -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)

@@ -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>]")+                          ["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

@@ -66,6 +66,8 @@   ( -- * Command line     parsePathAndParams   , pairFlags+  , FlagArity(..)+  , takeFlag      -- * Parsing   , parseParams

@@ -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)

@@ -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 -- (@<backend>.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 <ns>.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"}}          <ns>.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

@@ -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 (@<backend>.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 <backend> <root>@ prints. The IR a service writes itself+--   (plexus-core's @<service>.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<T, E> 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<Bytes> 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<Bytes>@ 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

@@ -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 }

@@ -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<T, E>@ or+    --   @Progress<T, P>@, @T@ alone). From @MethodSchema.returns@.+  , mdError       :: Maybe TypeRef+    -- ^ The error type @E@ of a @Result<T, E>@ 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<StandardRequest<T>, StandardResponse<T>>.@@ -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"

@@ -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

@@ -0,0 +1,589 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | BIDIR-18: synapse calls a method with an input half (@Input<T>@,+-- 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<Bytes>@): 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, @<ns>.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 @<ns>.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

@@ -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)   }

@@ -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

@@ -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" ]

@@ -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,+--   @<backend>.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).

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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  -- --------------------------------------------------------------------------- 

@@ -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

@@ -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 (@<service>.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 <backend> 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+      _ -> []

@@ -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<Bytes> 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 ])

@@ -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.

@@ -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)

@@ -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 <bytes>]"+    (_, 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