diff --git a/lisp/security-dispatcher.lisp b/lisp/security-dispatcher.lisp index c011391..3e35cb0 100644 --- a/lisp/security-dispatcher.lisp +++ b/lisp/security-dispatcher.lisp @@ -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*) diff --git a/org/security-dispatcher.org b/org/security-dispatcher.org index ebe52a2..231248a 100644 --- a/org/security-dispatcher.org +++ b/org/security-dispatcher.org @@ -266,6 +266,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) #+end_src ** dispatcher-check-text-for-privacy @@ -480,12 +492,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)) @@ -811,6 +832,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*)