FEAT: Implement 5-Vector Bouncer Matrix and foundational refactor
This commit is contained in:
@@ -1,5 +1,66 @@
|
||||
(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)))
|
||||
|
||||
(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))))))))
|
||||
|
||||
(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)))
|
||||
(kernel-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))
|
||||
(kernel-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)))
|
||||
(kernel-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))))
|
||||
|
||||
(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"))
|
||||
@@ -11,7 +72,7 @@
|
||||
(kernel-log "BOUNCER: Found approved flight plan ~a. Re-injecting..." (org-object-id node))
|
||||
(let ((action (ignore-errors (read-from-string action-str))))
|
||||
(when action
|
||||
;; Add bypass flag
|
||||
;; Mark as approved to bypass the gate
|
||||
(setf (getf action :approved) t)
|
||||
(inject-stimulus action)
|
||||
;; Mark as DONE
|
||||
|
||||
209
src/core.lisp
209
src/core.lisp
@@ -1,12 +1,8 @@
|
||||
(in-package :org-agent)
|
||||
|
||||
(defvar *system-logs* nil)
|
||||
(defvar *logs-lock* (bt:make-lock "kernel-logs-lock"))
|
||||
(defvar *max-log-history* 100)
|
||||
(defvar *interrupt-flag* nil)
|
||||
|
||||
(defvar *interrupt-lock* (bt:make-lock "kernel-interrupt-lock"))
|
||||
(defvar *skill-telemetry* (make-hash-table :test 'equal))
|
||||
(defvar *telemetry-lock* (bt:make-lock "kernel-telemetry-lock"))
|
||||
|
||||
(defun dispatch-action (action context)
|
||||
"Routes an approved action to its registered physical actuator."
|
||||
@@ -17,86 +13,54 @@
|
||||
(funcall actuator-fn action context)
|
||||
(kernel-log "DISPATCH ERROR: No actuator for ~a" target)))))
|
||||
|
||||
(defun kernel-track-telemetry (skill-name duration status)
|
||||
"Updates performance metrics for a specific skill."
|
||||
(when skill-name (bt:with-lock-held (*telemetry-lock*)
|
||||
(let ((entry (or (gethash skill-name *skill-telemetry*) (list :executions 0 :total-time 0 :failures 0))))
|
||||
(incf (getf entry :executions)) (incf (getf entry :total-time) duration)
|
||||
(when (eq status :rejected) (incf (getf entry :failures))) (setf (gethash skill-name *skill-telemetry*) entry)))))
|
||||
(defun inject-stimulus (stimulus &key stream)
|
||||
"Entry point for all external stimuli."
|
||||
(let ((signal (list :type (getf stimulus :type)
|
||||
:payload (getf stimulus :payload)
|
||||
:status :inbound
|
||||
:reply-stream stream
|
||||
:depth 0)))
|
||||
(bt:make-thread (lambda () (process-signal signal)) :name "signal-processor")))
|
||||
|
||||
(defun kernel-log (fmt &rest args)
|
||||
"Records a formatted message to the system log and standard output."
|
||||
(let ((msg (apply #'format nil fmt args)))
|
||||
(bt:with-lock-held (*logs-lock*) (push msg *system-logs*) (when (> (length *system-logs*) *max-log-history*) (setf *system-logs* (subseq *system-logs* 0 *max-log-history*))))
|
||||
(format t "~a~%" msg) (finish-output)))
|
||||
|
||||
(defun inject-stimulus (raw-message &key stream (depth 0))
|
||||
"Enqueues a raw message into the reactive signal pipeline, handling async/sync execution and recovery."
|
||||
(let* ((payload (getf raw-message :payload))
|
||||
(sensor (getf payload :sensor))
|
||||
;; Force Chat and Delegation to be async
|
||||
(async-p (or (getf payload :async-p) (member sensor '(:chat-message :delegation :user-command)))))
|
||||
(when stream (setf (getf raw-message :reply-stream) stream))
|
||||
(if async-p (bt:make-thread (lambda () (restart-case (handler-bind ((error (lambda (c) (kernel-log "ASYNC ERROR: ~a" c) (invoke-restart 'skip-event))))
|
||||
(process-signal raw-message)) (skip-event () nil))) :name "org-agent-async-task")
|
||||
(restart-case (handler-bind ((error (lambda (c) (kernel-log "SYSTEM ERROR: ~a" c) (invoke-restart 'skip-event)))) (process-signal raw-message))
|
||||
(skip-event () (kernel-log "SYSTEM RECOVERY: Stimulus dropped.~%"))))))
|
||||
|
||||
(defun execute-system-action (action context)
|
||||
"Processes internal kernel commands like skill creation or environment updates."
|
||||
(declare (ignore context))
|
||||
(let* ((payload (ignore-errors (getf action :payload))) (cmd (ignore-errors (getf payload :action))))
|
||||
(case cmd
|
||||
(:eval (let ((code (getf payload :code)))
|
||||
(kernel-log "ACTUATOR [System] - Evaluating: ~a" code)
|
||||
(handler-case (let ((result (eval (read-from-string code))))
|
||||
(kernel-log "ACTUATOR [System] - Result: ~s" result)
|
||||
result)
|
||||
(error (c) (kernel-log "ACTUATOR ERROR [System] - Eval failed: ~a" c)))))
|
||||
(:create-skill (let* ((filename (getf payload :filename)) (content (getf payload :content))
|
||||
(skills-dir (merge-pathnames "skills/" (asdf:system-source-directory :org-agent))) (full-path (merge-pathnames filename skills-dir)))
|
||||
(kernel-log "ACTUATOR [System] - Creating skill ~a..." filename)
|
||||
(with-open-file (out full-path :direction :output :if-exists :supersede) (write-string content out))
|
||||
(load-skill-from-org full-path)))
|
||||
(:set-cascade (setf *provider-cascade* (getf payload :cascade)))
|
||||
(:message (kernel-log "ACTUATOR [System] - ~a" (getf payload :text)))
|
||||
(t (kernel-log "ACTUATOR [System] - Unknown command ~s" cmd)))))
|
||||
(defun process-signal (signal)
|
||||
"Iterative signal processing pipeline."
|
||||
(loop
|
||||
(let ((status (getf signal :status)))
|
||||
(case status
|
||||
(:inbound (setq signal (perceive-gate signal)))
|
||||
(:perceived (setq signal (neuro-gate signal)))
|
||||
(:reasoned (setq signal (consensus-gate signal)))
|
||||
(:consensus (setq signal (decide-gate signal)))
|
||||
(:decided (setq signal (dispatch-gate signal)))
|
||||
(:dispatched (return-from process-signal signal))
|
||||
(t (kernel-log "PIPELINE ERROR: Unknown status ~a" status)
|
||||
(return-from process-signal signal))))))
|
||||
|
||||
(defun perceive-gate (signal)
|
||||
"Initial processing: Normalizes raw stimuli and updates memory."
|
||||
"Stage 1: Context assembly and signal enrichment."
|
||||
(let* ((payload (getf signal :payload))
|
||||
(type (getf signal :type))
|
||||
(sensor (getf payload :sensor)))
|
||||
(kernel-log "GATE [Perceive]: ~a (~a)" type (or sensor "no-sensor"))
|
||||
(snapshot-object-store)
|
||||
(cond ((eq type :EVENT)
|
||||
(case sensor
|
||||
(:buffer-update (let ((ast (getf payload :ast))) (when ast (ingest-ast ast))))
|
||||
(:point-update (let ((element (getf payload :element))) (when element (ingest-ast element))))
|
||||
(:interrupt (bt:with-lock-held (*interrupt-lock*) (setf *interrupt-flag* t)))))
|
||||
((eq type :RESPONSE)
|
||||
(kernel-log "GATE [Perceive]: Act Result -> ~a" (getf payload :status))))
|
||||
(kernel-log "GATE [Perceive]: ~a (~a)" (getf signal :type) (or sensor "no-sensor"))
|
||||
(setf (getf signal :context) (context-assemble-global-awareness))
|
||||
(setf (getf signal :status) :perceived)
|
||||
signal))
|
||||
|
||||
(defun neuro-gate (signal)
|
||||
"System 1: Intuition and proposed actions."
|
||||
(unless (eq (getf signal :type) :EVENT)
|
||||
(return-from neuro-gate signal))
|
||||
(kernel-log "GATE [Neuro]: Consulting System 1...")
|
||||
(let ((thoughts (think signal)))
|
||||
(setf (getf signal :proposals) (if (and thoughts (listp thoughts) (listp (car thoughts)))
|
||||
thoughts
|
||||
(if thoughts (list thoughts) nil)))
|
||||
(setf (getf signal :status) :thought)
|
||||
"Stage 2: Neural reasoning (System 1)."
|
||||
(let* ((context (getf signal :context))
|
||||
(skill (find-triggered-skill signal)))
|
||||
(if skill
|
||||
(let ((neuro-fn (skill-neuro-prompt skill)))
|
||||
(if neuro-fn
|
||||
(let ((proposals (funcall neuro-fn signal)))
|
||||
(setf (getf signal :proposals) (if (listp (first proposals)) proposals (list proposals))))
|
||||
(setf (getf signal :proposals) nil)))
|
||||
(setf (getf signal :proposals) nil))
|
||||
(setf (getf signal :status) :reasoned)
|
||||
signal))
|
||||
|
||||
(defun resolve-consensus (proposals signal)
|
||||
"Resolves diverging proposals by voting or selecting the safest one."
|
||||
(declare (ignore signal))
|
||||
(kernel-log "CONSENSUS: ~a proposals found. Resolving..." (length proposals))
|
||||
;; Simplified consensus: Majority vote or first safe one
|
||||
;; For now, we'll select the proposal that appears most frequently.
|
||||
"Majority rules implementation."
|
||||
(let ((counts (make-hash-table :test 'equal)))
|
||||
(dolist (p proposals)
|
||||
(incf (gethash p counts 0)))
|
||||
@@ -133,9 +97,11 @@
|
||||
"System 2: Safety and validation."
|
||||
(let ((candidate (getf signal :candidate)))
|
||||
(if candidate
|
||||
(let ((approved (decide candidate signal)))
|
||||
(setf (getf signal :approved-action) approved)
|
||||
(unless approved (kernel-log "GATE [Decide]: REJECTED by System 2")))
|
||||
(let ((decision (decide candidate signal)))
|
||||
;; If decision is different from candidate, it's an interception (EVENT or LOG)
|
||||
(setf (getf signal :approved-action) decision)
|
||||
(unless (equal decision candidate)
|
||||
(kernel-log "GATE [Decide]: Intercepted/Rejected by System 2")))
|
||||
(setf (getf signal :approved-action) nil))
|
||||
(setf (getf signal :status) :decided)
|
||||
signal))
|
||||
@@ -149,93 +115,16 @@
|
||||
(case type
|
||||
(:REQUEST (dispatch-action signal signal))
|
||||
(:EVENT
|
||||
(when approved
|
||||
(let* ((payload (getf approved :payload))
|
||||
(target (getf approved :target))
|
||||
(action (or (getf payload :action) (getf approved :action)))
|
||||
(tool-name (or (getf payload :tool) (getf approved :tool)))
|
||||
(tool-args (or (getf payload :args) (getf approved :args))))
|
||||
(if (and (eq target :tool) (eq action :call))
|
||||
(let ((tool (gethash (string-downcase (string tool-name)) *cognitive-tools*)))
|
||||
(if tool
|
||||
(handler-case
|
||||
(let* ((clean-args (if (and (listp tool-args) (listp (car tool-args))) (car tool-args) tool-args))
|
||||
(result (funcall (cognitive-tool-body tool) clean-args)))
|
||||
(setf feedback (list :type :EVENT :depth (1+ depth) :reply-stream (getf signal :reply-stream)
|
||||
:payload (list :sensor :tool-output :result result :tool tool-name))))
|
||||
(error (c)
|
||||
(setf feedback (list :type :EVENT :depth (1+ depth) :reply-stream (getf signal :reply-stream)
|
||||
:payload (list :sensor :tool-error :tool tool-name :message (format nil "~a" c))))))
|
||||
(setf feedback (list :type :EVENT :depth (1+ depth) :reply-stream (getf signal :reply-stream)
|
||||
:payload (list :sensor :tool-error :message "Tool not found")))))
|
||||
(let ((result (dispatch-action approved signal)))
|
||||
(when (and result (not (member target '(:emacs :system-message))))
|
||||
(setf feedback (list :type :EVENT :depth (1+ depth) :reply-stream (getf signal :reply-stream)
|
||||
:payload (list :sensor :tool-output :result result :tool approved))))))))))
|
||||
(when (and approved (eq (getf approved :type) :REQUEST))
|
||||
(dispatch-action approved signal))))
|
||||
(setf (getf signal :status) :dispatched)
|
||||
feedback))
|
||||
|
||||
(defun process-signal (signal)
|
||||
"The entry point to the Reactive Signal Pipeline."
|
||||
(let ((current-signal signal))
|
||||
(loop while current-signal do
|
||||
(let ((depth (getf current-signal :depth 0)))
|
||||
(when (> depth 10)
|
||||
(kernel-log "PIPELINE ERROR: Max depth reached.")
|
||||
(return nil))
|
||||
(when (bt:with-lock-held (*interrupt-lock*) *interrupt-flag*)
|
||||
(kernel-log "PIPELINE: Interrupted.")
|
||||
(bt:with-lock-held (*interrupt-lock*) (setf *interrupt-flag* nil))
|
||||
(return nil))
|
||||
|
||||
(handler-case
|
||||
(progn
|
||||
(setf current-signal (perceive-gate current-signal))
|
||||
(setf current-signal (neuro-gate current-signal))
|
||||
(setf current-signal (consensus-gate current-signal))
|
||||
(setf current-signal (decide-gate current-signal))
|
||||
(setf current-signal (dispatch-gate current-signal)))
|
||||
(error (c)
|
||||
(kernel-log "PIPELINE CRASH: ~a - Initiating Micro-Rollback." c)
|
||||
(rollback-object-store 0)
|
||||
(let ((sensor (ignore-errors (getf (getf current-signal :payload) :sensor))))
|
||||
(if (or (> depth 2) (member sensor '(:loop-error :tool-error)))
|
||||
(setf current-signal nil)
|
||||
(setf current-signal (list :type :EVENT :depth (1+ depth) :reply-stream (getf current-signal :reply-stream)
|
||||
:payload (list :sensor :loop-error :message (format nil "~a" c) :depth depth)))))))))))
|
||||
|
||||
(defvar *heartbeat-thread* nil)
|
||||
|
||||
(defun start-heartbeat (&optional (interval 60))
|
||||
"Spawns a thread that periodically injects a heartbeat stimulus."
|
||||
(setf *heartbeat-thread*
|
||||
(bt:make-thread
|
||||
(lambda ()
|
||||
(loop
|
||||
(sleep interval)
|
||||
(kernel-log "KERNEL: Heartbeat pulse...")
|
||||
(inject-stimulus (list :type :EVENT :payload (list :sensor :heartbeat :unix-time (get-universal-time))))))
|
||||
:name "org-agent-heartbeat")))
|
||||
|
||||
(defun stop-heartbeat ()
|
||||
"Gracefully terminates the heartbeat pulse thread."
|
||||
(when (and *heartbeat-thread* (bt:thread-alive-p *heartbeat-thread*))
|
||||
(bt:destroy-thread *heartbeat-thread*)
|
||||
(setf *heartbeat-thread* nil)))
|
||||
|
||||
(defun load-all-skills ()
|
||||
"Deprecated: use initialize-all-skills. Centralized boot orchestrator."
|
||||
(initialize-all-skills))
|
||||
signal))
|
||||
|
||||
(defun main ()
|
||||
"The entry point for the compiled standalone binary."
|
||||
(let* ((home (uiop:getenv "HOME"))
|
||||
(env-file (uiop:merge-pathnames* ".local/share/org-agent/.env" (uiop:ensure-directory-pathname home))))
|
||||
(if (uiop:file-exists-p env-file)
|
||||
(progn
|
||||
(format t "KERNEL: Loading environment from ~a~%" env-file)
|
||||
(cl-dotenv:load-env env-file))
|
||||
(format t "KERNEL ERROR: .env not found at ~a~%" env-file)))
|
||||
"Production entry point for the org-agent daemon."
|
||||
(load-dotenv)
|
||||
(initialize-all-skills)
|
||||
(kernel-log "KERNEL: Org-agent v1.0 starting up...")
|
||||
(let ((interval (or (ignore-errors (parse-integer (uiop:getenv "HEARTBEAT_INTERVAL") :junk-allowed t)) 60)))
|
||||
(format t "KERNEL: Heartbeat interval set to ~a seconds.~%" interval)
|
||||
(start-daemon :interval interval))
|
||||
|
||||
@@ -69,11 +69,12 @@
|
||||
(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."
|
||||
: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."))
|
||||
(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.")
|
||||
|
||||
@@ -117,3 +117,42 @@
|
||||
;; --- Environment Config ---
|
||||
#:set-llm-model
|
||||
#:get-llm-model))
|
||||
|
||||
(in-package :org-agent)
|
||||
|
||||
(defvar *system-logs* nil)
|
||||
(defvar *logs-lock* (bt:make-lock "kernel-logs-lock"))
|
||||
(defvar *max-log-history* 100)
|
||||
|
||||
(defvar *skills-registry* (make-hash-table :test 'equal)
|
||||
"Global registry of all loaded skills.")
|
||||
|
||||
(defvar *skill-telemetry* (make-hash-table :test 'equal))
|
||||
(defvar *telemetry-lock* (bt:make-lock "kernel-telemetry-lock"))
|
||||
|
||||
(defvar *cognitive-tools* (make-hash-table :test 'equal))
|
||||
|
||||
(defstruct cognitive-tool
|
||||
name
|
||||
description
|
||||
parameters
|
||||
guard
|
||||
body)
|
||||
|
||||
(defmacro def-cognitive-tool (name description parameters &key guard body)
|
||||
`(setf (gethash (string-downcase (string ',name)) *cognitive-tools*)
|
||||
(make-cognitive-tool :name (string-downcase (string ',name))
|
||||
:description ,description
|
||||
:parameters ',parameters
|
||||
:guard ,guard
|
||||
:body ,body)))
|
||||
|
||||
(defun kernel-log (msg &rest args)
|
||||
"Centralized logging for the kernel."
|
||||
(let ((formatted-msg (apply #'format nil msg args)))
|
||||
(bt:with-lock-held (*logs-lock*)
|
||||
(push formatted-msg *system-logs*)
|
||||
(when (> (length *system-logs*) *max-log-history*)
|
||||
(setq *system-logs* (subseq *system-logs* 0 *max-log-history*))))
|
||||
(format t "~a~%" formatted-msg)
|
||||
(finish-output)))
|
||||
|
||||
@@ -44,10 +44,11 @@
|
||||
(rollback-object-store 0)
|
||||
nil))))
|
||||
|
||||
(def-cognitive-tool :repair-file "Applies a surgical code modification to a file and reloads the skill if applicable."
|
||||
:parameters ((: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"))
|
||||
(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."
|
||||
|
||||
268
src/skills.lisp
268
src/skills.lisp
@@ -1,7 +1,5 @@
|
||||
(in-package :org-agent)
|
||||
|
||||
(defvar *skills-registry* (make-hash-table :test 'equal))
|
||||
|
||||
(defstruct skill name priority dependencies trigger-fn neuro-prompt symbolic-fn)
|
||||
|
||||
(defvar *skill-catalog* (make-hash-table :test 'equal)
|
||||
@@ -13,250 +11,38 @@
|
||||
error-log
|
||||
(load-time 0))
|
||||
|
||||
(defvar *cognitive-tools* (make-hash-table :test 'equal))
|
||||
|
||||
(defstruct cognitive-tool name description parameters guard body)
|
||||
|
||||
(defmacro def-cognitive-tool (name description &key parameters guard body)
|
||||
`(setf (gethash (string-downcase (string ,name)) *cognitive-tools*)
|
||||
(make-cognitive-tool :name (string-downcase (string ,name))
|
||||
:description ,description
|
||||
:parameters ',parameters
|
||||
:guard ,guard
|
||||
:body ,body)))
|
||||
|
||||
(defun generate-tool-belt-prompt ()
|
||||
(let ((output (format nil "AVAILABLE TOOLS:
|
||||
You can call tools by returning a Lisp plist: (:target :tool :action :call :tool <name> :args (...))
|
||||
|
||||
EXAMPLES:
|
||||
(:target :tool :action :call :tool \"eval\" :args (:code \"(+ 1 1)\"))
|
||||
(:target :tool :action :call :tool \"grep-search\" :args (:pattern \"sovereignty\"))
|
||||
(:target :tool :action :call :tool \"shell\" :args (:cmd \"ls -la\"))
|
||||
|
||||
---
|
||||
")))
|
||||
(maphash (lambda (name tool)
|
||||
(setf output (concatenate 'string output
|
||||
(format nil "- ~a: ~a~% Parameters: ~s~%~%"
|
||||
name
|
||||
(cognitive-tool-description tool)
|
||||
(cognitive-tool-parameters tool)))))
|
||||
*cognitive-tools*)
|
||||
output))
|
||||
(defun find-triggered-skill (context)
|
||||
"Returns the highest priority skill whose trigger condition matches the context."
|
||||
(let ((matched-skills nil))
|
||||
(maphash (lambda (name skill)
|
||||
(declare (ignore name))
|
||||
(let ((trigger-fn (skill-trigger-fn skill)))
|
||||
(when (and trigger-fn (funcall trigger-fn context))
|
||||
(push skill matched-skills))))
|
||||
*skills-registry*)
|
||||
(first (sort matched-skills #'> :key #'skill-priority))))
|
||||
|
||||
(defmacro defskill (name &key priority dependencies trigger neuro symbolic)
|
||||
`(setf (gethash ,(string-downcase (string name)) *skills-registry*)
|
||||
(make-skill :name ,(string-downcase (string name)) :priority (or ,priority 10) :dependencies ,dependencies
|
||||
:trigger-fn ,trigger :neuro-prompt ,neuro :symbolic-fn ,symbolic)))
|
||||
(make-skill :name ,(string-downcase (string name)) :priority (or ,priority 10) :dependencies ,dependencies :trigger-fn ,trigger :neuro-prompt ,neuro :symbolic-fn ,symbolic)))
|
||||
|
||||
(defun find-triggered-skill (context)
|
||||
(let ((triggered nil))
|
||||
(maphash (lambda (name skill) (declare (ignore name)) (when (ignore-errors (funcall (skill-trigger-fn skill) context)) (push skill triggered))) *skills-registry*)
|
||||
(first (sort triggered #'> :key #'skill-priority))))
|
||||
|
||||
(defun resolve-skill-dependencies (skill-name)
|
||||
(let ((resolved nil) (seen nil))
|
||||
(labels ((visit (name) (unless (member name seen :test #'equal) (push name seen)
|
||||
(let ((skill (gethash (string-downcase (string name)) *skills-registry*)))
|
||||
(when skill (dolist (dep (skill-dependencies skill)) (visit dep))))
|
||||
(push name resolved))))
|
||||
(visit skill-name) (nreverse resolved))))
|
||||
|
||||
(defun parse-skill-metadata (filepath)
|
||||
"Extracts ID and DEPENDS_ON tags using robust line-scanning."
|
||||
(let ((dependencies nil)
|
||||
(id nil))
|
||||
(with-open-file (stream filepath)
|
||||
(loop for line = (read-line stream nil :eof)
|
||||
until (eq line :eof)
|
||||
do (let ((clean (string-trim '(#\Space #\Tab #\Return #\Newline) line)))
|
||||
(cond
|
||||
((uiop:string-prefix-p "#+DEPENDS_ON:" (string-upcase clean))
|
||||
(let* ((deps-part (string-trim " " (subseq clean 13))))
|
||||
(setf dependencies (append dependencies
|
||||
(mapcar (lambda (s) (string-trim "[] " s))
|
||||
(uiop:split-string deps-part :separator '(#\Space #\Tab)))))))
|
||||
((uiop:string-prefix-p ":ID:" (string-upcase clean))
|
||||
(setf id (string-trim '(#\Space #\Tab) (subseq clean 4))))))))
|
||||
(values id (remove-if (lambda (s) (= 0 (length s))) dependencies))))
|
||||
|
||||
(defun topological-sort-skills (skills-dir)
|
||||
"Returns a list of skill filepaths sorted by dependency (dependencies first)."
|
||||
(let ((files (uiop:directory-files skills-dir "org-skill-*.org"))
|
||||
(adj (make-hash-table :test 'equal))
|
||||
(id-to-file (make-hash-table :test 'equal))
|
||||
(result nil)
|
||||
(visited (make-hash-table :test 'equal))
|
||||
(stack (make-hash-table :test 'equal)))
|
||||
(dolist (file files)
|
||||
(let ((filename (pathname-name file)))
|
||||
(multiple-value-bind (id deps) (parse-skill-metadata file)
|
||||
(setf (gethash (string-downcase filename) id-to-file) file)
|
||||
(when id (setf (gethash (string-downcase id) id-to-file) file))
|
||||
(setf (gethash (string-downcase filename) adj) deps))))
|
||||
(labels ((visit (file)
|
||||
(let* ((filename (pathname-name file))
|
||||
(node-key (string-downcase filename)))
|
||||
(unless (gethash node-key visited)
|
||||
(setf (gethash node-key stack) t)
|
||||
(dolist (dep (gethash node-key adj))
|
||||
(let* ((dep-id (if (and (> (length dep) 3) (uiop:string-prefix-p "id:" (string-downcase dep)))
|
||||
(subseq dep 3)
|
||||
dep))
|
||||
(dep-file (gethash (string-downcase dep-id) id-to-file)))
|
||||
(when dep-file
|
||||
(let ((dep-filename (pathname-name dep-file)))
|
||||
(if (gethash (string-downcase dep-filename) stack)
|
||||
(error "Circular dependency detected: ~a -> ~a" filename dep-filename)
|
||||
(visit dep-file))))))
|
||||
(setf (gethash node-key stack) nil)
|
||||
(setf (gethash node-key visited) t)
|
||||
(push file result)))))
|
||||
(let ((filenames (sort (mapcar #'pathname-name files) #'string<)))
|
||||
(dolist (name filenames)
|
||||
(let ((file (gethash (string-downcase name) id-to-file)))
|
||||
(when file (visit file)))))
|
||||
result)))
|
||||
|
||||
(defun load-skill-from-org (filepath)
|
||||
"Parses and evaluates Lisp blocks from an Org file into a jailed package."
|
||||
(let* ((skill-base-name (pathname-name filepath))
|
||||
(entry (or (gethash skill-base-name *skill-catalog*) (make-skill-entry :filename skill-base-name))))
|
||||
(setf (skill-entry-status entry) :loading)
|
||||
(setf (gethash skill-base-name *skill-catalog*) entry)
|
||||
|
||||
(defun load-skill-from-org (path)
|
||||
"Extracts Lisp source from an Org file and evaluates it."
|
||||
(let ((skill-name (pathname-name path)))
|
||||
(handler-case
|
||||
(let* ((content (uiop:read-file-string filepath))
|
||||
(lines (uiop:split-string content :separator '(#\Newline)))
|
||||
(in-lisp-block nil)
|
||||
(lisp-code "")
|
||||
(pkg-name (intern (string-upcase (format nil "ORG-AGENT.SKILLS.~a" skill-base-name)) :keyword)))
|
||||
|
||||
(dolist (line lines)
|
||||
(let ((clean-line (string-trim '(#\Space #\Tab #\Return) line)))
|
||||
(cond ((uiop:string-prefix-p "#+begin_src lisp" (string-downcase clean-line)) (setf in-lisp-block t))
|
||||
((uiop:string-prefix-p "#+end_src" (string-downcase clean-line)) (setf in-lisp-block nil))
|
||||
(in-lisp-block (setf lisp-code (concatenate 'string lisp-code line (string #\Newline)))))))
|
||||
|
||||
(if (= (length lisp-code) 0)
|
||||
(progn (setf (skill-entry-status entry) :ready) t) ;; Valid empty skill
|
||||
(progn
|
||||
;; PRE-FLIGHT: Syntax Validation
|
||||
(multiple-value-bind (valid-p err) (validate-lisp-syntax lisp-code)
|
||||
(unless valid-p
|
||||
(error "Syntax Error: ~a" err)))
|
||||
|
||||
(kernel-log "KERNEL: Jailing skill '~a' in package ~a" skill-base-name pkg-name)
|
||||
(unless (find-package pkg-name)
|
||||
(let ((new-pkg (make-package pkg-name :use '(:cl))))
|
||||
(do-external-symbols (sym (find-package :org-agent)) (shadowing-import sym new-pkg))))
|
||||
|
||||
(let ((*read-eval* nil) (*package* (find-package pkg-name)))
|
||||
(eval (read-from-string (format nil "(progn ~a)" lisp-code))))
|
||||
|
||||
(setf (skill-entry-status entry) :ready)
|
||||
t)))
|
||||
(let ((source (uiop:read-file-string path)))
|
||||
(cl-ppcre:do-register-groups (code) ("#\\+begin_src lisp.*\\n([\\s\\S]*?)\\n#\\+end_src" source)
|
||||
(let ((*package* (find-package :org-agent)))
|
||||
(eval (read-from-string (concatenate 'string "(progn " code ")")))))
|
||||
(setf (gethash skill-name *skill-catalog*) (make-skill-entry :filename path :status :ready :load-time (get-universal-time)))
|
||||
(kernel-log "SKILL [Loader] - Successfully loaded ~a" skill-name))
|
||||
(error (c)
|
||||
(let ((msg (format nil "~a" c)))
|
||||
(kernel-log "LOADER ERROR in skill '~a': ~a" skill-base-name msg)
|
||||
(setf (skill-entry-status entry) :failed)
|
||||
(setf (skill-entry-error-log entry) msg)
|
||||
nil)))))
|
||||
|
||||
(defun load-skill-with-timeout (filepath timeout-seconds)
|
||||
"Loads a skill Org file with a hard execution timeout."
|
||||
(let* ((finished nil)
|
||||
(thread (bt:make-thread (lambda ()
|
||||
(if (load-skill-from-org filepath)
|
||||
(setf finished t)
|
||||
(setf finished :error)))
|
||||
:name (format nil "loader-~a" (pathname-name filepath))))
|
||||
(start-time (get-internal-real-time))
|
||||
(timeout-units (truncate (* timeout-seconds internal-time-units-per-second))))
|
||||
(loop
|
||||
(when (eq finished t) (return :success))
|
||||
(when (eq finished :error) (return :error))
|
||||
(unless (bt:thread-alive-p thread) (return :error))
|
||||
(when (> (- (get-internal-real-time) start-time) timeout-units)
|
||||
(kernel-log "KERNEL: Timing out skill ~a..." (pathname-name filepath))
|
||||
#+sbcl (sb-thread:terminate-thread thread)
|
||||
#-sbcl (bt:destroy-thread thread)
|
||||
(return :timeout))
|
||||
(sleep 0.05))))
|
||||
(kernel-log "SKILL ERROR [Loader] - Failed to load ~a: ~a" skill-name c)
|
||||
(setf (gethash skill-name *skill-catalog*) (make-skill-entry :filename path :status :failed :error-log (format nil "~a" c)))))))
|
||||
|
||||
(defun initialize-all-skills ()
|
||||
"Scans the directory defined by SKILLS_DIR and hot-loads skills using topological order."
|
||||
(let* ((env-path (uiop:getenv "SKILLS_DIR"))
|
||||
(skills-dir-str (or env-path (namestring (merge-pathnames "notes/" (user-homedir-pathname)))))
|
||||
(resolved-path (context-resolve-path skills-dir-str))
|
||||
(skills-dir (if resolved-path (uiop:ensure-directory-pathname resolved-path) nil)))
|
||||
|
||||
(unless (and skills-dir (uiop:directory-exists-p skills-dir))
|
||||
(kernel-log "KERNEL ERROR: Skills directory not found: ~a" skills-dir-str)
|
||||
(return-from initialize-all-skills nil))
|
||||
|
||||
(let ((sorted-files (topological-sort-skills skills-dir)))
|
||||
;; MANDATE: The Executive Soul must be present
|
||||
(unless (member "org-skill-agent" sorted-files :key #'pathname-name :test #'string-equal)
|
||||
(error "BOOT FAILURE: org-skill-agent.org not found in skills directory."))
|
||||
|
||||
(kernel-log "==================================================")
|
||||
(kernel-log " LOADER: Initializing ~a skills..." (length sorted-files))
|
||||
|
||||
(dolist (file sorted-files)
|
||||
(let ((skill-name (pathname-name file)))
|
||||
(kernel-log " LOADER: Loading ~a..." skill-name)
|
||||
(load-skill-with-timeout file 5)))
|
||||
|
||||
;; Final Summary
|
||||
(let ((ready 0) (failed 0))
|
||||
(maphash (lambda (k v)
|
||||
(declare (ignore k))
|
||||
(if (eq (skill-entry-status v) :ready) (incf ready) (incf failed)))
|
||||
*skill-catalog*)
|
||||
(kernel-log " LOADER: Boot Complete. [Ready: ~a] [Failed: ~a]" ready failed)
|
||||
(kernel-log "==================================================")
|
||||
(values ready failed)))))
|
||||
|
||||
(defun validate-lisp-syntax (code-string)
|
||||
"Checks if a string contains valid, readable Common Lisp forms."
|
||||
(handler-case (let ((*read-eval* nil)) (with-input-from-string (stream (format nil "(progn ~a)" code-string))
|
||||
(loop for form = (read stream nil :eof) until (eq form :eof)) (values t nil)))
|
||||
(error (c) (values nil (format nil "~a" c)))))
|
||||
|
||||
(def-cognitive-tool :eval "Evaluates raw Common Lisp code in the kernel image. Use this for complex calculations or internal state inspection."
|
||||
:parameters ((:code :type :string :description "The Lisp code to evaluate"))
|
||||
:guard (lambda (args context)
|
||||
(declare (ignore context))
|
||||
(let ((code (getf args :code)))
|
||||
(let ((harness-pkg (find-package :org-agent.skills.org-skill-safety-harness)))
|
||||
(if harness-pkg
|
||||
(uiop:symbol-call :org-agent.skills.org-skill-safety-harness :safety-harness-validate code)
|
||||
t))))
|
||||
:body (lambda (args)
|
||||
(let ((code (getf args :code)))
|
||||
(handler-case (let ((result (eval (read-from-string code))))
|
||||
(format nil "~s" result))
|
||||
(error (c) (format nil "ERROR: ~a" c))))))
|
||||
|
||||
(def-cognitive-tool :grep-search "Searches for a pattern in the project files."
|
||||
:parameters ((:pattern :type :string :description "The regex pattern to search for")
|
||||
(:dir :type :string :description "Directory to search in (default is project root)"))
|
||||
:body (lambda (args)
|
||||
(let ((pattern (getf args :pattern))
|
||||
(dir (or (getf args :dir) (uiop:getenv "MEMEX_DIR"))))
|
||||
(uiop:run-program (list "grep" "-r" "-n" "--exclude-dir=node_modules" pattern dir)
|
||||
:output :string :ignore-error-status t))))
|
||||
|
||||
(def-cognitive-tool :shell "Executes a shell command on the local machine. Use this for file operations, system checks, or running tests."
|
||||
:parameters ((:cmd :type :string :description "The full bash command to execute"))
|
||||
:guard (lambda (args context)
|
||||
(declare (ignore context))
|
||||
(let ((cmd (getf args :cmd)))
|
||||
(not (or (search "rm -rf /" cmd) (search ":(){ :|:& };:" cmd)))))
|
||||
:body (lambda (args)
|
||||
(let ((cmd (getf args :cmd)))
|
||||
(multiple-value-bind (out err code)
|
||||
(uiop:run-program (list "bash" "-c" cmd) :output :string :error-output :string :ignore-error-status t)
|
||||
(format nil "EXIT-CODE: ~a~%~%STDOUT:~%~a~%~%STDERR:~%~a" code out err)))))
|
||||
"Discovers and loads all .org skills from the project directory."
|
||||
(let ((skill-dir (or (uiop:getenv "SKILLS_DIR") "projects/org-agent/skills/")))
|
||||
(ensure-directories-exist skill-dir)
|
||||
(dolist (path (uiop:directory-files skill-dir "*.org"))
|
||||
(load-skill-from-org path))))
|
||||
|
||||
@@ -14,20 +14,6 @@
|
||||
(return-from task-integrity-check "Blocked by Task Integrity: Active children exist."))))
|
||||
nil))
|
||||
|
||||
(defun bouncer-check (action)
|
||||
"Checks if an action requires manual authorization."
|
||||
(let* ((payload (getf action :payload))
|
||||
(target (getf action :target))
|
||||
(act (or (getf payload :action) (getf action :action)))
|
||||
(tool (or (getf payload :tool) (getf action :tool)))
|
||||
(approved (getf action :approved)))
|
||||
(when (and (not approved)
|
||||
(or (and (eq target :tool) (equal tool "shell"))
|
||||
(and (eq target :emacs) (eq act :eval))
|
||||
(and (eq target :tool) (equal tool "repair-file"))))
|
||||
(return-from bouncer-check t))
|
||||
nil))
|
||||
|
||||
(defun decide (proposed-action context)
|
||||
"The System 2 Safety Gate: validates or rejects proposed neural actions."
|
||||
;; 1. Task Integrity Check (GTD Semantics)
|
||||
@@ -36,14 +22,26 @@
|
||||
(kernel-log "SYSTEM 2 [INTEGRITY]: ~a~%" integrity-error)
|
||||
(return-from decide (list :type :LOG :payload (list :text integrity-error)))))
|
||||
|
||||
;; 2. Bouncer Check (Authorization Gate)
|
||||
(when (bouncer-check proposed-action)
|
||||
(kernel-log "SYSTEM 2 [BOUNCER]: Action requires manual approval.~%")
|
||||
(return-from decide
|
||||
(list :type :EVENT
|
||||
:payload (list :sensor :approval-required :action proposed-action))))
|
||||
;; 2. Bouncer Check (DPI & Authorization)
|
||||
;; All actions pass through the Bouncer skill logic first if it's loaded
|
||||
(let* ((bouncer-skill (gethash "skill-bouncer" *skills-registry*))
|
||||
(bouncer-fn (when bouncer-skill (skill-symbolic-fn bouncer-skill))))
|
||||
(when bouncer-fn
|
||||
(let ((bouncer-decision (funcall bouncer-fn proposed-action context)))
|
||||
(unless (equal bouncer-decision proposed-action)
|
||||
(kernel-log "SYSTEM 2 [BOUNCER]: Action intercepted.~%")
|
||||
(return-from decide bouncer-decision)))))
|
||||
|
||||
;; 3. Skill-specific and Safety Checks
|
||||
;; 3. Formal Verification Gate
|
||||
(let* ((formal-skill (gethash "skill-formal-verification" *skills-registry*))
|
||||
(formal-fn (when formal-skill (skill-symbolic-fn formal-skill))))
|
||||
(when formal-fn
|
||||
(let ((formal-decision (funcall formal-fn proposed-action context)))
|
||||
(unless (equal formal-decision proposed-action)
|
||||
(kernel-log "SYSTEM 2 [FORMAL]: Action intercepted.~%")
|
||||
(return-from decide formal-decision)))))
|
||||
|
||||
;; 4. Skill-specific and Safety Checks
|
||||
(let ((active-skill (find-triggered-skill context)))
|
||||
(if (and proposed-action (listp proposed-action) active-skill)
|
||||
(let* ((symbolic-gate (skill-symbolic-fn active-skill))
|
||||
|
||||
Reference in New Issue
Block a user