tuispec 0.1.0.0 → 0.2.0.0
raw patch · 15 files changed
+3995/−1102 lines, 15 filesdep +scientificdep ~tasty-hunitdep ~unix
Dependencies added: scientific
Dependency ranges changed: tasty-hunit, unix
Files
- CHANGELOG.md +25/−0
- README.md +26/−5
- SERVER.md +198/−96
- SKILL.md +157/−46
- SPEC.md +83/−10
- app/Main.hs +341/−4
- src/TuiSpec.hs +6/−2
- src/TuiSpec/Internal.hs +142/−0
- src/TuiSpec/Render.hs +8/−41
- src/TuiSpec/Replay.hs +432/−0
- src/TuiSpec/Runner.hs +186/−160
- src/TuiSpec/Server.hs +1809/−726
- src/TuiSpec/Types.hs +35/−3
- test/Spec.hs +531/−4
- tuispec.cabal +16/−5
CHANGELOG.md view
@@ -1,5 +1,30 @@ # Changelog +## 0.2.0.0 — 2026-02-24++* Add `waitForStable` primitive (DSL + JSON-RPC) to replace fixed sleeps with debounce-based viewport stability checks.+* Overhaul `SKILL.md` around a golden-path workflow using `waitForStable`, with a wait-strategy decision guide and common failure troubleshooting.+* Introduce server v2 APIs including launch `cwd`/nullable `env`, per-call ambiguity control, filtered `currentView`, render-in-one-step snapshot flows, notifications, batch operations, and JSONL recording/replay.+* Add `tuispec replay` CLI command and expand end-to-end protocol coverage in tests and docs.+* Record viewport frames in JSONL sessions and replay them on the terminal with `tuispec replay`, using delta compression for efficient frame storage. Keyframe and delta metadata are preserved through replay for frame reconstruction.+* Add interactive replay controls: Space to pause/resume, Left/Right to step frames, Up/Down to skip 5 frames, r to redraw from last keyframe, q to quit.+* Add `--show-input` replay flag to display the last input action on a status line below the viewport.+* Add `--version` flag to the CLI.+* Include tuispec version in `initialize` response and snapshot `meta.json`.+* Fix theme-aware color rendering for light/dark PNG snapshots.+* Use alternate screen buffer for replay to avoid polluting terminal scrollback.+* Fix test flakiness caused by orphaned PTY child processes between server tests.++## 0.1.1.1 — 2026-02-23++* Fix PTY teardown to avoid hangs when waiting for child exit by using bounded `getProcessExitCode` polling.+* Add regression coverage and documentation clarifying that selector matching runs on rendered viewport text (ANSI control/style escapes are interpreted).++## 0.1.1.0 — 2026-02-23++* Add optional `env` parameter to `launch` (DSL + JSON-RPC) to override process environment variables.+* Add `app` constructor helper and update docs/examples to use it.+ ## 0.1.0.0 — 2026-02-23 * Initial release
README.md view
@@ -26,6 +26,8 @@ - **Text selectors** — `Exact`, `Regex`, `At`, `Within`, `Nth` - **`tasty` integration** — tests are regular `tasty` test trees - **JSON-RPC server** — agentic orchestration of TUIs via `tuispec server`+- **Server notifications** — optional `view.changed` push events (debounced)+- **Batch + replay** — JSON-RPC batch execution and JSONL recording/replay - **REPL sessions** — ad-hoc exploration with `withTuiSession` ## Quick start@@ -42,7 +44,7 @@ main = defaultMain $ testGroup "demo" [ tuiTest defaultRunOptions "counter" $ \tui -> do- launch tui (App "my-tui" [])+ launch tui (app "my-tui" []) waitForText tui (Exact "Ready") press tui (CharKey '+') expectSnapshot tui "counter-updated"@@ -81,6 +83,7 @@ ```haskell launch :: Tui -> App -> IO ()+app :: FilePath -> [String] -> App press :: Tui -> Key -> IO () pressCombo :: Tui -> [Modifier] -> Key -> IO () typeText :: Tui -> Text -> IO ()@@ -91,6 +94,7 @@ ```haskell waitForText :: Tui -> Selector -> IO ()+waitForStable :: Tui -> WaitOptions -> Int -> IO () expectVisible :: Tui -> Selector -> IO () expectNotVisible :: Tui -> Selector -> IO () expectSnapshot :: Tui -> SnapshotName -> IO ()@@ -107,6 +111,9 @@ Nth Int Selector -- pick the Nth match ``` +`waitForText`/selector matching runs against the rendered viewport text+(after ANSI control/style escapes are interpreted), not raw escape bytes.+ ### Keys Named keys: `Enter`, `Esc`, `Tab`, `Backspace`, arrows, `FunctionKey 1..12`@@ -162,14 +169,22 @@ ```bash cat <<'JSON' | cabal run tuispec -- server --artifact-dir artifacts/server {"jsonrpc":"2.0","id":1,"method":"initialize","params":{"name":"rpc-demo","terminalCols":134,"terminalRows":40}}-{"jsonrpc":"2.0","id":2,"method":"launch","params":{"command":"sh","args":[]}}+{"jsonrpc":"2.0","id":2,"method":"launch","params":{"command":"sh","args":["-lc","printf 'READY\\n'; exec sh"],"cwd":".","env":{"DEMO_FLAG":"1","CLAUDECODE":null},"readySelector":{"type":"exact","text":"READY"}}} {"jsonrpc":"2.0","id":3,"method":"sendLine","params":{"text":"printf 'hello from rpc\\n'"}} {"jsonrpc":"2.0","id":4,"method":"waitForText","params":{"selector":{"type":"exact","text":"hello from rpc"}}}-{"jsonrpc":"2.0","id":5,"method":"dumpView","params":{"name":"after-hello"}}-{"jsonrpc":"2.0","id":6,"method":"server.shutdown","params":{}}+{"jsonrpc":"2.0","id":5,"method":"dumpView","params":{"name":"after-hello","format":"both"}}+{"jsonrpc":"2.0","id":6,"method":"currentView","params":{"entireRow":1}}+{"jsonrpc":"2.0","id":7,"method":"server.shutdown","params":{}} JSON ``` +`launch.params.env` is optional. Values set/override inherited variables and+`null` unsets inherited variables for that launch. `launch.params.cwd` sets the+child working directory.++`currentView` coordinates are 1-based. For row/col-oriented filters, `0` means+"entire row range" / "entire column range".+ Input examples: ```json@@ -178,13 +193,19 @@ {"jsonrpc":"2.0","id":9,"method":"sendText","params":{"text":"hello"}} ``` +Replay a recording JSONL file:++```bash+cabal run tuispec -- replay artifacts/server-tests/recording/session.jsonl --speed as-fast-as-possible+```+ ## REPL-style sessions For ad-hoc exploration outside `tasty`: ```haskell withTuiSession defaultRunOptions "demo" $ \tui -> do- launch tui (App "sh" [])+ launch tui (app "sh" []) sendLine tui "echo hello" _ <- dumpView tui "step-1" pure ()
SERVER.md view
@@ -4,41 +4,22 @@ ## Goals -- Add `tuispec server` for interactive TUI orchestration over stdin/stdout.-- Speak JSON-RPC 2.0 using the Hackage package `jsonrpc` (module `JSONRPC`).-- Support one active PTY-backed session per server process.-- Expose methods matching the DSL surface so agents can drive TUIs interactively.-- Use `--artifact-dir` as the base output path for dumped views and metadata.+- Run interactive PTY-backed TUI sessions over JSON-RPC 2.0.+- Keep one active session per server process.+- Provide launch/input/wait/snapshot APIs plus utility methods for batching,+ notifications, and JSONL recording/replay. ## Transport - Framing: newline-delimited JSON objects (one JSON-RPC message per line). - Input: stdin. - Output: stdout.-- Mode: request/response for v1 (no server notifications).--## Dependency--- Add dependency: `jsonrpc` (package `jsonrpc`, module `JSONRPC`).-- Use protocol types/constants from `JSONRPC`:- - `JSONRPCRequest`- - `JSONRPCResponse`- - `JSONRPCError`- - `JSONRPCErrorInfo`- - `RequestId`- - `rPC_VERSION`- - `pARSE_ERROR`- - `iNVALID_REQUEST`- - `mETHOD_NOT_FOUND`- - `iNVALID_PARAMS`- - `iNTERNAL_ERROR`+- Mode: request/response plus optional server notifications. ## CLI -Add command:- ```bash-tuispec server --artifact-dir PATH [--cols N] [--rows N] [--timeout-seconds N] [--ambiguity-mode fail|first-visible]+tuispec server --artifact-dir PATH [--cols N] [--rows N] [--timeout-seconds N] [--ambiguity-mode fail|first-visible|last-visible] ``` Defaults:@@ -51,10 +32,16 @@ ## Session Model - Single active session at a time.-- Explicit session initialization method:- - `initialize`-- Any non-lifecycle method requires an active session.+- Initialize with `initialize`.+- Non-lifecycle methods require an active session unless noted. +## Coordinate Rules++- Row/column coordinates in server APIs are 1-based.+- `0` is reserved as a wildcard for row/column range selectors in `currentView`+ filters (`entireRow`, `entireCol`, and `region`/`rows` wildcard forms).+- Selector `at`/`within.rect` coordinates must be `>= 1`.+ ## Method Surface ### Lifecycle@@ -66,7 +53,7 @@ - `timeoutSeconds` - `terminalCols` - `terminalRows`- - `ambiguityMode`+ - `ambiguityMode` (`fail|first|first-visible|last|last-visible`) - `snapshotTheme` - `updateSnapshots` - result:@@ -74,33 +61,72 @@ - `artifactRoot` - `rows` - `cols`--### Orchestration+ - `version` - `launch` - params:- - `command`- - `args`+ - `command` (required)+ - `args` (optional, default `[]`)+ - `env` (optional object of `string -> string|null`)+ - string value: set/override+ - `null`: unset inherited env var+ - `cwd` (optional)+ - `readySelector` (optional selector)+ - `readyTimeoutMs` (optional)+ - `readyPollIntervalMs` (optional)+ - result:+ - `ok` +### Input / Wait+ - `sendKey`- - params:- - `key` (string)- - accepted forms:- - `Enter`, `Esc`, `Tab`, `Backspace`- - `ArrowUp`, `ArrowDown`, `ArrowLeft`, `ArrowRight`- - `F1`..`F12`- - `Ctrl+X`, `Alt+X`- - single char like `"a"`+ - params: `key` - `sendText`- - params:- - `text`+ - params: `text` - `sendLine` - params: - `text`+ - optional `expectAfter` selector+ - optional `timeoutMs`+ - optional `pollIntervalMs`+ - optional `ambiguityMode`+ - result: `ok` +- `waitForText`+ - params:+ - `selector`+ - optional `timeoutMs`+ - optional `pollIntervalMs`+ - optional `ambiguityMode`+ - result: `ok`++- `waitUntil`+ - params:+ - `pattern` (regex-like pattern over full `currentView.text`)+ - optional `timeoutMs`+ - optional `pollIntervalMs`+ - result: `ok`++- `waitForStable`+ - params:+ - `debounceMs` (required): viewport must be unchanged for this many milliseconds+ - optional `timeoutMs`: overall timeout (defaults to session `timeoutSeconds × 1000`)+ - optional `pollIntervalMs`: poll interval (default `100`)+ - result: `ok`+ - Polls the viewport at `pollIntervalMs` intervals and returns once the visible+ text has remained identical for at least `debounceMs` consecutive milliseconds.+ Use this instead of fixed sleeps to wait for TUI output to settle.++### View / Snapshot+ - `currentView`+ - optional params (choose exactly one filter mode):+ - `rows`: `{ "start": Int, "end": Int }`+ - `region`: `{ "col": Int, "row": Int, "width": Int, "height": Int }`+ - `entireRow`: `Int`+ - `entireCol`: `Int` - result: - `text` - `rows`@@ -109,35 +135,139 @@ - `dumpView` - params: - `name`+ - optional `format`: `ansi|png|both` (default `ansi`)+ - optional render overrides for PNG mode:+ - `theme`+ - `font`+ - `rows`+ - `cols` - result:+ - `snapshotPath` (canonical)+ - `metaPath` (canonical)+ - `artifactRoot` (canonical)+ - optional `pngPath`++- `renderView`+ - params:+ - `name`+ - optional render overrides: `theme`, `font`, `rows`, `cols`+ - result: - `snapshotPath` - `metaPath`+ - `pngPath`+ - `artifactRoot` -### Assertions / waits+- `diffView`+ - params:+ - `leftPath`+ - `rightPath`+ - optional `mode`: `text|styled` (default `text`)+ - result:+ - `changed`+ - `changedLines`+ - `summary` +- `expectSnapshot`+ - params: `name`+ - result:+ - `ok`+ - `actualPath`+ - `baselinePath`+ - `baselineExists`++### Assertions+ - `expectVisible`- - params:- - `selector`+ - params: `selector`+ - result: `ok` - `expectNotVisible`+ - params: `selector`+ - result: `ok`++### Notifications++- `viewSubscribe`+ - params (optional):+ - `debounceMs` (default `100`)+ - `includeText` (default `false`)+ - result:+ - `ok`+ - `debounceMs`+ - `includeText`++- `viewUnsubscribe`+ - params: none+ - result: `ok`++When subscribed, the server emits JSON-RPC notifications:++```json+{"jsonrpc":"2.0","method":"view.changed","params":{"rows":40,"cols":134}}+```++If `includeText=true`, notification params also include `text`.++### Batch++- `batch` - params:- - `selector`+ - `steps`: array of `{ "method": Text, "params": Value }`+ - execution model:+ - sequential+ - non-atomic+ - stop on first failure+ - result:+ - on success: `{ "ok": true, "completed": N, "results": [...] }`+ - on failure: `{ "ok": false, "completed": N, "results": [...], "errorStep": K, "error": {...} }` -- `waitForText`+### Recording / Replay (JSONL)++- `recording.start` - params:- - `selector`- - optional `timeoutMs`- - optional `pollIntervalMs`+ - `path` (required): output JSONL path+ - `frameIntervalMs` (optional, default `200`): viewport sampling interval in+ milliseconds. Set to `0` to disable frame capture. Default 200ms = 5 Hz.+ - result: `{ "ok": true, "path": FilePath, "frameIntervalMs": Int }` -- `expectSnapshot`+- `recording.stop`+ - params: none+ - result: `{ "ok": true }`++- `recording.status`+ - params: none+ - result: `{ "active": Bool, "path": FilePath|null }`++- `replay` - params:- - `name`+ - `path`+ - optional `speed`: `as-fast-as-possible|real-time` - result: - `ok`- - plus snapshot paths where available+ - `replayedRequests`+ - `path`+ - `speed` -### Server utility+Recording files are JSONL with one event per line and include: +- `timestampMicros`+- `direction` (`request|response|notification|frame|frame-delta`)+- `line` (raw JSON-RPC line, viewport text, or delta payload)++When `frameIntervalMs > 0` (the default), the server spawns a background thread+that samples the viewport at the configured rate. Only frames that differ from+the previous sample are written. Two frame event types are used:++- `frame` — full keyframe, emitted roughly every second. `line` contains the+ complete rendered viewport text.+- `frame-delta` — compact delta, emitted between keyframes. `line` contains a+ JSON array of `[lineIndex, "new line text"]` pairs for each changed line.++The replay CLI reconstructs full frames by applying deltas to the most recent+keyframe.++### Server Utility+ - `server.ping` - result: - `pong: true`@@ -148,26 +278,18 @@ - `shuttingDown: true` - then hard-shutdown: - send `SIGKILL` to active child process group- - exit process immediately (no graceful wait)--## Signal behavior--- On `SIGHUP`, server does hard-shutdown:- - send `SIGKILL` to active child process group- - exit immediately+ - exit process immediately ## Selector Encoding -Use tagged object format:- - exact: - `{"type":"exact","text":"Ready"}` - regex: - `{"type":"regex","pattern":"Ready|Done"}`-- at:+- at (1-based): - `{"type":"at","col":10,"row":2}`-- within:- - `{"type":"within","rect":{"col":0,"row":0,"width":40,"height":10},"selector":{...}}`+- within (1-based origin):+ - `{"type":"within","rect":{"col":1,"row":1,"width":40,"height":10},"selector":{...}}` - nth: - `{"type":"nth","index":1,"selector":{...}}` @@ -179,37 +301,17 @@ - invalid request: `iNVALID_REQUEST` - unknown method: `mETHOD_NOT_FOUND` - bad params: `iNVALID_PARAMS`-- internal failures: `iNTERNAL_ERROR` -Server-domain error codes:--- `-32001` `NoActiveSession`-- `-32002` `SessionAlreadyStarted`-- `-32004` `MethodFailed`--Error `data` should include:--- `kind`-- `details`-- optional `hint`--## Artifact Layout--With `--artifact-dir X` and session `foo`:+Server-domain codes: -- `X/sessions/foo/snapshots/<name>.ansi.txt`-- `X/sessions/foo/snapshots/<name>.meta.json`+- `-32001` no active session+- `-32002` session already started+- `-32004` method failed -`dumpView` writes only run artifacts. -`expectSnapshot` keeps existing DSL baseline semantics unless changed later.+## Signal Behavior -## Validation+On `SIGHUP`, server does hard-shutdown: -- Build/tests:- - `cabal build`- - `cabal test`- - `(cd example && cabal test)`-- Manual server smoke:- - start `tuispec server`- - send `initialize`, `launch`, `sendKey`, `dumpView`, `server.shutdown`- - verify artifact files and response payloads+- send `SIGKILL` to active child process group+- close recording handle+- exit immediately
SKILL.md view
@@ -4,37 +4,62 @@ 1. launch a TUI 2. send commands/keys-3. periodically dump current view snapshots-4. render those snapshots as text/PNG+3. wait for stable output (no more fixed sleeps)+4. dump and view snapshots -## What was added for REPL ergonomics+## Golden path: wait for stability, not time -Use these APIs from `TuiSpec`:+The most common mistake in TUI testing is using fixed sleeps (`threadDelay`)+to wait for output. This is inherently flaky — timing varies across machines,+CI providers, and load conditions. -- `withTuiSession`:- creates an ad-hoc PTY session outside `tasty`-- `sendLine`:- sends text + `Enter`-- `currentView`:- returns current visible viewport text-- `dumpView`:- writes the current screen to `<name>.ansi.txt` + `<name>.meta.json`+**Always use `waitForStable` instead of `threadDelay`.** -Relevant implementation:+`waitForStable` polls the viewport and returns once the visible text has been+unchanged for a configurable debounce period. This makes tests both faster+(no over-sleeping) and more reliable (no under-sleeping). -- `src/TuiSpec/Runner.hs`-- `src/TuiSpec/Render.hs`+## Choosing a wait strategy -## Minimal REPL script+| Situation | Use | Why |+|-----------|-----|-----|+| Wait for output to settle after an action | `waitForStable` | No specific text to match; just need rendering to finish |+| Wait for specific text to appear | `waitForText` / `waitUntil` | You know what the TUI should display |+| Assert text is present right now | `expectVisible` | Viewport already settled, just check |+| Never | `threadDelay` / fixed sleep | Flaky by design | -Create a Haskell program (for example `scratch/ReplDemo.hs`):+## Viewing snapshots — prefer PNG +**Always render snapshots to PNG and view the image file** rather than+reading the plain-text `.txt` or `.ansi.txt` representation. A single PNG+gives you the complete visual state of the TUI (layout, colors, borders)+while consuming far less context than the equivalent text grid (a 160×50+viewport is ~8 000 characters of text but a single image token as PNG).++Workflow:++```bash+# Render a snapshot to PNG (output defaults to same path with .png extension)+cabal run tuispec -- render path/to/snapshot.ansi.txt++# Then view the PNG (use your image-reading tool / Read tool)+```++When using the JSON-RPC server, request `"format":"png"` or+`"format":"both"` in `dumpView` so the PNG is generated in one step.+Then read the returned `pngPath` instead of the text path.++Only fall back to `render-text` or `currentView` text when you need to+do programmatic string matching (e.g. searching for a selector or+extracting a specific value from the viewport).++## Minimal REPL script (Haskell DSL)+ ```haskell {-# LANGUAGE OverloadedStrings #-} module Main where -import Control.Concurrent (threadDelay) import TuiSpec main :: IO ()@@ -47,26 +72,28 @@ } "demo-session" $ \tui -> do- launch tui (App "sh" ["-lc", "tui-demo"])+ let wait = waitForStable tui (defaultWaitOptionsFor tui) 300 + launch tui (app "sh" ["-lc", "tui-demo"])+ wait _ <- dumpView tui "00-initial" press tui (CharKey 'b')+ wait _ <- dumpView tui "01-board" sendLine tui "/help"+ wait _ <- dumpView tui "02-help" - view <- currentView tui- putStrLn "Current viewport:"- putStrLn (take 1000 (show view))-- -- optional short settle pause between interactions- threadDelay (150 * 1000)- press tui (CharKey 'q') ``` +Key points:+- `waitForStable tui opts 300` — wait until viewport unchanged for 300ms+- Bind a local `wait` helper so every action is followed by a stability gate+- No `threadDelay` anywhere+ Run it: ```bash@@ -84,13 +111,14 @@ ## Render dumps while iterating -Render to PNG:+Render to PNG (preferred — compact, full-fidelity): ```bash cabal run tuispec -- render artifacts/repl/sessions/demo-session/snapshots/01-board.ansi.txt+# Then read the .png file to see the TUI state ``` -Render to visible plain text:+Render to visible plain text (only when you need string matching): ```bash cabal run tuispec -- render-text artifacts/repl/sessions/demo-session/snapshots/01-board.ansi.txt@@ -101,7 +129,7 @@ ## Practical loop 1. run your REPL script-2. inspect generated `.txt`/`.png`+2. render snapshots to PNG and view the images 3. tweak interactions 4. run again @@ -109,7 +137,9 @@ ## JSONRPC server workflow -You can also orchestrate a TUI from an external client using:+You can also orchestrate a TUI from an external client using the JSON-RPC+server. See [`SERVER.md`](SERVER.md) for the full protocol reference+(all methods, params, result shapes, error codes, and selector encoding). ```bash cabal run tuispec -- server --artifact-dir artifacts/server@@ -120,16 +150,7 @@ - Send one JSON-RPC request per line on stdin. - Read one JSON-RPC response per line on stdout. -### Shutdown semantics--- `server.shutdown` is a hard shutdown:- - kills active TUI child process group with `SIGKILL`- - exits server immediately (no graceful wait)-- On `SIGHUP`, the server does the same hard shutdown behavior:- - `SIGKILL` to active child process group- - immediate process exit--### Example session+### Example session with waitForStable Start server: @@ -137,18 +158,23 @@ cabal run tuispec -- server --artifact-dir artifacts/server ``` -Then send requests like:+Then send requests: ```json {"jsonrpc":"2.0","id":1,"method":"initialize","params":{"name":"demo"}}-{"jsonrpc":"2.0","id":2,"method":"launch","params":{"command":"sh","args":["-lc","tui-demo"]}}+{"jsonrpc":"2.0","id":2,"method":"launch","params":{"command":"sh","args":["-lc","printf 'READY\\n'; exec sh"],"readySelector":{"type":"exact","text":"READY"}}} {"jsonrpc":"2.0","id":3,"method":"sendKey","params":{"key":"ArrowDown"}}-{"jsonrpc":"2.0","id":4,"method":"sendKey","params":{"key":"Enter"}}-{"jsonrpc":"2.0","id":5,"method":"dumpView","params":{"name":"after-enter"}}-{"jsonrpc":"2.0","id":6,"method":"currentView","params":null}-{"jsonrpc":"2.0","id":7,"method":"server.shutdown","params":null}+{"jsonrpc":"2.0","id":4,"method":"waitForStable","params":{"debounceMs":300}}+{"jsonrpc":"2.0","id":5,"method":"dumpView","params":{"name":"after-arrow","format":"both"}}+{"jsonrpc":"2.0","id":6,"method":"sendKey","params":{"key":"Enter"}}+{"jsonrpc":"2.0","id":7,"method":"waitForStable","params":{"debounceMs":300}}+{"jsonrpc":"2.0","id":8,"method":"dumpView","params":{"name":"after-enter","format":"both"}}+{"jsonrpc":"2.0","id":9,"method":"server.shutdown","params":null} ``` +Notice: every input action is followed by `waitForStable` before dumping the+view. This replaces fixed sleeps and makes the script reliable across machines.+ ### Supported key strings for `sendKey` - `Enter`, `Esc`, `Tab`, `Backspace`@@ -170,3 +196,88 @@ cabal run tuispec -- render artifacts/server/sessions/demo/snapshots/after-enter.ansi.txt cabal run tuispec -- render-text artifacts/server/sessions/demo/snapshots/after-enter.ansi.txt ```++### JSONL recording with viewport frames++Start recording with automatic viewport sampling (default 5 Hz):++```json+{"jsonrpc":"2.0","id":7,"method":"recording.start","params":{"path":"artifacts/server/demo.jsonl"}}+```++To change the sampling rate, pass `frameIntervalMs` (e.g. 100 for 10 Hz, 0 to+disable frame capture):++```json+{"jsonrpc":"2.0","id":7,"method":"recording.start","params":{"path":"artifacts/server/demo.jsonl","frameIntervalMs":100}}+```++### JSONL replay++Replay a recording visually on your terminal (frame-by-frame):++```bash+cabal run tuispec -- replay artifacts/server/demo.jsonl --speed real-time+```++If the recording contains viewport frames, the replay renders each frame in+place with original timing. If no frames are present (older recordings), it+falls back to printing the raw JSON-RPC request lines.++Use `--speed as-fast-as-possible` to skip timing delays.++To show the last input action below the viewport during replay:++```bash+cabal run tuispec -- replay artifacts/server/demo.jsonl --show-input+```++#### Interactive replay controls++When replaying on a TTY, the following keyboard controls are available:++| Key | Action |+|-------------|---------------------------------|+| Space | Pause / resume playback |+| Left/Right | Step one frame backward/forward |+| Up/Down | Skip 5 frames backward/forward |+| r | Redraw current frame |+| q / Esc | Quit |++For push-based polling alternatives, subscribe to view changes:++```json+{"jsonrpc":"2.0","id":10,"method":"viewSubscribe","params":{"debounceMs":100,"includeText":false}}+```++## Common failure modes and troubleshooting++### `waitForStable` times out++- **Cause**: the TUI keeps updating (clock, spinner, streaming output).+- **Fix**: increase `debounceMs` to tolerate brief pauses in output, or use+ `waitForText`/`waitUntil` with a specific pattern instead.++### `waitForStable` returns too early++- **Cause**: `debounceMs` is too short — the TUI paused briefly mid-render.+- **Fix**: increase `debounceMs` (300ms is a good default; 500ms+ for apps+ with multi-phase rendering).++### Snapshot mismatch after stable wait++- **Cause**: viewport settled on different content than expected (race in app+ startup, wrong initial state).+- **Fix**: use `waitForText` with a readiness selector before taking snapshots.+ Combine: `waitForText` for readiness, then `waitForStable` for full settle.++### Server returns `-32001` (no active session)++- **Cause**: forgot to call `initialize` before other methods.+- **Fix**: always start with `initialize`, then `launch`.++### App exits immediately++- **Cause**: command fails or exits before the test can interact with it.+- **Fix**: verify the command works in a regular terminal first. Check `cwd`+ and `env` params. Use `readySelector` in `launch` to gate on app startup.
SPEC.md view
@@ -1,6 +1,6 @@ # tuispec Specification -Last updated: 2026-02-23+Last updated: 2026-02-24 Status: current implementation ## 1. Purpose@@ -39,7 +39,7 @@ Key data types: - `RunOptions`: runtime and artifact behavior-- `App`: target command + args+- `App`: target command + args + optional env overrides - `Key` / `Modifier`: input model - `Selector`: viewport query model - `WaitOptions`: polling behavior@@ -73,7 +73,7 @@ main = defaultMain $ testGroup "suite" [ tuiTest defaultRunOptions "counter" $ \tui -> do- launch tui (App "my-tui" [])+ launch tui (app "my-tui" []) waitForText tui (Exact "Ready") press tui (CharKey '+') expectSnapshot tui "counter-updated"@@ -86,7 +86,7 @@ ```haskell withTuiSession defaultRunOptions "demo" $ \tui -> do- launch tui (App "sh" [])+ launch tui (app "sh" []) sendLine tui "echo hello" _ <- dumpView tui "hello" pure ()@@ -95,16 +95,23 @@ ### 4.3 Actions - `launch :: Tui -> App -> IO ()`+- `app :: FilePath -> [String] -> App` - `press :: Tui -> Key -> IO ()` - `pressCombo :: Tui -> [Modifier] -> Key -> IO ()` - `typeText :: Tui -> Text -> IO ()` - `sendLine :: Tui -> Text -> IO ()` `launch` replaces any currently running app for that `Tui` handle.+When `App.env` is provided, launch inherits parent environment variables and:+- `Just "value"` sets/overrides a variable+- `Nothing` unsets an inherited variable +When `App.cwd` is provided, launch runs in that working directory.+ ### 4.4 Waits and assertions - `waitFor :: Tui -> WaitOptions -> (Viewport -> Bool) -> IO ()`+- `waitForStable :: Tui -> WaitOptions -> Int -> IO ()` - `waitForText :: Tui -> Selector -> IO ()` - `waitForSelector :: Tui -> WaitOptions -> Selector -> IO ()` - `expectVisible :: Tui -> Selector -> IO ()`@@ -114,8 +121,15 @@ - polling-based - default poll interval: `100ms` - `waitForText` / `expectVisible` use `timeoutSeconds` from `RunOptions`+- matching runs on rendered viewport text (ANSI control/style escapes are interpreted) - ambiguity checking runs after positive selector match +`waitForStable` semantics:+- polls viewport at `pollIntervalMs` intervals+- returns once viewport text has been unchanged for `debounceMs` consecutive milliseconds+- throws timeout error if overall `timeoutMs` is exceeded+- replaces brittle fixed `threadDelay` calls with semantic stability checks+ ### 4.5 Selector language `Selector` constructors:@@ -133,6 +147,7 @@ Ambiguity mode: - `FailOnAmbiguous`: fail if selector has multiple matches (except explicit `At`/`Nth`) - `FirstVisibleMatch`: tolerate multiple matches+- `LastVisibleMatch`: tolerate multiple matches ### 4.6 Input key model @@ -188,7 +203,7 @@ - `TUISPEC_TERMINAL_ROWS` - `TUISPEC_ARTIFACTS_DIR` - `TUISPEC_UPDATE_SNAPSHOTS`-- `TUISPEC_AMBIGUITY_MODE` (`fail|first|first-visible`)+- `TUISPEC_AMBIGUITY_MODE` (`fail|first|first-visible|last|last-visible`) - `TUISPEC_SNAPSHOT_THEME` Root/path helpers:@@ -236,12 +251,35 @@ - `TUISPEC_FONT_PATH` - built-in system fallback font paths +CLI command: `tuispec replay`+- input: JSONL recording file+- options:+ - `--speed as-fast-as-possible|real-time` (default `real-time`)+ - `--show-input`: display last input action on a status line below the viewport+- if recording contains `frame` events, replays them visually on the terminal+ (overwrite in place with original timing)+- falls back to printing raw request lines when no frames are present++### 8.1 Recording format++Recording JSONL files contain one event per line:+- `timestampMicros`: microseconds since POSIX epoch+- `direction`: `request|response|notification|frame|frame-delta`+- `line`: raw JSON-RPC line, viewport text, or delta payload++Frame events are captured by a background sampling thread during+`recording.start` at a configurable rate (default 200ms = 5 Hz).+Consecutive identical frames are deduplicated. Full keyframes (`frame`)+are emitted roughly every second; compact line-level deltas+(`frame-delta`) are emitted in between. Delta payloads are JSON arrays+of `[lineIndex, "text"]` pairs.+ ## 9. JSON-RPC Server CLI command: ```bash-tuispec server --artifact-dir PATH [--cols N] [--rows N] [--timeout-seconds N] [--ambiguity-mode fail|first-visible]+tuispec server --artifact-dir PATH [--cols N] [--rows N] [--timeout-seconds N] [--ambiguity-mode fail|first-visible|last-visible] ``` Transport:@@ -260,10 +298,21 @@ - `sendLine` - `currentView` - `dumpView`+- `renderView`+- `waitUntil`+- `waitForStable`+- `diffView` - `expectSnapshot` - `waitForText` - `expectVisible` - `expectNotVisible`+- `viewSubscribe`+- `viewUnsubscribe`+- `batch`+- `recording.start` (optional `frameIntervalMs`, default 200 = 5 Hz)+- `recording.stop`+- `recording.status`+- `replay` - `server.ping` - `server.shutdown` @@ -274,23 +323,47 @@ - `-32002` session already started - `-32004` method failed -### 9.1 `sendKey` format+### 9.1 `launch` params +`launch` accepts:+- `command` (string)+- `args` (array of strings, optional)+- `env` (object of string-to-(string|null) pairs, optional)+- `cwd` (string, optional)+- `readySelector` (selector, optional)+- `readyTimeoutMs` (int, optional)+- `readyPollIntervalMs` (int, optional)++Example:++```json+{"method":"launch","params":{"command":"sh","args":[],"env":{"APP_MODE":"test","CLAUDECODE":null},"cwd":"."}}+```++`env` string values override inherited process env variables for that launch.+`env` null values unset inherited variables for that launch.++### 9.2 `sendKey` format+ Accepted string forms: - base: `Enter`, `Esc`, `Tab`, `Backspace`, arrows, `F1..F12`, single char - combos: `Ctrl+X`, `Alt+X`, `Shift+X` -### 9.2 Selector JSON format+### 9.3 Selector JSON format ```json {"type":"exact","text":"Ready"} {"type":"regex","pattern":"Ready|Done"} {"type":"at","col":10,"row":2}-{"type":"within","rect":{"col":0,"row":0,"width":40,"height":10},"selector":{"type":"exact","text":"Ready"}}+{"type":"within","rect":{"col":1,"row":1,"width":40,"height":10},"selector":{"type":"exact","text":"Ready"}} {"type":"nth","index":1,"selector":{"type":"exact","text":"Task"}} ``` -### 9.3 Shutdown semantics+Coordinate notes:+- server row/col coordinates are 1-based+- `currentView` row/col filters support `0` wildcard for entire row/column ranges++### 9.4 Shutdown semantics `server.shutdown`: - sends `SIGKILL` to active child process group
app/Main.hs view
@@ -1,16 +1,29 @@ module Main where +import Control.Concurrent (threadDelay)+import Control.Exception (bracket_) import Data.List (isSuffixOf)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import Data.Version (showVersion) import Options.Applicative+import Paths_tuispec (version)+import System.IO (BufferMode (NoBuffering), hFlush, hIsTerminalDevice, hReady, hSetBuffering, hSetEcho, stdin, stdout)+import System.Posix.IO (stdInput)+import System.Posix.Terminal (TerminalAttributes, getTerminalAttributes, setTerminalAttributes, withMinInput, withTime, withoutMode)+import System.Posix.Terminal qualified as Posix import Text.Read (readMaybe) import TuiSpec.Render (renderAnsiSnapshotFileWithFont, renderAnsiSnapshotTextFile)+import TuiSpec.Replay (ReplayFrame (..), ReplaySpeed (ReplayAsFastAsPossible, ReplayRealTime), applyDelta, loadReplayFrames, streamReplayFrames, streamReplayRequests) import TuiSpec.Server qualified as Server-import TuiSpec.Types (AmbiguityMode (FailOnAmbiguous, FirstVisibleMatch))+import TuiSpec.Types (AmbiguityMode (FailOnAmbiguous, FirstVisibleMatch, LastVisibleMatch)) data Command = Render RenderOptions | RenderText RenderTextOptions | Server ServerOptions+ | Replay ReplayOptions data RenderOptions = RenderOptions { inputPath :: FilePath@@ -36,6 +49,12 @@ , ambiguity :: AmbiguityMode } +data ReplayOptions = ReplayOptions+ { replayInputPath :: FilePath+ , replaySpeed :: ReplaySpeed+ , replayShowInput :: Bool+ }+ main :: IO () main = do parsedCommand <- execParser commandParserInfo@@ -61,11 +80,16 @@ , Server.serverTimeoutSeconds = timeoutSeconds options , Server.serverAmbiguityMode = ambiguity options }+ Replay options -> do+ isTTY <- hIsTerminalDevice stdin+ if isTTY+ then replayInteractive options+ else replayNonInteractive options commandParserInfo :: ParserInfo Command commandParserInfo = info- (parseCommand <**> helper)+ (parseCommand <**> simpleVersioner (showVersion version) <**> helper) ( fullDesc <> progDesc "Render ANSI snapshot artifacts to PNG" <> header "tuispec"@@ -92,6 +116,12 @@ (Server <$> parseServerOptions) (progDesc "Run JSON-RPC server on stdin/stdout for interactive TUI orchestration") )+ <> command+ "replay"+ ( info+ (Replay <$> parseReplayOptions)+ (progDesc "Replay request lines from a tuispec JSONL recording")+ ) ) parseRenderOptions :: Parser RenderOptions@@ -208,11 +238,32 @@ ambiguityModeReader ( long "ambiguity-mode" <> metavar "MODE"- <> help "Default ambiguity mode: fail|first-visible"+ <> help "Default ambiguity mode: fail|first-visible|last-visible" <> value FailOnAmbiguous <> showDefaultWith renderAmbiguityMode ) +parseReplayOptions :: Parser ReplayOptions+parseReplayOptions =+ ReplayOptions+ <$> argument+ str+ ( metavar "RECORDING_JSONL"+ <> help "Path to a recording JSONL file"+ )+ <*> option+ replaySpeedReader+ ( long "speed"+ <> metavar "MODE"+ <> help "Replay speed: as-fast-as-possible|real-time"+ <> value ReplayRealTime+ <> showDefaultWith renderReplaySpeed+ )+ <*> switch+ ( long "show-input"+ <> help "Show last input action on a status line below the viewport"+ )+ positiveIntReader :: ReadM Int positiveIntReader = eitherReader $ \raw ->@@ -227,14 +278,31 @@ "fail" -> Right FailOnAmbiguous "first-visible" -> Right FirstVisibleMatch "first" -> Right FirstVisibleMatch- _ -> Left "Expected ambiguity mode: fail|first-visible"+ "last-visible" -> Right LastVisibleMatch+ "last" -> Right LastVisibleMatch+ _ -> Left "Expected ambiguity mode: fail|first-visible|last-visible" renderAmbiguityMode :: AmbiguityMode -> String renderAmbiguityMode mode = case mode of FailOnAmbiguous -> "fail" FirstVisibleMatch -> "first-visible"+ LastVisibleMatch -> "last-visible" +replaySpeedReader :: ReadM ReplaySpeed+replaySpeedReader =+ eitherReader $ \raw ->+ case raw of+ "as-fast-as-possible" -> Right ReplayAsFastAsPossible+ "real-time" -> Right ReplayRealTime+ _ -> Left "Expected replay speed: as-fast-as-possible|real-time"++renderReplaySpeed :: ReplaySpeed -> String+renderReplaySpeed speed =+ case speed of+ ReplayAsFastAsPossible -> "as-fast-as-possible"+ ReplayRealTime -> "real-time"+ defaultOutputPath :: FilePath -> FilePath defaultOutputPath input = if ".ansi.txt" `isSuffixOf` input@@ -246,3 +314,272 @@ if ".ansi.txt" `isSuffixOf` input then take (length input - length (".ansi.txt" :: String)) input <> ".txt" else input <> ".txt"++-- --------------------------------------------------------------------+-- Replay modes+-- --------------------------------------------------------------------++-- | Interactive replay with keyboard controls (when stdin is a TTY).+replayInteractive :: ReplayOptions -> IO ()+replayInteractive options = do+ frames <- loadReplayFrames (replayInputPath options)+ if null frames+ then do+ replayed <- streamReplayRequests (replaySpeed options) (replayInputPath options) TIO.putStrLn+ putStrLn ("Replayed " <> show replayed <> " request messages")+ else withAltScreen $+ withRawTerminal $ do+ interactiveReplay (replaySpeed options) (replayShowInput options) frames+ putStrLn ("Replayed " <> show (length frames) <> " frames")++-- | Non-interactive streaming replay (when stdin is not a TTY).+replayNonInteractive :: ReplayOptions -> IO ()+replayNonInteractive options = do+ let callback = if replayShowInput options then displayFrameWithInput else displayFrameOnly+ frameCount <- streamReplayFrames (replaySpeed options) (replayInputPath options) callback+ if frameCount > 0+ then putStrLn ("Replayed " <> show frameCount <> " frames")+ else do+ replayed <- streamReplayRequests (replaySpeed options) (replayInputPath options) TIO.putStrLn+ putStrLn ("Replayed " <> show replayed <> " request messages")++-- | Display a frame ignoring input labels (non-interactive mode).+displayFrameOnly :: Text -> Maybe Text -> IO ()+displayFrameOnly frameText _maybeInput = do+ putStr "\ESC[?25l\ESC[H"+ TIO.putStr frameText+ putStr "\ESC[?25h"+ hFlush stdout++-- | Display a frame with an input status line (non-interactive mode).+displayFrameWithInput :: Text -> Maybe Text -> IO ()+displayFrameWithInput frameText maybeInput = do+ putStr "\ESC[?25l\ESC[H"+ TIO.putStr frameText+ putStr "\ESC[K"+ case maybeInput of+ Just label -> do+ putStr "\n\ESC[7m "+ TIO.putStr label+ putStr " \ESC[0m\ESC[K"+ Nothing -> putStr "\n\ESC[K"+ putStr "\ESC[?25h"+ hFlush stdout++-- --------------------------------------------------------------------+-- Interactive replay+-- --------------------------------------------------------------------++-- | Keypress actions recognised by the interactive replay loop.+data ReplayKey+ = KeySpace+ | KeyLeft+ | KeyRight+ | KeyUp+ | KeyDown+ | KeyRedraw+ | KeyQuit+ | KeyUnknown++-- | Enter the alternate screen buffer and leave it when the action finishes.+withAltScreen :: IO a -> IO a+withAltScreen =+ bracket_+ (putStr "\ESC[?1049h\ESC[2J\ESC[H" >> hFlush stdout)+ (putStr "\ESC[?25h\ESC[?1049l" >> hFlush stdout)++-- | Set the terminal to raw mode and restore it when the action finishes.+withRawTerminal :: IO a -> IO a+withRawTerminal act = do+ oldAttrs <- getTerminalAttributes stdInput+ let rawAttrs =+ withTime (withMinInput (setRaw oldAttrs) 0) 0+ bracket_+ (setTerminalAttributes stdInput rawAttrs Posix.Immediately >> hSetBuffering stdin NoBuffering >> hSetEcho stdin False)+ (setTerminalAttributes stdInput oldAttrs Posix.Immediately)+ act++-- | Strip terminal attributes down to raw mode (no echo, no canonical, no signals).+setRaw :: TerminalAttributes -> TerminalAttributes+setRaw attrs =+ foldl+ withoutMode+ attrs+ [ Posix.EnableEcho+ , Posix.ProcessInput+ , Posix.KeyboardInterrupts+ , Posix.StartStopOutput+ , Posix.ExtendedFunctions+ ]++-- | Run the interactive replay loop over a non-empty list of frames.+interactiveReplay :: ReplaySpeed -> Bool -> [ReplayFrame] -> IO ()+interactiveReplay speed showInput frameList = do+ let frames = listToIndexed frameList+ totalFrames = length frameList+ case frameList of+ [] -> pure () -- unreachable, caller checks null+ (first : _) -> do+ displayFrame showInput first 0 totalFrames False+ go frames 0 totalFrames False+ where+ go frames idx total paused = do+ key <- if paused then readKey else waitForKeyOrDelay speed frames idx+ case key of+ Just KeyQuit -> pure ()+ Just KeySpace -> do+ let newPaused = not paused+ displayFrame showInput (snd (frames !! idx)) idx total newPaused+ go frames idx total newPaused+ Just KeyLeft -> do+ let newIdx = max 0 (idx - 1)+ displayFrame showInput (snd (frames !! newIdx)) newIdx total paused+ go frames newIdx total paused+ Just KeyRight -> do+ let newIdx = min (total - 1) (idx + 1)+ displayFrame showInput (snd (frames !! newIdx)) newIdx total paused+ go frames newIdx total paused+ Just KeyUp -> do+ let newIdx = max 0 (idx - 5)+ displayFrame showInput (snd (frames !! newIdx)) newIdx total paused+ go frames newIdx total paused+ Just KeyDown -> do+ let newIdx = min (total - 1) (idx + 5)+ displayFrame showInput (snd (frames !! newIdx)) newIdx total paused+ go frames newIdx total paused+ Just KeyRedraw -> do+ let rebuiltText = rebuildFromKeyframe frames idx+ rebuiltFrame = (snd (frames !! idx)){replayFrameText = rebuiltText}+ displayFrame showInput rebuiltFrame idx total paused+ go frames idx total paused+ Just KeyUnknown -> go frames idx total paused+ Nothing ->+ -- Timeout expired, advance to next frame+ if idx + 1 >= total+ then do+ -- Reached the end, pause on last frame+ displayFrame showInput (snd (frames !! idx)) idx total True+ go frames idx total True+ else do+ let newIdx = idx + 1+ displayFrame showInput (snd (frames !! newIdx)) newIdx total False+ go frames newIdx total False++-- | Display a single frame with optional input label and status bar.+displayFrame :: Bool -> ReplayFrame -> Int -> Int -> Bool -> IO ()+displayFrame showInput frame idx total paused = do+ putStr "\ESC[?25l\ESC[H"+ TIO.putStr (replayFrameText frame)+ putStr "\ESC[K"+ if showInput+ then do+ putStr "\n"+ case replayFrameInput frame of+ Just label -> do+ putStr "\ESC[7m "+ TIO.putStr label+ putStr " \ESC[0m"+ Nothing -> pure ()+ putStr "\ESC[K"+ else putStr "\n\ESC[K"+ -- Status bar: frame counter and pause state+ putStr "\n\ESC[7m "+ putStr (show (idx + 1) <> "/" <> show total)+ if paused then putStr " [PAUSED] Space:play Left/Right:step Up/Down:skip5 r:redraw q:quit" else pure ()+ putStr " \ESC[0m\ESC[K"+ hFlush stdout++-- | Blocking read of a single keypress. Returns 'Just' the key.+readKey :: IO (Maybe ReplayKey)+readKey = Just <$> readKeyRaw++-- | Read a raw keypress, handling escape sequences for arrow keys.+readKeyRaw :: IO ReplayKey+readKeyRaw = do+ c <- getChar+ case c of+ 'q' -> pure KeyQuit+ ' ' -> pure KeySpace+ 'r' -> pure KeyRedraw+ '\ESC' -> do+ -- Could be an arrow key escape sequence+ ready <- hReady stdin+ if ready+ then do+ c2 <- getChar+ if c2 == '['+ then do+ c3 <- getChar+ case c3 of+ 'A' -> pure KeyUp+ 'B' -> pure KeyDown+ 'C' -> pure KeyRight+ 'D' -> pure KeyLeft+ _ -> pure KeyUnknown+ else pure KeyUnknown+ else pure KeyQuit -- bare Escape = quit+ _ -> pure KeyUnknown++{- | Wait for a keypress or the inter-frame delay, whichever comes first.+Returns 'Nothing' if the delay expired (advance frame), 'Just' if a key was pressed.+-}+waitForKeyOrDelay :: ReplaySpeed -> [(Int, ReplayFrame)] -> Int -> IO (Maybe ReplayKey)+waitForKeyOrDelay speed frames idx = do+ let delayMicros = case speed of+ ReplayAsFastAsPossible -> 0 :: Int+ ReplayRealTime ->+ if idx + 1 < length frames+ then+ let current = snd (frames !! idx)+ next = snd (frames !! (idx + 1))+ in fromIntegral (replayFrameTimestampMicros next - replayFrameTimestampMicros current)+ else 0+ if delayMicros <= 0+ then do+ ready <- hReady stdin+ if ready then Just <$> readKeyRaw else pure Nothing+ else waitWithTimeout delayMicros++{- | Wait up to the given number of microseconds for input. Returns 'Nothing'+on timeout (meaning we should advance), or 'Just key' if a key was pressed.+-}+waitWithTimeout :: Int -> IO (Maybe ReplayKey)+waitWithTimeout totalMicros = go totalMicros+ where+ chunkMs = 20 -- poll every 20ms+ chunkMicros = chunkMs * 1000+ go remaining+ | remaining <= 0 = do+ ready <- hReady stdin+ if ready then Just <$> readKeyRaw else pure Nothing+ | otherwise = do+ ready <- hReady stdin+ if ready+ then Just <$> readKeyRaw+ else do+ let wait = min remaining chunkMicros+ threadDelay wait+ go (remaining - wait)++-- | Index a list with positions.+listToIndexed :: [a] -> [(Int, a)]+listToIndexed = zip [0 ..]++{- | Reconstruct frame text by finding the last keyframe and applying+all subsequent deltas forward to the target index.+-}+rebuildFromKeyframe :: [(Int, ReplayFrame)] -> Int -> T.Text+rebuildFromKeyframe frames targetIdx =+ let keyIdx = case [i | (i, f) <- take (targetIdx + 1) frames, replayFrameIsKeyframe f] of+ [] -> 0+ xs -> last xs+ keyText = replayFrameText (snd (frames !! keyIdx))+ deltas = [(i, f) | (i, f) <- frames, i > keyIdx, i <= targetIdx]+ nl = T.pack "\n"+ baseLines = T.splitOn nl keyText+ in T.intercalate nl (foldl' applyDeltaStep baseLines deltas)+ where+ applyDeltaStep currentLines (_, f) =+ case replayFrameDelta f of+ Just deltaText -> applyDelta currentLines deltaText+ Nothing -> T.splitOn (T.pack "\n") (replayFrameText f)
src/TuiSpec.hs view
@@ -12,9 +12,9 @@ main = defaultMain $ testGroup "demo" [ tuiTest defaultRunOptions "my test" $ \\tui -> do- launch tui (App "my-app" [])+ launch tui (app "my-app" []) waitForText tui (Exact "Ready")- press tui (CharKey 'q')+ press tui Enter ] @ @@ -35,6 +35,7 @@ -- * Waits and assertions waitFor,+ waitForStable, waitForText, waitForSelector, expectVisible,@@ -55,7 +56,10 @@ -- * Configuration types RunOptions (..), defaultRunOptions,+ defaultWaitOptions,+ defaultWaitOptionsFor, App (..),+ app, Key (..), Modifier (..), Selector (..),
+ src/TuiSpec/Internal.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- |+Module : TuiSpec.Internal+Description : Shared internal utilities used across tuispec modules.++This module is not part of the public API. It collects helper functions+that are needed by more than one of 'TuiSpec.Runner', 'TuiSpec.Server',+and 'TuiSpec.Render'.+-}+module TuiSpec.Internal (+ -- * List helpers+ safeIndex,++ -- * Path helpers+ safeFileStem,+ snapshotMetadataPath,++ -- * Pattern matching+ regexLikeMatch,+ cleanPattern,+ wildcardContains,++ -- * Theme helpers+ resolveAutoSnapshotTheme,+ detectTerminalBackground,++ -- * Exception helpers+ ignoreIOError,+) where++import Control.Exception (SomeException, catch)+import Data.Char (isAlphaNum, toLower)+import Data.List (isSuffixOf)+import Data.Text (Text)+import Data.Text qualified as T+import Text.Read (readMaybe)++-- | Safe list indexing that returns 'Nothing' for out-of-bounds access.+safeIndex :: Int -> [a] -> Maybe a+safeIndex indexValue values+ | indexValue < 0 = Nothing+ | otherwise = go indexValue values+ where+ go _ [] = Nothing+ go 0 (x : _) = Just x+ go n (_ : xs) = go (n - 1) xs++-- | Slugify a string into a safe file stem (lowercase, alphanumeric + dashes).+safeFileStem :: String -> String+safeFileStem input =+ let lowered = map toLower input+ normalized = map normalize lowered+ compact = collapseDashes normalized+ trimmed = trimDashes compact+ in if null trimmed then "snapshot" else trimmed+ where+ normalize c+ | isAlphaNum c = c+ | otherwise = '-'++ collapseDashes [] = []+ collapseDashes ('-' : '-' : rest) = collapseDashes ('-' : rest)+ collapseDashes (c : rest) = c : collapseDashes rest++ trimDashes = reverse . dropWhile (== '-') . reverse . dropWhile (== '-')++-- | Derive the @.meta.json@ sidecar path from an @.ansi.txt@ snapshot path.+snapshotMetadataPath :: FilePath -> FilePath+snapshotMetadataPath ansiPath =+ if ".ansi.txt" `isSuffixOf` ansiPath+ then take (length ansiPath - length (".ansi.txt" :: String)) ansiPath <> ".meta.json"+ else ansiPath <> ".meta.json"++{- | Check whether a simple regex-like pattern matches a haystack.++Supports @|@ alternation and @.*@ wildcards.+-}+regexLikeMatch :: Text -> Text -> Bool+regexLikeMatch patternText haystack =+ any (`wildcardContains` haystack) alternatives+ where+ alternatives =+ filter (not . T.null) $+ map cleanPattern (T.splitOn "|" patternText)++-- | Strip parentheses from a pattern fragment.+cleanPattern :: Text -> Text+cleanPattern = T.filter (`notElem` ("()" :: String))++-- | Check whether a @.*@-delimited pattern matches within a haystack.+wildcardContains :: Text -> Text -> Bool+wildcardContains patternText haystack =+ checkSegments 0 segments+ where+ segments = filter (not . T.null) (T.splitOn ".*" patternText)++ checkSegments :: Int -> [Text] -> Bool+ checkSegments _ [] = True+ checkSegments fromIdx (segment : rest) =+ let remaining = T.drop fromIdx haystack+ (prefix, suffix) = T.breakOn segment remaining+ in if T.null suffix+ then False+ else+ let nextStart = fromIdx + T.length prefix + T.length segment+ in checkSegments nextStart rest++-- | Resolve @\"auto\"@ snapshot theme to a concrete theme name using @COLORFGBG@.+resolveAutoSnapshotTheme :: String -> Maybe String -> String+resolveAutoSnapshotTheme requestedTheme colorFgBgValue =+ case map toLower requestedTheme of+ "auto" ->+ case detectTerminalBackground colorFgBgValue of+ Just "light" -> "pty-default-light"+ _ -> "pty-default-dark"+ _ -> requestedTheme++-- | Detect terminal background lightness from the @COLORFGBG@ value.+detectTerminalBackground :: Maybe String -> Maybe String+detectTerminalBackground colorFgBgValue =+ case colorFgBgValue >>= parseBgIndex of+ Just bgIndex | bgIndex >= 7 -> Just "light"+ Just _ -> Just "dark"+ Nothing -> Nothing+ where+ parseBgIndex raw =+ case reverse (splitOn ';' raw) of+ [] -> Nothing+ lastPart : _ -> (readMaybe lastPart :: Maybe Int)++ splitOn _ [] = [""]+ splitOn delimiter input =+ case break (== delimiter) input of+ (headPart, []) -> [headPart]+ (headPart, _ : rest) -> headPart : splitOn delimiter rest++-- | Run an IO action, silently discarding any exceptions.+ignoreIOError :: IO () -> IO ()+ignoreIOError action =+ action `catch` \(_ :: SomeException) -> pure ()
src/TuiSpec/Render.hs view
@@ -16,11 +16,10 @@ ) where import Control.Applicative ((<|>))-import Control.Exception (SomeException, catch, throwIO)+import Control.Exception (throwIO) import Data.Aeson (FromJSON (parseJSON), eitherDecode, withObject, (.:)) import Data.ByteString.Lazy qualified as BL-import Data.Char (toLower)-import Data.List (intercalate, isSuffixOf)+import Data.List (intercalate) import Data.Maybe (fromMaybe) import Data.Text qualified as T import Data.Text.IO qualified as TIO@@ -30,7 +29,7 @@ import System.FilePath (takeDirectory) import System.IO (hClose, openTempFile) import System.Process (proc, readCreateProcessWithExitCode)-import Text.Read (readMaybe)+import TuiSpec.Internal (ignoreIOError, resolveAutoSnapshotTheme, snapshotMetadataPath) import TuiSpec.Runner (renderAnsiViewportText, serializeAnsiSnapshot) import TuiSpec.Types (defaultRunOptions, terminalCols, terminalRows) @@ -48,6 +47,11 @@ renderAnsiSnapshotFile rowOverride colOverride themeOverride ansiPath outPath = do renderAnsiSnapshotFileWithFont Nothing rowOverride colOverride themeOverride ansiPath outPath +{- | Render an ANSI snapshot file to PNG with an optional explicit font path.++If no font is supplied, renderer defaults are used and may fall back to the+built-in terminal-safe font list.+-} renderAnsiSnapshotFileWithFont :: Maybe FilePath -> Maybe Int -> Maybe Int -> Maybe String -> FilePath -> FilePath -> IO () renderAnsiSnapshotFileWithFont maybeFontPath rowOverride colOverride themeOverride ansiPath outPath = do ansiText <- TIO.readFile ansiPath@@ -131,12 +135,6 @@ Just metadataValue Right _ -> Nothing -snapshotMetadataPath :: FilePath -> FilePath-snapshotMetadataPath ansiPath =- if ".ansi.txt" `isSuffixOf` ansiPath- then take (length ansiPath - length (".ansi.txt" :: String)) ansiPath <> ".meta.json"- else ansiPath <> ".meta.json"- pythonStyledRenderScript :: String pythonStyledRenderScript = unlines@@ -229,34 +227,3 @@ , "/System/Library/Fonts/Menlo.ttc" , "/Library/Fonts/Menlo.ttc" ]--resolveAutoSnapshotTheme :: String -> Maybe String -> String-resolveAutoSnapshotTheme requestedTheme colorFgBgValue =- case map toLower requestedTheme of- "auto" ->- case detectTerminalBackground colorFgBgValue of- Just "light" -> "pty-default-light"- _ -> "pty-default-dark"- _ -> requestedTheme--detectTerminalBackground :: Maybe String -> Maybe String-detectTerminalBackground colorFgBgValue =- case colorFgBgValue >>= parseBgIndex of- Just bgIndex | bgIndex >= 7 -> Just "light"- Just _ -> Just "dark"- Nothing -> Nothing- where- parseBgIndex raw =- case reverse (splitOn ';' raw) of- [] -> Nothing- lastPart : _ -> (readMaybe lastPart :: Maybe Int)-- splitOn _ [] = [""]- splitOn delimiter input =- case break (== delimiter) input of- (headPart, []) -> [headPart]- (headPart, _ : rest) -> headPart : splitOn delimiter rest--ignoreIOError :: IO () -> IO ()-ignoreIOError action =- action `catch` \(_ :: SomeException) -> pure ()
+ src/TuiSpec/Replay.hs view
@@ -0,0 +1,432 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Module : TuiSpec.Replay+Description : JSONL recording and replay primitives for server sessions.++This module isolates the JSONL event log format used by @tuispec server@+recording and replay features.+-}+module TuiSpec.Replay (+ RecordingHandle,+ RecordingEvent (..),+ RecordingDirection (..),+ ReplayFrame (..),+ ReplaySpeed (..),+ applyDelta,+ appendRecordingEvent,+ closeRecording,+ computeFrameDelta,+ extractInputLabel,+ loadReplayFrames,+ openRecording,+ streamReplayFrames,+ streamReplayRequests,+) where++import Control.Concurrent (threadDelay)+import Control.Exception (Exception, bracket, throwIO)+import Control.Monad (when)+import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), Value (Array, Number, Object, String), eitherDecodeStrict', encode, object, withObject, (.:), (.=))+import Data.Aeson qualified as Aeson+import Data.Aeson.KeyMap qualified as KM+import Data.ByteString.Char8 qualified as BS8+import Data.ByteString.Lazy qualified as BL+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.Int (Int64)+import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IM+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as TE+import Data.Time.Clock.POSIX (getPOSIXTime)+import System.Directory (createDirectoryIfMissing)+import System.FilePath (takeDirectory)+import System.IO (Handle, IOMode (AppendMode, ReadMode), hClose, hFlush, hIsEOF, hPutStrLn, openFile)++-- | Direction of a recorded JSON-RPC line, or a viewport frame capture.+data RecordingDirection+ = DirectionRequest+ | DirectionResponse+ | DirectionNotification+ | -- | Full viewport keyframe (line contains the complete visible text).+ DirectionFrame+ | -- | Delta frame (line contains JSON-encoded changed lines since last keyframe).+ DirectionFrameDelta+ deriving (Eq, Show)++instance ToJSON RecordingDirection where+ toJSON value =+ case value of+ DirectionRequest -> toJSON ("request" :: Text)+ DirectionResponse -> toJSON ("response" :: Text)+ DirectionNotification -> toJSON ("notification" :: Text)+ DirectionFrame -> toJSON ("frame" :: Text)+ DirectionFrameDelta -> toJSON ("frame-delta" :: Text)++instance FromJSON RecordingDirection where+ parseJSON value = do+ raw <- parseJSON value+ case (T.toLower (T.strip raw) :: Text) of+ "request" -> pure DirectionRequest+ "response" -> pure DirectionResponse+ "notification" -> pure DirectionNotification+ "frame" -> pure DirectionFrame+ "frame-delta" -> pure DirectionFrameDelta+ _ -> fail "direction must be one of: request, response, notification, frame, frame-delta"++-- | Single JSONL event written to disk.+data RecordingEvent = RecordingEvent+ { recordingTimestampMicros :: Int64+ , recordingDirection :: RecordingDirection+ , recordingLine :: Text+ }+ deriving (Eq, Show)++instance ToJSON RecordingEvent where+ toJSON event =+ object+ [ "timestampMicros" .= recordingTimestampMicros event+ , "direction" .= recordingDirection event+ , "line" .= recordingLine event+ ]++instance FromJSON RecordingEvent where+ parseJSON =+ withObject "RecordingEvent" $ \o ->+ RecordingEvent+ <$> o .: "timestampMicros"+ <*> o .: "direction"+ <*> o .: "line"++-- | Replay speed used by @streamReplayRequests@ and @streamReplayFrames@.+data ReplaySpeed+ = ReplayAsFastAsPossible+ | ReplayRealTime+ deriving (Eq, Show, Read)++-- | Handle wrapper for an active JSONL recording file.+data RecordingHandle = RecordingHandle+ { recordingPath :: FilePath+ , recordingOutputHandle :: Handle+ }++data RecordingParseError = RecordingParseError FilePath String+ deriving (Show)++instance Exception RecordingParseError++-- | Open or create a JSONL recording file in append mode.+openRecording :: FilePath -> IO RecordingHandle+openRecording path = do+ createDirectoryIfMissing True (takeDirectory path)+ handle <- openFile path AppendMode+ pure+ RecordingHandle+ { recordingPath = path+ , recordingOutputHandle = handle+ }++-- | Close an active recording handle.+closeRecording :: RecordingHandle -> IO ()+closeRecording = hClose . recordingOutputHandle++-- | Append one JSON-RPC line event to a recording file.+appendRecordingEvent :: RecordingHandle -> RecordingDirection -> Text -> IO ()+appendRecordingEvent handle direction lineValue = do+ micros <- nowMicros+ let event =+ RecordingEvent+ { recordingTimestampMicros = micros+ , recordingDirection = direction+ , recordingLine = lineValue+ }+ hPutStrLn (recordingOutputHandle handle) (toJsonLine event)+ hFlush (recordingOutputHandle handle)++{- | Stream replay of request events directly from a JSONL recording file,+avoiding loading all events into memory at once. Each request line is+parsed and dispatched to the callback one at a time. Returns the total+number of request events replayed.+-}+streamReplayRequests :: ReplaySpeed -> FilePath -> (Text -> IO ()) -> IO Int+streamReplayRequests speed path runRequest =+ streamFilteredEvents speed path DirectionRequest runRequest++{- | Stream replay of frame events from a JSONL recording file. Handles+both full keyframes (@frame@) and delta frames (@frame-delta@),+reconstructing full viewport text before dispatching to the callback.+Request events are also tracked; the callback receives the last input+label (if any) alongside each frame. Returns the total number of frames+replayed.+-}+streamReplayFrames :: ReplaySpeed -> FilePath -> (Text -> Maybe Text -> IO ()) -> IO Int+streamReplayFrames speed path showFrame =+ bracket (openFile path ReadMode) hClose $ \fileHandle -> do+ currentLinesRef <- newIORef ([] :: [Text])+ lastInputRef <- newIORef (Nothing :: Maybe Text)+ go fileHandle currentLinesRef lastInputRef (1 :: Int) Nothing 0+ where+ go fileHandle currentLinesRef lastInputRef lineNumber maybePrev !count = do+ eof <- hIsEOF fileHandle+ if eof+ then pure count+ else do+ lineValue <- BS8.hGetLine fileHandle+ let trimmed = TE.decodeUtf8 lineValue+ if T.null (T.strip trimmed)+ then go fileHandle currentLinesRef lastInputRef (lineNumber + 1) maybePrev count+ else case eitherDecodeStrict' lineValue of+ Left err ->+ throwIO+ (RecordingParseError path ("line " <> show lineNumber <> ": " <> err))+ Right event+ | recordingDirection event == DirectionRequest -> do+ let label = extractInputLabel (recordingLine event)+ case label of+ Just _ -> writeIORef lastInputRef label+ Nothing -> pure ()+ go fileHandle currentLinesRef lastInputRef (lineNumber + 1) maybePrev count+ | recordingDirection event == DirectionFrame -> do+ applyReplayDelay speed maybePrev event+ let frameLines = T.splitOn "\n" (recordingLine event)+ writeIORef currentLinesRef frameLines+ lastInput <- readIORef lastInputRef+ showFrame (recordingLine event) lastInput+ go fileHandle currentLinesRef lastInputRef (lineNumber + 1) (Just event) (count + 1)+ | recordingDirection event == DirectionFrameDelta -> do+ applyReplayDelay speed maybePrev event+ baseLines <- readIORef currentLinesRef+ let updatedLines = applyDelta baseLines (recordingLine event)+ writeIORef currentLinesRef updatedLines+ lastInput <- readIORef lastInputRef+ showFrame (T.intercalate "\n" updatedLines) lastInput+ go fileHandle currentLinesRef lastInputRef (lineNumber + 1) (Just event) (count + 1)+ | otherwise ->+ go fileHandle currentLinesRef lastInputRef (lineNumber + 1) maybePrev count++-- | Internal: stream events matching a given direction from a JSONL file.+streamFilteredEvents :: ReplaySpeed -> FilePath -> RecordingDirection -> (Text -> IO ()) -> IO Int+streamFilteredEvents speed path direction callback =+ bracket (openFile path ReadMode) hClose $ \fileHandle ->+ go fileHandle (1 :: Int) Nothing 0+ where+ go fileHandle lineNumber maybePrev !count = do+ eof <- hIsEOF fileHandle+ if eof+ then pure count+ else do+ lineValue <- BS8.hGetLine fileHandle+ let trimmed = TE.decodeUtf8 lineValue+ if T.null (T.strip trimmed)+ then go fileHandle (lineNumber + 1) maybePrev count+ else case eitherDecodeStrict' lineValue of+ Left err ->+ throwIO+ (RecordingParseError path ("line " <> show lineNumber <> ": " <> err))+ Right event+ | recordingDirection event == direction -> do+ applyReplayDelay speed maybePrev event+ callback (recordingLine event)+ go fileHandle (lineNumber + 1) (Just event) (count + 1)+ | otherwise ->+ go fileHandle (lineNumber + 1) maybePrev count++-- | Apply inter-event timing delay when in real-time replay mode.+applyReplayDelay :: ReplaySpeed -> Maybe RecordingEvent -> RecordingEvent -> IO ()+applyReplayDelay speed maybePrev event =+ case speed of+ ReplayAsFastAsPossible -> pure ()+ ReplayRealTime ->+ case maybePrev of+ Nothing -> pure ()+ Just prev -> do+ let delta = recordingTimestampMicros event - recordingTimestampMicros prev+ when (delta > 0) $ threadDelay (fromIntegral delta)++{- | Extract a human-readable input label from a JSON-RPC request line.+Returns @Just label@ for input methods (@sendKey@, @sendText@, @sendLine@),+@Nothing@ for non-input methods.+-}+extractInputLabel :: Text -> Maybe Text+extractInputLabel rawLine =+ case Aeson.eitherDecodeStrict' (TE.encodeUtf8 rawLine) of+ Left _ -> Nothing+ Right (Object obj) ->+ case KM.lookup "method" obj of+ Just (String method) -> extractFromMethod method obj+ _ -> Nothing+ Right _ -> Nothing+ where+ extractFromMethod method obj =+ case KM.lookup "params" obj of+ Just (Object params) ->+ case method of+ "sendKey" ->+ case KM.lookup "key" params of+ Just (String k) -> Just ("Key: " <> k)+ _ -> Nothing+ "sendText" ->+ case KM.lookup "text" params of+ Just (String t) -> Just ("Text: " <> showTextValue t)+ _ -> Nothing+ "sendLine" ->+ case KM.lookup "text" params of+ Just (String t) -> Just ("Line: " <> t)+ _ -> Nothing+ _ -> Nothing+ _ -> Nothing+ showTextValue t+ | t == " " = "<Space>"+ | t == "\t" = "<Tab>"+ | otherwise = "\"" <> t <> "\""++{- | Compute a line-level delta between two viewport texts. Returns+@Nothing@ when the frames are identical, or @Just encodedDelta@ with a+JSON-encoded array of @[lineIndex, \"new line text\"]@ pairs for each+changed line.+-}+computeFrameDelta :: Text -> Text -> Maybe Text+computeFrameDelta oldFrame newFrame+ | oldFrame == newFrame = Nothing+ | otherwise =+ let oldLines = T.splitOn "\n" oldFrame+ newLines = T.splitOn "\n" newFrame+ changes = collectChanges 0 oldLines newLines+ in if null changes+ then Nothing+ else Just (encodeDelta changes)++-- | Collect (index, newLine) pairs for lines that differ.+collectChanges :: Int -> [Text] -> [Text] -> [(Int, Text)]+collectChanges !idx olds news =+ case (olds, news) of+ ([], []) -> []+ ([], n : ns) -> (idx, n) : collectChanges (idx + 1) [] ns+ (_ : os, []) -> (idx, "") : collectChanges (idx + 1) os []+ (o : os, n : ns)+ | o == n -> collectChanges (idx + 1) os ns+ | otherwise -> (idx, n) : collectChanges (idx + 1) os ns++-- | Encode a list of (lineIndex, text) changes as a JSON array of pairs.+encodeDelta :: [(Int, Text)] -> Text+encodeDelta changes =+ TE.decodeUtf8 . BL.toStrict . Aeson.encode $+ Array (listToAesonArray (map encodePair changes))+ where+ encodePair (idx, txt) =+ Array (listToAesonArray [Number (fromIntegral idx), String txt])++-- | Apply a JSON-encoded delta to a list of lines.+applyDelta :: [Text] -> Text -> [Text]+applyDelta baseLines deltaText =+ case Aeson.eitherDecodeStrict' (TE.encodeUtf8 deltaText) of+ Left _ -> baseLines+ Right (Array arr) ->+ let patches = foldr parsePatch IM.empty (aesonArrayToList arr)+ baseMap = IM.fromList (zip [0 ..] baseLines)+ maxIdx = if IM.null patches then 0 else fst (IM.findMax patches)+ paddedMap =+ if maxIdx >= length baseLines+ then IM.union baseMap (IM.fromList [(i, "") | i <- [length baseLines .. maxIdx]])+ else baseMap+ merged = IM.union patches paddedMap+ in map snd (IM.toAscList merged)+ Right _ -> baseLines+ where+ parsePatch :: Value -> IntMap Text -> IntMap Text+ parsePatch (Array pair) acc =+ case aesonArrayToList pair of+ [Number n, String txt] -> IM.insert (floor n) txt acc+ _ -> acc+ parsePatch _ acc = acc++-- | Convert a Haskell list to an Aeson Array value.+listToAesonArray :: [Value] -> Aeson.Array+listToAesonArray = foldMap (\v -> pure v)++-- | Convert an Aeson Array to a Haskell list.+aesonArrayToList :: Aeson.Array -> [Value]+aesonArrayToList = foldr (:) []++toJsonLine :: RecordingEvent -> String+toJsonLine = T.unpack . TE.decodeUtf8 . BL.toStrict . encode++-- | A single reconstructed replay frame with full viewport text.+data ReplayFrame = ReplayFrame+ { replayFrameText :: Text+ , replayFrameInput :: Maybe Text+ , replayFrameTimestampMicros :: Int64+ , replayFrameIsKeyframe :: Bool+ -- ^ Whether this frame was a full keyframe (@True@) or reconstructed from a delta (@False@).+ , replayFrameDelta :: Maybe Text+ -- ^ Raw delta payload for non-keyframe frames, 'Nothing' for keyframes.+ }+ deriving (Eq, Show)++{- | Load all replay frames from a JSONL recording file into a list.+Delta frames are reconstructed into full viewport text so every element+contains the complete frame content ready for display.+-}+loadReplayFrames :: FilePath -> IO [ReplayFrame]+loadReplayFrames path =+ bracket (openFile path ReadMode) hClose $ \fileHandle -> do+ currentLinesRef <- newIORef ([] :: [Text])+ lastInputRef <- newIORef (Nothing :: Maybe Text)+ go fileHandle currentLinesRef lastInputRef (1 :: Int) []+ where+ go fileHandle currentLinesRef lastInputRef lineNumber !acc = do+ eof <- hIsEOF fileHandle+ if eof+ then pure (reverse acc)+ else do+ lineValue <- BS8.hGetLine fileHandle+ let trimmed = TE.decodeUtf8 lineValue+ if T.null (T.strip trimmed)+ then go fileHandle currentLinesRef lastInputRef (lineNumber + 1) acc+ else case eitherDecodeStrict' lineValue of+ Left err ->+ throwIO+ (RecordingParseError path ("line " <> show lineNumber <> ": " <> err))+ Right event+ | recordingDirection event == DirectionRequest -> do+ let label = extractInputLabel (recordingLine event)+ case label of+ Just _ -> writeIORef lastInputRef label+ Nothing -> pure ()+ go fileHandle currentLinesRef lastInputRef (lineNumber + 1) acc+ | recordingDirection event == DirectionFrame -> do+ let frameLines = T.splitOn "\n" (recordingLine event)+ writeIORef currentLinesRef frameLines+ lastInput <- readIORef lastInputRef+ let frame =+ ReplayFrame+ { replayFrameText = recordingLine event+ , replayFrameInput = lastInput+ , replayFrameTimestampMicros = recordingTimestampMicros event+ , replayFrameIsKeyframe = True+ , replayFrameDelta = Nothing+ }+ go fileHandle currentLinesRef lastInputRef (lineNumber + 1) (frame : acc)+ | recordingDirection event == DirectionFrameDelta -> do+ baseLines <- readIORef currentLinesRef+ let updatedLines = applyDelta baseLines (recordingLine event)+ writeIORef currentLinesRef updatedLines+ lastInput <- readIORef lastInputRef+ let fullText = T.intercalate "\n" updatedLines+ let frame =+ ReplayFrame+ { replayFrameText = fullText+ , replayFrameInput = lastInput+ , replayFrameTimestampMicros = recordingTimestampMicros event+ , replayFrameIsKeyframe = False+ , replayFrameDelta = Just (recordingLine event)+ }+ go fileHandle currentLinesRef lastInputRef (lineNumber + 1) (frame : acc)+ | otherwise ->+ go fileHandle currentLinesRef lastInputRef (lineNumber + 1) acc++nowMicros :: IO Int64+nowMicros = do+ now <- getPOSIXTime+ pure (floor (now * 1000000))
src/TuiSpec/Runner.hs view
@@ -27,23 +27,25 @@ typeText, killSessionChildrenNow, waitForSelector,+ waitForSelectorWithAmbiguity, defaultWaitOptionsFor, withTuiSession, waitFor,+ waitForStable, waitForText, ) where import Control.Concurrent (threadDelay)-import Control.Exception (Exception, SomeException, catch, displayException, finally, throwIO, toException, try)-import Control.Monad (unless, void, when)+import Control.Exception (Exception, SomeException, displayException, finally, throwIO, toException, try)+import Control.Monad (unless, when) import Data.Aeson (encode, object, (.=)) import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as BL-import Data.Char (chr, isAlphaNum, ord, toLower)+import Data.Char (chr, ord, toLower) import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef) import Data.IntMap.Strict qualified as IM-import Data.List (intercalate, isSuffixOf, nub, sort)-import Data.Maybe (fromMaybe)+import Data.List (intercalate, nub, sort)+import Data.Maybe (fromMaybe, isJust) import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as TE@@ -57,11 +59,12 @@ import System.Posix.Pty qualified as Pty import System.Posix.Signals (sigKILL, signalProcess, signalProcessGroup) import System.Posix.Types (ProcessGroupID)-import System.Process (getPid, terminateProcess, waitForProcess)+import System.Process (ProcessHandle, getPid, getProcessExitCode, terminateProcess) import System.Timeout (timeout) import Test.Tasty (TestTree) import Test.Tasty.HUnit (assertFailure, testCase) import Text.Read (readMaybe)+import TuiSpec.Internal (cleanPattern, ignoreIOError, regexLikeMatch, resolveAutoSnapshotTheme, safeFileStem, safeIndex, snapshotMetadataPath, wildcardContains) import TuiSpec.ProjectRoot (resolveProjectRoot) import TuiSpec.Types @@ -160,19 +163,19 @@ If an app is already running for the test, it is terminated first. -} launch :: Tui -> App -> IO ()-launch tui app = do- appendAction tui ("launch " <> T.pack (command app))+launch tui appSpec = do+ appendAction tui ("launch " <> T.pack (command appSpec)) currentPty <- readPty tui case currentPty of Just ptyHandle -> terminatePtyHandle ptyHandle Nothing -> pure () writePty tui Nothing- maybePty <- initializePty (terminalRows (tuiOptions tui)) (terminalCols (tuiOptions tui)) app+ maybePty <- initializePty (terminalRows (tuiOptions tui)) (terminalCols (tuiOptions tui)) appSpec case maybePty of Just ptyHandle -> do writePty tui (Just ptyHandle)- modifyState tui $ \state -> state{launchedApp = Just app}+ modifyState tui $ \state -> state{launchedApp = Just appSpec} threadDelay settleDelayMicros _ <- syncVisibleBuffer tui pure ()@@ -265,10 +268,21 @@ -- | Wait for a selector with explicit wait options and ambiguity handling. waitForSelector :: Tui -> WaitOptions -> Selector -> IO () waitForSelector tui waitOptions selector = do+ waitForSelectorWithAmbiguity tui waitOptions Nothing selector++-- | Wait for a selector with explicit wait and optional ambiguity mode override.+waitForSelectorWithAmbiguity :: Tui -> WaitOptions -> Maybe AmbiguityMode -> Selector -> IO ()+waitForSelectorWithAmbiguity tui waitOptions ambiguityOverride selector = do waitFor tui waitOptions (selectorMatches selector) viewport <- currentViewport tui- assertNotAmbiguous tui selector viewport+ assertNotAmbiguousWithMode (tuiName tui) effectiveMode selector viewport+ where+ effectiveMode =+ case ambiguityOverride of+ Just overrideMode -> overrideMode+ Nothing -> ambiguityMode (tuiOptions tui) +-- | Derive default wait settings for a TUI from its configured run options. defaultWaitOptionsFor :: Tui -> WaitOptions defaultWaitOptionsFor tui = defaultWaitOptions@@ -296,6 +310,35 @@ threadDelay (pollIntervalMs waitOptions * 1000) loop startedAt +{- | Wait until the viewport text has not changed for @debounceMs@ milliseconds.++This replaces brittle fixed @threadDelay@ calls with a semantic stability+check: the viewport is polled at @pollIntervalMs@ intervals, and the call+returns once the visible text has remained identical for at least @debounceMs@+consecutive milliseconds. Throws on overall timeout.+-}+waitForStable :: Tui -> WaitOptions -> Int -> IO ()+waitForStable tui waitOptions debounceMs = do+ start <- getCurrentTime+ initialView <- syncVisibleBuffer tui+ loop start initialView start+ where+ timeoutLimit = fromIntegral (timeoutMs waitOptions) / 1000 :: NominalDiffTime+ debounceLimit = fromIntegral debounceMs / 1000 :: NominalDiffTime++ loop :: UTCTime -> Text -> UTCTime -> IO ()+ loop startedAt lastView lastChangedAt = do+ threadDelay (pollIntervalMs waitOptions * 1000)+ now <- getCurrentTime+ if diffUTCTime now startedAt >= timeoutLimit+ then throwIO (AssertionError "waitForStable timed out")+ else do+ currentText <- syncVisibleBuffer tui+ let changedAt = if currentText /= lastView then now else lastChangedAt+ if diffUTCTime now changedAt >= debounceLimit+ then pure ()+ else loop startedAt currentText changedAt+ {- | Capture and compare the current PTY screen against a named snapshot. Writes:@@ -469,21 +512,22 @@ pure tui initializePty :: Int -> Int -> App -> IO (Maybe PtyHandle)-initializePty rows cols app = do- result <- try (startPty rows cols app) :: IO (Either SomeException PtyHandle)+initializePty rows cols appSpec = do+ result <- try (startPty rows cols appSpec) :: IO (Either SomeException PtyHandle) case result of Left _ -> pure Nothing Right handle -> pure (Just handle) startPty :: Int -> Int -> App -> IO PtyHandle-startPty rows cols app = do- processEnv <- withTerminalEnv+startPty rows cols appSpec = do+ processEnv <- withTerminalEnv (env appSpec)+ let (effectiveCommand, effectiveArgs) = wrapLaunchWithCwd appSpec (master, processHandle) <- Pty.spawnWithPty (Just processEnv) True- (command app)- (args app)+ effectiveCommand+ effectiveArgs (cols, rows) pure PtyHandle@@ -491,14 +535,52 @@ , ptyProcess = processHandle } -withTerminalEnv :: IO [(String, String)]-withTerminalEnv = do+withTerminalEnv :: Maybe [(String, Maybe String)] -> IO [(String, String)]+withTerminalEnv envOverrides = do existing <- getEnvironment- pure (overrideEnv "TERM" "xterm-256color" existing)+ let merged =+ case envOverrides of+ Nothing -> existing+ Just overrides ->+ foldl'+ (\acc (key, value) -> applyEnvOverride key value acc)+ existing+ overrides+ pure+ ( applyEnvOverride "COLORTERM" Nothing+ . applyEnvOverride "TERM" (Just "xterm-256color")+ $ merged+ ) where- overrideEnv key value pairs =- (key, value) : filter ((/= key) . fst) pairs+ applyEnvOverride key maybeValue pairs =+ case maybeValue of+ Nothing ->+ filter ((/= key) . fst) pairs+ Just value ->+ (key, value) : filter ((/= key) . fst) pairs +wrapLaunchWithCwd :: App -> (FilePath, [String])+wrapLaunchWithCwd appSpec =+ case cwd appSpec of+ Nothing -> (command appSpec, args appSpec)+ Just cwdPath ->+ ( "/bin/sh"+ ,+ [ "-lc"+ , "cd "+ <> shellQuote cwdPath+ <> " && exec "+ <> unwords (map shellQuote (command appSpec : args appSpec))+ ]+ )++shellQuote :: String -> String+shellQuote value =+ "'" <> concatMap escapeChar value <> "'"+ where+ escapeChar '\'' = "'\\''"+ escapeChar c = [c]+ teardownTui :: Tui -> IO () teardownTui tui = do@@ -512,17 +594,30 @@ terminatePtyHandle :: PtyHandle -> IO () terminatePtyHandle ptyHandle = do _ <- timeout (500 * 1000) (ignoreIOError (terminateProcess (ptyProcess ptyHandle)))- waitResult <- timeout (500 * 1000) (ignoreIOError (void (waitForProcess (ptyProcess ptyHandle))))- case waitResult of- Just () ->- pure ()- Nothing -> do- killPtyProcessGroupNow ptyHandle- _ <- timeout (500 * 1000) (ignoreIOError (void (waitForProcess (ptyProcess ptyHandle))))- pure ()+ exitedAfterTerminate <- waitForProcessExitWithin (500 * 1000) (ptyProcess ptyHandle)+ unless exitedAfterTerminate $ do+ killPtyProcessGroupNow ptyHandle+ _ <- waitForProcessExitWithin (500 * 1000) (ptyProcess ptyHandle)+ pure () _ <- timeout (500 * 1000) (ignoreIOError (Pty.closePty (ptyMaster ptyHandle))) pure () +waitForProcessExitWithin :: Int -> ProcessHandle -> IO Bool+waitForProcessExitWithin timeoutMicros processHandle =+ go (max 1 (timeoutMicros `div` pollMicros))+ where+ pollMicros = 20 * 1000++ go 0 = isJust <$> getProcessExitCode processHandle+ go remaining = do+ status <- getProcessExitCode processHandle+ case status of+ Just _ ->+ pure True+ Nothing -> do+ threadDelay pollMicros+ go (remaining - 1)+ killPtyProcessGroupNow :: PtyHandle -> IO () killPtyProcessGroupNow ptyHandle = do maybePid <- getPid (ptyProcess ptyHandle)@@ -715,7 +810,12 @@ _ -> pure acc -data EmuColor = EmuColor Int Int Int+{- | A terminal color, either an exact RGB triple or a palette index (0–15)+that is resolved against the active t'ThemePalette' at render time.+-}+data EmuColor+ = EmuColor Int Int Int+ | EmuPaletteColor Int data EmuCellStyle = EmuCellStyle { cellFg :: Maybe EmuColor@@ -843,21 +943,21 @@ , paletteDefaultFg = EmuColor 0 0 0 , paletteAnsi16 = [ EmuColor 0 0 0- , EmuColor 205 0 0- , EmuColor 0 205 0- , EmuColor 205 205 0- , EmuColor 0 0 238- , EmuColor 205 0 205- , EmuColor 0 205 205- , EmuColor 229 229 229- , EmuColor 127 127 127- , EmuColor 255 0 0- , EmuColor 0 255 0- , EmuColor 255 255 0- , EmuColor 92 92 255- , EmuColor 255 0 255- , EmuColor 0 255 255- , EmuColor 255 255 255+ , EmuColor 205 49 49+ , EmuColor 0 188 0+ , EmuColor 148 152 0+ , EmuColor 4 81 165+ , EmuColor 188 5 188+ , EmuColor 5 152 188+ , EmuColor 85 85 85+ , EmuColor 102 102 102+ , EmuColor 205 49 49+ , EmuColor 20 158 20+ , EmuColor 158 152 0+ , EmuColor 4 81 165+ , EmuColor 188 5 188+ , EmuColor 5 152 188+ , EmuColor 165 165 165 ] } @@ -899,19 +999,29 @@ , styledBgColor = paletteDefaultBg palette } +{- | Resolve an t'EmuColor' against the theme palette.++v'EmuPaletteColor' indices are looked up in the theme's 16-color table;+literal v'EmuColor' RGB triples pass through unchanged.+-}+resolveColor :: ThemePalette -> EmuColor -> EmuColor+resolveColor _ (EmuColor r g b) = EmuColor r g b+resolveColor palette (EmuPaletteColor code) =+ fromMaybe (EmuColor 0 0 0) (safeIndex code (paletteAnsi16 palette))+ resolveCellFg :: SnapshotTheme -> EmuCellStyle -> EmuColor resolveCellFg theme styleValue = if cellReverse styleValue- then fromMaybe (paletteDefaultBg palette) (cellBg styleValue)- else fromMaybe (paletteDefaultFg palette) (cellFg styleValue)+ then maybe (paletteDefaultBg palette) (resolveColor palette) (cellBg styleValue)+ else maybe (paletteDefaultFg palette) (resolveColor palette) (cellFg styleValue) where palette = themePalette theme resolveCellBg :: SnapshotTheme -> EmuCellStyle -> EmuColor resolveCellBg theme styleValue = if cellReverse styleValue- then fromMaybe (paletteDefaultFg palette) (cellFg styleValue)- else fromMaybe (paletteDefaultBg palette) (cellBg styleValue)+ then maybe (paletteDefaultFg palette) (resolveColor palette) (cellFg styleValue)+ else maybe (paletteDefaultBg palette) (resolveColor palette) (cellBg styleValue) where palette = themePalette theme @@ -1112,23 +1222,22 @@ colorSafe value = max 0 (min 255 value) mapBasicColor code- | code >= 0 && code < 16 =- fromMaybe- (EmuColor 0 0 0)- (safeIndex code (paletteAnsi16 (themePalette defaultSnapshotTheme)))+ | code >= 0 && code < 16 = EmuPaletteColor code | otherwise = EmuColor 0 0 0 - colorFromCode value =- EmuColor r g b- where- (r, g, b) = ansiColorFromCode value+ colorFromCode value+ | value >= 0 && value < 16 = EmuPaletteColor value+ | otherwise =+ let (r, g, b) = ansiColorFromCode value+ in EmuColor r g b +{- | Convert a 256-color code (16–255) to an RGB triple.++Palette colors 0–15 are theme-dependent and handled separately as+'EmuPaletteColor' indices.+-} ansiColorFromCode :: Int -> (Int, Int, Int) ansiColorFromCode value- | value >= 0 && value < 16 =- let EmuColor rValue gValue bValue =- fromMaybe (EmuColor 0 0 0) (safeIndex value (paletteAnsi16 (themePalette defaultSnapshotTheme)))- in (rValue, gValue, bValue) | value >= 16 && value <= 231 = let level v = (v * 51) rValue = level ((value - 16) `div` 36)@@ -1139,6 +1248,7 @@ let gray = 8 + (value - 232) * 10 in (gray, gray, gray) | otherwise = (0, 0, 0)+ parseCsiParams :: String -> [Int] parseCsiParams value = case splitOnSemicolon value of@@ -1318,10 +1428,12 @@ <> "]" colorJson colorValue =- let EmuColor rValue gValue bValue = colorValue- in "["- <> intercalate "," (map show [rValue, gValue, bValue])- <> "]"+ case colorValue of+ EmuColor rValue gValue bValue ->+ "[" <> intercalate "," (map show [rValue, gValue, bValue]) <> "]"+ EmuPaletteColor _ ->+ -- Palette colors should already be resolved before serialization.+ "[0,0,0]" snapshotThemeName :: SnapshotTheme -> String snapshotThemeName PtyDefaultDark = "pty-default-dark"@@ -1342,18 +1454,21 @@ assertNotAmbiguous :: Tui -> Selector -> Viewport -> IO () assertNotAmbiguous tui selector viewport =+ assertNotAmbiguousWithMode (tuiName tui) (ambiguityMode (tuiOptions tui)) selector viewport++assertNotAmbiguousWithMode :: String -> AmbiguityMode -> Selector -> Viewport -> IO ()+assertNotAmbiguousWithMode testName mode selector viewport = when shouldFail $ throwIO $ AssertionError ( "Ambiguous selector for test '"- <> tuiName tui+ <> testName <> "'; matched " <> show totalMatches <> " elements." ) where totalMatches = matchCount selector viewport- mode = ambiguityMode (tuiOptions tui) shouldFail = mode == FailOnAmbiguous && totalMatches > 1@@ -1385,34 +1500,6 @@ if wildcardContains alternative haystack then 1 else 0 | otherwise = occurrenceCount alternative haystack -regexLikeMatch :: Text -> Text -> Bool-regexLikeMatch patternText haystack =- any (`wildcardContains` haystack) alternatives- where- alternatives =- filter (not . T.null) $- map cleanPattern (T.splitOn "|" patternText)--cleanPattern :: Text -> Text-cleanPattern = T.filter (`notElem` ("()" :: String))--wildcardContains :: Text -> Text -> Bool-wildcardContains patternText haystack =- checkSegments 0 segments- where- segments = filter (not . T.null) (T.splitOn ".*" patternText)-- checkSegments :: Int -> [Text] -> Bool- checkSegments _ [] = True- checkSegments fromIdx (segment : rest) =- let remaining = T.drop fromIdx haystack- (prefix, suffix) = T.breakOn segment remaining- in if T.null suffix- then False- else- let nextStart = fromIdx + T.length prefix + T.length segment- in checkSegments nextStart rest- occurrenceCount :: Text -> Text -> Int occurrenceCount needle haystack | T.null needle = 0@@ -1443,15 +1530,6 @@ selectedRows = take h (drop y linesInViewport) croppedLines = map (T.take w . T.drop x) selectedRows -safeIndex :: Int -> [a] -> Maybe a-safeIndex indexValue values- | indexValue < 0 = Nothing- | otherwise = go indexValue values- where- go _ [] = Nothing- go 0 (x : _) = Just x- go n (_ : xs) = go (n - 1) xs- safeTextIndex :: Int -> Text -> Maybe Char safeTextIndex indexValue textValue | indexValue < 0 = Nothing@@ -1507,33 +1585,9 @@ exists <- doesDirectoryExist dir when exists (removePathForcibly dir) -safeFileStem :: String -> String-safeFileStem input =- let lowered = map toLower input- normalized = map normalize lowered- compact = collapseDashes normalized- trimmed = trimDashes compact- in if null trimmed then "snapshot" else trimmed- where- normalize c- | isAlphaNum c = c- | otherwise = '-'-- collapseDashes [] = []- collapseDashes ('-' : '-' : rest) = collapseDashes ('-' : rest)- collapseDashes (c : rest) = c : collapseDashes rest-- trimDashes = reverse . dropWhile (== '-') . reverse . dropWhile (== '-')- slugify :: String -> String slugify = safeFileStem -snapshotMetadataPath :: FilePath -> FilePath-snapshotMetadataPath ansiPath =- if ".ansi.txt" `isSuffixOf` ansiPath- then take (length ansiPath - length (".ansi.txt" :: String)) ansiPath <> ".meta.json"- else ansiPath <> ".meta.json"- writeSnapshotMetadata :: FilePath -> Int -> Int -> IO () writeSnapshotMetadata metaPath rows cols = BL.writeFile@@ -1542,6 +1596,7 @@ ( object [ "rows" .= rows , "cols" .= cols+ , "version" .= tuispecVersion ] ) )@@ -1628,35 +1683,6 @@ "fail" -> Just FailOnAmbiguous "first" -> Just FirstVisibleMatch "first-visible" -> Just FirstVisibleMatch+ "last" -> Just LastVisibleMatch+ "last-visible" -> Just LastVisibleMatch _ -> Nothing--resolveAutoSnapshotTheme :: String -> Maybe String -> String-resolveAutoSnapshotTheme requestedTheme colorFgBgValue =- case map toLower requestedTheme of- "auto" ->- case detectTerminalBackground colorFgBgValue of- Just "light" -> "pty-default-light"- _ -> "pty-default-dark"- _ -> requestedTheme--detectTerminalBackground :: Maybe String -> Maybe String-detectTerminalBackground colorFgBgValue =- case colorFgBgValue >>= parseBgIndex of- Just bgIndex | bgIndex >= 7 -> Just "light"- Just _ -> Just "dark"- Nothing -> Nothing- where- parseBgIndex raw =- case reverse (splitOn ';' raw) of- [] -> Nothing- lastPart : _ -> (readMaybe lastPart :: Maybe Int)-- splitOn _ [] = [""]- splitOn delimiter input =- case break (== delimiter) input of- (headPart, []) -> [headPart]- (headPart, _ : rest) -> headPart : splitOn delimiter rest--ignoreIOError :: IO () -> IO ()-ignoreIOError action =- action `catch` \(_ :: SomeException) -> pure ()
src/TuiSpec/Server.hs view
@@ -12,732 +12,1815 @@ runServer, ) where -import Control.Exception (SomeException, displayException, finally, try)-import Control.Monad (when)-import Data.Aeson (FromJSON (parseJSON), Result (Error, Success), Value (Null, Object), eitherDecodeStrict', encode, fromJSON, object, withObject, (.:), (.:?), (.=))-import Data.Aeson.KeyMap qualified as KM-import Data.Aeson.Types qualified as AesonTypes-import Data.ByteString qualified as BS-import Data.ByteString.Char8 qualified as BS8-import Data.ByteString.Lazy.Char8 qualified as BL8-import Data.Char (isAlphaNum, toLower)-import Data.IORef (IORef, newIORef, readIORef, writeIORef)-import Data.List (isSuffixOf)-import Data.Text (Text)-import Data.Text qualified as T-import JSONRPC qualified as RPC-import System.Directory (doesFileExist)-import System.Exit (ExitCode (ExitSuccess))-import System.FilePath ((</>))-import System.IO (hFlush, stdin, stdout)-import System.IO.Error (isEOFError, tryIOError)-import System.Posix.Process (exitImmediately)-import System.Posix.Signals (Handler (Catch), installHandler, sigHUP)-import TuiSpec.Runner (currentView, defaultWaitOptionsFor, dumpView, expectNotVisible, expectSnapshot, expectVisible, killSessionChildrenNow, launch, openSession, press, pressCombo, sendLine, typeText, waitForSelector)-import TuiSpec.Types (AmbiguityMode (FailOnAmbiguous, FirstVisibleMatch), App (App), Key (..), Modifier (Alt, Control, Shift), Rect (Rect), RunOptions (..), Selector (..), SnapshotName (SnapshotName), Tui (..), WaitOptions (..), defaultRunOptions)---- | Configuration for the JSON-RPC server.-data ServerOptions = ServerOptions- { serverArtifactsDir :: FilePath- -- ^ Base directory for session artifacts.- , serverTerminalCols :: Int- -- ^ Default terminal columns for launched sessions.- , serverTerminalRows :: Int- -- ^ Default terminal rows for launched sessions.- , serverTimeoutSeconds :: Int- -- ^ Default timeout for wait operations.- , serverAmbiguityMode :: AmbiguityMode- -- ^ Default ambiguity mode for selector assertions.- }- deriving (Eq, Show)--data ActiveSession = ActiveSession- { activeTui :: Tui- }--data ServerState = ServerState- { stateOptions :: ServerOptions- , stateActiveSession :: IORef (Maybe ActiveSession)- }--data DispatchOutcome- = Continue Value- | Shutdown Value--data RpcFailure = RpcFailure- { failureCode :: Int- , failureMessage :: Text- , failureData :: Maybe Value- }---- | Run the JSON-RPC server, reading requests from stdin and writing responses to stdout.-runServer :: ServerOptions -> IO ()-runServer options = do- sessionRef <- newIORef Nothing- let state = ServerState{stateOptions = options, stateActiveSession = sessionRef}- _ <- installHandler sigHUP (Catch (handleSighup state)) Nothing- loop state `finally` killActiveChildrenNow state- where- handleSighup state = do- killActiveChildrenNow state- exitImmediately ExitSuccess-- loop state = do- lineResult <- tryIOError (BS8.hGetLine stdin)- case lineResult of- Left ioErr- | isEOFError ioErr -> pure ()- | otherwise -> pure ()- Right line ->- if BS.null line- then loop state- else do- shouldContinue <- handleLine state line- when shouldContinue (loop state)--handleLine :: ServerState -> BS.ByteString -> IO Bool-handleLine state line =- case eitherDecodeStrict' line :: Either String RPC.JSONRPCRequest of- Left parseErr -> do- writeErrorResponse (RPC.RequestId Null) (parseError parseErr)- Right request ->- case validateRequestVersion request of- Left err -> do- writeErrorResponse (requestId request) err- Right () -> do- outcome <- dispatchRequest state request- case outcome of- Left err ->- writeErrorResponse (requestId request) err- Right (Continue resultValue) ->- writeSuccessResponse (requestId request) resultValue- Right (Shutdown resultValue) -> do- _ <- writeSuccessResponse (requestId request) resultValue- pure False--validateRequestVersion :: RPC.JSONRPCRequest -> Either RpcFailure ()-validateRequestVersion request =- if requestVersion request == RPC.rPC_VERSION- then Right ()- else Left (invalidRequest "Expected jsonrpc field to equal \"2.0\"")--dispatchRequest :: ServerState -> RPC.JSONRPCRequest -> IO (Either RpcFailure DispatchOutcome)-dispatchRequest state request =- case requestMethod request of- "initialize" -> dispatchInitialize state request- "launch" -> dispatchLaunch state request- "sendKey" -> dispatchSendKey state request- "sendText" -> dispatchSendText state request- "sendLine" -> dispatchSendLine state request- "currentView" -> dispatchCurrentView state request- "dumpView" -> dispatchDumpView state request- "expectSnapshot" -> dispatchExpectSnapshot state request- "waitForText" -> dispatchWaitForText state request- "expectVisible" -> dispatchExpectVisible state request- "expectNotVisible" -> dispatchExpectNotVisible state request- "server.ping" -> dispatchPing request- "server.shutdown" -> dispatchShutdown state request- unknownMethod ->- pure $- Left- ( RpcFailure- { failureCode = RPC.mETHOD_NOT_FOUND- , failureMessage = "Method not found"- , failureData = Just (object ["method" .= unknownMethod])- }- )--dispatchInitialize :: ServerState -> RPC.JSONRPCRequest -> IO (Either RpcFailure DispatchOutcome)-dispatchInitialize state request = do- existing <- readIORef (stateActiveSession state)- case existing of- Just _ ->- pure (Left sessionAlreadyStartedError)- Nothing ->- case decodeParams request of- Left err -> pure (Left err)- Right params -> do- let sessionName = T.unpack (T.strip (fromMaybeText "session" (startName params)))- if null sessionName- then pure (Left (invalidParams "session name cannot be empty"))- else do- case resolveAmbiguityOverride (startAmbiguityMode params) of- Left ambiguityErr ->- pure (Left (invalidParams ambiguityErr))- Right ambiguityOverride -> do- let runOptions = applyStartParams (stateOptions state) params ambiguityOverride- sessionResult <- try (openSession runOptions sessionName) :: IO (Either SomeException Tui)- case sessionResult of- Left err ->- pure (Left (methodFailed (displayException err)))- Right tui -> do- writeIORef (stateActiveSession state) (Just (ActiveSession tui))- pure $- Right $- Continue- ( object- [ "sessionName" .= sessionName- , "artifactRoot" .= tuiTestRoot tui- , "rows" .= terminalRows (tuiOptions tui)- , "cols" .= terminalCols (tuiOptions tui)- ]- )--dispatchLaunch :: ServerState -> RPC.JSONRPCRequest -> IO (Either RpcFailure DispatchOutcome)-dispatchLaunch state request =- withActiveSession state $ \active ->- case decodeParams request of- Left err -> pure (Left err)- Right params ->- runMethod $- launch (activeTui active) (App (launchCommand params) (launchArgs params))- >> pure (object ["ok" .= True])--dispatchSendKey :: ServerState -> RPC.JSONRPCRequest -> IO (Either RpcFailure DispatchOutcome)-dispatchSendKey state request =- withActiveSession state $ \active ->- case decodeParams request of- Left err -> pure (Left err)- Right params ->- case parseSendKey (sendKeyValue params) of- Left keyErr -> pure (Left (invalidParams keyErr))- Right (modifiers, keyValue) ->- runMethod $- do- if null modifiers- then press (activeTui active) keyValue- else pressCombo (activeTui active) modifiers keyValue- pure (object ["ok" .= True])--dispatchSendText :: ServerState -> RPC.JSONRPCRequest -> IO (Either RpcFailure DispatchOutcome)-dispatchSendText state request =- withActiveSession state $ \active ->- case decodeParams request of- Left err -> pure (Left err)- Right params ->- runMethod $- typeText (activeTui active) (sendTextValue params)- >> pure (object ["ok" .= True])--dispatchSendLine :: ServerState -> RPC.JSONRPCRequest -> IO (Either RpcFailure DispatchOutcome)-dispatchSendLine state request =- withActiveSession state $ \active ->- case decodeParams request of- Left err -> pure (Left err)- Right params ->- runMethod $- sendLine (activeTui active) (sendLineValue params)- >> pure (object ["ok" .= True])--dispatchCurrentView :: ServerState -> RPC.JSONRPCRequest -> IO (Either RpcFailure DispatchOutcome)-dispatchCurrentView state request =- withActiveSession state $ \active ->- case requireNoParams request of- Left err -> pure (Left err)- Right () ->- runMethod $ do- textValue <- currentView (activeTui active)- let options = tuiOptions (activeTui active)- pure- ( object- [ "text" .= textValue- , "rows" .= terminalRows options- , "cols" .= terminalCols options- ]- )--dispatchDumpView :: ServerState -> RPC.JSONRPCRequest -> IO (Either RpcFailure DispatchOutcome)-dispatchDumpView state request =- withActiveSession state $ \active ->- case decodeParams request of- Left err -> pure (Left err)- Right params ->- runMethod $ do- ansiPath <- dumpView (activeTui active) (SnapshotName (dumpName params))- pure- ( object- [ "snapshotPath" .= ansiPath- , "metaPath" .= snapshotMetaPath ansiPath- ]- )--dispatchExpectSnapshot :: ServerState -> RPC.JSONRPCRequest -> IO (Either RpcFailure DispatchOutcome)-dispatchExpectSnapshot state request =- withActiveSession state $ \active ->- case decodeParams request of- Left err -> pure (Left err)- Right params ->- runMethod $ do- let snapshotText = expectSnapshotNameValue params- let snapshotStem = safeSnapshotStem (T.unpack snapshotText)- let tui = activeTui active- let actualPath = tuiTestRoot tui </> "snapshots" </> (snapshotStem <> ".ansi.txt")- let baselinePath = tuiSnapshotRoot tui </> (snapshotStem <> ".ansi.txt")- expectSnapshot tui (SnapshotName snapshotText)- baselineExists <- doesFileExist baselinePath- pure- ( object- [ "ok" .= True- , "actualPath" .= actualPath- , "baselinePath" .= baselinePath- , "baselineExists" .= baselineExists- ]- )--dispatchWaitForText :: ServerState -> RPC.JSONRPCRequest -> IO (Either RpcFailure DispatchOutcome)-dispatchWaitForText state request =- withActiveSession state $ \active ->- case decodeParams request of- Left err -> pure (Left err)- Right params ->- runMethod $ do- let tui = activeTui active- let defaults = defaultWaitOptionsFor tui- let mergedWaitOptions =- defaults- { timeoutMs = maybe (timeoutMs defaults) id (waitTimeoutMs params)- , pollIntervalMs = maybe (pollIntervalMs defaults) id (waitPollIntervalMs params)- }- waitForSelector tui mergedWaitOptions (waitSelector params)- pure (object ["ok" .= True])--dispatchExpectVisible :: ServerState -> RPC.JSONRPCRequest -> IO (Either RpcFailure DispatchOutcome)-dispatchExpectVisible state request =- withActiveSession state $ \active ->- case decodeParams request of- Left err -> pure (Left err)- Right params ->- runMethod $- expectVisible (activeTui active) (selectorValue params)- >> pure (object ["ok" .= True])--dispatchExpectNotVisible :: ServerState -> RPC.JSONRPCRequest -> IO (Either RpcFailure DispatchOutcome)-dispatchExpectNotVisible state request =- withActiveSession state $ \active ->- case decodeParams request of- Left err -> pure (Left err)- Right params ->- runMethod $- expectNotVisible (activeTui active) (selectorValue params)- >> pure (object ["ok" .= True])--dispatchPing :: RPC.JSONRPCRequest -> IO (Either RpcFailure DispatchOutcome)-dispatchPing request =- case requireNoParams request of- Left err -> pure (Left err)- Right () ->- pure- ( Right- ( Continue- ( object- [ "pong" .= True- , "version" .= ("0.1.0.0" :: String)- ]- )- )- )--dispatchShutdown :: ServerState -> RPC.JSONRPCRequest -> IO (Either RpcFailure DispatchOutcome)-dispatchShutdown state request =- case requireNoParams request of- Left err -> pure (Left err)- Right () -> do- killActiveChildrenNow state- pure- ( Right- ( Shutdown- ( object- [ "shuttingDown" .= True- ]- )- )- )--withActiveSession :: ServerState -> (ActiveSession -> IO (Either RpcFailure DispatchOutcome)) -> IO (Either RpcFailure DispatchOutcome)-withActiveSession state action = do- maybeActive <- readIORef (stateActiveSession state)- case maybeActive of- Nothing -> pure (Left noActiveSessionError)- Just active -> action active--killActiveChildrenNow :: ServerState -> IO ()-killActiveChildrenNow state = do- maybeActive <- readIORef (stateActiveSession state)- case maybeActive of- Nothing -> pure ()- Just active -> killSessionChildrenNow (activeTui active)--runMethod :: IO Value -> IO (Either RpcFailure DispatchOutcome)-runMethod action = do- result <- try action :: IO (Either SomeException Value)- pure $- case result of- Left err -> Left (methodFailed (displayException err))- Right value -> Right (Continue value)--writeSuccessResponse :: RPC.RequestId -> Value -> IO Bool-writeSuccessResponse reqId resultValue =- writeJsonLine- ( encode- (RPC.JSONRPCResponse RPC.rPC_VERSION reqId resultValue)- )--writeErrorResponse :: RPC.RequestId -> RpcFailure -> IO Bool-writeErrorResponse reqId failure =- writeJsonLine- ( encode- ( RPC.JSONRPCError- RPC.rPC_VERSION- reqId- (RPC.JSONRPCErrorInfo (failureCode failure) (failureMessage failure) (failureData failure))- )- )--writeJsonLine :: BL8.ByteString -> IO Bool-writeJsonLine bytes = do- writeResult <-- tryIOError $ do- BL8.hPutStr stdout bytes- BL8.hPutStr stdout "\n"- hFlush stdout- pure $- case writeResult of- Left _ -> False- Right () -> True--decodeParams :: (FromJSON a) => RPC.JSONRPCRequest -> Either RpcFailure a-decodeParams request =- case fromJSON (requestParams request) of- Error err -> Left (invalidParams err)- Success value -> Right value--requireNoParams :: RPC.JSONRPCRequest -> Either RpcFailure ()-requireNoParams request =- case requestParams request of- Null -> Right ()- Object keyMap- | KM.null keyMap -> Right ()- _ -> Left (invalidParams "expected params to be null or empty object")--invalidRequest :: String -> RpcFailure-invalidRequest details =- RpcFailure- { failureCode = RPC.iNVALID_REQUEST- , failureMessage = "Invalid request"- , failureData = Just (object ["details" .= details])- }--invalidParams :: String -> RpcFailure-invalidParams details =- RpcFailure- { failureCode = RPC.iNVALID_PARAMS- , failureMessage = "Invalid params"- , failureData = Just (object ["details" .= details])- }--parseError :: String -> RpcFailure-parseError details =- RpcFailure- { failureCode = RPC.pARSE_ERROR- , failureMessage = "Parse error"- , failureData = Just (object ["details" .= details])- }--methodFailed :: String -> RpcFailure-methodFailed details =- RpcFailure- { failureCode = -32004- , failureMessage = "Method failed"- , failureData = Just (object ["details" .= details])- }--noActiveSessionError :: RpcFailure-noActiveSessionError =- RpcFailure- { failureCode = -32001- , failureMessage = "No active session"- , failureData = Nothing- }--sessionAlreadyStartedError :: RpcFailure-sessionAlreadyStartedError =- RpcFailure- { failureCode = -32002- , failureMessage = "Session already started"- , failureData = Nothing- }--data StartParams = StartParams- { startName :: Maybe Text- , startTimeoutSeconds :: Maybe Int- , startTerminalCols :: Maybe Int- , startTerminalRows :: Maybe Int- , startAmbiguityMode :: Maybe Text- , startSnapshotTheme :: Maybe Text- , startUpdateSnapshots :: Maybe Bool- }--instance FromJSON StartParams where- parseJSON value =- case value of- Null -> pure defaultStartParams- _ ->- withObject "StartParams" parseObject value- where- parseObject o =- StartParams- <$> o .:? "name"- <*> o .:? "timeoutSeconds"- <*> o .:? "terminalCols"- <*> o .:? "terminalRows"- <*> o .:? "ambiguityMode"- <*> o .:? "snapshotTheme"- <*> o .:? "updateSnapshots"--defaultStartParams :: StartParams-defaultStartParams =- StartParams- { startName = Nothing- , startTimeoutSeconds = Nothing- , startTerminalCols = Nothing- , startTerminalRows = Nothing- , startAmbiguityMode = Nothing- , startSnapshotTheme = Nothing- , startUpdateSnapshots = Nothing- }--data LaunchParams = LaunchParams- { launchCommand :: FilePath- , launchArgs :: [String]- }--instance FromJSON LaunchParams where- parseJSON =- withObject "LaunchParams" $ \o ->- LaunchParams- <$> o .: "command"- <*> o .:? "args" AesonTypes..!= []--data SendKeyParams = SendKeyParams- { sendKeyValue :: Text- }--instance FromJSON SendKeyParams where- parseJSON =- withObject "SendKeyParams" $ \o ->- SendKeyParams <$> o .: "key"--data SendTextParams = SendTextParams- { sendTextValue :: Text- }--instance FromJSON SendTextParams where- parseJSON =- withObject "SendTextParams" $ \o ->- SendTextParams <$> o .: "text"--data SendLineParams = SendLineParams- { sendLineValue :: Text- }--instance FromJSON SendLineParams where- parseJSON =- withObject "SendLineParams" $ \o ->- SendLineParams <$> o .: "text"--data DumpViewParams = DumpViewParams- { dumpName :: Text- }--instance FromJSON DumpViewParams where- parseJSON =- withObject "DumpViewParams" $ \o ->- DumpViewParams <$> o .: "name"--data ExpectSnapshotParams = ExpectSnapshotParams- { expectSnapshotNameValue :: Text- }--instance FromJSON ExpectSnapshotParams where- parseJSON =- withObject "ExpectSnapshotParams" $ \o ->- ExpectSnapshotParams <$> o .: "name"--data SelectorParams = SelectorParams- { selectorValue :: Selector- }--instance FromJSON SelectorParams where- parseJSON =- withObject "SelectorParams" $ \o ->- SelectorParams <$> (o .: "selector" >>= parseSelector)--data WaitForTextParams = WaitForTextParams- { waitSelector :: Selector- , waitTimeoutMs :: Maybe Int- , waitPollIntervalMs :: Maybe Int- }--instance FromJSON WaitForTextParams where- parseJSON =- withObject "WaitForTextParams" $ \o ->- WaitForTextParams- <$> (o .: "selector" >>= parseSelector)- <*> o .:? "timeoutMs"- <*> o .:? "pollIntervalMs"--parseSelector :: Value -> AesonTypes.Parser Selector-parseSelector =- withObject "Selector" $ \o -> do- selectorType <- (T.toLower <$> (o .: "type" :: AesonTypes.Parser Text))- case selectorType of- "exact" -> Exact <$> o .: "text"- "regex" -> Regex <$> o .: "pattern"- "at" -> At <$> o .: "col" <*> o .: "row"- "within" -> do- rectValue <- o .: "rect" >>= parseRect- nested <- o .: "selector" >>= parseSelector- pure (Within rectValue nested)- "nth" -> Nth <$> o .: "index" <*> (o .: "selector" >>= parseSelector)- _ -> fail ("unknown selector type: " <> T.unpack selectorType)--parseRect :: Value -> AesonTypes.Parser Rect-parseRect =- withObject "Rect" $ \o ->- Rect- <$> o .: "col"- <*> o .: "row"- <*> o .: "width"- <*> o .: "height"--requestId :: RPC.JSONRPCRequest -> RPC.RequestId-requestId (RPC.JSONRPCRequest _ reqId _ _) = reqId--requestVersion :: RPC.JSONRPCRequest -> Text-requestVersion (RPC.JSONRPCRequest version _ _ _) = version--requestMethod :: RPC.JSONRPCRequest -> Text-requestMethod (RPC.JSONRPCRequest _ _ methodName _) = methodName--requestParams :: RPC.JSONRPCRequest -> Value-requestParams (RPC.JSONRPCRequest _ _ _ paramsValue) = paramsValue--applyStartParams :: ServerOptions -> StartParams -> Maybe AmbiguityMode -> RunOptions-applyStartParams options params ambiguityOverride =- defaultRunOptions- { timeoutSeconds = maybe (serverTimeoutSeconds options) id (startTimeoutSeconds params)- , terminalCols = maybe (serverTerminalCols options) id (startTerminalCols params)- , terminalRows = maybe (serverTerminalRows options) id (startTerminalRows params)- , artifactsDir = serverArtifactsDir options- , ambiguityMode = maybe (serverAmbiguityMode options) id ambiguityOverride- , updateSnapshots = maybe False id (startUpdateSnapshots params)- , snapshotTheme = maybe "auto" T.unpack (startSnapshotTheme params)- }--resolveAmbiguityOverride :: Maybe Text -> Either String (Maybe AmbiguityMode)-resolveAmbiguityOverride maybeRaw =- case maybeRaw of- Nothing -> Right Nothing- Just raw ->- case parseAmbiguityMode raw of- Just mode -> Right (Just mode)- Nothing ->- Left "ambiguityMode must be one of: fail, first, first-visible"--parseAmbiguityMode :: Text -> Maybe AmbiguityMode-parseAmbiguityMode raw =- case map toLower (T.unpack (T.strip raw)) of- "fail" -> Just FailOnAmbiguous- "first" -> Just FirstVisibleMatch- "first-visible" -> Just FirstVisibleMatch- _ -> Nothing--parseSendKey :: Text -> Either String ([Modifier], Key)-parseSendKey rawKey =- if trimmed == "+"- then (,) [] <$> parseBaseKey trimmed- else case T.breakOn "+" trimmed of- (_, "") ->- (,) [] <$> parseBaseKey trimmed- (modifierText, remainder) ->- do- modifier <- parseModifier (T.strip modifierText)- keyValue <- parseModifiedKey (T.strip (T.drop 1 remainder))- pure ([modifier], keyValue)- where- trimmed = T.strip rawKey-- parseModifier textValue =- case map toLower (T.unpack textValue) of- "ctrl" -> Right Control- "control" -> Right Control- "alt" -> Right Alt- "shift" -> Right Shift- _ -> Left ("unknown modifier: " <> T.unpack textValue)-- parseModifiedKey textValue =- case T.unpack textValue of- [charValue] -> Right (CharKey charValue)- _ -> Left "modified keys must use a single character (for example Ctrl+C)"--parseBaseKey :: Text -> Either String Key-parseBaseKey keyText =- let lowered = map toLower (T.unpack (T.strip keyText))- in case lowered of- "enter" -> Right Enter- "esc" -> Right Esc- "escape" -> Right Esc- "tab" -> Right Tab- "backspace" -> Right Backspace- "arrowup" -> Right ArrowUp- "arrowdown" -> Right ArrowDown- "arrowleft" -> Right ArrowLeft- "arrowright" -> Right ArrowRight- "space" -> Right (CharKey ' ')- _ ->- case parseFunctionKey lowered of- Just functionNumber -> Right (FunctionKey functionNumber)- Nothing ->- case T.unpack (T.strip keyText) of- [charValue] -> Right (CharKey charValue)- _ -> Left ("unknown key: " <> T.unpack keyText)--parseFunctionKey :: String -> Maybe Int-parseFunctionKey lowered =- case lowered of- 'f' : digits- | all isDigitAscii digits ->- case reads digits of- [(value, "")]- | value >= 1 && value <= 12 -> Just value- _ -> Nothing- _ -> Nothing- where- isDigitAscii c = c >= '0' && c <= '9'--snapshotMetaPath :: FilePath -> FilePath-snapshotMetaPath ansiPath =- if ".ansi.txt" `isSuffixOf` ansiPath- then take (length ansiPath - length (".ansi.txt" :: String)) ansiPath <> ".meta.json"- else ansiPath <> ".meta.json"--safeSnapshotStem :: String -> String-safeSnapshotStem input =- let lowered = map toLower input- normalized = map normalize lowered- compact = collapseDashes normalized- trimmed = trimDashes compact- in if null trimmed then "snapshot" else trimmed- where- normalize c- | isAlphaNum c = c- | otherwise = '-'-- collapseDashes [] = []- collapseDashes ('-' : '-' : rest) = collapseDashes ('-' : rest)- collapseDashes (c : rest) = c : collapseDashes rest-- trimDashes = reverse . dropWhile (== '-') . reverse . dropWhile (== '-')+import Control.Concurrent (forkIO, threadDelay)+import Control.Exception (SomeException, displayException, finally, throwIO, try)+import Control.Monad (foldM, when)+import Data.Aeson (FromJSON (parseJSON), Result (Error, Success), Value (Null, Object), eitherDecode, eitherDecodeStrict', encode, fromJSON, object, withObject, (.:), (.:?), (.=))+import Data.Aeson.Key qualified as K+import Data.Aeson.KeyMap qualified as KM+import Data.Aeson.Types qualified as AesonTypes+import Data.ByteString qualified as BS+import Data.ByteString.Char8 qualified as BS8+import Data.ByteString.Lazy qualified as BL+import Data.ByteString.Lazy.Char8 qualified as BL8+import Data.Char (toLower)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Int (Int64)+import Data.List (isSuffixOf)+import Data.Maybe (fromMaybe, isJust)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as TE+import Data.Text.Encoding.Error qualified as TEE+import Data.Text.IO qualified as TIO+import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime)+import Data.Time.Clock.POSIX (getPOSIXTime)+import JSONRPC qualified as RPC+import System.Directory (canonicalizePath, doesFileExist)+import System.Exit (ExitCode (ExitSuccess))+import System.FilePath ((</>))+import System.IO (hFlush, stdin, stdout)+import System.IO.Error (isEOFError, tryIOError)+import System.Posix.Process (exitImmediately)+import System.Posix.Signals (Handler (Catch), installHandler, sigHUP)+import TuiSpec.Internal (regexLikeMatch, safeFileStem, safeIndex, snapshotMetadataPath)+import TuiSpec.Render (renderAnsiSnapshotFileWithFont)+import TuiSpec.Replay (RecordingDirection (DirectionFrame, DirectionFrameDelta, DirectionNotification, DirectionRequest, DirectionResponse), RecordingHandle, ReplaySpeed (ReplayAsFastAsPossible, ReplayRealTime), appendRecordingEvent, closeRecording, computeFrameDelta, openRecording, streamReplayRequests)+import TuiSpec.Runner (currentView, defaultWaitOptionsFor, dumpView, expectNotVisible, expectSnapshot, expectVisible, killSessionChildrenNow, launch, openSession, press, pressCombo, renderAnsiViewportText, sendLine, serializeAnsiSnapshot, typeText, waitForSelectorWithAmbiguity, waitForStable)+import TuiSpec.Types (AmbiguityMode (FailOnAmbiguous, FirstVisibleMatch, LastVisibleMatch), App (..), Key (..), Modifier (Alt, Control, Shift), Rect (Rect), RunOptions (..), Selector (..), SnapshotName (SnapshotName), Tui (..), WaitOptions (..), defaultRunOptions, tuispecVersion)++-- | Configuration for the JSON-RPC server.+data ServerOptions = ServerOptions+ { serverArtifactsDir :: FilePath+ -- ^ Base directory for session artifacts.+ , serverTerminalCols :: Int+ -- ^ Default terminal columns for launched sessions.+ , serverTerminalRows :: Int+ -- ^ Default terminal rows for launched sessions.+ , serverTimeoutSeconds :: Int+ -- ^ Default timeout for wait operations.+ , serverAmbiguityMode :: AmbiguityMode+ -- ^ Default ambiguity mode for selector assertions.+ }+ deriving (Eq, Show)++data ActiveSession = ActiveSession+ { activeTui :: Tui+ }++data RecordingSession = RecordingSession+ { activeRecordingPath :: FilePath+ , activeRecordingHandle :: RecordingHandle+ , activeFrameSamplerStop :: Maybe (IORef Bool)+ }++data ViewSubscription = ViewSubscription+ { subscriptionDebounceMs :: Int+ , subscriptionIncludeText :: Bool+ , subscriptionLastSentMicros :: Maybe Int64+ , subscriptionLastView :: Maybe Text+ }++data ServerState = ServerState+ { stateOptions :: ServerOptions+ , stateActiveSession :: IORef (Maybe ActiveSession)+ , stateRecording :: IORef (Maybe RecordingSession)+ , stateViewSubscription :: IORef (Maybe ViewSubscription)+ }++data DispatchOutcome+ = Continue Value+ | Shutdown Value++data RpcFailure = RpcFailure+ { failureCode :: Int+ , failureMessage :: Text+ , failureData :: Maybe Value+ }++-- | Run the JSON-RPC server, reading requests from stdin and writing responses to stdout.+runServer :: ServerOptions -> IO ()+runServer options = do+ sessionRef <- newIORef Nothing+ recordingRef <- newIORef Nothing+ subscriptionRef <- newIORef Nothing+ let state =+ ServerState+ { stateOptions = options+ , stateActiveSession = sessionRef+ , stateRecording = recordingRef+ , stateViewSubscription = subscriptionRef+ }+ _ <- installHandler sigHUP (Catch (handleSighup state)) Nothing+ loop state `finally` shutdownServer state+ where+ handleSighup state = do+ killActiveChildrenNow state+ closeActiveRecording state+ exitImmediately ExitSuccess++ loop state = do+ lineResult <- tryIOError (BS8.hGetLine stdin)+ case lineResult of+ Left ioErr+ | isEOFError ioErr -> pure ()+ | otherwise -> pure ()+ Right line ->+ if BS.null line+ then loop state+ else do+ shouldContinue <- handleLine state line+ when shouldContinue (loop state)++shutdownServer :: ServerState -> IO ()+shutdownServer state = do+ killActiveChildrenNow state+ closeActiveRecording state++handleLine :: ServerState -> BS.ByteString -> IO Bool+handleLine state line = do+ recordIncomingRequestLine state line+ case eitherDecodeStrict' line :: Either String RPC.JSONRPCRequest of+ Left parseErr -> do+ writeErrorResponse state (RPC.RequestId Null) (parseError parseErr)+ Right request ->+ case validateRequestVersion request of+ Left err -> do+ writeErrorResponse state (requestId request) err+ Right () -> do+ outcome <- dispatchMethod state (requestMethod request) (requestParams request)+ case outcome of+ Left err ->+ writeErrorResponse state (requestId request) err+ Right (Continue resultValue) ->+ writeSuccessResponse state (requestId request) resultValue+ Right (Shutdown resultValue) -> do+ _ <- writeSuccessResponse state (requestId request) resultValue+ pure False++validateRequestVersion :: RPC.JSONRPCRequest -> Either RpcFailure ()+validateRequestVersion request =+ if requestVersion request == RPC.rPC_VERSION+ then Right ()+ else Left (invalidRequest "Expected jsonrpc field to equal \"2.0\"")++dispatchMethod :: ServerState -> Text -> Value -> IO (Either RpcFailure DispatchOutcome)+dispatchMethod state methodName paramsValue =+ case methodName of+ "initialize" -> dispatchInitialize state paramsValue+ "launch" -> dispatchLaunch state paramsValue+ "sendKey" -> dispatchSendKey state paramsValue+ "sendText" -> dispatchSendText state paramsValue+ "sendLine" -> dispatchSendLine state paramsValue+ "currentView" -> dispatchCurrentView state paramsValue+ "dumpView" -> dispatchDumpView state paramsValue+ "renderView" -> dispatchRenderView state paramsValue+ "expectSnapshot" -> dispatchExpectSnapshot state paramsValue+ "waitForText" -> dispatchWaitForText state paramsValue+ "waitUntil" -> dispatchWaitUntil state paramsValue+ "waitForStable" -> dispatchWaitForStable state paramsValue+ "diffView" -> dispatchDiffView state paramsValue+ "expectVisible" -> dispatchExpectVisible state paramsValue+ "expectNotVisible" -> dispatchExpectNotVisible state paramsValue+ "viewSubscribe" -> dispatchViewSubscribe state paramsValue+ "viewUnsubscribe" -> dispatchViewUnsubscribe state paramsValue+ "batch" -> dispatchBatch state paramsValue+ "recording.start" -> dispatchRecordingStart state paramsValue+ "recording.stop" -> dispatchRecordingStop state paramsValue+ "recording.status" -> dispatchRecordingStatus state paramsValue+ "replay" -> dispatchReplay state paramsValue+ "server.ping" -> dispatchPing paramsValue+ "server.shutdown" -> dispatchShutdown state paramsValue+ unknownMethod ->+ pure $+ Left+ ( RpcFailure+ { failureCode = RPC.mETHOD_NOT_FOUND+ , failureMessage = "Method not found"+ , failureData = Just (object ["method" .= unknownMethod])+ }+ )++dispatchInitialize :: ServerState -> Value -> IO (Either RpcFailure DispatchOutcome)+dispatchInitialize state paramsValue = do+ existing <- readIORef (stateActiveSession state)+ case existing of+ Just _ ->+ pure (Left sessionAlreadyStartedError)+ Nothing ->+ case decodeParamsValue paramsValue of+ Left err -> pure (Left err)+ Right params -> do+ let sessionName = T.unpack (T.strip (fromMaybeText "session" (startName params)))+ if null sessionName+ then pure (Left (invalidParams "session name cannot be empty"))+ else do+ case resolveAmbiguityOverride (startAmbiguityMode params) of+ Left ambiguityErr ->+ pure (Left (invalidParams ambiguityErr))+ Right ambiguityOverride -> do+ let runOptions = applyStartParams (stateOptions state) params ambiguityOverride+ sessionResult <- try (openSession runOptions sessionName) :: IO (Either SomeException Tui)+ case sessionResult of+ Left err ->+ pure (Left (methodFailed (displayException err)))+ Right tui -> do+ writeIORef (stateActiveSession state) (Just (ActiveSession tui))+ pure $+ Right $+ Continue+ ( object+ [ "sessionName" .= sessionName+ , "artifactRoot" .= tuiTestRoot tui+ , "rows" .= terminalRows (tuiOptions tui)+ , "cols" .= terminalCols (tuiOptions tui)+ , "version" .= tuispecVersion+ ]+ )++dispatchLaunch :: ServerState -> Value -> IO (Either RpcFailure DispatchOutcome)+dispatchLaunch state paramsValue =+ withActiveSession state $ \active ->+ case decodeParamsValue paramsValue of+ Left err -> pure (Left err)+ Right params ->+ runMethod $ do+ let tui = activeTui active+ launch+ tui+ App+ { command = launchCommand params+ , args = launchArgs params+ , env = launchEnv params+ , cwd = launchCwd params+ }+ case launchReadySelector params of+ Nothing -> pure ()+ Just selector -> do+ let defaults = defaultWaitOptionsFor tui+ let waitOptions = mergeWaitOptions defaults (launchReadyTimeoutMs params) (launchReadyPollIntervalMs params)+ waitForSelectorWithAmbiguity tui waitOptions Nothing selector+ emitViewChangedNotification state tui+ pure (object ["ok" .= True])++dispatchSendKey :: ServerState -> Value -> IO (Either RpcFailure DispatchOutcome)+dispatchSendKey state paramsValue =+ withActiveSession state $ \active ->+ case decodeParamsValue paramsValue of+ Left err -> pure (Left err)+ Right params ->+ case parseSendKey (sendKeyValue params) of+ Left keyErr -> pure (Left (invalidParams keyErr))+ Right (modifiers, keyValue) ->+ runMethod $ do+ let tui = activeTui active+ if null modifiers+ then press tui keyValue+ else pressCombo tui modifiers keyValue+ emitViewChangedNotification state tui+ pure (object ["ok" .= True])++dispatchSendText :: ServerState -> Value -> IO (Either RpcFailure DispatchOutcome)+dispatchSendText state paramsValue =+ withActiveSession state $ \active ->+ case decodeParamsValue paramsValue of+ Left err -> pure (Left err)+ Right params ->+ runMethod $ do+ let tui = activeTui active+ typeText tui (sendTextValue params)+ emitViewChangedNotification state tui+ pure (object ["ok" .= True])++dispatchSendLine :: ServerState -> Value -> IO (Either RpcFailure DispatchOutcome)+dispatchSendLine state paramsValue =+ withActiveSession state $ \active ->+ case decodeParamsValue paramsValue of+ Left err -> pure (Left err)+ Right params ->+ case resolveAmbiguityOverride (sendLineAmbiguityMode params) of+ Left ambiguityErr -> pure (Left (invalidParams ambiguityErr))+ Right ambiguityOverride ->+ runMethod $ do+ let tui = activeTui active+ sendLine tui (sendLineValue params)+ case sendLineExpectAfter params of+ Nothing -> pure ()+ Just selector -> do+ let defaults = defaultWaitOptionsFor tui+ let waitOptions = mergeWaitOptions defaults (sendLineTimeoutMs params) (sendLinePollIntervalMs params)+ waitForSelectorWithAmbiguity tui waitOptions ambiguityOverride selector+ emitViewChangedNotification state tui+ pure (object ["ok" .= True])++dispatchCurrentView :: ServerState -> Value -> IO (Either RpcFailure DispatchOutcome)+dispatchCurrentView state paramsValue =+ withActiveSession state $ \active ->+ case decodeParamsValue paramsValue of+ Left err -> pure (Left err)+ Right params ->+ let options = tuiOptions (activeTui active)+ totalRows = terminalRows options+ totalCols = terminalCols options+ in case resolveCurrentViewFilter params totalRows totalCols of+ Left filterErr -> pure (Left (invalidParams filterErr))+ Right filterValue ->+ runMethod $ do+ textValue <- currentView (activeTui active)+ let (filteredText, outRows, outCols) = applyCurrentViewFilter filterValue totalRows totalCols textValue+ pure+ ( object+ [ "text" .= filteredText+ , "rows" .= outRows+ , "cols" .= outCols+ ]+ )++dispatchDumpView :: ServerState -> Value -> IO (Either RpcFailure DispatchOutcome)+dispatchDumpView state paramsValue =+ withActiveSession state $ \active ->+ case decodeParamsValue paramsValue of+ Left err -> pure (Left err)+ Right params ->+ runMethod $ do+ let tui = activeTui active+ ansiPathRaw <- dumpView tui (SnapshotName (dumpName params))+ ansiPath <- canonicalizeExistingPath ansiPathRaw+ metaPath <- canonicalizeExistingPath (snapshotMetadataPath ansiPath)+ artifactRoot <- canonicalizePath (tuiTestRoot tui)+ maybePngPath <-+ case dumpFormat params of+ DumpAnsi -> pure Nothing+ DumpPng -> Just <$> renderSnapshotFromDump params ansiPath+ DumpBoth -> Just <$> renderSnapshotFromDump params ansiPath+ pure+ ( object+ ( [ "snapshotPath" .= ansiPath+ , "metaPath" .= metaPath+ , "artifactRoot" .= artifactRoot+ ]+ <> maybe [] (\pngPath -> ["pngPath" .= pngPath]) maybePngPath+ )+ )++dispatchRenderView :: ServerState -> Value -> IO (Either RpcFailure DispatchOutcome)+dispatchRenderView state paramsValue =+ withActiveSession state $ \active ->+ case decodeParamsValue paramsValue of+ Left err -> pure (Left err)+ Right params ->+ runMethod $ do+ let tui = activeTui active+ ansiPathRaw <- dumpView tui (SnapshotName (renderViewName params))+ ansiPath <- canonicalizeExistingPath ansiPathRaw+ metaPath <- canonicalizeExistingPath (snapshotMetadataPath ansiPath)+ artifactRoot <- canonicalizePath (tuiTestRoot tui)+ pngPath <- renderSnapshotFromRenderView params ansiPath+ pure+ ( object+ [ "snapshotPath" .= ansiPath+ , "metaPath" .= metaPath+ , "pngPath" .= pngPath+ , "artifactRoot" .= artifactRoot+ ]+ )++dispatchExpectSnapshot :: ServerState -> Value -> IO (Either RpcFailure DispatchOutcome)+dispatchExpectSnapshot state paramsValue =+ withActiveSession state $ \active ->+ case decodeParamsValue paramsValue of+ Left err -> pure (Left err)+ Right params ->+ runMethod $ do+ let snapshotText = expectSnapshotNameValue params+ let snapshotStem = safeFileStem (T.unpack snapshotText)+ let tui = activeTui active+ let actualPath = tuiTestRoot tui </> "snapshots" </> (snapshotStem <> ".ansi.txt")+ let baselinePath = tuiSnapshotRoot tui </> (snapshotStem <> ".ansi.txt")+ expectSnapshot tui (SnapshotName snapshotText)+ baselineExists <- doesFileExist baselinePath+ pure+ ( object+ [ "ok" .= True+ , "actualPath" .= actualPath+ , "baselinePath" .= baselinePath+ , "baselineExists" .= baselineExists+ ]+ )++dispatchWaitForText :: ServerState -> Value -> IO (Either RpcFailure DispatchOutcome)+dispatchWaitForText state paramsValue =+ withActiveSession state $ \active ->+ case decodeParamsValue paramsValue of+ Left err -> pure (Left err)+ Right params ->+ case resolveAmbiguityOverride (waitAmbiguityMode params) of+ Left ambiguityErr -> pure (Left (invalidParams ambiguityErr))+ Right ambiguityOverride ->+ runMethod $ do+ let tui = activeTui active+ let defaults = defaultWaitOptionsFor tui+ let mergedWaitOptions = mergeWaitOptions defaults (waitTimeoutMs params) (waitPollIntervalMs params)+ waitForSelectorWithAmbiguity tui mergedWaitOptions ambiguityOverride (waitSelector params)+ pure (object ["ok" .= True])++dispatchWaitUntil :: ServerState -> Value -> IO (Either RpcFailure DispatchOutcome)+dispatchWaitUntil state paramsValue =+ withActiveSession state $ \active ->+ case decodeParamsValue paramsValue of+ Left err -> pure (Left err)+ Right params ->+ runMethod $ do+ let tui = activeTui active+ let defaults = defaultWaitOptionsFor tui+ let mergedWaitOptions = mergeWaitOptions defaults (waitUntilTimeoutMs params) (waitUntilPollIntervalMs params)+ waitUntilPattern tui mergedWaitOptions (waitUntilPatternValue params)+ pure (object ["ok" .= True])++dispatchWaitForStable :: ServerState -> Value -> IO (Either RpcFailure DispatchOutcome)+dispatchWaitForStable state paramsValue =+ withActiveSession state $ \active ->+ case decodeParamsValue paramsValue of+ Left err -> pure (Left err)+ Right params ->+ runMethod $ do+ let tui = activeTui active+ let defaults = defaultWaitOptionsFor tui+ let mergedWaitOptions = mergeWaitOptions defaults (waitStableTimeoutMs params) (waitStablePollIntervalMs params)+ waitForStable tui mergedWaitOptions (waitStableDebounceMs params)+ pure (object ["ok" .= True])++dispatchDiffView :: ServerState -> Value -> IO (Either RpcFailure DispatchOutcome)+dispatchDiffView state paramsValue =+ withActiveSession state $ \active ->+ case decodeParamsValue paramsValue of+ Left err -> pure (Left err)+ Right params ->+ runMethod $ do+ let options = tuiOptions (activeTui active)+ diffResult <- computeSnapshotDiff options params+ pure+ ( object+ [ "changed" .= diffChanged diffResult+ , "changedLines" .= diffChangedLines diffResult+ , "summary" .= diffSummary diffResult+ ]+ )++dispatchExpectVisible :: ServerState -> Value -> IO (Either RpcFailure DispatchOutcome)+dispatchExpectVisible state paramsValue =+ withActiveSession state $ \active ->+ case decodeParamsValue paramsValue of+ Left err -> pure (Left err)+ Right params ->+ runMethod $+ expectVisible (activeTui active) (selectorValue params)+ >> pure (object ["ok" .= True])++dispatchExpectNotVisible :: ServerState -> Value -> IO (Either RpcFailure DispatchOutcome)+dispatchExpectNotVisible state paramsValue =+ withActiveSession state $ \active ->+ case decodeParamsValue paramsValue of+ Left err -> pure (Left err)+ Right params ->+ runMethod $+ expectNotVisible (activeTui active) (selectorValue params)+ >> pure (object ["ok" .= True])++dispatchViewSubscribe :: ServerState -> Value -> IO (Either RpcFailure DispatchOutcome)+dispatchViewSubscribe state paramsValue =+ withActiveSession state $ \active ->+ case decodeParamsValue paramsValue of+ Left err -> pure (Left err)+ Right params ->+ if subscribeDebounceMs params < 0+ then pure (Left (invalidParams "debounceMs must be >= 0"))+ else runMethod $ do+ let subscription =+ ViewSubscription+ { subscriptionDebounceMs = subscribeDebounceMs params+ , subscriptionIncludeText = subscribeIncludeText params+ , subscriptionLastSentMicros = Nothing+ , subscriptionLastView = Nothing+ }+ writeIORef (stateViewSubscription state) (Just subscription)+ emitViewChangedNotification state (activeTui active)+ pure+ ( object+ [ "ok" .= True+ , "debounceMs" .= subscribeDebounceMs params+ , "includeText" .= subscribeIncludeText params+ ]+ )++dispatchViewUnsubscribe :: ServerState -> Value -> IO (Either RpcFailure DispatchOutcome)+dispatchViewUnsubscribe state paramsValue =+ case requireNoParamsValue paramsValue of+ Left err -> pure (Left err)+ Right () ->+ runMethod $ do+ writeIORef (stateViewSubscription state) Nothing+ pure (object ["ok" .= True])++dispatchBatch :: ServerState -> Value -> IO (Either RpcFailure DispatchOutcome)+dispatchBatch state paramsValue =+ case decodeParamsValue paramsValue of+ Left err -> pure (Left err)+ Right params ->+ runMethod $ do+ (completed, results, maybeFailure) <- foldM runBatchStep (0 :: Int, [], Nothing) (batchSteps params)+ case maybeFailure of+ Nothing ->+ pure+ ( object+ [ "ok" .= True+ , "completed" .= completed+ , "results" .= reverse results+ ]+ )+ Just (stepIndex, failureValue) ->+ pure+ ( object+ [ "ok" .= False+ , "completed" .= completed+ , "results" .= reverse results+ , "errorStep" .= stepIndex+ , "error" .= failureValue+ ]+ )+ where+ runBatchStep (completed, results, Just existingFailure) _ =+ pure (completed, results, Just existingFailure)+ runBatchStep (completed, results, Nothing) stepValue = do+ outcome <- dispatchMethod state (batchStepMethod stepValue) (batchStepParams stepValue)+ case outcome of+ Left err ->+ pure (completed, results, Just (completed + 1, rpcFailureToValue err))+ Right (Shutdown _) ->+ pure (completed, results, Just (completed + 1, object ["code" .= (-32020 :: Int), "message" .= ("batch step cannot call server.shutdown" :: Text)]))+ Right (Continue value) ->+ pure (completed + 1, value : results, Nothing)++dispatchRecordingStart :: ServerState -> Value -> IO (Either RpcFailure DispatchOutcome)+dispatchRecordingStart state paramsValue =+ case decodeParamsValue paramsValue of+ Left err -> pure (Left err)+ Right params ->+ runMethod $ do+ closeActiveRecording state+ handle <- openRecording (recordingStartPath params)+ canonicalPath <- canonicalizePath (recordingStartPath params)+ let intervalMs = recordingFrameIntervalMs params+ let keyframeEvery = max 1 (1000 `div` max 1 intervalMs)+ samplerStop <-+ if intervalMs > 0+ then do+ stopRef <- newIORef False+ lastFrameRef <- newIORef ("" :: Text)+ tickRef <- newIORef (0 :: Int)+ _ <- forkIO (frameSamplerLoop state handle lastFrameRef tickRef keyframeEvery stopRef intervalMs)+ pure (Just stopRef)+ else pure Nothing+ writeIORef+ (stateRecording state)+ (Just (RecordingSession canonicalPath handle samplerStop))+ pure+ ( object+ [ "ok" .= True+ , "path" .= canonicalPath+ , "frameIntervalMs" .= intervalMs+ ]+ )++dispatchRecordingStop :: ServerState -> Value -> IO (Either RpcFailure DispatchOutcome)+dispatchRecordingStop state paramsValue =+ case requireNoParamsValue paramsValue of+ Left err -> pure (Left err)+ Right () ->+ runMethod $ do+ closeActiveRecording state+ pure (object ["ok" .= True])++dispatchRecordingStatus :: ServerState -> Value -> IO (Either RpcFailure DispatchOutcome)+dispatchRecordingStatus state paramsValue =+ case requireNoParamsValue paramsValue of+ Left err -> pure (Left err)+ Right () ->+ runMethod $ do+ active <- readIORef (stateRecording state)+ pure+ ( object+ [ "active" .= isJust active+ , "path" .= fmap activeRecordingPath active+ ]+ )++dispatchReplay :: ServerState -> Value -> IO (Either RpcFailure DispatchOutcome)+dispatchReplay state paramsValue =+ case decodeParamsValue paramsValue of+ Left err -> pure (Left err)+ Right params ->+ runMethod $ do+ replayed <-+ streamReplayRequests+ (replaySpeed params)+ (replayPath params)+ (replayRecordedRequestLine state)+ pure+ ( object+ [ "ok" .= True+ , "replayedRequests" .= replayed+ , "path" .= replayPath params+ , "speed" .= renderReplaySpeed (replaySpeed params)+ ]+ )++dispatchPing :: Value -> IO (Either RpcFailure DispatchOutcome)+dispatchPing paramsValue =+ case requireNoParamsValue paramsValue of+ Left err -> pure (Left err)+ Right () ->+ pure+ ( Right+ ( Continue+ ( object+ [ "pong" .= True+ , "version" .= tuispecVersion+ ]+ )+ )+ )++dispatchShutdown :: ServerState -> Value -> IO (Either RpcFailure DispatchOutcome)+dispatchShutdown state paramsValue =+ case requireNoParamsValue paramsValue of+ Left err -> pure (Left err)+ Right () -> do+ killActiveChildrenNow state+ pure+ ( Right+ ( Shutdown+ ( object+ [ "shuttingDown" .= True+ ]+ )+ )+ )++withActiveSession :: ServerState -> (ActiveSession -> IO (Either RpcFailure DispatchOutcome)) -> IO (Either RpcFailure DispatchOutcome)+withActiveSession state action = do+ maybeActive <- readIORef (stateActiveSession state)+ case maybeActive of+ Nothing -> pure (Left noActiveSessionError)+ Just active -> action active++killActiveChildrenNow :: ServerState -> IO ()+killActiveChildrenNow state = do+ maybeActive <- readIORef (stateActiveSession state)+ case maybeActive of+ Nothing -> pure ()+ Just active -> killSessionChildrenNow (activeTui active)++closeActiveRecording :: ServerState -> IO ()+closeActiveRecording state = do+ maybeRecording <- readIORef (stateRecording state)+ case maybeRecording of+ Nothing -> pure ()+ Just recording -> do+ case activeFrameSamplerStop recording of+ Just stopRef -> do+ writeIORef stopRef True+ threadDelay 50000+ Nothing -> pure ()+ closeRecording (activeRecordingHandle recording)+ writeIORef (stateRecording state) Nothing++runMethod :: IO Value -> IO (Either RpcFailure DispatchOutcome)+runMethod action = do+ result <- try action :: IO (Either SomeException Value)+ pure $+ case result of+ Left err -> Left (methodFailed (displayException err))+ Right value -> Right (Continue value)++writeSuccessResponse :: ServerState -> RPC.RequestId -> Value -> IO Bool+writeSuccessResponse state reqId resultValue =+ writeJsonLine+ state+ DirectionResponse+ ( encode+ (RPC.JSONRPCResponse RPC.rPC_VERSION reqId resultValue)+ )++writeErrorResponse :: ServerState -> RPC.RequestId -> RpcFailure -> IO Bool+writeErrorResponse state reqId failure =+ writeJsonLine+ state+ DirectionResponse+ ( encode+ ( RPC.JSONRPCError+ RPC.rPC_VERSION+ reqId+ (RPC.JSONRPCErrorInfo (failureCode failure) (failureMessage failure) (failureData failure))+ )+ )++writeNotification :: ServerState -> Text -> Value -> IO Bool+writeNotification state methodName paramsValue =+ writeJsonLine+ state+ DirectionNotification+ ( encode+ ( object+ [ "jsonrpc" .= RPC.rPC_VERSION+ , "method" .= methodName+ , "params" .= paramsValue+ ]+ )+ )++writeJsonLine :: ServerState -> RecordingDirection -> BL8.ByteString -> IO Bool+writeJsonLine state direction bytes = do+ writeResult <-+ tryIOError $ do+ BL8.hPutStr stdout bytes+ BL8.hPutStr stdout "\n"+ hFlush stdout+ case writeResult of+ Left _ -> pure False+ Right () -> do+ recordOutgoingLine state direction bytes+ pure True++recordIncomingRequestLine :: ServerState -> BS.ByteString -> IO ()+recordIncomingRequestLine state line =+ withActiveRecording state $ \recording ->+ appendRecordingEvent+ (activeRecordingHandle recording)+ DirectionRequest+ (TE.decodeUtf8With TEE.lenientDecode line)++recordOutgoingLine :: ServerState -> RecordingDirection -> BL.ByteString -> IO ()+recordOutgoingLine state direction line =+ withActiveRecording state $ \recording ->+ appendRecordingEvent+ (activeRecordingHandle recording)+ direction+ (TE.decodeUtf8With TEE.lenientDecode (BL.toStrict line))++withActiveRecording :: ServerState -> (RecordingSession -> IO ()) -> IO ()+withActiveRecording state action = do+ maybeRecording <- readIORef (stateRecording state)+ case maybeRecording of+ Nothing -> pure ()+ Just recording -> action recording++{- | Background thread that samples the viewport at a fixed interval and+writes frame events to the recording JSONL. Emits full keyframes+periodically (roughly every second) and compact line-level deltas in+between. Deduplicates consecutive identical frames. Exits when the stop+flag is set to @True@.+-}+frameSamplerLoop :: ServerState -> RecordingHandle -> IORef Text -> IORef Int -> Int -> IORef Bool -> Int -> IO ()+frameSamplerLoop state handle lastFrameRef tickRef keyframeEvery stopRef intervalMs = loop+ where+ loop = do+ threadDelay (intervalMs * 1000)+ stopped <- readIORef stopRef+ if stopped+ then pure ()+ else do+ maybeActive <- readIORef (stateActiveSession state)+ case maybeActive of+ Nothing -> loop+ Just active -> do+ viewResult <- try (currentView (activeTui active)) :: IO (Either SomeException Text)+ case viewResult of+ Left _ -> loop+ Right frameText -> do+ lastFrame <- readIORef lastFrameRef+ when (frameText /= lastFrame) $ do+ tick <- readIORef tickRef+ if tick == 0 || T.null lastFrame+ then appendRecordingEvent handle DirectionFrame frameText+ else case computeFrameDelta lastFrame frameText of+ Nothing -> pure ()+ Just deltaText -> appendRecordingEvent handle DirectionFrameDelta deltaText+ writeIORef lastFrameRef frameText+ writeIORef tickRef ((tick + 1) `mod` keyframeEvery)+ loop++decodeParamsValue :: (FromJSON a) => Value -> Either RpcFailure a+decodeParamsValue paramsValue =+ case fromJSON paramsValue of+ Error err -> Left (invalidParams err)+ Success value -> Right value++requireNoParamsValue :: Value -> Either RpcFailure ()+requireNoParamsValue paramsValue =+ case paramsValue of+ Null -> Right ()+ Object keyMap+ | KM.null keyMap -> Right ()+ _ -> Left (invalidParams "expected params to be null or empty object")++invalidRequest :: String -> RpcFailure+invalidRequest details =+ RpcFailure+ { failureCode = RPC.iNVALID_REQUEST+ , failureMessage = "Invalid request"+ , failureData = Just (object ["details" .= details])+ }++invalidParams :: String -> RpcFailure+invalidParams details =+ RpcFailure+ { failureCode = RPC.iNVALID_PARAMS+ , failureMessage = "Invalid params"+ , failureData = Just (object ["details" .= details])+ }++parseError :: String -> RpcFailure+parseError details =+ RpcFailure+ { failureCode = RPC.pARSE_ERROR+ , failureMessage = "Parse error"+ , failureData = Just (object ["details" .= details])+ }++methodFailed :: String -> RpcFailure+methodFailed details =+ RpcFailure+ { failureCode = -32004+ , failureMessage = "Method failed"+ , failureData = Just (object ["details" .= details])+ }++rpcFailureToValue :: RpcFailure -> Value+rpcFailureToValue failure =+ object+ [ "code" .= failureCode failure+ , "message" .= failureMessage failure+ , "data" .= failureData failure+ ]++noActiveSessionError :: RpcFailure+noActiveSessionError =+ RpcFailure+ { failureCode = -32001+ , failureMessage = "No active session"+ , failureData = Nothing+ }++sessionAlreadyStartedError :: RpcFailure+sessionAlreadyStartedError =+ RpcFailure+ { failureCode = -32002+ , failureMessage = "Session already started"+ , failureData = Nothing+ }++data StartParams = StartParams+ { startName :: Maybe Text+ , startTimeoutSeconds :: Maybe Int+ , startTerminalCols :: Maybe Int+ , startTerminalRows :: Maybe Int+ , startAmbiguityMode :: Maybe Text+ , startSnapshotTheme :: Maybe Text+ , startUpdateSnapshots :: Maybe Bool+ }++instance FromJSON StartParams where+ parseJSON value =+ case value of+ Null -> pure defaultStartParams+ _ ->+ withObject "StartParams" parseObject value+ where+ parseObject o =+ StartParams+ <$> o .:? "name"+ <*> o .:? "timeoutSeconds"+ <*> o .:? "terminalCols"+ <*> o .:? "terminalRows"+ <*> o .:? "ambiguityMode"+ <*> o .:? "snapshotTheme"+ <*> o .:? "updateSnapshots"++defaultStartParams :: StartParams+defaultStartParams =+ StartParams+ { startName = Nothing+ , startTimeoutSeconds = Nothing+ , startTerminalCols = Nothing+ , startTerminalRows = Nothing+ , startAmbiguityMode = Nothing+ , startSnapshotTheme = Nothing+ , startUpdateSnapshots = Nothing+ }++data LaunchParams = LaunchParams+ { launchCommand :: FilePath+ , launchArgs :: [String]+ , launchEnv :: Maybe [(String, Maybe String)]+ , launchCwd :: Maybe FilePath+ , launchReadySelector :: Maybe Selector+ , launchReadyTimeoutMs :: Maybe Int+ , launchReadyPollIntervalMs :: Maybe Int+ }++instance FromJSON LaunchParams where+ parseJSON =+ withObject "LaunchParams" $ \o ->+ LaunchParams+ <$> o .: "command"+ <*> o .:? "args" AesonTypes..!= []+ <*> (o .:? "env" >>= traverse parseLaunchEnvObject)+ <*> o .:? "cwd"+ <*> (o .:? "readySelector" >>= traverse parseSelector)+ <*> o .:? "readyTimeoutMs"+ <*> o .:? "readyPollIntervalMs"++parseLaunchEnvObject :: Value -> AesonTypes.Parser [(String, Maybe String)]+parseLaunchEnvObject =+ withObject "launch.env" $ \envObject ->+ mapM parseLaunchEnvPair (KM.toList envObject)++parseLaunchEnvPair :: (K.Key, Value) -> AesonTypes.Parser (String, Maybe String)+parseLaunchEnvPair (key, value) =+ case value of+ Null -> pure (K.toString key, Nothing)+ _ -> do+ textValue <- (AesonTypes.parseJSON value :: AesonTypes.Parser Text)+ pure (K.toString key, Just (T.unpack textValue))++data SendKeyParams = SendKeyParams+ { sendKeyValue :: Text+ }++instance FromJSON SendKeyParams where+ parseJSON =+ withObject "SendKeyParams" $ \o ->+ SendKeyParams <$> o .: "key"++data SendTextParams = SendTextParams+ { sendTextValue :: Text+ }++instance FromJSON SendTextParams where+ parseJSON =+ withObject "SendTextParams" $ \o ->+ SendTextParams <$> o .: "text"++data SendLineParams = SendLineParams+ { sendLineValue :: Text+ , sendLineExpectAfter :: Maybe Selector+ , sendLineTimeoutMs :: Maybe Int+ , sendLinePollIntervalMs :: Maybe Int+ , sendLineAmbiguityMode :: Maybe Text+ }++instance FromJSON SendLineParams where+ parseJSON =+ withObject "SendLineParams" $ \o ->+ SendLineParams+ <$> o .: "text"+ <*> (o .:? "expectAfter" >>= traverse parseSelector)+ <*> o .:? "timeoutMs"+ <*> o .:? "pollIntervalMs"+ <*> o .:? "ambiguityMode"++data CurrentViewParams = CurrentViewParams+ { currentRowsFilter :: Maybe CurrentViewRowsFilter+ , currentRegionFilter :: Maybe CurrentViewRegionFilter+ , currentEntireRowFilter :: Maybe Int+ , currentEntireColFilter :: Maybe Int+ }++instance FromJSON CurrentViewParams where+ parseJSON value =+ case value of+ Null -> pure defaultCurrentViewParams+ _ ->+ withObject+ "CurrentViewParams"+ ( \o ->+ CurrentViewParams+ <$> o .:? "rows"+ <*> o .:? "region"+ <*> o .:? "entireRow"+ <*> o .:? "entireCol"+ )+ value++defaultCurrentViewParams :: CurrentViewParams+defaultCurrentViewParams =+ CurrentViewParams+ { currentRowsFilter = Nothing+ , currentRegionFilter = Nothing+ , currentEntireRowFilter = Nothing+ , currentEntireColFilter = Nothing+ }++data CurrentViewRowsFilter = CurrentViewRowsFilter+ { currentRowsStart :: Int+ , currentRowsEnd :: Int+ }++instance FromJSON CurrentViewRowsFilter where+ parseJSON =+ withObject "CurrentViewRowsFilter" $ \o ->+ CurrentViewRowsFilter+ <$> o .: "start"+ <*> o .: "end"++data CurrentViewRegionFilter = CurrentViewRegionFilter+ { currentRegionCol :: Int+ , currentRegionRow :: Int+ , currentRegionWidth :: Int+ , currentRegionHeight :: Int+ }++instance FromJSON CurrentViewRegionFilter where+ parseJSON =+ withObject "CurrentViewRegionFilter" $ \o ->+ CurrentViewRegionFilter+ <$> o .: "col"+ <*> o .: "row"+ <*> o .: "width"+ <*> o .: "height"++data DumpFormat+ = DumpAnsi+ | DumpPng+ | DumpBoth+ deriving (Eq, Show)++parseDumpFormat :: Text -> Maybe DumpFormat+parseDumpFormat raw =+ case map toLower (T.unpack (T.strip raw)) of+ "ansi" -> Just DumpAnsi+ "png" -> Just DumpPng+ "both" -> Just DumpBoth+ _ -> Nothing++data DumpViewParams = DumpViewParams+ { dumpName :: Text+ , dumpFormat :: DumpFormat+ , dumpTheme :: Maybe String+ , dumpFontPath :: Maybe FilePath+ , dumpRows :: Maybe Int+ , dumpCols :: Maybe Int+ }++instance FromJSON DumpViewParams where+ parseJSON =+ withObject "DumpViewParams" $ \o -> do+ maybeFormat <- o .:? "format"+ formatValue <-+ case maybeFormat of+ Nothing -> pure DumpAnsi+ Just raw ->+ case parseDumpFormat raw of+ Just parsed -> pure parsed+ Nothing -> fail "format must be one of: ansi, png, both"+ DumpViewParams+ <$> o .: "name"+ <*> pure formatValue+ <*> o .:? "theme"+ <*> o .:? "font"+ <*> o .:? "rows"+ <*> o .:? "cols"++data RenderViewParams = RenderViewParams+ { renderViewName :: Text+ , renderViewTheme :: Maybe String+ , renderViewFontPath :: Maybe FilePath+ , renderViewRows :: Maybe Int+ , renderViewCols :: Maybe Int+ }++instance FromJSON RenderViewParams where+ parseJSON =+ withObject "RenderViewParams" $ \o ->+ RenderViewParams+ <$> o .: "name"+ <*> o .:? "theme"+ <*> o .:? "font"+ <*> o .:? "rows"+ <*> o .:? "cols"++data ExpectSnapshotParams = ExpectSnapshotParams+ { expectSnapshotNameValue :: Text+ }++instance FromJSON ExpectSnapshotParams where+ parseJSON =+ withObject "ExpectSnapshotParams" $ \o ->+ ExpectSnapshotParams <$> o .: "name"++data SelectorParams = SelectorParams+ { selectorValue :: Selector+ }++instance FromJSON SelectorParams where+ parseJSON =+ withObject "SelectorParams" $ \o ->+ SelectorParams <$> (o .: "selector" >>= parseSelector)++data WaitForTextParams = WaitForTextParams+ { waitSelector :: Selector+ , waitTimeoutMs :: Maybe Int+ , waitPollIntervalMs :: Maybe Int+ , waitAmbiguityMode :: Maybe Text+ }++instance FromJSON WaitForTextParams where+ parseJSON =+ withObject "WaitForTextParams" $ \o ->+ WaitForTextParams+ <$> (o .: "selector" >>= parseSelector)+ <*> o .:? "timeoutMs"+ <*> o .:? "pollIntervalMs"+ <*> o .:? "ambiguityMode"++data WaitUntilParams = WaitUntilParams+ { waitUntilPatternValue :: Text+ , waitUntilTimeoutMs :: Maybe Int+ , waitUntilPollIntervalMs :: Maybe Int+ }++instance FromJSON WaitUntilParams where+ parseJSON =+ withObject "WaitUntilParams" $ \o ->+ WaitUntilParams+ <$> o .: "pattern"+ <*> o .:? "timeoutMs"+ <*> o .:? "pollIntervalMs"++data WaitForStableParams = WaitForStableParams+ { waitStableDebounceMs :: Int+ , waitStableTimeoutMs :: Maybe Int+ , waitStablePollIntervalMs :: Maybe Int+ }++instance FromJSON WaitForStableParams where+ parseJSON =+ withObject "WaitForStableParams" $ \o ->+ WaitForStableParams+ <$> o .: "debounceMs"+ <*> o .:? "timeoutMs"+ <*> o .:? "pollIntervalMs"++data DiffMode+ = DiffText+ | DiffStyled+ deriving (Eq, Show)++data DiffViewParams = DiffViewParams+ { diffLeftPath :: FilePath+ , diffRightPath :: FilePath+ , diffMode :: DiffMode+ }++instance FromJSON DiffViewParams where+ parseJSON =+ withObject "DiffViewParams" $ \o -> do+ maybeMode <- o .:? "mode"+ modeValue <-+ case maybeMode of+ Nothing -> pure DiffText+ Just raw ->+ case parseDiffMode raw of+ Just modeValue -> pure modeValue+ Nothing -> fail "mode must be one of: text, styled"+ DiffViewParams+ <$> o .: "leftPath"+ <*> o .: "rightPath"+ <*> pure modeValue++parseDiffMode :: Text -> Maybe DiffMode+parseDiffMode raw =+ case map toLower (T.unpack (T.strip raw)) of+ "text" -> Just DiffText+ "styled" -> Just DiffStyled+ _ -> Nothing++data ViewSubscribeParams = ViewSubscribeParams+ { subscribeDebounceMs :: Int+ , subscribeIncludeText :: Bool+ }++instance FromJSON ViewSubscribeParams where+ parseJSON value =+ case value of+ Null -> pure defaultViewSubscribeParams+ _ ->+ withObject+ "ViewSubscribeParams"+ ( \o ->+ ViewSubscribeParams+ <$> o .:? "debounceMs" AesonTypes..!= 100+ <*> o .:? "includeText" AesonTypes..!= False+ )+ value++defaultViewSubscribeParams :: ViewSubscribeParams+defaultViewSubscribeParams =+ ViewSubscribeParams+ { subscribeDebounceMs = 100+ , subscribeIncludeText = False+ }++data BatchParams = BatchParams+ { batchSteps :: [BatchStep]+ }++instance FromJSON BatchParams where+ parseJSON =+ withObject "BatchParams" $ \o ->+ BatchParams+ <$> o .:? "steps" AesonTypes..!= []++data BatchStep = BatchStep+ { batchStepMethod :: Text+ , batchStepParams :: Value+ }++instance FromJSON BatchStep where+ parseJSON =+ withObject "BatchStep" $ \o ->+ BatchStep+ <$> o .: "method"+ <*> o .:? "params" AesonTypes..!= Null++data RecordingStartParams = RecordingStartParams+ { recordingStartPath :: FilePath+ , recordingFrameIntervalMs :: Int+ }++instance FromJSON RecordingStartParams where+ parseJSON =+ withObject "RecordingStartParams" $ \o ->+ RecordingStartParams+ <$> o .: "path"+ <*> o .:? "frameIntervalMs" AesonTypes..!= 200++data ReplayParams = ReplayParams+ { replayPath :: FilePath+ , replaySpeed :: ReplaySpeed+ }++instance FromJSON ReplayParams where+ parseJSON =+ withObject "ReplayParams" $ \o -> do+ maybeSpeed <- o .:? "speed"+ speed <-+ case maybeSpeed of+ Nothing -> pure ReplayAsFastAsPossible+ Just raw ->+ case parseReplaySpeed raw of+ Just speed -> pure speed+ Nothing -> fail "speed must be one of: as-fast-as-possible, real-time"+ ReplayParams+ <$> o .: "path"+ <*> pure speed++parseReplaySpeed :: Text -> Maybe ReplaySpeed+parseReplaySpeed raw =+ case map toLower (T.unpack (T.strip raw)) of+ "as-fast-as-possible" -> Just ReplayAsFastAsPossible+ "real-time" -> Just ReplayRealTime+ _ -> Nothing++renderReplaySpeed :: ReplaySpeed -> Text+renderReplaySpeed speed =+ case speed of+ ReplayAsFastAsPossible -> "as-fast-as-possible"+ ReplayRealTime -> "real-time"++parseSelector :: Value -> AesonTypes.Parser Selector+parseSelector =+ withObject "Selector" $ \o -> do+ selectorType <- (T.toLower <$> (o .: "type" :: AesonTypes.Parser Text))+ case selectorType of+ "exact" -> Exact <$> o .: "text"+ "regex" -> Regex <$> o .: "pattern"+ "at" -> do+ col <- o .: "col"+ row <- o .: "row"+ if col < 1 || row < 1+ then fail "selector.at uses 1-based coordinates; col/row must be >= 1"+ else pure (At (col - 1) (row - 1))+ "within" -> do+ rectValue <- o .: "rect" >>= parseRect+ nested <- o .: "selector" >>= parseSelector+ pure (Within rectValue nested)+ "nth" -> Nth <$> o .: "index" <*> (o .: "selector" >>= parseSelector)+ _ -> fail ("unknown selector type: " <> T.unpack selectorType)++parseRect :: Value -> AesonTypes.Parser Rect+parseRect =+ withObject "Rect" $ \o -> do+ col <- o .: "col"+ row <- o .: "row"+ width <- o .: "width"+ height <- o .: "height"+ if col < 1 || row < 1+ then fail "selector.within.rect uses 1-based col/row coordinates"+ else+ if width < 1 || height < 1+ then fail "selector.within.rect width/height must be >= 1"+ else pure (Rect (col - 1) (row - 1) width height)++requestId :: RPC.JSONRPCRequest -> RPC.RequestId+requestId (RPC.JSONRPCRequest _ reqId _ _) = reqId++requestVersion :: RPC.JSONRPCRequest -> Text+requestVersion (RPC.JSONRPCRequest version _ _ _) = version++requestMethod :: RPC.JSONRPCRequest -> Text+requestMethod (RPC.JSONRPCRequest _ _ methodName _) = methodName++requestParams :: RPC.JSONRPCRequest -> Value+requestParams (RPC.JSONRPCRequest _ _ _ paramsValue) = paramsValue++applyStartParams :: ServerOptions -> StartParams -> Maybe AmbiguityMode -> RunOptions+applyStartParams options params ambiguityOverride =+ defaultRunOptions+ { timeoutSeconds = maybe (serverTimeoutSeconds options) id (startTimeoutSeconds params)+ , terminalCols = maybe (serverTerminalCols options) id (startTerminalCols params)+ , terminalRows = maybe (serverTerminalRows options) id (startTerminalRows params)+ , artifactsDir = serverArtifactsDir options+ , ambiguityMode = maybe (serverAmbiguityMode options) id ambiguityOverride+ , updateSnapshots = maybe False id (startUpdateSnapshots params)+ , snapshotTheme = maybe "auto" T.unpack (startSnapshotTheme params)+ }++resolveAmbiguityOverride :: Maybe Text -> Either String (Maybe AmbiguityMode)+resolveAmbiguityOverride maybeRaw =+ case maybeRaw of+ Nothing -> Right Nothing+ Just raw ->+ case parseAmbiguityMode raw of+ Just mode -> Right (Just mode)+ Nothing ->+ Left "ambiguityMode must be one of: fail, first, first-visible, last, last-visible"++parseAmbiguityMode :: Text -> Maybe AmbiguityMode+parseAmbiguityMode raw =+ case map toLower (T.unpack (T.strip raw)) of+ "fail" -> Just FailOnAmbiguous+ "first" -> Just FirstVisibleMatch+ "first-visible" -> Just FirstVisibleMatch+ "last" -> Just LastVisibleMatch+ "last-visible" -> Just LastVisibleMatch+ _ -> Nothing++parseSendKey :: Text -> Either String ([Modifier], Key)+parseSendKey rawKey =+ if trimmed == "+"+ then (,) [] <$> parseBaseKey trimmed+ else case T.breakOn "+" trimmed of+ (_, "") ->+ (,) [] <$> parseBaseKey trimmed+ (modifierText, remainder) ->+ do+ modifier <- parseModifier (T.strip modifierText)+ keyValue <- parseModifiedKey (T.strip (T.drop 1 remainder))+ pure ([modifier], keyValue)+ where+ trimmed = T.strip rawKey++ parseModifier textValue =+ case map toLower (T.unpack textValue) of+ "ctrl" -> Right Control+ "control" -> Right Control+ "alt" -> Right Alt+ "shift" -> Right Shift+ _ -> Left ("unknown modifier: " <> T.unpack textValue)++ parseModifiedKey textValue =+ case T.unpack textValue of+ [charValue] -> Right (CharKey charValue)+ _ -> Left "modified keys must use a single character (for example Ctrl+C)"++parseBaseKey :: Text -> Either String Key+parseBaseKey keyText =+ let lowered = map toLower (T.unpack (T.strip keyText))+ in case lowered of+ "enter" -> Right Enter+ "esc" -> Right Esc+ "escape" -> Right Esc+ "tab" -> Right Tab+ "backspace" -> Right Backspace+ "arrowup" -> Right ArrowUp+ "arrowdown" -> Right ArrowDown+ "arrowleft" -> Right ArrowLeft+ "arrowright" -> Right ArrowRight+ "space" -> Right (CharKey ' ')+ _ ->+ case parseFunctionKey lowered of+ Just functionNumber -> Right (FunctionKey functionNumber)+ Nothing ->+ case T.unpack (T.strip keyText) of+ [charValue] -> Right (CharKey charValue)+ _ -> Left ("unknown key: " <> T.unpack keyText)++parseFunctionKey :: String -> Maybe Int+parseFunctionKey lowered =+ case lowered of+ 'f' : digits+ | all isDigitAscii digits ->+ case reads digits of+ [(value, "")]+ | value >= 1 && value <= 12 -> Just value+ _ -> Nothing+ _ -> Nothing+ where+ isDigitAscii c = c >= '0' && c <= '9'++mergeWaitOptions :: WaitOptions -> Maybe Int -> Maybe Int -> WaitOptions+mergeWaitOptions defaults maybeTimeout maybePoll =+ defaults+ { timeoutMs = maybe (timeoutMs defaults) id maybeTimeout+ , pollIntervalMs = maybe (pollIntervalMs defaults) id maybePoll+ }++waitUntilPattern :: Tui -> WaitOptions -> Text -> IO ()+waitUntilPattern tui waitOptions patternText = do+ start <- getCurrentTime+ loop start+ where+ timeoutLimit = fromIntegral (timeoutMs waitOptions) / 1000 :: NominalDiffTime++ loop :: UTCTime -> IO ()+ loop startedAt = do+ viewText <- currentView tui+ if regexLikeMatch patternText viewText+ then pure ()+ else do+ now <- getCurrentTime+ if diffUTCTime now startedAt >= timeoutLimit+ then throwIO (userError "waitUntil timed out")+ else do+ threadDelay (pollIntervalMs waitOptions * 1000)+ loop startedAt++data CurrentViewFilter+ = FilterFull+ | FilterRows Int Int+ | FilterRegion Int Int Int Int+ | FilterEntireRow (Maybe Int)+ | FilterEntireCol (Maybe Int)++resolveCurrentViewFilter :: CurrentViewParams -> Int -> Int -> Either String CurrentViewFilter+resolveCurrentViewFilter params totalRows totalCols =+ case length activeFilters of+ n | n > 1 -> Left "currentView accepts exactly one of: rows, region, entireRow, entireCol"+ _ ->+ case activeFilters of+ [] -> Right FilterFull+ ["rows"] ->+ case currentRowsFilter params of+ Nothing -> Right FilterFull+ Just rowsFilter -> do+ start <- normalizeRowIndex "rows.start" totalRows (currentRowsStart rowsFilter)+ end <- normalizeRowIndex "rows.end" totalRows (currentRowsEnd rowsFilter)+ if start > end+ then Left "rows.start must be <= rows.end"+ else Right (FilterRows start end)+ ["region"] ->+ case currentRegionFilter params of+ Nothing -> Right FilterFull+ Just regionFilter -> resolveRegion regionFilter+ ["entireRow"] ->+ case currentEntireRowFilter params of+ Nothing -> Right FilterFull+ Just rowValue ->+ if rowValue == 0+ then Right (FilterEntireRow Nothing)+ else+ if rowValue < 0 || rowValue > totalRows+ then Left "entireRow must be 0 or between 1 and total rows"+ else Right (FilterEntireRow (Just rowValue))+ ["entireCol"] ->+ case currentEntireColFilter params of+ Nothing -> Right FilterFull+ Just colValue ->+ if colValue == 0+ then Right (FilterEntireCol Nothing)+ else+ if colValue < 0 || colValue > totalCols+ then Left "entireCol must be 0 or between 1 and total cols"+ else Right (FilterEntireCol (Just colValue))+ _ -> Left "invalid currentView filter selection"+ where+ activeFilters :: [Text]+ activeFilters =+ concat+ [ maybe [] (const ["rows"]) (currentRowsFilter params)+ , maybe [] (const ["region"]) (currentRegionFilter params)+ , maybe [] (const ["entireRow"]) (currentEntireRowFilter params)+ , maybe [] (const ["entireCol"]) (currentEntireColFilter params)+ ]++ resolveRegion regionFilter = do+ let rawCol = currentRegionCol regionFilter+ let rawRow = currentRegionRow regionFilter+ let rawWidth = currentRegionWidth regionFilter+ let rawHeight = currentRegionHeight regionFilter++ startCol <-+ if rawCol == 0+ then Right 1+ else normalizeColIndex "region.col" totalCols rawCol++ startRow <-+ if rawRow == 0+ then Right 1+ else normalizeRowIndex "region.row" totalRows rawRow++ endCol <-+ if rawCol == 0+ then Right totalCols+ else+ if rawWidth <= 0+ then Left "region.width must be > 0 when region.col is non-zero"+ else Right (min totalCols (startCol + rawWidth - 1))++ endRow <-+ if rawRow == 0+ then Right totalRows+ else+ if rawHeight <= 0+ then Left "region.height must be > 0 when region.row is non-zero"+ else Right (min totalRows (startRow + rawHeight - 1))++ if startCol > endCol || startRow > endRow+ then Left "resolved region is empty"+ else Right (FilterRegion startCol startRow endCol endRow)++normalizeRowIndex :: String -> Int -> Int -> Either String Int+normalizeRowIndex label totalRows rawValue =+ if rawValue == 0+ then Right 1+ else+ if rawValue < 1 || rawValue > totalRows+ then Left (label <> " must be 0 or between 1 and " <> show totalRows)+ else Right rawValue++normalizeColIndex :: String -> Int -> Int -> Either String Int+normalizeColIndex label totalCols rawValue =+ if rawValue == 0+ then Right 1+ else+ if rawValue < 1 || rawValue > totalCols+ then Left (label <> " must be 0 or between 1 and " <> show totalCols)+ else Right rawValue++applyCurrentViewFilter :: CurrentViewFilter -> Int -> Int -> Text -> (Text, Int, Int)+applyCurrentViewFilter filterValue totalRows totalCols textValue =+ case filterValue of+ FilterFull -> renderGrid grid+ FilterRows start end ->+ let selected = take (end - start + 1) (drop (start - 1) grid)+ in renderGrid selected+ FilterRegion startCol startRow endCol endRow ->+ let selectedRows = take (endRow - startRow + 1) (drop (startRow - 1) grid)+ selectedCols = map (sliceColumns startCol endCol) selectedRows+ in renderGrid selectedCols+ FilterEntireRow maybeRow ->+ case maybeRow of+ Nothing -> renderGrid grid+ Just rowIdx ->+ case safeIndex (rowIdx - 1) grid of+ Nothing -> renderGrid []+ Just rowText -> renderGrid [rowText]+ FilterEntireCol maybeCol ->+ case maybeCol of+ Nothing -> renderGrid grid+ Just colIdx ->+ let selected = map (sliceColumns colIdx colIdx) grid+ in renderGrid selected+ where+ grid = normalizeViewportGrid totalRows totalCols textValue++normalizeViewportGrid :: Int -> Int -> Text -> [Text]+normalizeViewportGrid rows cols textValue =+ map normalizeLine [0 .. rows - 1]+ where+ sourceLines = T.lines textValue+ padding = T.replicate cols " "++ normalizeLine idx =+ let sourceLine = fromMaybe "" (safeIndex idx sourceLines)+ in T.take cols (sourceLine <> padding)++renderGrid :: [Text] -> (Text, Int, Int)+renderGrid rowsText =+ let rowCount = length rowsText+ colCount =+ case rowsText of+ [] -> 0+ rowValue : _ -> T.length rowValue+ in (T.intercalate "\n" rowsText, rowCount, colCount)++sliceColumns :: Int -> Int -> Text -> Text+sliceColumns startCol endCol lineText =+ T.take (endCol - startCol + 1) (T.drop (startCol - 1) lineText)++renderSnapshotFromDump :: DumpViewParams -> FilePath -> IO FilePath+renderSnapshotFromDump params ansiPath = do+ let pngPath = defaultPngPath ansiPath+ renderAnsiSnapshotFileWithFont+ (dumpFontPath params)+ (dumpRows params)+ (dumpCols params)+ (dumpTheme params)+ ansiPath+ pngPath+ canonicalizeExistingPath pngPath++renderSnapshotFromRenderView :: RenderViewParams -> FilePath -> IO FilePath+renderSnapshotFromRenderView params ansiPath = do+ let pngPath = defaultPngPath ansiPath+ renderAnsiSnapshotFileWithFont+ (renderViewFontPath params)+ (renderViewRows params)+ (renderViewCols params)+ (renderViewTheme params)+ ansiPath+ pngPath+ canonicalizeExistingPath pngPath++defaultPngPath :: FilePath -> FilePath+defaultPngPath ansiPath =+ if ".ansi.txt" `isSuffixOf` ansiPath+ then take (length ansiPath - length (".ansi.txt" :: String)) ansiPath <> ".png"+ else ansiPath <> ".png"++canonicalizeExistingPath :: FilePath -> IO FilePath+canonicalizeExistingPath path = do+ exists <- doesFileExist path+ if exists+ then canonicalizePath path+ else pure path++data SnapshotDiffResult = SnapshotDiffResult+ { diffChanged :: Bool+ , diffChangedLines :: Int+ , diffSummary :: Text+ }++computeSnapshotDiff :: RunOptions -> DiffViewParams -> IO SnapshotDiffResult+computeSnapshotDiff options params = do+ leftPath <- canonicalizeExistingPath (diffLeftPath params)+ rightPath <- canonicalizeExistingPath (diffRightPath params)++ leftExists <- doesFileExist leftPath+ rightExists <- doesFileExist rightPath++ if not leftExists || not rightExists+ then+ throwIO+ ( userError+ ( "diffView requires both paths to exist (left="+ <> leftPath+ <> ", right="+ <> rightPath+ <> ")"+ )+ )+ else do+ leftComparable <- loadComparableSnapshot options (diffMode params) leftPath+ rightComparable <- loadComparableSnapshot options (diffMode params) rightPath+ let changed = leftComparable /= rightComparable+ let changedLineCount = lineDifferenceCount leftComparable rightComparable+ let summary =+ if changed+ then+ "Snapshots differ ("+ <> T.pack (show changedLineCount)+ <> " changed lines)"+ else "Snapshots are identical"+ pure+ SnapshotDiffResult+ { diffChanged = changed+ , diffChangedLines = changedLineCount+ , diffSummary = summary+ }++loadComparableSnapshot :: RunOptions -> DiffMode -> FilePath -> IO Text+loadComparableSnapshot options mode path = do+ ansiText <- TIO.readFile path+ (rows, cols) <- loadSnapshotDimensions path options+ case mode of+ DiffText -> pure (renderAnsiViewportText rows cols ansiText)+ DiffStyled -> pure (T.pack (serializeAnsiSnapshot rows cols (snapshotTheme options) ansiText))++loadSnapshotDimensions :: FilePath -> RunOptions -> IO (Int, Int)+loadSnapshotDimensions path options = do+ let metaPath = snapshotMetadataPath path+ metaExists <- doesFileExist metaPath+ if not metaExists+ then pure (terminalRows options, terminalCols options)+ else do+ metaBytes <- BL.readFile metaPath+ case eitherDecode metaBytes of+ Left _ -> pure (terminalRows options, terminalCols options)+ Right meta -> pure (snapshotMetaRows meta, snapshotMetaCols meta)++data SnapshotMeta = SnapshotMeta+ { snapshotMetaRows :: Int+ , snapshotMetaCols :: Int+ }++instance FromJSON SnapshotMeta where+ parseJSON =+ withObject "SnapshotMeta" $ \o ->+ SnapshotMeta+ <$> o .: "rows"+ <*> o .: "cols"++lineDifferenceCount :: Text -> Text -> Int+lineDifferenceCount left right =+ go 0 leftLines rightLines+ where+ leftLines = T.lines left+ rightLines = T.lines right++ go count [] [] = count+ go count (l : ls) [] = go (if T.null l then count else count + 1) ls []+ go count [] (r : rs) = go (if T.null r then count else count + 1) [] rs+ go count (l : ls) (r : rs) =+ go+ (if l == r then count else count + 1)+ ls+ rs++emitViewChangedNotification :: ServerState -> Tui -> IO ()+emitViewChangedNotification state tui = do+ maybeSubscription <- readIORef (stateViewSubscription state)+ case maybeSubscription of+ Nothing -> pure ()+ Just subscription -> do+ nowMicros <- currentMicros+ textValue <- currentView tui+ let changedSinceLast = maybe True (/= textValue) (subscriptionLastView subscription)+ let debounceMicros = fromIntegral (subscriptionDebounceMs subscription) * 1000+ let pastDebounce =+ case subscriptionLastSentMicros subscription of+ Nothing -> True+ Just lastSent -> nowMicros - lastSent >= debounceMicros+ let updatedSubscription = subscription{subscriptionLastView = Just textValue}+ if changedSinceLast && pastDebounce+ then do+ let options = tuiOptions tui+ let payloadBase =+ [ "rows" .= terminalRows options+ , "cols" .= terminalCols options+ ]+ let payload =+ if subscriptionIncludeText subscription+ then object (payloadBase <> ["text" .= textValue])+ else object payloadBase+ _ <- writeNotification state "view.changed" payload+ writeIORef+ (stateViewSubscription state)+ (Just updatedSubscription{subscriptionLastSentMicros = Just nowMicros})+ else+ writeIORef (stateViewSubscription state) (Just updatedSubscription)++currentMicros :: IO Int64+currentMicros = do+ now <- getPOSIXTime+ pure (floor (now * 1000000))++replayRecordedRequestLine :: ServerState -> Text -> IO ()+replayRecordedRequestLine state lineText =+ case eitherDecodeStrict' (TE.encodeUtf8 lineText) :: Either String RPC.JSONRPCRequest of+ Left parseErr ->+ throwIO (userError ("replay failed to parse request line: " <> parseErr))+ Right request ->+ if requestMethod request == "server.shutdown"+ then pure ()+ else case validateRequestVersion request of+ Left err ->+ throwIO (userError ("replay request rejected: " <> T.unpack (failureMessage err)))+ Right () -> do+ outcome <- dispatchMethod state (requestMethod request) (requestParams request)+ case outcome of+ Left failure ->+ throwIO+ ( userError+ ( "replay step failed ("+ <> T.unpack (requestMethod request)+ <> "): "+ <> T.unpack (failureMessage failure)+ )+ )+ Right _ -> pure () fromMaybeText :: Text -> Maybe Text -> Text fromMaybeText fallback maybeValue =
src/TuiSpec/Types.hs view
@@ -9,6 +9,7 @@ module TuiSpec.Types ( AmbiguityMode (..), App (..),+ app, Key (..), Modifier (..), PtyHandle (..),@@ -25,6 +26,7 @@ defaultRunOptions, defaultStepOptions, defaultWaitOptions,+ tuispecVersion, ) where import Data.IORef (IORef)@@ -40,17 +42,43 @@ , specBody :: Tui -> IO () } --- | The command to launch inside the PTY.+{- | The command to launch inside the PTY.++`env` overrides inherit from the parent process. Use:++- `Just "value"` to set or override an environment variable+- `Nothing` to unset an inherited variable++`cwd` sets the working directory for the launch command when present.+-} data App = App { command :: FilePath , args :: [String]+ , env :: Maybe [(String, Maybe String)]+ , cwd :: Maybe FilePath } deriving (Eq, Show) +{- | Construct an app launch request using inherited environment variables and+the current working directory.+-}+app :: FilePath -> [String] -> App+app commandValue argsValue =+ App+ { command = commandValue+ , args = argsValue+ , env = Nothing+ , cwd = Nothing+ }+ -- | How selector ambiguity is handled for assertion helpers. data AmbiguityMode- = FailOnAmbiguous- | FirstVisibleMatch+ = -- | Fail when a non-explicit selector matches more than one target.+ FailOnAmbiguous+ | -- | Accept ambiguous matches and use first-match behavior.+ FirstVisibleMatch+ | -- | Accept ambiguous matches and use last-match behavior.+ LastVisibleMatch deriving (Eq, Show, Read) -- | Runtime options for a @tuiTest@ execution.@@ -89,6 +117,10 @@ , updateSnapshots = False , snapshotTheme = "auto" }++-- | The tuispec library/protocol version.+tuispecVersion :: String+tuispecVersion = "0.2.0.0" -- | Key modifiers for combo key presses. data Modifier
test/Spec.hs view
@@ -2,9 +2,26 @@ module Main where -import System.Directory (doesFileExist)+import Control.Exception (SomeException, bracket, catch)+import Data.Aeson (Value (..), decodeStrict', encode, object, (.=))+import Data.Aeson.Key qualified as K+import Data.Aeson.KeyMap qualified as KM+import Data.ByteString.Char8 qualified as BS8+import Data.ByteString.Lazy qualified as BL+import Data.List (isInfixOf)+import Data.Scientific (toBoundedInteger)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as TE+import System.Directory (canonicalizePath, createDirectoryIfMissing, doesFileExist)+import System.Environment (getEnvironment)+import System.Exit (ExitCode (ExitSuccess))+import System.FilePath ((</>))+import System.IO (BufferMode (LineBuffering), Handle, hClose, hFlush, hSetBuffering)+import System.Process qualified as Process+import System.Timeout (timeout) import Test.Tasty (defaultMain, testGroup)-import Test.Tasty.HUnit (assertBool, testCase)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) import TuiSpec main :: IO ()@@ -20,7 +37,7 @@ } "smoke: text appears in viewport" $ \tui -> do- launch tui (App "sh" [])+ launch tui (app "sh" []) sendLine tui "printf 'hello from tuispec\\n'" waitForText tui (Exact "hello from tuispec") expectNotVisible tui (Exact "this text should not exist")@@ -35,11 +52,521 @@ } "session" $ \tui -> do- launch tui (App "sh" [])+ launch tui (app "sh" []) sendLine tui "printf 'hello from repl session\\n'" snapshotPath <- dumpView tui "repl-view" sendLine tui "exit" pure snapshotPath exists <- doesFileExist snapshotPath assertBool "dumpView should write an ansi snapshot file" exists+ , testCase "smoke: launch supports env overrides" $+ withTuiSession+ defaultRunOptions+ { timeoutSeconds = 8+ , artifactsDir = "artifacts/repl-env-smoke"+ }+ "env-session"+ ( \tui -> do+ launch+ tui+ App+ { command = "sh"+ , args = []+ , env = Just [("TUISPEC_TEST_ENV", Just "hello-env")]+ , cwd = Nothing+ }+ sendLine tui "printf '%s\\n' \"$TUISPEC_TEST_ENV\""+ waitForText tui (Exact "hello-env")+ sendLine tui "exit"+ )+ , testCase "smoke: waitForText ignores ANSI escape sequences" $+ withTuiSession+ defaultRunOptions+ { timeoutSeconds = 8+ , artifactsDir = "artifacts/repl-ansi-smoke"+ , ambiguityMode = FirstVisibleMatch+ }+ "ansi-session"+ ( \tui -> do+ launch tui (app "sh" [])+ sendLine tui "printf '\\033[31mstyled text\\033[0m\\n'"+ waitForText tui (Exact "styled text")+ expectNotVisible tui (Exact "\ESC[31mstyled text\ESC[0m")+ sendLine tui "exit"+ )+ , testCase "smoke: waitForStable detects viewport stability" $+ withTuiSession+ defaultRunOptions+ { timeoutSeconds = 8+ , artifactsDir = "artifacts/wait-stable-smoke"+ , ambiguityMode = FirstVisibleMatch+ }+ "wait-stable"+ ( \tui -> do+ launch tui (app "sh" [])+ sendLine tui "printf 'stable output\\n'"+ waitForText tui (Exact "stable output")+ waitForStable tui defaultWaitOptions{timeoutMs = 5000} 300+ sendLine tui "exit"+ )+ , testCase "server: additions end-to-end" testServerAdditions+ , testCase "server: notifications" testServerNotifications+ , testCase "server: recording + replay JSONL + CLI" testServerRecordingReplay ]++testServerAdditions :: IO ()+testServerAdditions =+ withRpcServer "additions" [("TUI_UNSET", "from-server")] $ \server -> do+ initResponse <- rpcCall server 1 "initialize" (object ["name" .= ("additions" :: Text), "ambiguityMode" .= ("first" :: Text)])+ _ <- expectResult initResponse++ cwdPath <- canonicalizePath "artifacts/server-tests/additions/cwd"+ createDirectoryIfMissing True cwdPath++ launchResponse <-+ rpcCall+ server+ 2+ "launch"+ ( object+ [ "command" .= ("sh" :: Text)+ , "args" .= (["-lc", "printf 'READY:%s\\n' \"$PWD\"; exec sh"] :: [String])+ , "cwd" .= cwdPath+ , "env"+ .= object+ [ "TUI_SET" .= ("value" :: Text)+ , "TUI_UNSET" .= Null+ ]+ , "readySelector" .= exactSelector "READY:"+ ]+ )+ _ <- expectResult launchResponse++ sendLineResponse <-+ rpcCall+ server+ 3+ "sendLine"+ ( object+ [ "text" .= ("printf '%s|%s\\n' \"$TUI_SET\" \"$TUI_UNSET\"" :: Text)+ , "expectAfter" .= exactSelector "value|"+ ]+ )+ _ <- expectResult sendLineResponse++ viewAll <- expectResult =<< rpcCall server 4 "currentView" (object ["entireRow" .= (0 :: Int)])+ rowsAll <- fieldInt "rows" viewAll+ rowsAll @?= 40++ viewRow <- expectResult =<< rpcCall server 5 "currentView" (object ["rows" .= object ["start" .= (1 :: Int), "end" .= (1 :: Int)]])+ rowsSingle <- fieldInt "rows" viewRow+ rowsSingle @?= 1++ viewCol <- expectResult =<< rpcCall server 6 "currentView" (object ["entireCol" .= (1 :: Int)])+ colsSingle <- fieldInt "cols" viewCol+ colsSingle @?= 1++ invalidFilter <- rpcCall server 7 "currentView" (object ["entireRow" .= (1 :: Int), "rows" .= object ["start" .= (1 :: Int), "end" .= (1 :: Int)]])+ _ <- expectError invalidFilter++ waitUntilResp <- rpcCall server 8 "waitUntil" (object ["pattern" .= ("value.*" :: Text)])+ _ <- expectResult waitUntilResp++ dumpResult <-+ expectResult+ =<< rpcCall+ server+ 9+ "dumpView"+ ( object+ [ "name" .= ("snap-a" :: Text)+ , "format" .= ("both" :: Text)+ ]+ )+ snapA <- fieldText "snapshotPath" dumpResult+ pngA <- fieldText "pngPath" dumpResult+ snapAExists <- doesFileExist (T.unpack snapA)+ pngAExists <- doesFileExist (T.unpack pngA)+ assertBool "dumpView should emit ANSI snapshot path" snapAExists+ assertBool "dumpView format=both should emit PNG" pngAExists++ _ <-+ expectResult+ =<< rpcCall+ server+ 10+ "sendLine"+ ( object+ [ "text" .= ("echo changed" :: Text)+ , "expectAfter" .= exactSelector "changed"+ ]+ )++ renderResult <- expectResult =<< rpcCall server 11 "renderView" (object ["name" .= ("snap-b" :: Text)])+ snapB <- fieldText "snapshotPath" renderResult+ _ <- fieldText "pngPath" renderResult++ diffChanged <-+ expectResult+ =<< rpcCall+ server+ 12+ "diffView"+ ( object+ [ "leftPath" .= snapA+ , "rightPath" .= snapB+ , "mode" .= ("text" :: Text)+ ]+ )+ changedFlag <- fieldBool "changed" diffChanged+ changedFlag @?= True++ diffUnchanged <-+ expectResult+ =<< rpcCall+ server+ 13+ "diffView"+ ( object+ [ "leftPath" .= snapA+ , "rightPath" .= snapA+ ]+ )+ unchangedFlag <- fieldBool "changed" diffUnchanged+ unchangedFlag @?= False++ _ <- expectResult =<< rpcCall server 14 "sendLine" (object ["text" .= ("echo Specify" :: Text)])+ _ <- expectResult =<< rpcCall server 15 "sendLine" (object ["text" .= ("echo Specify" :: Text)])++ ambiguousFail <-+ rpcCall+ server+ 16+ "waitForText"+ ( object+ [ "selector" .= exactSelector "Specify"+ , "ambiguityMode" .= ("fail" :: Text)+ ]+ )+ _ <- expectError ambiguousFail++ ambiguousLast <-+ rpcCall+ server+ 17+ "waitForText"+ ( object+ [ "selector" .= exactSelector "Specify"+ , "ambiguityMode" .= ("last" :: Text)+ ]+ )+ _ <- expectResult ambiguousLast++ batchResult <-+ expectResult+ =<< rpcCall+ server+ 18+ "batch"+ ( object+ [ "steps"+ .= [ object ["method" .= ("server.ping" :: Text), "params" .= object []]+ , object ["method" .= ("no.such.method" :: Text), "params" .= object []]+ ]+ ]+ )+ batchOk <- fieldBool "ok" batchResult+ batchOk @?= False+ completedSteps <- fieldInt "completed" batchResult+ completedSteps @?= 1++testServerNotifications :: IO ()+testServerNotifications =+ withRpcServer "notifications" [] $ \server -> do+ _ <- expectResult =<< rpcCall server 1 "initialize" (object ["name" .= ("notify" :: Text)])+ _ <-+ expectResult+ =<< rpcCall+ server+ 2+ "launch"+ ( object+ [ "command" .= ("sh" :: Text)+ , "args" .= (["-lc", "cat"] :: [String])+ ]+ )++ (_, subscribeNotifications) <-+ rpcCallWithNotifications+ server+ 3+ "viewSubscribe"+ ( object+ [ "debounceMs" .= (0 :: Int)+ , "includeText" .= True+ ]+ )+ assertBool "viewSubscribe should emit initial view.changed" (any isViewChangedNotification subscribeNotifications)++ (_, sendNotifications) <- rpcCallWithNotifications server 4 "sendText" (object ["text" .= ("x" :: Text)])+ assertBool "sendText should emit view.changed when subscribed" (any isViewChangedNotification sendNotifications)++ _ <- expectResult =<< rpcCall server 5 "viewUnsubscribe" (object [])+ (_, unsubscribedNotifications) <- rpcCallWithNotifications server 6 "sendText" (object ["text" .= ("y" :: Text)])+ assertBool "sendText should not emit notifications after unsubscribe" (not (any isViewChangedNotification unsubscribedNotifications))++testServerRecordingReplay :: IO ()+testServerRecordingReplay =+ withRpcServer "recording" [] $ \server -> do+ _ <- expectResult =<< rpcCall server 1 "initialize" (object ["name" .= ("recording" :: Text)])+ _ <-+ expectResult+ =<< rpcCall+ server+ 2+ "launch"+ ( object+ [ "command" .= ("sh" :: Text)+ , "args" .= (["-lc", "cat"] :: [String])+ ]+ )++ let recordingPath = "artifacts/server-tests/recording/session.jsonl"++ _ <- expectResult =<< rpcCall server 3 "recording.start" (object ["path" .= recordingPath])+ _ <- expectResult =<< rpcCall server 4 "sendText" (object ["text" .= ("hello" :: Text)])+ _ <- expectResult =<< rpcCall server 5 "sendKey" (object ["key" .= ("Enter" :: Text)])+ _ <- expectResult =<< rpcCall server 6 "recording.stop" (object [])++ statusResult <- expectResult =<< rpcCall server 7 "recording.status" (object [])+ statusActive <- fieldBool "active" statusResult+ statusActive @?= False++ exists <- doesFileExist recordingPath+ assertBool "recording JSONL should exist" exists++ replayResult <-+ expectResult+ =<< rpcCall+ server+ 8+ "replay"+ ( object+ [ "path" .= recordingPath+ , "speed" .= ("as-fast-as-possible" :: Text)+ ]+ )+ replayCount <- fieldInt "replayedRequests" replayResult+ assertBool "replay should execute recorded requests" (replayCount >= 2)++ exe <- locateTuiSpecExecutable+ (cliCode, cliOut, cliErr) <-+ Process.readCreateProcessWithExitCode+ (Process.proc exe ["replay", recordingPath, "--speed", "as-fast-as-possible"])+ ""+ case cliCode of+ ExitSuccess ->+ assertBool "CLI replay should report replay progress" ("Replayed" `isInfixOf` cliOut)+ _ ->+ assertFailure ("tuispec replay failed: " <> cliErr)++data RpcServer = RpcServer+ { rpcInput :: Handle+ , rpcOutput :: Handle+ , rpcProcess :: Process.ProcessHandle+ }++withRpcServer :: FilePath -> [(String, String)] -> (RpcServer -> IO a) -> IO a+withRpcServer name extraEnv action = do+ exe <- locateTuiSpecExecutable+ let artifactsRoot = "artifacts/server-tests" </> name+ createDirectoryIfMissing True artifactsRoot+ inheritedEnv <- getEnvironment+ let mergedEnv = applyEnvOverrides inheritedEnv extraEnv+ bracket+ (startServer exe artifactsRoot mergedEnv)+ stopServer+ action++startServer :: FilePath -> FilePath -> [(String, String)] -> IO RpcServer+startServer exe artifactsRoot serverEnv = do+ (Just inputHandle, Just outputHandle, _, processHandle) <-+ Process.createProcess+ (Process.proc exe ["server", "--artifact-dir", artifactsRoot])+ { Process.std_in = Process.CreatePipe+ , Process.std_out = Process.CreatePipe+ , Process.std_err = Process.Inherit+ , Process.env = Just serverEnv+ , Process.create_group = True+ }+ hSetBuffering inputHandle LineBuffering+ hSetBuffering outputHandle LineBuffering+ pure+ RpcServer+ { rpcInput = inputHandle+ , rpcOutput = outputHandle+ , rpcProcess = processHandle+ }++stopServer :: RpcServer -> IO ()+stopServer server = do+ _ <- rpcCall server 9999 "server.shutdown" (object []) `catch` ignoreAny+ hClose (rpcInput server) `catch` ignoreAnyUnit+ Process.terminateProcess (rpcProcess server) `catch` ignoreAnyUnit+ _ <- Process.waitForProcess (rpcProcess server) `catch` ignoreAnyExit+ pure ()++ignoreAny :: SomeException -> IO Value+ignoreAny _ = pure Null++ignoreAnyUnit :: SomeException -> IO ()+ignoreAnyUnit _ = pure ()++ignoreAnyExit :: SomeException -> IO ExitCode+ignoreAnyExit _ = pure ExitSuccess++rpcCall :: RpcServer -> Int -> Text -> Value -> IO Value+rpcCall server reqId methodName paramsValue = do+ (response, _) <- rpcCallWithNotifications server reqId methodName paramsValue+ pure response++rpcCallWithNotifications :: RpcServer -> Int -> Text -> Value -> IO (Value, [Value])+rpcCallWithNotifications server reqId methodName paramsValue = do+ let payload =+ object+ [ "jsonrpc" .= ("2.0" :: Text)+ , "id" .= reqId+ , "method" .= methodName+ , "params" .= paramsValue+ ]+ BS8.hPutStrLn (rpcInput server) (BL.toStrict (encode payload))+ hFlush (rpcInput server)+ readResponses []+ where+ readResponses notifications = do+ maybeLine <- timeout (10 * 1000 * 1000) (BS8.hGetLine (rpcOutput server))+ case maybeLine of+ Nothing ->+ assertFailure ("Timed out waiting for JSON-RPC response for method " <> T.unpack methodName)+ Just line ->+ case decodeStrict' line of+ Nothing ->+ assertFailure ("Failed to decode JSON-RPC line: " <> BS8.unpack line)+ Just value ->+ if responseHasId reqId value+ then pure (value, reverse notifications)+ else+ if isNotification value+ then readResponses (value : notifications)+ else readResponses notifications++responseHasId :: Int -> Value -> Bool+responseHasId reqId value =+ case fieldValue "id" value of+ Just (Number n) ->+ case toBoundedInteger n :: Maybe Int of+ Just parsed -> parsed == reqId+ Nothing -> False+ _ -> False++isNotification :: Value -> Bool+isNotification value =+ case value of+ Object _ ->+ case (fieldValue "method" value, fieldValue "id" value) of+ (Just _, Nothing) -> True+ _ -> False+ _ -> False++isViewChangedNotification :: Value -> Bool+isViewChangedNotification value =+ case fieldTextMaybe "method" value of+ Just methodName -> methodName == "view.changed"+ Nothing -> False++expectResult :: Value -> IO Value+expectResult response =+ case fieldValue "result" response of+ Just resultValue -> pure resultValue+ Nothing ->+ case fieldValue "error" response of+ Just errorValue ->+ assertFailure ("Expected JSON-RPC result but received error: " <> T.unpack (renderValue errorValue))+ Nothing ->+ assertFailure "Expected JSON-RPC result field"++expectError :: Value -> IO Value+expectError response =+ case fieldValue "error" response of+ Just errorValue -> pure errorValue+ Nothing ->+ assertFailure "Expected JSON-RPC error field"++fieldValue :: Text -> Value -> Maybe Value+fieldValue key value =+ case value of+ Object objectValue -> KM.lookup (K.fromText key) objectValue+ _ -> Nothing++fieldTextMaybe :: Text -> Value -> Maybe Text+fieldTextMaybe key value =+ case fieldValue key value of+ Just (String textValue) -> Just textValue+ _ -> Nothing++fieldText :: Text -> Value -> IO Text+fieldText key value =+ case fieldTextMaybe key value of+ Just textValue -> pure textValue+ Nothing -> assertFailure ("Expected text field: " <> T.unpack key)++fieldInt :: Text -> Value -> IO Int+fieldInt key value =+ case fieldValue key value of+ Just (Number n) ->+ case toBoundedInteger n of+ Just intValue -> pure intValue+ Nothing -> assertFailure ("Expected bounded integer field: " <> T.unpack key)+ _ -> assertFailure ("Expected integer field: " <> T.unpack key)++fieldBool :: Text -> Value -> IO Bool+fieldBool key value =+ case fieldValue key value of+ Just (Bool boolValue) -> pure boolValue+ _ -> assertFailure ("Expected boolean field: " <> T.unpack key)++exactSelector :: Text -> Value+exactSelector textValue =+ object+ [ "type" .= ("exact" :: Text)+ , "text" .= textValue+ ]++renderValue :: Value -> Text+renderValue = TE.decodeUtf8 . BL.toStrict . encode++locateTuiSpecExecutable :: IO FilePath+locateTuiSpecExecutable = do+ (exitCode, stdoutText, stderrText) <-+ Process.readCreateProcessWithExitCode+ ( Process.proc+ "sh"+ [ "-lc"+ , "find dist-newstyle/build -type f -path '*/x/tuispec/build/tuispec/tuispec' | sort | tail -n 1"+ ]+ )+ ""+ case exitCode of+ ExitSuccess ->+ case lines stdoutText of+ [] -> assertFailure "Could not locate built tuispec executable in dist-newstyle"+ pathValue : _ | null pathValue -> assertFailure "Located empty executable path"+ pathValue : _ -> pure pathValue+ _ -> assertFailure ("Failed to locate tuispec executable: " <> stderrText)++applyEnvOverrides :: [(String, String)] -> [(String, String)] -> [(String, String)]+applyEnvOverrides base overrides =+ foldl+ (\acc (key, value) -> (key, value) : filter ((/= key) . fst) acc)+ base+ overrides
tuispec.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.8 name: tuispec-version: 0.1.0.0+version: 0.2.0.0 build-type: Simple license: MIT license-file: LICENSE@@ -40,8 +40,8 @@ SERVER.md SKILL.md SPEC.md- doc/example-dashboard-ioskeley-dark.png doc/example-board-ioskeley-light.png+ doc/example-dashboard-ioskeley-dark.png source-repository head type: git@@ -57,11 +57,13 @@ exposed-modules: TuiSpec TuiSpec.Render+ TuiSpec.Replay TuiSpec.Runner TuiSpec.Server TuiSpec.Types other-modules:+ TuiSpec.Internal TuiSpec.ProjectRoot build-depends:@@ -75,19 +77,23 @@ posix-pty >=0.2 && <0.3, process >=1.6 && <1.7, tasty >=1.4 && <1.6,- tasty-hunit >=0.10 && <0.11,+ tasty-hunit >=0.10 && <0.12, text >=1.2 && <2.2, time >=1.9 && <1.15,- unix >=2.8 && <2.9,+ unix >=2.8 && <2.10, executable tuispec import: common-settings hs-source-dirs: app main-is: Main.hs+ autogen-modules: Paths_tuispec+ other-modules: Paths_tuispec build-depends: base >=4.16 && <5, optparse-applicative >=0.18 && <0.20,+ text >=1.2 && <2.2, tuispec,+ unix >=2.8 && <2.10, test-suite tuispec-smoke import: common-settings@@ -95,9 +101,14 @@ hs-source-dirs: test main-is: Spec.hs build-depends:+ aeson >=2.0 && <2.3, base >=4.16 && <5,+ bytestring >=0.11 && <0.13, directory >=1.3 && <1.4,+ filepath >=1.4 && <1.6,+ process >=1.6 && <1.7,+ scientific >=0.3 && <0.4, tasty >=1.4 && <1.6,- tasty-hunit >=0.10 && <0.11,+ tasty-hunit >=0.10 && <0.12, text >=1.2 && <2.2, tuispec,