Harden MCP process execution
ober
477c66a099efe790af4fd792ca51902d4ac1a71d
--- a/data/cookbooks.sexp +++ b/data/cookbooks.sexp @@ -5987,4 +5987,27 @@ "length-prefix" "deserialize" "security") ("title" . - "Bounds-check length-prefixed bytevector parsers"))) + "Bounds-check length-prefixed bytevector parsers")) + (("code" + . + ";; Recommended layout for converted legacy library sources:\n;;\n;; jerboa-src/src/jsh/foo.ss ; canonical Jerboa source\n;; src/jsh/foo.sls ; generated R6RS library output\n;;\n;; Build rule:\n;; jerbuild exec --libdirs \"$JERBOA_HOME/lib\" support/jerbuild.ss jerboa-src/src src --force\n;;\n;; Source file:\n;;; jerbuild-library: (jsh foo)\n(export foo)\n(import (chezscheme))\n(define (foo) 'ok)") ("id" . "jerbuild-separate-source-output-roots") + ("imports") + ("notes" + . + "Do not put flat Jerboa .ss source files directly under directories passed as Chez/Jerboa libdirs when those files contain top-level (export ...) and (import ...) forms. Chez library search may prefer or inspect .ss source files in the libdir and fail with errors such as 'export form outside module' before the generated .sls is used. Keep canonical .ss in a source-only tree and generate .sls into the runtime libdir/output tree.") + ("tags" "jerbuild" "source-layout" "generated-sls" "libdirs" + "chez" "ss") + ("title" + . + "Keep Jerboa source roots separate from generated library output roots")) + (("code" + . + "(define (definition-form? form)\n ;; Add project macros that expand to top-level definitions here.\n (and (pair? form)\n (memq (car form)\n '(define define-syntax define-values\n define-jsh-foreign))))\n\n(define (collect-definition-name form)\n (and (pair? form)\n (pair? (cdr form))\n (case (car form)\n [(define define-jsh-foreign)\n (let ([name (cadr form)])\n (if (pair? name) (car name) name))]\n [(define-syntax) (cadr form)]\n [else #f])))\n\n(define (reorder-body-forms forms)\n (let loop ([forms forms] [defs '()] [exprs '()])\n (cond\n [(null? forms) (append (reverse defs) (reverse exprs))]\n [(definition-form? (car forms))\n (loop (cdr forms) (cons (car forms) defs) exprs)]\n [else\n (loop (cdr forms) defs (cons (car forms) exprs))])))") ("id" . "jerbuild-macro-definition-reorder") ("imports") + ("notes" + . + "If jerbuild partitions a library body into definitions followed by expressions, top-level macros that expand to definitions must be treated as definitions by the partitioner and by any definition collectors. Otherwise expressions can be moved ahead of macro-generated bindings, producing runtime or compile-time undefined variable errors. This showed up with a define-jsh-foreign macro used before constants called the generated FFI binding.") + ("tags" "jerbuild" "macro" "definition" "reorder" "ffi" + "r6rs") + ("title" + . + "Classify top-level definition macros before reordering library bodies"))) --- a/data/features.sexp +++ b/data/features.sexp @@ -2514,4 +2514,44 @@ ("use_case" . "Reviewing Scheme FFI code that safely allocates temporary C memory for out-parameters or buffers.") + ("votes" . 0)) + (("description" + . + "Add a project audit tool that reports tracked non-vendor .sls files, .ss source files placed inside active libdir/output roots, and source files with top-level (library ...) forms. This would directly support Jerboa repos migrating legacy Chez/R6RS libraries to canonical .ss sources while keeping generated .sls out of git.") + ("estimated_token_reduction" + . + "~500-1000 tokens per migration audit") + ("example_scenario" + . + "A jerboa-shell migration needs to verify that no non-vendor .sls files remain tracked, no .ss files sit under src/lib/vault-stage libdirs, and no user-facing .ss still contains a top-level (library ...) form.") + ("id" . "generated-sls-source-layout-audit") + ("impact" . "medium") + ("tags" "audit" "jerbuild" "generated-sls" "git" + "source-layout") + ("title" + . + "Audit tracked generated .sls files against canonical .ss source layout") + ("use_case" + . + "Before or after converting a repo from tracked .sls files to Jerboa .ss files, run one tool to verify the layout invariants instead of combining git ls-files, find, and rg commands.") + ("votes" . 0)) + (("description" + . + "When jerboa_verify fails while expanding or checking a script-style .ss file, include the failing top-level form and source location where possible. Avoid opaque internal errors such as 'Exception in cadr: incorrect list structure (defstruct)' without a file line or surrounding form.") + ("estimated_token_reduction" + . + "~300-800 tokens per failed verification") + ("example_scenario" + . + "A support/jerbuild.ss verification returned 'cadr: incorrect list structure (defstruct)' with no source location, so the actual validation had to be done through make compile instead of the MCP verifier.") + ("id" . "verify-script-expansion-source-locations") + ("impact" . "medium") + ("tags" "verify" "diagnostics" "source-location" "script" + "expansion") + ("title" + . + "Improve jerboa_verify diagnostics for script expansion failures") + ("use_case" + . + "Use jerboa_verify on build scripts and helper transpilers, then fix syntax or macro issues without falling back to Makefile execution or manual bisection.") ("votes" . 0))) --- a/lib/std/misc/process.ss +++ b/lib/std/misc/process.ss @@ -26,6 +26,100 @@ (import (chezscheme) (only (jerboa core) def defstruct try catch finally)) + (def (with-process-mutex mutex thunk) + (dynamic-wind + (lambda () (mutex-acquire mutex)) + thunk + (lambda () (mutex-release mutex)))) + + (def (timeout-ms->duration ms) + (make-time 'time-duration + (* (mod ms 1000) 1000000) + (div ms 1000))) + + (def (current-monotonic-ms) + (let ([t (current-time 'time-monotonic)]) + (+ (* (time-second t) 1000) + (div (time-nanosecond t) 1000000)))) + + (def (positive-timeout-ms? x) + (and (integer? x) (> x 0))) + + (def (safe-close-port port) + (try (close-port port) (catch (e) #f))) + + (def (drain-all port) + (let lp () + (let ([buf (get-string-n port 4096)]) + (unless (eof-object? buf) + (lp))))) + + (def (run-process-command full-cmd stdin-data timeout-ms) + (let-values ([(to-stdin from-stdout from-stderr pid) + (open-process-ports full-cmd 'line (native-transcoder))]) + (let ([stdout ""] + [stdout-done? #f] + [stderr-done? #f] + [mutex (make-mutex)] + [done-cond (make-condition)]) + (def (mark-stdout! value) + (with-process-mutex mutex + (lambda () + (set! stdout value) + (set! stdout-done? #t) + (condition-broadcast done-cond)))) + (def (mark-stderr!) + (with-process-mutex mutex + (lambda () + (set! stderr-done? #t) + (condition-broadcast done-cond)))) + (fork-thread + (lambda () + (mark-stdout! + (guard (e [else ""]) + (read-all from-stdout))))) + (fork-thread + (lambda () + (guard (e [else #f]) + (drain-all from-stderr)) + (mark-stderr!))) + (guard (e [else #f]) + (when stdin-data + (display stdin-data to-stdin) + (flush-output-port to-stdin))) + (safe-close-port to-stdin) + (let ([completed? + (with-process-mutex mutex + (lambda () + (if (positive-timeout-ms? timeout-ms) + (let ([deadline (+ (current-monotonic-ms) timeout-ms)]) + (let loop () + (cond + [(and stdout-done? stderr-done?) #t] + [else + (let ([remaining (- deadline (current-monotonic-ms))]) + (if (<= remaining 0) + #f + (begin + (condition-wait done-cond mutex + (timeout-ms->duration (min remaining 50))) + (loop))))]))) + (let loop () + (if (and stdout-done? stderr-done?) + #t + (begin + (condition-wait done-cond mutex) + (loop)))))))]) + (if completed? + stdout + (begin + (guard (e [else #f]) (process-kill pid 15)) + (safe-close-port from-stdout) + (safe-close-port from-stderr) + (error 'run-process + (format "process timed out after ~a ms" timeout-ms) + full-cmd))))))) + (def (run-process args . rest) ;; Run a process and return its stdout as a string. ;; args: list of strings (command and arguments) @@ -35,16 +129,11 @@ (let* ((cmd (build-command-string args)) (show-console (extract-keyword rest 'show-console: #f)) (dir (extract-keyword rest 'directory: #f)) + (timeout-ms (extract-keyword rest 'timeout-ms: #f)) (full-cmd (if dir (string-append "cd " (shell-quote dir) " && " cmd) cmd))) - (let-values (((to-stdin from-stdout from-stderr pid) - (open-process-ports full-cmd 'line (native-transcoder)))) - (close-port to-stdin) - (let ((output (read-all from-stdout))) - (close-port from-stdout) - (close-port from-stderr) - output)))) + (run-process-command full-cmd #f timeout-ms))) (def (run-process/batch args . rest) ;; Run a process and return exit status (0 = success) @@ -65,21 +154,13 @@ (error 'run-process/exec "args must be a non-empty list of strings" args)) (let* ([dir (extract-keyword rest 'directory: #f)] [stdin-data (extract-keyword rest 'stdin-data: #f)] + [timeout-ms (extract-keyword rest 'timeout-ms: #f)] ;; Each argument is individually quoted — no shell expansion [cmd (string-join (map strict-shell-quote args) " ")] [full-cmd (if dir (string-append "cd " (strict-shell-quote dir) " && " cmd) cmd)]) - (let-values ([(to-stdin from-stdout from-stderr pid) - (open-process-ports full-cmd 'line (native-transcoder))]) - (when stdin-data - (display stdin-data to-stdin) - (flush-output-port to-stdin)) - (close-port to-stdin) - (let ([output (read-all from-stdout)]) - (close-port from-stdout) - (close-port from-stderr) - output)))) + (run-process-command full-cmd stdin-data timeout-ms))) (def (strict-shell-quote s) ;; Strictly quote a string for shell: wrap in single quotes, --- a/mcp/server.ss +++ b/mcp/server.ss @@ -60,6 +60,23 @@ (def (truthy? x) (if x #t #f)) +(def (positive-integer? x) + (and (integer? x) (> x 0))) + +(def (tool-timeout-ms args default) + (let ([v (hash-get* args "timeout_ms" default)]) + (if (positive-integer? v) v default))) + +(def (tool-limit args default) + (let ([v (hash-get* args "limit" default)]) + (if (positive-integer? v) v default))) + +(def (take-n xs n) + (let loop ([rest xs] [i n] [out '()]) + (cond + [(or (null? rest) (<= i 0)) (reverse out)] + [else (loop (cdr rest) (- i 1) (cons (car rest) out))]))) + (def (env name default) (def v (getenv name)) (if (and v (> (string-length v) 0)) v default)) @@ -540,7 +557,7 @@ (project-libdirs project home) (source-extra-libdirs file))))) -(def (run-jerboa-script code home (extra-libdirs '())) +(def (run-jerboa-script code home (extra-libdirs '()) (timeout-ms 30000)) (def tmp (tmp-script-name)) (let* ([cmd (list (scheme-path) "--libdirs" (effective-libdirs home extra-libdirs) @@ -549,7 +566,7 @@ (begin (write-file-string tmp code) (guard (e [else (string-append error-marker "\n" (error-message e))]) - (run-process cmd)))]) + (run-process cmd 'timeout-ms: timeout-ms)))]) (when (file-exists? tmp) (delete-file tmp)) (if (script-output-has-marker? output) output @@ -1201,9 +1218,11 @@ (text-result "code is required." #t) (let* ([imports (hash-get* args "imports" '())] [home (hash-get* args "jerboa_home" #f)] + [timeout-ms (tool-timeout-ms args 15000)] [out (run-jerboa-script (build-syntax-script (strip-shebang code) imports) home - (tool-extra-libdirs args #f home))]) + (tool-extra-libdirs args #f home) + timeout-ms)]) (cond [(index-of out valid-marker) (text-result "Syntax is valid.")] [(index-of out error-marker) @@ -4335,10 +4354,21 @@ "## Summary\n" summary)))))))) +(def (write-file-string/atomic path content) + (let ([tmp (string-append path ".tmp." (number->string (random-integer 1000000000)))]) + (guard (e [else + (when (file-exists? tmp) + (guard (e2 [else #f]) (delete-file tmp))) + (raise e)]) + (write-file-string tmp content) + (rename-file tmp path)))) + (def (write-json-file path obj) - (if (string-suffix? ".sexp" path) - (write-file-string path (pp-to-string (data->sexp obj))) - (write-file-string path (string-append (json-object->string obj) "\n")))) + (write-file-string/atomic + path + (if (string-suffix? ".sexp" path) + (pp-to-string (data->sexp obj)) + (string-append (json-object->string obj) "\n")))) (def (entry-id entry) (hash-get* entry "id" "")) @@ -4401,30 +4431,46 @@ (string-append "Output:\n```\n" (string-trim out) "\n```") "(no output)")))))]))) -(def (verify-recipe recipe home) +(def (verify-recipe recipe home timeout-ms) (let* ([imports (hash-get* recipe "imports" '())] [code (hash-get* recipe "code" "")] - [result (tool-check-syntax (jhash "code" code "imports" imports "jerboa_home" home))]) + [result (tool-check-syntax (jhash "code" code "imports" imports "jerboa_home" home "timeout_ms" timeout-ms))]) (if (hash-ref result "isError") (string-append " FAIL " (entry-id recipe) ": " (car (string-split (result-text result) #\newline))) (string-append " PASS " (entry-id recipe))))) (def (tool-howto-verify args) (let* ([path (hash-get* args "cookbook_path" #f)] - [id (hash-get* args "recipe_id" #f)] + [id (hash-get* args "recipe_id" (hash-get* args "id" #f))] + [all? (truthy? (hash-get* args "all" #f))] + [limit (tool-limit args 50)] + [timeout-ms (tool-timeout-ms args 15000)] [home (hash-get* args "jerboa_home" #f)] [recipes0 (load-recipes-for-tool path)] - [recipes (if id (filter (lambda (r) (string=? (entry-id r) id)) recipes0) recipes0)]) + [recipes (cond + [id (filter (lambda (r) (string=? (entry-id r) id)) recipes0)] + [all? (take-n recipes0 limit)] + [else '()])]) (cond + [(and (not id) (not all?)) + (text-result "recipe_id (or id) is required. Pass all: true with optional limit to verify multiple recipes." #t)] [(and id (null? recipes)) (text-result (string-append "Recipe \"" id "\" not found.") #t)] [(null? recipes) (text-result "No recipes to verify.")] [else - (let* ([lines (map (lambda (r) (verify-recipe r home)) recipes)] + (let* ([lines (map (lambda (r) (verify-recipe r home timeout-ms)) recipes)] [failures (filter (lambda (line) (string-prefix? " FAIL" line)) lines)] - [passed (- (length lines) (length failures))]) + [passed (- (length lines) (length failures))] + [truncated? (and all? (> (length recipes0) (length recipes)))]) (text-result (string-append "Recipe verification: " (number->string passed) "/" (number->string (length lines)) " passed\n\n" - (string-join lines "\n")) + (string-join lines "\n") + (if truncated? + (string-append "\n\nVerified first " + (number->string (length recipes)) + " of " + (number->string (length recipes0)) + " recipes. Increase limit or pass recipe_id/id for a specific recipe.") + "")) (not (null? failures))))]))) (def (error-fix-entry-matches? entry message) @@ -6862,7 +6908,8 @@ (list "imports" (property "array" "Module imports")) (list "project_path" (property "string" "Project path for local libdirs")) (list "extra_libdirs" (property "array" "Additional Scheme libdirs")) - (list "jerboa_home" (property "string" "Jerboa home"))) + (list "jerboa_home" (property "string" "Jerboa home")) + (list "timeout_ms" (property "number" "Per-check timeout in milliseconds"))) '("code")) tool-check-syntax #t '()) (register-tool "jerboa_compile_check" "Compile-Check Jerboa File" @@ -7324,6 +7371,10 @@ (register-tool "jerboa_howto_verify" "Howto Verify" "Syntax-check cookbook recipes." (schema (list (list "recipe_id" (property "string" "Recipe id")) + (list "id" (property "string" "Recipe id alias")) + (list "all" (property "boolean" "Verify multiple recipes explicitly")) + (list "limit" (property "number" "Maximum recipes to verify when all is true")) + (list "timeout_ms" (property "number" "Per-recipe timeout in milliseconds")) (list "cookbook_path" (property "string" "Cookbook path")) (list "jerboa_home" (property "string" "Jerboa home"))) '()) --- a/mcp/test/protocol-test.ss +++ b/mcp/test/protocol-test.ss @@ -310,7 +310,7 @@ (call-tool 43 "jerboa_howto_verify" (alist->hash-table (list (cons "cookbook_path" cookbook-file) - (cons "recipe_id" "tmp-recipe")))) + (cons "id" "tmp-recipe")))) (call-tool 44 "jerboa_howto_run" (alist->hash-table (list (cons "cookbook_path" cookbook-file) @@ -589,11 +589,19 @@ (alist->hash-table (list (cons "query" "list features suggest feature vote feature") (cons "max_results" 8))))))) - (call-tool 116 "jerboa_eval" + (call-tool 116 "jerboa_howto_verify" + (alist->hash-table + (list (cons "cookbook_path" cookbook-file)))) + (call-tool 117 "jerboa_howto_verify" + (alist->hash-table + (list (cons "cookbook_path" cookbook-file) + (cons "all" #t) + (cons "limit" 1)))) + (call-tool 118 "jerboa_eval" (alist->hash-table (list (cons "expression" "(exit 0)"))))))) -(check "expected 116 responses" (= (length responses) 116)) +(check "expected 118 responses" (= (length responses) 118)) (def init-result (result (car responses))) (check "initialize server name" @@ -963,8 +971,16 @@ (string-contains (content-text (result (list-ref responses 114))) "suggest_feature") (string-contains (content-text (result (list-ref responses 114))) "vote_feature"))) +(check "howto verify requires explicit id or all" + (and (hash-ref (result (list-ref responses 115)) "isError") + (string-contains (content-text (result (list-ref responses 115))) "recipe_id (or id) is required"))) + +(check "howto verify all is bounded by limit" + (and (not (hash-ref (result (list-ref responses 116)) "isError")) + (string-contains (content-text (result (list-ref responses 116))) "1/1 passed"))) + (check "markerless eval reports command detail" - (string-contains (content-text (result (list-ref responses 115))) "Command detail")) + (string-contains (content-text (result (list-ref responses 117))) "Command detail")) (display "protocol-test: PASS") (newline) --- a/tests/test-process-exec.ss +++ b/tests/test-process-exec.ss @@ -42,6 +42,19 @@ ;; Stdin data piping (check (run-process/exec '("cat") 'stdin-data: "piped\n") => "piped\n") +;; Stderr is drained so a noisy child cannot block while stdout is read. +(check (run-process + '("sh" "-c" "i=0; while [ $i -lt 20000 ]; do echo err >&2; i=$((i+1)); done; printf ok")) + => "ok") + +;; Timeout kills a child instead of blocking forever. +(check (guard (e [#t 'timeout]) + (run-process '("sh" "-c" "sleep 2; echo late") 'timeout-ms: 250)) + => 'timeout) +(check (guard (e [#t 'timeout]) + (run-process/exec '("sh" "-c" "sleep 2; echo late") 'timeout-ms: 250)) + => 'timeout) + ;; Rejects string args (must be list) (check (guard (e [#t 'error]) (run-process/exec "echo hi")) => 'error)