Report verified policy status
ober
7c3d37d04f49693b55c2580f848da724e78000f5
--- a/src/jcode/core/verified-run.ss +++ b/src/jcode/core/verified-run.ss @@ -4740,6 +4740,8 @@ 'replace_def)) ((placeholder-only-content? content) (guard-placeholder-content! 'replace_def path content)) + ((verified-mutation-policy-error "replace_def" cwd path) + => (lambda (msg) (error 'replace_def msg))) ((and (not (rejected-draft-content cwd path)) (rejected-draft-hard-recovery-message cwd 'replace_def)) => (lambda (msg) @@ -4810,6 +4812,14 @@ 'replace_range)) ((placeholder-only-content? content) (guard-placeholder-content! 'replace_range path content)) + ((write-scope-error "replace_range" (scope-path cwd path)) + => (lambda (msg) (error 'replace_range msg))) + ((verified-mutation-policy-error "replace_range" cwd path) + => (lambda (msg) (error 'replace_range msg))) + ((path-has-symlink-component? cwd path) + (error 'replace_range + (format "refusing write through symlink path component: ~a" + path))) ((or (<= start-line 0) (< end-line start-line)) (raise-recoverable-tool-error (missing-local-mutation-args-message @@ -4905,6 +4915,8 @@ (guard-placeholder-content! 'edit path (or new-str content))) ((write-scope-error "edit" (scope-path cwd path)) => (lambda (msg) (error 'edit msg))) + ((verified-mutation-policy-error "edit" cwd path) + => (lambda (msg) (error 'edit msg))) ((path-has-symlink-component? cwd path) (error 'edit (format "refusing write through symlink path component: ~a" @@ -5745,6 +5757,36 @@ ((member (car rest) seen) (loop (cdr rest) seen acc)) (else (loop (cdr rest) (cons (car rest) seen) (cons (car rest) acc)))))) +(def (final-policy-immutable-paths) + (unique-strings + (policy-env-paths + '("JCODE_VERIFIED_IMMUTABLE_PATHS" "JCODE_IMMUTABLE_PATHS")))) + +(def (final-policy-forbidden-paths) + (unique-strings + (policy-env-paths + '("JCODE_VERIFIED_FORBIDDEN_ADDED_PATHS" + "JCODE_FORBIDDEN_ADDED_PATHS")))) + +(def (policy-path-matches? paths rel) + (and (pair? paths) + (write-scope-allows? paths rel))) + +(def (verified-mutation-policy-error tool cwd path) + (let ((rel (scope-path cwd path))) + (cond + ((policy-path-matches? (final-policy-immutable-paths) rel) + (string-append + tool + " refused by verified policy: immutable path may not be modified: " + rel)) + ((policy-path-matches? (final-policy-forbidden-paths) rel) + (string-append + tool + " refused by verified policy: forbidden path may not be added or modified: " + rel)) + (else #f)))) + (def (policy-abs-path cwd path) (abs-path cwd (expand-home-path path))) @@ -5778,15 +5820,8 @@ '())) (def (final-policy-snapshot cwd) - (let* ((immutable - (unique-strings - (policy-env-paths - '("JCODE_VERIFIED_IMMUTABLE_PATHS" "JCODE_IMMUTABLE_PATHS")))) - (forbidden - (unique-strings - (policy-env-paths - '("JCODE_VERIFIED_FORBIDDEN_ADDED_PATHS" - "JCODE_FORBIDDEN_ADDED_PATHS"))))) + (let* ((immutable (final-policy-immutable-paths)) + (forbidden (final-policy-forbidden-paths))) (and (or (pair? immutable) (pair? forbidden)) (list (cons 'immutable --- a/src/jcode/ui/cli.ss +++ b/src/jcode/ui/cli.ss @@ -1,6 +1,7 @@ ;;; jcode CLI interface -(export cli-main) +(export cli-main + verified-status) (import :std/misc/string :std/misc/ports @@ -779,11 +780,46 @@ EXAMPLES: (hash-put! ht key val) ht) +(def (status-env-nonempty? name) + (let ((v (getenv name))) + (and v (> (string-length (string-trim v)) 0)))) + +(def (verified-policy-configured?) + (or (status-env-nonempty? "JCODE_VERIFIED_IMMUTABLE_PATHS") + (status-env-nonempty? "JCODE_IMMUTABLE_PATHS") + (status-env-nonempty? "JCODE_VERIFIED_FORBIDDEN_ADDED_PATHS") + (status-env-nonempty? "JCODE_FORBIDDEN_ADDED_PATHS"))) + +(def (verified-final-policy-error-text? msg) + (if (and (string? msg) + (string-contains msg "final policy refused verified result")) + #t + #f)) + +(def (verified-policy-error-text? msg) + (if (and (string? msg) + (or (string-contains msg "verified policy") + (verified-final-policy-error-text? msg))) + #t + #f)) + (def (verified-status ok? task bestof verify-command cwd scope run-aliases? guidance-file status-file summary error-type error-message) - (let ((ht (make-hash-table))) + (let* ((ht (make-hash-table)) + (policy-configured? (verified-policy-configured?)) + (policy-failed? (verified-policy-error-text? error-message)) + (policy-passed? (not policy-failed?)) + (verify-passed? (or ok? (verified-final-policy-error-text? error-message)))) (put-json! ht "ok" ok?) (put-json! ht "status" (if ok? "passed" "failed")) - (put-json! ht "verify_passed" ok?) + (put-json! ht "verify_passed" verify-passed?) + (put-json! ht "policy_configured" policy-configured?) + (put-json! ht "policy_passed" policy-passed?) + (put-json! ht "policy_status" + (cond + (policy-failed? "failed") + (policy-configured? "passed") + (else "not_configured"))) + (put-json! ht "final_valid" ok?) (put-json! ht "exit_code" (if ok? 0 1)) (put-json! ht "exit_reason" (if ok? "verified" (or error-type "error"))) (put-json! ht "error_type" (or error-type #f)) --- a/test/run.ss +++ b/test/run.ss @@ -42,6 +42,7 @@ (jcode core verified) (jcode core best-of-k) (jcode core verified-run) + (jcode ui cli) (jcode proxy convert) (jcode proxy handler) (jcode ui tui-message) @@ -2695,9 +2696,6 @@ (let* ([resp (scripted-responder (list (list (make-wtool-call "edit" - (list (cons "path" seed) - (cons "content" "changed\n")) #f)) - (list (make-wtool-call "edit" (list (cons "path" target) (cons "content" "ok\n")) #f)) (list (make-wtool-call "verify" '() #f))))] @@ -2708,9 +2706,11 @@ (list (cons 'cwd vr-dir) (cons 'verify-command - (string-append "grep -q ok " target)) + (string-append + "printf changed > " seed + " && grep -q ok " target)) (cons 'write-scope - (parse-write-scope (string-append seed "," target))) + (parse-write-scope target)) (cons 'max-iterations 6) (cons 'max-tool-errors 0)))))]) (check-pred! "verified-run: final policy rejects immutable change" @@ -2742,9 +2742,6 @@ (let* ([resp (scripted-responder (list (list (make-wtool-call "edit" - (list (cons "path" forbidden) - (cons "content" "artifact\n")) #f)) - (list (make-wtool-call "edit" (list (cons "path" target) (cons "content" "ok\n")) #f)) (list (make-wtool-call "verify" '() #f))))] @@ -2755,10 +2752,10 @@ (list (cons 'cwd vr-dir) (cons 'verify-command - (string-append "grep -q ok " target)) - (cons 'write-scope - (parse-write-scope - (string-append forbidden "," target))) + (string-append + "printf artifact > " forbidden + " && 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 forbidden add" @@ -2773,6 +2770,111 @@ (safe-delete-test-file! forbidden-path) (safe-delete-test-file! target-path)) +(let* ([vr-dir "/tmp/jcode-verified-tool-policy"] + [makefile-path (string-append vr-dir "/Makefile")] + [test-dir (string-append vr-dir "/test")] + [test-path (string-append test-dir "/run-tests.sh")] + [lib-parent (string-append vr-dir "/lib")] + [lib-dir (string-append vr-dir "/lib/jerboa-qt")] + [lib-path (string-append lib-dir "/qt.sls")] + [old-immutable (getenv "JCODE_VERIFIED_IMMUTABLE_PATHS")] + [old-forbidden (getenv "JCODE_VERIFIED_FORBIDDEN_ADDED_PATHS")]) + (ensure-test-directory! vr-dir) + (ensure-test-directory! test-dir) + (ensure-test-directory! lib-parent) + (ensure-test-directory! lib-dir) + (write-test-output-file makefile-path + (lambda (o) (display "all:\n\t@true\n" o)) + 'replace) + (write-test-output-file test-path + (lambda (o) (display "#!/usr/bin/env bash\nexit 0\n" o)) + 'replace) + (write-test-output-file lib-path + (lambda (o) (display "(def (qt-real) 1)\n" o)) + 'replace) + (dynamic-wind + (lambda () + (putenv "JCODE_VERIFIED_IMMUTABLE_PATHS" "Makefile:test") + (putenv "JCODE_VERIFIED_FORBIDDEN_ADDED_PATHS" "lib")) + (lambda () + (let* ([wf (coding-workflow "true" vr-dir)] + [edit-tool (tool-def-callable (workflow-get-tool-def wf "edit"))] + [write-tool (tool-def-callable (workflow-get-tool-def wf "write"))] + [line-tool (tool-def-callable (workflow-get-tool-def wf "line_edit"))] + [replace-def-tool (tool-def-callable (workflow-get-tool-def wf "replace_def"))] + [replace-range-tool (tool-def-callable (workflow-get-tool-def wf "replace_range"))] + [policy-error? + (lambda (thunk) + (let ([err (condition->string thunk)]) + (and (str-contains? err "verified policy") + (or (str-contains? err "immutable path") + (str-contains? err "forbidden path")))))]) + (check! "verified-run: policy blocks edit on immutable Makefile" + (policy-error? + (lambda () + (edit-tool '(("path" . "Makefile") + ("content" . "changed\n"))))) + #t) + (check! "verified-run: policy blocks write on immutable test" + (policy-error? + (lambda () + (write-tool '(("path" . "test/run-tests.sh") + ("content" . "changed\n"))))) + #t) + (check! "verified-run: policy blocks line_edit on immutable Makefile" + (policy-error? + (lambda () + (line-tool '(("path" . "Makefile") + ("line" . 1) + ("content" . "changed"))))) + #t) + (check! "verified-run: policy blocks replace_def on forbidden dependency" + (policy-error? + (lambda () + (replace-def-tool '(("path" . "lib/jerboa-qt/qt.sls") + ("name" . "qt-real") + ("content" . "(def (qt-real) 2)"))))) + #t) + (check! "verified-run: policy blocks replace_range on immutable Makefile" + (policy-error? + (lambda () + (replace-range-tool '(("path" . "Makefile") + ("start" . 1) + ("end" . 1) + ("content" . "changed"))))) + #t))) + (lambda () + (putenv "JCODE_VERIFIED_IMMUTABLE_PATHS" (or old-immutable "")) + (putenv "JCODE_VERIFIED_FORBIDDEN_ADDED_PATHS" (or old-forbidden ""))))) + +(let* ([old-immutable (getenv "JCODE_VERIFIED_IMMUTABLE_PATHS")] + [old-forbidden (getenv "JCODE_VERIFIED_FORBIDDEN_ADDED_PATHS")]) + (dynamic-wind + (lambda () + (putenv "JCODE_VERIFIED_IMMUTABLE_PATHS" "Makefile") + (putenv "JCODE_VERIFIED_FORBIDDEN_ADDED_PATHS" "lib")) + (lambda () + (let* ([status + (verified-status + #f "policy status" 1 "true" "/tmp" #f #f #f #f #f + "error" + "Exception in verified-final-policy: final policy refused verified result: immutable path changed: Makefile.")] + [lookup (lambda (key) + (hashtable-ref status key 'missing))]) + (check! "verified status records verifier pass under final policy failure" + (lookup "verify_passed") #t) + (check! "verified status records policy configured" + (lookup "policy_configured") #t) + (check! "verified status records policy failure" + (lookup "policy_passed") #f) + (check! "verified status records policy status" + (lookup "policy_status") "failed") + (check! "verified status never final-valid on policy failure" + (lookup "final_valid") #f))) + (lambda () + (putenv "JCODE_VERIFIED_IMMUTABLE_PATHS" (or old-immutable "")) + (putenv "JCODE_VERIFIED_FORBIDDEN_ADDED_PATHS" (or old-forbidden ""))))) + (let* ([vr-dir "/tmp"] [target "jcode-verified-best-of-state.ss"] [target-path (string-append vr-dir "/" target)]