v0.8.3: TUI stabilization — box calls, package fixes, sandbox, configure
Bug fixes: - Fix box() calls: set color-pair before box, pass ACS default chtype integers - Fix markdown functions: move to passepartout.channel-tui package where Croatoan is imported; use add-attributes/remove-attributes instead of :bold/:underline kwargs to add-string; call theme-color in gate-trace-lines to convert theme keys to Croatoan colors - Fix sandbox: remove dex:get/dex:post from restricted symbols (blocked neuro-provider from loading) - Export *log-lock* from passepartout (was unbound in jailed skill packages) - Fix configure: always deploy to XDG, skip cp when source==dest - Fix bash crash handler format string (~~ escaping) - Revert test reorder in 28 files (caused package leakage in skill loader) Design cleanup: - Extract tui-run-screen from tui-main for clean separation - Remove inject-stimulus alias - Merge *backend-registry* into *probabilistic-backends* - Fix read-framed-message whitespace DoS (4096-iteration max) - Add *read-eval* nil to dispatcher-approvals-process read-from-string
This commit is contained in:
@@ -1,185 +1,3 @@
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-pipeline-reason-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:pipeline-reason-suite))
|
||||
|
||||
(in-package :passepartout-pipeline-reason-tests)
|
||||
|
||||
(def-suite pipeline-reason-suite :description "Test suite for Reason pipeline")
|
||||
(in-suite pipeline-reason-suite)
|
||||
|
||||
(test test-decide-gate-safety
|
||||
"Contract 1: cognitive-verify blocks unsafe actions with :LOG rejection."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout::defskill :mock-safety
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx))
|
||||
(if (search "rm -rf" (format nil "~s" action))
|
||||
(list :type :LOG :payload (list :text "Rejected"))
|
||||
action)))
|
||||
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "rm -rf /")))
|
||||
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(result (cognitive-verify candidate signal)))
|
||||
(is (eq :LOG (getf result :type)))))
|
||||
|
||||
(test test-cognitive-verify-pass-through
|
||||
"Contract 1: safe actions pass through cognitive-verify unchanged."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout::defskill :mock-passthrough
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx))
|
||||
action))
|
||||
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "echo hello")))
|
||||
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(result (cognitive-verify candidate signal)))
|
||||
(is (eq :REQUEST (getf result :type)))
|
||||
(is (equal (getf candidate :payload) (getf result :payload)))
|
||||
(is (getf result :gate-trace))))
|
||||
|
||||
(test test-cognitive-verify-empty-registry
|
||||
"Contract 1: with no gates registered, action passes through unchanged."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "ls")))
|
||||
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(result (cognitive-verify candidate signal)))
|
||||
(is (eq :REQUEST (getf result :type)))
|
||||
(is (equal (getf candidate :payload) (getf result :payload)))))
|
||||
|
||||
(test test-cognitive-verify-approval-required
|
||||
"Contract 1: gate returning :approval-required produces an approval event."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout::defskill :mock-approval
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx))
|
||||
(list :type :EVENT :level :approval-required
|
||||
:payload (list :action action))))
|
||||
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "sudo reboot")))
|
||||
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(result (cognitive-verify candidate signal)))
|
||||
(is (eq :approval-required (getf result :level)))
|
||||
(is (eq :EVENT (getf result :type)))))
|
||||
|
||||
(test test-loop-gate-reason-passthrough
|
||||
"Contract 2: non-user-input sensors pass through loop-gate-reason unchanged."
|
||||
(let* ((signal '(:type :EVENT :payload (:sensor :heartbeat) :meta (:source :system)))
|
||||
(result (loop-gate-reason signal)))
|
||||
(is (not (null result)))))
|
||||
|
||||
(test test-loop-gate-reason-sets-status
|
||||
"Contract 2: loop-gate-reason sets :status on :user-input signals."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((passepartout::*provider-cascade* nil)
|
||||
(signal (list :type :EVENT :payload (list :sensor :user-input :text "test")))
|
||||
(result (loop-gate-reason signal)))
|
||||
(is (member (getf result :status) '(:reasoned :requires-approval)))))
|
||||
|
||||
(test test-backend-cascade-no-backends
|
||||
"Contract 4: empty cascade returns :LOG failure."
|
||||
(let* ((passepartout::*provider-cascade* nil)
|
||||
(passepartout::*probabilistic-backends* (make-hash-table :test 'equal))
|
||||
(result (backend-cascade-call "test" :cascade '())))
|
||||
(is (eq :LOG (getf result :type)))
|
||||
(is (search "exhausted" (getf (getf result :payload) :text) :test #'char-equal))))
|
||||
|
||||
(test test-backend-cascade-with-mock
|
||||
"Contract 4: backend-cascade-call returns content from first successful backend."
|
||||
(let ((passepartout::*probabilistic-backends* (make-hash-table :test 'equal)))
|
||||
(setf (gethash :mock-backend passepartout::*probabilistic-backends*)
|
||||
(lambda (prompt sp &key model)
|
||||
(declare (ignore prompt sp model))
|
||||
(list :status :success :content "mock-response")))
|
||||
(let ((result (backend-cascade-call "hello" :cascade '(:mock-backend))))
|
||||
(is (string= "mock-response" result)))))
|
||||
|
||||
(test test-read-eval-rce-blocked
|
||||
"Contract 1/v0.3.1: #. reader macro in LLM output must not execute arbitrary code."
|
||||
(let ((passepartout::*probabilistic-backends* (make-hash-table :test 'equal))
|
||||
(passepartout::*provider-cascade* '(:mock-evil)))
|
||||
(setf (gethash :mock-evil passepartout::*probabilistic-backends*)
|
||||
(lambda (prompt sp &key model)
|
||||
(declare (ignore prompt sp model))
|
||||
(list :status :success :content "(#.(setf passepartout::*v031-rce-test* :PWNED))")))
|
||||
(setf passepartout::*v031-rce-test* nil)
|
||||
(setf *read-eval* t)
|
||||
(let* ((ctx (list :type :EVENT :payload (list :sensor :user-input :text "test") :depth 0))
|
||||
(result (passepartout::think ctx)))
|
||||
(is (not (eq passepartout::*v031-rce-test* :PWNED)))
|
||||
(is (eq :REQUEST (getf result :TYPE)))
|
||||
(setf *read-eval* nil))))
|
||||
|
||||
(test test-json-alist-to-plist-simple
|
||||
"Contract 5: converts simple alist to keyword plist."
|
||||
(let ((alist (list (cons "action" "shell") (cons "cmd" "echo hello"))))
|
||||
(let ((result (json-alist-to-plist alist)))
|
||||
(is (eq :ACTION (first result)))
|
||||
(is (string= "shell" (second result)))
|
||||
(is (eq :CMD (third result)))
|
||||
(is (string= "echo hello" (fourth result))))))
|
||||
|
||||
(test test-json-alist-to-plist-nested
|
||||
"Contract 5: nested alists recurse into nested plists."
|
||||
(let ((alist (list (cons "tool" "write-file")
|
||||
(cons "args" (list (cons "filepath" "/tmp/x")
|
||||
(cons "content" "hi"))))))
|
||||
(let ((result (json-alist-to-plist alist)))
|
||||
(is (eq :TOOL (first result)))
|
||||
(is (eq :ARGS (third result)))
|
||||
(let ((inner (fourth result)))
|
||||
(is (eq :FILEPATH (first inner)))
|
||||
(is (string= "/tmp/x" (second inner)))
|
||||
(is (eq :CONTENT (third inner)))))))
|
||||
|
||||
(test test-json-alist-to-plist-array-passthrough
|
||||
"Contract 5: JSON arrays pass through unchanged."
|
||||
(let ((alist (list (cons "names" (list "alice" "bob")))))
|
||||
(let ((result (json-alist-to-plist alist)))
|
||||
(is (eq :NAMES (first result)))
|
||||
(is (equal (list "alice" "bob") (second result))))))
|
||||
|
||||
(test test-json-alist-to-plist-null
|
||||
"Contract 5: nil passes through unchanged."
|
||||
(let ((result (json-alist-to-plist nil)))
|
||||
(is (null result))))
|
||||
|
||||
(test test-json-alist-to-plist-scalar
|
||||
"Contract 5: scalar values pass through."
|
||||
(let ((alist (list (cons "count" 42) (cons "active" :true))))
|
||||
(let ((result (json-alist-to-plist alist)))
|
||||
(is (eq :COUNT (first result)))
|
||||
(is (= 42 (second result)))
|
||||
(is (eq :ACTIVE (third result)))
|
||||
(is (eq :true (fourth result))))))
|
||||
|
||||
(test test-assemble-config-section
|
||||
"Contract v0.7.2: config section contains Passepartout and version."
|
||||
(let ((section (passepartout::assemble-config-section)))
|
||||
(is (stringp section))
|
||||
(is (search "Passepartout" section))
|
||||
(is (search "v0.7.2" section))
|
||||
(is (search "Security gates" section))))
|
||||
|
||||
(test test-think-snapshots-before-llm
|
||||
"Contract v0.7.2: think() snapshots memory before LLM call."
|
||||
(let ((passepartout::*memory-snapshots* nil)
|
||||
(passepartout::*memory-store* (make-hash-table :test 'equal)))
|
||||
(setf (gethash "pre" passepartout::*memory-store*) "value")
|
||||
(let ((passepartout::*probabilistic-backends* (make-hash-table :test 'equal))
|
||||
(passepartout::*provider-cascade* nil))
|
||||
(handler-case
|
||||
(let* ((ctx (list :type :EVENT :payload (list :sensor :user-input :text "hi") :depth 0))
|
||||
(result (passepartout::think ctx)))
|
||||
(declare (ignore result)))
|
||||
(error (c) (format nil "Expected: ~a" c)))
|
||||
(is (>= (length passepartout::*memory-snapshots*) 0)))))
|
||||
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *probabilistic-backends* (make-hash-table :test 'equal)
|
||||
@@ -506,3 +324,185 @@ sorted by priority (highest first). Returns a rejection plist or the action."
|
||||
|
||||
(defun reason-gate (signal)
|
||||
(loop-gate-reason signal))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-pipeline-reason-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:pipeline-reason-suite))
|
||||
|
||||
(in-package :passepartout-pipeline-reason-tests)
|
||||
|
||||
(def-suite pipeline-reason-suite :description "Test suite for Reason pipeline")
|
||||
(in-suite pipeline-reason-suite)
|
||||
|
||||
(test test-decide-gate-safety
|
||||
"Contract 1: cognitive-verify blocks unsafe actions with :LOG rejection."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout::defskill :mock-safety
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx))
|
||||
(if (search "rm -rf" (format nil "~s" action))
|
||||
(list :type :LOG :payload (list :text "Rejected"))
|
||||
action)))
|
||||
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "rm -rf /")))
|
||||
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(result (cognitive-verify candidate signal)))
|
||||
(is (eq :LOG (getf result :type)))))
|
||||
|
||||
(test test-cognitive-verify-pass-through
|
||||
"Contract 1: safe actions pass through cognitive-verify unchanged."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout::defskill :mock-passthrough
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx))
|
||||
action))
|
||||
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "echo hello")))
|
||||
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(result (cognitive-verify candidate signal)))
|
||||
(is (eq :REQUEST (getf result :type)))
|
||||
(is (equal (getf candidate :payload) (getf result :payload)))
|
||||
(is (getf result :gate-trace))))
|
||||
|
||||
(test test-cognitive-verify-empty-registry
|
||||
"Contract 1: with no gates registered, action passes through unchanged."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "ls")))
|
||||
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(result (cognitive-verify candidate signal)))
|
||||
(is (eq :REQUEST (getf result :type)))
|
||||
(is (equal (getf candidate :payload) (getf result :payload)))))
|
||||
|
||||
(test test-cognitive-verify-approval-required
|
||||
"Contract 1: gate returning :approval-required produces an approval event."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout::defskill :mock-approval
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx))
|
||||
(list :type :EVENT :level :approval-required
|
||||
:payload (list :action action))))
|
||||
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "sudo reboot")))
|
||||
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(result (cognitive-verify candidate signal)))
|
||||
(is (eq :approval-required (getf result :level)))
|
||||
(is (eq :EVENT (getf result :type)))))
|
||||
|
||||
(test test-loop-gate-reason-passthrough
|
||||
"Contract 2: non-user-input sensors pass through loop-gate-reason unchanged."
|
||||
(let* ((signal '(:type :EVENT :payload (:sensor :heartbeat) :meta (:source :system)))
|
||||
(result (loop-gate-reason signal)))
|
||||
(is (not (null result)))))
|
||||
|
||||
(test test-loop-gate-reason-sets-status
|
||||
"Contract 2: loop-gate-reason sets :status on :user-input signals."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((passepartout::*provider-cascade* nil)
|
||||
(signal (list :type :EVENT :payload (list :sensor :user-input :text "test")))
|
||||
(result (loop-gate-reason signal)))
|
||||
(is (member (getf result :status) '(:reasoned :requires-approval)))))
|
||||
|
||||
(test test-backend-cascade-no-backends
|
||||
"Contract 4: empty cascade returns :LOG failure."
|
||||
(let* ((passepartout::*provider-cascade* nil)
|
||||
(passepartout::*probabilistic-backends* (make-hash-table :test 'equal))
|
||||
(result (backend-cascade-call "test" :cascade '())))
|
||||
(is (eq :LOG (getf result :type)))
|
||||
(is (search "exhausted" (getf (getf result :payload) :text) :test #'char-equal))))
|
||||
|
||||
(test test-backend-cascade-with-mock
|
||||
"Contract 4: backend-cascade-call returns content from first successful backend."
|
||||
(let ((passepartout::*probabilistic-backends* (make-hash-table :test 'equal)))
|
||||
(setf (gethash :mock-backend passepartout::*probabilistic-backends*)
|
||||
(lambda (prompt sp &key model)
|
||||
(declare (ignore prompt sp model))
|
||||
(list :status :success :content "mock-response")))
|
||||
(let ((result (backend-cascade-call "hello" :cascade '(:mock-backend))))
|
||||
(is (string= "mock-response" result)))))
|
||||
|
||||
(test test-read-eval-rce-blocked
|
||||
"Contract 1/v0.3.1: #. reader macro in LLM output must not execute arbitrary code."
|
||||
(let ((passepartout::*probabilistic-backends* (make-hash-table :test 'equal))
|
||||
(passepartout::*provider-cascade* '(:mock-evil)))
|
||||
(setf (gethash :mock-evil passepartout::*probabilistic-backends*)
|
||||
(lambda (prompt sp &key model)
|
||||
(declare (ignore prompt sp model))
|
||||
(list :status :success :content "(#.(setf passepartout::*v031-rce-test* :PWNED))")))
|
||||
(setf passepartout::*v031-rce-test* nil)
|
||||
(setf *read-eval* t)
|
||||
(let* ((ctx (list :type :EVENT :payload (list :sensor :user-input :text "test") :depth 0))
|
||||
(result (passepartout::think ctx)))
|
||||
(is (not (eq passepartout::*v031-rce-test* :PWNED)))
|
||||
(is (eq :REQUEST (getf result :TYPE)))
|
||||
(setf *read-eval* nil))))
|
||||
|
||||
(test test-json-alist-to-plist-simple
|
||||
"Contract 5: converts simple alist to keyword plist."
|
||||
(let ((alist (list (cons "action" "shell") (cons "cmd" "echo hello"))))
|
||||
(let ((result (json-alist-to-plist alist)))
|
||||
(is (eq :ACTION (first result)))
|
||||
(is (string= "shell" (second result)))
|
||||
(is (eq :CMD (third result)))
|
||||
(is (string= "echo hello" (fourth result))))))
|
||||
|
||||
(test test-json-alist-to-plist-nested
|
||||
"Contract 5: nested alists recurse into nested plists."
|
||||
(let ((alist (list (cons "tool" "write-file")
|
||||
(cons "args" (list (cons "filepath" "/tmp/x")
|
||||
(cons "content" "hi"))))))
|
||||
(let ((result (json-alist-to-plist alist)))
|
||||
(is (eq :TOOL (first result)))
|
||||
(is (eq :ARGS (third result)))
|
||||
(let ((inner (fourth result)))
|
||||
(is (eq :FILEPATH (first inner)))
|
||||
(is (string= "/tmp/x" (second inner)))
|
||||
(is (eq :CONTENT (third inner)))))))
|
||||
|
||||
(test test-json-alist-to-plist-array-passthrough
|
||||
"Contract 5: JSON arrays pass through unchanged."
|
||||
(let ((alist (list (cons "names" (list "alice" "bob")))))
|
||||
(let ((result (json-alist-to-plist alist)))
|
||||
(is (eq :NAMES (first result)))
|
||||
(is (equal (list "alice" "bob") (second result))))))
|
||||
|
||||
(test test-json-alist-to-plist-null
|
||||
"Contract 5: nil passes through unchanged."
|
||||
(let ((result (json-alist-to-plist nil)))
|
||||
(is (null result))))
|
||||
|
||||
(test test-json-alist-to-plist-scalar
|
||||
"Contract 5: scalar values pass through."
|
||||
(let ((alist (list (cons "count" 42) (cons "active" :true))))
|
||||
(let ((result (json-alist-to-plist alist)))
|
||||
(is (eq :COUNT (first result)))
|
||||
(is (= 42 (second result)))
|
||||
(is (eq :ACTIVE (third result)))
|
||||
(is (eq :true (fourth result))))))
|
||||
|
||||
(test test-assemble-config-section
|
||||
"Contract v0.7.2: config section contains Passepartout and version."
|
||||
(let ((section (passepartout::assemble-config-section)))
|
||||
(is (stringp section))
|
||||
(is (search "Passepartout" section))
|
||||
(is (search "v0.7.2" section))
|
||||
(is (search "Security gates" section))))
|
||||
|
||||
(test test-think-snapshots-before-llm
|
||||
"Contract v0.7.2: think() snapshots memory before LLM call."
|
||||
(let ((passepartout::*memory-snapshots* nil)
|
||||
(passepartout::*memory-store* (make-hash-table :test 'equal)))
|
||||
(setf (gethash "pre" passepartout::*memory-store*) "value")
|
||||
(let ((passepartout::*probabilistic-backends* (make-hash-table :test 'equal))
|
||||
(passepartout::*provider-cascade* nil))
|
||||
(handler-case
|
||||
(let* ((ctx (list :type :EVENT :payload (list :sensor :user-input :text "hi") :depth 0))
|
||||
(result (passepartout::think ctx)))
|
||||
(declare (ignore result)))
|
||||
(error (c) (format nil "Expected: ~a" c)))
|
||||
(is (>= (length passepartout::*memory-snapshots*) 0)))))
|
||||
|
||||
Reference in New Issue
Block a user