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

ARCH: Finalize Microkernel Decoupling - Move behavioral skills to dynamic user-space

Browse Source
This commit is contained in:
Amr Gharbeia
2026-04-13 16:11:09 -04:00
parent 34f59a6e43
commit 19fb888434
74 changed files with 129 additions and 2744 deletions
Download Patch File Download Diff File Expand all files Collapse all files

42
src/accountant-logic.lisp
View File

@@ -1,42 +0,0 @@
(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
(harness-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 harness'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))

110
src/bouncer.lisp
View File

@@ -1,110 +0,0 @@
(in-package :org-agent)
(defun bouncer-scan-secrets (text)
"Returns the name of the secret found in TEXT, or NIL if clean."
(when (and text (stringp text))
(let ((found-secret nil))
(maphash (lambda (key val)
(when (and val (stringp val) (> (length val) 5))
(when (search val text)
(setf found-secret key))))
*vault-memory*)
found-secret)))
(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))
;; Basic check for common data exfiltration tools being used with IPs/URLs
(let ((network-whitelist '("api.telegram.org" "matrix.org" "googleapis.com" "openai.com" "anthropic.com")))
(when (cl-ppcre:scan "(http|https|ftp)://([\\w\\.-]+)" cmd)
(multiple-value-bind (match regs)
(cl-ppcre:scan-to-strings "(http|https|ftp)://([\\w\\.-]+)" cmd)
(declare (ignore match))
(let ((domain (aref regs 1)))
(not (some (lambda (safe) (search safe domain)) network-whitelist))))))))
(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))
(payload (getf action :payload))
(text (or (getf payload :text) (getf action :text)))
;; Extract cmd from direct shell or tool-mediated shell call
(cmd (or (getf payload :cmd)
(when (and (eq target :tool) (equal (getf payload :tool) "shell"))
(getf (getf payload :args) :cmd))))
(approved (getf action :approved)))
(cond
;; 0. Bypass for already approved actions
(approved action)
;; 1. Secret Exposure Vector (Hard Block)
((and text (bouncer-scan-secrets text))
(let ((secret-name (bouncer-scan-secrets text)))
(harness-log "SECURITY VIOLATION: Blocked leak of secret ~a" secret-name)
`(:type :log :payload (:level :error :text ,(format nil "Action blocked: Potential exposure of ~a" secret-name)))))
;; 2. Network Exfiltration Vector (Authorization Required)
((and (or (eq target :shell)
(and (eq target :tool) (equal (getf payload :tool) "shell")))
(bouncer-check-network-exfil cmd))
(harness-log "SECURITY WARNING: External network call detected. Queuing for approval.")
`(:type :EVENT :payload (:sensor :approval-required :action ,action)))
;; 3. High-Impact Target Vector (Authorization Required)
((or (member target '(:shell))
(and (eq target :tool) (member (getf payload :tool) '("shell" "repair-file") :test #'string=))
(and (eq target :emacs) (eq (getf payload :action) :eval)))
(harness-log "SECURITY: High-impact action ~a requires approval." (or (getf payload :tool) target))
`(:type :EVENT :payload (:sensor :approval-required :action ,action)))
;; 4. Default Pass
(t action))))
(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"))
(found-any nil))
(dolist (node approved-nodes)
(let* ((tags (getf (org-object-attributes node) :TAGS))
(action-str (getf (org-object-attributes node) :ACTION)))
(when (and (member "FLIGHT_PLAN" tags :test #'string-equal) action-str)
(harness-log "BOUNCER: Found approved flight plan ~a. Re-injecting..." (org-object-id node))
(let ((action (ignore-errors (read-from-string action-str))))
(when action
;; Mark as approved to bypass the gate
(setf (getf action :approved) t)
(inject-stimulus action)
;; Mark as DONE
(setf (getf (org-object-attributes node) :TODO) "DONE")
(setq found-any t))))))
found-any))
(in-package :org-agent)
(defskill :skill-bouncer
:priority 100
:trigger (lambda (ctx)
(or (eq (getf (getf ctx :payload) :sensor) :approval-required)
(eq (getf (getf ctx :payload) :sensor) :heartbeat)))
:probabilistic nil
:deterministic (lambda (action context)
(declare (ignore action))
(let* ((payload (getf context :payload))
(sensor (getf payload :sensor)))
(case sensor
(:approval-required
(let* ((blocked-action (getf payload :action))
(id (org-id-new)))
(harness-log "BOUNCER: Creating flight plan node...")
;; Create the node in Emacs (or inbox)
(list :type :REQUEST :target :emacs :action :insert-node
:id id :attributes `(:TITLE "Flight Plan: High-Risk Action"
:TODO "PLAN"
:TAGS ("FLIGHT_PLAN")
:ACTION ,(format nil "~s" blocked-action)))))
(:heartbeat
;; Periodically check for approvals
(bouncer-process-approvals)
nil)))))

43
src/chaos-logic.lisp
View File

