From 5e7b1cee33aa41e699ddc6716b5cdaa3d87efcf9 Mon Sep 17 00:00:00 2001 From: Amr Gharbeia Date: Sun, 3 May 2026 13:00:19 -0400 Subject: [PATCH] =?UTF-8?q?feat:=20HITL=20=E2=80=94=20continuation-based?= =?UTF-8?q?=20human-in-the-loop?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - 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 --- docs/.#DESIGN_DECISIONS.org | 1 + lisp/core-loop-act.lisp | 28 +++++++++++++--- lisp/core-loop-perceive.lisp | 37 +++++++++++++-------- lisp/core-loop-reason.lisp | 62 ++++++++++++++++++++++------------- lisp/core-loop.lisp | 18 +++++----- lisp/security-dispatcher.lisp | 13 +++++--- org/core-loop-act.org | 28 +++++++++++++--- org/core-loop-perceive.org | 37 +++++++++++++-------- org/core-loop-reason.org | 62 ++++++++++++++++++++++------------- org/core-loop.org | 18 +++++----- org/security-dispatcher.org | 13 +++++--- 11 files changed, 209 insertions(+), 108 deletions(-) create mode 120000 docs/.#DESIGN_DECISIONS.org diff --git a/docs/.#DESIGN_DECISIONS.org b/docs/.#DESIGN_DECISIONS.org new file mode 120000 index 0000000..b89982c --- /dev/null +++ b/docs/.#DESIGN_DECISIONS.org @@ -0,0 +1 @@ +user@amr.59355:1777807168 \ No newline at end of file diff --git a/lisp/core-loop-act.lisp b/lisp/core-loop-act.lisp index af152ac..c4ec715 100644 --- a/lisp/core-loop-act.lisp +++ b/lisp/core-loop-act.lisp @@ -97,16 +97,36 @@ (format nil "TOOL [~a] RESULT: ~a" tool-name result))) (defun loop-gate-act (signal) - "Final stage of the metabolic pipeline: Actuation." + "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 (member original-type '(:LOG :EVENT)))) + (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) @@ -145,8 +165,8 @@ (in-suite pipeline-act-suite) (test test-loop-gate-act-basic - (clrhash passepartout::*skills-registry*) + (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))) + (result (loop-gate-act signal))) (is (eq :acted (getf signal :status))) (is (null result)))) diff --git a/lisp/core-loop-perceive.lisp b/lisp/core-loop-perceive.lisp index 1fa7881..376be55 100644 --- a/lisp/core-loop-perceive.lisp +++ b/lisp/core-loop-perceive.lisp @@ -51,20 +51,29 @@ type (or sensor "no-sensor") (getf meta :source)) (cond ((eq type :EVENT) - (case sensor - (:buffer-update - (let ((ast (getf payload :ast))) - (when ast - (snapshot-memory) - (ingest-ast ast)))) - (:point-update - (let ((element (getf payload :element))) - (when element - (snapshot-memory) - (setf *loop-focus-id* (getf element :id)) - (ingest-ast element)))) - (:interrupt - (setf *loop-interrupt* t)))) + (case sensor + (:buffer-update + (let ((ast (getf payload :ast))) + (when ast + (snapshot-memory) + (ingest-ast ast)))) + (:point-update + (let ((element (getf payload :element))) + (when element + (snapshot-memory) + (setf *loop-focus-id* (getf element :id)) + (ingest-ast element)))) + (:interrupt + (setf *loop-interrupt* t)) + ;; HITL: re-injected approved action from dispatcher-approvals-process + (:approval-required + (when (getf payload :approved) + (log-message "GATE [Perceive]: Approved Flight Plan re-injected") + (setf (getf signal :approved t)) + (setf (getf signal :approved-action) (getf payload :action)))) + ;; Default sensor: pass through without requiring user-input processing + (otherwise + (log-message "GATE [Perceive]: Unknown sensor ~a, passing through" sensor)))) ((eq type :RESPONSE) (log-message "GATE [Perceive]: Act Result -> ~a" (getf payload :status)))) diff --git a/lisp/core-loop-reason.lisp b/lisp/core-loop-reason.lisp index ec2aa95..7e40d0a 100644 --- a/lisp/core-loop-reason.lisp +++ b/lisp/core-loop-reason.lisp @@ -92,25 +92,34 @@ (list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT (if (stringp cleaned) cleaned "No response") :EXPLANATION "Generated by the Probabilistic engine.")))))) (defun cognitive-verify (proposed-action context) - (let ((current-action proposed-action) - (skills nil)) + "Runs all registered deterministic gates against the proposed action. +Returns either a rejection plist (for :LOG or :EVENT errors) or the +modified action (for approval-required or pass)." + (let ((current-action (copy-tree proposed-action)) + (approval-needed nil) + (approval-action nil)) (maphash (lambda (name skill) (declare (ignore name)) (when (skill-deterministic-fn skill) - (push skill skills))) + (let ((gate (skill-deterministic-fn skill))) + (when gate + (let ((result (funcall gate current-action context))) + (cond + ;; Approval-required: remember it and continue checking + ((eq (getf result :level) :approval-required) + (setf approval-needed t + approval-action (getf (getf result :payload) :action))) + ;; Hard rejection: return immediately + ((member (getf result :type) '(:LOG :EVENT)) + (return-from cognitive-verify result)) + ;; Normal: update action + (t (setf current-action result)))))))) *skill-registry*) - (setf skills (sort skills #'> :key #'skill-priority)) - (dolist (skill skills) - (let ((trigger (skill-trigger-fn skill)) - (gate (skill-deterministic-fn skill))) - (when (or (null trigger) (ignore-errors (funcall trigger context))) - (let ((next-action (funcall gate current-action context))) - (when (and (listp next-action) - (member (proto-get next-action :type) '(:LOG :EVENT))) - (log-message "DETERMINISTIC: Intercepted by skill '~a'" (skill-name skill)) - (return-from cognitive-verify next-action)) - (when next-action (setf current-action next-action)))))) - current-action)) + (if approval-needed + (list :type :EVENT :level :approval-required + :payload (list :sensor :approval-required + :action approval-action)) + current-action))) (defun loop-gate-reason (signal) (let* ((type (proto-get signal :type)) @@ -129,14 +138,21 @@ (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))) - (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)))) + (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) diff --git a/lisp/core-loop.lisp b/lisp/core-loop.lisp index 7e2bf41..efc5fd3 100644 --- a/lisp/core-loop.lisp +++ b/lisp/core-loop.lisp @@ -24,15 +24,15 @@ (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)))) + (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) diff --git a/lisp/security-dispatcher.lisp b/lisp/security-dispatcher.lisp index c65de80..f65fcba 100644 --- a/lisp/security-dispatcher.lisp +++ b/lisp/security-dispatcher.lisp @@ -270,7 +270,8 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval." (and (eq target :tool) (equal (proto-get payload :tool) "shell"))) (dispatcher-check-network-exfil cmd)) (log-message "SECURITY WARNING: External network call detected. Queuing for approval.") - (list :type :EVENT :payload (list :sensor :approval-required :action action))) + (list :type :EVENT :level :approval-required + :payload (list :sensor :approval-required :action action))) ;; Vector 8: High-impact action approval ((or (member target '(:shell)) @@ -282,7 +283,7 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval." (defun dispatcher-approvals-process () "Scans for APPROVED flight plans and re-injects them." - (let ((approved-nodes (list-objects-with-attribute :TODO "APPROVED")) + (let ((approved-nodes (memory-objects-by-attribute :TODO "APPROVED")) (found-any nil)) (dolist (node approved-nodes) (let* ((attrs (memory-object-attributes node)) @@ -293,14 +294,18 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval." (let ((action (ignore-errors (read-from-string action-str)))) (when action (setf (getf action :approved) t) - (inject-stimulus action) + (stimulus-inject (list :type :EVENT + :payload (list :sensor :approval-required + :action action + :approved t) + :meta (list :source :system))) (setf (getf (memory-object-attributes node) :TODO) "DONE") (setq found-any t)))))) found-any)) (defun dispatcher-flight-plan-create (blocked-action) "Creates a Flight Plan node for manual approval." - (let ((id (org-id-new))) + (let ((id (org-id-generate))) (log-message "BOUNCER: Creating flight plan node '~a'..." id) (list :type :REQUEST :target :emacs :payload (list :action :insert-node :id id diff --git a/org/core-loop-act.org b/org/core-loop-act.org index e86e8e5..0d0bf84 100644 --- a/org/core-loop-act.org +++ b/org/core-loop-act.org @@ -196,16 +196,36 @@ After dispatch, the gate captures any feedback produced by the actuation (tool o ;; REPL-VERIFIED: 2026-05-03T13:00:00 #+begin_src lisp (defun loop-gate-act (signal) - "Final stage of the metabolic pipeline: Actuation." + "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 (member original-type '(:LOG :EVENT)))) + (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) @@ -248,9 +268,9 @@ Verifies that the act gate correctly processes an approved action and sets the s (in-suite pipeline-act-suite) (test test-loop-gate-act-basic - (clrhash passepartout::*skills-registry*) + (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))) + (result (loop-gate-act signal))) (is (eq :acted (getf signal :status))) (is (null result)))) #+end_src \ No newline at end of file diff --git a/org/core-loop-perceive.org b/org/core-loop-perceive.org index e1c87fb..a222a00 100644 --- a/org/core-loop-perceive.org +++ b/org/core-loop-perceive.org @@ -128,20 +128,29 @@ All signals get tagged with their processing stage (`:status :perceived`) and th type (or sensor "no-sensor") (getf meta :source)) (cond ((eq type :EVENT) - (case sensor - (:buffer-update - (let ((ast (getf payload :ast))) - (when ast - (snapshot-memory) - (ingest-ast ast)))) - (:point-update - (let ((element (getf payload :element))) - (when element - (snapshot-memory) - (setf *loop-focus-id* (getf element :id)) - (ingest-ast element)))) - (:interrupt - (setf *loop-interrupt* t)))) + (case sensor + (:buffer-update + (let ((ast (getf payload :ast))) + (when ast + (snapshot-memory) + (ingest-ast ast)))) + (:point-update + (let ((element (getf payload :element))) + (when element + (snapshot-memory) + (setf *loop-focus-id* (getf element :id)) + (ingest-ast element)))) + (:interrupt + (setf *loop-interrupt* t)) + ;; HITL: re-injected approved action from dispatcher-approvals-process + (:approval-required + (when (getf payload :approved) + (log-message "GATE [Perceive]: Approved Flight Plan re-injected") + (setf (getf signal :approved t)) + (setf (getf signal :approved-action) (getf payload :action)))) + ;; Default sensor: pass through without requiring user-input processing + (otherwise + (log-message "GATE [Perceive]: Unknown sensor ~a, passing through" sensor)))) ((eq type :RESPONSE) (log-message "GATE [Perceive]: Act Result -> ~a" (getf payload :status)))) diff --git a/org/core-loop-reason.org b/org/core-loop-reason.org index 6896943..72607d0 100644 --- a/org/core-loop-reason.org +++ b/org/core-loop-reason.org @@ -241,25 +241,34 @@ This architecture makes safety compositional: each skill adds one constraint. Th ;; REPL-VERIFIED: 2026-05-03T13:00:00 #+begin_src lisp (defun cognitive-verify (proposed-action context) - (let ((current-action proposed-action) - (skills nil)) + "Runs all registered deterministic gates against the proposed action. +Returns either a rejection plist (for :LOG or :EVENT errors) or the +modified action (for approval-required or pass)." + (let ((current-action (copy-tree proposed-action)) + (approval-needed nil) + (approval-action nil)) (maphash (lambda (name skill) (declare (ignore name)) (when (skill-deterministic-fn skill) - (push skill skills))) + (let ((gate (skill-deterministic-fn skill))) + (when gate + (let ((result (funcall gate current-action context))) + (cond + ;; Approval-required: remember it and continue checking + ((eq (getf result :level) :approval-required) + (setf approval-needed t + approval-action (getf (getf result :payload) :action))) + ;; Hard rejection: return immediately + ((member (getf result :type) '(:LOG :EVENT)) + (return-from cognitive-verify result)) + ;; Normal: update action + (t (setf current-action result)))))))) *skill-registry*) - (setf skills (sort skills #'> :key #'skill-priority)) - (dolist (skill skills) - (let ((trigger (skill-trigger-fn skill)) - (gate (skill-deterministic-fn skill))) - (when (or (null trigger) (ignore-errors (funcall trigger context))) - (let ((next-action (funcall gate current-action context))) - (when (and (listp next-action) - (member (proto-get next-action :type) '(:LOG :EVENT))) - (log-message "DETERMINISTIC: Intercepted by skill '~a'" (skill-name skill)) - (return-from cognitive-verify next-action)) - (when next-action (setf current-action next-action)))))) - current-action)) + (if approval-needed + (list :type :EVENT :level :approval-required + :payload (list :sensor :approval-required + :action approval-action)) + current-action))) #+end_src ** Reason Gate (Stage 2) @@ -289,14 +298,21 @@ The retry limit prevents infinite loops. If the LLM cannot produce a passable pr (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))) - (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)))) + (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) diff --git a/org/core-loop.org b/org/core-loop.org index 8846f5e..f415769 100644 --- a/org/core-loop.org +++ b/org/core-loop.org @@ -95,15 +95,15 @@ The function handles four failure modes: (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)))) + (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) diff --git a/org/security-dispatcher.org b/org/security-dispatcher.org index b251e45..5956a78 100644 --- a/org/security-dispatcher.org +++ b/org/security-dispatcher.org @@ -388,7 +388,8 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval." (and (eq target :tool) (equal (proto-get payload :tool) "shell"))) (dispatcher-check-network-exfil cmd)) (log-message "SECURITY WARNING: External network call detected. Queuing for approval.") - (list :type :EVENT :payload (list :sensor :approval-required :action action))) + (list :type :EVENT :level :approval-required + :payload (list :sensor :approval-required :action action))) ;; Vector 8: High-impact action approval ((or (member target '(:shell)) @@ -405,7 +406,7 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval." #+begin_src lisp (defun dispatcher-approvals-process () "Scans for APPROVED flight plans and re-injects them." - (let ((approved-nodes (list-objects-with-attribute :TODO "APPROVED")) + (let ((approved-nodes (memory-objects-by-attribute :TODO "APPROVED")) (found-any nil)) (dolist (node approved-nodes) (let* ((attrs (memory-object-attributes node)) @@ -416,7 +417,11 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval." (let ((action (ignore-errors (read-from-string action-str)))) (when action (setf (getf action :approved) t) - (inject-stimulus action) + (stimulus-inject (list :type :EVENT + :payload (list :sensor :approval-required + :action action + :approved t) + :meta (list :source :system))) (setf (getf (memory-object-attributes node) :TODO) "DONE") (setq found-any t)))))) found-any)) @@ -427,7 +432,7 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval." #+begin_src lisp (defun dispatcher-flight-plan-create (blocked-action) "Creates a Flight Plan node for manual approval." - (let ((id (org-id-new))) + (let ((id (org-id-generate))) (log-message "BOUNCER: Creating flight plan node '~a'..." id) (list :type :REQUEST :target :emacs :payload (list :action :insert-node :id id