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))
#+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)

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.
* 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

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*)
(make-skill :name (string-downcase (string ,name))
:priority (or ,priority 10)
:dependencies ,dependencies
:dependencies ',dependencies
:trigger-fn ,trigger
:neuro-prompt ,neuro
: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)
: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")

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.
#+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)

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)
#+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."

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
#+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))

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
#+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))

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.
#+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

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

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

5
src/bouncer.lisp
View File

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

29
src/chat-logic.lisp
View File

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

1
src/consensus-logic.lisp
View File

@@ -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."

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)
(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."

2
src/gateway-signal.lisp
View File

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

22
src/gateway-telegram.lisp
View File

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

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
: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...")

42
src/neuro.lisp
View File

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

3
src/processor-logic.lisp
View File

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

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

24
src/self-fix.lisp
View File

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

31
src/shell-logic.lisp
View File

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

2
src/skills.lisp
View File

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

96
src/symbolic.lisp
View File

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

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