Harden verified rejected-draft recovery
ober
1b52ab218d3d06702571fdf824bc0241499ecd3a
--- a/src/jcode/core/verified-run.ss +++ b/src/jcode/core/verified-run.ss @@ -408,10 +408,12 @@ (string-append "\n" stderr) ""))) (detail (string-append "exit " (number->string exit-code) "\n" (tail-lines out 40))) - (augmented (augment-verify-detail detail cwd))) - (cons (and (= exit-code 0) - (not (verify-output-forced-failure? out))) - augmented)))) + (pass? (and (= exit-code 0) + (not (verify-output-forced-failure? out))))) + (cons pass? + (if pass? + detail + (augment-verify-detail detail cwd)))))) ;; ── coding workflow tools ────────────────────────────────────────────── (def (arg-ref args key default) @@ -440,7 +442,7 @@ (def (schema-function schema) (and (hash-table? schema) (hash-get schema "function"))) -(def (workflow-mcp-tool-defs) +(def (workflow-mcp-tool-defs cwd) (filter-map (lambda (schema) (let* ((fn (schema-function schema)) @@ -453,7 +455,9 @@ (params (or (hash-get fn "parameters") (make-hash-table)))) (make-tool-def (make-tool-spec name desc params) - (lambda (args) (tool-execute name (workflow-args->hash args))) + (lambda (args) + (or (rejected-draft-hard-recovery-message cwd name) + (tool-execute name (workflow-args->hash args)))) '()))))) (get-tool-schemas))) @@ -574,6 +578,12 @@ (def rejected-draft-inspection-limit 2) +(def (tool-label who) + (cond + ((symbol? who) (symbol->string who)) + ((string? who) who) + (else "tool"))) + (def (reset-failed-verify-inspections!) (current-after-failed-verify? #f) (current-inspections-after-failed-verify 0) @@ -774,7 +784,46 @@ (string-append "The file was not written. Next tool call must be edit with complete corrected contents for " path - ". You may call read(path,start,end) or balance(path) to inspect the rejected draft, then rewrite the complete file. Do not call run/list/verify until that file exists.")) + ". You may call read(path,start,end) or balance(path) to inspect the rejected draft, then rewrite the complete file. " + "MCP file-edit tools cannot repair this state because the file does not exist on disk. " + "Do not call run/list/verify until that file exists.")) + +(def (pending-missing-ss-create-path cwd) + (let ((path (current-pending-ss-create-repair))) + (and path + (not (file-exists? (abs-path cwd path))) + path))) + +(def (rejected-draft-hard-recovery? cwd) + (and (pending-missing-ss-create-path cwd) + (> (current-rejected-draft-inspections) + rejected-draft-inspection-limit))) + +(def (rejected-draft-limit-message path content) + (string-append + "Rejected draft inspection limit reached for " path + ". Missing-file recovery is now locked to a fresh full-file create. " + "The rejected draft was not written to disk; MCP file-edit tools, run/list/verify, " + "line_edit, replace_def, and replace_range cannot repair it. " + "Next call must be edit or write with complete corrected contents for " + path + ". Do not inspect the rejected draft again.\n" + "Last balance result: " + (balance-report content path))) + +(def (rejected-draft-hard-recovery-message cwd who) + (let ((path (pending-missing-ss-create-path cwd))) + (and path + (> (current-rejected-draft-inspections) + rejected-draft-inspection-limit) + (string-append + "Rejected draft inspection limit reached for " path + " while calling " (tool-label who) ". " + "Missing-file recovery is locked to a fresh full-file create. " + "The rejected draft was not written to disk; MCP file-edit tools, run/list/verify, " + "line_edit, replace_def, and replace_range cannot repair it. " + "Next call must be edit or write with path=\"" path + "\" and complete corrected contents. Do not inspect the rejected draft again.")))) (def (pending-ss-create-repair-message cwd) (let ((path (current-pending-ss-create-repair))) @@ -795,11 +844,7 @@ (let ((n (+ (current-rejected-draft-inspections) 1))) (current-rejected-draft-inspections n) (and (> n rejected-draft-inspection-limit) - (string-append - "Rejected draft inspection limit reached for " path - ". Stop reading this rejected draft. Next call must be edit with complete corrected contents for missing-file creation, or balance/verify on the unchanged file if it already exists.\n" - "Last balance result: " - (balance-report content path))))) + (rejected-draft-limit-message path content)))) (def (rejected-draft-read-message cwd path args) (let ((content (rejected-draft-content cwd path))) @@ -972,6 +1017,7 @@ (def (do-read args cwd) (cond + ((rejected-draft-hard-recovery-message cwd 'read) => (lambda (msg) msg)) ((required-repair-read-block-message cwd args) => (lambda (msg) msg)) ((current-required-range-repair) (do-read-current args cwd)) ((note-inspection-after-failed-verify! 'read) => (lambda (msg) (error 'read msg))) @@ -980,6 +1026,7 @@ (def (do-list args cwd) (cond + ((rejected-draft-hard-recovery-message cwd 'list) => (lambda (msg) msg)) ((required-repair-tool-block-message cwd 'list args) => (lambda (msg) msg)) ((note-inspection-after-failed-verify! 'list) => (lambda (msg) (error 'list msg))) ((note-inspection-after-edit! 'list) => (lambda (msg) (error 'list msg))) @@ -1467,6 +1514,7 @@ (if repair (required-repair-balance-message cwd repair) "balance: missing path"))) + ((rejected-draft-hard-recovery-message cwd 'balance) => (lambda (msg) msg)) ((note-inspection-after-edit! 'balance) => (lambda (msg) (error 'balance msg))) ((rejected-draft-balance-message cwd path) => (lambda (msg) msg)) ((current-required-range-repair) @@ -1713,6 +1761,7 @@ ((current-required-range-repair) => (lambda (repair) (error 'run (required-repair-message 'run repair)))) + ((rejected-draft-hard-recovery-message cwd 'run) => (lambda (msg) msg)) (else (let* ((raw-cmd (run-arg args)) (cmd (or (strip-safe-cd-prefix raw-cmd cwd) raw-cmd)) @@ -2110,6 +2159,7 @@ ((not path) (error 'replace_def "missing path arg")) ((not name) (error 'replace_def "missing name arg")) ((not content) (error 'replace_def "missing content arg")) + ((rejected-draft-hard-recovery-message cwd 'replace_def) => (lambda (msg) msg)) ((required-repair-tool-block-message cwd 'replace_def args) => (lambda (msg) msg)) (else (let ((p (abs-path cwd path))) @@ -2138,6 +2188,7 @@ ((not content) (error 'replace_range "missing content arg")) ((<= start-line 0) (error 'replace_range "missing positive start arg")) ((< end-line start-line) (error 'replace_range "end must be >= start")) + ((rejected-draft-hard-recovery-message cwd 'replace_range) => (lambda (msg) msg)) ((required-repair-replace-range-block-message cwd args) => (lambda (msg) msg)) (else (let ((p (abs-path cwd path))) @@ -2179,8 +2230,10 @@ (def (do-edit args cwd) (let* ((path (arg-path args #f)) (content (arg-content args)) - (old-str (arg-ref args "old_str" #f)) + (old-str (or (arg-ref args "old_str" #f) + (arg-ref args "old_string" #f))) (new-str (or (arg-ref args "new_str" #f) + (arg-ref args "new_string" #f) (and old-str content))) (line-no (arg-int args "line" 0))) (cond @@ -2193,6 +2246,10 @@ => (lambda (msg) (error 'edit msg))) ((path-has-symlink-component? cwd path) (error 'edit "refusing write through symlink path component: ~a" path)) + ((and old-str (rejected-draft-hard-recovery? cwd)) + (string-append + (rejected-draft-hard-recovery-message cwd 'edit) + " Exact replacement on the rejected draft is disabled after the inspection limit; send one complete file body instead.")) ((> line-no 0) (let ((p (abs-path cwd path))) (unless (file-exists? p) @@ -2318,7 +2375,7 @@ (if p (cdr p) #t))) (terminal-on-verify? (and (opt-get o 'terminal-on-verify) #t)) (task-guidance (opt-get o 'task-guidance)) - (external-tool-defs (if external-tools? (workflow-mcp-tool-defs) '()))) + (external-tool-defs (if external-tools? (workflow-mcp-tool-defs cwd) '()))) (let ((read-def (make-tool-def (make-tool-spec "read" @@ -2420,14 +2477,14 @@ '())) (edit-def (make-tool-def - (make-tool-spec "edit" - "Edit a file. Full write args: {\"path\": string, \"content\": string}; \"file\", \"filename\", \"file_path\", \"filepath\", \"target\", and \"target_path\" are accepted as path aliases. \"file\" is still accepted as a content alias when a separate path is present. \"contents\", \"new_content\", \"body\", and \"text\" are accepted as content aliases. Exact replacement args: {\"path\": string, \"old_str\": string, \"new_str\": string}; \"content\" may be used instead of \"new_str\" when \"old_str\" is present. Line replacement args: {\"path\": string, \"line\": number, \"content\": string}." - *obj-schema*) + (make-tool-spec "edit" + "Edit a file. Full write args: {\"path\": string, \"content\": string}; \"file\", \"filename\", \"file_path\", \"filepath\", \"target\", and \"target_path\" are accepted as path aliases. \"file\" is still accepted as a content alias when a separate path is present. \"contents\", \"new_content\", \"body\", and \"text\" are accepted as content aliases. Exact replacement args: {\"path\": string, \"old_str\": string, \"new_str\": string}; old_string/new_string are accepted aliases; \"content\" may be used instead of \"new_str\" when \"old_str\" is present. Line replacement args: {\"path\": string, \"line\": number, \"content\": string}." + *obj-schema*) (lambda (args) (do-edit args cwd)) '())) (write-def (make-tool-def (make-tool-spec "write" - "Alias for edit. Full write args: {\"path\": string, \"content\": string}. \"file\" is accepted as a path alias and content/file/body/text aliases are accepted like edit." + "Alias for edit. Full write args: {\"path\": string, \"content\": string}. Exact replacement accepts old_str/new_str or old_string/new_string. \"file\" is accepted as a path alias and content/file/body/text aliases are accepted like edit." *obj-schema*) (lambda (args) (do-edit args cwd)) '())) (line-edit-def @@ -2443,6 +2500,7 @@ ((not path) (error 'line_edit "missing path arg")) ((not content) (error 'line_edit "missing content arg")) ((<= line-no 0) (error 'line_edit "missing positive line arg")) + ((rejected-draft-hard-recovery-message cwd 'line_edit) => (lambda (msg) msg)) (else (do-edit (list (cons "path" path) @@ -2473,7 +2531,9 @@ *obj-schema*) (make-verify-callable (lambda (args) - (let ((pending (pending-ss-create-repair-message cwd))) + (let ((pending + (or (rejected-draft-hard-recovery-message cwd 'verify) + (pending-ss-create-repair-message cwd)))) (record-verify-result! (if pending (cons #f pending) --- a/test/run.ss +++ b/test/run.ss @@ -1980,6 +1980,16 @@ (and (str-contains? s "MCP failure advisor") (str-contains? s "MCP-FAILURE-ADVICE"))))) +(let ([result (run-verify-command "sh -c 'echo mcp-ok; exit 0'" "/tmp")]) + (check! "verified-run: MCP failure advisor skips passing verify" + (car result) #t) + (check-pred! "verified-run: passing verify detail stays clean" + (cdr result) + (lambda (s) + (and (str-contains? s "mcp-ok") + (not (str-contains? s "MCP failure advisor")) + (not (str-contains? s "MCP-FAILURE-ADVICE")))))) + (let* ([wf (coding-workflow "true" "/tmp" (list (cons 'task-guidance "recipe-context-marker")))]) (check-pred! "verified-run: caller guidance appears in prompt" @@ -2825,8 +2835,8 @@ [(and (str-contains? (car ys) "file still does not exist") (str-contains? (car ys) "Next tool call must be edit")) #t] - [else (loop (cdr ys))]))))) - (guard (e [#t (void)]) (delete-file target-path))) + [else (loop (cdr ys))])))) + (guard (e [#t (void)]) (delete-file target-path)))) (let* ([vr-dir "/tmp"] [target "jcode-verified-balance-guard.ss"] @@ -2946,8 +2956,8 @@ [(and (str-contains? (car ys) "Unclosed") (str-contains? (car ys) "Rejected draft")) #t] - [else (loop (cdr ys))]))))) - (guard (e [#t (void)]) (delete-file target-path))) + [else (loop (cdr ys))])))) + (guard (e [#t (void)]) (delete-file target-path)))) (let* ([vr-dir "/tmp"] [target "jcode-verified-rejected-draft-replace.ss"] @@ -2974,8 +2984,8 @@ (make-wtool-call "edit" (list (cons "path" target) - (cons "old_str" old-line) - (cons "new_str" new-line)) + (cons "old_string" old-line) + (cons "new_string" new-line)) #f)) (list (make-wtool-call "verify" '() #f)) (list (make-wtool-call "done" '(("summary" . "rejected-draft-replace-ok")) #f))))] @@ -2988,7 +2998,7 @@ (when (equal? (message-role m) "tool") (set! tool-results (cons (message-content m) tool-results))))))))]) - (check! "verified-run: exact replacement can repair rejected draft" + (check! "verified-run: exact replacement aliases can repair rejected draft" result "rejected-draft-replace-ok") (check! "verified-run: rejected draft replacement writes fixed file" (slurp target-path) fixed) @@ -2999,8 +3009,8 @@ (cond [(null? ys) #f] [(str-contains? (car ys) "edited rejected draft") #t] - [else (loop (cdr ys))]))))) - (guard (e [#t (void)]) (delete-file target-path))) + [else (loop (cdr ys))])))) + (guard (e [#t (void)]) (delete-file target-path)))) (let* ([vr-dir "/tmp"] [target "jcode-verified-rejected-draft-limit.ss"] @@ -3031,8 +3041,27 @@ (list (cons "path" target) (cons "content" bad)) #f))) - (list (read-call) (read-call) (read-call) - (read-call) (read-call) (read-call)) + (list (read-call) (read-call) (read-call)) + (list + (list (make-wtool-call "list" '() #f)) + (list + (make-wtool-call + "balance" + (list (cons "path" target)) + #f)) + (list + (make-wtool-call + "replace_range" + (list (cons "path" target) + (cons "start" 1) + (cons "end" 1) + (cons "content" good)) + #f)) + (list + (make-wtool-call + "run" + (list (cons "command" target)) + #f))) (list (list (make-wtool-call @@ -3044,7 +3073,7 @@ (list (make-wtool-call "done" '(("summary" . "rejected-draft-limit-ok")) #f)))))] [result (parameterize ((current-write-scope scope)) (run-workflow wf "limit rejected draft inspection" resp - (list (cons 'max-iterations 12) + (list (cons 'max-iterations 16) (cons 'max-tool-errors 3) (cons 'on-message (lambda (m) @@ -3062,8 +3091,19 @@ (cond [(null? ys) #f] [(str-contains? (car ys) "Rejected draft inspection limit reached") #t] - [else (loop (cdr ys))]))))) - (guard (e [#t (void)]) (delete-file target-path))) + [else (loop (cdr ys))])))) + (check-pred! "verified-run: rejected draft limit blocks non-edit tools" + (reverse tool-results) + (lambda (xs) + (let loop ([ys xs]) + (cond + [(null? ys) #f] + [(and (str-contains? (car ys) "Missing-file recovery is locked") + (str-contains? (car ys) "MCP file-edit tools") + (str-contains? (car ys) "Next call must be edit or write")) + #t] + [else (loop (cdr ys))])))) + (guard (e [#t (void)]) (delete-file target-path)))) (let* ([vr-dir "/tmp"] [target "jcode-verified-balance-after-reads.ss"]