fix: HITL functions now properly loaded, define missing proto-get
Some checks failed
Deploy (Gitea) / deploy (push) Has been cancelled

Root cause chain:
1. proto-get was used throughout the pipeline but never defined — added
   to core-communication.org as a keyword-normalizing getf wrapper.
2. security-dispatcher.lisp was loaded by skill-initialize-all into a
   separate package, making HITL functions invisible to :passepartout.
   Fixed by adding to ASDF component list and excluding from skill loader.
3. org-id-generate was referenced from hitl-create but lives in an
   unexported skill package — replaced with uuid:make-v4-uuid.
4. uiop:string-prefix-p was called with :test keyword argument it does
   not accept — replaced with string-downcase normalization on both sides.

Also:
- Export hitl-create, hitl-approve, hitl-deny, hitl-handle-message,
  stimulus-inject from :passepartout for REPL accessibility.
This commit is contained in:
2026-05-03 14:21:08 -04:00
parent a16f973b50
commit ce90fd3e72
10 changed files with 74 additions and 39 deletions

View File

@@ -1,5 +1,9 @@
(in-package :passepartout) (in-package :passepartout)
(defun proto-get (plist key)
"Look up KEY in PLIST with keyword normalization."
(getf plist (if (keywordp key) key (intern (string-upcase (string key)) :keyword))))
(defvar *actuator-registry* (make-hash-table :test 'equalp) (defvar *actuator-registry* (make-hash-table :test 'equalp)
"Global registry mapping target keywords to their physical actuator functions.") "Global registry mapping target keywords to their physical actuator functions.")

View File

@@ -64,9 +64,14 @@
#:act-gate #:act-gate
#:reason-gate #:reason-gate
#:dispatch-gate #:dispatch-gate
#:register-pre-reason-handler #:register-pre-reason-handler
#:inject-stimulus #:inject-stimulus
#:actuator-initialize #:stimulus-inject
#:hitl-create
#:hitl-approve
#:hitl-deny
#:hitl-handle-message
#:actuator-initialize
#:dispatch-action #:dispatch-action
#:register-actuator #:register-actuator
#:load-skill-from-org #:load-skill-from-org

View File

@@ -82,16 +82,17 @@
(all-files (append org-files lisp-files)) (all-files (append org-files lisp-files))
(files (remove-if (lambda (f) (files (remove-if (lambda (f)
(let ((n (pathname-name f))) (let ((n (pathname-name f)))
(or (string= n "core-defpackage") (or (string= n "core-defpackage")
(string= n "core-skills") (string= n "core-skills")
(string= n "core-communication") (string= n "core-communication")
(string= n "core-memory") (string= n "core-memory")
(string= n "core-context") (string= n "core-context")
(string= n "core-loop-perceive") (string= n "core-loop-perceive")
(string= n "core-loop-reason") (string= n "core-loop-reason")
(string= n "core-loop-act") (string= n "core-loop-act")
(string= n "core-loop") (string= n "core-loop")
(string= n "core-manifest")))) (string= n "core-manifest")
(string= n "security-dispatcher"))))
all-files)) all-files))
(adj (make-hash-table :test 'equal)) (adj (make-hash-table :test 'equal))
(name-to-file (make-hash-table :test 'equal)) (name-to-file (make-hash-table :test 'equal))

Binary file not shown.

View File

