diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 () diff --git a/SERVER.md b/SERVER.md --- a/SERVER.md +++ b/SERVER.md @@ -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/.ansi.txt` -- `X/sessions/foo/snapshots/.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 diff --git a/SKILL.md b/SKILL.md --- a/SKILL.md +++ b/SKILL.md @@ -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 `.ansi.txt` + `.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. diff --git a/SPEC.md b/SPEC.md --- a/SPEC.md +++ b/SPEC.md @@ -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 diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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) diff --git a/src/TuiSpec.hs b/src/TuiSpec.hs --- a/src/TuiSpec.hs +++ b/src/TuiSpec.hs @@ -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 (..), diff --git a/src/TuiSpec/Internal.hs b/src/TuiSpec/Internal.hs new file mode 100644 --- /dev/null +++ b/src/TuiSpec/Internal.hs @@ -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 () diff --git a/src/TuiSpec/Render.hs b/src/TuiSpec/Render.hs --- a/src/TuiSpec/Render.hs +++ b/src/TuiSpec/Render.hs @@ -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 () diff --git a/src/TuiSpec/Replay.hs b/src/TuiSpec/Replay.hs new file mode 100644 --- /dev/null +++ b/src/TuiSpec/Replay.hs @@ -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 == " " = "" + | t == "\t" = "" + | 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)) diff --git a/src/TuiSpec/Runner.hs b/src/TuiSpec/Runner.hs --- a/src/TuiSpec/Runner.hs +++ b/src/TuiSpec/Runner.hs @@ -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 () diff --git a/src/TuiSpec/Server.hs b/src/TuiSpec/Server.hs --- a/src/TuiSpec/Server.hs +++ b/src/TuiSpec/Server.hs @@ -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 = diff --git a/src/TuiSpec/Types.hs b/src/TuiSpec/Types.hs --- a/src/TuiSpec/Types.hs +++ b/src/TuiSpec/Types.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 diff --git a/tuispec.cabal b/tuispec.cabal --- a/tuispec.cabal +++ b/tuispec.cabal @@ -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,