Improve verified workflow recovery
ober
2e3d1afcd27eebb428f33031c2786942403b46dc
--- a/src/jcode/core/verified-run.ss +++ b/src/jcode/core/verified-run.ss @@ -542,6 +542,20 @@ "edit" "write" "line_edit" "replace_def" "replace_range" "verify" "done")) +(def *verified-muted-mcp-name-fragments* + '("_add" + "vote_feature" + "suggest_feature" + "balanced_replace" + "check_balance" + "script_scaffold_verify" + "jerboa_make" + "jerboa_run_tests" + "jerboa_eval")) + +(def (verified-muted-mcp-tool? name) + (string-has-any? name *verified-muted-mcp-name-fragments*)) + (def (schema-function schema) (and (hash-table? schema) (hash-get schema "function"))) @@ -550,10 +564,11 @@ (lambda (schema) (let* ((fn (schema-function schema)) (name (and (hash-table? fn) (hash-get fn "name")))) - (and (string? name) - (eq? (tool-origin name) 'mcp) - (not (member name *verified-reserved-tool-names*)) - (not (write-tool-name? name)) + (and (string? name) + (eq? (tool-origin name) 'mcp) + (not (member name *verified-reserved-tool-names*)) + (not (verified-muted-mcp-tool? name)) + (not (write-tool-name? name)) (let ((desc (or (hash-get fn "description") "MCP tool")) (params (or (hash-get fn "parameters") (make-hash-table)))) (make-tool-def @@ -672,6 +687,15 @@ (def current-existing-ss-rewrite-repeat-count (make-parameter 0)) +(def current-scaffold-created-ss-paths + (make-parameter '())) + +(def current-path-only-run-fingerprint + (make-parameter #f)) + +(def current-path-only-run-repeat-count + (make-parameter 0)) + (def current-after-failed-verify? (make-parameter #f)) @@ -730,6 +754,24 @@ (current-existing-ss-rewrite-fingerprint #f) (current-existing-ss-rewrite-repeat-count 0)) +(def (reset-path-only-run-state!) + (current-path-only-run-fingerprint #f) + (current-path-only-run-repeat-count 0)) + +(def (scaffold-created-ss? cwd path) + (and (source-ss-path? path) + (let loop ((paths (current-scaffold-created-ss-paths))) + (cond + ((null? paths) #f) + ((same-verified-path? cwd (car paths) path) #t) + (else (loop (cdr paths))))))) + +(def (record-scaffold-created-ss! cwd path) + (let ((absolute (abs-path cwd path))) + (unless (scaffold-created-ss? cwd path) + (current-scaffold-created-ss-paths + (cons absolute (current-scaffold-created-ss-paths)))))) + (def (record-existing-ss-rewrite-rejection! cwd path content) (let* ((fp (rejected-draft-fingerprint path content)) (old-path (current-existing-ss-rewrite-reject-path)) @@ -752,6 +794,7 @@ (def (existing-ss-rewrite-locked? cwd path) (let ((old-path (current-existing-ss-rewrite-reject-path))) (and (source-ss-path? path) + (not (scaffold-created-ss? cwd path)) old-path (same-verified-path? cwd old-path path) (>= (current-existing-ss-rewrite-reject-count) @@ -832,6 +875,7 @@ (def (record-successful-edit! cwd path) (clear-pending-ss-create-repair! cwd path) (reset-existing-ss-rewrite-state!) + (reset-path-only-run-state!) (reset-failed-verify-inspections!) (current-edited-since-verify? #t) (current-inspections-after-edit 0)) @@ -1022,7 +1066,7 @@ path))) (def (rejected-draft-hard-recovery? cwd) - (and (pending-missing-ss-create-path cwd) + (and (current-rejected-ss-draft) (> (current-rejected-draft-inspections) rejected-draft-inspection-limit))) @@ -1039,6 +1083,23 @@ (balance-report content path))) (def (rejected-draft-hard-recovery-message cwd who) + (let ((draft (current-rejected-ss-draft))) + (and draft + (> (current-rejected-draft-inspections) + rejected-draft-inspection-limit) + (let* ((path (car draft)) + (missing? (not (file-exists? (abs-path cwd path))))) + (string-append + "Rejected draft inspection limit reached for " path + " while calling " (tool-label who) ". " + (if missing? + "Missing-file recovery is locked to a fresh full-file create. " + "The rejected full-file replacement was not written; the on-disk file is unchanged. ") + "MCP file-edit tools, run/list/verify, line_edit, replace_def, and replace_range cannot repair this rejected draft. " + "Next call must be edit or write with path=\"" path + "\" and complete corrected contents. Do not inspect the rejected draft again."))))) + +(def (pending-missing-ss-create-recovery-message cwd who) (let ((path (pending-missing-ss-create-path cwd))) (and path (> (current-rejected-draft-inspections) @@ -1088,6 +1149,7 @@ (or (note-rejected-draft-inspection! path content) (string-append (balance-report content path) + (or (minimal-balance-suffix-hint content path) "") "\nRejected draft for " path " was not written to disk; call edit with complete corrected contents after repair."))))) @@ -1158,6 +1220,21 @@ (else (normalize-relative-scope path)))) +(def (outside-scope-path? rel) + (and (string? rel) + (or (absolute-path-string? rel) + (string=? rel "..") + (string-prefix? "../" rel)))) + +(def (read-scope-message cwd tool path) + (let ((rel (scope-path cwd path))) + (and (outside-scope-path? rel) + (string-append + tool + " refused outside the verified working directory: " + path + ". Use MCP tools such as module_exports, apropos, howto, or cookbook_task_bundle for external Jerboa APIs; use read/list only for files under the current repo.")))) + (def (absolute-components->path comps) (string-append "/" (string-join comps "/"))) @@ -1235,6 +1312,7 @@ (cond ((rejected-draft-read-message cwd path args) => (lambda (msg) msg)) ((pending-ss-create-repair-message cwd) => (lambda (msg) msg)) + ((read-scope-message cwd "read" path) => (lambda (msg) msg)) ((not (file-exists? p)) (string-append "(file does not exist: " path ")")) ((file-directory? p) @@ -1261,6 +1339,7 @@ (p (abs-path cwd path))) (cond ((pending-ss-create-repair-message cwd) => (lambda (msg) msg)) + ((read-scope-message cwd "list" path) => (lambda (msg) msg)) ((not (file-exists? p)) (string-append "(path does not exist: " path ")")) ((not (file-directory? p)) @@ -1518,6 +1597,15 @@ (and (balance-ok-text? (balance-report line-candidate label)) line-candidate))))))) +(def (minimal-balance-suffix-hint content label) + (let ((suffix (missing-closing-delims content))) + (and suffix + (let ((candidate (minimal-balance-candidate content label))) + (and candidate + (string-append + "\nMinimal delimiter repair: append this exact suffix at EOF before resubmitting the complete file contents:\n" + suffix)))))) + (def (read-first-form content) (with-input-from-string content (lambda () @@ -1879,9 +1967,61 @@ (or (arg-ref args "command" #f) (arg-ref args "bash" #f) (arg-ref args "shell" #f) - (arg-ref args "path" #f) "")) +(def (path-only-run-call? args) + (and (not (arg-ref args "command" #f)) + (not (arg-ref args "bash" #f)) + (not (arg-ref args "shell" #f)) + (arg-path args #f))) + +(def (record-path-only-run! path) + (let ((old (current-path-only-run-fingerprint))) + (if (and old (string=? old path)) + (let ((n (+ (current-path-only-run-repeat-count) 1))) + (current-path-only-run-repeat-count n) + n) + (begin + (current-path-only-run-fingerprint path) + (current-path-only-run-repeat-count 1) + 1)))) + +(def (path-only-run-prefix path mode repeat-count) + (string-append + "run requires a command string; this path-only call was auto-converted to " + mode + "(path=\"" + path + "\"). Do not retry run/bash/shell with path-only args; call " + mode + " directly next time." + (if (> repeat-count 1) + "\nThis is a repeated path-only shell call for the same path. Next useful step should be edit/write/replace_range/verify, not another run/bash/shell call." + ""))) + +(def (path-only-run-result args cwd) + (let* ((path (arg-path args #f)) + (p (abs-path cwd path)) + (repeat-count (record-path-only-run! path))) + (cond + ((or (rejected-draft-content cwd path) + (and (file-exists? p) + (not (file-directory? p)))) + (string-append + (path-only-run-prefix path "read" repeat-count) + "\n" + (do-read (list (cons "path" path)) cwd))) + ((and (file-exists? p) (file-directory? p)) + (string-append + (path-only-run-prefix path "list" repeat-count) + "\n" + (do-list (list (cons "path" path)) cwd))) + (else + (string-append + "run requires a command string, but this call only supplied path=\"" + path + "\" and that path does not exist. Use edit/write(path, content) to create files, mkdir -p DIR for directories, or verify for the configured test command. Do not retry run/bash/shell with the same path-only arguments."))))) + (def (safe-cd-prefix-target prefix) (let ((trimmed (string-trim prefix))) (and (string-prefix? "cd " trimmed) @@ -1988,16 +2128,18 @@ => (lambda (repair) (error 'run (required-repair-message 'run repair)))) ((rejected-draft-hard-recovery-message cwd 'run) => (lambda (msg) msg)) + ((pending-ss-create-repair-message cwd) => (lambda (msg) msg)) + ((path-only-run-call? args) + (path-only-run-result args cwd)) (else (let* ((raw-cmd (run-arg args)) (cmd (or (strip-safe-cd-prefix raw-cmd cwd) raw-cmd)) (words (if (string? cmd) (split-command cmd) '()))) - (cond + (cond ((cat-heredoc-write cmd cwd) => (lambda (result) result)) (else (cond ((note-inspection-after-failed-verify! 'run) => (lambda (msg) (error 'run msg))) - ((pending-ss-create-repair-message cwd) => (lambda (msg) msg)) ((and (string? cmd) (not (null? words)) (null? (cdr words)) @@ -2196,6 +2338,8 @@ (cons "random-make-state" "use (random n); do not use random-make-state") (cons "'." "do not use '. as a datum; use a normal symbol such as 'empty or a number sentinel") (cons "(quote .)" "do not use (quote .); use a normal symbol such as 'empty or a number sentinel") + (cons "#\\\\#" "over-escaped Scheme character literal: replace the source text #\\\\# with #\\#; character literals use one backslash after # in the actual file") + (cons "#\\\\." "over-escaped Scheme character literal: replace the source text #\\\\. with #\\.; character literals use one backslash after # in the actual file") (cons "#{" "do not use Clojure/hash-literal syntax") (cons "(raise \"" "do not raise a string; use (error 'who \"message\" ...)") (cons "symbol<?" "symbol<? is not in Jerboa; compare symbol->string values") @@ -2264,8 +2408,17 @@ (not (string-contains content "#<<")) (let ((report (balance-report content path))) (and (not (balance-ok-text? report)) - (format "Jerboa syntax guard rejected ~a: delimiter balance failed: ~a" - path report))))) + (string-append + (format "Jerboa syntax guard rejected ~a: delimiter balance failed: ~a" + path report) + (or (minimal-balance-suffix-hint content path) "")))))) + +(def (auto-balance-full-ss-content path content) + (and (source-ss-path? path) + ;; Keep heredoc-like content out of the lightweight delimiter scanner. + (not (string-contains content "#<<")) + (not (balance-ok-text? (balance-report content path))) + (minimal-balance-candidate content path))) (def (jerboa-syntax-guard-message path content) (and (source-ss-path? path) @@ -2294,16 +2447,31 @@ (def (guard-jerboa-syntax-existing-file-edit! cwd path content) (let ((msg (jerboa-syntax-guard-message path content))) (when msg - (record-existing-ss-rewrite-rejection! cwd path content) - (reset-rejected-draft-state!) - (error 'edit - (string-append - msg - "\nThe full-file rewrite was not written; the on-disk file is unchanged. " - "Do not inspect or repair this rejected full-file draft. Next tool call should be balance(path=\"" - path - "\") or verify(), then use line_edit, replace_range, or replace_def for a local repair.\n" - (existing-ss-rewrite-lock-message cwd path)))))) + (if (scaffold-created-ss? cwd path) + (begin + (record-rejected-ss-draft! path content) + (error 'edit + (string-append + msg + "\nThe full-file replacement was not written; the scaffold on disk is unchanged. " + "This .ss file was created by create_verified_jerboa_script during this workflow, " + "so you may retry edit/write with complete corrected contents, or inspect the rejected draft with read(path=\"" + path + "\") or balance(path=\"" + path + "\"). Call verify after the replacement is written." + (or (rejected-draft-repeat-note path) "")))) + (begin + (record-existing-ss-rewrite-rejection! cwd path content) + (reset-rejected-draft-state!) + (error 'edit + (string-append + msg + "\nThe full-file rewrite was not written; the on-disk file is unchanged. " + "Do not inspect or repair this rejected full-file draft. Next tool call should be balance(path=\"" + path + "\") or verify(), then use line_edit, replace_range, or replace_def for a local repair.\n" + (existing-ss-rewrite-lock-message cwd path)))))))) (def (guard-jerboa-syntax-for-replace-range! cwd path full-content replacement-content) (let ((repair (current-required-range-repair)) @@ -2526,15 +2694,21 @@ (reject-incomplete-ss-create path new-content "replacement snippets")) (else - (let ((dir (path-directory p))) + (let* ((balanced-content + (auto-balance-full-ss-content path new-content)) + (final-content (or balanced-content new-content)) + (dir (path-directory p))) (when (and dir (not (equal? dir "")) (not (file-exists? dir))) - (mkdir-p dir))) - (guard-jerboa-syntax! path new-content) - (write-file-string p new-content) + (mkdir-p dir)) + (guard-jerboa-syntax! path final-content) + (write-file-string p final-content) (record-successful-edit! cwd path) (string-append "wrote " path " (" - (number->string (string-length new-content)) - " bytes)"))))) + (number->string (string-length final-content)) + " bytes)" + (if balanced-content + " after appending minimal delimiter suffix" + ""))))))) ((not (file-exists? p)) (error 'edit "replace target does not exist: ~a" path)) (else @@ -2552,29 +2726,39 @@ (string-append "edited " path " by exact replacement")))))))) (else (let ((p (abs-path cwd path))) - (if (and (not (file-exists? p)) - (source-ss-path? path) - (not (looks-like-complete-file? content))) - (reject-incomplete-ss-create - path content "full-write snippets") - (if (and (file-exists? p) - (existing-ss-rewrite-locked? cwd path)) - (existing-ss-rewrite-lock-message cwd path) - (begin - (let ((dir (path-directory p))) - (when (and dir (not (equal? dir "")) (not (file-exists? dir))) - (mkdir-p dir))) - (when (file-exists? p) - (let ((old (read-file-string p))) - (let ((msg (partial-overwrite-error path old content))) - (when msg (error 'edit msg))))) - (if (file-exists? p) - (guard-jerboa-syntax-existing-file-edit! cwd path content) - (guard-jerboa-syntax! path content #t)) - (write-file-string p content) - (record-successful-edit! cwd path) - (string-append "wrote " path " (" - (number->string (string-length content)) " bytes)"))))))))) + (cond + ((and (not (file-exists? p)) + (source-ss-path? path) + (not (looks-like-complete-file? content))) + (reject-incomplete-ss-create + path content "full-write snippets")) + ((and (file-exists? p) + (existing-ss-rewrite-locked? cwd path)) + (existing-ss-rewrite-lock-message cwd path)) + (else + (let ((dir (path-directory p))) + (when (and dir (not (equal? dir "")) (not (file-exists? dir))) + (mkdir-p dir))) + (when (file-exists? p) + (let ((old (read-file-string p))) + (let ((msg (partial-overwrite-error path old content))) + (when msg (error 'edit msg))))) + (let* ((balanced-content + (and (not (file-exists? p)) + (auto-balance-full-ss-content path content))) + (final-content (or balanced-content content))) + (if (file-exists? p) + (guard-jerboa-syntax-existing-file-edit! cwd path final-content) + (guard-jerboa-syntax! path final-content #t)) + (write-file-string p final-content) + (record-successful-edit! cwd path) + (string-append "wrote " path " (" + (number->string (string-length final-content)) + " bytes)" + (if balanced-content + " after appending minimal delimiter suffix" + ""))))))))) + ) ;; Minimal JSON-Schema object; the per-arg contract rides in each tool's ;; description (nested schema alists don't serialize cleanly, descriptions do). @@ -2601,13 +2785,13 @@ (def (normal-script-kind kind) (let ((k (string-downcase (or kind "minimal-pass")))) (cond + ((or (string-contains k "grid") + (string-contains k "vector")) + "vector-grid") ((or (string-contains k "cli") (string-contains k "arg") (string-contains k "sum")) "cli-two-args") - ((or (string-contains k "grid") - (string-contains k "vector")) - "vector-grid") (else "minimal-pass")))) (def (jerboa-minimal-pass-script) @@ -2703,11 +2887,14 @@ (error 'create_verified_jerboa_script "refusing write through symlink path component: ~a" path)) (else - (let ((result - (do-edit - (list (cons "path" path) - (cons "content" (jerboa-script-template template-kind))) - cwd))) + (let* ((created-new? (not (file-exists? (abs-path cwd path)))) + (result + (do-edit + (list (cons "path" path) + (cons "content" (jerboa-script-template template-kind))) + cwd))) + (when (and created-new? (file-exists? (abs-path cwd path))) + (record-scaffold-created-ss! cwd path)) (string-append "created verified Jerboa script scaffold " template-kind @@ -2793,7 +2980,7 @@ (create-script-def (make-tool-def (make-tool-spec "create_verified_jerboa_script" - "Create a small executable Jerboa .ss script scaffold through the verified edit path. args: {\"path\": string ending .ss, \"kind\": \"minimal-pass\" | \"cli-two-args\" | \"vector-grid\"}. For new Jerboa scripts, prefer this before hand-writing a full file." + "Create a small executable Jerboa .ss starter through the verified edit path. args: {\"path\": string ending .ss, \"kind\": \"minimal-pass\" | \"cli-two-args\" | \"vector-grid\"}. Use only when a generic template clearly matches: minimal-pass for trivial scripts, cli-two-args for simple numeric two-argument CLIs, vector-grid for 2-D vector/grid examples. For nontrivial algorithms, you may skip scaffolding and write the complete file." *obj-schema*) (lambda (args) (create-verified-jerboa-script args cwd)) '())) @@ -2932,7 +3119,7 @@ (if run-aliases? "run/bash/shell are narrow inspection aliases only; use verify for the configured build/test command.\n" "run/bash/shell are not available in this workflow. Use verify for the configured build/test command.\n") - "For a new Jerboa .ss script, call create_verified_jerboa_script first when a generic kind such as minimal-pass, cli-two-args, or vector-grid matches the task shape, then verify and only hand-edit if verify fails.\n" + "For a new Jerboa .ss script, create_verified_jerboa_script is optional. Use it only when one generic kind clearly matches: minimal-pass for trivial executable scripts, cli-two-args for simple numeric two-argument CLIs, and vector-grid for 2-D vector/grid examples. For nontrivial algorithms, write the complete file directly, then verify.\n" (external-tools-instruction external-tool-defs) (scope-instruction scope) (guidance-instruction task-guidance) @@ -2970,9 +3157,10 @@ (if p (cdr p) #t))) (cons 'task-guidance task-guidance) (cons 'terminal-on-verify #t)))) - (ropt (list (cons 'max-iterations (or (opt-get o 'max-iterations) 48)) - (cons 'max-repeated-calls (or (opt-get o 'max-repeated-calls) 6)) - (cons 'on-message (opt-get o 'on-message))))) + (ropt (list (cons 'max-iterations (or (opt-get o 'max-iterations) 48)) + (cons 'max-repeated-calls (or (opt-get o 'max-repeated-calls) 6)) + (cons 'retry-text-responses? #t) + (cons 'on-message (opt-get o 'on-message))))) (parameterize ((current-write-scope scope) (current-pending-ss-create-repair #f) (current-rejected-ss-draft #f) @@ -2983,6 +3171,7 @@ (current-existing-ss-rewrite-reject-count 0) (current-existing-ss-rewrite-fingerprint #f) (current-existing-ss-rewrite-repeat-count 0) + (current-scaffold-created-ss-paths '()) (current-after-failed-verify? #f) (current-inspections-after-failed-verify 0) (current-edited-since-verify? #f) --- a/src/jcode/core/workflow-runner.ss +++ b/src/jcode/core/workflow-runner.ss @@ -192,8 +192,9 @@ "Execute WORKFLOW with USER-MESSAGE, driving the loop through RESPONDER. Returns the terminal tool's value. OPT is an optional options assoc: max-iterations (10) max-retries-per-step (3) max-tool-errors (2) - max-repeated-calls (#f = off) on-message (#f) prompt-vars ('()) - initial-messages (#f) cancel? (thunk -> bool, default never). + max-repeated-calls (#f = off) retry-text-responses? (#f) + on-message (#f) prompt-vars ('()) initial-messages (#f) + cancel? (thunk -> bool, default never). Raises MaxIterationsError / StepEnforcementError / PrerequisiteError / ToolExecutionError / WorkflowCancelledError / NoProgressError on the corresponding conditions." @@ -202,6 +203,7 @@ (max-retries (or (opt-ref o 'max-retries-per-step) 3)) (max-tool-errors (or (opt-ref o 'max-tool-errors) 2)) (max-repeated-calls (opt-ref o 'max-repeated-calls)) + (retry-text-responses? (and (opt-ref o 'retry-text-responses?) #t)) (on-message (opt-ref o 'on-message)) (prompt-vars (or (opt-ref o 'prompt-vars) '())) (initial-msgs (opt-ref o 'initial-messages)) @@ -236,12 +238,24 @@ (let ((response (responder messages tool-specs iteration))) (cond ;; Intentional text response — emit and consume an iteration. - ((text-response? response) - (emit! (make-assistant-message (text-response-content response))) - (loop (+ iteration 1))) - (else - (let ((tool-calls (if (list? response) response (list response)))) - ;; 3b — premature terminal + ((text-response? response) + (let ((content (text-response-content response))) + (emit! (make-assistant-message content)) + (if retry-text-responses? + (begin + (error-tracker-record-retry! error-tracker) + (when (error-tracker-retries-exhausted? error-tracker) + (raise-tool-call-error + "Model failed to produce a valid tool call after text-response retries." + content)) + (emit! (make-user-message + (nudge-content (make-retry-nudge content)))) + (loop (+ iteration 1))) + (loop (+ iteration 1))))) + (else + (let ((tool-calls (if (list? response) response (list response)))) + (error-tracker-reset-retries! error-tracker) + ;; 3b — premature terminal (let ((step-check (step-enforcer-check enforcer tool-calls))) (cond ((step-check-needs-nudge step-check) --- a/src/jcode/mcp/client.ss +++ b/src/jcode/mcp/client.ss @@ -48,8 +48,36 @@ (display "'" out) (get-output-string out))) -(def (shell-command command args) - (string-join (map shell-quote (cons command args)) " ")) +(def (env-assignment kv) + (let ((k (car kv)) + (v (cdr kv))) + (and (string? k) + (not (string=? k "")) + (string-append k "=" (if (string? v) v (format "~a" v)))))) + +(def (env-assignments env) + (let loop ((pairs env) (out '())) + (cond + ((null? pairs) (reverse out)) + (else + (let ((assignment (env-assignment (car pairs)))) + (loop (cdr pairs) + (if assignment (cons assignment out) out))))))) + +(def (shell-command command args . env-opt) + (let* ((env (if (null? env-opt) '() (car env-opt))) + (assignments (env-assignments env)) + (words (if (null? assignments) + (cons command args) + (append (cons "env" assignments) (cons command args))))) + (string-join (map shell-quote words) " "))) + +(def (mcp-config-env cfg) + (let ((env (or (hash-get cfg "env") + (hash-get cfg "environment")))) + (if (hash-table? env) + (hash->list env) + '()))) ;; --- MCP server state --- @@ -128,10 +156,11 @@ ;; --- subprocess management --- -(def (mcp-start name command args) +(def (mcp-start name command args . env-opt) "Start an MCP server subprocess and return an mcp-conn." (log-info logger "starting" `((name . ,name) (command . ,command))) - (let ((cmd-str (shell-command command args))) + (let ((cmd-str (shell-command command args + (if (null? env-opt) '() (car env-opt))))) (let-values (((to-stdin from-stdout from-stderr pid) (open-process-ports cmd-str 'block (make-transcoder (utf-8-codec))))) (let ((conn (make-mcp-conn name to-stdin from-stdout from-stderr pid 1 @@ -341,9 +370,10 @@ (let* ((command (hash-ref cfg "command" "node")) (args (let ((a (hash-get cfg "args"))) (if (list? a) a '()))) + (env (mcp-config-env cfg)) (prefix (or (hash-get cfg "prefix") (string-append "mcp_" name "_"))) - (conn (mcp-start name command args))) + (conn (mcp-start name command args env))) (mcp-initialize conn) (let ((count (register-mcp-tools conn prefix))) (log-info logger "ready" --- a/src/jcode/ui/cli.ss +++ b/src/jcode/ui/cli.ss @@ -98,33 +98,34 @@ (open-trace-log! trace-path) (current-log-level 'debug) (fprintf (current-error-port) "[trace] writing to ~a~n" trace-path))) - (load-config) - (load-cli-themes!) - (session-init-db) - (init-tools) - ;; Start debug REPL only when an explicit port is requested. - (let ((repl-opt (assoc '--repl-port opts)) - (host-opt (assoc '--repl-host opts))) - (when repl-opt - (let* ((host (and host-opt (cdr host-opt))) - (remote? (and host (not (string-prefix? "127." host)))) - (port (guard (e (#t (fprintf (current-error-port) "[ERROR] ") - (display-condition e (current-error-port)) - (fprintf (current-error-port) "~n") - (exit 1))) - (if host - (start-jcode-repl! (cdr repl-opt) host) - (start-jcode-repl! (cdr repl-opt)))))) - (if remote? - (printf "Debug REPL on ~a:~a — TLS + token auth: openssl s_client -quiet -connect ~a:~a (first line = token)~n" - host port host port) - (printf "Debug REPL on port ~a (nc 127.0.0.1 ~a)~n" port port))))) - ;; Apply CLI overrides to agent parameters - (let ((p-opt (assoc '--provider opts)) - (m-opt (assoc '--model opts))) - (when p-opt (current-provider-override (cdr p-opt))) - (when m-opt (current-model-override (cdr m-opt)))) (let ((rest (let ((r (assoc '-- opts))) (if r (cdr r) '())))) + (load-config) + (load-cli-themes!) + (when (cli-session-command? rest opts) + (session-init-db)) + (init-tools) + ;; Start debug REPL only when an explicit port is requested. + (let ((repl-opt (assoc '--repl-port opts)) + (host-opt (assoc '--repl-host opts))) + (when repl-opt + (let* ((host (and host-opt (cdr host-opt))) + (remote? (and host (not (string-prefix? "127." host)))) + (port (guard (e (#t (fprintf (current-error-port) "[ERROR] ") + (display-condition e (current-error-port)) + (fprintf (current-error-port) "~n") + (exit 1))) + (if host + (start-jcode-repl! (cdr repl-opt) host) + (start-jcode-repl! (cdr repl-opt)))))) + (if remote? + (printf "Debug REPL on ~a:~a — TLS + token auth: openssl s_client -quiet -connect ~a:~a (first line = token)~n" + host port host port) + (printf "Debug REPL on port ~a (nc 127.0.0.1 ~a)~n" port port))))) + ;; Apply CLI overrides to agent parameters + (let ((p-opt (assoc '--provider opts)) + (m-opt (assoc '--model opts))) + (when p-opt (current-provider-override (cdr p-opt))) + (when m-opt (current-model-override (cdr m-opt)))) (cond ;; TUI mode ((assoc '--tui opts) @@ -196,6 +197,20 @@ (def *no-mcp* #f) +(def (cli-session-command? rest opts) + ;; The persisted chat DB is needed by interactive/TUI/chat/session/serve + ;; flows, but not by standalone operational commands such as verified. + ;; Avoid taking the global sessions.db flock for commands that never touch + ;; chat history; a long-lived interactive jcode may legitimately hold it. + (or (assoc '--tui opts) + (null? rest) + (and (pair? rest) + (or (equal? (car rest) "session") + (equal? (car rest) "serve"))) + (and (pair? rest) + (not (member (car rest) + '("config" "keys" "proxy" "verified" "relay" "connect")))))) + (def (init-tools) ;; Register local tools (fast, no I/O) (init-file-tools) --- a/test/run.ss +++ b/test/run.ss @@ -1200,6 +1200,42 @@ [result (run-workflow w "go" resp (list (cons 'max-iterations 6)))]) (check! "text-then-tools reaches terminal" result "ANSWER delivered")) +;; Opt-in tool-calling workflows treat prose as invalid and nudge for a tool. +(let* ([w (mk-research-wf)] + [msgs '()] + [resp (scripted-responder + (list (make-text-response "thinking out loud") + (list (make-wtool-call "search" '() #f)) + (list (make-wtool-call "answer" '() #f))))] + [result (run-workflow w "go" resp + (list (cons 'max-iterations 6) + (cons 'retry-text-responses? #t) + (cons 'on-message + (lambda (m) (set! msgs (cons m msgs))))))]) + (check! "retry-text workflow still reaches terminal" result "ANSWER delivered") + (check-pred! "retry-text workflow emits tool-call nudge" + (reverse msgs) + (lambda (xs) + (let loop ([ys xs]) + (cond + [(null? ys) #f] + [(and (equal? (message-role (car ys)) "user") + (str-contains? (message-content (car ys)) + "You must respond with a tool call")) + #t] + [else (loop (cdr ys))]))))) + +;; Opt-in text retries fail through ToolCallError instead of burning every +;; workflow iteration. +(let* ([w (mk-research-wf)] + [resp (scripted-responder (make-list 5 (make-text-response "no tools here")))]) + (check! "retry-text exhausted raises ToolCallError" + (raises-pred? (lambda () (run-workflow w "go" resp + (list (cons 'max-iterations 10) + (cons 'max-retries-per-step 1) + (cons 'retry-text-responses? #t)))) + tool-call-error?) #t)) + ;; premature terminal recovered (not exhausted): answer, then search, then answer (let* ([w (mk-research-wf)] [resp (scripted-responder @@ -1971,6 +2007,50 @@ (car (reverse tool-results)) "two\nthree")) (guard (e [#t (void)]) (delete-file "/tmp/jcode-verified-cd-sed-alias.txt")) +(let* ([wf (coding-workflow "true" "/tmp")] + [tool-results '()] + [resp (scripted-responder + (list + (list (make-wtool-call "run" '(("path" . "/tmp")) #f)) + (list (make-wtool-call "verify" '() #f)) + (list (make-wtool-call + "done" '(("summary" . "path-run-recovered")) #f))))] + [result (run-workflow wf "recover from path-only run" resp + (list (cons 'max-iterations 6) + (cons 'on-message + (lambda (m) + (when (equal? (message-role m) "tool") + (set! tool-results + (cons (message-content m) tool-results)))))))]) + (check! "verified-run: path-only run can recover" + result "path-run-recovered") + (check-pred! "verified-run: path-only run returns explicit guidance" + (car (reverse tool-results)) + (lambda (s) + (and (not (str-contains? s "[ToolError]")) + (str-contains? s "run requires a command string") + (str-contains? s "auto-converted to list") + (str-contains? s "Do not retry run/bash/shell"))))) + +(let* ([wf (coding-workflow "true" "/tmp/jcode-verified-read-scope")] + [read-tool (tool-def-callable (workflow-get-tool-def wf "read"))] + [list-tool (tool-def-callable (workflow-get-tool-def wf "list"))] + [run-tool (tool-def-callable (workflow-get-tool-def wf "run"))]) + (check-pred! "verified-run: read refuses outside cwd" + (read-tool '(("path" . "/tmp"))) + (lambda (s) + (and (str-contains? s "read refused outside") + (str-contains? s "MCP tools")))) + (check-pred! "verified-run: list refuses outside cwd" + (list-tool '(("path" . "/tmp"))) + (lambda (s) + (str-contains? s "list refused outside"))) + (check-pred! "verified-run: path-only run cannot inspect outside cwd" + (run-tool '(("path" . "/tmp"))) + (lambda (s) + (and (str-contains? s "auto-converted to list") + (str-contains? s "list refused outside"))))) + (let* ([wf (coding-workflow "true" "/tmp" (list (cons 'run-aliases? #f)))] [names (workflow-tool-names wf)]) @@ -1991,23 +2071,51 @@ "A plain registry tool that should not enter verified workflow." '(("type" . "object")) (lambda (a) "plain")) -(register-tool! "jerboa_test_lookup" - "A custom-prefixed MCP-origin lookup tool." - '(("type" . "object") - ("properties" . (("q" . (("type" . "string")))))) - (lambda (a) (json-object->string a))) -(set-tool-origin! "jerboa_test_lookup" 'mcp) -(let* ([wf (coding-workflow "true" "/tmp")] - [mcp-tool (workflow-get-tool-def wf "jerboa_test_lookup")] - [plain-tool (workflow-get-tool-def wf "jcode_test_plain_lookup")] - [disabled-wf (coding-workflow "true" "/tmp" - (list (cons 'external-tools? #f)))]) - (check! "verified-run: MCP-origin custom prefix is exposed" - (and mcp-tool #t) #t) - (check! "verified-run: plain registry tool is not exposed" - plain-tool #f) - (check! "verified-run: external tools option disables MCP bridge" - (workflow-get-tool-def disabled-wf "jerboa_test_lookup") #f) + (register-tool! "jerboa_test_lookup" + "A custom-prefixed MCP-origin lookup tool." + '(("type" . "object") + ("properties" . (("q" . (("type" . "string")))))) + (lambda (a) (json-object->string a))) + (set-tool-origin! "jerboa_test_lookup" 'mcp) + (register-tool! "jerboa_script_scaffold_verify" + "A write-capable MCP scaffold tool that verified-run should hide." + '(("type" . "object")) + (lambda (a) "scaffold")) + (set-tool-origin! "jerboa_script_scaffold_verify" 'mcp) + (register-tool! "jerboa_howto_add" + "A data-mutating MCP cookbook writer that verified-run should hide." + '(("type" . "object")) + (lambda (a) "added")) + (set-tool-origin! "jerboa_howto_add" 'mcp) + (register-tool! "jerboa_check_balance" + "A duplicate MCP balance tool that cannot see jcode rejected drafts." + '(("type" . "object")) + (lambda (a) "balance")) + (set-tool-origin! "jerboa_check_balance" 'mcp) + (register-tool! "jerboa_balanced_replace" + "A write-capable MCP replace tool that should not bypass jcode edits." + '(("type" . "object")) + (lambda (a) "replaced")) + (set-tool-origin! "jerboa_balanced_replace" 'mcp) + (let* ([wf (coding-workflow "true" "/tmp")] + [mcp-tool (workflow-get-tool-def wf "jerboa_test_lookup")] + [plain-tool (workflow-get-tool-def wf "jcode_test_plain_lookup")] + [disabled-wf (coding-workflow "true" "/tmp" + (list (cons 'external-tools? #f)))]) + (check! "verified-run: MCP-origin custom prefix is exposed" + (and mcp-tool #t) #t) + (check! "verified-run: plain registry tool is not exposed" + plain-tool #f) + (check! "verified-run: MCP scaffold writers are not exposed" + (workflow-get-tool-def wf "jerboa_script_scaffold_verify") #f) + (check! "verified-run: MCP data writers are not exposed" + (workflow-get-tool-def wf "jerboa_howto_add") #f) + (check! "verified-run: MCP duplicate balance tool is not exposed" + (workflow-get-tool-def wf "jerboa_check_balance") #f) + (check! "verified-run: MCP file mutator is not exposed" + (workflow-get-tool-def wf "jerboa_balanced_replace") #f) + (check! "verified-run: external tools option disables MCP bridge" + (workflow-get-tool-def disabled-wf "jerboa_test_lookup") #f) (check-pred! "verified-run: MCP-origin tool receives converted args" ((tool-def-callable mcp-tool) '(("q" . "life"))) (lambda (s) (str-contains? s "\"life\""))) @@ -2930,9 +3038,56 @@ (guard (e [#t (void)]) (delete-file target-path)))) (let* ([vr-dir "/tmp"] - [target "jcode-verified-balance-guard.ss"] + [target "jcode-verified-char-escape-guard.ss"] [target-path (string-append vr-dir "/" target)] - [bad "(import (jerboa prelude))\n(define (main) 1))\n"] + [bad "(import (jerboa prelude))\n(display #\\\\#)\n"] + [good "(import (jerboa prelude))\n(display #\\#)\n"] + [tool-results '()] + [slurp (lambda (p) (call-with-input-file p (lambda (i) (get-string-all i))))]) + (guard (e [#t (void)]) (delete-file target-path)) + (let* ([scope (parse-write-scope target)] + [wf (coding-workflow (string-append "test -s " target) vr-dir + (list (cons 'write-scope scope)))] + [resp (scripted-responder + (list + (list + (make-wtool-call + "edit" + (list (cons "path" target) + (cons "content" bad)) + #f)) + (list + (make-wtool-call + "edit" + (list (cons "path" target) + (cons "content" good)) + #f)) + (list (make-wtool-call "verify" '() #f)) + (list (make-wtool-call "done" '(("summary" . "char-escape-guard-ok")) #f))))] + [result (parameterize ((current-write-scope scope)) + (run-workflow wf "reject over-escaped character literal" resp + (list (cons 'max-iterations 8) + (cons 'max-tool-errors 3) + (cons 'on-message + (lambda (m) + (when (equal? (message-role m) "tool") + (set! tool-results + (cons (message-content m) tool-results))))))))]) + (check! "verified-run: char escape guard rejects then accepts repaired write" + result "char-escape-guard-ok") + (check! "verified-run: char escape guard accepted single backslash source" + (slurp target-path) good) + (check-pred! "verified-run: char escape guard explains over-escaped source" + (reverse tool-results) + (lambda (xs) + (and (pair? xs) + (str-contains? (car xs) "over-escaped Scheme character literal"))))) + (guard (e [#t (void)]) (delete-file target-path))) + + (let* ([vr-dir "/tmp"] + [target "jcode-verified-balance-guard.ss"] + [target-path (string-append vr-dir "/" target)] + [bad "(import (jerboa prelude))\n(define (main) 1))\n"] [good "(import (jerboa prelude))\n(define (main) 1)\n"] [tool-results '()] [slurp (lambda (p) (call-with-input-file p (lambda (i) (get-string-all i))))]) @@ -2969,15 +3124,56 @@ result "balance-guard-ok") (check! "verified-run: balance guard accepted corrected file" (slurp target-path) good) - (check-pred! "verified-run: balance guard explains delimiter failure" - (reverse tool-results) - (lambda (xs) - (and (pair? xs) - (str-contains? (car xs) "delimiter balance failed"))))) - (guard (e [#t (void)]) (delete-file target-path))) - - (let* ([vr-dir "/tmp"] - [target "jcode-verified-scaffold-grid.ss"] + (check-pred! "verified-run: balance guard explains delimiter failure" + (reverse tool-results) + (lambda (xs) + (and (pair? xs) + (str-contains? (car xs) "delimiter balance failed"))))) + (guard (e [#t (void)]) (delete-file target-path))) + + (let* ([vr-dir "/tmp"] + [target "jcode-verified-balance-autoclose.ss"] + [target-path (string-append vr-dir "/" target)] + [bad "(import (jerboa prelude))\n(define (main)\n (displayln \"draft\")\n"] + [expected (string-append bad ")")] + [tool-results '()] + [slurp (lambda (p) (call-with-input-file p (lambda (i) (get-string-all i))))]) + (guard (e [#t (void)]) (delete-file target-path)) + (let* ([scope (parse-write-scope target)] + [wf (coding-workflow (string-append "grep -q draft " target) vr-dir + (list (cons 'write-scope scope)))] + [resp (scripted-responder + (list + (list + (make-wtool-call + "edit" + (list (cons "path" target) + (cons "content" bad)) + #f)) + (list (make-wtool-call "verify" '() #f)) + (list (make-wtool-call "done" '(("summary" . "balance-autoclose-ok")) #f))))] + [result (parameterize ((current-write-scope scope)) + (run-workflow wf "autoclose missing EOF delimiter" resp + (list (cons 'max-iterations 8) + (cons 'max-tool-errors 3) + (cons 'on-message + (lambda (m) + (when (equal? (message-role m) "tool") + (set! tool-results + (cons (message-content m) tool-results))))))))]) + (check! "verified-run: missing EOF delimiter autocloses" + result "balance-autoclose-ok") + (check! "verified-run: autoclose wrote minimal suffix" + (slurp target-path) expected) + (check-pred! "verified-run: autoclose reports suffix" + (reverse tool-results) + (lambda (xs) + (and (pair? xs) + (str-contains? (car xs) "minimal delimiter suffix"))))) + (guard (e [#t (void)]) (delete-file target-path))) + + (let* ([vr-dir "/tmp"]