fix: HITL functions now properly loaded, define missing proto-get
Some checks failed
Deploy (Gitea) / deploy (push) Has been cancelled
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:
@@ -1,5 +1,9 @@
|
||||
(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)
|
||||
"Global registry mapping target keywords to their physical actuator functions.")
|
||||
|
||||
|
||||
@@ -66,6 +66,11 @@
|
||||
#:dispatch-gate
|
||||
#:register-pre-reason-handler
|
||||
#:inject-stimulus
|
||||
#:stimulus-inject
|
||||
#:hitl-create
|
||||
#:hitl-approve
|
||||
#:hitl-deny
|
||||
#:hitl-handle-message
|
||||
#:actuator-initialize
|
||||
#:dispatch-action
|
||||
#:register-actuator
|
||||
|
||||
@@ -91,7 +91,8 @@
|
||||
(string= n "core-loop-reason")
|
||||
(string= n "core-loop-act")
|
||||
(string= n "core-loop")
|
||||
(string= n "core-manifest"))))
|
||||
(string= n "core-manifest")
|
||||
(string= n "security-dispatcher"))))
|
||||
all-files))
|
||||
(adj (make-hash-table :test 'equal))
|
||||
(name-to-file (make-hash-table :test 'equal))
|
||||
|
||||
BIN
lisp/security-dispatcher.fasl
Normal file
BIN
lisp/security-dispatcher.fasl
Normal file
Binary file not shown.
@@ -1,3 +1,5 @@
|
||||
(in-package :passepartout)
|
||||
|
||||
(defvar *dispatcher-network-whitelist*
|
||||
'("api.telegram.org" "matrix.org" "googleapis.com" "openai.com" "anthropic.com")
|
||||
"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)
|
||||
"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)
|
||||
(list :type :REQUEST :target :emacs
|
||||
: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)
|
||||
"Saves a blocked action for HITL approval. Returns a plist with
|
||||
: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)
|
||||
(log-message "HITL: Created pending approval ~a" token)
|
||||
(list :token token
|
||||
@@ -366,15 +368,15 @@ Recognized formats:
|
||||
approve HITL-abc123
|
||||
deny HITL-abc123"
|
||||
(let ((text (string-trim '(#\Space) (or text ""))))
|
||||
(when (or (uiop:string-prefix-p "/approve" text :test #'char-equal)
|
||||
(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 (string-downcase "approve") (string-downcase text)))
|
||||
(let* ((parts (uiop:split-string text :separator '(#\Space #\Tab)))
|
||||
(token (when (> (length parts) 1) (second parts))))
|
||||
(when (and token (hitl-approve token))
|
||||
(log-message "HITL: Approved via ~a — ~a" (or source :unknown) token)
|
||||
(return-from hitl-handle-message t))))
|
||||
(when (or (uiop:string-prefix-p "/deny" text :test #'char-equal)
|
||||
(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 (string-downcase "deny") (string-downcase text)))
|
||||
(let* ((parts (uiop:split-string text :separator '(#\Space #\Tab)))
|
||||
(token (when (> (length parts) 1) (second parts))))
|
||||
(when (and token (hitl-deny token))
|
||||
|
||||
@@ -36,6 +36,18 @@ The 6-character hex length supports messages up to ~16MB (0xFFFFFF bytes). This
|
||||
(in-package :passepartout)
|
||||
#+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
|
||||
|
||||
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~.
|
||||
|
||||
@@ -91,6 +91,11 @@ The package definition. All public symbols are exported here.
|
||||
#:dispatch-gate
|
||||
#:register-pre-reason-handler
|
||||
#:inject-stimulus
|
||||
#:stimulus-inject
|
||||
#:hitl-create
|
||||
#:hitl-approve
|
||||
#:hitl-deny
|
||||
#:hitl-handle-message
|
||||
#:actuator-initialize
|
||||
#:dispatch-action
|
||||
#:register-actuator
|
||||
|
||||
@@ -186,7 +186,8 @@ Both ~.org~ and ~.lisp~ files are included. For each skill, the ~.org~ file supp
|
||||
(string= n "core-loop-reason")
|
||||
(string= n "core-loop-act")
|
||||
(string= n "core-loop")
|
||||
(string= n "core-manifest"))))
|
||||
(string= n "core-manifest")
|
||||
(string= n "security-dispatcher"))))
|
||||
all-files))
|
||||
(adj (make-hash-table :test 'equal))
|
||||
(name-to-file (make-hash-table :test 'equal))
|
||||
|
||||
@@ -24,7 +24,11 @@ The Bouncer also handles the **Flight Plan** system: when a high-risk action is
|
||||
|
||||
* Implementation
|
||||
|
||||
* Implementation
|
||||
** Package Context
|
||||
|
||||
#+begin_src lisp
|
||||
(in-package :passepartout)
|
||||
#+end_src
|
||||
|
||||
** Security Configuration — network whitelist
|
||||
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
|
||||
(defun dispatcher-flight-plan-create (blocked-action)
|
||||
"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)
|
||||
(list :type :REQUEST :target :emacs
|
||||
: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)
|
||||
"Saves a blocked action for HITL approval. Returns a plist with
|
||||
: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)
|
||||
(log-message "HITL: Created pending approval ~a" token)
|
||||
(list :token token
|
||||
@@ -542,15 +546,15 @@ Recognized formats:
|
||||
approve HITL-abc123
|
||||
deny HITL-abc123"
|
||||
(let ((text (string-trim '(#\Space) (or text ""))))
|
||||
(when (or (uiop:string-prefix-p "/approve" text :test #'char-equal)
|
||||
(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 (string-downcase "approve") (string-downcase text)))
|
||||
(let* ((parts (uiop:split-string text :separator '(#\Space #\Tab)))
|
||||
(token (when (> (length parts) 1) (second parts))))
|
||||
(when (and token (hitl-approve token))
|
||||
(log-message "HITL: Approved via ~a — ~a" (or source :unknown) token)
|
||||
(return-from hitl-handle-message t))))
|
||||
(when (or (uiop:string-prefix-p "/deny" text :test #'char-equal)
|
||||
(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 (string-downcase "deny") (string-downcase text)))
|
||||
(let* ((parts (uiop:split-string text :separator '(#\Space #\Tab)))
|
||||
(token (when (> (length parts) 1) (second parts))))
|
||||
(when (and token (hitl-deny token))
|
||||
|
||||
@@ -11,6 +11,7 @@
|
||||
(:file "lisp/core-communication")
|
||||
(:file "lisp/core-memory")
|
||||
(:file "lisp/core-context")
|
||||
(:file "lisp/security-dispatcher")
|
||||
(:file "lisp/core-loop-perceive")
|
||||
(:file "lisp/core-loop-reason")
|
||||
(:file "lisp/core-loop-act")
|
||||
|
||||
Reference in New Issue
Block a user