diff --git a/lisp/core-communication.lisp b/lisp/core-communication.lisp index 72ba3d3..2f9a58f 100644 --- a/lisp/core-communication.lisp +++ b/lisp/core-communication.lisp @@ -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.") diff --git a/lisp/core-defpackage.lisp b/lisp/core-defpackage.lisp index 0fc589a..0631e8a 100644 --- a/lisp/core-defpackage.lisp +++ b/lisp/core-defpackage.lisp @@ -64,9 +64,14 @@ #:act-gate #:reason-gate #:dispatch-gate - #:register-pre-reason-handler - #:inject-stimulus - #:actuator-initialize + #:register-pre-reason-handler + #:inject-stimulus + #:stimulus-inject + #:hitl-create + #:hitl-approve + #:hitl-deny + #:hitl-handle-message + #:actuator-initialize #:dispatch-action #:register-actuator #:load-skill-from-org diff --git a/lisp/core-skills.lisp b/lisp/core-skills.lisp index 35840bb..dfdd976 100644 --- a/lisp/core-skills.lisp +++ b/lisp/core-skills.lisp @@ -82,16 +82,17 @@ (all-files (append org-files lisp-files)) (files (remove-if (lambda (f) (let ((n (pathname-name f))) - (or (string= n "core-defpackage") - (string= n "core-skills") - (string= n "core-communication") - (string= n "core-memory") - (string= n "core-context") - (string= n "core-loop-perceive") - (string= n "core-loop-reason") - (string= n "core-loop-act") - (string= n "core-loop") - (string= n "core-manifest")))) + (or (string= n "core-defpackage") + (string= n "core-skills") + (string= n "core-communication") + (string= n "core-memory") + (string= n "core-context") + (string= n "core-loop-perceive") + (string= n "core-loop-reason") + (string= n "core-loop-act") + (string= n "core-loop") + (string= n "core-manifest") + (string= n "security-dispatcher")))) all-files)) (adj (make-hash-table :test 'equal)) (name-to-file (make-hash-table :test 'equal)) diff --git a/lisp/security-dispatcher.fasl b/lisp/security-dispatcher.fasl new file mode 100644 index 0000000..331e198 Binary files /dev/null and b/lisp/security-dispatcher.fasl differ diff --git a/lisp/security-dispatcher.lisp b/lisp/security-dispatcher.lisp index 18ddec9..78aab44 100644 --- a/lisp/security-dispatcher.lisp +++ b/lisp/security-dispatcher.lisp @@ -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)) diff --git a/org/core-communication.org b/org/core-communication.org index 5875dca..477dbda 100644 --- a/org/core-communication.org +++ b/org/core-communication.org @@ -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~. diff --git a/org/core-defpackage.org b/org/core-defpackage.org index 3907118..092fa0b 100644 --- a/org/core-defpackage.org +++ b/org/core-defpackage.org @@ -89,9 +89,14 @@ The package definition. All public symbols are exported here. #:act-gate #:reason-gate #:dispatch-gate - #:register-pre-reason-handler - #:inject-stimulus - #:actuator-initialize + #:register-pre-reason-handler + #:inject-stimulus + #:stimulus-inject + #:hitl-create + #:hitl-approve + #:hitl-deny + #:hitl-handle-message + #:actuator-initialize #:dispatch-action #:register-actuator #:load-skill-from-org diff --git a/org/core-skills.org b/org/core-skills.org index 4741964..73b16db 100644 --- a/org/core-skills.org +++ b/org/core-skills.org @@ -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)) (files (remove-if (lambda (f) (let ((n (pathname-name f))) - (or (string= n "core-defpackage") - (string= n "core-skills") - (string= n "core-communication") - (string= n "core-memory") - (string= n "core-context") - (string= n "core-loop-perceive") - (string= n "core-loop-reason") - (string= n "core-loop-act") - (string= n "core-loop") - (string= n "core-manifest")))) + (or (string= n "core-defpackage") + (string= n "core-skills") + (string= n "core-communication") + (string= n "core-memory") + (string= n "core-context") + (string= n "core-loop-perceive") + (string= n "core-loop-reason") + (string= n "core-loop-act") + (string= n "core-loop") + (string= n "core-manifest") + (string= n "security-dispatcher")))) all-files)) (adj (make-hash-table :test 'equal)) (name-to-file (make-hash-table :test 'equal)) diff --git a/org/security-dispatcher.org b/org/security-dispatcher.org index 6b62fd7..6a08f45 100644 --- a/org/security-dispatcher.org +++ b/org/security-dispatcher.org @@ -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)) diff --git a/passepartout.asd b/passepartout.asd index 55b1d3f..69cb0e0 100644 --- a/passepartout.asd +++ b/passepartout.asd @@ -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")