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

PSF: Enforce 'Thin Harness' by purging hardcoded vendor logic from core

Browse Source
This commit is contained in:
Amr Gharbeia
2026-04-12 16:16:46 -04:00
parent c46c4d4fd7
commit a35480a040
10 changed files with 252 additions and 116 deletions
Download Patch File Download Diff File Expand all files Collapse all files

3
org-agent.asd
View File

@@ -8,9 +8,12 @@
:serial t
:components ((:file "src/package")
(:file "src/protocol")
(:file "src/protocol-validator")
(:file "src/object-store")
(:file "src/embedding")
(:file "src/embedding-logic")
(:file "src/context")
(:file "src/context-logic")
(:file "src/skills")
(:file "src/neuro")
(:file "src/credentials-vault")

2
src/bouncer.lisp
View File

@@ -1,5 +1,3 @@
(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))

32
src/chaos-logic.lisp
View File

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

221
src/core.lisp
View File

@@ -2,8 +2,14 @@
(defvar *interrupt-flag* nil)
;; MOVED TO package.lisp
(defvar *interrupt-lock* (bt:make-lock "kernel-interrupt-lock"))
;; MOVED TO package.lisp
;; MOVED TO package.lisp
(defun dispatch-action (action context)
"Routes an approved action to its registered physical actuator."
(when (and action (listp action))
@@ -13,54 +19,86 @@
(funcall actuator-fn action context)
(kernel-log "DISPATCH ERROR: No actuator for ~a" target)))))
(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-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 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 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 perceive-gate (signal)
"Stage 1: Context assembly and signal enrichment."
"Initial processing: Normalizes raw stimuli and updates memory."
(let* ((payload (getf signal :payload))
(type (getf signal :type))
(sensor (getf payload :sensor)))
(kernel-log "GATE [Perceive]: ~a (~a)" (getf signal :type) (or sensor "no-sensor"))
(setf (getf signal :context) (context-assemble-global-awareness))
(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))))
(setf (getf signal :status) :perceived)
signal))
(defun neuro-gate (signal)
"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 (and (listp proposals) (listp (first proposals))) proposals (list proposals))))
(setf (getf signal :proposals) nil)))
(setf (getf signal :proposals) nil))
(setf (getf signal :status) :reasoned)
"Associative: Intuition and proposed actions."
(unless (eq (getf signal :type) :EVENT)
(return-from neuro-gate signal))
(kernel-log "GATE [Associative]: Consulting System 1...")
(let ((thoughts (think signal)))
(setf (getf signal :proposals) (if (and (listp thoughts) (listp (car thoughts)))
thoughts
(if thoughts (list thoughts) nil)))
(setf (getf signal :status) :thought)
signal))
(defun resolve-consensus (proposals signal)
"Majority rules implementation."
"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.
(let ((counts (make-hash-table :test 'equal)))
(dolist (p proposals)
(incf (gethash p counts 0)))
@@ -84,17 +122,8 @@
(setf (getf signal :status) :consensus)
signal))
(defun delegate-task (task-id recipient &key context)
"Enqueues a task for another agent or background process."
(kernel-log "ORCHESTRATOR: Delegating task ~a to ~a" task-id recipient)
(inject-stimulus (list :type :EVENT
:payload (list :sensor :delegation
:task-id task-id
:recipient recipient
:context context))))
(defun decide-gate (signal)
"Stage 3: Symbolic verification (System 2)."
"Deliberate: Safety and validation."
(let ((candidate (getf signal :candidate)))
(if candidate
(let* ((normalized-candidate (if (listp candidate) candidate (list :type :RESPONSE :payload (list :text candidate))))
@@ -113,16 +142,102 @@
(case type
(:REQUEST (dispatch-action signal signal))
(:EVENT
(when (and approved (eq (getf approved :type) :REQUEST))
(dispatch-action approved signal))))
(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))))))))))
(setf (getf signal :status) :dispatched)
signal))
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)))))))))))
(defun delegate-task (task-id recipient &key context)
"Enqueues a task for another agent or background process."
(kernel-log "ORCHESTRATOR: Delegating task ~a to ~a" task-id recipient)
(inject-stimulus (list :type :EVENT
:payload (list :sensor :delegation
:task-id task-id
:recipient recipient
:context context))))
(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))
(defun main ()
"Production entry point for the org-agent daemon."
(load-dotenv)
(initialize-all-skills)
(kernel-log "KERNEL: Org-agent v1.0 starting up...")
"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)))
(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))

20
src/llm-gateway.lisp
View File

