v0.7.2: wire tag severity into dispatcher-check — TDD

dispatcher-privacy-severity replaces binary dispatcher-check-privacy-tags.
Three-tier: :block (reject), :warn (log+allow), :log (silent).
Wired into dispatcher-check vector 5.

- security-dispatcher: dispatcher-privacy-severity fn, +3 tests
  Updated vector 5 in dispatcher-check with severity branching.
- Core: 88/88
This commit is contained in:
2026-05-08 19:35:17 -04:00
parent 44f927e8f1
commit 510643786b
2 changed files with 84 additions and 12 deletions

View File

@@ -130,6 +130,18 @@ Severity: :block (filter), :warn (log+include), :log (silent record).")
"Return the severity keyword for TAG, or NIL if not found."
(cdr (assoc tag *tag-categories* :test #'string-equal)))
(defun dispatcher-privacy-severity (tags-list)
"Return the highest-severity tag match: :block > :warn > :log, or nil."
(when (and tags-list (listp tags-list))
(let ((highest nil))
(dolist (tag tags-list)
(let ((sev (tag-category-severity tag)))
(when (or (eq sev :block)
(and (eq sev :warn) (not (eq highest :block)))
(and (eq sev :log) (null highest)))
(setf highest sev))))
highest)))
(tag-categories-load)
(defun dispatcher-check-text-for-privacy (text)
@@ -306,12 +318,21 @@ Eleven checks: 0=REPL-lint (warn-only), 1=lisp-validation, 2=secret-path,
:payload (list :level :error
:text (format nil "Action blocked: Potential exposure of '~a'" secret-name)))))
;; Vector 5: Privacy-tagged content in action
((and tags (dispatcher-check-privacy-tags tags))
(log-message "PRIVACY VIOLATION: Action contains privacy-tagged content")
(list :type :LOG
:payload (list :level :warn
:text "Action blocked: Content tagged with privacy filter.")))
;; Vector 5: Privacy-tagged content (severity tiers)
((and tags (fboundp 'dispatcher-privacy-severity))
(let ((severity (dispatcher-privacy-severity tags)))
(cond
((eq severity :block)
(log-message "PRIVACY VIOLATION: Blocked by @tag — ~a" tags)
(list :type :LOG
:payload (list :level :error
:text (format nil "Action blocked: Content tagged with privacy filter (~a)." tags))))
((eq severity :warn)
(log-message "PRIVACY WARNING: @tag ~a (allowed with warning)" tags)
action)
((eq severity :log)
(log-message "PRIVACY: @tag ~a (logged)" tags)
action))))
;; Vector 6: Text leaks privacy tag names
((and text (dispatcher-check-text-for-privacy text))
@@ -568,6 +589,21 @@ Recognized formats:
"Contract v0.7.2: unknown tag returns nil."
(is (null (passepartout::tag-category-severity "@nonexistent-xxxx"))))
(test test-privacy-severity-block
"v0.7.2: dispatcher-privacy-severity returns :block for block-tagged content."
(setf passepartout::*tag-categories* '(("@personal" . :block)))
(is (eq :block (passepartout::dispatcher-privacy-severity '("@personal")))))
(test test-privacy-severity-warn
"v0.7.2: dispatcher-privacy-severity returns :warn for warn-tagged content."
(setf passepartout::*tag-categories* '(("@draft" . :warn)))
(is (eq :warn (passepartout::dispatcher-privacy-severity '("@draft")))))
(test test-privacy-severity-nil
"v0.7.2: dispatcher-privacy-severity returns nil for untagged content."
(setf passepartout::*tag-categories* nil)
(is (null (passepartout::dispatcher-privacy-severity '("public")))))
(test test-safe-tool-read-only-auto-approve
"Contract v0.7.2: read-only tools pass dispatcher-check unconditionally."
(setf (gethash "test-ro-tool" passepartout::*cognitive-tool-registry*)