fix(kernel): Implement robust proto-get and suppress heartbeat noise in CLI
Some checks failed
Deploy-Agent-V15-Stdin / JOB-V15-STDIN (push) Failing after 2s

This commit is contained in:
2026-04-19 16:58:52 -04:00
parent 63e821ede3
commit 8bcd07bd45
3 changed files with 19 additions and 8 deletions

View File

@@ -22,6 +22,9 @@
(register-actuator :tool #'execute-tool-action)) (register-actuator :tool #'execute-tool-action))
(defun dispatch-action (action context) (defun dispatch-action (action context)
(let ((payload (proto-get action :payload)))
(when (eq (proto-get payload :sensor) :heartbeat)
(return-from dispatch-action nil)))
"Routes an approved action to its registered physical actuator." "Routes an approved action to its registered physical actuator."
(when (and action (listp action)) (when (and action (listp action))
(let* ((raw-target (or (ignore-errors (getf action :TARGET)) (let* ((raw-target (or (ignore-errors (getf action :TARGET))
@@ -70,8 +73,8 @@
(defun act-gate (signal) (defun act-gate (signal)
"Final Stage: Actuation and feedback generation." "Final Stage: Actuation and feedback generation."
(let* ((approved (getf signal :approved-action)) (let* ((approved (proto-get signal :approved-action))
(type (getf signal :type)) (type (proto-get signal :type))
(feedback nil)) (feedback nil))
;; 1. Last-Mile Safety Check (The Bouncer & Deterministic Gates) ;; 1. Last-Mile Safety Check (The Bouncer & Deterministic Gates)
@@ -83,11 +86,11 @@
(not (member original-type '(:LOG :EVENT :log :event)))) (not (member original-type '(:LOG :EVENT :log :event))))
(progn (progn
(harness-log "ACT BLOCKED: Action failed last-mile deterministic check.") (harness-log "ACT BLOCKED: Action failed last-mile deterministic check.")
(setf (getf signal :approved-action) nil) (setf (proto-get signal :approved-action) nil)
(setf approved nil) (setf approved nil)
(setf feedback verified)) (setf feedback verified))
(progn (progn
(setf (getf signal :approved-action) verified) (setf (proto-get signal :approved-action) verified)
(setf approved verified))))) (setf approved verified)))))
;; 2. Actuation Logic ;; 2. Actuation Logic
@@ -96,18 +99,18 @@
(:LOG (dispatch-action signal signal)) (:LOG (dispatch-action signal signal))
(:EVENT (:EVENT
(if approved (if approved
(let* ((target (getf approved :target)) (let* ((target (proto-get approved :target))
(result (dispatch-action approved signal))) (result (dispatch-action approved signal)))
;; If the actuator returns a signal (like :tool-output), it becomes the feedback. ;; If the actuator returns a signal (like :tool-output), it becomes the feedback.
;; Otherwise, generate tool-output feedback for non-silent actuators. ;; Otherwise, generate tool-output feedback for non-silent actuators.
(cond ((and (listp result) (member (getf result :type) '(:EVENT :LOG))) (cond ((and (listp result) (member (getf result :type) '(:EVENT :LOG)))
(setf feedback result)) (setf feedback result))
((and result (not (member target *silent-actuators*))) ((and result (not (member target *silent-actuators*)))
(setf feedback (list :type :EVENT :depth (1+ (getf signal :depth 0)) (setf feedback (list :type :EVENT :depth (1+ (or (proto-get signal :depth) 0))
:reply-stream (getf signal :reply-stream) :reply-stream (proto-get signal :reply-stream)
:payload (list :sensor :tool-output :result result :tool approved)))))) :payload (list :sensor :tool-output :result result :tool approved))))))
;; If no approved action but we have a reply-stream, this might be a raw event/log stimulus. ;; If no approved action but we have a reply-stream, this might be a raw event/log stimulus.
(when (getf signal :reply-stream) (when (proto-get signal :reply-stream)
(dispatch-action signal signal))))) (dispatch-action signal signal)))))
(setf (getf signal :status) :acted) (setf (getf signal :status) :acted)

View File

@@ -93,3 +93,10 @@
(error (c) (error (c)
(harness-log "PROTOCOL READ ERROR: ~a" c) (harness-log "PROTOCOL READ ERROR: ~a" c)
:error)))) :error))))
(defun proto-get (plist key)
"Robustly retrieves a value from a plist, checking both uppercase and lowercase keyword versions."
(let* ((s (string key))
(up (intern (string-upcase s) :keyword))
(dn (intern (string-downcase s) :keyword)))
(or (getf plist up) (getf plist dn))))

View File

@@ -5,6 +5,7 @@
#:frame-message #:frame-message
#:read-framed-message #:read-framed-message
#:parse-message #:parse-message
#:proto-get
#:make-hello-message #:make-hello-message
#:validate-communication-protocol-schema #:validate-communication-protocol-schema