Amr Gharbeia
5e7b1cee33
Some checks failed
Deploy (Gitea) / deploy (push) Failing after 3s
- dispatcher-check: add :level :approval-required to network/high-impact returns - cognitive-verify: distinguish approval-required from hard rejection; pass approval requests through to act gate instead of returning early - loop-gate-reason: don't retry approval requests; pass them as approved-action with :status :requires-approval - loop-gate-act: detect approval-required, create Flight Plan, dispatch HITL message to user's client, don't execute original action - loop-gate-perceive: handle re-injected approved signals from dispatcher-approvals-process; set :approved-action on signal - dispatcher-approvals-process: fix function name (stimulus-inject) and wrap action in proper signal envelope with :sensor :approval-required - Fix: list-objects-with-attribute → memory-objects-by-attribute - Fix: org-id-new → org-id-generate - Fix: inject-stimulus → stimulus-inject (correct function name) Flow: 1. LLM proposes high-risk action → dispatcher returns approval-required 2. cognitive-verify collects approval request → passes to reason as :requires-approval 3. loop-gate-act creates Flight Plan → dispatches HITL message to client → exits 4. Human approves in Emacs → heartbeat re-injects with :approved t 5. Re-injected signal flows through pipeline → dispatcher passes through 6. Action executed normally
173 lines
7.8 KiB
Common Lisp
173 lines
7.8 KiB
Common Lisp
(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))
|
|
(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))
|
|
(actuator-fn (gethash 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'" 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 (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*)))
|
|
(if tool
|
|
(handler-case
|
|
(let* ((clean-args (if (and (listp tool-args) (listp (car tool-args))) (car tool-args) tool-args))
|
|
(result (funcall (cognitive-tool-body tool) clean-args)))
|
|
(when source
|
|
(action-dispatch (list :TYPE :REQUEST :TARGET source
|
|
:PAYLOAD (list :ACTION :MESSAGE :TEXT (tool-result-format tool-name result)))
|
|
context))
|
|
(list :TYPE :EVENT :DEPTH (1+ depth) :META meta
|
|
:PAYLOAD (list :SENSOR :tool-output :RESULT 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))))))
|
|
|
|
(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 and notify the user via their client.
|
|
(when (and approved
|
|
(eq (getf approved :level) :approval-required))
|
|
(let* ((payload (getf approved :payload))
|
|
(blocked-action (getf payload :action)))
|
|
(log-message "ACT: Action requires approval — creating Flight Plan")
|
|
(dispatcher-flight-plan-create blocked-action)
|
|
(setf (getf signal :status) :suspended)
|
|
;; Dispatch HITL notification to the user's client via the source actuator
|
|
(action-dispatch (list :target source
|
|
:payload (list :text
|
|
"HITL: Action requires your approval. Check Flight Plan and set TODO to APPROVED."))
|
|
signal)
|
|
(setf approved nil) ;; Don't execute the original action
|
|
(setf feedback nil))) ;; Don't loop back — wait for human
|
|
(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))
|
|
|
|
(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
|
|
(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))))
|