Harden jmcp subprocess timeouts
ober
6a599be60f303df8a0d8ace65030787580b86fc6
--- a/data/cookbooks.sexp +++ b/data/cookbooks.sexp @@ -6161,4 +6161,45 @@ "escape-sequences" "overlay") ("title" . - "Keep a mux status bar persistent below a PTY pane"))) + "Keep a mux status bar persistent below a PTY pane")) + (("code" + . + "(import (jerboa prelude))\n\n(def (pane-rows-for-client rows)\n (max 1 (- (if (<= rows 0) 24 rows) 1)))\n\n(def (resize-pane-to-client! pane client)\n (when (and (pane-alive? pane))\n (let* ([cols (let ([c (client-cols client)])\n (if (<= c 0) 80 c))]\n [rows (pane-rows-for-client (client-rows client))])\n (unless (and (= (pane-cols pane) cols)\n (= (pane-rows pane) rows))\n (pty-set-size! (pane-fd pane) cols rows)\n (pane-cols-set! pane cols)\n (pane-rows-set! pane rows)\n (vt-resize! (pane-vt pane) cols rows)))))\n\n(def (redraw-client! pane client render send force-repaint!)\n (resize-pane-to-client! pane client)\n (send (render pane (client-cols client) (client-rows client)))\n (force-repaint! pane))") ("id" . "mux-resize-pane-before-redraw") + ("imports" "(jerboa prelude)") + ("notes" + . + "If a mux session has several windows, an initial client resize only updates the pane active at that moment. Older inactive panes can keep their original 80x24 PTY size, so full-screen apps like top render in a small area after the user switches to that window. Before any redraw caused by select-window, next-window, last-window, next-pane, or explicit redraw, first resize the newly active pane to the current client size, update the VT dimensions, then render and force a repaint/SIGWINCH. Keep the pane rows at client rows minus one when reserving a persistent status bar.") + ("tags" "mux" "pty" "resize" "redraw" "reattach" + "window-switch") + ("title" + . + "Resize a mux pane before redraw after window selection")) + (("code" + . + ";; Pattern used by jmcp subprocess tools:\n;; 1. Build the user command with shell-quote for every argv element.\n;; 2. Run it through a temp /bin/sh wrapper that redirects child stdout/stderr\n;; to temp files and redirects the wrapper's own stdout/stderr to a wrapper log.\n;; 3. Start the child in the background, start a watcher sleep, and on timeout\n;; write a stable marker such as JERBOA-MCP-TIMEOUT to the captured stderr.\n;; 4. Recursively terminate visible children before killing the root child.\n;; 5. Return timeout text through the MCP tool result, not raw process stderr.\n\n(def timeout-marker \"JERBOA-MCP-TIMEOUT:\")\n\n(def (timeout-ms->seconds ms)\n (max 1 (quotient (+ ms 999) 1000)))\n\n(def (join-output stdout stderr)\n (cond\n [(= (string-length stdout) 0) stderr]\n [(= (string-length stderr) 0) stdout]\n [else (string-append stdout \"\\n\" stderr)]))\n\n;; In the generated shell wrapper, redirect child output to files and run:\n;; child=$!\n;; (sleep SECONDS; if kill -0 \"$child\"; then ... terminate tree ...; fi) &\n;; Then wait for child, kill the watcher, read temp files, and delete them.") ("id" . "jmcp-subprocess-timeout-wrapper") + ("imports" + "(jerboa prelude)" + "(std os shell)" + "(std security taint)") + ("notes" + . + "Do not let the wrapper shell inherit MCP stderr; killed background jobs can print `Terminated` outside JSON-RPC. Redirect wrapper stdout/stderr to a temp log. Script-based tools should convert timeout-marker output into an MCP isError result. Command-style tools such as make/test runners should classify timeout-marker output as failure. Use marker-prefixed payloads for successful introspection output so runner diagnostics cannot be mistaken for tool data.") + ("tags" "jmcp" "mcp" "timeout" "subprocess" "json-rpc" + "process-tree") + ("title" + . + "Bound jmcp subprocess tools with a JSON-safe timeout wrapper")) + (("code" + . + "(def (try-load-native path)\n ;; Avoid `(catch (e) #f)` in current Jerboa: return sentinel symbols.\n (eq? (try (begin (load-shared-object path) 'loaded)\n (catch (e) 'failed))\n 'loaded))\n\n(def (read-buffered c-read who stmt col initial-size)\n (let ([buf (make-bytevector initial-size)]\n [len-box (make-bytevector 8 0)])\n (let ([rc (c-read stmt col buf initial-size len-box)])\n (when (< rc 0) (error who \"read failed\" col))\n (let ([len (bytevector-u64-native-ref len-box 0)])\n (if (<= len initial-size)\n (sub-bytevector buf 0 len)\n (let ([full (make-bytevector len)]\n [full-len-box (make-bytevector 8 0)])\n (let ([full-rc (c-read stmt col full len full-len-box)])\n (when (< full-rc 0) (error who \"read failed\" col))\n (sub-bytevector full 0 (bytevector-u64-native-ref full-len-box 0)))))))))\n\n(def (with-finalized-stmt stmt thunk)\n (dynamic-wind\n (lambda () (void))\n thunk\n (lambda () (sqlite-finalize stmt))))") ("id" . "sqlite-native-finalize-and-reread") + ("imports" + "(chezscheme)" + "(only (jerboa core) def try catch)") + ("notes" + . + "Use `dynamic-wind` immediately after `sqlite-prepare` so bind/step/column errors still finalize the statement. For FFI column reads where the shim reports the true byte length through a len-box, retry with a buffer of that exact length instead of clamping. When probing dynamic libraries, avoid literal `#f` as the try/catch result until the known catch-#f quirk is fixed; sentinel symbols preserve boolean intent.") + ("tags" "sqlite-native" "ffi" "dynamic-wind" "length-box" + "blob" "load-shared-object") + ("title" + . + "Finalize SQLite native statements and reread oversized columns"))) --- a/data/features.sexp +++ b/data/features.sexp @@ -2723,4 +2723,42 @@ ("use_case" . "Debugging jsh mux attach, prefix, detach, and replace flows across macOS and Linux without relying on expect being installed.") + ("votes" . 0)) + (("description" + . + "Security rules should support optional exclude_pattern or suppress_when fields so false positives like Git diff prefix stripping or absolute-path checks can be filtered in data instead of adding rule-specific Scheme branches to the scanner. The scanner would apply the main pattern, then skip matches whose line or context matches the exclusion predicate.") + ("estimated_token_reduction" + . + "~200-600 tokens per scan/debug cycle by avoiding false-positive investigation.") + ("example_scenario" + . + "The path-prefix rules correctly warn on path containment checks, but also matched `(string-prefix? \"a/\" path)` for Git diff prefixes and `(string-prefix? \"/\" ref)` for absolute-path detection. Those are not sandbox prefix checks.") + ("id" . "security-scan-rule-exclusions") + ("impact" . "medium") + ("tags" "security-scan" "false-positive" "rules" "mcp" + "metadata") + ("title" + . + "Allow data-driven security scanner rule exclusions") + ("use_case" + . + "When a broad security regex is valuable but catches known safe idioms, maintainers can refine the rule without changing mcp/server.ss.") + ("votes" . 0)) + (("description" + . + "`jerboa_verify` can compile a native-backed module such as `(std db sqlite-native)`, but verifying a script that imports it fails before expansion because the verifier subprocess cannot load `libjerboa_native` symbols. Add parameters for environment variables or a native-library search setup, and propagate `JERBOA_HOME` plus platform library paths into the verifier command.") + ("estimated_token_reduction" + . + "~300-600 tokens per native-backed test verification by avoiding failed verifier retries and manual fallback explanation.") + ("example_scenario" + . + "`tests/test-sqlite-robustness.ss` passes through `make test-sqlite-robustness` with `JERBOA_HOME` and `DYLD_LIBRARY_PATH`, but `jerboa_verify` reports `no entry for \"jerboa_sqlite_open\"`.") + ("id" . "verify-native-library-env") ("impact" . "medium") + ("tags" "verify" "native" "ffi" "library-path" "sqlite") + ("title" + . + "Allow verifier tools to run native-backed scripts with library-path env") + ("use_case" + . + "Verifying tests or scripts that import native-backed modules before running Makefile targets.") ("votes" . 0))) --- a/mcp/server.ss +++ b/mcp/server.ss @@ -15,6 +15,7 @@ (def error-marker "JERBOA-MCP-ERROR:") (def stdout-marker "JERBOA-MCP-STDOUT:") (def valid-marker "JERBOA-MCP-VALID") +(def timeout-marker "JERBOA-MCP-TIMEOUT:") (def *embedded-data* '()) (def *tools* '()) @@ -151,33 +152,117 @@ [(eq? (car rest) key) (cadr rest)] [else (loop (cddr rest))]))) +(def (mcp-process-timeout-default-ms) + (let ([raw (getenv "JERBOA_MCP_PROCESS_TIMEOUT_MS")]) + (if raw + (let ([n (string->number raw)]) + (if (positive-integer? n) n 120000)) + 120000))) + +(def (mcp-timeout-ms rest) + (let* ([default (mcp-process-timeout-default-ms)] + [v (mcp-extract-keyword + rest + 'timeout-ms: + (mcp-extract-keyword rest 'timeout_ms: default))]) + (if (positive-integer? v) v default))) + +(def (timeout-ms->seconds ms) + (max 1 (quotient (+ ms 999) 1000))) + +(def (join-output stdout stderr) + (cond + [(= (string-length stdout) 0) stderr] + [(= (string-length stderr) 0) stdout] + [else (string-append stdout "\n" stderr)])) + +(def (mcp-timeout-runner-script cmd dir out-file err-file timeout-ms) + (let ([seconds (number->string (timeout-ms->seconds timeout-ms))]) + (string-append + "child_pids() {\n" + " parent=$1\n" + " if [ -x /bin/ps ]; then\n" + " /bin/ps -axo pid=,ppid=\n" + " else\n" + " ps -axo pid=,ppid=\n" + " fi | awk -v parent=\"$parent\" '$2 == parent {print $1}' || true\n" + "}\n" + "\n" + "terminate_process_tree() {\n" + " signal=$1\n" + " pid=$2\n" + " for child in $(child_pids \"$pid\"); do\n" + " terminate_process_tree \"$signal\" \"$child\"\n" + " done\n" + " kill -$signal \"$pid\" 2>/dev/null || true\n" + "}\n" + "\n" + (if dir + (string-append "cd " (shell-quote dir) " || exit 127\n") + "") + "/bin/sh -c " (shell-quote cmd) + " > " (shell-quote out-file) + " 2> " (shell-quote err-file) " &\n" + "child=$!\n" + "(\n" + " sleep " seconds "\n" + " if kill -0 \"$child\" 2>/dev/null; then\n" + " printf '\\n" timeout-marker " command exceeded " seconds "s; terminating process tree rooted at %s\\n' \"$child\" >> " + (shell-quote err-file) "\n" + " terminate_process_tree TERM \"$child\"\n" + " sleep 2\n" + " terminate_process_tree KILL \"$child\"\n" + " fi\n" + ") &\n" + "watcher=$!\n" + "wait \"$child\"\n" + "rc=$?\n" + "kill \"$watcher\" 2>/dev/null || true\n" + "wait \"$watcher\" 2>/dev/null || true\n" + "exit \"$rc\"\n"))) + (def (mcp-run-process args . rest) ;; The multicall jmcp embedding can lose output from std/misc/process' ;; thread-drained open-process-ports path. Capture through shell redirection - ;; instead so MCP verification tools see child stdout reliably. + ;; instead so MCP verification tools see child stdout reliably. The wrapper + ;; also enforces a wall-clock timeout and kills visible descendants before + ;; returning, which prevents compile/verify timeouts from leaking scheme + ;; workers. (let* ([dir (mcp-extract-keyword rest 'directory: #f)] [out-file (tmp-artifact-base "jerboa-mcp-stdout")] [err-file (tmp-artifact-base "jerboa-mcp-stderr")] + [runner-file (tmp-artifact-base "jerboa-mcp-runner")] + [runner-log-file (tmp-artifact-base "jerboa-mcp-runner-log")] + [timeout-ms (mcp-timeout-ms rest)] [cmd (if (string? args) args (string-join (map shell-quote args) " "))] - [full-cmd (string-append - (if dir (string-append "cd " (shell-quote dir) " && ") "") - cmd - " > " (shell-quote out-file) - " 2> " (shell-quote err-file))] - [rc (safe-system full-cmd)] + [runner (mcp-timeout-runner-script cmd dir out-file err-file timeout-ms)] + [rc (begin + (write-file-string runner-file runner) + (safe-system (string-append "/bin/sh " (shell-quote runner-file) + " > " (shell-quote runner-log-file) + " 2>&1")))] [stdout (if (file-exists? out-file) (guard (e [else ""]) (read-file-string out-file)) "")] [stderr (if (file-exists? err-file) (guard (e [else ""]) (read-file-string err-file)) - "")]) + "")] + [runner-log (if (file-exists? runner-log-file) + (guard (e [else ""]) (read-file-string runner-log-file)) + "")]) (when (file-exists? out-file) (safe-delete-file out-file)) (when (file-exists? err-file) (safe-delete-file err-file)) + (when (file-exists? runner-file) (safe-delete-file runner-file)) + (when (file-exists? runner-log-file) (safe-delete-file runner-log-file)) (cond + [(or (index-of stdout timeout-marker) + (index-of stderr timeout-marker)) + (join-output stdout stderr)] [(> (string-length stdout) 0) stdout] - [(not (= rc 0)) stderr] + [(not (= rc 0)) (join-output (join-output stdout stderr) runner-log)] + [(> (string-length runner-log) 0) runner-log] [else stdout]))) (def (libdirs home) @@ -225,18 +310,21 @@ (def (join-lines lines) (string-join lines "\n")) +(def (import-list imports) + (filter string? (seq->list imports))) + (def (import-lines imports) (append '("(import (rnrs))" "(import (jerboa prelude))" "(import (jerboa reader))") (map (lambda (imp) (string-append "(import " (normalize-import imp) ")")) - (if imports imports '())))) + (import-list imports)))) (def (env-specs imports) (string-join (append '("'(rnrs)" "'(jerboa prelude)" "'(jerboa reader)") (map (lambda (imp) (string-append "'" (normalize-import imp))) - (if imports imports '()))) + (import-list imports))) " ")) (def (build-eval-script expression imports) @@ -501,7 +589,13 @@ (or (index-of out valid-marker) (index-of out error-marker) (index-of out result-marker) - (index-of out stdout-marker))) + (index-of out stdout-marker) + (index-of out "JERBOA-MCP-EXPORT:") + (index-of out "JERBOA-MCP-ARITY:") + (index-of out "JERBOA-MCP-CATALOG:") + (index-of out "JERBOA-MCP-DOC:") + (index-of out "JERBOA-MCP-CLASS:") + (index-of out "JERBOA-MCP-IMPORT:"))) (def (command-detail-text cmd tmp out) (string-append @@ -610,9 +704,11 @@ (guard (e [else (string-append error-marker "\n" (error-message e))]) (mcp-run-process cmd 'timeout-ms: timeout-ms)))]) (when (file-exists? tmp) (delete-file tmp)) - (if (script-output-has-marker? output) - output - (command-detail-text cmd tmp output)))) + (cond + [(index-of output timeout-marker) + (string-append error-marker "\n" (string-trim output))] + [(script-output-has-marker? output) output] + [else (command-detail-text cmd tmp output)]))) (def (starts-with? s prefix) (string-prefix? prefix s)) @@ -1234,9 +1330,11 @@ [else (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-eval-script expression imports) home - (tool-extra-libdirs args #f home))]) + (tool-extra-libdirs args #f home) + timeout-ms)]) (cond [(index-of out error-marker) (text-result (string-append "Error:\n" (after-marker out error-marker)) #t)] @@ -1261,6 +1359,7 @@ (text-result "code is required." #t) (let* ([imports (hash-get* args "imports" '())] [home (hash-get* args "jerboa_home" #f)] + [extra-libdirs (tool-extra-libdirs args #f home)] [timeout-ms (tool-timeout-ms args 15000)] [out (run-jerboa-script (build-syntax-script (strip-shebang code) imports) home @@ -1380,6 +1479,7 @@ [check-stale? (not (eq? (hash-get* args "check_stale_artifacts" #t) #f))] [clean-stale? (hash-get* args "clean_stale_artifacts" (hash-get* args "delete_stale_artifacts" #f))] + [timeout-ms (tool-timeout-ms args 30000)] [stale-records (if (and file check-stale?) (stale-compiled-artifact-records file args home extra-libdirs) '())] @@ -1406,7 +1506,7 @@ [else (when (and clean-stale? (not (null? stale-records))) (clean-stale-compiled-artifacts! stale-records)) - (let ([out (run-jerboa-script script home extra-libdirs)] + (let ([out (run-jerboa-script script home extra-libdirs timeout-ms)] [clean-note (if (and clean-stale? (not (null? stale-records))) (string-append "\n\nCleaned stale compiled artifacts:\n" stale-text) "")]) @@ -1469,7 +1569,7 @@ (hash-get* args "wpo_mode" #f) (hash-get* args "compile_program" #f))) -(def (tool-verify-wpo args file source label home extra-libdirs hits hit-text) +(def (tool-verify-wpo args file source label home extra-libdirs timeout-ms hits hit-text) (let* ([module-raw (hash-get* args "module_path" (and file (source-file-module file extra-libdirs)))] [module (and module-raw (normalize-import module-raw))] @@ -1482,7 +1582,7 @@ (text-result "module_path is required for WPO verify mode on .sls files outside known libdirs." #t)] [else (let* ([script (build-wpo-verify-script file module temp-base whole?)] - [out (run-jerboa-script script home extra-libdirs)]) + [out (run-jerboa-script script home extra-libdirs timeout-ms)]) (cond [(index-of out valid-marker) (let ([message (string-append label ": WPO verify passed" @@ -1537,6 +1637,7 @@ [hit-text (if (null? hits) "" (string-append "\n\nDivergence pre-scan:\n" (string-join (map format-divergence-hit hits) "\n")))] [home (hash-get* args "jerboa_home" #f)] [extra-libdirs (tool-extra-libdirs args file home)] + [timeout-ms (tool-timeout-ms args 30000)] [script (if (chez-reader-file? file source) (build-library-syntax-script file) (let ([stripped (strip-shebang source)]) @@ -1550,10 +1651,10 @@ (build-syntax-script stripped '()))))] [out (if (wpo-verify-requested? args) #f - (run-jerboa-script script home extra-libdirs))]) + (run-jerboa-script script home extra-libdirs timeout-ms))]) (cond [(wpo-verify-requested? args) - (tool-verify-wpo args file source label home extra-libdirs hits hit-text)] + (tool-verify-wpo args file source label home extra-libdirs timeout-ms hits hit-text)] [(index-of out valid-marker) (if (null? hits) (text-result (string-append label ": No issues found.")) @@ -1651,24 +1752,19 @@ [source-display (or source-file (and (not (null? hits)) (car hits)) "(not found in checked libdirs)")] - [script (string-append - "(import (rnrs))\n(import (jerboa prelude))\n" - "(guard (e [else (display \"" error-marker "\\n\") (display-condition e (current-output-port))])\n" - " (let ([syms (environment-symbols (environment '" normalized "))])\n" - " (for-each (lambda (s) (display s) (newline))\n" - " (list-sort (lambda (a b) (string<? (symbol->string a) (symbol->string b))) syms))))\n")] - [out (run-jerboa-script script home extra-libdirs)]) + [exports (module-exports-list normalized home)]) (cond [(null? hits) (text-result (string-append "Module " normalized " not found in checked libdirs:\n " (string-join dirs "\n ")) #t)] - [(index-of out error-marker) - (text-result (string-append "Error introspecting " normalized ":\n" (after-marker out error-marker)) #t) - ] + [(not (hash-ref exports "ok")) + (text-result (string-append "Error introspecting " normalized ":\n" + (hash-ref exports "error")) + #t)] [else - (let* ([lines (filter (lambda (s) (> (string-length s) 0)) (string-split (string-trim out) #\newline))] + (let* ([lines (hash-ref exports "symbols")] [text (if (null? lines) (string-append "Module " normalized "\nSource: " source-display @@ -1685,21 +1781,34 @@ (text-result "symbol is required." #t) (let* ([imports (hash-get* args "imports" '())] [home (hash-get* args "jerboa_home" #f)] - [script (string-append - (join-lines (import-lines imports)) "\n" - "(guard (e [else (display \"" error-marker "\\n\") (display-condition e (current-output-port))])\n" - " (let ([proc " sym "])\n" - " (if (procedure? proc)\n" - " (begin (display \"JERBOA-MCP-ARITY:\") (display (procedure-arity-mask proc)) (newline))\n" - " (display \"JERBOA-MCP-ARITY:not-a-procedure\\n\"))))\n")] - [out (run-jerboa-script script home)]) - (cond - [(index-of out error-marker) (text-result (string-append "Error: " (after-marker out error-marker)) #t)] - [(index-of out "JERBOA-MCP-ARITY:not-a-procedure") (text-result (string-append sym " is not a procedure."))] - [(index-of out "JERBOA-MCP-ARITY:") - (let ([mask (after-marker out "JERBOA-MCP-ARITY:")]) - (text-result (string-append sym ": arity mask " mask)))] - [else (text-result (string-append "Could not find " sym ".") #t)])))) + [extra-libdirs (tool-extra-libdirs args #f home)] + [modules (unique-strings + (append '("(rnrs)" "(jerboa prelude)") + (import-list imports)))]) + (let loop ([rest modules] [errors '()]) + (cond + [(null? rest) + (text-result + (string-append + "Could not find " sym "." + (if (null? errors) + "" + (string-append "\n\nCatalog errors:\n" (string-join (reverse errors) "\n")))) + #t)] + [else + (let* ([module (car rest)] + [catalog (catalog-entries module #t home extra-libdirs)]) + (if (not (hash-ref catalog "ok")) + (loop (cdr rest) + (cons (string-append module ": " (hash-ref catalog "error")) errors)) + (let ([hit (find (lambda (entry) + (string=? (hash-ref entry "name") sym)) + (hash-ref catalog "entries"))]) + (if hit + (text-result + (string-append sym ": arity mask " (hash-ref hit "arity") + "\nModule: " (hash-ref catalog "module"))) + (loop (cdr rest) errors)))))]))))) (def (tool-apropos args) (def pattern (hash-get* args "pattern" #f)) @@ -1888,7 +1997,10 @@ (def context-aware-security-rules '("call-with-output-file-overwrite-fail" "do-loop-unchecked-bound" - "ffi-u8-star-for-foreign-alloc")) + "ffi-u8-star-for-foreign-alloc" + "realpath-missing-canonicalize" + "symlink-sandbox-bypass" + "jerbuild-set-bang-duplicate-define-syntax")) (def (security-finding-line sev file line-no rule) (string-append sev " " file ":" @@ -1919,6 +2031,16 @@ (let ([ch (first-nonspace-char line)]) (and ch (char=? ch #\")))) +(def (git-diff-prefix-strip-line? line) + (or (string-contains line "string-prefix? \"a/\"") + (string-contains line "string-prefix? \"b/\""))) + +(def (absolute-path-check-line? line) + (string-contains line "string-prefix? \"/\"")) + +(def (top-level-set!-line? line) + (string-prefix? "(set!" line)) + (def (source-call-token? line token) (let ([idx (string-contains line token)]) (and idx @@ -1936,6 +2058,12 @@ (nonnegative-do-bound? line))] [(string=? rule-id "ffi-u8-star-for-foreign-alloc") (not (string-contains content "foreign-alloc"))] + [(or (string=? rule-id "realpath-missing-canonicalize") + (string=? rule-id "symlink-sandbox-bypass")) + (or (git-diff-prefix-strip-line? line) + (absolute-path-check-line? line))] + [(string=? rule-id "jerbuild-set-bang-duplicate-define-syntax") + (not (top-level-set!-line? line))] [else #f])) (def (scan-context-aware-security-rule file content rule) @@ -2277,6 +2405,7 @@ (def home-arg (hash-get* args "jerboa_home" #f)) (def home (jerboa-home home-arg)) (def extra-libdirs (tool-extra-libdirs args file home-arg)) + (def timeout-ms (tool-timeout-ms args 120000)) (def files (cond [file (list file)] [dir (filter (lambda (f) (string-suffix? "-test.ss" f)) (scan-files dir))] @@ -2290,9 +2419,11 @@ "--script" f)) (def out (guard (e [else (error-message e)]) (if project - (mcp-run-process cmd 'directory: project) - (mcp-run-process cmd)))) - (if (or (string-contains out "Exception") (string-contains out "ERROR")) + (mcp-run-process cmd 'directory: project 'timeout-ms: timeout-ms) + (mcp-run-process cmd 'timeout-ms: timeout-ms)))) + (if (or (string-contains out "Exception") + (string-contains out "ERROR") + (string-contains out timeout-marker)) (string-append "FAIL " f "\n" out) (string-append "PASS " f))) files)]) @@ -2443,9 +2574,12 @@ (def (phase-record name status output) (jhash "name" name "status" status "output" output)) -(def (run-phase-command project name cmd) +(def (run-phase-command project name cmd timeout-ms) (guard (e [else (phase-record name "FAIL" (error-message e))]) - (phase-record name "PASS" (mcp-run-process cmd 'directory: project)))) + (let ([out (mcp-run-process cmd 'directory: project 'timeout-ms: timeout-ms)]) + (phase-record name + (if (index-of out timeout-marker) "FAIL" "PASS") + out)))) (def (format-phase-record rec) (string-append (hash-ref rec "status") " " @@ -2496,6 +2630,7 @@ [changed (changed-files-from-args args)] [typed-files (filter typed-relevant-file? changed)] [targets (typed-phase-targets args changed)] + [timeout-ms (tool-timeout-ms args 120000)] [dry-run? (hash-get* args "dry_run" #f)]) (cond [(not project) (text-result "project_path is required." #t)] @@ -2519,11 +2654,13 @@ (map (lambda (target) (run-phase-command project (string-append "make " target) - (list "make" target))) + (list "make" target) + timeout-ms)) targets)] [diff-record (run-phase-command project "git diff --check" - (list "git" "diff" "--check"))] + (list "git" "diff" "--check") + timeout-ms)] [records (append compile-records security-records make-records (list diff-record))] [failed (filter phase-failed? records)]) @@ -2543,9 +2680,12 @@ [(not (file-exists? (path-join project "Makefile"))) (text-result (string-append "No Makefile found in " project) #t)] [else - (let* ([cmd (if (> (string-length target) 0) (list "make" target) (list "make"))] - [out (guard (e [else (error-message e)]) (mcp-run-process cmd 'directory: project))]) - (text-result (string-append "make " (if (> (string-length target) 0) target "(default)") " output:\n\n" out)))])) + (let* ([cmd (if (> (string-length target) 0) (list "make" target) (list "make"))] + [timeout-ms (tool-timeout-ms args 120000)] + [out (guard (e [else (error-message e)]) + (mcp-run-process cmd 'directory: project 'timeout-ms: timeout-ms))]) + (text-result (string-append "make " (if (> (string-length target) 0) target "(default)") " output:\n\n" out) + (truthy? (index-of out timeout-marker))))])) (def (tool-security-profile args) (def project (hash-get* args "project_path" (repo-root))) @@ -3767,18 +3907,18 @@ (not (string-suffix? ".ss" s)) (not (string-suffix? ".scm" s))))) -(def (module-exports-list module-path home) +(def (module-exports-list module-path home (extra-libdirs '())) (let* ([normalized (normalize-import module-path)] - [script (string-append - "(import (rnrs))\n(import (jerboa prelude))\n" - "(guard (e [else (display \"" error-marker "\\n\") (display-condition e (current-output-port))])\n" - " (let ([syms (environment-symbols (environment '" normalized "))])\n" - " (for-each (lambda (s) (display \"" export-marker "\") (display s) (newline))\n" - " (list-sort (lambda (a b) (string<? (symbol->string a) (symbol->string b))) syms))))\n")] - [out (run-jerboa-script script home)]) - (if (index-of out error-marker) - (jhash "ok" #f "module" normalized "error" (after-marker out error-marker) "symbols" '()) - (jhash "ok" #t "module" normalized "symbols" (marker-payloads out export-marker))))) + [catalog (catalog-entries normalized #t home extra-libdirs)]) + (if (hash-ref catalog "ok") + (jhash "ok" #t + "module" normalized + "symbols" (map (lambda (entry) (hash-ref entry "name")) + (hash-ref catalog "entries"))) + (jhash "ok" #f + "module" normalized + "error" (hash-ref catalog "error") + "symbols" '())))) (def (catalog-line->entry payload) (let ([parts (string-split payload #\tab)]) @@ -3786,7 +3926,7 @@ "kind" (list-ref* parts 1 "?") "arity" (list-ref* parts 2 "-")))) -(def (catalog-entries module-path include-signatures home) +(def (catalog-entries module-path include-signatures home (extra-libdirs '())) (let* ([normalized (normalize-import module-path)] [with-sigs (if include-signatures "#t" "#f")] [script (string-append @@ -3810,7 +3950,7 @@ " (display \"-\"))\n" " (newline))))\n" " syms)))\n")] - [out (run-jerboa-script script home)]) + [out (run-jerboa-script script home extra-libdirs)]) (if (index-of out error-marker) (jhash "ok" #f "module" normalized "error" (after-marker out error-marker) "entries" '()) (jhash "ok" #t "module" normalized @@ -5143,7 +5283,7 @@ file (if (null? argv) "" (string-append " " (string-join argv " "))))) -(def (run-temp-script code argv home extra-libdirs) +(def (run-temp-script code argv home extra-libdirs timeout-ms) (def tmp (tmp-script-name)) (let* ([cmd (append (list (scheme-path) "--libdirs" (effective-libdirs home extra-libdirs) @@ -5152,7 +5292,7 @@ [out (begin (write-file-string tmp code) (guard (e [else (string-append "ERROR: " (condition->text e))]) - (mcp-run-process cmd)))]) + (mcp-run-process cmd 'timeout-ms: timeout-ms)))]) (when (file-exists? tmp) (delete-file tmp)) out)) @@ -5174,6 +5314,7 @@ [code (script-code-for-kind kind label)] [home (hash-get* args "jerboa_home" #f)] [extra-libdirs (tool-extra-libdirs args file home)] + [timeout-ms (tool-timeout-ms args 30000)] [verify? (not (eq? (hash-get* args "verify" #t) #f))] [write? (hash-get* args "write" #f)] [overwrite? (hash-get* args "overwrite" #f)] @@ -5186,10 +5327,11 @@ (tool-verify (jhash "code" code "project_path" (hash-get* args "project_path" #f) "extra_libdirs" (hash-get* args "extra_libdirs" '()) + "timeout_ms" timeout-ms "jerboa_home" home)) (text-result "Verification skipped."))] [run-output (if (and verify? (not (hash-ref verify-result "isError"))) - (run-temp-script code argv home extra-libdirs) + (run-temp-script code argv home extra-libdirs timeout-ms) "")] [trimmed-output (string-trim run-output)] [expected-ok? (or (not expected) @@ -6685,8 +6827,12 @@ [(not binary) (text-result "binary_path is required." #t)] [(not (file-exists? binary)) (text-result (string-append "Binary not found: " binary) #t)] [else - (let ([out (guard (e [else (error-message e)]) (mcp-run-process (append (list binary) argv)))]) - (if (or (string-contains out "Exception") (string-contains out "segmentation")) + (let* ([timeout-ms (tool-timeout-ms args 120000)] + [out (guard (e [else (error-message e)]) + (mcp-run-process (append (list binary) argv) 'timeout-ms: timeout-ms))]) + (if (or (string-contains out "Exception") + (string-contains out "segmentation") + (string-contains out timeout-marker)) (text-result (string-append "Static binary smoke test failed:\n\n" out) #t) (text-result (string-append "Static binary smoke test passed:\n\n" (string-trim out)))))])))