From 294c1a976e320dfba293b6880fc4288936cc1952 Mon Sep 17 00:00:00 2001 From: Amr Gharbeia Date: Sun, 12 Apr 2026 16:43:43 -0400 Subject: [PATCH] PSF: Complete 'Thin Harness' refactor and move kernel logic to skills --- literate/context.org | 60 +-------- literate/neurosymbolic.org | 187 ++++++--------------------- literate/skills.org | 2 +- org-agent.asd | 4 +- skills/org-skill-bouncer.org | 5 + skills/org-skill-consensus.org | 1 + skills/org-skill-inbox-processor.org | 3 + skills/org-skill-self-fix.org | 2 + skills/org-skill-shell-actuator.org | 24 +++- skills/org-skill-task-integrity.org | 84 +++++++----- src/bouncer.lisp | 5 + src/chat-logic.lisp | 29 ++++- src/consensus-logic.lisp | 1 + src/context-logic.lisp | 72 +++++++++++ src/embedding-logic.lisp | 60 +++++++++ src/gateway-matrix.lisp | 57 ++++---- src/gateway-signal.lisp | 2 +- src/gateway-telegram.lisp | 22 ++-- src/lisp-repair.lisp | 5 +- src/neuro.lisp | 42 +----- src/processor-logic.lisp | 3 + src/protocol-validator.lisp | 39 ++++++ src/safety-harness.lisp | 42 ------ src/self-fix.lisp | 24 ++-- src/shell-logic.lisp | 31 ++--- src/skills.lisp | 2 +- src/symbolic.lisp | 96 +++++--------- src/task-integrity.lisp | 16 +++ 28 files changed, 454 insertions(+), 466 deletions(-) create mode 100644 src/context-logic.lisp create mode 100644 src/embedding-logic.lisp create mode 100644 src/protocol-validator.lisp create mode 100644 src/task-integrity.lisp diff --git a/literate/context.org b/literate/context.org index 059311c..10be5f4 100644 --- a/literate/context.org +++ b/literate/context.org @@ -181,67 +181,11 @@ The primary context generator. It identifies active projects and the current fov output)) #+end_src -* Semantic Search (embedding.lisp) -The `embedding.lisp` module handles vector representations and cosine similarity for semantic discovery. - -** Package Context -#+begin_src lisp :tangle ../src/embedding.lisp -(in-package :org-agent) -#+end_src - -** Embedding Retrieval (get-embedding) -Fetches a numerical vector representation of text from the configured provider (defaults to Gemini `text-embedding-004`). - -#+begin_src lisp :tangle ../src/embedding.lisp -(defun get-embedding (text) - "Retrieves a vector representation of text via the configured neural provider." - (let* ((auth (get-provider-auth :gemini)) (api-key (getf auth :api-key)) - (endpoint "https://generativelanguage.googleapis.com/v1beta/models/text-embedding-004:embedContent")) - (unless api-key (return-from get-embedding nil)) - (let* ((url (format nil "~a?key=~a" endpoint api-key)) (headers `(("Content-Type" . "application/json"))) - (body (cl-json:encode-json-to-string `((model . "models/text-embedding-004") (content . ((parts . ((text . ,text))))))))) - (handler-case (let* ((response (dex:post url :headers headers :content body)) - (json (cl-json:decode-json-from-string response))) - (cdr (assoc :values (cdr (assoc :embedding json))))) - (error (c) (kernel-log "EMBEDDING FAILURE: ~a" c) nil))))) -#+end_src - -** Vector Math -Simple implementations of dot product and magnitude for similarity calculations. - -#+begin_src lisp :tangle ../src/embedding.lisp -(defun dot-product (v1 v2) - "Calculates the dot product of two numerical vectors." - (reduce #'+ (mapcar #'* v1 v2))) - -(defun magnitude (v) - "Calculates the Euclidean magnitude of a numerical vector." - (sqrt (reduce #'+ (mapcar (lambda (x) (* x x)) v)))) -#+end_src - -** Cosine Similarity (cosine-similarity) -Calculates the semantic distance (normalized dot product) between two vectors. - -#+begin_src lisp :tangle ../src/embedding.lisp -(defun cosine-similarity (v1 v2) - "Calculates the semantic distance between two vectors." - (let ((m1 (magnitude v1)) (m2 (magnitude v2))) (if (or (zerop m1) (zerop m2)) 0 (/ (dot-product v1 v2) (* m1 m2))))) -#+end_src - -** Semantic Discovery (find-most-similar) -Identifies the top-k most semantically related objects in the entire store by comparing their cached vectors against a query vector. - -#+begin_src lisp :tangle ../src/embedding.lisp -(defun find-most-similar (query-vector top-k) - "Identifies the top-k most semantically related objects in the store." - (let ((similarities nil)) - (maphash (lambda (id obj) (let ((vec (org-object-vector obj))) (when vec (push (cons (cosine-similarity query-vector vec) obj) similarities)))) *object-store*) - (let ((sorted (sort similarities #'> :key #'car))) (subseq sorted 0 (min top-k (length sorted)))))) -#+end_src - * Phase E: Chaos (Verification) Verification of the peripheral vision extraction and rendering logic. +Verification of the peripheral vision extraction and rendering logic. + #+begin_src lisp :tangle ../tests/peripheral-vision-tests.lisp (defpackage :org-agent-peripheral-vision-tests (:use :cl :fiveam :org-agent) diff --git a/literate/neurosymbolic.org b/literate/neurosymbolic.org index f6c9edc..cf171c3 100644 --- a/literate/neurosymbolic.org +++ b/literate/neurosymbolic.org @@ -10,56 +10,13 @@ Associative (LLM) is creative but hallucination-prone. Deliberate (Lisp) is rigi - **Sovereign Decoupling:** By moving the physical API logic into skills, the core remains a neutral "Thinking Engine" that doesn't care if the imagination comes from Google, Anthropic, or a local Llama instance. * Associative Engine (neuro.lisp) -This module handles the interaction with Large Language Models, providing a unified interface for multiple backends. +This module handles the interaction with Large Language Models, providing a unified interface for multiple backends. As a "Thin Harness," it does not handle authentication or specific provider logic; these are delegated to skills. ** Package Context #+begin_src lisp :tangle ../src/neuro.lisp (in-package :org-agent) #+end_src -** Environment Access -#+begin_src lisp :tangle ../src/neuro.lisp -(defun get-env (var &optional default) (or (uiop:getenv var) default)) -#+end_src - -** Auth Providers Registry -Tracks API keys and authentication functions for various providers. - -#+begin_src lisp :tangle ../src/neuro.lisp -(defvar *auth-providers* (make-hash-table :test 'equal)) -#+end_src - -** Register Auth Provider -Registers a function or list to provide authentication for a specific backend. - -#+begin_src lisp :tangle ../src/neuro.lisp -(defun register-auth-provider (name fn) (setf (gethash name *auth-providers*) fn)) -#+end_src - -** Get Provider Auth -Retrieves authentication credentials for a provider, falling back to environment variables if not found in the registry. - -#+begin_src lisp :tangle ../src/neuro.lisp -(defun get-provider-auth (provider) - "Retrieves authentication credentials for a provider." - (let ((auth (gethash provider *auth-providers*))) - (cond - ((functionp auth) (funcall auth)) - ((listp auth) auth) - (t - (let ((specific-key (case provider - (:gemini (uiop:getenv "GEMINI_API_KEY")) - (:openrouter (uiop:getenv "OPENROUTER_API_KEY")) - (:anthropic (uiop:getenv "ANTHROPIC_API_KEY")) - (:openai (uiop:getenv "OPENAI_API_KEY")) - (t nil)))) - (if (and specific-key (> (length specific-key) 0)) - (list :api-key specific-key) - (let ((legacy (uiop:getenv "LLM_API_KEY"))) - (when (and legacy (> (length legacy) 0)) - (list :api-key legacy))))))))) -#+end_src - ** Associative Backends Registry Tracks the actual implementation functions for each LLM provider. @@ -68,10 +25,10 @@ Tracks the actual implementation functions for each LLM provider. #+end_src ** Provider Cascade -The ordered list of backends to attempt for neural reasoning. +The ordered list of backends to attempt for neural reasoning. This is a default that can be overridden by skills like the Token Accountant. #+begin_src lisp :tangle ../src/neuro.lisp -(defvar *provider-cascade* '(:openrouter :gemini)) +(defvar *provider-cascade* '(:openrouter :gemini-api)) #+end_src ** Register Associative Backend @@ -89,10 +46,10 @@ A hook for dynamic model selection based on the current context. #+end_src ** Associative Dispatch (ask-neuro) -The primary entry point for Associative. It handles the retry logic and backend selection. It supports a parallel consensus mode where all backends are queried simultaneously. +The primary entry point for Associative. It handles the retry logic and backend selection. It supports a parallel consensus mode where multiple backends are queried. #+begin_src lisp :tangle ../src/neuro.lisp -(defvar *consensus-enabled-p* t "If T, ask-neuro queries all backends in parallel.") +(defvar *consensus-enabled-p* nil "If T, ask-neuro queries all backends in parallel.") (defun ask-neuro (prompt &key (system-prompt "You are the Associative engine of a Neurosymbolic Lisp Machine.") (cascade nil) (context nil)) "Dispatches a neural request through the provider cascade or parallel consensus." @@ -130,7 +87,7 @@ The primary entry point for Associative. It handles the retry logic and backend (format nil "~{~a~^|CONSENSUS-SEP|~}" valid-results) "(:type :LOG :payload (:text \"Neural Consensus Failure\"))"))) - ;; SEQUENTIAL CASCADE MODE (Legacy) + ;; SEQUENTIAL CASCADE MODE (or (dolist (backend backends) (let ((backend-fn (gethash backend *neuro-backends*))) (when backend-fn @@ -139,28 +96,18 @@ The primary entry point for Associative. It handles the retry logic and backend (result (if model (funcall backend-fn prompt system-prompt :model model) (funcall backend-fn prompt system-prompt)))) - (unless (and (stringp result) (search ":LOG" result) (or (search "Failure" result) (search "missing" result))) + (unless (or (null result) + (and (stringp result) (search ":LOG" result) (or (search "Failure" result) (search "missing" result)))) (return result)))))) "(:type :LOG :payload (:text \"Neural Cascade Failure\"))")))) #+end_src -** Sovereign Service Fallbacks -Standard functions that can be overridden by specific skills to provide enhanced functionality. - -#+begin_src lisp :tangle ../src/neuro.lisp -(defun token-accountant-route-task (context) - "Generic fallback for routing. Overridden by skill-token-accountant." - (declare (ignore context)) - '(:openrouter :gemini)) -#+end_src - ** Associative Reasoning (think) -Invokes the Associative engine to generate a proposed Lisp action. It automatically injects the tool documentation and global context into the prompt. +Invokes the Associative engine to generate a proposed Lisp action based on context. It automatically injects the tool documentation and global context into the prompt. #+begin_src lisp :tangle ../src/neuro.lisp (defun think (context) - "Invokes the neural Associative engine to propose a Lisp action based on context. -If consensus is enabled, it returns a list of proposals from different backends." + "Invokes the neural Associative engine to propose a Lisp action based on context." (let ((active-skill (find-triggered-skill context)) (tool-belt (generate-tool-belt-prompt)) (global-context (context-assemble-global-awareness))) @@ -227,96 +174,44 @@ Allows the agent to self-optimize its own prompts. (ask-neuro (format nil "PROMPT: ~a~%RESULT: ~a" full-prompt successful-output) :system-prompt system-instr))) #+end_src -* Deliberate Logic (symbolic.lisp) -The deterministic gatekeeper that ensures all proposed actions are safe and logically valid. + +* Deliberate Engine (symbolic.lisp) +The deterministic gatekeeper that ensures all proposed actions are safe and logically valid. As a "Thin Harness," the Deliberate engine does not contain specific security rules; instead, it provides a priority-based dispatcher that iterates through all loaded skills to validate or transform proposed actions. ** Package Context #+begin_src lisp :tangle ../src/symbolic.lisp (in-package :org-agent) #+end_src -** Task Integrity Check -Enforces high-integrity semantic rules for task management (e.g. blocking closing parent tasks with active children). - -#+begin_src lisp :tangle ../src/symbolic.lisp -(defun task-integrity-check (action) - "Enforces semantic GTD integrity rules on proposed actions." - (let* ((payload (getf action :payload)) - (act (or (getf payload :action) (getf action :action))) - (id (or (getf payload :id) (getf action :id))) - (new-attrs (or (getf payload :attributes) (getf action :attributes)))) - (when (and (eq act :update-node) (equal (getf new-attrs :TODO) "DONE")) - (let ((children (list-objects-with-attribute :PARENT id))) - (when (some (lambda (child) (let ((todo (getf (org-object-attributes child) :TODO))) - (and todo (not (equal todo "DONE"))))) - children) - (return-from task-integrity-check "Blocked by Task Integrity: Active children exist.")))) - nil)) -#+end_src - -** Authorization Gate (Bouncer) -The Bouncer intercepts high-risk or complex actions and requires manual Foreground approval. - -#+begin_src lisp :tangle ../src/symbolic.lisp -(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)) -#+end_src - ** Validation Gate (decide) -The "Deliberate" supervisor. It intercepts every action proposed by Associative and runs it through the task integrity check, the bouncer, the skill's symbolic gate, and the global safety harness. +The "Deliberate" supervisor. It intercepts every action proposed by Associative and runs it through the symbolic gates of all registered skills, sorted by priority. #+begin_src lisp :tangle ../src/symbolic.lisp (defun decide (proposed-action context) - "The Deliberate Safety Gate: validates or rejects proposed neural actions." - ;; 1. Task Integrity Check (GTD Semantics) - (let ((integrity-error (task-integrity-check proposed-action))) - (when integrity-error - (kernel-log "DELIBERATE [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 "DELIBERATE [BOUNCER]: Action requires manual approval.~%") - (return-from decide - (list :type :EVENT - :payload (list :sensor :approval-required :action proposed-action)))) - - ;; 3. 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)) - (payload (getf proposed-action :payload)) - (action (or (getf payload :action) (getf proposed-action :action))) - (code (or (getf payload :code) (getf proposed-action :code)))) - ;; Global safety harness for EVAL - (when (and (member (getf proposed-action :type) '(:request :REQUEST)) - (member action '(:eval :EVAL))) - (let ((harness-pkg (find-package :org-agent.skills.org-skill-safety-harness))) - (when (and code harness-pkg) - (unless (ignore-errors (uiop:symbol-call :org-agent.skills.org-skill-safety-harness :safety-harness-validate code)) - (kernel-log "DELIBERATE [GLOBAL]: Security violation blocked.~%") - (return-from decide '(:type :LOG :payload (:text "Blocked by Global Safety Harness"))))))) - ;; Skill-specific verification - (if symbolic-gate - (let ((decision (funcall symbolic-gate proposed-action context))) - (if decision - (progn (kernel-log "DELIBERATE: Verified by skill '~a'.~%" (skill-name active-skill)) decision) - (progn (kernel-log "DELIBERATE: REJECTED by skill '~a'.~%" (skill-name active-skill)) - '(:type :LOG :payload (:text "Action rejected by skill heuristics"))))) - (progn (kernel-log "DELIBERATE: Verified (Implicitly safe for skill '~a').~%" (skill-name active-skill)) proposed-action))) - proposed-action))) -#+end_src + "The Deliberate Safety Gate: iterates through all skill symbolic-gates sorted by priority." + (let ((current-action proposed-action) + (skills nil)) + ;; 1. Collect all skills with symbolic gates + (maphash (lambda (name skill) + (declare (ignore name)) + (when (skill-symbolic-fn skill) + (push skill skills))) + *skills-registry*) + + ;; 2. Sort skills by priority (highest first) + (setf skills (sort skills #'> :key #'skill-priority)) + + ;; 3. Execute symbolic gates sequentially + (dolist (skill skills) + (let ((gate (skill-symbolic-fn skill))) + (setf current-action (funcall gate current-action context)) + ;; If any gate returns a LOG or EVENT (blocking/intercepting), stop and return it. + (when (and (listp current-action) + (member (getf current-action :type) '(:LOG :EVENT :log :event))) + (kernel-log "DELIBERATE: Intercepted by skill '~a'~%" (skill-name skill)) + (return-from decide current-action)))) + + current-action)) #+end_src ** Store Filtering (list-objects-with-attribute) @@ -326,6 +221,10 @@ A symbolic helper function to find nodes with specific attributes. (defun list-objects-with-attribute (attr-key attr-val) "Filters the Object Store for nodes having a specific attribute value." (let ((results nil)) - (maphash (lambda (id obj) (declare (ignore id)) (when (equal (getf (org-object-attributes obj) attr-key) attr-val) (push obj results))) *object-store*) + (maphash (lambda (id obj) + (declare (ignore id)) + (when (equal (getf (org-object-attributes obj) attr-key) attr-val) + (push obj results))) + *object-store*) results)) #+end_src diff --git a/literate/skills.org b/literate/skills.org index d0e9983..889d8f0 100644 --- a/literate/skills.org +++ b/literate/skills.org @@ -60,7 +60,7 @@ The primary macro used within Org files to register new agent capabilities. `(setf (gethash (string-downcase (string ,name)) *skills-registry*) (make-skill :name (string-downcase (string ,name)) :priority (or ,priority 10) - :dependencies ,dependencies + :dependencies ',dependencies :trigger-fn ,trigger :neuro-prompt ,neuro :symbolic-fn ,symbolic))) diff --git a/org-agent.asd b/org-agent.asd index 4a726f0..caa4698 100644 --- a/org-agent.asd +++ b/org-agent.asd @@ -7,14 +7,14 @@ :depends-on (:usocket :cl-json :bordeaux-threads :dexador :uiop :cl-dotenv :cl-ppcre :hunchentoot :ironclad :str) :serial t :components ((:file "src/package") - (:file "src/protocol") + (:file "src/skills") (:file "src/protocol-validator") + (:file "src/protocol") (:file "src/object-store") (:file "src/embedding") (:file "src/embedding-logic") (:file "src/context") (:file "src/context-logic") - (:file "src/skills") (:file "src/neuro") (:file "src/credentials-vault") (:file "src/llm-gateway") diff --git a/skills/org-skill-bouncer.org b/skills/org-skill-bouncer.org index e45cfdc..a951fe5 100644 --- a/skills/org-skill-bouncer.org +++ b/skills/org-skill-bouncer.org @@ -24,6 +24,7 @@ While the *Formal Prover* ensures an action is "legal" (e.g., "Yes, you are allo Retrieves all active secrets from the vault and scans the payload for potential leaks. #+begin_src lisp :tangle ../src/bouncer.lisp +(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)) @@ -40,6 +41,7 @@ Retrieves all active secrets from the vault and scans the payload for potential Inspects shell commands for unwhitelisted domains or IP addresses. #+begin_src lisp :tangle ../src/bouncer.lisp +(in-package :org-agent) (defun bouncer-check-network-exfil (cmd) "Returns T if the command appears to target an unwhitelisted external host." (when (and cmd (stringp cmd)) @@ -57,6 +59,7 @@ Inspects shell commands for unwhitelisted domains or IP addresses. The primary entry point for all high-impact actions. #+begin_src lisp :tangle ../src/bouncer.lisp +(in-package :org-agent) (defun bouncer-check (action context) "The 5-Vector security gate. Blocks or queues actions based on risk." (let* ((target (getf action :target)) @@ -98,6 +101,7 @@ The primary entry point for all high-impact actions. ** 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")) @@ -120,6 +124,7 @@ The primary entry point for all high-impact actions. ** Skill Definition #+begin_src lisp :tangle ../src/bouncer.lisp +(in-package :org-agent) (defskill :skill-bouncer :priority 100 :trigger (lambda (ctx) diff --git a/skills/org-skill-consensus.org b/skills/org-skill-consensus.org index e432194..88ac546 100644 --- a/skills/org-skill-consensus.org +++ b/skills/org-skill-consensus.org @@ -28,6 +28,7 @@ Enable reliable, cross-instance coordination without a central master. ** Consensus Algorithm (Simplified Raft) #+begin_src lisp :tangle ../src/consensus-logic.lisp +(in-package :org-agent) (defun consensus-propose-vote (proposal) "Broadcasts a proposal to the peer swarm and collects votes. Implements PSF Social Consensus Protocol." diff --git a/skills/org-skill-inbox-processor.org b/skills/org-skill-inbox-processor.org index 4ad4101..5e9d7df 100644 --- a/skills/org-skill-inbox-processor.org +++ b/skills/org-skill-inbox-processor.org @@ -38,6 +38,7 @@ Iterate through the inbox. Use System 2 (Symbolic) to identify the tag. If ~@per ** Helper: Privacy & Archive Checks #+begin_src lisp :tangle ../src/processor-logic.lisp +(in-package :org-agent) (defun inbox-is-private-p (tags) (member "@personal" tags :test #'string-equal)) @@ -47,6 +48,7 @@ Iterate through the inbox. Use System 2 (Symbolic) to identify the tag. If ~@per ** Neural Stage (Enrichment) #+begin_src lisp :tangle ../src/processor-logic.lisp +(in-package :org-agent) (defun neuro-skill-inbox-processor (context) (let* ((payload (getf context :payload)) (content (getf payload :content)) @@ -64,6 +66,7 @@ RULES: ** Symbolic Stage (The Physical Move) #+begin_src lisp :tangle ../src/processor-logic.lisp +(in-package :org-agent) (defun inbox-process-logic (action context) (declare (ignore action)) (let* ((payload (getf context :payload)) diff --git a/skills/org-skill-self-fix.org b/skills/org-skill-self-fix.org index 4fd0d31..c03100b 100644 --- a/skills/org-skill-self-fix.org +++ b/skills/org-skill-self-fix.org @@ -16,6 +16,8 @@ The *Self-Fix Agent* is the system's "Repair Mechanism." It takes failure hypoth ** Repair Logic #+begin_src lisp :tangle ../src/self-fix.lisp +(in-package :org-agent) + (defun self-fix-apply (action context) "Applies a surgical code fix and reloads the modified skill." (declare (ignore context)) diff --git a/skills/org-skill-shell-actuator.org b/skills/org-skill-shell-actuator.org index f952bd9..0ada8e4 100644 --- a/skills/org-skill-shell-actuator.org +++ b/skills/org-skill-shell-actuator.org @@ -79,6 +79,7 @@ Interfaces for secure system calls. State is event-driven via the core kernel bu Whitelist of permitted host binaries. #+begin_src lisp :tangle ../src/shell-logic.lisp +(in-package :org-agent) (defparameter *allowed-commands* '("ls" "git" "rg" "grep" "date" "echo" "cat" "node" "python3" "sbcl")) #+end_src @@ -86,6 +87,7 @@ Whitelist of permitted host binaries. Dangerous characters that are banned to prevent command injection. #+begin_src lisp :tangle ../src/shell-logic.lisp +(in-package :org-agent) (defparameter *shell-metacharacters* '(#\; #\& #\| #\> #\< #\$ #\` #\\ #\!) "Characters that are banned in shell commands to prevent injection.") #+end_src @@ -94,6 +96,7 @@ Dangerous characters that are banned to prevent command injection. Predicate to verify a command string is free of metacharacters. #+begin_src lisp :tangle ../src/shell-logic.lisp +(in-package :org-agent) (defun shell-command-safe-p (cmd-string) "Returns T if the command string contains no dangerous metacharacters." (not (some (lambda (char) (find char cmd-string)) *shell-metacharacters*))) @@ -103,6 +106,7 @@ Predicate to verify a command string is free of metacharacters. The primary secure actuator for host system calls. #+begin_src lisp :tangle ../src/shell-logic.lisp +(in-package :org-agent) (defun execute-shell-safely (action context) (let* ((cmd-string (getf (getf action :payload) :cmd)) (executable (car (uiop:split-string (string-trim " " cmd-string) :separator '(#\Space))))) @@ -133,6 +137,7 @@ The primary secure actuator for host system calls. Executes a synthesized script (Python/Lisp/JS) in a controlled directory. #+begin_src lisp :tangle ../src/shell-logic.lisp +(in-package :org-agent) (defun execute-sandboxed-script (action context) "Executes a synthesized script (Python/Lisp/JS) in a controlled directory. This enables SOTA-level Tool Synthesis and Iterative Fixing." @@ -162,6 +167,7 @@ Executes a synthesized script (Python/Lisp/JS) in a controlled directory. Hardware-Level Isolation for future security evolution. #+begin_src lisp :tangle ../src/shell-logic.lisp +(in-package :org-agent) (defun provision-microvm (id &key (cpu 1) (ram 512)) "Hardware-Level Isolation: Provisions an ephemeral Firecracker MicroVM. This is the high-security evolution of directory-based sandboxing." @@ -172,6 +178,7 @@ Hardware-Level Isolation for future security evolution. ** Feedback Perception #+begin_src lisp :tangle ../src/shell-logic.lisp +(in-package :org-agent) (defun trigger-skill-shell-actuator (context) (let ((type (getf context :type)) (payload (getf context :payload))) @@ -181,6 +188,7 @@ Hardware-Level Isolation for future security evolution. ** Neuro-Cognitive Analysis #+begin_src lisp :tangle ../src/shell-logic.lisp +(in-package :org-agent) (defun neuro-skill-shell-actuator (context) (let* ((p (getf context :payload)) (cmd (getf p :cmd)) @@ -199,7 +207,19 @@ Hardware-Level Isolation for future security evolution. If the command failed (Exit != 0), analyze the STDERR and propose a FIX for the script. If it succeeded, use the STDOUT to complete the original goal. " cmd exit-code stdout stderr) - (let ((result-text (format nil "* Shell Command Result\n- Command: ~a\n- Exit Code: ~a\n\n** STDOUT\n#+begin_example\n~a\n#+end_example\n\n** STDERR\n#+begin_example\n~a\n#+end_example" + (let ((result-text (format nil "* Shell Command Result +- Command: ~a +- Exit Code: ~a + +** STDOUT +#+begin_example +~a +#+end_example + +** STDERR +#+begin_example +~a +#+end_example" cmd exit-code stdout stderr))) `(:type :request :target :emacs :payload (:action :insert-at-end :buffer "*org-agent-chat*" :text ,result-text)))))) #+end_src @@ -210,6 +230,7 @@ Hardware-Level Isolation for future security evolution. Register the shell channel as a physical actuator. #+begin_src lisp :tangle ../src/shell-logic.lisp +(in-package :org-agent) (org-agent:register-actuator :shell #'execute-shell-safely) #+end_src @@ -217,6 +238,7 @@ Register the shell channel as a physical actuator. Define the skill entry for the shell actuator. #+begin_src lisp :tangle ../src/shell-logic.lisp +(in-package :org-agent) (defskill :skill-shell-actuator :priority 80 :trigger #'trigger-skill-shell-actuator diff --git a/skills/org-skill-task-integrity.org b/skills/org-skill-task-integrity.org index 59c1a02..f06dc05 100644 --- a/skills/org-skill-task-integrity.org +++ b/skills/org-skill-task-integrity.org @@ -36,42 +36,62 @@ Define automated behaviors for GTD state consistency and dependency verification :END: -* Phase B: Blueprint (PROTOCOL) -:PROPERTIES: -:STATUS: DRAFT -:END: +* Implementation -** 1. Architectural Intent - The Task Integrity Agent will operate as a reactive system, intercepting task state change requests within the Org-mode task management system. It will validate these requests against predefined semantic rules and dependencies before allowing the change to propagate. It will be implemented using Lisp, leveraging Org-mode's extension capabilities to hook into task state modification events. The goal is to build a system that is both performant and easily extensible with new integrity rules. Errors will be reported clearly to the user with options for correction. +** Semantic Mapping +#+begin_src lisp :tangle ../src/task-integrity.lisp +(in-package :org-agent) -** 2. Semantic Interfaces (Lisp Signatures) +(defun semantic-mapping (task-state) + "Maps Org-mode task states to semantic categories." + (case (intern (string-upcase task-state) :keyword) + ((:todo :active :started :wait) :active) + ((:done :cancelled :resolved) :resolved) + (t :unknown))) +#+end_src -*** `task-integrity-check (task-id new-state)` - - *Purpose:* Core function to validate a proposed state transition. - - *Parameters:* - - `task-id`: Unique identifier of the task (e.g., Org-id). - - `new-state`: Target state of the task (e.g., 'DONE', 'ACTIVE'). - - *Returns:* `t` if the transition is valid; `nil` or an error message (string) if invalid. - - *Example:* `(task-integrity-check "*TODO Example Task" 'DONE)` +** Active Children Detection +#+begin_src lisp :tangle ../src/task-integrity.lisp +(defun detect-active-children (task-id) + "Checks if a task has any child tasks in an active state." + (let ((children (list-objects-with-attribute :PARENT task-id))) + (remove-if-not (lambda (child) + (let ((todo (getf (org-object-attributes child) :TODO))) + (and todo (eq (semantic-mapping todo) :active)))) + children))) +#+end_src -*** `semantic-mapping (task-state)` - - *Purpose:* Maps Org-mode task states (e.g., 'TODO', 'DONE') to semantic categories (e.g., 'Active', 'Resolved'). - - *Parameters:* - - `task-state`: An Org-mode task state keyword. - - *Returns:* Semantic category symbol (e.g., `:active`, `:resolved`). - - *Example:* `(semantic-mapping 'TODO)` -> `:active` +** Integrity Check (task-integrity-check) +Enforces high-integrity semantic rules for task management. -*** `detect-active-children (task-id)` - - *Purpose:* Checks if a task has any child tasks in an active state. - - *Parameters:* - - `task-id`: Unique identifier of the parent task. - - *Returns:* A list of active child task IDs, or `nil` if no active children exist. - - *Example:* `(detect-active-children "*TODO Parent Task")` -> `("*TODO Child Task 1" "*TODO Child Task 2")` (if they are TODO) +#+begin_src lisp :tangle ../src/task-integrity.lisp +(defun task-integrity-check (action) + "Enforces semantic GTD integrity rules on proposed actions." + (let* ((payload (getf action :payload)) + (act (or (getf payload :action) (getf action :action))) + (id (or (getf payload :id) (getf action :id))) + (new-attrs (or (getf payload :attributes) (getf action :attributes)))) + (when (and (eq act :update-node) + (equal (getf new-attrs :TODO) "DONE")) + (let ((active-children (detect-active-children id))) + (when active-children + (return-from task-integrity-check + (format nil "Blocked by Task Integrity: ~a active children exist." (length active-children)))))) + nil)) +#+begin_src + +** Skill Definition +#+begin_src lisp :tangle ../src/task-integrity.lisp +(defskill :skill-task-integrity + :priority 90 + :trigger (lambda (ctx) (declare (ignore ctx)) nil) + :neuro nil + :symbolic (lambda (action context) + (declare (ignore context)) + (let ((err (task-integrity-check action))) + (if err + (list :type :LOG :payload (list :text err)) + action)))) +#+end_src -*** `block-state-transition (task-id error-message)` - - *Purpose:* Prevents a task state transition and displays an error message to the user. - - *Parameters:* - - `task-id`: Unique identifier of the task. - - `error-message`: String explaining why the transition is blocked. - - *Returns:* `nil` (side effect: displays message). diff --git a/src/bouncer.lisp b/src/bouncer.lisp index c507eca..8cebc06 100644 --- a/src/bouncer.lisp +++ b/src/bouncer.lisp @@ -1,3 +1,4 @@ +(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)) @@ -9,6 +10,7 @@ *vault-memory*) found-secret))) +(in-package :org-agent) (defun bouncer-check-network-exfil (cmd) "Returns T if the command appears to target an unwhitelisted external host." (when (and cmd (stringp cmd)) @@ -21,6 +23,7 @@ (let ((domain (aref regs 1))) (not (some (lambda (safe) (search safe domain)) network-whitelist)))))))) +(in-package :org-agent) (defun bouncer-check (action context) "The 5-Vector security gate. Blocks or queues actions based on risk." (let* ((target (getf action :target)) @@ -59,6 +62,7 @@ ;; 4. Default Pass (t action)))) +(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")) @@ -78,6 +82,7 @@ (setq found-any t)))))) found-any)) +(in-package :org-agent) (defskill :skill-bouncer :priority 100 :trigger (lambda (ctx) diff --git a/src/chat-logic.lisp b/src/chat-logic.lisp index 258a95c..5a762da 100644 --- a/src/chat-logic.lisp +++ b/src/chat-logic.lisp @@ -1,9 +1,26 @@ (in-package :org-agent) +(defun chat-archive-message (text &key (role :user) channel chat-id) + "Archives a chat message into the persistent Object Store and triggers a snapshot." + (let* ((msg-id (org-id-new)) + (obj (make-org-object + :id msg-id + :type :CHAT-MESSAGE + :attributes `(:role ,role :channel ,channel :chat-id ,chat-id :timestamp ,(get-universal-time)) + :content text + :version (get-universal-time)))) + (setf (gethash msg-id *object-store*) obj) + (kernel-log "CHAT - Message archived: ~a (~a)" msg-id role) + (snapshot-object-store) + msg-id)) + (defun trigger-skill-chat (context) (let* ((payload (getf context :payload)) (sensor (getf payload :sensor))) - (eq sensor :chat-message))) + (when (eq sensor :chat-message) + ;; Archive inbound message + (chat-archive-message (getf payload :text) :role :user :channel (getf payload :channel) :chat-id (getf payload :chat-id)) + t))) (defun verify-skill-chat (proposed-action context) (let* ((payload (getf proposed-action :payload)) @@ -23,9 +40,13 @@ (or (getf payload :cmd) (getf proposed-action :cmd))) (member target '(:tool :TOOL)))) (member (getf proposed-action :type) '(:response :RESPONSE :log :LOG)))) - proposed-action - (let ((err-text (format nil " -*System Error:* Chat agent returned invalid action: ~s" proposed-action))) + (progn + ;; Archive outbound response + (when (and (member (getf proposed-action :type) '(:request :REQUEST)) + (not (eq target :tool))) + (chat-archive-message (getf payload :text) :role :agent :channel target :chat-id (or (getf payload :chat-id) (getf payload :room-id)))) + proposed-action) + (let ((err-text (format nil "\n\n*System Error:* Chat agent returned invalid action: ~s" proposed-action))) `(:type :request :target :emacs :payload (:action :insert-at-end :buffer "*org-agent-chat*" :text ,err-text)))))) (defun neuro-skill-chat (context) diff --git a/src/consensus-logic.lisp b/src/consensus-logic.lisp index 780ccb7..7d3fb9a 100644 --- a/src/consensus-logic.lisp +++ b/src/consensus-logic.lisp @@ -1,3 +1,4 @@ +(in-package :org-agent) (defun consensus-propose-vote (proposal) "Broadcasts a proposal to the peer swarm and collects votes. Implements PSF Social Consensus Protocol." diff --git a/src/context-logic.lisp b/src/context-logic.lisp new file mode 100644 index 0000000..2febbe7 --- /dev/null +++ b/src/context-logic.lisp @@ -0,0 +1,72 @@ +(in-package :org-agent) + +(defun context-render-to-org (obj &key (depth 1) (foveal-id nil) (semantic-threshold 0.75) (foveal-vector nil)) + "Recursively renders an org-object and its children to an Org string using a Foveal-Peripheral Hybrid model." + (let* ((id (org-object-id obj)) + (is-foveal (equal id foveal-id)) + (title (or (getf (org-object-attributes obj) :TITLE) "Untitled")) + (content (org-object-content obj)) + (children (org-object-children obj)) + (stars (make-string depth :initial-element #\*)) + (obj-vector (org-object-vector obj)) + (similarity (if (and foveal-vector obj-vector (not is-foveal)) + (cosine-similarity foveal-vector obj-vector) + 0.0)) + (is-semantically-relevant (>= similarity semantic-threshold)) + ;; We always render depth 1 and 2 (Projects and main tasks). + ;; We always render the foveal node and its immediate children. + ;; We render deeper nodes ONLY if they are semantically relevant. + (should-render (or (<= depth 2) is-foveal is-semantically-relevant)) + (output "")) + + (when should-render + (setf output (format nil "~a ~a~%:PROPERTIES:~%:ID: ~a~%" stars title id)) + (when (and is-semantically-relevant (> similarity 0)) + (setf output (concatenate 'string output (format nil ":SEMANTIC_SCORE: ~,2f~%" similarity)))) + (setf output (concatenate 'string output (format nil ":END:~%"))) + + ;; Only include full body content if this is the Foveal focus or highly relevant + (when (and content (or is-foveal is-semantically-relevant)) + (setf output (concatenate 'string output content (string #\Newline)))) + + ;; Recursively render children + (dolist (child-id children) + (let ((child-obj (lookup-object child-id))) + (when child-obj + ;; If the current node is Foveal, its children should be rendered (depth effectively resets) + (let ((next-foveal (if is-foveal child-id foveal-id))) + (setf output (concatenate 'string output + (context-render-to-org child-obj + :depth (1+ depth) + :foveal-id next-foveal + :semantic-threshold semantic-threshold + :foveal-vector foveal-vector)))))))) + output)) + +(defun context-assemble-global-awareness (&optional signal) + "Produces a high-level skeletal outline of the current Object Store for the LLM." + (let* ((payload (when signal (getf signal :payload))) + (foveal-id (when payload (getf payload :target-id))) + (foveal-vector (when foveal-id (org-object-vector (lookup-object foveal-id)))) + (projects (context-get-active-projects)) + (output "GLOBAL MEMEX AWARENESS (Peripheral Vision): +")) + (if projects + (dolist (project projects) + (setf output (concatenate 'string output + (context-render-to-org project + :foveal-id foveal-id + :foveal-vector foveal-vector)))) + (setf output (concatenate 'string output "No active projects found.~%"))) + output)) + +(defskill :skill-peripheral-vision + :priority 90 + :dependencies ("org-skill-embedding") + :trigger (lambda (ctx) (member (getf (getf ctx :payload) :sensor) '(:perceive :context-refresh))) + :neuro nil + :symbolic (lambda (action ctx) + (declare (ignore action ctx)) + ;; This skill primarily provides the context-assemble-global-awareness function + ;; used by the neuro-gate, rather than handling specific actions. + nil)) diff --git a/src/embedding-logic.lisp b/src/embedding-logic.lisp new file mode 100644 index 0000000..986f8d6 --- /dev/null +++ b/src/embedding-logic.lisp @@ -0,0 +1,60 @@ +(in-package :org-agent) + +(defun get-embedding (text) + "Retrieves a vector representation of text via the configured neural provider." + (let* ((auth (get-provider-auth :gemini)) + (api-key (getf auth :api-key)) + (endpoint "https://generativelanguage.googleapis.com/v1beta/models/text-embedding-004:embedContent")) + (unless api-key + (kernel-log "EMBEDDING ERROR: No API key for :gemini") + (return-from get-embedding nil)) + (let* ((url (format nil "~a?key=~a" endpoint api-key)) + (headers `(("Content-Type" . "application/json"))) + (body (cl-json:encode-json-to-string + `((model . "models/text-embedding-004") + (content . ((parts . ((text . ,text))))))))) + (handler-case + (let* ((response (dex:post url :headers headers :content body)) + (json (cl-json:decode-json-from-string response)) + (embedding (getf (getf json :embedding) :values))) + embedding) + (error (c) + (kernel-log "EMBEDDING FAILURE: ~a" c) + nil))))) + +(defun dot-product (v1 v2) + "Calculates the dot product of two numerical vectors." + (reduce #'+ (mapcar #'* v1 v2))) + +(defun magnitude (v) + "Calculates the Euclidean magnitude of a numerical vector." + (sqrt (reduce #'+ (mapcar (lambda (x) (* x x)) v)))) + +(defun cosine-similarity (v1 v2) + "Calculates the semantic distance between two vectors." + (let ((m1 (magnitude v1)) + (m2 (magnitude v2))) + (if (or (zerop m1) (zerop m2)) 0 (/ (dot-product v1 v2) (* m1 m2))))) + +(defun find-most-similar (query-vector top-k) + "Identifies the top-k most semantically related objects in the store." + (let ((similarities nil)) + (maphash (lambda (id obj) + (declare (ignore id)) + (let ((vec (org-object-vector obj))) + (when vec + (push (cons (cosine-similarity query-vector vec) obj) similarities)))) + *object-store*) + (let ((sorted (sort similarities #'> :key #'car))) + (subseq sorted 0 (min top-k (length sorted)))))) + +(defskill :skill-embedding + :priority 50 + :trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :embedding-request)) + :neuro nil + :symbolic (lambda (action ctx) + (declare (ignore ctx)) + (case (getf action :action) + (:get-embedding (get-embedding (getf action :text))) + (:similarity (cosine-similarity (getf action :v1) (getf action :v2))) + (t action)))) diff --git a/src/gateway-matrix.lisp b/src/gateway-matrix.lisp index e3b1855..f1845c1 100644 --- a/src/gateway-matrix.lisp +++ b/src/gateway-matrix.lisp @@ -37,34 +37,35 @@ (when (and hs token) (handler-case (let* ((response (dex:get url :headers `(("Authorization" . ,(format nil "Bearer ~a" token))))) - (json (cl-json:decode-json-from-string response)) - (next-batch (or (cdr (assoc :next-batch json)) - (cdr (assoc :next--batch json)))) - (rooms (cdr (assoc :rooms json))) - (joined (cdr (assoc :join rooms)))) - - (when next-batch - (setf *matrix-since-token* next-batch)) - - (dolist (room-entry joined) - (let* ((room-id (string-downcase (string (car room-entry)))) - (room-data (cdr room-entry)) - (timeline (cdr (assoc :timeline room-data))) - (events (cdr (assoc :events timeline)))) - (dolist (event events) - (let* ((type (cdr (assoc :type event))) - (content (cdr (assoc :content event))) - (sender (cdr (assoc :sender event))) - (body (cdr (assoc :body content)))) - (when (and (string= type "m.room.message") body) - (kernel-log "MATRIX: Received message from ~a in ~a" sender room-id) - (inject-stimulus - (list :type :EVENT - :payload (list :sensor :chat-message - :channel :matrix - :room-id room-id - :sender sender - :text body))))))))) (error (c) (kernel-log "MATRIX SYNC ERROR: ~a" c)))))) + (json (cl-json:decode-json-from-string response)) + (next-batch (or (cdr (assoc :next-batch json)) + (cdr (assoc :next--batch json)))) + (rooms (cdr (assoc :rooms json))) + (joined (cdr (assoc :join rooms)))) + + (when next-batch + (setf *matrix-since-token* next-batch)) + + (dolist (room-entry joined) + (let* ((room-id (string-downcase (string (car room-entry)))) + (room-data (cdr room-entry)) + (timeline (cdr (assoc :timeline room-data))) + (events (cdr (assoc :events timeline)))) + (dolist (event events) + (let* ((type (cdr (assoc :type event))) + (content (cdr (assoc :content event))) + (sender (cdr (assoc :sender event))) + (body (cdr (assoc :body content)))) + (when (and (string= type "m.room.message") body) + (kernel-log "MATRIX: Received message from ~a in ~a" sender room-id) + (inject-stimulus + (list :type :EVENT + :payload (list :sensor :chat-message + :channel :matrix + :room-id room-id + :sender sender + :text body))))))))) + (error (c) (kernel-log "MATRIX SYNC ERROR: ~a" c)))))) (defun start-matrix-gateway () "Initializes the Matrix background thread." diff --git a/src/gateway-signal.lisp b/src/gateway-signal.lisp index 700efee..1ddc6ad 100644 --- a/src/gateway-signal.lisp +++ b/src/gateway-signal.lisp @@ -45,7 +45,7 @@ (defun start-signal-gateway () "Initializes the Signal background thread." - (unless (and *telegram-polling-thread* (bt:thread-alive-p *telegram-polling-thread*)) + (unless (and *signal-polling-thread* (bt:thread-alive-p *signal-polling-thread*)) (setf *signal-polling-thread* (bt:make-thread (lambda () diff --git a/src/gateway-telegram.lisp b/src/gateway-telegram.lisp index 0e6d0a2..1359f0e 100644 --- a/src/gateway-telegram.lisp +++ b/src/gateway-telegram.lisp @@ -1,7 +1,9 @@ (in-package :org-agent) (defvar *telegram-last-update-id* 0) + (defvar *telegram-polling-thread* nil) + (defvar *telegram-authorized-chats* nil "List of chat IDs allowed to interact with the bot. Hydrated from environment.") @@ -68,14 +70,12 @@ (bt:destroy-thread *telegram-polling-thread*) (setf *telegram-polling-thread* nil))) -(progn - (register-actuator :telegram #'execute-telegram-action) - - (defskill :skill-gateway-telegram - :priority 150 - :trigger (lambda (ctx) (declare (ignore ctx)) nil) ;; Passive, handles its own loop - :neuro nil - :symbolic (lambda (action ctx) (declare (ignore ctx)) action)) - - ;; Initialize the background polling loop - (start-telegram-gateway)) +(register-actuator :telegram #'execute-telegram-action) + +(defskill :skill-gateway-telegram + :priority 150 + :trigger (lambda (ctx) (declare (ignore ctx)) nil) ;; Passive, handles its own loop + :neuro nil + :symbolic (lambda (action ctx) (declare (ignore ctx)) action)) + +(start-telegram-gateway) diff --git a/src/lisp-repair.lisp b/src/lisp-repair.lisp index fe42cbf..205d2b9 100644 --- a/src/lisp-repair.lisp +++ b/src/lisp-repair.lisp @@ -30,11 +30,10 @@ MANDATE: Output EXACTLY ONE valid Common Lisp list. Do not explain. Do not use m (defskill :skill-lisp-repair :priority 90 :trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :syntax-error)) - :neuro nil + :neuro nil ;; Handled deterministically in symbolic or manually via ask-neuro :symbolic (lambda (action context) (declare (ignore action)) - (let* ((stimulus (getf context :candidate)) - (payload (getf stimulus :payload)) + (let* ((payload (getf context :payload)) (code (getf payload :code)) (error-msg (getf payload :error))) (kernel-log "SYNTAX GATE: Reacting to broken Lisp stimulus...") diff --git a/src/neuro.lisp b/src/neuro.lisp index 65388e9..e14a158 100644 --- a/src/neuro.lisp +++ b/src/neuro.lisp @@ -1,39 +1,14 @@ (in-package :org-agent) -(defun get-env (var &optional default) (or (uiop:getenv var) default)) - -(defvar *auth-providers* (make-hash-table :test 'equal)) - -(defun register-auth-provider (name fn) (setf (gethash name *auth-providers*) fn)) - -(defun get-provider-auth (provider) - "Retrieves authentication credentials for a provider." - (let ((auth (gethash provider *auth-providers*))) - (cond - ((functionp auth) (funcall auth)) - ((listp auth) auth) - (t - (let ((specific-key (case provider - (:gemini (uiop:getenv "GEMINI_API_KEY")) - (:openrouter (uiop:getenv "OPENROUTER_API_KEY")) - (:anthropic (uiop:getenv "ANTHROPIC_API_KEY")) - (:openai (uiop:getenv "OPENAI_API_KEY")) - (t nil)))) - (if (and specific-key (> (length specific-key) 0)) - (list :api-key specific-key) - (let ((legacy (uiop:getenv "LLM_API_KEY"))) - (when (and legacy (> (length legacy) 0)) - (list :api-key legacy))))))))) - (defvar *neuro-backends* (make-hash-table :test 'equal)) -(defvar *provider-cascade* '(:openrouter :gemini)) +(defvar *provider-cascade* '(:openrouter :gemini-api)) (defun register-neuro-backend (name fn) (setf (gethash name *neuro-backends*) fn)) (defvar *model-selector-fn* nil "A function called with (provider context) to return a model ID.") -(defvar *consensus-enabled-p* t "If T, ask-neuro queries all backends in parallel.") +(defvar *consensus-enabled-p* nil "If T, ask-neuro queries all backends in parallel.") (defun ask-neuro (prompt &key (system-prompt "You are the Associative engine of a Neurosymbolic Lisp Machine.") (cascade nil) (context nil)) "Dispatches a neural request through the provider cascade or parallel consensus." @@ -71,7 +46,7 @@ (format nil "~{~a~^|CONSENSUS-SEP|~}" valid-results) "(:type :LOG :payload (:text \"Neural Consensus Failure\"))"))) - ;; SEQUENTIAL CASCADE MODE (Legacy) + ;; SEQUENTIAL CASCADE MODE (or (dolist (backend backends) (let ((backend-fn (gethash backend *neuro-backends*))) (when backend-fn @@ -80,18 +55,13 @@ (result (if model (funcall backend-fn prompt system-prompt :model model) (funcall backend-fn prompt system-prompt)))) - (unless (and (stringp result) (search ":LOG" result) (or (search "Failure" result) (search "missing" result))) + (unless (or (null result) + (and (stringp result) (search ":LOG" result) (or (search "Failure" result) (search "missing" result)))) (return result)))))) "(:type :LOG :payload (:text \"Neural Cascade Failure\"))")))) -(defun token-accountant-route-task (context) - "Generic fallback for routing. Overridden by skill-token-accountant." - (declare (ignore context)) - '(:openrouter :gemini)) - (defun think (context) - "Invokes the neural Associative engine to propose a Lisp action based on context. -If consensus is enabled, it returns a list of proposals from different backends." + "Invokes the neural Associative engine to propose a Lisp action based on context." (let ((active-skill (find-triggered-skill context)) (tool-belt (generate-tool-belt-prompt)) (global-context (context-assemble-global-awareness))) diff --git a/src/processor-logic.lisp b/src/processor-logic.lisp index 58c2e45..99d57e2 100644 --- a/src/processor-logic.lisp +++ b/src/processor-logic.lisp @@ -1,9 +1,11 @@ +(in-package :org-agent) (defun inbox-is-private-p (tags) (member "@personal" tags :test #'string-equal)) (defun inbox-is-archive-p (tags) (member "!archive" tags :test #'string-equal)) +(in-package :org-agent) (defun neuro-skill-inbox-processor (context) (let* ((payload (getf context :payload)) (content (getf payload :content)) @@ -18,6 +20,7 @@ RULES: 4. Return ONLY a Lisp plist with :summary :significance :full-text. 5. NO conversational filler." is-archive)))) +(in-package :org-agent) (defun inbox-process-logic (action context) (declare (ignore action)) (let* ((payload (getf context :payload)) diff --git a/src/protocol-validator.lisp b/src/protocol-validator.lisp new file mode 100644 index 0000000..584fbb5 --- /dev/null +++ b/src/protocol-validator.lisp @@ -0,0 +1,39 @@ +(in-package :org-agent) + +(defun validate-oacp-schema (msg) + "Strict structural validation for incoming OACP messages." + (unless (listp msg) + (error "OACP Schema Error: Message must be a property list (got ~s)" (type-of msg))) + + (let ((type (getf msg :type))) + (unless (member type '(:REQUEST :EVENT :RESPONSE :LOG)) + (error "OACP Schema Error: Invalid message type '~a'" type)) + + (case type + (:REQUEST + (unless (getf msg :target) + (error "OACP Schema Error: REQUEST missing mandatory :target")) + (unless (getf msg :payload) + (error "OACP Schema Error: REQUEST missing mandatory :payload"))) + + (:EVENT + (let ((payload (getf msg :payload))) + (unless (and payload (listp payload)) + (error "OACP Schema Error: EVENT missing or invalid :payload")) + (unless (or (getf payload :action) (getf payload :sensor)) + (error "OACP Schema Error: EVENT payload must contain :action or :sensor")))) + + (:RESPONSE + (unless (getf msg :payload) + (error "OACP Schema Error: RESPONSE missing mandatory :payload")))) + + t)) + +(defskill :skill-oacp-validator + :priority 95 + :trigger (lambda (ctx) (member (getf (getf ctx :payload) :sensor) '(:protocol-received))) + :neuro nil + :symbolic (lambda (action ctx) + (declare (ignore ctx)) + (validate-oacp-schema action) + action)) diff --git a/src/safety-harness.lisp b/src/safety-harness.lisp index 7815f2c..2de695a 100644 --- a/src/safety-harness.lisp +++ b/src/safety-harness.lisp @@ -40,45 +40,3 @@ declare ignore ;; Let's also add simple data types t nil quote function)) - -(defvar *safety-registry* nil - "List of dynamically registered safe symbols.") - -(defun safety-harness-register (symbols) - "Adds symbols to the global safety registry." - (setf *safety-registry* (append *safety-registry* (if (listp symbols) symbols (list symbols)))) - (kernel-log "SAFETY HARNESS: Registered ~a new safe symbols." (length (if (listp symbols) symbols (list symbols))))) - -(defun safety-harness-is-safe (symbol) - "Checks if a symbol is in the static whitelist or the dynamic registry." - (or (member symbol *safety-whitelist* :test #'string-equal) - (member symbol *safety-registry* :test #'string-equal))) - -(defun safety-harness-ast-walk (form) - "Recursively walks the Lisp AST. Returns T if safe, NIL if unsafe." - (cond - ;; Self-evaluating objects (strings, numbers, keywords) are safe. - ((or (stringp form) (numberp form) (keywordp form) (characterp form)) - t) - ;; Symbols used as variables (in non-function position) - ((symbolp form) - (safety-harness-is-safe form)) - ;; Lists represent function calls or special forms. - ((listp form) - (let ((head (car form))) - (cond - ((eq head 'quote) t) - ((not (symbolp head)) nil) - ((safety-harness-is-safe head) - (every #'safety-harness-ast-walk (cdr form))) - (t - (kernel-log "SAFETY HARNESS: Blocked call to non-whitelisted function ~a" head) - nil)))) - (t nil))) - -(defun safety-harness-validate (code) - "Parses and validates a Lisp string or form." - (let ((form (if (stringp code) (ignore-errors (read-from-string code)) code))) - (if form - (safety-harness-ast-walk form) - nil))) diff --git a/src/self-fix.lisp b/src/self-fix.lisp index d6078e2..ae0495b 100644 --- a/src/self-fix.lisp +++ b/src/self-fix.lisp @@ -10,8 +10,8 @@ (is-skill (and (stringp (namestring target-file)) (search "skills/" (namestring target-file))))) - (snapshot-object-store) - (kernel-log "SELF-FIX - Attempting surgical fix on ~a..." target-file) + (org-agent:snapshot-object-store) + (org-agent:kernel-log "SELF-FIX - Attempting surgical fix on ~a..." target-file) (handler-case (if (uiop:file-exists-p target-file) @@ -23,25 +23,25 @@ (if is-skill (progn - (kernel-log "SELF-FIX - Reloading modified skill ~a..." target-file) - (if (load-skill-from-org target-file) + (org-agent:kernel-log "SELF-FIX - Reloading modified skill ~a..." target-file) + (if (org-agent:load-skill-from-org target-file) (progn - (kernel-log "SELF-FIX SUCCESS - Applied and reloaded.") + (org-agent:kernel-log "SELF-FIX SUCCESS - Applied and reloaded.") t) (progn - (kernel-log "SELF-FIX FAILURE - Skill reload failed. Rolling back.") + (org-agent:kernel-log "SELF-FIX FAILURE - Skill reload failed. Rolling back.") (with-open-file (out target-file :direction :output :if-exists :supersede) (write-string content out)) - (rollback-object-store 0) + (org-agent:rollback-object-store 0) nil))) (progn - (kernel-log "SELF-FIX SUCCESS - Applied fix to file.") + (org-agent:kernel-log "SELF-FIX SUCCESS - Applied fix to file.") t))) - (progn (kernel-log "SELF-FIX FAILURE - Pattern not found.") nil))) - (progn (kernel-log "SELF-FIX FAILURE - File not found.") nil)) + (progn (org-agent:kernel-log "SELF-FIX FAILURE - Pattern not found.") nil))) + (progn (org-agent:kernel-log "SELF-FIX FAILURE - File not found.") nil)) (error (c) - (kernel-log "SELF-FIX CRASH - ~a. Rolling back." c) - (rollback-object-store 0) + (org-agent:kernel-log "SELF-FIX CRASH - ~a. Rolling back." c) + (org-agent:rollback-object-store 0) nil)))) (def-cognitive-tool :repair-file diff --git a/src/shell-logic.lisp b/src/shell-logic.lisp index 86dc57e..e2fabe1 100644 --- a/src/shell-logic.lisp +++ b/src/shell-logic.lisp @@ -1,14 +1,16 @@ (in-package :org-agent) - (defparameter *allowed-commands* '("ls" "git" "rg" "grep" "date" "echo" "cat" "node" "python3" "sbcl")) +(in-package :org-agent) (defparameter *shell-metacharacters* '(#\; #\& #\| #\> #\< #\$ #\` #\\ #\!) "Characters that are banned in shell commands to prevent injection.") +(in-package :org-agent) (defun shell-command-safe-p (cmd-string) "Returns T if the command string contains no dangerous metacharacters." (not (some (lambda (char) (find char cmd-string)) *shell-metacharacters*))) +(in-package :org-agent) (defun execute-shell-safely (action context) (let* ((cmd-string (getf (getf action :payload) :cmd)) (executable (car (uiop:split-string (string-trim " " cmd-string) :separator '(#\Space))))) @@ -34,6 +36,7 @@ `(:type :EVENT :payload (:sensor :shell-response :cmd ,cmd-string :stdout ,(or stdout "") :stderr ,(or stderr "") :exit-code ,exit-code)) :stream (getf context :reply-stream))))))) +(in-package :org-agent) (defun execute-sandboxed-script (action context) "Executes a synthesized script (Python/Lisp/JS) in a controlled directory. This enables SOTA-level Tool Synthesis and Iterative Fixing." @@ -58,6 +61,7 @@ `(:type :EVENT :payload (:sensor :shell-response :cmd ,cmd :stdout ,(or stdout "") :stderr ,(or stderr "") :exit-code ,exit-code :synthesis-p t)) :stream (getf context :reply-stream)))))) +(in-package :org-agent) (defun provision-microvm (id &key (cpu 1) (ram 512)) "Hardware-Level Isolation: Provisions an ephemeral Firecracker MicroVM. This is the high-security evolution of directory-based sandboxing." @@ -65,36 +69,17 @@ ;; Future implementation: Wraps 'fcvm' or 'firecracker' CLI calls. (format nil "vm-~a-provisioned" id)) +(in-package :org-agent) (defun trigger-skill-shell-actuator (context) (let ((type (getf context :type)) (payload (getf context :payload))) (and (eq type :EVENT) (eq (getf payload :sensor) :shell-response)))) -(defun neuro-skill-shell-actuator (context) - (let* ((p (getf context :payload)) - (cmd (getf p :cmd)) - (stdout (getf p :stdout)) - (stderr (getf p :stderr)) - (exit-code (getf p :exit-code)) - (synthesis-p (getf p :synthesis-p))) - (if synthesis-p - (format nil " - TOOL SYNTHESIS RESULT: - Command: ~a (Exit: ~a) - STDOUT: ~a - STDERR: ~a - - TASK: - If the command failed (Exit != 0), analyze the STDERR and propose a FIX for the script. - If it succeeded, use the STDOUT to complete the original goal. - " cmd exit-code stdout stderr) - (let ((result-text (format nil "* Shell Command Result\n- Command: ~a\n- Exit Code: ~a\n\n** STDOUT\n#+begin_example\n~a\n#+end_example\n\n** STDERR\n#+begin_example\n~a\n#+end_example" - cmd exit-code stdout stderr))) - `(:type :request :target :emacs :payload (:action :insert-at-end :buffer "*org-agent-chat*" :text ,result-text)))))) - +(in-package :org-agent) (org-agent:register-actuator :shell #'execute-shell-safely) +(in-package :org-agent) (defskill :skill-shell-actuator :priority 80 :trigger #'trigger-skill-shell-actuator diff --git a/src/skills.lisp b/src/skills.lisp index 2867495..669d29b 100644 --- a/src/skills.lisp +++ b/src/skills.lisp @@ -26,7 +26,7 @@ `(setf (gethash (string-downcase (string ,name)) *skills-registry*) (make-skill :name (string-downcase (string ,name)) :priority (or ,priority 10) - :dependencies ,dependencies + :dependencies ',dependencies :trigger-fn ,trigger :neuro-prompt ,neuro :symbolic-fn ,symbolic))) diff --git a/src/symbolic.lisp b/src/symbolic.lisp index c979203..d1f4c48 100644 --- a/src/symbolic.lisp +++ b/src/symbolic.lisp @@ -1,75 +1,37 @@ (in-package :org-agent) -(defun task-integrity-check (action) - "Enforces semantic GTD integrity rules on proposed actions." - (let* ((payload (getf action :payload)) - (act (or (getf payload :action) (getf action :action))) - (id (or (getf payload :id) (getf action :id))) - (new-attrs (or (getf payload :attributes) (getf action :attributes)))) - (when (and (eq act :update-node) (equal (getf new-attrs :TODO) "DONE")) - (let ((children (list-objects-with-attribute :PARENT id))) - (when (some (lambda (child) (let ((todo (getf (org-object-attributes child) :TODO))) - (and todo (not (equal todo "DONE"))))) - children) - (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 Deliberate Safety Gate: validates or rejects proposed neural actions." - ;; 1. Task Integrity Check (GTD Semantics) - (let ((integrity-error (task-integrity-check proposed-action))) - (when integrity-error - (kernel-log "DELIBERATE [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 "DELIBERATE [BOUNCER]: Action requires manual approval.~%") - (return-from decide - (list :type :EVENT - :payload (list :sensor :approval-required :action proposed-action)))) - - ;; 3. 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)) - (payload (getf proposed-action :payload)) - (action (or (getf payload :action) (getf proposed-action :action))) - (code (or (getf payload :code) (getf proposed-action :code)))) - ;; Global safety harness for EVAL - (when (and (member (getf proposed-action :type) '(:request :REQUEST)) - (member action '(:eval :EVAL))) - (let ((harness-pkg (find-package :org-agent.skills.org-skill-safety-harness))) - (when (and code harness-pkg) - (unless (ignore-errors (uiop:symbol-call :org-agent.skills.org-skill-safety-harness :safety-harness-validate code)) - (kernel-log "DELIBERATE [GLOBAL]: Security violation blocked.~%") - (return-from decide '(:type :LOG :payload (:text "Blocked by Global Safety Harness"))))))) - ;; Skill-specific verification - (if symbolic-gate - (let ((decision (funcall symbolic-gate proposed-action context))) - (if decision - (progn (kernel-log "DELIBERATE: Verified by skill '~a'.~%" (skill-name active-skill)) decision) - (progn (kernel-log "DELIBERATE: REJECTED by skill '~a'.~%" (skill-name active-skill)) - '(:type :LOG :payload (:text "Action rejected by skill heuristics"))))) - (progn (kernel-log "DELIBERATE: Verified (Implicitly safe for skill '~a').~%" (skill-name active-skill)) proposed-action))) - proposed-action))) + "The Deliberate Safety Gate: iterates through all skill symbolic-gates sorted by priority." + (let ((current-action proposed-action) + (skills nil)) + ;; 1. Collect all skills with symbolic gates + (maphash (lambda (name skill) + (declare (ignore name)) + (when (skill-symbolic-fn skill) + (push skill skills))) + *skills-registry*) + + ;; 2. Sort skills by priority (highest first) + (setf skills (sort skills #'> :key #'skill-priority)) + + ;; 3. Execute symbolic gates sequentially + (dolist (skill skills) + (let ((gate (skill-symbolic-fn skill))) + (setf current-action (funcall gate current-action context)) + ;; If any gate returns a LOG or EVENT (blocking/intercepting), stop and return it. + (when (and (listp current-action) + (member (getf current-action :type) '(:LOG :EVENT :log :event))) + (kernel-log "DELIBERATE: Intercepted by skill '~a'~%" (skill-name skill)) + (return-from decide current-action)))) + + current-action)) (defun list-objects-with-attribute (attr-key attr-val) "Filters the Object Store for nodes having a specific attribute value." (let ((results nil)) - (maphash (lambda (id obj) (declare (ignore id)) (when (equal (getf (org-object-attributes obj) attr-key) attr-val) (push obj results))) *object-store*) + (maphash (lambda (id obj) + (declare (ignore id)) + (when (equal (getf (org-object-attributes obj) attr-key) attr-val) + (push obj results))) + *object-store*) results)) diff --git a/src/task-integrity.lisp b/src/task-integrity.lisp new file mode 100644 index 0000000..0d49f08 --- /dev/null +++ b/src/task-integrity.lisp @@ -0,0 +1,16 @@ +(in-package :org-agent) + +(defun semantic-mapping (task-state) + "Maps Org-mode task states to semantic categories." + (case (intern (string-upcase task-state) :keyword) + ((:todo :active :started :wait) :active) + ((:done :cancelled :resolved) :resolved) + (t :unknown))) + +(defun detect-active-children (task-id) + "Checks if a task has any child tasks in an active state." + (let ((children (list-objects-with-attribute :PARENT task-id))) + (remove-if-not (lambda (child) + (let ((todo (getf (org-object-attributes child) :TODO))) + (and todo (eq (semantic-mapping todo) :active)))) + children)))