51 lines
2.1 KiB
Common Lisp
51 lines
2.1 KiB
Common Lisp
(in-package :passepartout)
|
|
|
|
(defun policy-compliance-check (action context)
|
|
"Enforces constitutional invariants on proposed actions."
|
|
(declare (ignore context))
|
|
(let* ((payload (proto-get action :payload))
|
|
(explanation (proto-get payload :explanation)))
|
|
(if (and explanation (stringp explanation) (> (length explanation) 10))
|
|
action
|
|
(progn
|
|
(log-message "POLICY VIOLATION: Action lacks sufficient explanation.")
|
|
(list :type :LOG
|
|
:payload (list :level :warn
|
|
:text "Action blocked: Missing or insufficient :explanation. Please justify your reasoning."))))))
|
|
|
|
(defskill :passepartout-security-policy
|
|
:priority 500
|
|
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
|
:deterministic #'policy-compliance-check)
|
|
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(ql:quickload :fiveam :silent t))
|
|
|
|
(defpackage :passepartout-security-policy-tests
|
|
(:use :cl :fiveam :passepartout)
|
|
(:export #:policy-suite))
|
|
|
|
(in-package :passepartout-security-policy-tests)
|
|
|
|
(def-suite policy-suite :description "Verification of the Constitutional Policy Layer")
|
|
(in-suite policy-suite)
|
|
|
|
(test test-policy-passes-valid-explanation
|
|
"Contract 1: action with sufficient explanation passes through unchanged."
|
|
(let* ((action '(:type :REQUEST :payload (:action :read :explanation "The user asked me to read the TODO list for today.")))
|
|
(result (policy-compliance-check action nil)))
|
|
(is (equal action result))))
|
|
|
|
(test test-policy-rejects-short-explanation
|
|
"Contract 1: action with explanation ≤10 characters is rejected with :LOG."
|
|
(let* ((action '(:type :REQUEST :payload (:action :read :explanation "hi")))
|
|
(result (policy-compliance-check action nil)))
|
|
(is (eq :LOG (getf result :type)))
|
|
(is (search "blocked" (getf (getf result :payload) :text) :test #'char-equal))))
|
|
|
|
(test test-policy-rejects-missing-explanation
|
|
"Contract 1: action without :explanation is rejected."
|
|
(let* ((action '(:type :REQUEST :payload (:action :read)))
|
|
(result (policy-compliance-check action nil)))
|
|
(is (eq :LOG (getf result :type)))))
|