Allow missing draft full-write recovery
ober
68e2e201c5107899c1ff06bec2091352bb9711a6
--- a/src/jcode/core/verified-run.ss +++ b/src/jcode/core/verified-run.ss @@ -183,6 +183,10 @@ (member (tool-spec-name spec) '("line_edit" "replace_def" "replace_range" "verify"))) +(def (verified-missing-create-staged-tool-spec? spec) + (member (tool-spec-name spec) + '("edit" "write" "line_edit" "replace_def" "replace_range" "verify"))) + (def (verified-rejected-draft-inspection-tool-spec? spec) (member (tool-spec-name spec) '("read" "balance"))) @@ -203,6 +207,7 @@ (def (verified-provider-tool-spec spec) (if (and (local-focused-repair-mode?) + (not (current-pending-ss-create-repair)) (string=? (tool-spec-name spec) "edit")) (make-tool-spec "edit" "Replace exact existing text only. args: {\"path\": string, \"old_str\": string, \"new_str\": string}. Full-file rewrites are disabled after a valid local artifact exists; use line_edit, replace_def, or replace_range for bounded repairs." @@ -243,6 +248,7 @@ ;; but remove the broad write alias. The edit schema is narrowed ;; below to old_str/new_str so the provider cannot request a rewrite. ((and (local-focused-repair-mode?) + (not (current-pending-ss-create-repair)) (string=? name "write")) #f) ;; After a successful edit, another observation should come from the @@ -303,7 +309,10 @@ ;; expensive failure cycle. ((and (current-verified-local-model?) (rejected-draft-staged-repair-mode?) - (not (verified-staged-repair-tool-spec? spec))) + (not ((if (current-pending-ss-create-repair) + verified-missing-create-staged-tool-spec? + verified-staged-repair-tool-spec?) + spec))) #f) ((not (verified-mcp-tool-spec? spec)) #t) (else @@ -328,7 +337,11 @@ (def (verified-executable-tool-specs specs) (if (and (current-verified-local-model?) (rejected-draft-staged-repair-mode?)) - (filter verified-staged-repair-tool-spec? specs) + (filter + (if (current-pending-ss-create-repair) + verified-missing-create-staged-tool-spec? + verified-staged-repair-tool-spec?) + specs) specs)) (def (tool-specs-include? specs name) @@ -5811,6 +5824,11 @@ (policy-env-paths '("JCODE_VERIFIED_IMMUTABLE_PATHS" "JCODE_IMMUTABLE_PATHS")))) +(def (final-policy-allowed-paths) + (unique-strings + (policy-env-paths + '("JCODE_VERIFIED_ALLOWED_PATHS" "JCODE_ALLOWED_PATHS")))) + (def (final-policy-forbidden-paths) (unique-strings (policy-env-paths @@ -5819,11 +5837,19 @@ (def (policy-path-matches? paths rel) (and (pair? paths) + (string? rel) (write-scope-allows? paths rel))) (def (verified-mutation-policy-error tool cwd path) (let ((rel (scope-path cwd path))) (cond + ((and (string? rel) + (pair? (final-policy-allowed-paths)) + (not (policy-path-matches? (final-policy-allowed-paths) rel))) + (string-append + tool + " refused by verified policy: path is outside allowed paths: " + rel)) ((policy-path-matches? (final-policy-immutable-paths) rel) (string-append tool @@ -5869,10 +5895,12 @@ '())) (def (final-policy-snapshot cwd) - (let* ((immutable (final-policy-immutable-paths)) + (let* ((allowed (final-policy-allowed-paths)) + (immutable (final-policy-immutable-paths)) (forbidden (final-policy-forbidden-paths))) - (and (or (pair? immutable) (pair? forbidden)) + (and (or (pair? allowed) (pair? immutable) (pair? forbidden)) (list + (cons 'allowed allowed) (cons 'immutable (map (lambda (path) (let ((abs (policy-abs-path cwd path))) @@ -5912,13 +5940,47 @@ (loop (cdr items) (if (pair? added) (cons path acc) acc))))))) +(def (git-status-policy-paths cwd) + (guard (_ [else '()]) + (let-values (((stdout _stderr exit-code) + (aproc-run/status + "git status --porcelain --untracked-files=all" + dir: cwd))) + (if (and (= exit-code 0) (string? stdout)) + (let loop ((lines (string-split stdout #\newline)) (acc '())) + (cond + ((null? lines) (reverse acc)) + ((< (string-length (car lines)) 4) (loop (cdr lines) acc)) + (else + (let* ((raw (substring (car lines) 3 (string-length (car lines)))) + (arrow (string-contains raw " -> ")) + (path (if arrow + (substring raw (+ arrow 4) (string-length raw)) + raw))) + (loop (cdr lines) + (if (string=? path "") acc (cons path acc))))))) + '())))) + +(def (disallowed-final-policy-paths snapshot cwd) + (let ((allowed (snapshot-ref snapshot 'allowed))) + (if (pair? allowed) + (filter + (lambda (path) (not (policy-path-matches? allowed path))) + (git-status-policy-paths cwd)) + '()))) + (def (final-policy-error snapshot cwd) (and snapshot - (let ((changed (changed-immutable-paths snapshot cwd)) + (let ((outside (disallowed-final-policy-paths snapshot cwd)) + (changed (changed-immutable-paths snapshot cwd)) (added (new-forbidden-paths snapshot cwd))) - (and (or (pair? changed) (pair? added)) + (and (or (pair? outside) (pair? changed) (pair? added)) (string-append "final policy refused verified result:" + (if (pair? outside) + (string-append " outside allowed paths changed: " + (string-join outside ", ") ".") + "") (if (pair? changed) (string-append " immutable path changed: " (string-join changed ", ") ".") --- a/test/run.ss +++ b/test/run.ss @@ -2770,6 +2770,52 @@ (safe-delete-test-file! forbidden-path) (safe-delete-test-file! target-path)) +(let* ([vr-dir "/tmp/jcode-verified-policy-allowed-repo"] + [target "jcode-verified-policy-only.txt"] + [extra "qt-err.txt"] + [old-allowed (getenv "JCODE_VERIFIED_ALLOWED_PATHS")] + [old-immutable (getenv "JCODE_VERIFIED_IMMUTABLE_PATHS")] + [old-forbidden (getenv "JCODE_VERIFIED_FORBIDDEN_ADDED_PATHS")]) + (run-verify-command + (string-append "rm -rf " vr-dir " && mkdir -p " vr-dir + " && git -C " vr-dir " init -q") + "/tmp") + (dynamic-wind + (lambda () + (putenv "JCODE_VERIFIED_ALLOWED_PATHS" target) + (putenv "JCODE_VERIFIED_IMMUTABLE_PATHS" "") + (putenv "JCODE_VERIFIED_FORBIDDEN_ADDED_PATHS" "")) + (lambda () + (let* ([resp (scripted-responder + (list + (list (make-wtool-call "edit" + (list (cons "path" target) + (cons "content" "ok\n")) #f)) + (list (make-wtool-call "verify" '() #f))))] + [err + (condition->string + (lambda () + (verified-run resp "allowed final paths catch stray artifacts" + (list + (cons 'cwd vr-dir) + (cons 'verify-command + (string-append + "printf artifact > " extra + " && grep -q ok " target)) + (cons 'write-scope (parse-write-scope target)) + (cons 'max-iterations 6) + (cons 'max-tool-errors 0)))))]) + (check-pred! "verified-run: final policy rejects outside allowed add" + err + (lambda (s) + (and (str-contains? s "final policy refused") + (str-contains? s "outside allowed paths") + (str-contains? s extra)))))) + (lambda () + (putenv "JCODE_VERIFIED_ALLOWED_PATHS" (or old-allowed "")) + (putenv "JCODE_VERIFIED_IMMUTABLE_PATHS" (or old-immutable "")) + (putenv "JCODE_VERIFIED_FORBIDDEN_ADDED_PATHS" (or old-forbidden ""))))) + (let* ([vr-dir "/tmp/jcode-verified-tool-policy"] [makefile-path (string-append vr-dir "/Makefile")] [test-dir (string-append vr-dir "/test")] @@ -3513,11 +3559,14 @@ (check-pred! "verified-run: repeated local rejection focuses staged tools" staged-tool-names (lambda (names) - (and (= (length names) 4) + (and (member "edit" names) + (member "write" names) (member "line_edit" names) (member "replace_def" names) (member "replace_range" names) - (member "verify" names)))) + (member "verify" names) + (not (member "read" names)) + (not (member "balance" names))))) (check! "verified-run: local staged line edit promotes repaired file" (slurp target-path) (string-append "(import (jerboa prelude))\n" good-line "\n"))) @@ -3980,8 +4029,8 @@ (cadr observed) 4096) (check! "verified-run: inspected rejected draft repair uses 4k cap" (caddr observed) 4096)) - (check-pred! "verified-run: inspected rejected draft hides broad write" - repair-tool-names (lambda (names) (not (member "write" names)))) + (check-pred! "verified-run: inspected missing draft keeps broad write" + repair-tool-names (lambda (names) (member "write" names))) (check-pred! "verified-run: inspected rejected draft keeps line edit" repair-tool-names (lambda (names) (member "line_edit" names))) (safe-delete-test-file! target-path)) @@ -4021,8 +4070,8 @@ (cons 'max-iterations 8)))]) (check! "verified-run: repeated rejected draft schema repair verifies" result "VERIFIED: exit 0\n")) - (check-pred! "verified-run: repeated rejected draft hides write schema" - tool-names-after-repeat (lambda (names) (not (member "write" names)))) + (check-pred! "verified-run: repeated missing draft keeps write schema" + tool-names-after-repeat (lambda (names) (member "write" names))) (check-pred! "verified-run: repeated rejected draft keeps line edit schema" tool-names-after-repeat (lambda (names) (member "line_edit" names))) (safe-delete-test-file! target-path)) @@ -4057,6 +4106,10 @@ (cons "content" " (displayln \"fixed\"))")) #f))] [else (error 'test "hidden write should be rejected before bounded repair")]))]) (safe-delete-test-file! target-path) + (write-test-output-file target-path + (lambda (o) + (display "(import (jerboa prelude))\n(def (main)\n (displayln \"initial\"))\n" o)) + 'replace) (let ([result (verified-run responder "reject hidden broad writes during staged repair" (list @@ -4090,6 +4143,50 @@ (safe-delete-test-file! target-path)) (let* ([vr-dir "/tmp"] + [target "jcode-local-missing-create-full-write-after-reject.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"] + [good "(import (jerboa prelude))\n(def (main)\n (displayln \"fixed\"))\n"] + [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" good)) #f))] + [else (error 'test "missing create full write should auto-verify")]))]) + (safe-delete-test-file! target-path) + (let ([result + (verified-run responder "allow corrected full write for missing create" + (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 8)))]) + (check! "verified-run: missing create full write after rejects verifies" + result "VERIFIED: exit 0\n")) + (check-pred! "verified-run: missing create staged repair keeps write" + tool-names-after-repeat (lambda (names) (member "write" names))) + (check-pred! "verified-run: missing create staged repair keeps edit" + tool-names-after-repeat (lambda (names) (member "edit" names))) + (check-pred! "verified-run: missing create corrected full write reaches disk" + (call-with-input-file target-path (lambda (p) (get-string-all p))) + (lambda (s) (str-contains? s "fixed"))) + (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"]