@@ -1,43 +0,0 @@
(in-package :org-agent)
(defun chaos-inject-error (sensor-type)
"Injects a synthetic error into a specific sensor pipeline."
(unless *chaos-enabled-p*
(harness-log "CHAOS ERROR - Injection blocked. Production gate is ACTIVE.")
(return-from chaos-inject-error nil))
(harness-log "CHAOS - Injecting synthetic error into ~a sensor..." sensor-type)
(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))
(unless *chaos-enabled-p*
(harness-log "CHAOS ERROR - Stress test blocked. Production gate is ACTIVE.")
(return-from chaos-stress-test "FAILURE - Production gate active."))
(let* ((payload (getf action :payload))
(mode (or (getf payload :mode) :random))
(intensity (or (getf payload :intensity) 3)))
(harness-log "CHAOS - Commencing stress test (Mode: ~a, Intensity: ~a)" mode intensity)
(snapshot-memory)
(case mode
(:random (dotimes (i intensity)
(let ((failure-type (nth (random 3) '(:test-failure :shell-timeout :llm-error))))
(inject-stimulus
`(:type :EVENT :payload (:sensor :chaos-injection :type ,failure-type))))))
(:shell (inject-stimulus
`(:type :EVENT :payload (:sensor :shell-response :cmd "git push" :exit-code 128 :stderr "fatal: network unreachable")))))
(snapshot-memory)
(format nil "SUCCESS - Chaos stress test initiated.")))
(defun chaos-enable ()
"Disables the production gate and allows chaos injection."
(setf *chaos-enabled-p* t)
(harness-log "CHAOS - Production gate DISABLED. Chaos injection is now ALLOWED.")
t)
(defun chaos-disable ()
"Enables the production gate and blocks chaos injection."
(setf *chaos-enabled-p* nil)
(harness-log "CHAOS - Production gate ENABLED. Chaos injection is now BLOCKED.")
t)

83
src/chat-logic.lisp
View File

@@ -1,83 +0,0 @@
(in-package :org-agent)
(defun chat-archive-message (text &key (role :user) channel chat-id)
"Archives a chat message into the persistent Memory 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 *memory*) obj)
(harness-log "CHAT - Message archived: ~a (~a)" msg-id role)
(snapshot-memory)
msg-id))
(defun trigger-skill-chat (context)
(let* ((payload (getf context :payload))
(sensor (getf payload :sensor)))
(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))
(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 '(:telegram :TELEGRAM))
(or (getf payload :chat-id) (getf proposed-action :chat-id)))
(and (member target '(:signal :SIGNAL))
(or (getf payload :chat-id) (getf proposed-action :chat-id)))
(and (member target '(:matrix :MATRIX))
(or (getf payload :room-id) (getf proposed-action :room-id)))
(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))))
(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 probabilistic-skill-chat (context)
"Generates a conversational response, stripping system errors from context."
(let* ((payload (getf context :payload))
(raw-text (getf payload :text))
(channel (or (getf payload :channel) :emacs))
(chat-id (getf payload :chat-id))
;; 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))
(reply-instruction
(case channel
(:telegram (format nil "- To reply via Telegram: (:type :REQUEST :target :telegram :chat-id \"~a\" :text \"<Response>\")" chat-id))
(:signal (format nil "- To reply via Signal: (:type :REQUEST :target :signal :chat-id \"~a\" :text \"<Response>\")" chat-id))
(:matrix (format nil "- To reply via Matrix: (:type :REQUEST :target :matrix :room-id \"~a\" :text \"<Response>\")" chat-id))
(t "- To reply via Emacs: (:type :REQUEST :target :emacs :action :insert-at-end :buffer \"*org-agent-chat*\" :text \"* <Response>\")"))))
(ask-probabilistic trimmed-text :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 use markdown.
STRICT RULE: Never output the strings 'Unknown request' or 'System Error'.
REQUIRED FORMATS:
" reply-instruction "
- To use a tool: (:type :REQUEST :target :tool :action :call :tool \"<name>\" :args (...))"))))
(defskill :skill-chat
:priority 100
:trigger #'trigger-skill-chat
:probabilistic #'probabilistic-skill-chat
:deterministic #'verify-skill-chat)

22
src/config-logic.lisp
View File

@@ -1,22 +0,0 @@
(in-package :org-agent)
(defun set-llm-model (provider model-id)
"Registers a preferred model for a provider in the Memory."
(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 *memory*) obj)
(harness-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 Memory."
(let* ((config-id (format nil "config-llm-~a" (string-downcase (string provider))))
(obj (gethash config-id *memory*)))
(if obj
(getf (org-object-attributes obj) :model-id)
default)))

10
src/consensus-logic.lisp
View File

@@ -1,10 +0,0 @@
(in-package :org-agent)
(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)))

72
src/context-logic.lisp
View File

@@ -1,72 +0,0 @@
(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 Memory 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)))
:probabilistic nil
:deterministic (lambda (action ctx)
(declare (ignore action ctx))
;; This skill primarily provides the context-assemble-global-awareness function
;; used by the probabilistic-gate, rather than handling specific actions.
nil))

57
src/credentials-vault.lisp
View File

@@ -1,57 +0,0 @@
(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) "GEMINI_API_KEY")
(:openai "OPENAI_API_KEY")
(:anthropic "ANTHROPIC_API_KEY")
(:groq "GROQ_API_KEY")
(:openrouter "OPENROUTER_API_KEY")
(:telegram "TELEGRAM_BOT_TOKEN")
(:signal "SIGNAL_ACCOUNT_NUMBER")
(:matrix-homeserver "MATRIX_HOMESERVER")
(:matrix-token "MATRIX_ACCESS_TOKEN")
(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)
(harness-log "VAULT - Updated ~a for ~a. Triggering Merkle snapshot..." type provider)
(snapshot-memory)
t))
(defun vault-onboard-gemini-web ()
"Instructions for the Sovereign Cookie Handshake."
(harness-log "--- GEMINI WEB ONBOARDING ---")
(harness-log "1. Visit gemini.google.com")
(harness-log "2. Run the 'Get Gemini Cookies' Bookmarklet.")
(harness-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));})();")
(harness-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))
:probabilistic nil
:deterministic (lambda (action ctx)
(vault-onboard-gemini-web)
action)))