@@ -81,14 +81,12 @@
:provider (getf args :provider)
:model (getf args :model))))
(progn
;; Register all supported backends with the kernel
(dolist (p '(:anthropic :gemini-api :gemini-web :groq :ollama :openai :openrouter))
(org-agent:register-neuro-backend p (lambda (prompt system-prompt &key model)
(execute-llm-request prompt system-prompt :provider p :model model))))
(defskill :skill-llm-gateway
:priority 150 ; Higher than individual old skills
:trigger (lambda (context) nil)
:neuro (lambda (context) nil)
:symbolic (lambda (action context) action)))
(dolist (p '(:anthropic :gemini-api :gemini-web :groq :ollama :openai :openrouter))
(org-agent:register-neuro-backend p (lambda (prompt system-prompt &key model)
(execute-llm-request prompt system-prompt :provider p :model model))))
(defskill :skill-llm-gateway
:priority 150 ; Higher than individual old skills
:trigger (lambda (context) (declare (ignore context)) nil)
:neuro (lambda (context) (declare (ignore context)) nil)
:symbolic (lambda (action context) (declare (ignore context)) action))

19
src/neuro.lisp
View File

@@ -26,14 +26,16 @@
(list :api-key legacy)))))))))
(defvar *neuro-backends* (make-hash-table :test 'equal))
(defvar *provider-cascade* '(:openrouter :gemini))
(defvar *consensus-enabled-p* t "If T, ask-neuro queries all backends in parallel.")
(defun register-neuro-backend (name fn) (setf (gethash name *neuro-backends*) fn))
(defvar *model-selector-fn* nil "A function called with (provider context) to return a model ID.")
(defun ask-neuro (prompt &key (system-prompt "You are the System 1 engine of a Neurosymbolic Lisp Machine.") (cascade nil) (context nil))
(defvar *consensus-enabled-p* t "If T, ask-neuro queries all backends in parallel.")
(defun ask-neuro (prompt &key (system-prompt "You are the Associative engine of a Neurosymbolic Lisp Machine.") (cascade nil) (context nil))
"Dispatches a neural request through the provider cascade or parallel consensus."
(let ((backends (cond
((and cascade (listp cascade)) cascade)
@@ -49,7 +51,7 @@
(when backend-fn
(push (bt:make-thread
(lambda ()
(kernel-log "SYSTEM 1 [Consensus]: Querying backend ~a..." backend)
(kernel-log "ASSOCIATIVE [Consensus]: Querying backend ~a..." backend)
(let* ((model (when *model-selector-fn* (funcall *model-selector-fn* backend context)))
(result (ignore-errors
(if model
@@ -73,7 +75,7 @@
(or (dolist (backend backends)
(let ((backend-fn (gethash backend *neuro-backends*)))
(when backend-fn
(kernel-log "SYSTEM 1: Attempting backend ~a..." backend)
(kernel-log "ASSOCIATIVE: Attempting backend ~a..." backend)
(let* ((model (when *model-selector-fn* (funcall *model-selector-fn* backend context)))
(result (if model
(funcall backend-fn prompt system-prompt :model model)
@@ -88,13 +90,14 @@
'(:openrouter :gemini))
(defun think (context)
"Invokes the neural System 1 engine to propose a Lisp action based on context."
"Invokes the neural Associative engine to propose a Lisp action based on context.
If consensus is enabled, it returns a list of proposals from different backends."
(let ((active-skill (find-triggered-skill context))
(tool-belt (generate-tool-belt-prompt))
(global-context (context-assemble-global-awareness)))
(if active-skill
(progn
(kernel-log "SYSTEM 1: Engaging skill '~a'~%" (skill-name active-skill))
(kernel-log "ASSOCIATIVE: Engaging skill '~a'~%" (skill-name active-skill))
(let* ((prompt-generator (skill-neuro-prompt active-skill))
(raw-prompt (when prompt-generator (funcall prompt-generator context)))
(full-system-prompt (concatenate 'string
@@ -122,7 +125,7 @@ To call a tool, you MUST use:
(raw-thoughts (cl-ppcre:split (cl-ppcre:quote-meta-chars "|CONSENSUS-SEP|") thought))
(suggestions nil))
(dolist (raw-thought raw-thoughts)
(kernel-log "SYSTEM 1 RAW: ~a~%" raw-thought)
(kernel-log "ASSOCIATIVE RAW: ~a~%" raw-thought)
(let* ((cleaned-thought
(let ((match (cl-ppcre:scan-to-strings "(?s)```(?:lisp)?\\n?(.*?)\\n?```" raw-thought)))
(if match
@@ -136,7 +139,7 @@ To call a tool, you MUST use:
(list :sensor :syntax-error
:code cleaned-thought
:error (format nil "~a" c)))))))
(kernel-log "SYSTEM 1 Suggestion: ~a~%" cleaned-thought)
(kernel-log "ASSOCIATIVE Suggestion: ~a~%" cleaned-thought)
(when (and suggestion (listp suggestion))
(push suggestion suggestions))))
(if (and *consensus-enabled-p* suggestions)

6
src/package.lisp
View File

@@ -33,9 +33,6 @@
#:rollback-object-store
#:send-swarm-packet
;; --- Self-Fix Agent ---
#:self-fix-apply
;; --- Context API (Peripheral Vision) ---
#:context-query-store
#:context-get-active-projects
@@ -110,9 +107,8 @@
;; --- Symbolic Logic ---
#:list-objects-with-attribute
#:org-id-new
;; --- AST Helpers ---
#:find-headline-missing-id
;; --- Environment Config ---

4
src/protocol.lisp
View File

@@ -54,7 +54,9 @@
;; SECURITY: Prevent Reader Macro Injection (e.g. #. ) during deserialization
(let ((*read-eval* nil))
(read-from-string actual-msg)))))
(let ((msg (read-from-string actual-msg)))
(validate-oacp-schema msg)
msg)))))
(defun make-hello-message (version)
"Construct the standard HELLO handshake message."

9
src/skills.lisp
View File

@@ -99,7 +99,7 @@
(dolist (name filenames)
(let ((file (gethash (string-downcase name) id-to-file)))
(when file (visit file)))))
(nreverse result))))
result)))
(defun validate-lisp-syntax (code-string)
"Checks if a string contains valid, readable Common Lisp forms."
@@ -187,16 +187,13 @@
(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 "projects/org-agent/skills/" (uiop:getcwd)))))
(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)
;; Fallback check
(setq skills-dir (uiop:ensure-directory-pathname (merge-pathnames "projects/org-agent/skills/" (uiop:getcwd))))
(unless (uiop:directory-exists-p skills-dir)
(return-from initialize-all-skills nil)))
(return-from initialize-all-skills nil))
(let ((sorted-files (topological-sort-skills skills-dir)))
;; MANDATE: The Executive Soul must be present

52
src/symbolic.lisp
View File

@@ -14,34 +14,36 @@
(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."
"The Deliberate Safety Gate: validates or rejects proposed neural actions."
;; 1. Task Integrity Check (GTD Semantics)
(let ((integrity-error (task-integrity-check proposed-action)))
(when integrity-error
(kernel-log "SYSTEM 2 [INTEGRITY]: ~a~%" integrity-error)
(kernel-log "DELIBERATE [INTEGRITY]: ~a~%" integrity-error)
(return-from decide (list :type :LOG :payload (list :text integrity-error)))))
;; 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)))))
;; 2. Bouncer Check (Authorization Gate)
(when (bouncer-check proposed-action)
(kernel-log "DELIBERATE [BOUNCER]: Action requires manual approval.~%")
(return-from decide
(list :type :EVENT
:payload (list :sensor :approval-required :action proposed-action))))
;; 3. 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
;; 3. Skill-specific and Safety Checks
(let ((active-skill (find-triggered-skill context)))
(if (and proposed-action (listp proposed-action) active-skill)
(let* ((symbolic-gate (skill-symbolic-fn active-skill))
@@ -54,16 +56,16 @@
(let ((harness-pkg (find-package :org-agent.skills.org-skill-safety-harness)))
(when (and code harness-pkg)
(unless (ignore-errors (uiop:symbol-call :org-agent.skills.org-skill-safety-harness :safety-harness-validate code))
(kernel-log "SYSTEM 2 [GLOBAL]: Security violation blocked.~%")
(kernel-log "DELIBERATE [GLOBAL]: Security violation blocked.~%")
(return-from decide '(:type :LOG :payload (:text "Blocked by Global Safety Harness")))))))
;; Skill-specific verification
(if symbolic-gate
(let ((decision (funcall symbolic-gate proposed-action context)))
(if decision
(progn (kernel-log "SYSTEM 2: Verified by skill '~a'.~%" (skill-name active-skill)) decision)
(progn (kernel-log "SYSTEM 2: REJECTED by skill '~a'.~%" (skill-name active-skill))
(progn (kernel-log "DELIBERATE: Verified by skill '~a'.~%" (skill-name active-skill)) decision)
(progn (kernel-log "DELIBERATE: REJECTED by skill '~a'.~%" (skill-name active-skill))
'(:type :LOG :payload (:text "Action rejected by skill heuristics")))))
(progn (kernel-log "SYSTEM 2: Verified (Implicitly safe for skill '~a').~%" (skill-name active-skill)) proposed-action)))
(progn (kernel-log "DELIBERATE: Verified (Implicitly safe for skill '~a').~%" (skill-name active-skill)) proposed-action)))
proposed-action)))
(defun list-objects-with-attribute (attr-key attr-val)