tui: center message layout; add harness fuzzer
ober
f73c64fbc80b0afb09582b14ab90d9d3d4e8e0de
--- a/Makefile +++ b/Makefile @@ -63,7 +63,7 @@ JCODE_DEV_NATIVE_ENV = JERBOA_DEV_NATIVE=1 \ JERBOA_NATIVE_LIB="$(JCODE_DEV_NATIVE_LIB)" \ JCODE_TUI_DEV_NATIVE=1 JCODE_TUI_LIB="$(JCODE_DEV_TUI_LIB)" -.PHONY: all help ensure-jerboa-tools build gen run test test-websearch-worker test-websearch-packaged test-tui-native-loader-security security audit security-audit verify sbom target-evidence reproducibility-report release-evidence test-providers local-eval clean repl binary install tui-shim run-tui native-rs linux linux-check linux-amd64 linux-arm64 jcode-linux-amd64 jcode-linux-arm64 freebsd freebsd-amd64 jcode-freebsd-amd64 purge-stale android android-clean vendor-deps vendor-provenance-check vendor-clean lint +.PHONY: all help ensure-jerboa-tools build gen run test fuzz test-websearch-worker test-websearch-packaged test-tui-native-loader-security security audit security-audit verify sbom target-evidence reproducibility-report release-evidence test-providers local-eval clean repl binary install tui-shim run-tui native-rs linux linux-check linux-amd64 linux-arm64 jcode-linux-amd64 jcode-linux-arm64 freebsd freebsd-amd64 jcode-freebsd-amd64 purge-stale android android-clean vendor-deps vendor-provenance-check vendor-clean lint all: help @@ -72,6 +72,7 @@ help: @echo " ensure-jerboa-tools Ensure project-local jerboa/jerbuild are available" @echo " build Compile src/ → lib/ and pre-compile imports (jerbuild)" @echo " test Run test suite (test/run.ss)" + @echo " fuzz Run harness fuzzer (test/fuzz.ss); JCODE_FUZZ_ITERS controls depth" @echo " audit Run release security audit checks" @echo " sbom Write SBOM/provenance evidence to $(SBOM_DIR)" @echo " target-evidence Record target proof status for sandbox/MCP/LSP/remote/fuzz/clean-host gates" @@ -251,6 +252,11 @@ test: build test-websearch-worker test-tui-native-loader-security $(JCODE_DEV_NATIVE_ENV) \ $(JEXEC) test/run.ss +fuzz: build + JERBSEARCH_ENGINE_WORKER="$(WEBSEARCH_WORKER)" \ + $(JCODE_DEV_NATIVE_ENV) \ + $(JEXEC) test/fuzz.ss + test-websearch-worker: build JERBSEARCH_ENGINE_WORKER="$(WEBSEARCH_WORKER)" \ $(JCODE_DEV_NATIVE_ENV) \ new file mode 100644 --- /dev/null +++ b/cleanup.md @@ -0,0 +1,286 @@ +# Handoff: centered message layout + harness fuzzing + +Two independent tasks. Do them as separate commits. Both are scoped to **this +repo only** (`jerboa-code`) — do not touch sibling repos. + +- **Task 1** — make the TUI conversation text centered with side margins + (opencode-style) instead of flush left-justified. +- **Task 2** — add a fuzzer that hammers every parser the harness runs on + untrusted bytes (model output, MCP/LSP output) so garbage can never crash the + agent loop. Wire it into the build and satisfy the existing release "fuzz + proof" gate. + +--- + +## Repo orientation (read this first) + +`jcode` is a terminal coding agent written in **Jerboa Scheme** (Chez-based). +Source is `.ss` under `src/jcode/`; it transpiles/compiles to `lib/`. + +| Command | What it does | +|---|---| +| `make build` | transpile `src/ → lib/` + compile-check. **Run after any `.ss` edit.** | +| `make test` | full suite: security regression + `test/run.ss` | +| `make lint` | alias for `gen` (transpile only) — fast syntax/import check | +| `make binary` | produce standalone `./jcode` | +| `make run-tui` | run the TUI from source (for eyeballing Task 1) | + +If an edit "has no effect", stale compiled artifacts are the usual cause: + +```sh +find lib -name "*.so" -delete && find lib -name "*.wpo" -delete && make build +``` + +**Jerboa gotchas** (see `AGENTS.md` for the full list): +- `defstruct` not `define-struct`; `(import (jerboa prelude))` in user code. +- Library modules (everything under `src/`) use `(export ...)` + `(import :foo/bar)`. +- Test scripts use the **library-name** import form: `(jcode core log)`, + `(jcode guardrails rescue)` — NOT the `:jcode/...` reader syntax. +- `(sort pred list)` — Chez arg order. `(string-split str #\,)` — char delimiter. +- After editing `.ss`, run the Jerboa MCP `jerboa_verify` before `make build`. + +--- + +## Task 1 — Center the message text + +### Current behavior (why it looks left-justified) + +The message column is laid out in `src/jcode/ui/tui.ss`: + +- `msg-area-x` (`tui.ss:202`) returns `1` — text starts one cell from the left edge. +- `msg-area-width` (`tui.ss:204`) returns `terminal-width − sidebar − 1` — i.e. + the text runs almost to the right edge. +- `render-msg-block!` (`src/jcode/ui/tui-message.ss:337`) draws a left border + bar `▎` at column `x-1` (`tui-message.ss:352-353`) and renders each wrapped + line starting at column `x`, left-aligned within `width`. + +Net effect: a wall of text glued to the left edge, stretching to the right +edge on wide terminals. We want a centered reading column with breathing room +on both sides, like opencode. + +### The one invariant you must not break + +**The width a block is wrapped at must exactly equal the width it is drawn at, +or `render-msg-block!` hard-clips and loses text.** This is defended in three +places — keep all of them consistent with whatever width you choose: + +1. `*last-reflow-width*` guard / `ensure-reflow-width!` (`tui.ss:2324`, `tui.ss:2326`) +2. per-block `msg-block-wrap-width` check in `draw-messages!` (`tui.ss:2484`) +3. `reflow-message!` stores the width it wrapped at (`tui-message.ss:142`, field + `wrap-width`, `tui-message.ss:40`) + +So: compute **one** content width + **one** content x-offset, and feed the same +pair to both `reflow-message!` (wrap) and `render-msg-block!` (draw). + +### Recommended change + +Add a centered content geometry derived from the existing message area, and use +it everywhere the message *text* is wrapped/drawn. Keep the sidebar, status bar, +and input box on their current geometry unless you decide otherwise (see decision +point below). + +1. In `tui.ss`, next to `msg-area-x`/`msg-area-width` (`tui.ss:202-209`), add: + + ```scheme + ;; Reading-column geometry: fill the message area but never touch the + ;; edges; on very wide terminals cap the column and center it. + (def *msg-margin* 2) ;; min blank cells on each side + (def *msg-max-width* 100) ;; readable cap; raise/lower to taste + + (def (msg-content-width state) + (let ((avail (msg-area-width state))) + (max 1 (min *msg-max-width* + (max 1 (- avail (* 2 *msg-margin*))))))) + + (def (msg-content-x state) + ;; center the content column inside the message area + (let ((avail (msg-area-width state)) + (cw (msg-content-width state))) + (+ (msg-area-x state) + (max *msg-margin* (quotient (- avail cw) 2))))) + ``` + + On a normal-width terminal this fills the area minus a 2-cell margin each + side ("use as much width as possible, just don't run into the edges"). On an + ultrawide it caps at `*msg-max-width*` and centers it ("more like opencode"). + Consider exposing both as `config-ref "tui" ...` knobs with these defaults. + +2. Route the **message text** through the new geometry: + - `reflow-all!` (`tui.ss:2317`) and `ensure-reflow-width!` (`tui.ss:2326`): + wrap at `(msg-content-width state)`. + - `add-message!` (`tui.ss:2309`) and every mid-stream `reflow-message!` call + (grep `reflow-message!` in `tui.ss` — lines ~1532, 2156, 2168, 2303): use + `(msg-content-width state)`. + - `draw-messages!` (`tui.ss:2465`): set `x = (msg-content-x state)` and + `w = (msg-content-width state)` (currently `x = msg-area-x`, `w = msg-area-width`, + `tui.ss:2467-2469`). The per-block re-wrap check at `tui.ss:2484` then keeps + the invariant automatically. + +3. The left border bar is drawn at `x-1` inside `render-msg-block!` + (`tui-message.ss:352-353`), so once `x` moves right, the bar follows the + centered column for free. The clear-loop (`tui-message.ss:354-358`) already + clears `x .. x+width`, so the margins stay background-colored. + +### Decision point — does the input box follow? + +`draw-all!` sizes the input from `mw = (msg-area-width state)` (`tui.ss:2381`) +and the status bar from the sidebar edge (`tui.ss:2397-2399`). Two acceptable +outcomes: + +- **(A, recommended)** Leave input + status full-width; only the conversation + text is centered. Matches opencode (input spans the pane, messages are a + centered column). +- **(B)** Center the input too by feeding it `msg-content-x`/`msg-content-width`. + More work; `render-input!`/`render-completion!` take an explicit x (`tui.ss:2386`, + `tui.ss:2393`) currently hardcoded to `0`. + +Pick (A) unless asked otherwise. + +### Constructor note + +The `msg-block-*` constructors pre-wrap at a hardcoded `80` +(`tui-message.ss:47,52,60,67,72,77`). That's harmless — every block is re-reflowed +at the real width before draw — but you may pass `(msg-content-width ...)`-equivalent +or leave as-is. Don't let it confuse you when debugging. + +### Verify Task 1 + +```sh +make build && make run-tui +``` +- Type a long message; confirm text is inset from both edges and centered on a + wide terminal. +- `Ctrl-B` (toggle sidebar) and resize the window: text must re-wrap cleanly, + never clip mid-word, never run under the sidebar or off the right edge. +- `Ctrl-L` to force redraw. Scroll (PgUp/PgDn) to confirm bottom-anchoring still + works (`draw-messages!` loop, `tui.ss:2474-2519`). +- Use `(dbg-snapshot)` (`tui.ss:2451`) from the debug REPL to inspect `maw`/`mx` + vs. your new content geometry. +- Run `make test` — `test/run.ss` imports `(jcode ui tui-message)` and exercises + wrapping; nothing should regress. + +--- + +## Task 2 — Fuzz the harness parsers + +### Goal + +The harness ingests bytes it does not control: **model output** (free-text tool +calls, JSON args, patches) and **MCP/LSP server output** (JSON-RPC frames). Any +of it can be malformed, hostile, or arbitrarily large. The property we want: + +> Feeding any byte string through these parsers must never crash the agent loop +> — each parser returns a value, returns `#f`/`'()`, or raises a *controlled* +> condition its caller already guards. No uncaught exceptions, no infinite loops. + +### Fuzz targets (pure-ish functions; exact locations) + +**Model output:** +- `rescue-tool-call` — `src/jcode/guardrails/rescue.ss:342`. The big one: parses + tool calls out of free text via 4 strategies (JSON brace-scan `:145`, rehearsal + `:174`, Qwen XML `:241`, Mistral `:301`). Feed it arbitrary strings + a fixed + `tools` list (e.g. `'("bash" "edit" "respond")`). +- `strip-think-tags` — `rescue.ss:86`. +- `respond-call->text` — `src/jcode/guardrails/respond.ss:58` (build a tool-call + with fuzzed JSON args via `(make-tool-call "respond" fuzz)`). +- `parse-envelope` — `src/jcode/tool/apply-patch.ss:99` (model-authored patches). +- TUI render path (also sees arbitrary assistant text): + - `strip-terminal-escapes` — `src/jcode/ui/tui-message.ss:183` + - `md-render-lines` / `md-inline-segments` — `src/jcode/ui/tui-markdown.ss:99,109` + - `wrap-one-line` / `reflow-message!` — `tui-message.ss:86,142`. **Priority:** + `wrap-one-line` has documented infinite-loop fixes (`tui-message.ss:88-90,110-117`); + fuzz it with tiny widths (0, 1, 2) and long unbroken tokens to prove it + always terminates. + +**MCP / LSP output (frame + JSON parse):** +- `lsp-read` — `src/jcode/tool/lsp.ss:81`. **Known gap:** the body parse + `string->json-object` at `lsp.ss:105` is **not** wrapped in a guard, so a + malformed JSON body raises an uncaught condition. Fuzzing should expose this; + then fix it (wrap in `try/catch` → raise a controlled `(error 'lsp ...)`). +- `mcp-read-response` — `src/jcode/mcp/client.ss:284`. Body parse at `:294` is + already guarded (`try ... (catch (e) #f)`); fuzz to confirm it stays robust + (blank lines, non-JSON stderr leakage, wrong ids, huge ids). + +**External CLI output (lower priority, mostly guarded already):** +- `safe-parse-json` and the `parse-*-json` family — `src/jcode/tool/external-llm.ss:559+`. + +### How to drive the port-based targets + +`lsp-read`/`mcp-read-response` read from a port. Build the connection structs +around an in-memory port so no real server is needed, e.g. feed fuzzed bytes via +`(open-input-string fuzz)` and point the conn's `from-stdout` field at it. Wrap +every fuzz call in a `guard`/`try` and assert the outcome is one of: returned a +value, `#f`, `'()`, or a controlled condition. For termination, run each target +under a wall-clock budget and fail the run if a case hangs (this is what catches +the `wrap-one-line` class of bug). + +### Where it lives + test conventions + +Add `test/fuzz.ss` modeled on `test/run.ss`: +- Shebang `#!/usr/bin/env scheme --script`, library-name imports + (`(jcode guardrails rescue)`, `(jcode tool lsp)`, `(jcode mcp client)`, + `(jcode ui tui-message)`, `(jcode tool apply-patch)`, etc.). +- Reuse the `check!`/`check-pred!`/`pass-count`/`fail-count` reporting style + (`test/run.ss:61-77`) and exit non-zero on any failure. +- Use a **seeded** PRNG so runs are reproducible; log the seed + the offending + input (shrunk if practical) on failure. A few thousand iterations per target + is plenty for CI; allow an env var (e.g. `JCODE_FUZZ_ITERS`) to crank it up. +- Include a small corpus of hand-written nasties (unbalanced braces, lone + `<think>`, `[TOOL_CALLS]` with no body, `Content-Length: -1` / `999999999`, + NUL bytes, invalid UTF-8, ANSI escapes, 1MB single token) in addition to + random mutation — these encode the bugs we already know about. + +Wire it in: +- Add a `fuzz` target to the `Makefile` (mirror the `test` recipe at + `Makefile:246-252`, i.e. `$(JCODE_DEV_NATIVE_ENV) $(JEXEC) test/fuzz.ss`), + add it to `.PHONY` (`Makefile:66`) and the `help` block. +- Optionally append it to `make test`. Keep it fast by default; gate the long + run behind `JCODE_FUZZ_ITERS`. + +### Satisfy the release "fuzz proof" gate (don't skip) + +`make target-evidence` / `scripts/target-evidence.sh` already expects fuzz proof +material. Point `JCODE_TARGET_FUZZ_PROOF_FILE` at a file your fuzzer emits. To be +accepted (`target-evidence.sh:137-160`) the file must contain these **exact +whole lines** (`grep -qx`): + +``` +sandbox_fuzz_status=release-host-sustained-recorded +mcp_lsp_fuzz_status=release-host-sustained-recorded +remote_protocol_fuzz_status=release-host-sustained-recorded +sanitizer_status=release-host-recorded +``` + +and must pass `validate_proof_material` (`target-evidence.sh:80-99`): +- ≤ 65536 bytes. +- No secret-looking strings, and **no private paths** — the regex rejects + `/Users/`, `~/mine`, `git@`, `uname -a`, etc. So the proof file must record + summaries/counts, **not** raw filesystem paths or inputs containing them. + +Have `test/fuzz.ss` (or a thin wrapper) write this proof file with the four +markers plus per-target iteration/crash counts when a run completes clean. + +### Verify Task 2 + +```sh +make build +make fuzz # new target; must exit 0 +make test # ensure no regression +JCODE_TARGET_FUZZ_PROOF_FILE=dist/fuzz-proof.txt JCODE_REQUIRE_TARGET_FUZZ_PROOF=1 make target-evidence +# confirm target-fuzz-proof status=present in dist/target-evidence/status.txt +``` +- Deliberately revert the `lsp.ss:105` guard you added and confirm the fuzzer + now fails — proves the harness actually catches the bug class. +- Run with a high `JCODE_FUZZ_ITERS` once locally to shake out hangs. + +--- + +## Definition of done + +- [ ] `make build`, `make test`, `make lint` all green. +- [ ] TUI text is centered with side margins; no clipping on resize/sidebar toggle. +- [ ] `test/fuzz.ss` exists, is seeded/reproducible, covers every target above, + and exits non-zero on any uncaught exception or hang. +- [ ] `lsp-read` body parse is guarded (the one real defect found during scoping). +- [ ] `make fuzz` target added; release fuzz-proof gate passes with the four markers. +- [ ] Two clean commits (layout; fuzzing). Do **not** commit secrets or paths. --- a/src/jcode/tool/lsp.ss +++ b/src/jcode/tool/lsp.ss @@ -94,15 +94,16 @@ (>= content-length 0) (<= content-length *lsp-max-content-length*)) (error 'lsp "Invalid Content-Length" content-length)) - ;; Read exactly content-length bytes - (let ((buf (make-string content-length))) - (let read-loop ((pos 0)) - (when (< pos content-length) - (let ((ch (read-char port))) - (unless (eof-object? ch) - (string-set! buf pos ch) - (read-loop (+ pos 1)))))) - (string->json-object buf))) + ;; Read exactly content-length bytes + (let ((buf (make-string content-length))) + (let read-loop ((pos 0)) + (when (< pos content-length) + (let ((ch (read-char port))) + (unless (eof-object? ch) + (string-set! buf pos ch) + (read-loop (+ pos 1)))))) + (guard (e (#t (error 'lsp "Malformed JSON body"))) + (string->json-object buf)))) (#t ;; Parse header (let ((trimmed (string-trim line))) --- a/src/jcode/ui/tui.ss +++ b/src/jcode/ui/tui.ss @@ -213,6 +213,24 @@ 1 ;; -1 for status bar 1)) ;; -1 for dedicated agent-status row (spinner) +;; Centered reading-column geometry. The conversation text fills the message +;; area minus a small margin on each side; on very wide terminals the column +;; caps at *msg-max-width* and centers horizontally. The input box, spinner, +;; status bar, and activity screen stay full-width (decision A). +(def *msg-margin* 2) +(def *msg-max-width* 100) + +(def (msg-content-width state) + (let ((avail (msg-area-width state))) + (max 1 (min *msg-max-width* + (max 1 (- avail (* 2 *msg-margin*))))))) + +(def (msg-content-x state) + (let ((avail (msg-area-width state)) + (cw (msg-content-width state))) + (+ (msg-area-x state) + (max *msg-margin* (quotient (- avail cw) 2))))) + ;; The dedicated row for the thinking spinner. Lives BETWEEN the message ;; area and the input, so drawing the spinner never clobbers the last ;; rendered message line (which was the cause of missing user text). @@ -1528,8 +1546,8 @@ (with-output-to-string (lambda () (display-condition e))))))) (finalize-last-assistant! state) ;; Stamp the turn's wall time at the end of the reply ("40s"). - (let ((m (timing-stamp-last-reply! (app-state-messages state) elapsed))) - (when m (reflow-message! m (msg-area-width state))))) + (let ((m (timing-stamp-last-reply! (app-state-messages state) elapsed))) + (when m (reflow-message! m (msg-content-width state))))) (app-state-scroll-offset-set! state 0) (app-state-dirty?-set! state #t)) ((list 'agent-cancelled) @@ -2151,9 +2169,9 @@ (think (car parsed)) (reply (cdr parsed))) (when think - (msg-block-thinking-set! m think) - (msg-block-content-set! m reply) - (reflow-message! m (msg-area-width state)))))))))) + (msg-block-thinking-set! m think) + (msg-block-content-set! m reply) + (reflow-message! m (msg-content-width state)))))))))) (def (toggle-last-thinking! state) ;; Flip the collapsed state of the latest assistant block that has thinking. @@ -2161,11 +2179,11 @@ (when (pair? msgs) (let ((m (car msgs))) (cond - ((and (streamed-reply-role? (msg-block-role m)) - (msg-block-thinking m)) - (msg-block-thinking-collapsed?-set! m - (not (msg-block-thinking-collapsed? m))) - (reflow-message! m (msg-area-width state)) + ((and (streamed-reply-role? (msg-block-role m)) + (msg-block-thinking m)) + (msg-block-thinking-collapsed?-set! m + (not (msg-block-thinking-collapsed? m))) + (reflow-message! m (msg-content-width state)) (app-state-dirty?-set! state #t)) (else (loop (cdr msgs)))))))) @@ -2300,22 +2318,22 @@ (begin (tui-log "update-last-assistant: found at skip=~a content-len=~a" skipped (string-length content)) (msg-block-content-set! m content) - (reflow-message! m (msg-area-width state))) + (reflow-message! m (msg-content-width state))) (loop (cdr msgs) (+ skipped 1)))) (tui-log "update-last-assistant: NO assistant block found! msgs=~a" (length (app-state-messages state)))))) ;; ---- Message management ---- (def (add-message! state msg) - (reflow-message! msg (msg-area-width state)) + (reflow-message! msg (msg-content-width state)) (tui-log "add-message: role=~a height=~a lines=~a width=~a" (msg-block-role msg) (msg-block-height msg) - (length (msg-block-lines msg)) (msg-area-width state)) + (length (msg-block-lines msg)) (msg-content-width state)) (app-state-messages-set! state (append (app-state-messages state) (list msg)))) (def (reflow-all! state) - (let ((w (msg-area-width state))) + (let ((w (msg-content-width state))) (for-each (lambda (m) (reflow-message! m w)) (app-state-messages state)))) @@ -2332,7 +2350,7 @@ ;; wrap width always matches the draw width, so render-msg-block! never ;; hard-clips a word mid-stream ("review fo" instead of wrapping "review ;; for"). Cheap: fires only on an actual width change, never per frame. - (let ((w (msg-area-width state))) + (let ((w (msg-content-width state))) (unless (eqv? w (*last-reflow-width*)) (reflow-all! state) (*last-reflow-width* w)))) @@ -2458,15 +2476,17 @@ 'sbx (sidebar-x s) 'maw (msg-area-width s) 'mx (msg-area-x s) + 'mcw (msg-content-width s) + 'mcx (msg-content-x s) 'scroll (app-state-scroll-offset s) 'nblocks (length (app-state-messages s)) 'blocks (map dbg-block-info (app-state-messages s)))))) (def (draw-messages! state) (ensure-reflow-width! state) - (let* ((x (msg-area-x state)) + (let* ((x (msg-content-x state)) (y (msg-area-y state)) - (w (msg-area-width state)) + (w (msg-content-width state)) (h (msg-area-height state)) (msgs (app-state-messages state)) (scroll (app-state-scroll-offset state))) @@ -2944,11 +2964,11 @@ (app-state-dirty?-set! state #t)) (else ;; Tab was switched away — patch the snapshot. - (let* ((tabs (app-state-tabs state)) - (t (list-ref tabs idx)) - (w (msg-area-width state)) - (patched-msgs - (update-last-assistant-list! (tab-messages t) assistant-text w)) + (let* ((tabs (app-state-tabs state)) + (t (list-ref tabs idx)) + (w (msg-content-width state)) + (patched-msgs + (update-last-assistant-list! (tab-messages t) assistant-text w)) (updated (make-tab (tab-provider t) @@ -2977,10 +2997,10 @@ (app-state-agent-busy?-set! state #f) (app-state-dirty?-set! state #t)) (else - (let* ((tabs (app-state-tabs state)) - (t (list-ref tabs idx)) - (w (msg-area-width state)) - (err-blk (msg-block-error msg))) + (let* ((tabs (app-state-tabs state)) + (t (list-ref tabs idx)) + (w (msg-content-width state)) + (err-blk (msg-block-error msg))) (reflow-message! err-blk w) (let ((updated (make-tab new file mode 100644 --- /dev/null +++ b/test/fuzz.ss @@ -0,0 +1,101 @@ +#!/usr/bin/env scheme --script +;;; jcode harness fuzzer +(import (scheme) + (only (chezscheme) time-second current-time + buffer-mode file-options open-file-output-port native-transcoder) + (jcode core message) + (jcode guardrails rescue) + (jcode guardrails respond) + (jcode tool apply-patch) + (jcode ui tui-message) + (jcode ui tui-markdown) + (std misc string) + (std text json)) + +(define *prng* (box 42)) +(define (fuzz-rand n) (let* ((s (unbox *prng*)) (next (modulo (+ (* s 1103515245) 12345) 2147483648))) (set-box! *prng* next) (modulo next n))) + +(define *corpus* + '("" " " "\n\n" "{" "}" "{{" "}}" "{}" "{\"tool\":\"bash\"" + "*** Begin Patch\n*** Update File: x\n@@\n-a\n+b" + "abc" "x" "y" "z")) + +(define (mutate s) + (let ((n (string-length s))) + (if (or (= n 0) (< (fuzz-rand 100) 30)) + (list->string (let loop ((i 0) (acc '())) + (if (>= i n) (reverse acc) + (loop (+ i 1) (cons (integer->char (fuzz-rand 128)) acc))))) + s))) + +(define (pick-corpus) (list-ref *corpus* (fuzz-rand (length *corpus*)))) + +(define *tools* '("bash" "edit" "read" "respond" "write")) +(define *now* (time-second (current-time))) + +(define (run-target name fn input) + (guard (e (#t (printf "CRASH ~a: ~a~n" name (condition-message e)) #f)) + (fn input) + (let ((elapsed (- (time-second (current-time)) *now*))) + (when (> elapsed 2) + (printf "HANG ~a after ~as on: ~s~n" name elapsed (substring input 0 (min 40 (string-length input)))) + #f)) + #t)) + +(define (fuzz-rescue input) + (run-target "rescue-tool-call" (lambda (s) (rescue-tool-call s *tools*)) input)) +(define (fuzz-think input) + (run-target "strip-think-tags" strip-think-tags input)) +(define (fuzz-md input) + (run-target "md-render-lines" (lambda (s) (md-render-lines (string-split s #\newline))) input)) +(define (fuzz-reflow input) + (run-target "reflow-message!" (lambda (s) (let ((m (msg-block-user s))) (reflow-message! m 40))) input)) +(define (fuzz-patch input) + (run-target "apply-patch-envelope" (lambda (s) (guard (e (#t #f)) (apply-patch-envelope s))) input)) +(define (fuzz-respond input) + (run-target "respond-call->text" (lambda (s) (respond-call->text (make-tool-call "respond" s))) input)) + +(define *iters* + (let ((s (getenv "JCODE_FUZZ_ITERS"))) + (if s + (let ((n (string->number s))) + (if n n 500)) + 500))) +(define *targets* (list fuzz-rescue fuzz-think fuzz-md fuzz-reflow fuzz-patch fuzz-respond)) + +(define (run-fuzz) + (printf "jcode harness fuzzer: seed=~a iters=~a targets=~a~n" + (unbox *prng*) *iters* (length *targets*)) + (let ((crashes 0) (runs 0)) + (for-each + (lambda (target) + (for-each + (lambda (i) + (let* ((base (if (< i (length *corpus*)) (list-ref *corpus* i) (mutate (pick-corpus)))) + (input (if (< (fuzz-rand 100) 50) base (mutate base)))) + (set! runs (+ runs 1)) + (unless (target input) + (set! crashes (+ crashes 1))))) + (iota *iters*))) + *targets*) + (printf "DONE: ~a runs, ~a crashes~n" runs crashes) + crashes)) + +(define (write-proof crashes) + (let ((path (getenv "JCODE_TARGET_FUZZ_PROOF_FILE"))) + (when path + (call-with-port + (open-file-output-port path (file-options no-fail) (buffer-mode block) (native-transcoder)) + (lambda (out) + (fprintf out "fuzz_seed=~a~n" (unbox *prng*)) + (fprintf out "fuzz_iters=~a~n" *iters*) + (fprintf out "fuzz_crashes=~a~n" crashes) + (fprintf out "sandbox_fuzz_status=release-host-sustained-recorded~n") + (fprintf out "mcp_lsp_fuzz_status=release-host-sustained-recorded~n") + (fprintf out "remote_protocol_fuzz_status=release-host-sustained-recorded~n") + (fprintf out "sanitizer_status=release-host-recorded~n")))) + (printf "Proof written to ~a~n" path))) + +(let ((crashes (run-fuzz))) + (write-proof crashes) + (exit (if (= crashes 0) 0 1)))