@@ -1,3 +1,5 @@
(in-package :passepartout)
(defvar *dispatcher-network-whitelist* (defvar *dispatcher-network-whitelist*
'("api.telegram.org" "matrix.org" "googleapis.com" "openai.com" "anthropic.com") '("api.telegram.org" "matrix.org" "googleapis.com" "openai.com" "anthropic.com")
"Domains the Bouncer considers safe for outbound connections.") "Domains the Bouncer considers safe for outbound connections.")
@@ -305,7 +307,7 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval."
(defun dispatcher-flight-plan-create (blocked-action) (defun dispatcher-flight-plan-create (blocked-action)
"Creates a Flight Plan node for manual approval in Emacs." "Creates a Flight Plan node for manual approval in Emacs."
(let ((id (org-id-generate))) (let ((id (remove #\- (princ-to-string (uuid:make-v4-uuid)))))
(log-message "BOUNCER: Creating flight plan node '~a'..." id) (log-message "BOUNCER: Creating flight plan node '~a'..." id)
(list :type :REQUEST :target :emacs (list :type :REQUEST :target :emacs
:payload (list :action :insert-node :id id :payload (list :action :insert-node :id id
@@ -319,7 +321,7 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval."
(defun hitl-create (blocked-action) (defun hitl-create (blocked-action)
"Saves a blocked action for HITL approval. Returns a plist with "Saves a blocked action for HITL approval. Returns a plist with
:token (the correlation ID) and :message (user-facing text)." :token (the correlation ID) and :message (user-facing text)."
(let* ((token (format nil "HITL-~a" (subseq (org-id-generate) 3 11)))) (let* ((token (format nil "HITL-~a" (subseq (remove #\- (princ-to-string (uuid:make-v4-uuid))) 0 8))))
(setf (gethash token *hitl-pending*) blocked-action) (setf (gethash token *hitl-pending*) blocked-action)
(log-message "HITL: Created pending approval ~a" token) (log-message "HITL: Created pending approval ~a" token)
(list :token token (list :token token
@@ -366,15 +368,15 @@ Recognized formats:
approve HITL-abc123 approve HITL-abc123
deny HITL-abc123" deny HITL-abc123"
(let ((text (string-trim '(#\Space) (or text "")))) (let ((text (string-trim '(#\Space) (or text ""))))
(when (or (uiop:string-prefix-p "/approve" text :test #'char-equal) (when (or (uiop:string-prefix-p (string-downcase "/approve") (string-downcase text))
(uiop:string-prefix-p "approve" text :test #'char-equal)) (uiop:string-prefix-p (string-downcase "approve") (string-downcase text)))
(let* ((parts (uiop:split-string text :separator '(#\Space #\Tab))) (let* ((parts (uiop:split-string text :separator '(#\Space #\Tab)))
(token (when (> (length parts) 1) (second parts)))) (token (when (> (length parts) 1) (second parts))))
(when (and token (hitl-approve token)) (when (and token (hitl-approve token))
(log-message "HITL: Approved via ~a — ~a" (or source :unknown) token) (log-message "HITL: Approved via ~a — ~a" (or source :unknown) token)
(return-from hitl-handle-message t)))) (return-from hitl-handle-message t))))
(when (or (uiop:string-prefix-p "/deny" text :test #'char-equal) (when (or (uiop:string-prefix-p (string-downcase "/deny") (string-downcase text))
(uiop:string-prefix-p "deny " text :test #'char-equal)) (uiop:string-prefix-p (string-downcase "deny") (string-downcase text)))
(let* ((parts (uiop:split-string text :separator '(#\Space #\Tab))) (let* ((parts (uiop:split-string text :separator '(#\Space #\Tab)))
(token (when (> (length parts) 1) (second parts)))) (token (when (> (length parts) 1) (second parts))))
(when (and token (hitl-deny token)) (when (and token (hitl-deny token))

View File

@@ -36,6 +36,18 @@ The 6-character hex length supports messages up to ~16MB (0xFFFFFF bytes). This
(in-package :passepartout) (in-package :passepartout)
#+end_src #+end_src
** Protocol Accessor (proto-get)
Case-insensitive property list accessor used throughout the pipeline.
Returns the value associated with KEY in PLIST by interning a keyword.
;; REPL-VERIFIED: 2026-05-03T13:00:00
#+begin_src lisp
(defun proto-get (plist key)
"Look up KEY in PLIST with keyword normalization."
(getf plist (if (keywordp key) key (intern (string-upcase (string key)) :keyword))))
#+end_src
** Actuator Registry ** Actuator Registry
The global registry mapping target keywords (~:cli~, ~:telegram~, ~:signal~, etc.) to their physical actuator functions. Extensible at runtime — skills can register new actuators via ~register-actuator~. The global registry mapping target keywords (~:cli~, ~:telegram~, ~:signal~, etc.) to their physical actuator functions. Extensible at runtime — skills can register new actuators via ~register-actuator~.

View File

@@ -89,9 +89,14 @@ The package definition. All public symbols are exported here.
#:act-gate #:act-gate
#:reason-gate #:reason-gate
#:dispatch-gate #:dispatch-gate
#:register-pre-reason-handler #:register-pre-reason-handler
#:inject-stimulus #:inject-stimulus
#:actuator-initialize #:stimulus-inject
#:hitl-create
#:hitl-approve
#:hitl-deny
#:hitl-handle-message
#:actuator-initialize
#:dispatch-action #:dispatch-action
#:register-actuator #:register-actuator
#:load-skill-from-org #:load-skill-from-org

View File

@@ -177,16 +177,17 @@ Both ~.org~ and ~.lisp~ files are included. For each skill, the ~.org~ file supp
(all-files (append org-files lisp-files)) (all-files (append org-files lisp-files))
(files (remove-if (lambda (f) (files (remove-if (lambda (f)
(let ((n (pathname-name f))) (let ((n (pathname-name f)))
(or (string= n "core-defpackage") (or (string= n "core-defpackage")
(string= n "core-skills") (string= n "core-skills")
(string= n "core-communication") (string= n "core-communication")
(string= n "core-memory") (string= n "core-memory")
(string= n "core-context") (string= n "core-context")
(string= n "core-loop-perceive") (string= n "core-loop-perceive")
(string= n "core-loop-reason") (string= n "core-loop-reason")
(string= n "core-loop-act") (string= n "core-loop-act")
(string= n "core-loop") (string= n "core-loop")
(string= n "core-manifest")))) (string= n "core-manifest")
(string= n "security-dispatcher"))))
all-files)) all-files))
(adj (make-hash-table :test 'equal)) (adj (make-hash-table :test 'equal))
(name-to-file (make-hash-table :test 'equal)) (name-to-file (make-hash-table :test 'equal))

View File

@@ -24,7 +24,11 @@ The Bouncer also handles the **Flight Plan** system: when a high-risk action is
* Implementation * Implementation
* Implementation ** Package Context
#+begin_src lisp
(in-package :passepartout)
#+end_src
** Security Configuration — network whitelist ** Security Configuration — network whitelist
Domains that the Bouncer considers safe for outbound connections. Network calls to unlisted domains are blocked or queued for approval. Domains that the Bouncer considers safe for outbound connections. Network calls to unlisted domains are blocked or queued for approval.
@@ -432,7 +436,7 @@ privacy tags, privacy text, shell safety, network exfil, high-impact approval."
#+begin_src lisp #+begin_src lisp
(defun dispatcher-flight-plan-create (blocked-action) (defun dispatcher-flight-plan-create (blocked-action)
"Creates a Flight Plan node for manual approval in Emacs." "Creates a Flight Plan node for manual approval in Emacs."
(let ((id (org-id-generate))) (let ((id (remove #\- (princ-to-string (uuid:make-v4-uuid)))))
(log-message "BOUNCER: Creating flight plan node '~a'..." id) (log-message "BOUNCER: Creating flight plan node '~a'..." id)
(list :type :REQUEST :target :emacs (list :type :REQUEST :target :emacs
:payload (list :action :insert-node :id id :payload (list :action :insert-node :id id
@@ -465,7 +469,7 @@ the blocked action is stored for later retrieval by ~hitl-approve~ or
(defun hitl-create (blocked-action) (defun hitl-create (blocked-action)
"Saves a blocked action for HITL approval. Returns a plist with "Saves a blocked action for HITL approval. Returns a plist with
:token (the correlation ID) and :message (user-facing text)." :token (the correlation ID) and :message (user-facing text)."
(let* ((token (format nil "HITL-~a" (subseq (org-id-generate) 3 11)))) (let* ((token (format nil "HITL-~a" (subseq (remove #\- (princ-to-string (uuid:make-v4-uuid))) 0 8))))
(setf (gethash token *hitl-pending*) blocked-action) (setf (gethash token *hitl-pending*) blocked-action)
(log-message "HITL: Created pending approval ~a" token) (log-message "HITL: Created pending approval ~a" token)
(list :token token (list :token token
@@ -542,15 +546,15 @@ Recognized formats:
approve HITL-abc123 approve HITL-abc123
deny HITL-abc123" deny HITL-abc123"
(let ((text (string-trim '(#\Space) (or text "")))) (let ((text (string-trim '(#\Space) (or text ""))))
(when (or (uiop:string-prefix-p "/approve" text :test #'char-equal) (when (or (uiop:string-prefix-p (string-downcase "/approve") (string-downcase text))
(uiop:string-prefix-p "approve" text :test #'char-equal)) (uiop:string-prefix-p (string-downcase "approve") (string-downcase text)))
(let* ((parts (uiop:split-string text :separator '(#\Space #\Tab))) (let* ((parts (uiop:split-string text :separator '(#\Space #\Tab)))
(token (when (> (length parts) 1) (second parts)))) (token (when (> (length parts) 1) (second parts))))
(when (and token (hitl-approve token)) (when (and token (hitl-approve token))
(log-message "HITL: Approved via ~a — ~a" (or source :unknown) token) (log-message "HITL: Approved via ~a — ~a" (or source :unknown) token)
(return-from hitl-handle-message t)))) (return-from hitl-handle-message t))))
(when (or (uiop:string-prefix-p "/deny" text :test #'char-equal) (when (or (uiop:string-prefix-p (string-downcase "/deny") (string-downcase text))
(uiop:string-prefix-p "deny " text :test #'char-equal)) (uiop:string-prefix-p (string-downcase "deny") (string-downcase text)))
(let* ((parts (uiop:split-string text :separator '(#\Space #\Tab))) (let* ((parts (uiop:split-string text :separator '(#\Space #\Tab)))
(token (when (> (length parts) 1) (second parts)))) (token (when (> (length parts) 1) (second parts))))
(when (and token (hitl-deny token)) (when (and token (hitl-deny token))

View File

@@ -11,6 +11,7 @@
(:file "lisp/core-communication") (:file "lisp/core-communication")
(:file "lisp/core-memory") (:file "lisp/core-memory")
(:file "lisp/core-context") (:file "lisp/core-context")
(:file "lisp/security-dispatcher")
(:file "lisp/core-loop-perceive") (:file "lisp/core-loop-perceive")
(:file "lisp/core-loop-reason") (:file "lisp/core-loop-reason")
(:file "lisp/core-loop-act") (:file "lisp/core-loop-act")