Enforce staged repair tool locks
ober
1c5bcecb7b7058631607449609b1ded7ce73b1b7
--- a/src/jcode/core/verified-run.ss +++ b/src/jcode/core/verified-run.ss @@ -322,6 +322,12 @@ (else #t)))))) specs))) +(def (verified-executable-tool-specs specs) + (if (and (current-verified-local-model?) + (rejected-draft-staged-repair-mode?)) + (filter verified-staged-repair-tool-spec? specs) + specs)) + (def (tool-specs-include? specs name) (let loop ((xs specs)) (cond @@ -5946,6 +5952,9 @@ (cons 'max-repeated-calls (or (opt-get o 'max-repeated-calls) 6)) (cons 'max-no-progress-retries (or (opt-get o 'max-no-progress-retries) 2)) (cons 'retry-text-responses? #t) + (cons 'tool-spec-filter verified-provider-tool-specs) + (cons 'tool-execution-spec-filter + verified-executable-tool-specs) (cons 'automatic-tool-calls (lambda () (cond --- a/src/jcode/core/workflow-runner.ss +++ b/src/jcode/core/workflow-runner.ss @@ -120,6 +120,9 @@ (def (tool-name-available? names name) (and (member name names) #t)) +(def (tool-spec-name-list specs) + (map tool-spec-name specs)) + (def (verified-coding-workflow-tools? names) (or (tool-name-available? names "verify") (tool-name-available? names "edit") @@ -140,15 +143,24 @@ "Do not retry that tool name. Choose one of the available workflow tools. ") (format "Available tools: ~a" available))) -(def (unknown-tool-outcome workflow name) - (let ((available (workflow-tool-names workflow))) +(def (unknown-tool-outcome workflow name . maybe-available) + (let ((available (if (pair? maybe-available) + (car maybe-available) + (workflow-tool-names workflow)))) (cons 'resolution (if (disabled-shell-tool? name) (let ((n (+ (current-disabled-shell-tool-count) 1))) (current-disabled-shell-tool-count n) (disabled-shell-tool-message name available n)) + (if (and (string=? name "done") + (workflow-get-tool-def workflow name) + (tool-name-available? available "verify")) + (string-append + "done refused because code changed after the last passing verify. " + "Call verify again; only then call done. " + (format "Available tools: ~a" available)) (format "Unknown tool '~a'. Available tools: ~a" - name available))))) + name available)))))) (def (reasoning-of tool-calls) (and (pair? tool-calls) (wtool-call-reasoning (car tool-calls)))) @@ -186,7 +198,7 @@ ;; ── Batch execution (forge 3c → 3e) ────────────────────────────────── ;; Returns (terminal . value) when a terminal tool succeeded, else 'continue. ;; May raise ToolExecutionError when the error budget is exhausted. -(def (execute-batch! emit! workflow enforcer error-tracker tool-calls) +(def (execute-batch! emit! workflow enforcer error-tracker tool-calls available-names) (let ((reasoning (reasoning-of tool-calls)) (tc-data (wtool-calls->data tool-calls))) (when reasoning (emit! (make-assistant-message reasoning))) @@ -214,12 +226,15 @@ (td (car tds)) (tc-id (tool-call-id td)) (name (wtool-call-tool tc)) - (terminal? (workflow-terminal-tool? workflow name)) - (tdf (workflow-get-tool-def workflow name)) + (available? (tool-name-available? available-names name)) + (terminal? (and available? + (workflow-terminal-tool? workflow name))) + (tdf (and available? + (workflow-get-tool-def workflow name))) (outcome (if tdf (run-one-tool (tool-def-callable tdf) (wtool-call-args tc)) - (unknown-tool-outcome workflow name)))) + (unknown-tool-outcome workflow name available-names)))) (case (car outcome) ((resolution) ;; privileged: emit result, no error-budget hit @@ -421,6 +436,8 @@ max-repeated-calls (#f = off) max-no-progress-retries (0) retry-text-responses? (#f) prepare-messages (#f; optional messages -> provider-messages transform) + tool-spec-filter (#f; optional current tool-specs -> visible tool-specs) + tool-execution-spec-filter (#f; optional current tool-specs -> executable tool-specs) automatic-tool-calls (#f; optional thunk -> tool-call list) on-message (#f) prompt-vars ('()) initial-messages (#f) cancel? (thunk -> bool, default never). @@ -435,6 +452,8 @@ (max-no-progress-retries (or (opt-ref o 'max-no-progress-retries) 0)) (retry-text-responses? (and (opt-ref o 'retry-text-responses?) #t)) (prepare-messages (opt-ref o 'prepare-messages)) + (tool-spec-filter (opt-ref o 'tool-spec-filter)) + (tool-execution-spec-filter (opt-ref o 'tool-execution-spec-filter)) (automatic-tool-calls (opt-ref o 'automatic-tool-calls)) (on-message (opt-ref o 'on-message)) (prompt-vars (or (opt-ref o 'prompt-vars) '())) @@ -469,15 +488,25 @@ ((cancel?) (raise-workflow-cancelled (step-enforcer-completed enforcer) iteration)) (else - (let ((automatic-calls - (and automatic-tool-calls (automatic-tool-calls)))) + (let* ((visible-tool-specs + (if tool-spec-filter + (tool-spec-filter tool-specs) + tool-specs)) + (executable-tool-specs + (if tool-execution-spec-filter + (tool-execution-spec-filter tool-specs) + tool-specs)) + (executable-tool-names + (tool-spec-name-list executable-tool-specs)) + (automatic-calls + (and automatic-tool-calls (automatic-tool-calls)))) (if (and (list? automatic-calls) (pair? automatic-calls)) ;; Verified workflows use this to run their authoritative ;; verifier without spending a model turn after an edit or ;; when resuming a dirty workspace. (let ((outcome (execute-batch! emit! workflow enforcer - error-tracker automatic-calls))) + error-tracker automatic-calls executable-tool-names))) (if (and (pair? outcome) (eq? (car outcome) 'terminal)) (cdr outcome) (loop iteration))) @@ -486,7 +515,7 @@ (prepare-messages messages) messages)) (response - (responder provider-messages tool-specs iteration))) + (responder provider-messages visible-tool-specs iteration))) (cond ;; Intentional text response — emit and consume an iteration. ((text-response? response) @@ -551,7 +580,8 @@ (loop (+ iteration 1)) ;; 3d → 3e — execute the batch (let ((outcome (execute-batch! emit! workflow enforcer - error-tracker tool-calls))) + error-tracker tool-calls + executable-tool-names))) (if (and (pair? outcome) (eq? (car outcome) 'terminal)) (cdr outcome) (loop (+ iteration 1)))))))))))))))))))))))) --- a/test/run.ss +++ b/test/run.ss @@ -4002,6 +4002,68 @@ (safe-delete-test-file! target-path)) (let* ([vr-dir "/tmp"] + [target "jcode-local-hidden-write-rejected-draft.ss"] + [target-path (string-append vr-dir "/" target)] + [bad-a "(import (jerboa prelude))\n(def (main)\n (displayln \"bad\")))\n"] + [bad-b "(import (jerboa prelude))\n(def (main)\n (displayln \"still bad\")))\n"] + [bad-c "(import (jerboa prelude))\n(def (main)\n (displayln \"ignored\")))\n"] + [tool-results '()] + [tool-names-after-repeat '()] + [calls 0] + [responder + (lambda (_messages tools _step) + (set! calls (+ calls 1)) + (when (= calls 3) + (set! tool-names-after-repeat (map tool-spec-name tools))) + (case calls + [(1) (list (make-wtool-call "write" + (list (cons "path" target) + (cons "content" bad-a)) #f))] + [(2) (list (make-wtool-call "write" + (list (cons "path" target) + (cons "content" bad-b)) #f))] + [(3) (list (make-wtool-call "write" + (list (cons "path" target) + (cons "content" bad-c)) #f))] + [(4) (list (make-wtool-call "line_edit" + (list (cons "path" target) + (cons "line" 3) + (cons "content" " (displayln \"fixed\"))")) #f))] + [else (error 'test "hidden write should be rejected before bounded repair")]))]) + (safe-delete-test-file! target-path) + (let ([result + (verified-run responder "reject hidden broad writes during staged repair" + (list + (cons 'cwd vr-dir) + (cons 'verify-command (string-append "grep -q fixed " target)) + (cons 'write-scope (parse-write-scope target)) + (cons 'local-model? #t) + (cons 'max-iterations 10) + (cons 'on-message + (lambda (m) + (when (equal? (message-role m) "tool") + (set! tool-results + (cons (message-content m) tool-results)))))))]) + (check! "verified-run: hidden write staged repair verifies" + result "VERIFIED: exit 0\n")) + (check-pred! "verified-run: hidden write not advertised after repeated rejects" + tool-names-after-repeat (lambda (names) (not (member "write" names)))) + (check-pred! "verified-run: hidden write call is rejected at execution" + (reverse tool-results) + (lambda (xs) + (let loop ([rest xs]) + (and (pair? rest) + (or (and (str-contains? (car rest) "[ToolResolutionError] Unknown tool 'write'") + (str-contains? (car rest) "replace_range")) + (loop (cdr rest))))))) + (check-pred! "verified-run: hidden write did not replace staged draft" + (call-with-input-file target-path (lambda (p) (get-string-all p))) + (lambda (s) + (and (str-contains? s "fixed") + (not (str-contains? s "ignored"))))) + (safe-delete-test-file! target-path)) + + (let* ([vr-dir "/tmp"] [target "jcode-local-rejected-draft-read-after-failure.ss"] [target-path (string-append vr-dir "/" target)] [initial "(import (jerboa prelude))\n(def value \"broken\")\n"]