60
src/embedding-logic.lisp
View File

@@ -1,60 +0,0 @@
(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
(harness-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)
(harness-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))))
*memory*)
(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))
:probabilistic nil
:deterministic (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))))

31
src/embedding.lisp
View File

@@ -1,31 +0,0 @@
(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 (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) (harness-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) (let ((vec (org-object-vector obj))) (when vec (push (cons (cosine-similarity query-vector vec) obj) similarities)))) *memory*)
(let ((sorted (sort similarities #'> :key #'car))) (subseq sorted 0 (min top-k (length sorted))))))

72
src/event-orchestrator.lisp
View File

@@ -1,72 +0,0 @@
(in-package :org-agent)
(defvar *hook-registry* (make-hash-table :test 'equal)
"Maps hook-names (symbols) to lists of functions.")
(defvar *cron-registry* (make-hash-table :test 'equal)
"Maps task-ids to plists containing schedule and function.")
(defun orchestrator-register-hook (hook-name fn)
"Registers a function for a named hook. Triggers a Merkle snapshot."
(pushnew fn (gethash hook-name *hook-registry*))
(harness-log "ORCHESTRATOR - Registered hook function for ~a" hook-name)
(snapshot-memory)
t)
(defun orchestrator-trigger-hook (hook-name &rest args)
"Executes all registered functions for the given hook name."
(let ((functions (gethash hook-name *hook-registry*)))
(dolist (fn functions)
(handler-case (apply fn args)
(error (c) (harness-log "ORCHESTRATOR ERROR - Hook ~a failed: ~a" hook-name c))))))
(defun orchestrator-schedule-task (task-id schedule fn)
"Schedules a task for execution. Schedule can be an interval (integer seconds) or 'heartbeat'."
(setf (gethash task-id *cron-registry*) (list :schedule schedule :fn fn :last-run 0))
(harness-log "ORCHESTRATOR - Scheduled task ~a (~a)" task-id schedule)
(snapshot-memory)
t)
(defun orchestrator-process-cron ()
"Checked by the harness on every heartbeat."
(let ((now (get-universal-time)))
(maphash (lambda (id task)
(let ((schedule (getf task :schedule))
(last-run (getf task :last-run))
(fn (getf task :fn)))
(when (or (eq schedule :heartbeat)
(and (integerp schedule) (>= (- now last-run) schedule)))
(handler-case (funcall fn)
(error (c) (harness-log "ORCHESTRATOR ERROR - Cron task ~a failed: ~a" id c)))
(setf (getf (gethash id *cron-registry*) :last-run) now))))
*cron-registry*)))
(defun orchestrator-classify-complexity (context)
"Returns the complexity tier (:REFLEX, :COGNITION, :REASONING) for a stimulus."
(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 and background automation
(t :REFLEX))))
(progn
;; Hook into kernel routing
(setf org-agent::*model-selector-fn* #'orchestrator-classify-complexity)
(defskill :skill-event-orchestrator
:priority 400 ; Foundational control layer
:trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :heartbeat))
:probabilistic nil
:deterministic (lambda (action ctx)
(orchestrator-process-cron)
action)))

95
src/gateway-matrix.lisp
View File

@@ -1,95 +0,0 @@
(in-package :org-agent)
(defvar *matrix-since-token* nil)
(defvar *matrix-polling-thread* nil)
(defun get-matrix-homeserver () (vault-get-secret :matrix-homeserver))
(defun get-matrix-token () (vault-get-secret :matrix-token))
(defun execute-matrix-action (action context)
"Sends a message via Matrix Client API."
(declare (ignore context))
(let* ((payload (getf action :payload))
(room-id (or (getf payload :room-id) (getf action :room-id)))
(text (or (getf payload :text) (getf action :text)))
(hs (get-matrix-homeserver))
(token (get-matrix-token))
(txn-id (get-universal-time))
(url (format nil "~a/_matrix/client/v3/rooms/~a/send/m.room.message/~a" hs room-id txn-id)))
(when (and hs token room-id text)
(harness-log "MATRIX: Sending message to ~a..." room-id)
(handler-case
(dex:put url
:headers `(("Authorization" . ,(format nil "Bearer ~a" token))
("Content-Type" . "application/json"))
:content (cl-json:encode-json-to-string
`((msgtype . "m.text") (body . ,text))))
(error (c) (harness-log "MATRIX ERROR: ~a" c))))))
(defun matrix-process-sync ()
"Calls Matrix sync and injects new messages."
(let* ((hs (get-matrix-homeserver))
(token (get-matrix-token))
(url (format nil "~a/_matrix/client/v3/sync?timeout=30000~@[&since=~a~]"
hs *matrix-since-token*)))
(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)
(harness-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) (harness-log "MATRIX SYNC ERROR: ~a" c))))))
(defun start-matrix-gateway ()
"Initializes the Matrix background thread."
(unless (and *matrix-polling-thread* (bt:thread-alive-p *matrix-polling-thread*))
(setf *matrix-polling-thread*
(bt:make-thread
(lambda ()
(loop
(matrix-process-sync)
(sleep 2)))
:name "org-agent-matrix-gateway"))
(harness-log "MATRIX: Gateway sync active.")))
(defun stop-matrix-gateway ()
(when (and *matrix-polling-thread* (bt:thread-alive-p *matrix-polling-thread*))
(bt:destroy-thread *matrix-polling-thread*)
(setf *matrix-polling-thread* nil)))
(register-actuator :matrix #'execute-matrix-action)
(defskill :skill-gateway-matrix
:priority 150
:trigger (lambda (ctx) (declare (ignore ctx)) nil)
:probabilistic nil
:deterministic (lambda (action ctx) (declare (ignore ctx)) action))
(start-matrix-gateway)

71
src/gateway-signal.lisp
View File

@@ -1,71 +0,0 @@
(in-package :org-agent)
(defun get-signal-account () (vault-get-secret :signal))
(defvar *signal-polling-thread* nil)
(defun execute-signal-action (action context)
"Sends a message via signal-cli."
(declare (ignore context))
(let* ((payload (getf action :payload))
(chat-id (or (getf payload :chat-id) (getf action :chat-id)))
(text (or (getf payload :text) (getf action :text)))
(account (get-signal-account)))
(when (and account chat-id text)
(harness-log "SIGNAL: Sending message to ~a..." chat-id)
(handler-case
(uiop:run-program (list "signal-cli" "-u" account "send" "-m" text chat-id)
:output :string :error-output :string)
(error (c) (harness-log "SIGNAL ERROR: ~a" c))))))
(defun signal-process-updates ()
"Polls for new messages via signal-cli and injects them into the harness."
(let ((account (get-signal-account)))
(when account
(handler-case
(let* ((output (uiop:run-program (list "signal-cli" "-u" account "receive" "--json")
:output :string :error-output :string :ignore-error-status t))
(lines (cl-ppcre:split "\\n" output)))
(dolist (line lines)
(when (and line (> (length line) 0))
(let* ((json (ignore-errors (cl-json:decode-json-from-string line)))
(envelope (cdr (assoc :envelope json)))
(source (cdr (assoc :source envelope)))
(data-message (cdr (assoc :data-message envelope)))
(text (cdr (assoc :message data-message))))
(when (and source text)
(harness-log "SIGNAL: Received message from ~a" source)
(inject-stimulus
(list :type :EVENT
:payload (list :sensor :chat-message
:channel :signal
:chat-id source
:text text))))))))
(error (c) (harness-log "SIGNAL POLL ERROR: ~a" c))))))
(defun start-signal-gateway ()
"Initializes the Signal background thread."
(unless (and *signal-polling-thread* (bt:thread-alive-p *signal-polling-thread*))
(setf *signal-polling-thread*
(bt:make-thread
(lambda ()
(loop
(signal-process-updates)
(sleep 5)))
:name "org-agent-signal-gateway"))
(harness-log "SIGNAL: Gateway polling active.")))
(defun stop-signal-gateway ()
(when (and *signal-polling-thread* (bt:thread-alive-p *signal-polling-thread*))
(bt:destroy-thread *signal-polling-thread*)
(setf *signal-polling-thread* nil)))
(register-actuator :signal #'execute-signal-action)
(defskill :skill-gateway-signal
:priority 150
:trigger (lambda (ctx) (declare (ignore ctx)) nil) ;; Passive
:probabilistic nil
:deterministic (lambda (action ctx) (declare (ignore ctx)) action))
(start-signal-gateway)

81
src/gateway-telegram.lisp
View File

@@ -1,81 +0,0 @@
(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.")
(defun get-telegram-token () (vault-get-secret :telegram))
(defun execute-telegram-action (action context)
"Sends a message back to Telegram."
(declare (ignore context))
(let* ((payload (getf action :payload))
(chat-id (or (getf payload :chat-id) (getf action :chat-id)))
(text (or (getf payload :text) (getf action :text)))
(token (get-telegram-token))
(url (format nil "https://api.telegram.org/bot~a/sendMessage" token)))
(when (and token chat-id text)
(harness-log "TELEGRAM: Sending message to ~a..." chat-id)
(handler-case
(dex:post url
:headers '(("Content-Type" . "application/json"))
:content (cl-json:encode-json-to-string
`((chat_id . ,chat-id) (text . ,text))))
(error (c) (harness-log "TELEGRAM ERROR: ~a" c))))))
(defun telegram-process-updates ()
"Polls for new messages and injects them into the harness."
(let* ((token (get-telegram-token))
(url (format nil "https://api.telegram.org/bot~a/getUpdates?offset=~a"
token (1+ *telegram-last-update-id*))))
(when token
(handler-case
(let* ((response (dex:get url))
(json (cl-json:decode-json-from-string response))
(updates (cdr (assoc :result json))))
(dolist (update updates)
(let* ((update-id (cdr (assoc :update--id update)))
(message (cdr (assoc :message update)))
(chat (cdr (assoc :chat message)))
(chat-id (cdr (assoc :id chat)))
(text (cdr (assoc :text message))))
(setf *telegram-last-update-id* update-id)
(when (and text chat-id)
(harness-log "TELEGRAM: Received message from ~a" chat-id)
(inject-stimulus
(list :type :EVENT
:payload (list :sensor :chat-message
:channel :telegram
:chat-id (format nil "~a" chat-id)
:text text)))))))
(error (c) (harness-log "TELEGRAM POLL ERROR: ~a" c))))))
(defun start-telegram-gateway ()
"Initializes the Telegram background thread."
(unless (and *telegram-polling-thread* (bt:thread-alive-p *telegram-polling-thread*))
(setf *telegram-polling-thread*
(bt:make-thread
(lambda ()
(loop
(telegram-process-updates)
(sleep 3)))
:name "org-agent-telegram-gateway"))
(harness-log "TELEGRAM: Gateway polling active.")))
(defun stop-telegram-gateway ()
(when (and *telegram-polling-thread* (bt:thread-alive-p *telegram-polling-thread*))
(bt:destroy-thread *telegram-polling-thread*)
(setf *telegram-polling-thread* nil)))
(register-actuator :telegram #'execute-telegram-action)
(defskill :skill-gateway-telegram
:priority 150
:trigger (lambda (ctx) (declare (ignore ctx)) nil) ;; Passive, handles its own loop
:probabilistic nil
:deterministic (lambda (action ctx) (declare (ignore ctx)) action))
(start-telegram-gateway)

36
src/harness-monitor.lisp
View File

@@ -1,36 +0,0 @@
(in-package :org-agent)
(org-agent:def-cognitive-tool :harness-status \"Returns the current operational status of the Org-Agent harness, including loaded skills and telemetry.\"
nil
:body (lambda (args)
(declare (ignore args))
(format nil \"HARNESS STATUS:
- Active Skills: ~a
- Uptime: ~a seconds
- Memory Usage: ~a
- Providers: ~a\"
(hash-table-count org-agent:*skills-registry*)
(get-universal-time)
\"Not implemented\"
org-agent:*provider-cascade*)))
(org-agent:def-cognitive-tool :list-skills \"Lists all currently loaded skills and their metadata.\"
nil
:body (lambda (args)
(declare (ignore args))
(let ((output \"LOADED SKILLS:
\"))
(maphash (lambda (name skill)
(setf output (concatenate 'string output
(format nil \"- ~a (Priority: ~a, Deps: ~s)~%\"
name
(org-agent:skill-priority skill)
(org-agent:skill-dependencies skill)))))
org-agent:*skills-registry*)
output)))
(defskill :skill-harness-monitor
:priority 100
:trigger (lambda (context) t)
:probabilistic (lambda (context) \"You are the Harness Monitor. Use your tools to provide system visibility.\")
:deterministic (lambda (action context) action))

60
src/homoiconic-memory.lisp
View File

@@ -1,60 +0,0 @@
(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 org-id-get-create ()
"Generates a new unique ID for an Org node. This is the system-wide standard."
(format nil "node-~a" (get-universal-time)))
(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)))
(harness-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
(harness-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
(harness-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)))
:probabilistic nil
:deterministic (lambda (action ctx)
(let ((ast (getf (getf ctx :payload) :ast)))
(when ast (memory-normalize-ast ast))
action))))

64
src/latent-reflection.lisp
View File

@@ -1,64 +0,0 @@
(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)) *memory*)
(let ((len (length keys)))
(when (> len 0)
(dotimes (i count)
(let* ((random-key (nth (random len) keys))
(obj (gethash random-key *memory*)))
(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
(harness-log "GARDENER - Initiating Latent Reflection...")
(setf *last-reflection-time* now)
t)
nil)))
:probabilistic (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)))
:deterministic (lambda (action ctx)
(declare (ignore ctx))
;; Approve any safe request
action))

54
src/lisp-repair.lisp
View File

@@ -1,54 +0,0 @@
(in-package :org-agent)
(defun count-char (char string)
(let ((count 0))
(loop for c across string
when (char= c char)
do (incf count))
count))
(defun deterministic-repair (code)
"Attempts instant fixes on broken Lisp code (e.g. balancing parens)."
(let* ((open-parens (count-char #\( code))
(close-parens (count-char #\) code))
(diff (- open-parens close-parens)))
(if (> diff 0)
(concatenate 'string code (make-string diff :initial-element #\)))
code)))
(defun neural-repair (code error-message)
"Uses Probabilistic Engine to deeply repair the syntax structure."
(let ((prompt (format nil "The following Lisp code failed to parse.
ERROR: ~a
CODE: ~a
MANDATE: Output EXACTLY ONE valid Common Lisp list. Do not explain. Do not use markdown blocks."
error-message code))
(system-prompt "You are a Lisp Syntax Repair Actuator. Return only valid, balanced Lisp code."))
(let ((repaired (ask-probabilistic prompt :system-prompt system-prompt)))
(string-trim '(#\Space #\Newline #\Tab) repaired))))
(defskill :skill-lisp-repair
:priority 90
:trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :syntax-error))
:probabilistic nil ;; Handled deterministically in deterministic or manually via ask-probabilistic
:deterministic (lambda (action context)
(declare (ignore action))
(let* ((payload (getf context :payload))
(code (getf payload :code))
(error-msg (getf payload :error)))
(harness-log "SYNTAX GATE: Reacting to broken Lisp stimulus...")
(let ((fast-fix (deterministic-repair code)))
(handler-case
(let ((repaired (read-from-string fast-fix)))
(harness-log "SYNTAX GATE: Deterministic repair SUCCESS.")
repaired)
(error ()
(harness-log "SYNTAX GATE: Deterministic repair failed. Escalating...")
(let ((deep-fix (neural-repair code error-msg)))
(handler-case
(let ((repaired (read-from-string deep-fix)))
(harness-log "SYNTAX GATE: Neural repair SUCCESS.")
repaired)
(error ()
(harness-log "SYNTAX GATE: Neural repair failed.")
(list :type :LOG :payload (list :text "Lisp Repair Failed.")))))))))))

102
src/lisp-validator.lisp
View File

@@ -1,102 +0,0 @@
(in-package :org-agent)
(defparameter *lisp-validator-whitelist*
'(;; Math & Logic
+ - * / = < > <= >= 1+ 1- min max
and or not null eq eql equal string= string-equal
;; List Manipulation
list cons car cdr cadr cddr cdar caar append mapcar remove-if remove-if-not
length reverse sort nth nthcdr push pop
;; Plists and Hash Tables
getf gethash
;; Control Flow
let let* if cond when unless case typecase
;; Strings
format concatenate string-downcase string-upcase search
;; Kernel specifics
org-agent::harness-log
org-agent::snapshot-memory
org-agent::rollback-memory
org-agent::lookup-object
org-agent::list-objects-by-type
org-agent::ingest-ast
org-agent::find-headline-missing-id
org-agent::context-query-store
org-agent::context-get-active-projects
org-agent::context-get-recent-completed-tasks
org-agent::context-list-all-skills
org-agent::context-get-system-logs
org-agent::context-assemble-global-awareness
org-agent::org-object-id
org-agent::org-object-type
org-agent::org-object-attributes
org-agent::org-object-content
org-agent::org-object-parent-id
org-agent::org-object-children
org-agent::org-object-version
org-agent::org-object-last-sync
org-agent::org-object-hash
;; Essential macros
declare ignore
;; Let's also add simple data types
t nil quote function))
(defvar *lisp-validator-registry* nil
"List of dynamically registered safe symbols.")
(defun lisp-validator-register (symbols)
"Adds symbols to the global validator registry."
(setf *lisp-validator-registry* (append *lisp-validator-registry* (if (listp symbols) symbols (list symbols))))
(harness-log "LISP VALIDATOR: Registered ~a new safe symbols." (length (if (listp symbols) symbols (list symbols)))))
(defun lisp-validator-is-safe (symbol)
"Checks if a symbol is in the static whitelist or the dynamic registry."
(or (member symbol *lisp-validator-whitelist* :test #'string-equal)
(member symbol *lisp-validator-registry* :test #'string-equal)))
(defun lisp-validator-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)
(lisp-validator-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)
((lisp-validator-is-safe head)
(every #'lisp-validator-ast-walk (cdr form)))
(t
(harness-log "LISP VALIDATOR: Blocked call to non-whitelisted function ~a" head)
nil))))
(t nil)))
(org-agent:def-cognitive-tool :lisp-validator-status "Returns validator-related telemetry, including blocked actions and harness status."
nil
:body (lambda (args)
(declare (ignore args))
(format nil "LISP VALIDATOR STATUS:
- Static Whitelist: ~a symbols
- Dynamic Registry: ~a symbols
- Total Blocked Actions: ~a"
(length *lisp-validator-whitelist*)
(length *lisp-validator-registry*)
"Not implemented")))
(org-agent:defskill :skill-lisp-validator
:priority 900 ; High priority, before most skills
:trigger (lambda (ctx)
;; Check if any proposed action is an :eval or :shell call
(let ((candidate (getf ctx :candidate)))
(when candidate
(let ((payload (getf candidate :payload)))
(member (getf payload :action) '(:eval :shell))))))
:probabilistic nil ; Purely deterministic/safety skill
:deterministic (lambda (action context)
(harness-log "DETERMINISTIC ENGINE [Lisp-Validator]: Intercepted critical action for structural validation.")
action))

92
src/llm-gateway.lisp
View File

@@ -1,92 +0,0 @@
(in-package :org-agent)
(defun get-nested (alist &rest keys)
"Recursively extracts nested values from an alist, handling both objects and arrays."
(let ((val alist))
(dolist (k keys)
;; If val is an array (a list where the first element is a list but NOT a pair),
;; descend into the first element.
(when (and (listp val) (listp (car val)) (not (keywordp (caar val))))
(setf val (car val)))
(let ((pair (assoc k val)))
(if pair
(setf val (cdr pair))
(return-from get-nested nil))))
val))
(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)))
(harness-log "PROBABILISTIC ENGINE: 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)
(when (or (null api-key) (string= 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)))
(let ((content (case provider
(:anthropic (get-nested json :content :text))
(:gemini-api (get-nested json :candidates :parts :text))
(t (get-nested json :choices :message :content)))))
(if content
(list :status :success :content content)
(list :status :error :message (format nil "Failed to parse ~a response structure." provider)))))
(error (c) (list :status :error :message (format nil "LLM Gateway Failure (~a): ~a" provider c)))))))))
(def-cognitive-tool :ask-llm
"Queries an LLM provider via the unified gateway."
((: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))))
(dolist (p '(:anthropic :gemini-api :gemini-web :groq :ollama :openai :openrouter))
(org-agent:register-probabilistic-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) (declare (ignore context)) nil)
:probabilistic (lambda (context) (declare (ignore context)) nil)
:deterministic (lambda (action context) (declare (ignore context)) action))

1
src/package.lisp
View File

@@ -62,7 +62,6 @@
#:load-skill-with-timeout
#:topological-sort-skills
#:validate-lisp-syntax
#:lisp-validator-validate
#:defskill
#:*skills-registry*
#:skill

38
src/playwright.lisp
View File

@@ -1,38 +0,0 @@
(in-package :org-agent)
(defun get-browser-bridge-path ()
"Returns the absolute path to the Python browser bridge script."
(let ((root (or (uiop:getenv "PROJECT_ROOT") (uiop:native-namestring (uiop:getcwd)))))
(merge-pathnames "scripts/browser-bridge.py" (uiop:ensure-directory-pathname root))))
(defun execute-browser-command (args)
"Invokes the Playwright Python bridge with the provided arguments."
(let* ((script-path (get-browser-bridge-path))
(json-input (cl-json:encode-json-to-string args)))
(handler-case
(let ((output (uiop:run-program (list "python3" (uiop:native-namestring script-path))
:input (make-string-input-stream json-input)
:output :string
:error-output :string)))
(cl-json:decode-json-from-string output))
(error (c)
(list :status "error" :message (format nil "Bridge Execution Failed: ~a" c))))))
(def-cognitive-tool :browser
"High-fidelity web browsing via Playwright (Chromium). Supports JS rendering."
((:url :type :string :description "The target URL")
(:action :type :string :description "Action to perform: 'extract_text' or 'screenshot'")
(:selector :type :string :description "Optional CSS selector (default: 'body')"))
:body (lambda (args)
(let ((result (execute-browser-command args)))
(if (string= (cdr (assoc :status result)) "success")
(or (cdr (assoc :content result))
(cdr (assoc :screenshot--base64 result))
"Success (no content returned)")
(format nil "BROWSER ERROR: ~a" (cdr (assoc :message result)))))))
(defskill :skill-playwright
:priority 150
:trigger (lambda (ctx) (declare (ignore ctx)) nil) ; Passive tool provider
:probabilistic nil
:deterministic (lambda (action ctx) (declare (ignore ctx)) action))

15
src/policy-enforcer.lisp
View File

@@ -1,15 +0,0 @@
(in-package :org-agent)
(defskill :skill-policy-enforcer
:priority 1000 ; Absolute highest priority
:trigger (lambda (context) t) ; Always active as a fallback
:probabilistic (lambda (context)
\"You are the Org-Agent Policy Enforcer. Your goal is to ensure all actions empower the user through the Lisp Machine and adhere to the System Policy.\")
:deterministic (lambda (action context)
;; Basic invariant check: Block actions that appear to violate sovereignty
(let ((payload (getf action :payload)))
(if (and payload (search \"proprietary\" (format nil \"~s\" payload)))
(progn
(org-agent:harness-log \"DETERMINISTIC [Policy]: Sovereignty violation suspected. Blocking action.\")
nil)
action))))

33
src/processor-logic.lisp
View File

@@ -1,33 +0,0 @@
(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 probabilistic-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-probabilistic 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))))
(in-package :org-agent)
(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:harness-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)."))))))

39
src/protocol-validator.lisp
View File

@@ -1,39 +0,0 @@
(in-package :org-agent)
(defun validate-communication-protocol-schema (msg)
"Strict structural validation for incoming communication protocol messages."
(unless (listp msg)
(error "Communication Protocol 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 "Communication Protocol Schema Error: Invalid message type '~a'" type))
(case type
(:REQUEST
(unless (getf msg :target)
(error "Communication Protocol Schema Error: REQUEST missing mandatory :target"))
(unless (getf msg :payload)
(error "Communication Protocol Schema Error: REQUEST missing mandatory :payload")))
(:EVENT
(let ((payload (getf msg :payload)))
(unless (and payload (listp payload))
(error "Communication Protocol Schema Error: EVENT missing or invalid :payload"))
(unless (or (getf payload :action) (getf payload :sensor))
(error "Communication Protocol Schema Error: EVENT payload must contain :action or :sensor"))))
(:RESPONSE
(unless (getf msg :payload)
(error "Communication Protocol Schema Error: RESPONSE missing mandatory :payload"))))
t))
(defskill :skill-communication-protocol-validator
:priority 95
:trigger (lambda (ctx) (member (getf (getf ctx :payload) :sensor) '(:protocol-received)))
:probabilistic nil
:deterministic (lambda (action ctx)
(declare (ignore ctx))
(validate-communication-protocol-schema action)
action))

19
src/router-logic.lisp
View File

@@ -1,19 +0,0 @@
(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))))

55
src/self-fix.lisp
View File

@@ -1,55 +0,0 @@
(in-package :org-agent)
(defun self-fix-apply (action context)
"Applies a surgical code fix and reloads the modified skill."
(declare (ignore context))
(let* ((payload (getf action :payload))
(target-file (getf payload :file))
(old-code (getf payload :old))
(new-code (getf payload :new))
(is-skill (and (stringp (namestring target-file))
(search "skills/" (namestring target-file)))))
(org-agent:snapshot-memory)
(org-agent:harness-log "SELF-FIX - Attempting surgical fix on ~a..." target-file)
(handler-case
(if (uiop:file-exists-p target-file)
(let ((content (uiop:read-file-string target-file)))
(if (search old-code content)
(let ((new-content (cl-ppcre:regex-replace-all (cl-ppcre:quote-meta-chars old-code) content new-code)))
(with-open-file (out target-file :direction :output :if-exists :supersede)
(write-string new-content out))
(if is-skill
(progn
(org-agent:harness-log "SELF-FIX - Reloading modified skill ~a..." target-file)
(if (org-agent:load-skill-from-org target-file)
(progn
(org-agent:harness-log "SELF-FIX SUCCESS - Applied and reloaded.")
t)
(progn
(org-agent:harness-log "SELF-FIX FAILURE - Skill reload failed. Rolling back.")
(with-open-file (out target-file :direction :output :if-exists :supersede)
(write-string content out))
(org-agent:rollback-memory 0)
nil)))
(progn
(org-agent:harness-log "SELF-FIX SUCCESS - Applied fix to file.")
t)))
(progn (org-agent:harness-log "SELF-FIX FAILURE - Pattern not found.") nil)))
(progn (org-agent:harness-log "SELF-FIX FAILURE - File not found.") nil))
(error (c)
(org-agent:harness-log "SELF-FIX CRASH - ~a. Rolling back." c)
(org-agent:rollback-memory 0)
nil))))
(def-cognitive-tool :repair-file
"Applies a surgical code modification to a file and reloads the skill if applicable."
((:file :type :string :description "Path to the target file")
(:old :type :string :description "The literal code block to find")
(:new :type :string :description "The literal code block to replace it with"))
:body (lambda (args)
(if (self-fix-apply (list :payload args) nil)
"REPAIR SUCCESSFUL."
"REPAIR FAILED.")))

87
src/shell-logic.lisp
View File

@@ -1,87 +0,0 @@
(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)))))
(cond
;; 1. Metacharacter check (Injection prevention)
((not (shell-command-safe-p cmd-string))
(org-agent:inject-stimulus
`(:type :EVENT :payload (:sensor :shell-response :cmd ,cmd-string :stdout "" :stderr "ERROR - Security Violation: Dangerous metacharacters detected." :exit-code 1))
:stream (getf context :reply-stream)))
;; 2. Whitelist check
((not (member executable *allowed-commands* :test #'string=))
(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)))
;; 3. Safe Execution
(t
(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)))))))
(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."
(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))))))
(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."
(harness-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))
(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))))
(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
:probabilistic #'probabilistic-skill-shell-actuator
:deterministic (lambda (action context) (declare (ignore context)) action))

