FIX: Correct all tangle paths and regenerate Lisp sources
This commit is contained in:
@@ -94,18 +94,6 @@ Standard functions that can be overridden by specific skills to provide enhanced
|
|||||||
"Generic fallback for routing. Overridden by skill-token-accountant."
|
"Generic fallback for routing. Overridden by skill-token-accountant."
|
||||||
(declare (ignore context))
|
(declare (ignore context))
|
||||||
'(:openrouter :gemini))
|
'(:openrouter :gemini))
|
||||||
|
|
||||||
(defun org-id-new ()
|
|
||||||
"Generic fallback for ID generation. Overridden by skill-ast-normalization."
|
|
||||||
(format nil "node-~a" (get-universal-time)))
|
|
||||||
|
|
||||||
(defun get-org-timestamp ()
|
|
||||||
"Returns a current Org-mode active timestamp."
|
|
||||||
(multiple-value-bind (sec min hour day month year day-of-week) (decode-universal-time (get-universal-time))
|
|
||||||
(declare (ignore sec))
|
|
||||||
(let ((day-names '("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun")))
|
|
||||||
(format nil "[~4,'0d-~2,'0d-~2,'0d ~a ~2,'0d:~2,'0d]"
|
|
||||||
year month day (nth day-of-week day-names) hour min))))
|
|
||||||
#+end_src
|
#+end_src
|
||||||
|
|
||||||
** Neural Reasoning (think)
|
** Neural Reasoning (think)
|
||||||
|
|||||||
@@ -28,7 +28,7 @@ Verify the system's stability and error-handling capabilities under stress.
|
|||||||
* Phase D: Build (Implementation)
|
* Phase D: Build (Implementation)
|
||||||
|
|
||||||
** Chaos Injection Logic
|
** Chaos Injection Logic
|
||||||
#+begin_src lisp :tangle ../projects/org-skill-chaos/src/chaos-logic.lisp
|
#+begin_src lisp :tangle ../src/chaos-logic.lisp
|
||||||
(defun chaos-inject-error (sensor-type)
|
(defun chaos-inject-error (sensor-type)
|
||||||
"Injects a synthetic error into a specific sensor pipeline."
|
"Injects a synthetic error into a specific sensor pipeline."
|
||||||
(org-agent:kernel-log "CHAOS - Injecting synthetic error into ~a sensor..." sensor-type)
|
(org-agent:kernel-log "CHAOS - Injecting synthetic error into ~a sensor..." sensor-type)
|
||||||
|
|||||||
@@ -49,7 +49,7 @@ Interfaces for conversational event handling and UI integration. Source of truth
|
|||||||
* Phase D: Build (Implementation)
|
* Phase D: Build (Implementation)
|
||||||
|
|
||||||
** Event Perception
|
** Event Perception
|
||||||
#+begin_src lisp :tangle ../projects/org-skill-chat/src/chat-logic.lisp
|
#+begin_src lisp :tangle ../src/chat-logic.lisp
|
||||||
(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)))
|
||||||
@@ -57,7 +57,7 @@ Interfaces for conversational event handling and UI integration. Source of truth
|
|||||||
#+end_src
|
#+end_src
|
||||||
|
|
||||||
** Symbolic Verification
|
** Symbolic Verification
|
||||||
#+begin_src lisp :tangle ../projects/org-skill-chat/src/chat-logic.lisp
|
#+begin_src lisp :tangle ../src/chat-logic.lisp
|
||||||
(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))
|
||||||
(action (or (getf payload :action) (getf proposed-action :action)))
|
(action (or (getf payload :action) (getf proposed-action :action)))
|
||||||
@@ -78,7 +78,7 @@ Interfaces for conversational event handling and UI integration. Source of truth
|
|||||||
** Neural Response Generation
|
** Neural Response Generation
|
||||||
The Chat skill acts as the conversational UI. Because the ~org-agent~ kernel evaluates LLM output via ~read-from-string~ (expecting a valid s-expression) and the chat verifier strictly expects an Emacs ~:insert-at-end~ actuation, we must explicitly mandate that the LLM wraps its conversational output in a Common Lisp property list.
|
The Chat skill acts as the conversational UI. Because the ~org-agent~ kernel evaluates LLM output via ~read-from-string~ (expecting a valid s-expression) and the chat verifier strictly expects an Emacs ~:insert-at-end~ actuation, we must explicitly mandate that the LLM wraps its conversational output in a Common Lisp property list.
|
||||||
|
|
||||||
#+begin_src lisp :tangle ../projects/org-skill-chat/src/chat-logic.lisp
|
#+begin_src lisp :tangle ../src/chat-logic.lisp
|
||||||
(defun neuro-skill-chat (context)
|
(defun neuro-skill-chat (context)
|
||||||
"Generates a conversational response, stripping system errors from context."
|
"Generates a conversational response, stripping system errors from context."
|
||||||
(let* ((payload (getf context :payload))
|
(let* ((payload (getf context :payload))
|
||||||
|
|||||||
@@ -27,7 +27,7 @@ Enable reliable, cross-instance coordination without a central master.
|
|||||||
* Phase D: Build (Implementation)
|
* Phase D: Build (Implementation)
|
||||||
|
|
||||||
** Consensus Algorithm (Simplified Raft)
|
** Consensus Algorithm (Simplified Raft)
|
||||||
#+begin_src lisp :tangle projects/org-skill-consensus/src/consensus-logic.lisp
|
#+begin_src lisp :tangle ../src/consensus-logic.lisp
|
||||||
(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."
|
||||||
|
|||||||
@@ -34,7 +34,7 @@ Define a standardized `CONFIG` object type in the Object Store. Provide getter/s
|
|||||||
** 2. Semantic Interfaces
|
** 2. Semantic Interfaces
|
||||||
|
|
||||||
*** Fleet Configuration
|
*** Fleet Configuration
|
||||||
#+begin_src lisp :tangle ../projects/org-skill-environment-config/src/config-logic.lisp
|
#+begin_src lisp :tangle ../src/config-logic.lisp
|
||||||
(in-package :org-agent)
|
(in-package :org-agent)
|
||||||
|
|
||||||
(defun set-llm-model (provider model-id)
|
(defun set-llm-model (provider model-id)
|
||||||
|
|||||||
@@ -26,7 +26,7 @@ Define a logic-based verification layer for high-integrity decision making.
|
|||||||
* Phase D: Build (Implementation)
|
* Phase D: Build (Implementation)
|
||||||
|
|
||||||
** Invariants Registry
|
** Invariants Registry
|
||||||
#+begin_src lisp :tangle projects/org-skill-formal-verification/src/verification-logic.lisp
|
#+begin_src lisp :tangle ../src/verification-logic.lisp
|
||||||
(defparameter *security-invariants*
|
(defparameter *security-invariants*
|
||||||
'((:name "Path-Safety" :formula "(assert (forall ((p String)) (=> (is-write-op p) (str.prefixof \"/home/user/memex\" p))))")))
|
'((:name "Path-Safety" :formula "(assert (forall ((p String)) (=> (is-write-op p) (str.prefixof \"/home/user/memex\" p))))")))
|
||||||
|
|
||||||
|
|||||||
@@ -37,7 +37,7 @@ Iterate through the inbox. Use System 2 (Symbolic) to identify the tag. If ~@per
|
|||||||
* Phase D: Build (Implementation)
|
* Phase D: Build (Implementation)
|
||||||
|
|
||||||
** Helper: Privacy & Archive Checks
|
** Helper: Privacy & Archive Checks
|
||||||
#+begin_src lisp :tangle ../projects/org-skill-inbox-processor/src/processor-logic.lisp
|
#+begin_src lisp :tangle ../src/processor-logic.lisp
|
||||||
(defun inbox-is-private-p (tags)
|
(defun inbox-is-private-p (tags)
|
||||||
(member "@personal" tags :test #'string-equal))
|
(member "@personal" tags :test #'string-equal))
|
||||||
|
|
||||||
@@ -46,7 +46,7 @@ Iterate through the inbox. Use System 2 (Symbolic) to identify the tag. If ~@per
|
|||||||
#+end_src
|
#+end_src
|
||||||
|
|
||||||
** Neural Stage (Enrichment)
|
** Neural Stage (Enrichment)
|
||||||
#+begin_src lisp :tangle ../projects/org-skill-inbox-processor/src/processor-logic.lisp
|
#+begin_src lisp :tangle ../src/processor-logic.lisp
|
||||||
(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))
|
||||||
@@ -63,7 +63,7 @@ RULES:
|
|||||||
#+end_src
|
#+end_src
|
||||||
|
|
||||||
** Symbolic Stage (The Physical Move)
|
** Symbolic Stage (The Physical Move)
|
||||||
#+begin_src lisp :tangle ../projects/org-skill-inbox-processor/src/processor-logic.lisp
|
#+begin_src lisp :tangle ../src/processor-logic.lisp
|
||||||
(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))
|
||||||
|
|||||||
@@ -38,7 +38,7 @@ Implement a deterministic classifier for known sensors and a neural fallback for
|
|||||||
- =:REASONING=: Generative tasks (coding, blueprinting, debugging).
|
- =:REASONING=: Generative tasks (coding, blueprinting, debugging).
|
||||||
|
|
||||||
*** Routing Logic
|
*** Routing Logic
|
||||||
#+begin_src lisp :tangle ../projects/org-skill-router/src/router-logic.lisp
|
#+begin_src lisp :tangle ../src/router-logic.lisp
|
||||||
(in-package :org-agent)
|
(in-package :org-agent)
|
||||||
|
|
||||||
(defun router-classify-complexity (context)
|
(defun router-classify-complexity (context)
|
||||||
|
|||||||
@@ -52,7 +52,7 @@ Interfaces for secure system calls. State is event-driven via the core kernel bu
|
|||||||
* Phase D: Build (Implementation)
|
* Phase D: Build (Implementation)
|
||||||
|
|
||||||
** Whitelisting & Execution
|
** Whitelisting & Execution
|
||||||
#+begin_src lisp :tangle ../projects/org-skill-shell-actuator/src/shell-logic.lisp
|
#+begin_src lisp :tangle ../src/shell-logic.lisp
|
||||||
(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"))
|
||||||
|
|
||||||
(defun execute-shell-safely (action context)
|
(defun execute-shell-safely (action context)
|
||||||
@@ -101,7 +101,7 @@ Interfaces for secure system calls. State is event-driven via the core kernel bu
|
|||||||
#+end_src
|
#+end_src
|
||||||
|
|
||||||
** Feedback Perception
|
** Feedback Perception
|
||||||
#+begin_src lisp :tangle ../projects/org-skill-shell-actuator/src/shell-logic.lisp
|
#+begin_src lisp :tangle ../src/shell-logic.lisp
|
||||||
(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)))
|
||||||
@@ -110,7 +110,7 @@ Interfaces for secure system calls. State is event-driven via the core kernel bu
|
|||||||
#+end_src
|
#+end_src
|
||||||
|
|
||||||
** Neuro-Cognitive Analysis
|
** Neuro-Cognitive Analysis
|
||||||
#+begin_src lisp :tangle ../projects/org-skill-shell-actuator/src/shell-logic.lisp
|
#+begin_src lisp :tangle ../src/shell-logic.lisp
|
||||||
(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))
|
||||||
|
|||||||
@@ -30,7 +30,7 @@ Maintain a state-aware provider cascade that routes around "pain" (failures) and
|
|||||||
** 2. Semantic Interfaces
|
** 2. Semantic Interfaces
|
||||||
|
|
||||||
*** Routing and Pain Management
|
*** Routing and Pain Management
|
||||||
#+begin_src lisp :tangle ../projects/org-skill-token-accountant/src/accountant-logic.lisp
|
#+begin_src lisp :tangle ../src/accountant-logic.lisp
|
||||||
(in-package :org-agent)
|
(in-package :org-agent)
|
||||||
|
|
||||||
(defvar *provider-pain-table* (make-hash-table :test 'equal))
|
(defvar *provider-pain-table* (make-hash-table :test 'equal))
|
||||||
|
|||||||
42
src/accountant-logic.lisp
Normal file
42
src/accountant-logic.lisp
Normal file
@@ -0,0 +1,42 @@
|
|||||||
|
(in-package :org-agent)
|
||||||
|
|
||||||
|
(defvar *provider-pain-table* (make-hash-table :test 'equal))
|
||||||
|
|
||||||
|
(defun token-accountant-record-pain (provider)
|
||||||
|
"Marks a provider as 'pained' (failed). It will be de-prioritized."
|
||||||
|
(setf (gethash provider *provider-pain-table*) (+ (get-universal-time) 600)) ; 10 min penalty
|
||||||
|
(kernel-log "ACCOUNTANT - Provider ~a de-prioritized due to failure." provider))
|
||||||
|
|
||||||
|
(defun token-accountant-get-cascade (context)
|
||||||
|
"Returns a dynamic list of providers, routing around pained ones. Uses standardized gateway keywords."
|
||||||
|
(let ((all-providers '(:openrouter :groq :gemini-api :ollama))
|
||||||
|
(healthy nil)
|
||||||
|
(pained nil)
|
||||||
|
(now (get-universal-time)))
|
||||||
|
(dolist (p all-providers)
|
||||||
|
(if (> (or (gethash p *provider-pain-table*) 0) now)
|
||||||
|
(push p pained)
|
||||||
|
(push p healthy)))
|
||||||
|
(append (nreverse healthy) (nreverse pained))))
|
||||||
|
|
||||||
|
(defun token-accountant-get-model-for-provider (provider &optional context)
|
||||||
|
"Returns the recommended model for the provider, prioritizing free/subsidized models. Updated April 2026."
|
||||||
|
(let ((complexity (ignore-errors (uiop:symbol-call :org-agent.skills.org-skill-router :router-classify-complexity context))))
|
||||||
|
(case provider
|
||||||
|
(:openrouter
|
||||||
|
(case complexity
|
||||||
|
(:REASONING "meta-llama/llama-3.3-70b-instruct:free") ; High fidelity, zero cost
|
||||||
|
(:COGNITION "qwen/qwen3.6-plus:free") ; Latest interaction, zero cost
|
||||||
|
(t "meta-llama/llama-3.2-3b-instruct:free"))) ; Ultra-fast reflex, zero cost
|
||||||
|
(:groq
|
||||||
|
(case complexity
|
||||||
|
(:REASONING "llama-3.3-70b-versatile")
|
||||||
|
(t "llama-3.1-8b-instant")))
|
||||||
|
(:gemini-api
|
||||||
|
"gemini-1.5-flash-latest")
|
||||||
|
(t nil))))
|
||||||
|
|
||||||
|
(defun token-accountant-patch-kernel ()
|
||||||
|
"Hot-patches the kernel's cascade and model selector to use our dynamic logic."
|
||||||
|
(setf org-agent:*provider-cascade* #'token-accountant-get-cascade)
|
||||||
|
(setf org-agent::*model-selector-fn* #'token-accountant-get-model-for-provider))
|
||||||
21
src/chaos-logic.lisp
Normal file
21
src/chaos-logic.lisp
Normal file
@@ -0,0 +1,21 @@
|
|||||||
|
(defun chaos-inject-error (sensor-type)
|
||||||
|
"Injects a synthetic error into a specific sensor pipeline."
|
||||||
|
(org-agent:kernel-log "CHAOS - Injecting synthetic error into ~a sensor..." sensor-type)
|
||||||
|
(org-agent:inject-stimulus
|
||||||
|
`(:type :EVENT :payload (:sensor ,sensor-type :error "SYNTHETIC_CHAOS_ERROR"))))
|
||||||
|
|
||||||
|
(defun chaos-stress-test (action context)
|
||||||
|
"Executes a randomized stress test by injecting failures into the system."
|
||||||
|
(declare (ignore context))
|
||||||
|
(let* ((payload (getf action :payload))
|
||||||
|
(mode (or (getf payload :mode) :random))
|
||||||
|
(intensity (or (getf payload :intensity) 3)))
|
||||||
|
(org-agent:kernel-log "CHAOS - Commencing stress test (Mode: ~a, Intensity: ~a)" mode intensity)
|
||||||
|
(case mode
|
||||||
|
(:random (dotimes (i intensity)
|
||||||
|
(let ((failure-type (nth (random 3) '(:test-failure :shell-timeout :llm-error))))
|
||||||
|
(org-agent:inject-stimulus
|
||||||
|
`(:type :EVENT :payload (:sensor :chaos-injection :type ,failure-type))))))
|
||||||
|
(:shell (org-agent:inject-stimulus
|
||||||
|
`(:type :EVENT :payload (:sensor :shell-response :cmd "git push" :exit-code 128 :stderr "fatal: network unreachable")))))
|
||||||
|
(format nil "SUCCESS - Chaos stress test initiated.")))
|
||||||
38
src/chat-logic.lisp
Normal file
38
src/chat-logic.lisp
Normal file
@@ -0,0 +1,38 @@
|
|||||||
|
(defun trigger-skill-chat (context)
|
||||||
|
(let* ((payload (getf context :payload))
|
||||||
|
(sensor (getf payload :sensor)))
|
||||||
|
(eq sensor :chat-message)))
|
||||||
|
|
||||||
|
(defun verify-skill-chat (proposed-action context)
|
||||||
|
(let* ((payload (getf proposed-action :payload))
|
||||||
|
(action (or (getf payload :action) (getf proposed-action :action)))
|
||||||
|
(target (getf proposed-action :target)))
|
||||||
|
(if (and (listp proposed-action)
|
||||||
|
(or (and (member (getf proposed-action :type) '(:request :REQUEST))
|
||||||
|
(or (and (member target '(:emacs :EMACS))
|
||||||
|
(member action '(:insert-at-end :INSERT-AT-END)))
|
||||||
|
(and (member target '(:shell :SHELL))
|
||||||
|
(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 "\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)
|
||||||
|
"Generates a conversational response, stripping system errors from context."
|
||||||
|
(let* ((payload (getf context :payload))
|
||||||
|
(raw-text (getf payload :text))
|
||||||
|
;; Context Purge: Remove system errors and hallucinations from the history
|
||||||
|
(clean-text (cl-ppcre:regex-replace-all "(?i)Unknown request|System Error.*|Thinking\\.\\.\\." raw-text ""))
|
||||||
|
(trimmed-text (if (> (length clean-text) 1000)
|
||||||
|
(subseq clean-text (- (length clean-text) 1000))
|
||||||
|
clean-text)))
|
||||||
|
(ask-neuro trimmed-text :system-prompt "ACTUATOR IDENTITY: You are the pure Lisp actuator for the org-agent kernel.
|
||||||
|
MANDATE: Output EXACTLY ONE Common Lisp property list starting with (:type :REQUEST).
|
||||||
|
ZERO CONVERSATION: Do not explain. Do not use markdown.
|
||||||
|
STRICT RULE: Never output the strings 'Unknown request' or 'System Error'.
|
||||||
|
|
||||||
|
REQUIRED FORMATS:
|
||||||
|
- To reply: (:type :REQUEST :target :emacs :action :insert-at-end :buffer \"*org-agent-chat*\" :text \"* <Response>\")
|
||||||
|
- To use a tool: (:type :REQUEST :target :tool :action :call :tool \"<name>\" :args (...))")))
|
||||||
22
src/config-logic.lisp
Normal file
22
src/config-logic.lisp
Normal file
@@ -0,0 +1,22 @@
|
|||||||
|
(in-package :org-agent)
|
||||||
|
|
||||||
|
(defun set-llm-model (provider model-id)
|
||||||
|
"Registers a preferred model for a provider in the Object Store."
|
||||||
|
(let ((config-id (format nil "config-llm-~a" (string-downcase (string provider)))))
|
||||||
|
(let ((obj (make-org-object
|
||||||
|
:id config-id
|
||||||
|
:type :CONFIG
|
||||||
|
:attributes `(:provider ,provider :model-id ,model-id)
|
||||||
|
:content (format nil "Fleet preference for ~a set to ~a" provider model-id)
|
||||||
|
:version (get-universal-time))))
|
||||||
|
(setf (gethash config-id *object-store*) obj)
|
||||||
|
(kernel-log "CONFIG - Fleet updated: ~a -> ~a" provider model-id)
|
||||||
|
t)))
|
||||||
|
|
||||||
|
(defun get-llm-model (provider &optional default)
|
||||||
|
"Retrieves the preferred model for a provider from the Object Store."
|
||||||
|
(let* ((config-id (format nil "config-llm-~a" (string-downcase (string provider))))
|
||||||
|
(obj (gethash config-id *object-store*)))
|
||||||
|
(if obj
|
||||||
|
(getf (org-object-attributes obj) :model-id)
|
||||||
|
default)))
|
||||||
9
src/consensus-logic.lisp
Normal file
9
src/consensus-logic.lisp
Normal file
@@ -0,0 +1,9 @@
|
|||||||
|
(defun consensus-propose-vote (proposal)
|
||||||
|
"Broadcasts a proposal to the peer swarm and collects votes.
|
||||||
|
Implements PSF Social Consensus Protocol."
|
||||||
|
(let* ((peers (get-swarm-peer-list))
|
||||||
|
(votes (loop for peer in peers
|
||||||
|
collect (org-agent:send-swarm-packet peer `(:type :REQUEST :action :vote :proposal ,proposal)))))
|
||||||
|
(if (> (count :YES votes) (/ (length peers) 2))
|
||||||
|
t ; Consensus reached
|
||||||
|
nil)))
|
||||||
53
src/credentials-vault.lisp
Normal file
53
src/credentials-vault.lisp
Normal file
@@ -0,0 +1,53 @@
|
|||||||
|
(in-package :org-agent)
|
||||||
|
|
||||||
|
(defvar *vault-memory* (make-hash-table :test 'equal)
|
||||||
|
"In-memory cache of sensitive credentials.")
|
||||||
|
|
||||||
|
(defun vault-mask-string (str)
|
||||||
|
"Returns a masked version of a sensitive string."
|
||||||
|
(if (and str (> (length str) 8))
|
||||||
|
(format nil "~a...~a" (subseq str 0 4) (subseq str (- (length str) 4)))
|
||||||
|
"[REDACTED]"))
|
||||||
|
|
||||||
|
(defun vault-get-secret (provider &key (type :api-key))
|
||||||
|
"Retrieves a credential. Type can be :api-key or :session."
|
||||||
|
(let* ((key (format nil "~a-~a" provider type))
|
||||||
|
(val (gethash key *vault-memory*)))
|
||||||
|
(if val
|
||||||
|
val
|
||||||
|
;; Fallback to environment
|
||||||
|
(let ((env-var (case provider
|
||||||
|
(:gemini "GEMINI_API_KEY")
|
||||||
|
(:openai "OPENAI_API_KEY")
|
||||||
|
(:anthropic "ANTHROPIC_API_KEY")
|
||||||
|
(:groq "GROQ_API_KEY")
|
||||||
|
(:openrouter "OPENROUTER_API_KEY")
|
||||||
|
(t nil))))
|
||||||
|
(when (and env-var (eq type :api-key))
|
||||||
|
(uiop:getenv env-var))))))
|
||||||
|
|
||||||
|
(defun vault-set-secret (provider secret &key (type :api-key))
|
||||||
|
"Securely stores a secret and triggers a Merkle snapshot."
|
||||||
|
(let ((key (format nil "~a-~a" provider type)))
|
||||||
|
(setf (gethash key *vault-memory*) secret)
|
||||||
|
(kernel-log "VAULT - Updated ~a for ~a. Triggering Merkle snapshot..." type provider)
|
||||||
|
(snapshot-object-store)
|
||||||
|
t))
|
||||||
|
|
||||||
|
(defun vault-onboard-gemini-web ()
|
||||||
|
"Instructions for the Sovereign Cookie Handshake."
|
||||||
|
(kernel-log "--- GEMINI WEB ONBOARDING ---")
|
||||||
|
(kernel-log "1. Visit gemini.google.com")
|
||||||
|
(kernel-log "2. Run the 'Get Gemini Cookies' Bookmarklet.")
|
||||||
|
(kernel-log " CODE: javascript:(function(){const c=document.cookie.split('; ').reduce((r,v)=>{const [n,val]=v.split('=');r[n]=val;return r},{});const target=['__Secure-1PSID','__Secure-1PSIDTS'];const out=target.map(n=>({name:n,value:c[n]}));prompt('Copy JSON:',JSON.stringify(out));})();")
|
||||||
|
(kernel-log "PLATFORM GUIDE: Chrome/Firefox/Safari all support Bookmarklets via 'Add Page' or 'New Bookmark'.")
|
||||||
|
t)
|
||||||
|
|
||||||
|
(progn
|
||||||
|
(defskill :skill-credentials-vault
|
||||||
|
:priority 200 ; High priority, foundational
|
||||||
|
:trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :onboarding-request))
|
||||||
|
:neuro nil
|
||||||
|
:symbolic (lambda (action ctx)
|
||||||
|
(vault-onboard-gemini-web)
|
||||||
|
action)))
|
||||||
56
src/homoiconic-memory.lisp
Normal file
56
src/homoiconic-memory.lisp
Normal file
@@ -0,0 +1,56 @@
|
|||||||
|
(in-package :org-agent)
|
||||||
|
|
||||||
|
(defun make-memory-node (headline &key content properties children)
|
||||||
|
"Constructor for a normalized Org node alist."
|
||||||
|
(list :type :HEADLINE
|
||||||
|
:properties (or properties nil)
|
||||||
|
:content content
|
||||||
|
:contents children))
|
||||||
|
|
||||||
|
(defun memory-ensure-id (node)
|
||||||
|
"Injects a unique ID into an Org node if missing, using the standard org-id-get-create mechanism."
|
||||||
|
(let* ((props (getf node :properties))
|
||||||
|
(id (getf props :ID)))
|
||||||
|
(if (and id (not (equal id "")))
|
||||||
|
node
|
||||||
|
(let ((new-id (org-agent:org-id-get-create)))
|
||||||
|
(setf (getf node :properties) (append props (list :ID new-id)))
|
||||||
|
(kernel-log "MEMORY - Injected standard ID ~a" new-id)
|
||||||
|
node))))
|
||||||
|
|
||||||
|
(defun memory-normalize-ast (ast)
|
||||||
|
"Recursively normalizes an Org AST."
|
||||||
|
(let ((type (getf ast :type))
|
||||||
|
(contents (getf ast :contents)))
|
||||||
|
(when (eq type :HEADLINE)
|
||||||
|
(setf ast (memory-ensure-id ast)))
|
||||||
|
(when contents
|
||||||
|
(setf (getf ast :contents)
|
||||||
|
(mapcar (lambda (child)
|
||||||
|
(if (listp child)
|
||||||
|
(memory-normalize-ast child)
|
||||||
|
child))
|
||||||
|
contents)))
|
||||||
|
ast))
|
||||||
|
|
||||||
|
(defun memory-org-to-json (source-path)
|
||||||
|
"Routes to the Emacs-based Org-JSON bridge."
|
||||||
|
;; Future implementation will use the org-json-convert CLI tool
|
||||||
|
(kernel-log "MEMORY - Parsing ~a to JSON..." source-path)
|
||||||
|
nil)
|
||||||
|
|
||||||
|
(defun memory-json-to-org (ast)
|
||||||
|
"Materializes a JSON AST into Org-mode text."
|
||||||
|
;; Placeholder for org-element-interpret-data equivalent
|
||||||
|
(kernel-log "MEMORY - Rendering AST to text...")
|
||||||
|
"")
|
||||||
|
|
||||||
|
(progn
|
||||||
|
(defskill :skill-homoiconic-memory
|
||||||
|
:priority 300 ; Core foundational skill
|
||||||
|
:trigger (lambda (ctx) (member (getf (getf ctx :payload) :sensor) '(:buffer-save :ingest)))
|
||||||
|
:neuro nil
|
||||||
|
:symbolic (lambda (action ctx)
|
||||||
|
(let ((ast (getf (getf ctx :payload) :ast)))
|
||||||
|
(when ast (memory-normalize-ast ast))
|
||||||
|
action))))
|
||||||
64
src/latent-reflection.lisp
Normal file
64
src/latent-reflection.lisp
Normal file
@@ -0,0 +1,64 @@
|
|||||||
|
(in-package :org-agent)
|
||||||
|
|
||||||
|
(defvar *last-reflection-time* 0)
|
||||||
|
(defvar *reflection-interval* 14400) ;; 4 hours by default
|
||||||
|
|
||||||
|
(defun sample-random-memories (count)
|
||||||
|
"Returns COUNT random objects from the object-store."
|
||||||
|
(let ((keys nil)
|
||||||
|
(selected nil))
|
||||||
|
(maphash (lambda (k v) (declare (ignore v)) (push k keys)) *object-store*)
|
||||||
|
(let ((len (length keys)))
|
||||||
|
(when (> len 0)
|
||||||
|
(dotimes (i count)
|
||||||
|
(let* ((random-key (nth (random len) keys))
|
||||||
|
(obj (gethash random-key *object-store*)))
|
||||||
|
(when obj
|
||||||
|
(push obj selected))))))
|
||||||
|
selected))
|
||||||
|
|
||||||
|
(def-cognitive-tool :trigger-latent-reflection "Manually triggers a proactive gardening cycle."
|
||||||
|
:parameters nil
|
||||||
|
:body (lambda (args)
|
||||||
|
(declare (ignore args))
|
||||||
|
(setf *last-reflection-time* 0)
|
||||||
|
"Latent reflection triggered. Wait for the next heartbeat."))
|
||||||
|
|
||||||
|
(defskill :skill-latent-reflection
|
||||||
|
:priority 30
|
||||||
|
:trigger (lambda (ctx)
|
||||||
|
(let* ((payload (getf ctx :payload))
|
||||||
|
(sensor (getf payload :sensor))
|
||||||
|
(now (get-universal-time)))
|
||||||
|
(if (and (eq sensor :heartbeat)
|
||||||
|
(> (- now *last-reflection-time*) *reflection-interval*))
|
||||||
|
(progn
|
||||||
|
(kernel-log "GARDENER - Initiating Latent Reflection...")
|
||||||
|
(setf *last-reflection-time* now)
|
||||||
|
t)
|
||||||
|
nil)))
|
||||||
|
:neuro (lambda (ctx)
|
||||||
|
(declare (ignore ctx))
|
||||||
|
(let* ((memories (sample-random-memories 3))
|
||||||
|
(context-string "LATENT REFLECTION CANDIDATES:\n"))
|
||||||
|
(dolist (m memories)
|
||||||
|
(let ((title (or (getf (org-object-attributes m) :TITLE) "Untitled"))
|
||||||
|
(content (or (org-object-content m) "")))
|
||||||
|
(setf context-string
|
||||||
|
(concatenate 'string context-string
|
||||||
|
(format nil "- ID: ~a | TITLE: ~a | CONTENT: ~a~%"
|
||||||
|
(org-object-id m) title content)))))
|
||||||
|
(format nil "You are the Proactive Gardener of the Memex.
|
||||||
|
I have selected 3 random notes from the knowledge graph.
|
||||||
|
Please read them and synthesize a 'Latent Reflection'.
|
||||||
|
Find hidden connections, suggest new tags, or propose a new insight that bridges them.
|
||||||
|
|
||||||
|
~a
|
||||||
|
|
||||||
|
MANDATE: Output EXACTLY ONE Common Lisp property list starting with (:type :REQUEST).
|
||||||
|
Use the :emacs target and :insert-at-end action to write your reflection into the \"*org-agent-chat*\" buffer."
|
||||||
|
context-string)))
|
||||||
|
:symbolic (lambda (action ctx)
|
||||||
|
(declare (ignore ctx))
|
||||||
|
;; Approve any safe request
|
||||||
|
action))
|
||||||
77
src/llm-gateway.lisp
Normal file
77
src/llm-gateway.lisp
Normal file
@@ -0,0 +1,77 @@
|
|||||||
|
(in-package :org-agent)
|
||||||
|
|
||||||
|
(defun execute-llm-request (prompt system-prompt &key provider model)
|
||||||
|
"Unified entry point for all LLM providers."
|
||||||
|
(let ((api-key (vault-get-secret provider :type :api-key))
|
||||||
|
(full-prompt (format nil "~a~%~%Prompt: ~a" system-prompt prompt)))
|
||||||
|
|
||||||
|
(kernel-log "SYSTEM 1: Requesting ~a (Model: ~a) [Key: ~a]"
|
||||||
|
provider (or model "default") (vault-mask-string api-key))
|
||||||
|
|
||||||
|
(case provider
|
||||||
|
...
|
||||||
|
(:gemini-web
|
||||||
|
(let ((res (uiop:symbol-call :org-agent.skills.org-skill-web-research :ask-gemini-web full-prompt)))
|
||||||
|
(if res (list :status :success :content res) (list :status :error :message "Web Research Failure"))))
|
||||||
|
|
||||||
|
(:ollama
|
||||||
|
(let* ((host (or (uiop:getenv "OLLAMA_HOST") "localhost:11434"))
|
||||||
|
(url (format nil "http://~a/api/generate" host))
|
||||||
|
(body (cl-json:encode-json-to-string `((model . ,(or model "llama3")) (prompt . ,full-prompt) (stream . :false)))))
|
||||||
|
(handler-case
|
||||||
|
(let* ((response (dex:post url :headers '(("Content-Type" . "application/json")) :content body :connect-timeout 5 :read-timeout 60))
|
||||||
|
(json (cl-json:decode-json-from-string response)))
|
||||||
|
(list :status :success :content (cdr (assoc :response json))))
|
||||||
|
(error (c) (list :status :error :message (format nil "Ollama Failure: ~a" c))))))
|
||||||
|
|
||||||
|
(t ;; Cloud Providers (Anthropic, Gemini API, Groq, OpenAI, OpenRouter)
|
||||||
|
(unless api-key (return-from execute-llm-request (list :status :error :message (format nil "API Key missing for ~a" provider))))
|
||||||
|
(let* ((endpoint (case provider
|
||||||
|
(:anthropic "https://api.anthropic.com/v1/messages")
|
||||||
|
(:gemini-api (format nil "https://generativelanguage.googleapis.com/v1/models/~a:generateContent" (or model "gemini-1.5-flash-latest")))
|
||||||
|
(:groq "https://api.groq.com/openai/v1/chat/completions")
|
||||||
|
(:openai "https://api.openai.com/v1/chat/completions")
|
||||||
|
(:openrouter "https://openrouter.ai/api/v1/chat/completions")))
|
||||||
|
(headers (case provider
|
||||||
|
(:anthropic `(("Content-Type" . "application/json") ("x-api-key" . ,api-key) ("anthropic-version" . "2023-06-01")))
|
||||||
|
(:gemini-api `(("Content-Type" . "application/json") ("x-goog-api-key" . ,api-key)))
|
||||||
|
(:openrouter `(("Content-Type" . "application/json") ("Authorization" . ,(format nil "Bearer ~a" api-key))
|
||||||
|
("HTTP-Referer" . "https://github.com/amr/org-agent") ("X-Title" . "org-agent Sovereign Kernel")))
|
||||||
|
(t `(("Content-Type" . "application/json") ("Authorization" . ,(format nil "Bearer ~a" api-key))))))
|
||||||
|
(body (case provider
|
||||||
|
(:anthropic (cl-json:encode-json-to-string `((model . ,(or model "claude-3-5-sonnet-20240620")) (max_tokens . 4096) (system . ,system-prompt) (messages . (( (role . "user") (content . ,prompt) ))))))
|
||||||
|
(:gemini-api (cl-json:encode-json-to-string `((contents . ((parts . ((text . ,full-prompt))))))))
|
||||||
|
(t (cl-json:encode-json-to-string `((model . ,(or model (case provider (:groq "llama-3.3-70b-versatile") (:openai "gpt-4o") (t "openrouter/auto"))))
|
||||||
|
(messages . (( (role . "system") (content . ,system-prompt) ) ( (role . "user") (content . ,prompt) )))))))))
|
||||||
|
(handler-case
|
||||||
|
(let* ((response (dex:post endpoint :headers headers :content body :connect-timeout 10 :read-timeout 30))
|
||||||
|
(json (cl-json:decode-json-from-string response)))
|
||||||
|
(list :status :success :content
|
||||||
|
(case provider
|
||||||
|
(:anthropic (cdr (assoc :text (car (cdr (assoc :content json))))))
|
||||||
|
(:gemini-api (cdr (assoc :text (cdr (assoc :parts (car (cdr (assoc :parts (car (cdr (assoc :candidates json)))))))))))
|
||||||
|
(t (cdr (assoc :content (cdr (assoc :message (car (cdr (assoc :choices json)))))))))))
|
||||||
|
(error (c) (list :status :error :message (format nil "LLM Gateway Failure (~a): ~a" provider c)))))))))
|
||||||
|
|
||||||
|
(def-cognitive-tool :ask-llm "Queries an LLM provider via the unified gateway."
|
||||||
|
:parameters ((:prompt :type :string :description "The user prompt.")
|
||||||
|
(:system-prompt :type :string :description "The system instructions.")
|
||||||
|
(:provider :type :keyword :description "The provider (e.g., :gemini-api, :anthropic, :groq, :openai, :openrouter, :ollama, :gemini-web).")
|
||||||
|
(:model :type :string :description "Optional specific model ID."))
|
||||||
|
:body (lambda (args)
|
||||||
|
(execute-llm-request (getf args :prompt)
|
||||||
|
(or (getf args :system-prompt) "You are a helpful assistant.")
|
||||||
|
:provider (getf args :provider)
|
||||||
|
:model (getf args :model))))
|
||||||
|
|
||||||
|
(progn
|
||||||
|
;; Register all supported backends with the kernel
|
||||||
|
(dolist (p '(:anthropic :gemini-api :gemini-web :groq :ollama :openai :openrouter))
|
||||||
|
(org-agent:register-neuro-backend p (lambda (prompt system-prompt &key model)
|
||||||
|
(execute-llm-request prompt system-prompt :provider p :model model))))
|
||||||
|
|
||||||
|
(defskill :skill-llm-gateway
|
||||||
|
:priority 150 ; Higher than individual old skills
|
||||||
|
:trigger (lambda (context) nil)
|
||||||
|
:neuro (lambda (context) nil)
|
||||||
|
:symbolic (lambda (action context) action)))
|
||||||
@@ -3,7 +3,9 @@
|
|||||||
(defun get-env (var &optional default) (or (uiop:getenv var) default))
|
(defun get-env (var &optional default) (or (uiop:getenv var) default))
|
||||||
|
|
||||||
(defvar *auth-providers* (make-hash-table :test 'equal))
|
(defvar *auth-providers* (make-hash-table :test 'equal))
|
||||||
|
|
||||||
(defun register-auth-provider (name fn) (setf (gethash name *auth-providers*) fn))
|
(defun register-auth-provider (name fn) (setf (gethash name *auth-providers*) fn))
|
||||||
|
|
||||||
(defun get-provider-auth (provider)
|
(defun get-provider-auth (provider)
|
||||||
"Retrieves authentication credentials for a provider."
|
"Retrieves authentication credentials for a provider."
|
||||||
(let ((auth (gethash provider *auth-providers*)))
|
(let ((auth (gethash provider *auth-providers*)))
|
||||||
@@ -25,6 +27,7 @@
|
|||||||
|
|
||||||
(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))
|
||||||
|
|
||||||
(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.")
|
||||||
@@ -43,19 +46,17 @@
|
|||||||
(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))))
|
||||||
(cond
|
(if (and (stringp result) (search ":LOG" result) (or (search "Failure" result) (search "missing" result)))
|
||||||
((listp result)
|
(kernel-log "SYSTEM 1: Backend ~a failed. Falling back..." backend)
|
||||||
(if (eq (getf result :status) :success)
|
(return-from ask-neuro result))))))
|
||||||
(return-from ask-neuro (getf result :content))
|
|
||||||
(kernel-log "SYSTEM 1: Backend ~a failed: ~a" backend (getf result :message))))
|
|
||||||
((and (stringp result) (search ":LOG" result) (or (search "Failure" result) (search "missing" result)))
|
|
||||||
(kernel-log "SYSTEM 1: Backend ~a failed. Falling back..." backend))
|
|
||||||
(t (return-from ask-neuro result))))))
|
|
||||||
"(:type :LOG :payload (:text \"Neural Cascade Failure\"))"))
|
"(:type :LOG :payload (:text \"Neural Cascade Failure\"))"))
|
||||||
|
|
||||||
;; --- Sovereign Service Fallbacks ---
|
|
||||||
|
|
||||||
(defun token-accountant-route-task (context)
|
(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 System 1 engine to propose a Lisp action based on context."
|
"Invokes the neural System 1 engine to propose a Lisp action based on context."
|
||||||
(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))
|
||||||
|
|||||||
30
src/processor-logic.lisp
Normal file
30
src/processor-logic.lisp
Normal file
@@ -0,0 +1,30 @@
|
|||||||
|
(defun inbox-is-private-p (tags)
|
||||||
|
(member "@personal" tags :test #'string-equal))
|
||||||
|
|
||||||
|
(defun inbox-is-archive-p (tags)
|
||||||
|
(member "!archive" tags :test #'string-equal))
|
||||||
|
|
||||||
|
(defun neuro-skill-inbox-processor (context)
|
||||||
|
(let* ((payload (getf context :payload))
|
||||||
|
(content (getf payload :content))
|
||||||
|
(tags (getf payload :tags))
|
||||||
|
(is-archive (inbox-is-archive-p tags)))
|
||||||
|
(ask-neuro content :system-prompt
|
||||||
|
(format nil "You are the PSF Librarian. Your goal is to ENRICH this Org-mode capture.
|
||||||
|
RULES:
|
||||||
|
1. Create a '** Summary' sub-heading with a 1-sentence summary.
|
||||||
|
2. Create a '** Significance' sub-heading with a paragraph explaining why this matters to a Sovereign Lisp Machine and how it can be used.
|
||||||
|
3. ~:[~;~* ARCHIVE MODE: Extract the full text of the item into a '** Full Text' sub-heading, preserving Org-mode structure.~]
|
||||||
|
4. Return ONLY a Lisp plist with :summary :significance :full-text.
|
||||||
|
5. NO conversational filler." is-archive))))
|
||||||
|
|
||||||
|
(defun inbox-process-logic (action context)
|
||||||
|
(declare (ignore action))
|
||||||
|
(let* ((payload (getf context :payload))
|
||||||
|
(sensor (getf payload :sensor)))
|
||||||
|
(when (eq sensor :heartbeat)
|
||||||
|
(let* ((base-dir (or (uiop:getenv "MEMEX_DIR") "/home/user/memex/"))
|
||||||
|
(inbox-path (merge-pathnames "inbox.org" base-dir)))
|
||||||
|
(org-agent:kernel-log "INBOX - Scanning ~a for migration..." (uiop:native-namestring inbox-path))
|
||||||
|
;; Physical move logic would go here using Org AST parsing
|
||||||
|
'(:target :system :payload (:action :message :text "Inbox processing complete (Simulation)."))))))
|
||||||
19
src/router-logic.lisp
Normal file
19
src/router-logic.lisp
Normal file
@@ -0,0 +1,19 @@
|
|||||||
|
(in-package :org-agent)
|
||||||
|
|
||||||
|
(defun router-classify-complexity (context)
|
||||||
|
"Returns the complexity tier for a given stimulus context."
|
||||||
|
(let* ((payload (getf context :payload))
|
||||||
|
(sensor (getf payload :sensor))
|
||||||
|
(skill (find-triggered-skill context))
|
||||||
|
(skill-name (when skill (skill-name skill))))
|
||||||
|
(cond
|
||||||
|
;; reasoning: generative or architectural
|
||||||
|
((member skill-name '("skill-architect" "skill-tech-analyst" "skill-scientist" "skill-self-fix") :test #'string-equal) :REASONING)
|
||||||
|
((member sensor '(:user-command)) :REASONING)
|
||||||
|
|
||||||
|
;; cognition: human interaction or semantic data
|
||||||
|
((member sensor '(:chat-message :delegation)) :COGNITION)
|
||||||
|
((member skill-name '("skill-scribe" "skill-web-research") :test #'string-equal) :COGNITION)
|
||||||
|
|
||||||
|
;; reflex: system infrastructure
|
||||||
|
(t :REFLEX))))
|
||||||
@@ -40,43 +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))
|
||||||
|
|
||||||
(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 must be in the whitelist
|
|
||||||
((symbolp form)
|
|
||||||
(if (member form *safety-whitelist* :test #'string-equal)
|
|
||||||
t
|
|
||||||
t)) ;; We allow symbols as potential variables
|
|
||||||
;; Lists represent function calls or special forms.
|
|
||||||
((listp form)
|
|
||||||
(let ((head (car form)))
|
|
||||||
(cond
|
|
||||||
((eq head 'quote) t)
|
|
||||||
((not (symbolp head)) nil)
|
|
||||||
((member head *safety-whitelist* :test #'string-equal)
|
|
||||||
(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-string)
|
|
||||||
"Parses a code string and validates it against the safety harness."
|
|
||||||
(handler-case
|
|
||||||
(let* ((*read-eval* nil)
|
|
||||||
(form (read-from-string code-string)))
|
|
||||||
(safety-harness-ast-walk form))
|
|
||||||
(error (c)
|
|
||||||
(kernel-log "SAFETY HARNESS ERROR: Syntax or read error during validation: ~a" c)
|
|
||||||
nil)))
|
|
||||||
|
|
||||||
(defskill :skill-safety-harness
|
|
||||||
:priority 90
|
|
||||||
:trigger (lambda (ctx) nil)
|
|
||||||
:neuro nil
|
|
||||||
:symbolic nil)
|
|
||||||
|
|||||||
73
src/shell-logic.lisp
Normal file
73
src/shell-logic.lisp
Normal file
@@ -0,0 +1,73 @@
|
|||||||
|
(defparameter *allowed-commands* '("ls" "git" "rg" "grep" "date" "echo" "cat" "node" "python3" "sbcl"))
|
||||||
|
|
||||||
|
(defun execute-shell-safely (action context)
|
||||||
|
(let* ((cmd-string (getf (getf action :payload) :cmd))
|
||||||
|
(executable (car (uiop:split-string cmd-string :separator '(#\Space)))))
|
||||||
|
(if (member executable *allowed-commands* :test #'string=)
|
||||||
|
(multiple-value-bind (stdout stderr exit-code)
|
||||||
|
(uiop:run-program cmd-string :output :string :error-output :string :ignore-error-status t)
|
||||||
|
(org-agent:inject-stimulus
|
||||||
|
`(:type :EVENT :payload (:sensor :shell-response :cmd ,cmd-string :stdout ,(or stdout "") :stderr ,(or stderr "") :exit-code ,exit-code))
|
||||||
|
:stream (getf context :reply-stream)))
|
||||||
|
(org-agent:inject-stimulus
|
||||||
|
`(:type :EVENT :payload (:sensor :shell-response :cmd ,cmd-string :stdout "" :stderr "ERROR - Command not in security whitelist." :exit-code 1))
|
||||||
|
:stream (getf context :reply-stream)))))
|
||||||
|
|
||||||
|
(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."
|
||||||
|
(let* ((payload (getf action :payload))
|
||||||
|
(language (getf payload :language))
|
||||||
|
(content (getf payload :content))
|
||||||
|
(sandbox-dir "/tmp/org-agent-sandbox/")
|
||||||
|
(filename (format nil "synth-~a.~a" (get-universal-time) (case language (:python "py") (:lisp "lisp") (:js "js") (t "txt"))))
|
||||||
|
(full-path (format nil "~a~a" sandbox-dir filename)))
|
||||||
|
|
||||||
|
(ensure-directories-exist sandbox-dir)
|
||||||
|
(with-open-file (out full-path :direction :output :if-exists :supersede)
|
||||||
|
(write-string content out))
|
||||||
|
|
||||||
|
(let ((cmd (case language
|
||||||
|
(:python (format nil "python3 ~a" full-path))
|
||||||
|
(:lisp (format nil "sbcl --script ~a" full-path))
|
||||||
|
(:js (format nil "node ~a" full-path)))))
|
||||||
|
(multiple-value-bind (stdout stderr exit-code)
|
||||||
|
(uiop:run-program cmd :output :string :error-output :string :ignore-error-status t)
|
||||||
|
(org-agent:inject-stimulus
|
||||||
|
`(: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))))))
|
||||||
|
|
||||||
|
(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."
|
||||||
|
(kernel-log "SECURITY [Hardware] - Provisioning MicroVM ~a (CPU: ~a, RAM: ~aMB)..." id cpu ram)
|
||||||
|
;; Future implementation: Wraps 'fcvm' or 'firecracker' CLI calls.
|
||||||
|
(format nil "vm-~a-provisioned" id))
|
||||||
|
|
||||||
|
(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))))))
|
||||||
@@ -1,40 +0,0 @@
|
|||||||
(defun think (context)
|
|
||||||
(let ((active-skill (find-triggered-skill context))
|
|
||||||
(tool-belt (generate-tool-belt-prompt)))
|
|
||||||
(if active-skill
|
|
||||||
(progn
|
|
||||||
(kernel-log "SYSTEM 1: Engaging skill '~a'~%" (skill-name active-skill))
|
|
||||||
(let* ((prompt-generator (skill-neuro-prompt active-skill))
|
|
||||||
(raw-prompt (when prompt-generator (funcall prompt-generator context)))
|
|
||||||
(full-system-prompt (concatenate 'string
|
|
||||||
"ACTUATOR IDENTITY: You are the pure Lisp actuator for the org-agent kernel.
|
|
||||||
MANDATE: Output EXACTLY ONE Common Lisp property list starting with (:type :REQUEST).
|
|
||||||
ZERO CONVERSATION: Do not explain. Do not say 'Okay'. Do not use markdown blocks.
|
|
||||||
|
|
||||||
"
|
|
||||||
tool-belt
|
|
||||||
"
|
|
||||||
IMPORTANT: To reply to the user, you MUST use:
|
|
||||||
(:type :REQUEST :target :emacs :payload (:action :insert-at-end :buffer \"*org-agent-chat*\" :text \"* <Response Text>\"))
|
|
||||||
|
|
||||||
To call a tool, you MUST use:
|
|
||||||
(:type :REQUEST :target :tool :payload (:action :call :tool \"<name>\" :args (:arg1 \"val\")))
|
|
||||||
")))
|
|
||||||
(if (and raw-prompt (> (length raw-prompt) 0))
|
|
||||||
(let* ((thought (ask-neuro raw-prompt :system-prompt full-system-prompt :context context)))
|
|
||||||
(kernel-log "SYSTEM 1 RAW: ~a~%" thought)
|
|
||||||
(let* ((cleaned-thought
|
|
||||||
(let ((match (cl-ppcre:scan-to-strings "(?s)```(?:lisp)?\\n?(.*?)\\n?```" thought)))
|
|
||||||
(if match
|
|
||||||
(let ((regs (nth-value 1 (cl-ppcre:scan-to-strings "(?s)```(?:lisp)?\\n?(.*?)\\n?```" thought))))
|
|
||||||
(if (and regs (> (length regs) 0)) (elt regs 0) thought))
|
|
||||||
(string-trim '(#\Space #\Newline #\Tab) thought))))
|
|
||||||
(suggestion (ignore-errors (read-from-string cleaned-thought))))
|
|
||||||
(kernel-log "SYSTEM 1 Suggestion: ~a~%" cleaned-thought)
|
|
||||||
(cond
|
|
||||||
((and suggestion (listp suggestion)) suggestion)
|
|
||||||
(t
|
|
||||||
(kernel-log "SYSTEM 1 ERROR: Invalid output format from LLM.~%")
|
|
||||||
nil))))
|
|
||||||
'(:type :LOG :payload (:text "Skill triggered (Deterministic only)")))))
|
|
||||||
nil)))
|
|
||||||
17
src/verification-logic.lisp
Normal file
17
src/verification-logic.lisp
Normal file
@@ -0,0 +1,17 @@
|
|||||||
|
(defparameter *security-invariants*
|
||||||
|
'((:name "Path-Safety" :formula "(assert (forall ((p String)) (=> (is-write-op p) (str.prefixof \"/home/user/memex\" p))))")))
|
||||||
|
|
||||||
|
(defun verify-action-logic (action)
|
||||||
|
"Translates ACTION into an SMT-LIB query and invokes Z3 to prove safety.
|
||||||
|
This is the SOTA upgrade from simple whitelisting."
|
||||||
|
(let* ((payload (getf action :payload))
|
||||||
|
(cmd (getf payload :cmd))
|
||||||
|
;; Mock translation for demonstration of the formal gate
|
||||||
|
(smt-query (format nil "(declare-fun cmd () String) (assert (= cmd \"~a\")) ~{~a~%~} (check-sat)"
|
||||||
|
cmd (mapcar (lambda (i) (getf i :formula)) *security-invariants*))))
|
||||||
|
|
||||||
|
(kernel-log "SYMBOLIC [Formal] - Verifying logic formula...")
|
||||||
|
;; In a full implementation, we'd pipe smt-query to 'z3 -smt2'
|
||||||
|
(if (search "rm -rf" cmd) ; Example of a failing proof
|
||||||
|
nil
|
||||||
|
t)))
|
||||||
18
tests/llm-gateway-tests.lisp
Normal file
18
tests/llm-gateway-tests.lisp
Normal file
@@ -0,0 +1,18 @@
|
|||||||
|
(defpackage :org-agent-llm-gateway-tests
|
||||||
|
(:use :cl :fiveam :org-agent))
|
||||||
|
(in-package :org-agent-llm-gateway-tests)
|
||||||
|
|
||||||
|
(def-suite llm-gateway-suite :description "Tests for the Unified LLM Gateway.")
|
||||||
|
(in-suite llm-gateway-suite)
|
||||||
|
|
||||||
|
(test test-credential-retrieval
|
||||||
|
"Ensure credentials are retrieved from the correct environment variables."
|
||||||
|
(uiop:setenv "ANTHROPIC_API_KEY" "sk-test-key")
|
||||||
|
(is (equal "sk-test-key" (org-agent::get-llm-credentials :anthropic)))
|
||||||
|
(uiop:setenv "ANTHROPIC_API_KEY" ""))
|
||||||
|
|
||||||
|
(test test-error-handling-missing-key
|
||||||
|
"Ensure missing keys return a standardized error plist."
|
||||||
|
(let ((res (org-agent:execute-llm-request "test" "sys" :provider :openai)))
|
||||||
|
(is (eq (getf res :status) :error))
|
||||||
|
(is (search "API Key missing" (getf res :message)))))
|
||||||
11
tests/memory-suite-tests.lisp
Normal file
11
tests/memory-suite-tests.lisp
Normal file
@@ -0,0 +1,11 @@
|
|||||||
|
(defpackage :org-agent-memory-tests
|
||||||
|
(:use :cl :fiveam :org-agent))
|
||||||
|
(in-package :org-agent-memory-tests)
|
||||||
|
|
||||||
|
(def-suite memory-suite :description "Tests for Homoiconic Memory.")
|
||||||
|
(in-suite memory-suite)
|
||||||
|
|
||||||
|
(test test-id-injection
|
||||||
|
(let* ((node (list :type :HEADLINE :properties nil))
|
||||||
|
(normalized (org-agent::memory-ensure-id node)))
|
||||||
|
(is (not (null (getf (getf normalized :properties) :ID))))))
|
||||||
16
tests/vault-tests.lisp
Normal file
16
tests/vault-tests.lisp
Normal file
@@ -0,0 +1,16 @@
|
|||||||
|
(defpackage :org-agent-vault-tests
|
||||||
|
(:use :cl :fiveam :org-agent))
|
||||||
|
(in-package :org-agent-vault-tests)
|
||||||
|
|
||||||
|
(def-suite vault-suite :description "Tests for the Credentials Vault.")
|
||||||
|
(in-suite vault-suite)
|
||||||
|
|
||||||
|
(test test-masking
|
||||||
|
(is (equal "sk-t...-key" (org-agent::vault-mask-string "sk-test-key")))
|
||||||
|
(is (equal "[REDACTED]" (org-agent::vault-mask-string "short"))))
|
||||||
|
|
||||||
|
(test test-vault-persistence
|
||||||
|
"Verify that setting a secret triggers a snapshot (mock check)."
|
||||||
|
(let ((old-version (org-agent::org-object-version (gethash "root" *object-store*))))
|
||||||
|
(org-agent:vault-set-secret :test "secret-val")
|
||||||
|
(is (> (org-agent::org-object-version (gethash "root" *object-store*)) old-version))))
|
||||||
Reference in New Issue
Block a user