(in-package :passepartout) (defvar *actuator-default* :cli "The actuator used when no explicit target is specified.") (defvar *actuator-silent* '(:cli :system-message :emacs) "List of actuators that don't generate tool-output feedback.") (defun actuator-initialize () "Register core actuators and load configuration." (let ((def (uiop:getenv "DEFAULT_ACTUATOR")) (silent (uiop:getenv "SILENT_ACTUATORS"))) (when def (setf *actuator-default* (intern (string-upcase def) :keyword))) (when silent (setf *actuator-silent* (mapcar (lambda (s) (intern (string-upcase (string-trim '(#\Space) s)) :keyword)) (uiop:split-string silent :separator '(#\,)))))) (register-actuator :system #'action-system-execute) (register-actuator :tool #'action-tool-execute) (register-actuator :tui (lambda (action context) (declare (ignore context)) (let* ((meta (getf action :meta)) (stream (getf meta :reply-stream))) (when (and stream (open-stream-p stream)) ;; Enrich response with differentiator visualization data (setf (getf (getf action :payload) :rule-count) (if (boundp '*hitl-pending*) (hash-table-count *hitl-pending*) 0)) (setf (getf (getf action :payload) :foveal-id) (getf context :foveal-id)) (format stream "~a" (frame-message action)) (finish-output stream)))))) (defun action-dispatch (action context) "Route an approved action to its registered actuator." (let ((payload (proto-get action :payload))) (when (eq (proto-get payload :sensor) :heartbeat) (return-from action-dispatch nil)) (when (and action (listp action)) (let* ((meta (proto-get context :meta)) (source (proto-get meta :source)) (raw-target (or (proto-get action :target) source *actuator-default*)) (target (intern (string-upcase (string raw-target)) :keyword)) ;; If target is :SYSTEM and we have a live reply-stream, route to :TUI instead (actual-target (if (and (eq target :system) (getf meta :reply-stream) (ignore-errors (open-stream-p (getf meta :reply-stream)))) :tui target)) (actuator-fn (gethash actual-target *actuator-registry*))) (when (and meta (null (getf action :meta))) (setf (getf action :meta) meta)) (if actuator-fn (funcall actuator-fn action context) (log-message "ACT ERROR: No actuator registered for '~s'" actual-target)))))) (defun action-system-execute (action context) "Execute internal harness commands." (declare (ignore context)) (let* ((payload (getf action :payload)) (cmd (getf payload :action))) (case cmd (:eval (eval (let ((*read-eval* nil)) (read-from-string (getf payload :code))))) (:message (log-message "ACT [System]: ~a" (getf payload :text))) (t (log-message "ACT ERROR [System]: Unknown command '~s'" cmd))))) (defun action-tool-execute (action context) "Execute a registered cognitive tool." (let* ((payload (getf action :payload)) (tool-name (getf payload :tool)) (tool-args (getf payload :args)) (depth (getf context :depth 0)) (meta (getf context :meta)) (source (getf meta :source)) (tool (gethash (string-downcase (string tool-name)) *cognitive-tool-registry*))) ;; v0.7.2: snapshot before destructive tool execution (when (and tool (not (cognitive-tool-read-only-p tool))) (undo-snapshot)) (if tool (handler-case (let* ((clean-args (if (and (listp tool-args) (listp (car tool-args))) (car tool-args) tool-args)) (is-read-only (cognitive-tool-read-only-p tool)) (cache-key (when is-read-only (tool-cache-key tool-name clean-args))) (cached (when cache-key (gethash cache-key *tool-cache*))) (raw-result (if cached (progn (log-message "TOOL-CACHE: hit for ~a" tool-name) cached) (let* ((res (call-with-tool-timeout tool-name (lambda () (funcall (cognitive-tool-body tool) clean-args))))) (when (and is-read-only cache-key) (setf (gethash cache-key *tool-cache*) res)) res)))) ;; Timeout: propagate error (when (and (listp raw-result) (eq (getf raw-result :status) :error)) (return-from action-tool-execute (list :TYPE :EVENT :DEPTH (1+ depth) :META meta :PAYLOAD (list :SENSOR :tool-error :TOOL tool-name :MESSAGE (getf raw-result :message))))) (when source (action-dispatch (list :TYPE :REQUEST :TARGET source :PAYLOAD (list :ACTION :MESSAGE :TEXT (tool-result-format tool-name raw-result))) context)) (list :TYPE :EVENT :DEPTH (1+ depth) :META meta :PAYLOAD (list :SENSOR :tool-output :RESULT raw-result :TOOL tool-name))) (error (c) (list :TYPE :EVENT :DEPTH (1+ depth) :META meta :PAYLOAD (list :SENSOR :tool-error :TOOL tool-name :MESSAGE (format nil "~a" c))))) (list :TYPE :EVENT :DEPTH (1+ depth) :META meta :PAYLOAD (list :SENSOR :tool-error :MESSAGE (format nil "Tool '~a' not found" tool-name)))))) (defvar *tool-timeouts* (make-hash-table :test 'equal) "Per-tool timeout in seconds. Default 120s.") ;; Defaults: shell=300s, search-files=30s, eval-form=10s (setf (gethash "shell" *tool-timeouts*) 300) (setf (gethash "search-files" *tool-timeouts*) 30) (setf (gethash "eval-form" *tool-timeouts*) 10) (defun tool-timeout (tool-name) "Return timeout for tool-name, default 120 seconds." (gethash (string-downcase (string tool-name)) *tool-timeouts* 120)) (defun call-with-tool-timeout (tool-name fn) "Execute FN within the timeout for TOOL-NAME. On timeout, returns (:status :error :message ...)." (let ((timeout (tool-timeout tool-name))) (handler-case (sb-ext:with-timeout timeout (funcall fn)) (sb-ext:timeout (c) (declare (ignore c)) (list :status :error :message (format nil "Timed out after ~a second~:p" timeout)))))) (defun verify-write (filepath expected-content) "Verify that FILEPATH contains EXPECTED-CONTENT after write. Returns T on match, logs and returns NIL on mismatch or read error." (handler-case (let ((actual (uiop:read-file-string filepath))) (if (string= expected-content actual) t (progn (log-message "WRITE-VERIFY: Mismatch in ~a" filepath) nil))) (error (c) (log-message "WRITE-VERIFY: Cannot read ~a: ~a" filepath c) nil))) ;; v0.7.2: read-only tool response cache (defvar *tool-cache* (make-hash-table :test 'equal) "Cache for read-only tool results. Key: tool-name$sxhash-args. Cleared per session.") (defun tool-cache-key (tool-name args) "Build a cache key from TOOL-NAME and ARGS." (format nil "~a$~a" (string-downcase (string tool-name)) (sxhash args))) (defun tool-cache-clear () "Clear the read-only tool response cache." (clrhash *tool-cache*)) (defun tool-result-format (tool-name result) "Format a tool result for display." (if (listp result) (let ((status (getf result :status)) (content (getf result :content)) (msg (getf result :message))) (cond ((and (eq status :success) content) (format nil "~a" content)) ((and (eq status :error) msg) (format nil "ERROR [~a]: ~a" tool-name msg)) (t (format nil "TOOL [~a] RESULT: ~s" tool-name result)))) (format nil "TOOL [~a] RESULT: ~a" tool-name result))) (defun loop-gate-act (signal) "Final stage of the metabolic pipeline: Actuation. For approval-required actions, creates a Flight Plan instead of executing." (let* ((approved (getf signal :approved-action)) (signal-status (getf signal :status)) (type (getf signal :type)) (meta (getf signal :meta)) (source (getf meta :source)) (feedback nil)) ;; HITL: if the approved action requires human approval, ;; create a Flight Plan (Emacs) and HITL entry (all gateways). (when (and approved (eq (getf approved :level) :approval-required)) (let* ((payload (getf approved :payload)) (blocked-action (getf payload :action)) (hitl (hitl-create blocked-action))) (log-message "ACT: Action requires approval — creating Flight Plan + HITL (~a)" (getf hitl :token)) (dispatcher-flight-plan-create blocked-action) (setf (getf signal :status) :suspended) (action-dispatch (list :target source :payload (list :text (getf hitl :message))) signal) (setf approved nil) (setf feedback nil))) (when approved (let* ((original-type (getf approved :type)) (verified (cognitive-verify approved signal))) (if (and (listp verified) (member (getf verified :type) '(:LOG :EVENT)) (not (eq (getf verified :level) :approval-required)) (not (member original-type '(:LOG :EVENT)))) (progn (log-message "ACT BLOCKED: Action failed last-mile deterministic check.") (setf (getf signal :approved-action) nil) (setf feedback verified)) (progn (setf (getf signal :approved-action) verified) (setf approved verified))))) (case type (:REQUEST (action-dispatch signal signal)) (:LOG (action-dispatch signal signal)) (:EVENT (if approved (let* ((target (getf approved :target)) (result (action-dispatch approved signal))) (cond ((and (listp result) (member (getf result :type) '(:EVENT :LOG))) (setf feedback result)) ((and result (not (member target *actuator-silent*))) (setf feedback (list :type :EVENT :depth (1+ (getf signal :depth 0)) :meta meta :payload (list :sensor :tool-output :result result :tool approved)))))) (when source (action-dispatch signal signal))))) (setf (getf signal :status) :acted) feedback)) (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*))))