(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)) (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)))))