v0.8.2: cleanup + prose + structure + decomposition + budget + errors
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:
@@ -56,6 +56,212 @@ This is not a cosmetic choice. It means the reasoning pipeline can generate, mod
|
||||
String keys → upcased keywords. Nested alists recurse into plists.
|
||||
JSON arrays (lists whose first element is not a cons) pass through.
|
||||
Scalars and nil pass through.
|
||||
6. (think-assemble-prompt context): returns three values —
|
||||
~system-prompt~ (the full prompt string), ~raw-prompt~ (user text or
|
||||
skill-generated), and ~reply-stream~ (for streaming responses).
|
||||
Handles all conditional assembly paths: TIME section, CONFIG section,
|
||||
IDENTITY (assistant name + identity file + standing mandates +
|
||||
reflection feedback), TOOLS, CONTEXT, LOGS. Gracefully degrades when
|
||||
awareness or token-economics skills are not loaded.
|
||||
7. (think-call-llm raw-prompt system-prompt reply-stream context): calls
|
||||
the LLM. Checks session budget exhaustion before dispatching
|
||||
(v0.5.0 deferred, ~fboundp~-guarded). Uses streaming
|
||||
(~cascade-stream~) when reply-stream is non-nil and the streaming
|
||||
module is loaded; falls back to ~backend-cascade-call~ otherwise.
|
||||
Returns the raw thought (string or plist with ~:tool-calls~) or
|
||||
a budget-exhaustion message.
|
||||
8. (think-parse-response thought): parses the LLM response into an action
|
||||
plist. Handles three paths: structured ~:tool-calls~ (convert JSON args
|
||||
to plist via ~json-alist-to-plist~), raw S-expression text (parse with
|
||||
~*read-eval* nil~, normalize keywords), and plain text (wrap as
|
||||
~:MESSAGE~ action). Tracks cost via ~cost-track-backend-call~ when
|
||||
available. Guarantees a valid plist for any input.
|
||||
|
||||
* Test Suite
|
||||
Verifies that the deterministic engine correctly rejects unsafe actions (like ~rm -rf /~) while allowing safe ones.
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-pipeline-reason-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:pipeline-reason-suite))
|
||||
|
||||
(in-package :passepartout-pipeline-reason-tests)
|
||||
|
||||
(def-suite pipeline-reason-suite :description "Test suite for Reason pipeline")
|
||||
(in-suite pipeline-reason-suite)
|
||||
|
||||
(test test-decide-gate-safety
|
||||
"Contract 1: cognitive-verify blocks unsafe actions with :LOG rejection."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout::defskill :mock-safety
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx))
|
||||
(if (search "rm -rf" (format nil "~s" action))
|
||||
(list :type :LOG :payload (list :text "Rejected"))
|
||||
action)))
|
||||
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "rm -rf /")))
|
||||
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(result (cognitive-verify candidate signal)))
|
||||
(is (eq :LOG (getf result :type)))))
|
||||
|
||||
(test test-cognitive-verify-pass-through
|
||||
"Contract 1: safe actions pass through cognitive-verify unchanged."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout::defskill :mock-passthrough
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx))
|
||||
action))
|
||||
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "echo hello")))
|
||||
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(result (cognitive-verify candidate signal)))
|
||||
(is (eq :REQUEST (getf result :type)))
|
||||
(is (equal (getf candidate :payload) (getf result :payload)))
|
||||
(is (getf result :gate-trace))))
|
||||
|
||||
(test test-cognitive-verify-empty-registry
|
||||
"Contract 1: with no gates registered, action passes through unchanged."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "ls")))
|
||||
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(result (cognitive-verify candidate signal)))
|
||||
(is (eq :REQUEST (getf result :type)))
|
||||
(is (equal (getf candidate :payload) (getf result :payload)))))
|
||||
|
||||
(test test-cognitive-verify-approval-required
|
||||
"Contract 1: gate returning :approval-required produces an approval event."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout::defskill :mock-approval
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx))
|
||||
(list :type :EVENT :level :approval-required
|
||||
:payload (list :action action))))
|
||||
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "sudo reboot")))
|
||||
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(result (cognitive-verify candidate signal)))
|
||||
(is (eq :approval-required (getf result :level)))
|
||||
(is (eq :EVENT (getf result :type)))))
|
||||
|
||||
(test test-loop-gate-reason-passthrough
|
||||
"Contract 2: non-user-input sensors pass through loop-gate-reason unchanged."
|
||||
(let* ((signal '(:type :EVENT :payload (:sensor :heartbeat) :meta (:source :system)))
|
||||
(result (loop-gate-reason signal)))
|
||||
(is (not (null result)))))
|
||||
|
||||
(test test-loop-gate-reason-sets-status
|
||||
"Contract 2: loop-gate-reason sets :status on :user-input signals."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((passepartout::*provider-cascade* nil)
|
||||
(signal (list :type :EVENT :payload (list :sensor :user-input :text "test")))
|
||||
(result (loop-gate-reason signal)))
|
||||
(is (member (getf result :status) '(:reasoned :requires-approval)))))
|
||||
|
||||
(test test-backend-cascade-no-backends
|
||||
"Contract 4: empty cascade returns :LOG failure."
|
||||
(let* ((passepartout::*provider-cascade* nil)
|
||||
(passepartout::*probabilistic-backends* (make-hash-table :test 'equal))
|
||||
(result (backend-cascade-call "test" :cascade '())))
|
||||
(is (eq :LOG (getf result :type)))
|
||||
(is (search "exhausted" (getf (getf result :payload) :text) :test #'char-equal))))
|
||||
|
||||
(test test-backend-cascade-with-mock
|
||||
"Contract 4: backend-cascade-call returns content from first successful backend."
|
||||
(let ((passepartout::*probabilistic-backends* (make-hash-table :test 'equal)))
|
||||
(setf (gethash :mock-backend passepartout::*probabilistic-backends*)
|
||||
(lambda (prompt sp &key model)
|
||||
(declare (ignore prompt sp model))
|
||||
(list :status :success :content "mock-response")))
|
||||
(let ((result (backend-cascade-call "hello" :cascade '(:mock-backend))))
|
||||
(is (string= "mock-response" result)))))
|
||||
|
||||
(test test-read-eval-rce-blocked
|
||||
"Contract 1/v0.3.1: #. reader macro in LLM output must not execute arbitrary code."
|
||||
(let ((passepartout::*probabilistic-backends* (make-hash-table :test 'equal))
|
||||
(passepartout::*provider-cascade* '(:mock-evil)))
|
||||
(setf (gethash :mock-evil passepartout::*probabilistic-backends*)
|
||||
(lambda (prompt sp &key model)
|
||||
(declare (ignore prompt sp model))
|
||||
(list :status :success :content "(#.(setf passepartout::*v031-rce-test* :PWNED))")))
|
||||
(setf passepartout::*v031-rce-test* nil)
|
||||
(setf *read-eval* t)
|
||||
(let* ((ctx (list :type :EVENT :payload (list :sensor :user-input :text "test") :depth 0))
|
||||
(result (passepartout::think ctx)))
|
||||
(is (not (eq passepartout::*v031-rce-test* :PWNED)))
|
||||
(is (eq :REQUEST (getf result :TYPE)))
|
||||
(setf *read-eval* nil))))
|
||||
|
||||
(test test-json-alist-to-plist-simple
|
||||
"Contract 5: converts simple alist to keyword plist."
|
||||
(let ((alist (list (cons "action" "shell") (cons "cmd" "echo hello"))))
|
||||
(let ((result (json-alist-to-plist alist)))
|
||||
(is (eq :ACTION (first result)))
|
||||
(is (string= "shell" (second result)))
|
||||
(is (eq :CMD (third result)))
|
||||
(is (string= "echo hello" (fourth result))))))
|
||||
|
||||
(test test-json-alist-to-plist-nested
|
||||
"Contract 5: nested alists recurse into nested plists."
|
||||
(let ((alist (list (cons "tool" "write-file")
|
||||
(cons "args" (list (cons "filepath" "/tmp/x")
|
||||
(cons "content" "hi"))))))
|
||||
(let ((result (json-alist-to-plist alist)))
|
||||
(is (eq :TOOL (first result)))
|
||||
(is (eq :ARGS (third result)))
|
||||
(let ((inner (fourth result)))
|
||||
(is (eq :FILEPATH (first inner)))
|
||||
(is (string= "/tmp/x" (second inner)))
|
||||
(is (eq :CONTENT (third inner)))))))
|
||||
|
||||
(test test-json-alist-to-plist-array-passthrough
|
||||
"Contract 5: JSON arrays pass through unchanged."
|
||||
(let ((alist (list (cons "names" (list "alice" "bob")))))
|
||||
(let ((result (json-alist-to-plist alist)))
|
||||
(is (eq :NAMES (first result)))
|
||||
(is (equal (list "alice" "bob") (second result))))))
|
||||
|
||||
(test test-json-alist-to-plist-null
|
||||
"Contract 5: nil passes through unchanged."
|
||||
(let ((result (json-alist-to-plist nil)))
|
||||
(is (null result))))
|
||||
|
||||
(test test-json-alist-to-plist-scalar
|
||||
"Contract 5: scalar values pass through."
|
||||
(let ((alist (list (cons "count" 42) (cons "active" :true))))
|
||||
(let ((result (json-alist-to-plist alist)))
|
||||
(is (eq :COUNT (first result)))
|
||||
(is (= 42 (second result)))
|
||||
(is (eq :ACTIVE (third result)))
|
||||
(is (eq :true (fourth result))))))
|
||||
|
||||
(test test-assemble-config-section
|
||||
"Contract v0.7.2: config section contains Passepartout and version."
|
||||
(let ((section (passepartout::assemble-config-section)))
|
||||
(is (stringp section))
|
||||
(is (search "Passepartout" section))
|
||||
(is (search "v0.7.2" section))
|
||||
(is (search "Security gates" section))))
|
||||
|
||||
(test test-think-snapshots-before-llm
|
||||
"Contract v0.7.2: think() snapshots memory before LLM call."
|
||||
(let ((passepartout::*memory-snapshots* nil)
|
||||
(passepartout::*memory-store* (make-hash-table :test 'equal)))
|
||||
(setf (gethash "pre" passepartout::*memory-store*) "value")
|
||||
(let ((passepartout::*probabilistic-backends* (make-hash-table :test 'equal))
|
||||
(passepartout::*provider-cascade* nil))
|
||||
(handler-case
|
||||
(let* ((ctx (list :type :EVENT :payload (list :sensor :user-input :text "hi") :depth 0))
|
||||
(result (passepartout::think ctx)))
|
||||
(declare (ignore result)))
|
||||
(error (c) (format nil "Expected: ~a" c)))
|
||||
(is (>= (length passepartout::*memory-snapshots*) 0)))))
|
||||
#+end_src
|
||||
|
||||
* Implementation
|
||||
|
||||
@@ -80,16 +286,11 @@ Skills like system-model-provider register into this table at boot time.
|
||||
(setf (gethash name *probabilistic-backends*) fn))
|
||||
#+end_src
|
||||
|
||||
The probabilistic engine maintains four pieces of global state that control how LLM requests are dispatched:
|
||||
The probabilistic engine maintains three pieces of global state that control how LLM requests are dispatched:
|
||||
|
||||
~*backend-registry*~ is a hash table mapping provider keywords (like ~:ollama~ or ~:openrouter~) to the actual function that calls that provider's API. ~*provider-cascade*~ is the ordered list of providers to try — if the first one fails, the cascade falls through to the next. ~*model-selector*~ is an optional function that examines the context and picks a model per request (useful for routing simple questions to a small fast model and complex reasoning to a large expensive one). ~*consensus-enabled*~ toggles multi-provider agreement, where multiple LLMs run the same prompt and the system waits for consensus.
|
||||
~*provider-cascade*~ is the ordered list of providers to try — if the first one fails, the cascade falls through to the next. ~*model-selector*~ is an optional function that examines the context and picks a model per request (useful for routing simple questions to a small fast model and complex reasoning to a large expensive one). ~*consensus-enabled*~ toggles multi-provider agreement, where multiple LLMs run the same prompt and the system waits for consensus.
|
||||
|
||||
These variables are configurable at runtime. The cascade can be changed without restart: (setf *provider-cascade* (quote (:ollama :openrouter))).
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defvar *backend-registry* (make-hash-table :test 'equal))
|
||||
#+end_src
|
||||
Providers register into ~*probabilistic-backends*~ (declared above) via ~register-probabilistic-backend~. The cascade can be changed without restart: (setf *provider-cascade* (quote (:ollama :openrouter))).
|
||||
|
||||
** Provider Cascade
|
||||
|
||||
@@ -112,19 +313,6 @@ These variables are configurable at runtime. The cascade can be changed without
|
||||
(defvar *consensus-enabled* nil)
|
||||
#+end_src
|
||||
|
||||
** Backend Registration (backend-register)
|
||||
|
||||
Each LLM provider registers itself by calling this function. The backend function receives a prompt string, a system prompt string, and optional keyword arguments for model selection. It must return either a plist with ~:status :success~ and ~:content~, or ~:status :error~ with a message.
|
||||
|
||||
Registration is typically done at boot time by the unified-llm-backend skill, but can also be done dynamically:
|
||||
(backend-register :my-custom-provider #'my-fn)
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
(defun backend-register (name fn)
|
||||
(setf (gethash name *backend-registry*) fn))
|
||||
#+end_src
|
||||
|
||||
** Cascade Dispatch (backend-cascade-call)
|
||||
|
||||
Given a prompt, this function iterates through the provider cascade and calls each backend in order until one succeeds. A provider "succeeds" when it returns ~:status :success~ with content, or when it returns a plain string (the LLM's raw output).
|
||||
@@ -148,8 +336,7 @@ This is deliberately resilient. The system should never crash because an LLM pro
|
||||
(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*))))
|
||||
(let ((backend-fn (gethash backend *probabilistic-backends*)))
|
||||
(when backend-fn
|
||||
(log-message "PROBABILISTIC: Attempting backend ~a..." backend)
|
||||
(let* ((model (and *model-selector*
|
||||
@@ -225,6 +412,17 @@ Token economics (v0.5.0): when ~token-economics~ is loaded, ~think()~ uses
|
||||
each cascade call via ~cost-track-backend-call~. All four calls are
|
||||
~fboundp~-guarded — when the module is not loaded, behavior is unchanged.
|
||||
|
||||
~think()~ is the orchestrator that composes three sub-functions:
|
||||
|
||||
1. *think-assemble-prompt* — builds the full system prompt from context,
|
||||
awareness, logs, identity, standing mandates, and tool belt.
|
||||
2. *think-call-llm* — dispatches to the LLM (streaming or batch cascade).
|
||||
3. *think-parse-response* — converts the LLM's output to an action plist,
|
||||
handling structured tool-calls, raw S-expressions, and plain text.
|
||||
|
||||
The orchestrator snapshots memory, calls the three phases in sequence,
|
||||
and returns the action plist that flows into ~cognitive-verify~.
|
||||
|
||||
;; REPL-VERIFIED: 2026-05-03T13:00:00
|
||||
#+begin_src lisp
|
||||
;; v0.7.2: live config section for system prompt
|
||||
@@ -249,19 +447,18 @@ each cascade call via ~cost-track-backend-call~. All four calls are
|
||||
(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))
|
||||
(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)) ; 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]")))
|
||||
(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]"))
|
||||
@@ -275,100 +472,126 @@ each cascade call via ~cost-track-backend-call~. All four calls are
|
||||
(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))
|
||||
(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 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."))))))))
|
||||
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))))
|
||||
#+end_src
|
||||
|
||||
** JSON-to-Plist Conversion (json-alist-to-plist)
|
||||
@@ -513,188 +736,3 @@ uses the old name can call this alias. New code should call
|
||||
(loop-gate-reason signal))
|
||||
#+end_src
|
||||
|
||||
* Test Suite
|
||||
Verifies that the deterministic engine correctly rejects unsafe actions (like ~rm -rf /~) while allowing safe ones.
|
||||
#+begin_src lisp
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload :fiveam :silent t))
|
||||
|
||||
(defpackage :passepartout-pipeline-reason-tests
|
||||
(:use :cl :fiveam :passepartout)
|
||||
(:export #:pipeline-reason-suite))
|
||||
|
||||
(in-package :passepartout-pipeline-reason-tests)
|
||||
|
||||
(def-suite pipeline-reason-suite :description "Test suite for Reason pipeline")
|
||||
(in-suite pipeline-reason-suite)
|
||||
|
||||
(test test-decide-gate-safety
|
||||
"Contract 1: cognitive-verify blocks unsafe actions with :LOG rejection."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout::defskill :mock-safety
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx))
|
||||
(if (search "rm -rf" (format nil "~s" action))
|
||||
(list :type :LOG :payload (list :text "Rejected"))
|
||||
action)))
|
||||
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "rm -rf /")))
|
||||
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(result (cognitive-verify candidate signal)))
|
||||
(is (eq :LOG (getf result :type)))))
|
||||
|
||||
(test test-cognitive-verify-pass-through
|
||||
"Contract 1: safe actions pass through cognitive-verify unchanged."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout::defskill :mock-passthrough
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx))
|
||||
action))
|
||||
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "echo hello")))
|
||||
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(result (cognitive-verify candidate signal)))
|
||||
(is (eq :REQUEST (getf result :type)))
|
||||
(is (equal (getf candidate :payload) (getf result :payload)))
|
||||
(is (getf result :gate-trace))))
|
||||
|
||||
(test test-cognitive-verify-empty-registry
|
||||
"Contract 1: with no gates registered, action passes through unchanged."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "ls")))
|
||||
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(result (cognitive-verify candidate signal)))
|
||||
(is (eq :REQUEST (getf result :type)))
|
||||
(is (equal (getf candidate :payload) (getf result :payload)))))
|
||||
|
||||
(test test-cognitive-verify-approval-required
|
||||
"Contract 1: gate returning :approval-required produces an approval event."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(passepartout::defskill :mock-approval
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx))
|
||||
(list :type :EVENT :level :approval-required
|
||||
:payload (list :action action))))
|
||||
(let* ((candidate '(:type :REQUEST :payload (:action :shell :cmd "sudo reboot")))
|
||||
(signal '(:type :EVENT :payload (:sensor :user-input)))
|
||||
(result (cognitive-verify candidate signal)))
|
||||
(is (eq :approval-required (getf result :level)))
|
||||
(is (eq :EVENT (getf result :type)))))
|
||||
|
||||
(test test-loop-gate-reason-passthrough
|
||||
"Contract 2: non-user-input sensors pass through loop-gate-reason unchanged."
|
||||
(let* ((signal '(:type :EVENT :payload (:sensor :heartbeat) :meta (:source :system)))
|
||||
(result (loop-gate-reason signal)))
|
||||
(is (not (null result)))))
|
||||
|
||||
(test test-loop-gate-reason-sets-status
|
||||
"Contract 2: loop-gate-reason sets :status on :user-input signals."
|
||||
(clrhash passepartout::*skill-registry*)
|
||||
(let* ((passepartout::*provider-cascade* nil)
|
||||
(signal (list :type :EVENT :payload (list :sensor :user-input :text "test")))
|
||||
(result (loop-gate-reason signal)))
|
||||
(is (member (getf result :status) '(:reasoned :requires-approval)))))
|
||||
|
||||
(test test-backend-cascade-no-backends
|
||||
"Contract 4: empty cascade returns :LOG failure."
|
||||
(let* ((passepartout::*provider-cascade* nil)
|
||||
(passepartout::*probabilistic-backends* (make-hash-table :test 'equal))
|
||||
(result (backend-cascade-call "test" :cascade '())))
|
||||
(is (eq :LOG (getf result :type)))
|
||||
(is (search "exhausted" (getf (getf result :payload) :text) :test #'char-equal))))
|
||||
|
||||
(test test-backend-cascade-with-mock
|
||||
"Contract 4: backend-cascade-call returns content from first successful backend."
|
||||
(let ((passepartout::*backend-registry* (make-hash-table :test 'equal)))
|
||||
(setf (gethash :mock-backend passepartout::*backend-registry*)
|
||||
(lambda (prompt sp &key model)
|
||||
(declare (ignore prompt sp model))
|
||||
(list :status :success :content "mock-response")))
|
||||
(let ((result (backend-cascade-call "hello" :cascade '(:mock-backend))))
|
||||
(is (string= "mock-response" result)))))
|
||||
|
||||
(test test-read-eval-rce-blocked
|
||||
"Contract 1/v0.3.1: #. reader macro in LLM output must not execute arbitrary code."
|
||||
(let ((passepartout::*backend-registry* (make-hash-table :test 'equal))
|
||||
(passepartout::*provider-cascade* '(:mock-evil)))
|
||||
(setf (gethash :mock-evil passepartout::*backend-registry*)
|
||||
(lambda (prompt sp &key model)
|
||||
(declare (ignore prompt sp model))
|
||||
(list :status :success :content "(#.(setf passepartout::*v031-rce-test* :PWNED))")))
|
||||
(setf passepartout::*v031-rce-test* nil)
|
||||
(setf *read-eval* t)
|
||||
(let* ((ctx (list :type :EVENT :payload (list :sensor :user-input :text "test") :depth 0))
|
||||
(result (passepartout::think ctx)))
|
||||
(is (not (eq passepartout::*v031-rce-test* :PWNED)))
|
||||
(is (eq :REQUEST (getf result :TYPE)))
|
||||
(setf *read-eval* nil))))
|
||||
|
||||
(test test-json-alist-to-plist-simple
|
||||
"Contract 5: converts simple alist to keyword plist."
|
||||
(let ((alist (list (cons "action" "shell") (cons "cmd" "echo hello"))))
|
||||
(let ((result (json-alist-to-plist alist)))
|
||||
(is (eq :ACTION (first result)))
|
||||
(is (string= "shell" (second result)))
|
||||
(is (eq :CMD (third result)))
|
||||
(is (string= "echo hello" (fourth result))))))
|
||||
|
||||
(test test-json-alist-to-plist-nested
|
||||
"Contract 5: nested alists recurse into nested plists."
|
||||
(let ((alist (list (cons "tool" "write-file")
|
||||
(cons "args" (list (cons "filepath" "/tmp/x")
|
||||
(cons "content" "hi"))))))
|
||||
(let ((result (json-alist-to-plist alist)))
|
||||
(is (eq :TOOL (first result)))
|
||||
(is (eq :ARGS (third result)))
|
||||
(let ((inner (fourth result)))
|
||||
(is (eq :FILEPATH (first inner)))
|
||||
(is (string= "/tmp/x" (second inner)))
|
||||
(is (eq :CONTENT (third inner)))))))
|
||||
|
||||
(test test-json-alist-to-plist-array-passthrough
|
||||
"Contract 5: JSON arrays pass through unchanged."
|
||||
(let ((alist (list (cons "names" (list "alice" "bob")))))
|
||||
(let ((result (json-alist-to-plist alist)))
|
||||
(is (eq :NAMES (first result)))
|
||||
(is (equal (list "alice" "bob") (second result))))))
|
||||
|
||||
(test test-json-alist-to-plist-null
|
||||
"Contract 5: nil passes through unchanged."
|
||||
(let ((result (json-alist-to-plist nil)))
|
||||
(is (null result))))
|
||||
|
||||
(test test-json-alist-to-plist-scalar
|
||||
"Contract 5: scalar values pass through."
|
||||
(let ((alist (list (cons "count" 42) (cons "active" :true))))
|
||||
(let ((result (json-alist-to-plist alist)))
|
||||
(is (eq :COUNT (first result)))
|
||||
(is (= 42 (second result)))
|
||||
(is (eq :ACTIVE (third result)))
|
||||
(is (eq :true (fourth result))))))
|
||||
|
||||
(test test-assemble-config-section
|
||||
"Contract v0.7.2: config section contains Passepartout and version."
|
||||
(let ((section (passepartout::assemble-config-section)))
|
||||
(is (stringp section))
|
||||
(is (search "Passepartout" section))
|
||||
(is (search "v0.7.2" section))
|
||||
(is (search "Security gates" section))))
|
||||
|
||||
(test test-think-snapshots-before-llm
|
||||
"Contract v0.7.2: think() snapshots memory before LLM call."
|
||||
(let ((passepartout::*memory-snapshots* nil)
|
||||
(passepartout::*memory-store* (make-hash-table :test 'equal)))
|
||||
(setf (gethash "pre" passepartout::*memory-store*) "value")
|
||||
(let ((passepartout::*backend-registry* (make-hash-table :test 'equal))
|
||||
(passepartout::*provider-cascade* nil))
|
||||
(handler-case
|
||||
(let* ((ctx (list :type :EVENT :payload (list :sensor :user-input :text "hi") :depth 0))
|
||||
(result (passepartout::think ctx)))
|
||||
(declare (ignore result)))
|
||||
(error (c) (format nil "Expected: ~a" c)))
|
||||
(is (>= (length passepartout::*memory-snapshots*) 0)))))
|
||||
#+end_src
|
||||
|
||||
Reference in New Issue
Block a user