amr/passepartout
1
0
Fork 0
Code Issues 15 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

PSF: Complete 'Thin Harness' refactor and move kernel logic to skills

Browse Source
This commit is contained in:
Amr Gharbeia
2026-04-12 16:43:43 -04:00
parent f047230e67
commit 294c1a976e
28 changed files with 454 additions and 466 deletions
Download Patch File Download Diff File Expand all files Collapse all files

60
literate/context.org
View File

@@ -181,67 +181,11 @@ The primary context generator. It identifies active projects and the current fov
output)) output))
#+end_src #+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) * Phase E: Chaos (Verification)
Verification of the peripheral vision extraction and rendering logic. 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 #+begin_src lisp :tangle ../tests/peripheral-vision-tests.lisp
(defpackage :org-agent-peripheral-vision-tests (defpackage :org-agent-peripheral-vision-tests
(:use :cl :fiveam :org-agent) (:use :cl :fiveam :org-agent)

187
literate/neurosymbolic.org
View File

@@ -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. - **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) * 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 ** Package Context
#+begin_src lisp :tangle ../src/neuro.lisp #+begin_src lisp :tangle ../src/neuro.lisp
(in-package :org-agent) (in-package :org-agent)
#+end_src #+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 ** Associative Backends Registry
Tracks the actual implementation functions for each LLM provider. Tracks the actual implementation functions for each LLM provider.
@@ -68,10 +25,10 @@ Tracks the actual implementation functions for each LLM provider.
#+end_src #+end_src
** Provider Cascade ** 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 #+begin_src lisp :tangle ../src/neuro.lisp
(defvar *provider-cascade* '(:openrouter :gemini)) (defvar *provider-cascade* '(:openrouter :gemini-api))
#+end_src #+end_src
** Register Associative Backend ** Register Associative Backend
@@ -89,10 +46,10 @@ A hook for dynamic model selection based on the current context.
#+end_src #+end_src
** Associative Dispatch (ask-neuro) ** 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 #+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)) (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." "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) (format nil "~{~a~^|CONSENSUS-SEP|~}" valid-results)
"(:type :LOG :payload (:text \"Neural Consensus Failure\"))"))) "(:type :LOG :payload (:text \"Neural Consensus Failure\"))")))
;; SEQUENTIAL CASCADE MODE (Legacy) ;; SEQUENTIAL CASCADE MODE
(or (dolist (backend backends) (or (dolist (backend backends)
(let ((backend-fn (gethash backend *neuro-backends*))) (let ((backend-fn (gethash backend *neuro-backends*)))
(when backend-fn (when backend-fn
@@ -139,28 +96,18 @@ The primary entry point for Associative. It handles the retry logic and backend
(result (if model (result (if model
(funcall backend-fn prompt system-prompt :model model) (funcall backend-fn prompt system-prompt :model model)
(funcall backend-fn prompt system-prompt)))) (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)))))) (return result))))))
"(:type :LOG :payload (:text \"Neural Cascade Failure\"))")))) "(:type :LOG :payload (:text \"Neural Cascade Failure\"))"))))
#+end_src #+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) ** 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 #+begin_src lisp :tangle ../src/neuro.lisp
(defun think (context) (defun think (context)
"Invokes the neural Associative engine to propose a Lisp action based on 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."
(let ((active-skill (find-triggered-skill context)) (let ((active-skill (find-triggered-skill context))
(tool-belt (generate-tool-belt-prompt)) (tool-belt (generate-tool-belt-prompt))
(global-context (context-assemble-global-awareness))) (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))) (ask-neuro (format nil "PROMPT: ~a~%RESULT: ~a" full-prompt successful-output) :system-prompt system-instr)))
#+end_src #+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 ** Package Context
#+begin_src lisp :tangle ../src/symbolic.lisp #+begin_src lisp :tangle ../src/symbolic.lisp
(in-package :org-agent) (in-package :org-agent)
#+end_src #+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) ** 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 #+begin_src lisp :tangle ../src/symbolic.lisp
(defun decide (proposed-action context) (defun decide (proposed-action context)
"The Deliberate Safety Gate: validates or rejects proposed neural actions." "The Deliberate Safety Gate: iterates through all skill symbolic-gates sorted by priority."
;; 1. Task Integrity Check (GTD Semantics) (let ((current-action proposed-action)
(let ((integrity-error (task-integrity-check proposed-action))) (skills nil))
(when integrity-error ;; 1. Collect all skills with symbolic gates
(kernel-log "DELIBERATE [INTEGRITY]: ~a~%" integrity-error) (maphash (lambda (name skill)
(return-from decide (list :type :LOG :payload (list :text integrity-error))))) (declare (ignore name))
(when (skill-symbolic-fn skill)
;; 2. Bouncer Check (Authorization Gate) (push skill skills)))
(when (bouncer-check proposed-action) *skills-registry*)
(kernel-log "DELIBERATE [BOUNCER]: Action requires manual approval.~%")
(return-from decide ;; 2. Sort skills by priority (highest first)
(list :type :EVENT (setf skills (sort skills #'> :key #'skill-priority))
:payload (list :sensor :approval-required :action proposed-action))))
;; 3. Execute symbolic gates sequentially
;; 3. Skill-specific and Safety Checks (dolist (skill skills)
(let ((active-skill (find-triggered-skill context))) (let ((gate (skill-symbolic-fn skill)))
(if (and proposed-action (listp proposed-action) active-skill) (setf current-action (funcall gate current-action context))
(let* ((symbolic-gate (skill-symbolic-fn active-skill)) ;; If any gate returns a LOG or EVENT (blocking/intercepting), stop and return it.
(payload (getf proposed-action :payload)) (when (and (listp current-action)
(action (or (getf payload :action) (getf proposed-action :action))) (member (getf current-action :type) '(:LOG :EVENT :log :event)))
(code (or (getf payload :code) (getf proposed-action :code)))) (kernel-log "DELIBERATE: Intercepted by skill '~a'~%" (skill-name skill))
;; Global safety harness for EVAL (return-from decide current-action))))
(when (and (member (getf proposed-action :type) '(:request :REQUEST))
(member action '(:eval :EVAL))) current-action))
(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
#+end_src #+end_src
** Store Filtering (list-objects-with-attribute) ** 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) (defun list-objects-with-attribute (attr-key attr-val)
"Filters the Object Store for nodes having a specific attribute value." "Filters the Object Store for nodes having a specific attribute value."
(let ((results nil)) (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)) results))
#+end_src #+end_src

2
literate/skills.org
View File

@@ -60,7 +60,7 @@ The primary macro used within Org files to register new agent capabilities.
`(setf (gethash (string-downcase (string ,name)) *skills-registry*) `(setf (gethash (string-downcase (string ,name)) *skills-registry*)
(make-skill :name (string-downcase (string ,name)) (make-skill :name (string-downcase (string ,name))
:priority (or ,priority 10) :priority (or ,priority 10)
:dependencies ,dependencies :dependencies ',dependencies
:trigger-fn ,trigger :trigger-fn ,trigger
:neuro-prompt ,neuro :neuro-prompt ,neuro
:symbolic-fn ,symbolic))) :symbolic-fn ,symbolic)))

4
org-agent.asd
View File

@@ -7,14 +7,14 @@
:depends-on (:usocket :cl-json :bordeaux-threads :dexador :uiop :cl-dotenv :cl-ppcre :hunchentoot :ironclad :str) :depends-on (:usocket :cl-json :bordeaux-threads :dexador :uiop :cl-dotenv :cl-ppcre :hunchentoot :ironclad :str)
:serial t :serial t
:components ((:file "src/package") :components ((:file "src/package")
(:file "src/protocol") (:file "src/skills")
(:file "src/protocol-validator") (:file "src/protocol-validator")
(:file "src/protocol")
(:file "src/object-store") (:file "src/object-store")
(:file "src/embedding") (:file "src/embedding")
(:file "src/embedding-logic") (:file "src/embedding-logic")
(:file "src/context") (:file "src/context")
(:file "src/context-logic") (:file "src/context-logic")
(:file "src/skills")
(:file "src/neuro") (:file "src/neuro")
(:file "src/credentials-vault") (:file "src/credentials-vault")
(:file "src/llm-gateway") (:file "src/llm-gateway")

5
skills/org-skill-bouncer.org
View File

@@ -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. Retrieves all active secrets from the vault and scans the payload for potential leaks.
#+begin_src lisp :tangle ../src/bouncer.lisp #+begin_src lisp :tangle ../src/bouncer.lisp
(in-package :org-agent)
(defun bouncer-scan-secrets (text) (defun bouncer-scan-secrets (text)
"Returns the name of the secret found in TEXT, or NIL if clean." "Returns the name of the secret found in TEXT, or NIL if clean."
(when (and text (stringp text)) (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. Inspects shell commands for unwhitelisted domains or IP addresses.
#+begin_src lisp :tangle ../src/bouncer.lisp #+begin_src lisp :tangle ../src/bouncer.lisp
(in-package :org-agent)
(defun bouncer-check-network-exfil (cmd) (defun bouncer-check-network-exfil (cmd)
"Returns T if the command appears to target an unwhitelisted external host." "Returns T if the command appears to target an unwhitelisted external host."
(when (and cmd (stringp cmd)) (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. The primary entry point for all high-impact actions.
#+begin_src lisp :tangle ../src/bouncer.lisp #+begin_src lisp :tangle ../src/bouncer.lisp
(in-package :org-agent)
(defun bouncer-check (action context) (defun bouncer-check (action context)
"The 5-Vector security gate. Blocks or queues actions based on risk." "The 5-Vector security gate. Blocks or queues actions based on risk."
(let* ((target (getf action :target)) (let* ((target (getf action :target))
@@ -98,6 +101,7 @@ The primary entry point for all high-impact actions.
** Approval Processing ** Approval Processing
#+begin_src lisp :tangle ../src/bouncer.lisp #+begin_src lisp :tangle ../src/bouncer.lisp
(in-package :org-agent)
(defun bouncer-process-approvals () (defun bouncer-process-approvals ()
"Scans the object store for APPROVED flight plans and re-injects their actions." "Scans the object store for APPROVED flight plans and re-injects their actions."
(let ((approved-nodes (list-objects-with-attribute :TODO "APPROVED")) (let ((approved-nodes (list-objects-with-attribute :TODO "APPROVED"))
@@ -120,6 +124,7 @@ The primary entry point for all high-impact actions.
** Skill Definition ** Skill Definition
#+begin_src lisp :tangle ../src/bouncer.lisp #+begin_src lisp :tangle ../src/bouncer.lisp
(in-package :org-agent)
(defskill :skill-bouncer (defskill :skill-bouncer
:priority 100 :priority 100
:trigger (lambda (ctx) :trigger (lambda (ctx)

1
skills/org-skill-consensus.org
View File

@@ -28,6 +28,7 @@ Enable reliable, cross-instance coordination without a central master.
** Consensus Algorithm (Simplified Raft) ** Consensus Algorithm (Simplified Raft)
#+begin_src lisp :tangle ../src/consensus-logic.lisp #+begin_src lisp :tangle ../src/consensus-logic.lisp
(in-package :org-agent)
(defun consensus-propose-vote (proposal) (defun consensus-propose-vote (proposal)
"Broadcasts a proposal to the peer swarm and collects votes. "Broadcasts a proposal to the peer swarm and collects votes.
Implements PSF Social Consensus Protocol." Implements PSF Social Consensus Protocol."

3
skills/org-skill-inbox-processor.org
View File

@@ -38,6 +38,7 @@ Iterate through the inbox. Use System 2 (Symbolic) to identify the tag. If ~@per
** Helper: Privacy & Archive Checks ** Helper: Privacy & Archive Checks
#+begin_src lisp :tangle ../src/processor-logic.lisp #+begin_src lisp :tangle ../src/processor-logic.lisp
(in-package :org-agent)
(defun inbox-is-private-p (tags) (defun inbox-is-private-p (tags)
(member "@personal" tags :test #'string-equal)) (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) ** Neural Stage (Enrichment)
#+begin_src lisp :tangle ../src/processor-logic.lisp #+begin_src lisp :tangle ../src/processor-logic.lisp
(in-package :org-agent)
(defun neuro-skill-inbox-processor (context) (defun neuro-skill-inbox-processor (context)
(let* ((payload (getf context :payload)) (let* ((payload (getf context :payload))
(content (getf payload :content)) (content (getf payload :content))
@@ -64,6 +66,7 @@ RULES:
** Symbolic Stage (The Physical Move) ** Symbolic Stage (The Physical Move)
#+begin_src lisp :tangle ../src/processor-logic.lisp #+begin_src lisp :tangle ../src/processor-logic.lisp
(in-package :org-agent)
(defun inbox-process-logic (action context) (defun inbox-process-logic (action context)
(declare (ignore action)) (declare (ignore action))
(let* ((payload (getf context :payload)) (let* ((payload (getf context :payload))

2
skills/org-skill-self-fix.org
View File

@@ -16,6 +16,8 @@ The *Self-Fix Agent* is the system's "Repair Mechanism." It takes failure hypoth
** Repair Logic ** Repair Logic
#+begin_src lisp :tangle ../src/self-fix.lisp #+begin_src lisp :tangle ../src/self-fix.lisp
(in-package :org-agent)
(defun self-fix-apply (action context) (defun self-fix-apply (action context)
"Applies a surgical code fix and reloads the modified skill." "Applies a surgical code fix and reloads the modified skill."
(declare (ignore context)) (declare (ignore context))

24
skills/org-skill-shell-actuator.org
View File

@@ -79,6 +79,7 @@ Interfaces for secure system calls. State is event-driven via the core kernel bu
Whitelist of permitted host binaries. Whitelist of permitted host binaries.
#+begin_src lisp :tangle ../src/shell-logic.lisp #+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")) (defparameter *allowed-commands* '("ls" "git" "rg" "grep" "date" "echo" "cat" "node" "python3" "sbcl"))
#+end_src #+end_src
@@ -86,6 +87,7 @@ Whitelist of permitted host binaries.
Dangerous characters that are banned to prevent command injection. Dangerous characters that are banned to prevent command injection.
#+begin_src lisp :tangle ../src/shell-logic.lisp #+begin_src lisp :tangle ../src/shell-logic.lisp
(in-package :org-agent)
(defparameter *shell-metacharacters* '(#\; #\& #\| #\> #\< #\$ #\` #\\ #\!) (defparameter *shell-metacharacters* '(#\; #\& #\| #\> #\< #\$ #\` #\\ #\!)
"Characters that are banned in shell commands to prevent injection.") "Characters that are banned in shell commands to prevent injection.")
#+end_src #+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. Predicate to verify a command string is free of metacharacters.
#+begin_src lisp :tangle ../src/shell-logic.lisp #+begin_src lisp :tangle ../src/shell-logic.lisp
(in-package :org-agent)
(defun shell-command-safe-p (cmd-string) (defun shell-command-safe-p (cmd-string)
"Returns T if the command string contains no dangerous metacharacters." "Returns T if the command string contains no dangerous metacharacters."
(not (some (lambda (char) (find char cmd-string)) *shell-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. The primary secure actuator for host system calls.
#+begin_src lisp :tangle ../src/shell-logic.lisp #+begin_src lisp :tangle ../src/shell-logic.lisp
(in-package :org-agent)
(defun execute-shell-safely (action context) (defun execute-shell-safely (action context)
(let* ((cmd-string (getf (getf action :payload) :cmd)) (let* ((cmd-string (getf (getf action :payload) :cmd))
(executable (car (uiop:split-string (string-trim " " cmd-string) :separator '(#\Space))))) (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. Executes a synthesized script (Python/Lisp/JS) in a controlled directory.
#+begin_src lisp :tangle ../src/shell-logic.lisp #+begin_src lisp :tangle ../src/shell-logic.lisp
(in-package :org-agent)
(defun execute-sandboxed-script (action context) (defun execute-sandboxed-script (action context)
"Executes a synthesized script (Python/Lisp/JS) in a controlled directory. "Executes a synthesized script (Python/Lisp/JS) in a controlled directory.
This enables SOTA-level Tool Synthesis and Iterative Fixing." 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. Hardware-Level Isolation for future security evolution.
#+begin_src lisp :tangle ../src/shell-logic.lisp #+begin_src lisp :tangle ../src/shell-logic.lisp
(in-package :org-agent)
(defun provision-microvm (id &key (cpu 1) (ram 512)) (defun provision-microvm (id &key (cpu 1) (ram 512))
"Hardware-Level Isolation: Provisions an ephemeral Firecracker MicroVM. "Hardware-Level Isolation: Provisions an ephemeral Firecracker MicroVM.
This is the high-security evolution of directory-based sandboxing." This is the high-security evolution of directory-based sandboxing."
@@ -172,6 +178,7 @@ Hardware-Level Isolation for future security evolution.
** Feedback Perception ** Feedback Perception
#+begin_src lisp :tangle ../src/shell-logic.lisp #+begin_src lisp :tangle ../src/shell-logic.lisp
(in-package :org-agent)
(defun trigger-skill-shell-actuator (context) (defun trigger-skill-shell-actuator (context)
(let ((type (getf context :type)) (let ((type (getf context :type))
(payload (getf context :payload))) (payload (getf context :payload)))
@@ -181,6 +188,7 @@ Hardware-Level Isolation for future security evolution.
** Neuro-Cognitive Analysis ** Neuro-Cognitive Analysis
#+begin_src lisp :tangle ../src/shell-logic.lisp #+begin_src lisp :tangle ../src/shell-logic.lisp
(in-package :org-agent)
(defun neuro-skill-shell-actuator (context) (defun neuro-skill-shell-actuator (context)
(let* ((p (getf context :payload)) (let* ((p (getf context :payload))
(cmd (getf p :cmd)) (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 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. If it succeeded, use the STDOUT to complete the original goal.
" cmd exit-code stdout stderr) " 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))) cmd exit-code stdout stderr)))
`(:type :request :target :emacs :payload (:action :insert-at-end :buffer "*org-agent-chat*" :text ,result-text)))))) `(:type :request :target :emacs :payload (:action :insert-at-end :buffer "*org-agent-chat*" :text ,result-text))))))
#+end_src #+end_src
@@ -210,6 +230,7 @@ Hardware-Level Isolation for future security evolution.
Register the shell channel as a physical actuator. Register the shell channel as a physical actuator.
#+begin_src lisp :tangle ../src/shell-logic.lisp #+begin_src lisp :tangle ../src/shell-logic.lisp
(in-package :org-agent)
(org-agent:register-actuator :shell #'execute-shell-safely) (org-agent:register-actuator :shell #'execute-shell-safely)
#+end_src #+end_src
@@ -217,6 +238,7 @@ Register the shell channel as a physical actuator.
Define the skill entry for the shell actuator. Define the skill entry for the shell actuator.
#+begin_src lisp :tangle ../src/shell-logic.lisp #+begin_src lisp :tangle ../src/shell-logic.lisp
(in-package :org-agent)
(defskill :skill-shell-actuator (defskill :skill-shell-actuator
:priority 80 :priority 80
:trigger #'trigger-skill-shell-actuator :trigger #'trigger-skill-shell-actuator

84
skills/org-skill-task-integrity.org
View File

@@ -36,42 +36,62 @@ Define automated behaviors for GTD state consistency and dependency verification
:END: :END:
* Phase B: Blueprint (PROTOCOL) * Implementation
:PROPERTIES:
:STATUS: DRAFT
:END:
** 1. Architectural Intent ** Semantic Mapping
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. #+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)` ** Active Children Detection
- *Purpose:* Core function to validate a proposed state transition. #+begin_src lisp :tangle ../src/task-integrity.lisp
- *Parameters:* (defun detect-active-children (task-id)
- `task-id`: Unique identifier of the task (e.g., Org-id). "Checks if a task has any child tasks in an active state."
- `new-state`: Target state of the task (e.g., 'DONE', 'ACTIVE'). (let ((children (list-objects-with-attribute :PARENT task-id)))
- *Returns:* `t` if the transition is valid; `nil` or an error message (string) if invalid. (remove-if-not (lambda (child)
- *Example:* `(task-integrity-check "*TODO Example Task" 'DONE)` (let ((todo (getf (org-object-attributes child) :TODO)))
(and todo (eq (semantic-mapping todo) :active))))
children)))
#+end_src
*** `semantic-mapping (task-state)` ** Integrity Check (task-integrity-check)
- *Purpose:* Maps Org-mode task states (e.g., 'TODO', 'DONE') to semantic categories (e.g., 'Active', 'Resolved'). Enforces high-integrity semantic rules for task management.
- *Parameters:*
- `task-state`: An Org-mode task state keyword.
- *Returns:* Semantic category symbol (e.g., `:active`, `:resolved`).
- *Example:* `(semantic-mapping 'TODO)` -> `:active`
*** `detect-active-children (task-id)` #+begin_src lisp :tangle ../src/task-integrity.lisp
- *Purpose:* Checks if a task has any child tasks in an active state. (defun task-integrity-check (action)
- *Parameters:* "Enforces semantic GTD integrity rules on proposed actions."
- `task-id`: Unique identifier of the parent task. (let* ((payload (getf action :payload))
- *Returns:* A list of active child task IDs, or `nil` if no active children exist. (act (or (getf payload :action) (getf action :action)))
- *Example:* `(detect-active-children "*TODO Parent Task")` -> `("*TODO Child Task 1" "*TODO Child Task 2")` (if they are TODO) (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).

5
src/bouncer.lisp
View File

@@ -1,3 +1,4 @@
(in-package :org-agent)
(defun bouncer-scan-secrets (text) (defun bouncer-scan-secrets (text)
"Returns the name of the secret found in TEXT, or NIL if clean." "Returns the name of the secret found in TEXT, or NIL if clean."
(when (and text (stringp text)) (when (and text (stringp text))
@@ -9,6 +10,7 @@
*vault-memory*) *vault-memory*)
found-secret))) found-secret)))
(in-package :org-agent)
(defun bouncer-check-network-exfil (cmd) (defun bouncer-check-network-exfil (cmd)
"Returns T if the command appears to target an unwhitelisted external host." "Returns T if the command appears to target an unwhitelisted external host."
(when (and cmd (stringp cmd)) (when (and cmd (stringp cmd))
@@ -21,6 +23,7 @@
(let ((domain (aref regs 1))) (let ((domain (aref regs 1)))
(not (some (lambda (safe) (search safe domain)) network-whitelist)))))))) (not (some (lambda (safe) (search safe domain)) network-whitelist))))))))
(in-package :org-agent)
(defun bouncer-check (action context) (defun bouncer-check (action context)
"The 5-Vector security gate. Blocks or queues actions based on risk." "The 5-Vector security gate. Blocks or queues actions based on risk."
(let* ((target (getf action :target)) (let* ((target (getf action :target))
@@ -59,6 +62,7 @@
;; 4. Default Pass ;; 4. Default Pass
(t action)))) (t action))))
(in-package :org-agent)
(defun bouncer-process-approvals () (defun bouncer-process-approvals ()
"Scans the object store for APPROVED flight plans and re-injects their actions." "Scans the object store for APPROVED flight plans and re-injects their actions."
(let ((approved-nodes (list-objects-with-attribute :TODO "APPROVED")) (let ((approved-nodes (list-objects-with-attribute :TODO "APPROVED"))
@@ -78,6 +82,7 @@
(setq found-any t)))))) (setq found-any t))))))
found-any)) found-any))
(in-package :org-agent)
(defskill :skill-bouncer (defskill :skill-bouncer
:priority 100 :priority 100
:trigger (lambda (ctx) :trigger (lambda (ctx)

29
src/chat-logic.lisp
View File

@@ -1,9 +1,26 @@
(in-package :org-agent) (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) (defun trigger-skill-chat (context)
(let* ((payload (getf context :payload)) (let* ((payload (getf context :payload))
(sensor (getf payload :sensor))) (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) (defun verify-skill-chat (proposed-action context)
(let* ((payload (getf proposed-action :payload)) (let* ((payload (getf proposed-action :payload))
@@ -23,9 +40,13 @@
(or (getf payload :cmd) (getf proposed-action :cmd))) (or (getf payload :cmd) (getf proposed-action :cmd)))
(member target '(:tool :TOOL)))) (member target '(:tool :TOOL))))
(member (getf proposed-action :type) '(:response :RESPONSE :log :LOG)))) (member (getf proposed-action :type) '(:response :RESPONSE :log :LOG))))
proposed-action (progn
(let ((err-text (format nil " ;; Archive outbound response
*System Error:* Chat agent returned invalid action: ~s" proposed-action))) (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)))))) `(:type :request :target :emacs :payload (:action :insert-at-end :buffer "*org-agent-chat*" :text ,err-text))))))
(defun neuro-skill-chat (context) (defun neuro-skill-chat (context)

1
src/consensus-logic.lisp
View File

@@ -1,3 +1,4 @@
(in-package :org-agent)
(defun consensus-propose-vote (proposal) (defun consensus-propose-vote (proposal)
"Broadcasts a proposal to the peer swarm and collects votes. "Broadcasts a proposal to the peer swarm and collects votes.
Implements PSF Social Consensus Protocol." Implements PSF Social Consensus Protocol."

72
src/context-logic.lisp Normal file
View File

@@ -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))

60
src/embedding-logic.lisp Normal file
View File

@@ -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))))

57
src/gateway-matrix.lisp
View File

@@ -37,34 +37,35 @@
(when (and hs token) (when (and hs token)
(handler-case (handler-case
(let* ((response (dex:get url :headers `(("Authorization" . ,(format nil "Bearer ~a" token))))) (let* ((response (dex:get url :headers `(("Authorization" . ,(format nil "Bearer ~a" token)))))
(json (cl-json:decode-json-from-string response)) (json (cl-json:decode-json-from-string response))
(next-batch (or (cdr (assoc :next-batch json)) (next-batch (or (cdr (assoc :next-batch json))
(cdr (assoc :next--batch json)))) (cdr (assoc :next--batch json))))
(rooms (cdr (assoc :rooms json))) (rooms (cdr (assoc :rooms json)))
(joined (cdr (assoc :join rooms)))) (joined (cdr (assoc :join rooms))))
(when next-batch (when next-batch
(setf *matrix-since-token* next-batch)) (setf *matrix-since-token* next-batch))
(dolist (room-entry joined) (dolist (room-entry joined)
(let* ((room-id (string-downcase (string (car room-entry)))) (let* ((room-id (string-downcase (string (car room-entry))))
(room-data (cdr room-entry)) (room-data (cdr room-entry))
(timeline (cdr (assoc :timeline room-data))) (timeline (cdr (assoc :timeline room-data)))
(events (cdr (assoc :events timeline)))) (events (cdr (assoc :events timeline))))
(dolist (event events) (dolist (event events)
(let* ((type (cdr (assoc :type event))) (let* ((type (cdr (assoc :type event)))
(content (cdr (assoc :content event))) (content (cdr (assoc :content event)))
(sender (cdr (assoc :sender event))) (sender (cdr (assoc :sender event)))
(body (cdr (assoc :body content)))) (body (cdr (assoc :body content))))
(when (and (string= type "m.room.message") body) (when (and (string= type "m.room.message") body)
(kernel-log "MATRIX: Received message from ~a in ~a" sender room-id) (kernel-log "MATRIX: Received message from ~a in ~a" sender room-id)
(inject-stimulus (inject-stimulus
(list :type :EVENT (list :type :EVENT
:payload (list :sensor :chat-message :payload (list :sensor :chat-message
:channel :matrix :channel :matrix
:room-id room-id :room-id room-id
:sender sender :sender sender
:text body))))))))) (error (c) (kernel-log "MATRIX SYNC ERROR: ~a" c)))))) :text body)))))))))
(error (c) (kernel-log "MATRIX SYNC ERROR: ~a" c))))))
(defun start-matrix-gateway () (defun start-matrix-gateway ()
"Initializes the Matrix background thread." "Initializes the Matrix background thread."

2
src/gateway-signal.lisp
View File

@@ -45,7 +45,7 @@
(defun start-signal-gateway () (defun start-signal-gateway ()
"Initializes the Signal background thread." "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* (setf *signal-polling-thread*
(bt:make-thread (bt:make-thread
(lambda () (lambda ()

22
src/gateway-telegram.lisp
View File

@@ -1,7 +1,9 @@
(in-package :org-agent) (in-package :org-agent)
(defvar *telegram-last-update-id* 0) (defvar *telegram-last-update-id* 0)
(defvar *telegram-polling-thread* nil) (defvar *telegram-polling-thread* nil)
(defvar *telegram-authorized-chats* nil (defvar *telegram-authorized-chats* nil
"List of chat IDs allowed to interact with the bot. Hydrated from environment.") "List of chat IDs allowed to interact with the bot. Hydrated from environment.")
@@ -68,14 +70,12 @@
(bt:destroy-thread *telegram-polling-thread*) (bt:destroy-thread *telegram-polling-thread*)
(setf *telegram-polling-thread* nil))) (setf *telegram-polling-thread* nil)))
(progn (register-actuator :telegram #'execute-telegram-action)
(register-actuator :telegram #'execute-telegram-action)
(defskill :skill-gateway-telegram
(defskill :skill-gateway-telegram :priority 150
:priority 150 :trigger (lambda (ctx) (declare (ignore ctx)) nil) ;; Passive, handles its own loop
:trigger (lambda (ctx) (declare (ignore ctx)) nil) ;; Passive, handles its own loop :neuro nil
:neuro nil :symbolic (lambda (action ctx) (declare (ignore ctx)) action))
:symbolic (lambda (action ctx) (declare (ignore ctx)) action))
(start-telegram-gateway)
;; Initialize the background polling loop
(start-telegram-gateway))

5
src/lisp-repair.lisp
View File

@@ -30,11 +30,10 @@ MANDATE: Output EXACTLY ONE valid Common Lisp list. Do not explain. Do not use m
(defskill :skill-lisp-repair (defskill :skill-lisp-repair
:priority 90 :priority 90
:trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :syntax-error)) :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) :symbolic (lambda (action context)
(declare (ignore action)) (declare (ignore action))
(let* ((stimulus (getf context :candidate)) (let* ((payload (getf context :payload))
(payload (getf stimulus :payload))
(code (getf payload :code)) (code (getf payload :code))
(error-msg (getf payload :error))) (error-msg (getf payload :error)))
(kernel-log "SYNTAX GATE: Reacting to broken Lisp stimulus...") (kernel-log "SYNTAX GATE: Reacting to broken Lisp stimulus...")

42
src/neuro.lisp
View File

@@ -1,39 +1,14 @@
(in-package :org-agent) (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 *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)) (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 *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)) (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." "Dispatches a neural request through the provider cascade or parallel consensus."
@@ -71,7 +46,7 @@
(format nil "~{~a~^|CONSENSUS-SEP|~}" valid-results) (format nil "~{~a~^|CONSENSUS-SEP|~}" valid-results)
"(:type :LOG :payload (:text \"Neural Consensus Failure\"))"))) "(:type :LOG :payload (:text \"Neural Consensus Failure\"))")))
;; SEQUENTIAL CASCADE MODE (Legacy) ;; SEQUENTIAL CASCADE MODE
(or (dolist (backend backends) (or (dolist (backend backends)
(let ((backend-fn (gethash backend *neuro-backends*))) (let ((backend-fn (gethash backend *neuro-backends*)))
(when backend-fn (when backend-fn
@@ -80,18 +55,13 @@
(result (if model (result (if model
(funcall backend-fn prompt system-prompt :model model) (funcall backend-fn prompt system-prompt :model model)
(funcall backend-fn prompt system-prompt)))) (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)))))) (return result))))))
"(:type :LOG :payload (:text \"Neural Cascade Failure\"))")))) "(: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) (defun think (context)
"Invokes the neural Associative engine to propose a Lisp action based on 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."
(let ((active-skill (find-triggered-skill context)) (let ((active-skill (find-triggered-skill context))
(tool-belt (generate-tool-belt-prompt)) (tool-belt (generate-tool-belt-prompt))
(global-context (context-assemble-global-awareness))) (global-context (context-assemble-global-awareness)))

3
src/processor-logic.lisp
View File

@@ -1,9 +1,11 @@
(in-package :org-agent)
(defun inbox-is-private-p (tags) (defun inbox-is-private-p (tags)
(member "@personal" tags :test #'string-equal)) (member "@personal" tags :test #'string-equal))
(defun inbox-is-archive-p (tags) (defun inbox-is-archive-p (tags)
(member "!archive" tags :test #'string-equal)) (member "!archive" tags :test #'string-equal))
(in-package :org-agent)
(defun neuro-skill-inbox-processor (context) (defun neuro-skill-inbox-processor (context)
(let* ((payload (getf context :payload)) (let* ((payload (getf context :payload))
(content (getf payload :content)) (content (getf payload :content))
@@ -18,6 +20,7 @@ RULES:
4. Return ONLY a Lisp plist with :summary :significance :full-text. 4. Return ONLY a Lisp plist with :summary :significance :full-text.
5. NO conversational filler." is-archive)))) 5. NO conversational filler." is-archive))))
(in-package :org-agent)
(defun inbox-process-logic (action context) (defun inbox-process-logic (action context)
(declare (ignore action)) (declare (ignore action))
(let* ((payload (getf context :payload)) (let* ((payload (getf context :payload))

39
src/protocol-validator.lisp Normal file
View File

@@ -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))

42
src/safety-harness.lisp
View File

@@ -40,45 +40,3 @@
declare ignore declare ignore
;; Let's also add simple data types ;; Let's also add simple data types
t nil quote function)) 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)))

24
src/self-fix.lisp
View File

@@ -10,8 +10,8 @@
(is-skill (and (stringp (namestring target-file)) (is-skill (and (stringp (namestring target-file))
(search "skills/" (namestring target-file))))) (search "skills/" (namestring target-file)))))
(snapshot-object-store) (org-agent:snapshot-object-store)
(kernel-log "SELF-FIX - Attempting surgical fix on ~a..." target-file) (org-agent:kernel-log "SELF-FIX - Attempting surgical fix on ~a..." target-file)
(handler-case (handler-case
(if (uiop:file-exists-p target-file) (if (uiop:file-exists-p target-file)
@@ -23,25 +23,25 @@
(if is-skill (if is-skill
(progn (progn
(kernel-log "SELF-FIX - Reloading modified skill ~a..." target-file) (org-agent:kernel-log "SELF-FIX - Reloading modified skill ~a..." target-file)
(if (load-skill-from-org target-file) (if (org-agent:load-skill-from-org target-file)
(progn (progn
(kernel-log "SELF-FIX SUCCESS - Applied and reloaded.") (org-agent:kernel-log "SELF-FIX SUCCESS - Applied and reloaded.")
t) t)
(progn (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) (with-open-file (out target-file :direction :output :if-exists :supersede)
(write-string content out)) (write-string content out))
(rollback-object-store 0) (org-agent:rollback-object-store 0)
nil))) nil)))
(progn (progn
(kernel-log "SELF-FIX SUCCESS - Applied fix to file.") (org-agent:kernel-log "SELF-FIX SUCCESS - Applied fix to file.")
t))) t)))
(progn (kernel-log "SELF-FIX FAILURE - Pattern not found.") nil))) (progn (org-agent: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 - File not found.") nil))
(error (c) (error (c)
(kernel-log "SELF-FIX CRASH - ~a. Rolling back." c) (org-agent:kernel-log "SELF-FIX CRASH - ~a. Rolling back." c)
(rollback-object-store 0) (org-agent:rollback-object-store 0)
nil)))) nil))))
(def-cognitive-tool :repair-file (def-cognitive-tool :repair-file

31
src/shell-logic.lisp
View File

@@ -1,14 +1,16 @@
(in-package :org-agent) (in-package :org-agent)
(defparameter *allowed-commands* '("ls" "git" "rg" "grep" "date" "echo" "cat" "node" "python3" "sbcl")) (defparameter *allowed-commands* '("ls" "git" "rg" "grep" "date" "echo" "cat" "node" "python3" "sbcl"))
(in-package :org-agent)
(defparameter *shell-metacharacters* '(#\; #\& #\| #\> #\< #\$ #\` #\\ #\!) (defparameter *shell-metacharacters* '(#\; #\& #\| #\> #\< #\$ #\` #\\ #\!)
"Characters that are banned in shell commands to prevent injection.") "Characters that are banned in shell commands to prevent injection.")
(in-package :org-agent)
(defun shell-command-safe-p (cmd-string) (defun shell-command-safe-p (cmd-string)
"Returns T if the command string contains no dangerous metacharacters." "Returns T if the command string contains no dangerous metacharacters."
(not (some (lambda (char) (find char cmd-string)) *shell-metacharacters*))) (not (some (lambda (char) (find char cmd-string)) *shell-metacharacters*)))
(in-package :org-agent)
(defun execute-shell-safely (action context) (defun execute-shell-safely (action context)
(let* ((cmd-string (getf (getf action :payload) :cmd)) (let* ((cmd-string (getf (getf action :payload) :cmd))
(executable (car (uiop:split-string (string-trim " " cmd-string) :separator '(#\Space))))) (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)) `(:type :EVENT :payload (:sensor :shell-response :cmd ,cmd-string :stdout ,(or stdout "") :stderr ,(or stderr "") :exit-code ,exit-code))
:stream (getf context :reply-stream))))))) :stream (getf context :reply-stream)))))))
(in-package :org-agent)
(defun execute-sandboxed-script (action context) (defun execute-sandboxed-script (action context)
"Executes a synthesized script (Python/Lisp/JS) in a controlled directory. "Executes a synthesized script (Python/Lisp/JS) in a controlled directory.
This enables SOTA-level Tool Synthesis and Iterative Fixing." 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)) `(: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)))))) :stream (getf context :reply-stream))))))
(in-package :org-agent)
(defun provision-microvm (id &key (cpu 1) (ram 512)) (defun provision-microvm (id &key (cpu 1) (ram 512))
"Hardware-Level Isolation: Provisions an ephemeral Firecracker MicroVM. "Hardware-Level Isolation: Provisions an ephemeral Firecracker MicroVM.
This is the high-security evolution of directory-based sandboxing." This is the high-security evolution of directory-based sandboxing."
@@ -65,36 +69,17 @@
;; Future implementation: Wraps 'fcvm' or 'firecracker' CLI calls. ;; Future implementation: Wraps 'fcvm' or 'firecracker' CLI calls.
(format nil "vm-~a-provisioned" id)) (format nil "vm-~a-provisioned" id))
(in-package :org-agent)
(defun trigger-skill-shell-actuator (context) (defun trigger-skill-shell-actuator (context)
(let ((type (getf context :type)) (let ((type (getf context :type))
(payload (getf context :payload))) (payload (getf context :payload)))
(and (eq type :EVENT) (and (eq type :EVENT)
(eq (getf payload :sensor) :shell-response)))) (eq (getf payload :sensor) :shell-response))))
(defun neuro-skill-shell-actuator (context) (in-package :org-agent)
(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))))))
(org-agent:register-actuator :shell #'execute-shell-safely) (org-agent:register-actuator :shell #'execute-shell-safely)
(in-package :org-agent)
(defskill :skill-shell-actuator (defskill :skill-shell-actuator
:priority 80 :priority 80
:trigger #'trigger-skill-shell-actuator :trigger #'trigger-skill-shell-actuator

2
src/skills.lisp
View File

@@ -26,7 +26,7 @@
`(setf (gethash (string-downcase (string ,name)) *skills-registry*) `(setf (gethash (string-downcase (string ,name)) *skills-registry*)
(make-skill :name (string-downcase (string ,name)) (make-skill :name (string-downcase (string ,name))
:priority (or ,priority 10) :priority (or ,priority 10)
:dependencies ,dependencies :dependencies ',dependencies
:trigger-fn ,trigger :trigger-fn ,trigger
:neuro-prompt ,neuro :neuro-prompt ,neuro
:symbolic-fn ,symbolic))) :symbolic-fn ,symbolic)))

96
src/symbolic.lisp
View File

@@ -1,75 +1,37 @@
(in-package :org-agent) (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) (defun decide (proposed-action context)
"The Deliberate Safety Gate: validates or rejects proposed neural actions." "The Deliberate Safety Gate: iterates through all skill symbolic-gates sorted by priority."
;; 1. Task Integrity Check (GTD Semantics) (let ((current-action proposed-action)
(let ((integrity-error (task-integrity-check proposed-action))) (skills nil))
(when integrity-error ;; 1. Collect all skills with symbolic gates
(kernel-log "DELIBERATE [INTEGRITY]: ~a~%" integrity-error) (maphash (lambda (name skill)
(return-from decide (list :type :LOG :payload (list :text integrity-error))))) (declare (ignore name))
(when (skill-symbolic-fn skill)
;; 2. Bouncer Check (Authorization Gate) (push skill skills)))
(when (bouncer-check proposed-action) *skills-registry*)
(kernel-log "DELIBERATE [BOUNCER]: Action requires manual approval.~%")
(return-from decide ;; 2. Sort skills by priority (highest first)
(list :type :EVENT (setf skills (sort skills #'> :key #'skill-priority))
:payload (list :sensor :approval-required :action proposed-action))))
;; 3. Execute symbolic gates sequentially
;; 3. Skill-specific and Safety Checks (dolist (skill skills)
(let ((active-skill (find-triggered-skill context))) (let ((gate (skill-symbolic-fn skill)))
(if (and proposed-action (listp proposed-action) active-skill) (setf current-action (funcall gate current-action context))
(let* ((symbolic-gate (skill-symbolic-fn active-skill)) ;; If any gate returns a LOG or EVENT (blocking/intercepting), stop and return it.
(payload (getf proposed-action :payload)) (when (and (listp current-action)
(action (or (getf payload :action) (getf proposed-action :action))) (member (getf current-action :type) '(:LOG :EVENT :log :event)))
(code (or (getf payload :code) (getf proposed-action :code)))) (kernel-log "DELIBERATE: Intercepted by skill '~a'~%" (skill-name skill))
;; Global safety harness for EVAL (return-from decide current-action))))
(when (and (member (getf proposed-action :type) '(:request :REQUEST))
(member action '(:eval :EVAL))) current-action))
(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)))
(defun list-objects-with-attribute (attr-key attr-val) (defun list-objects-with-attribute (attr-key attr-val)
"Filters the Object Store for nodes having a specific attribute value." "Filters the Object Store for nodes having a specific attribute value."
(let ((results nil)) (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)) results))

16
src/task-integrity.lisp Normal file
View File

@@ -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)))