16
src/task-integrity.lisp
View File

@@ -1,16 +0,0 @@
(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)))

72
src/verification-logic.lisp
View File

@@ -1,72 +0,0 @@
(in-package :org-agent)
(defvar *formal-invariants* (make-hash-table :test 'equal)
"Registry of security invariants used by the Formal Verification Gate.")
(defmacro def-invariant (name action-type (action context) &body body)
"Defines a formal security invariant.
BODY must return T for safe actions and NIL for unsafe ones."
`(setf (gethash (string-downcase (string ',name)) *formal-invariants*)
(list :name ',name
:type ,action-type
:logic (lambda (,action ,context) ,@body))))
(def-invariant path-confinement :all (action context)
"Forces all path-based operations to reside within the Sovereign Memex."
(declare (ignore context))
(let* ((payload (getf action :payload))
(path (or (getf payload :file) (getf payload :path)))
(cmd (getf payload :cmd))
(memex-root (or (uiop:getenv "MEMEX_DIR") "/home/user/memex")))
(cond
;; If a path is explicitly provided, verify it is absolute and within root
(path
(let ((truename (ignore-errors (namestring (truename path)))))
(if truename
(str:starts-with-p memex-root truename)
;; If file doesn't exist yet, check string prefix
(str:starts-with-p memex-root path))))
;; If it's a shell command, check for absolute paths outside memex
(cmd
(not (cl-ppcre:scan "(^|\\s)/((etc|var|proc|root|sys)|(home/(?!user/memex)))" cmd)))
(t t))))
(def-invariant no-network-exfil :shell (action context)
"Prevents shell commands from establishing unauthorized external connections."
(declare (ignore context))
(let* ((payload (getf action :payload))
(cmd (getf payload :cmd)))
(if (and cmd (stringp cmd))
(let ((forbidden-tools '("nc" "netcat" "ssh" "scp" "rsync" "ftp" "telnet")))
(not (some (lambda (tool) (cl-ppcre:scan (format nil "(^|\\s)~a(\\s|$)" tool) cmd))
forbidden-tools)))
t)))
(defun verify-action-formally (action context)
"Deterministically proves that ACTION satisfies all applicable security invariants."
(let ((action-target (getf action :target))
(action-type (getf action :type))
(all-passed t))
(maphash (lambda (id inv)
(declare (ignore id))
(let ((inv-type (getf inv :type))
(inv-logic (getf inv :logic))
(inv-name (getf inv :name)))
(when (or (eq inv-type :all)
(eq inv-type action-target)
(eq inv-type action-type))
(unless (funcall inv-logic action context)
(harness-log "FORMAL FAILURE: Action ~s violated invariant ~a" action inv-name)
(setf all-passed nil)))))
*formal-invariants*)
all-passed))
(defskill :skill-formal-verification
:priority 95 ; Just below Bouncer
:trigger (lambda (context) (declare (ignore context)) nil) ; Middleware only
:probabilistic nil
:deterministic (lambda (action context)
(if (verify-action-formally action context)
action
(let ((err (format nil "Formal verification failed for action: ~s" action)))
`(:type :log :payload (:level :error :text ,err))))))