diff --git a/harness/act.org b/harness/act.org index 343e3b2..1891efa 100644 --- a/harness/act.org +++ b/harness/act.org @@ -262,7 +262,7 @@ Example feedback chain: :DEPTH (1+ depth) :META meta :PAYLOAD (list :SENSOR :tool-error - :MESSAGE (format nil "Tool '~a' not found" tool-name))))) + :MESSAGE (format nil "Tool '~a' not found" tool-name)))))) #+end_src ** format-tool-result: Human-Readable Output diff --git a/harness/loop.org b/harness/loop.org index f4cdc48..00c7928 100644 --- a/harness/loop.org +++ b/harness/loop.org @@ -202,7 +202,7 @@ The heartbeat thread ensures the agent remains alive even without external input :payload (list :sensor :heartbeat :unix-time (get-universal-time))))) - :name "opencortex-heartbeat")))) + :name "opencortex-heartbeat"))))) #+end_src * Main Entry Point diff --git a/harness/memory.org b/harness/memory.org index 3ea89b3..30c22ad 100644 --- a/harness/memory.org +++ b/harness/memory.org @@ -202,12 +202,7 @@ These tests verify the Memory system. Run with: (let* ((ast-v2 '(:type :HEADLINE :properties (:ID "cow-node" :TITLE "State B") :contents nil)) (id-v2 (ingest-ast ast-v2)) (hash-v2 (org-object-hash (lookup-object id-v2)))) - (is (equal (org-object-hash (lookup-object "cow-node")) hash-v2)) - (rollback-memory 0) - (is (equal (org-object-hash (lookup-object "cow-node")) hash-v1)) - (is (not (null (gethash hash-v2 *history-store*)))))) -#+end_src - + ** Disk Persistence (save-memory / load-memory) Essential for surviving crashes. Saves the in-memory hash tables to disk and loads them back on restart. The path is controlled by the `MEMORY_SNAPSHOT_PATH` environment variable. @@ -445,7 +440,7 @@ Following the Engineering Standards, the Memory must be empirically verified thr (let* ((ast-v1 '(:type :HEADLINE :properties (:ID "cow-node" :TITLE "State A") :contents nil)) (id-v1 (ingest-ast ast-v1)) (hash-v1 (org-object-hash (lookup-object id-v1)))) - + ;; Take a snapshot at State A (snapshot-memory) @@ -463,7 +458,7 @@ Following the Engineering Standards, the Memory must be empirically verified thr (is (equal (org-object-hash (lookup-object "cow-node")) hash-v1)) ;; Verify State B is still safely in the history store (no data loss) - (is (not (null (gethash hash-v2 *history-store*)))))) + (is (not (null (gethash hash-v2 *history-store*))))))) (test merkle-hash-consistency "Verify that identical ASTs produce identical Merkle hashes." @@ -486,6 +481,6 @@ Following the Engineering Standards, the Memory must be empirically verified thr (let* ((ast-mod '(:type :HEADLINE :properties (:ID "root" :TITLE "Root") :contents ((:type :HEADLINE :properties (:ID "leaf" :TITLE "Changed") :contents nil)))) (id-mod (progn (clrhash *memory*) (ingest-ast ast-mod))) - (mod-hash (org-object-hash (lookup-object id-mod)))) + (mod-hash (org-object-hash (lookup-object id-mod)))) (is (not (equal root-hash mod-hash)))))) #+end_src diff --git a/harness/skills.org b/harness/skills.org index 416f11f..1ecbb68 100644 --- a/harness/skills.org +++ b/harness/skills.org @@ -195,9 +195,9 @@ Only loads blocks that specify a .lisp tangle target, ignoring tests and example (search ".lisp" tl) (not (search "tests/" tl)) (not (search "test/" tl)))))) - ((uiop:string-prefix-p "#+end_src" (string-downcase clean-line)) - (setf in-lisp-block nil) - (setf collect-this-block nil)) + ((uiop:string-prefix-p "#+end" (string-downcase clean-line)) + (setf in-lisp-block nil) + (setf collect-this-block nil)) ((and in-lisp-block collect-this-block) (unless (or (uiop:string-prefix-p ":PROPERTIES:" (string-upcase clean-line)) (uiop:string-prefix-p ":END:" (string-upcase clean-line))) @@ -394,7 +394,7 @@ EXAMPLES: (let ((base-name (pathname-name file))) (setf (skill-entry-status (gethash base-name *skill-catalog*)) :ready) (format nil "OK: Skill '~a' reloaded successfully." base-name)) - (format nil "ERROR: Reload failed with status ~a" status))))))))) + (format nil "ERROR: Reload failed with status ~a" status)))))))))) #+end_src *** The File Read Tool (V 0.2.0 File I/O) @@ -413,7 +413,7 @@ EXAMPLES: (handler-case (uiop:read-file-string file) (error (c) - (format nil "ERROR reading ~a: ~a" file c))))) + (format nil "ERROR reading ~a: ~a" file c)))))) #+end_src *** The File Write Tool (V 0.2.0 File I/O) @@ -445,7 +445,7 @@ EXAMPLES: (if append-p "content appended" "file written") file)) (error (c) - (format nil "ERROR writing ~a: ~a" file c))))) + (format nil "ERROR writing ~a: ~a" file c)))))) #+end_src *** The String Replace Tool (V 0.2.0 File I/O) @@ -476,7 +476,7 @@ EXAMPLES: (format nil "OK: Replaced first occurrence in ~a" file)) (format nil "ERROR: Pattern not found in ~a" file)))) (error (c) - (format nil "ERROR replacing in ~a: ~a" file c))))) + (format nil "ERROR replacing in ~a: ~a" file c)))))) #+end_src * Test Suite diff --git a/library/act.lisp b/library/act.lisp index 042c286..aede5a8 100644 --- a/library/act.lisp +++ b/library/act.lisp @@ -1,22 +1,47 @@ (in-package :opencortex) -(defvar *default-actuator* :cli) -(defvar *silent-actuators* '(:cli :system-message :emacs)) +(defvar *default-actuator* :cli + "The actuator used when no explicit target is specified. + Override with DEFAULT_ACTUATOR environment variable.") + +(defvar *silent-actuators* '(:cli :system-message :emacs) + "List of actuators that don't generate tool-output feedback. + These typically have their own feedback mechanisms (CLI prints directly, etc.)") (defun initialize-actuators () - "Loads actuator routing defaults from environment variables and registers core harness actuators." + "Load actuator configuration from environment and register core actuators. + + Environment variables: + - DEFAULT_ACTUATOR: Keyword for default target (:cli, :shell, etc.) + - SILENT_ACTUATORS: Comma-separated list of actuators that skip feedback + + Registers three core actuators: + 1. :system - Internal commands (eval, create-skill, message) + 2. :tool - Cognitive tool execution + 3. :tui - Terminal UI output via reply stream" + + ;; Load environment configuration (let ((def (uiop:getenv "DEFAULT_ACTUATOR")) (silent (uiop:getenv "SILENT_ACTUATORS"))) + + ;; Set default actuator (when def - (setf *default-actuator* (intern (string-upcase def) "KEYWORD"))) + (setf *default-actuator* + (intern (string-upcase def) "KEYWORD"))) + + ;; Parse silent actuators list (when silent (setf *silent-actuators* - (mapcar (lambda (s) (intern (string-upcase (string-trim '(#\Space) s)) "KEYWORD")) + (mapcar (lambda (s) + (intern (string-upcase (string-trim '(#\Space) s)) + "KEYWORD")) (str:split "," silent))))) - + ;; Register core harness actuators (register-actuator :system #'execute-system-action) (register-actuator :tool #'execute-tool-action) + + ;; TUI actuator: sends response back through the reply stream (register-actuator :tui (lambda (action context) (let* ((meta (getf context :meta)) (stream (getf meta :reply-stream))) @@ -25,55 +50,107 @@ (finish-output stream)))))) (defun dispatch-action (action context) + "Route an approved action to its registered actuator. + + ACTION is a plist with structure: + (:TYPE :REQUEST :TARGET :shell :PAYLOAD (...)) + + CONTEXT is the signal being processed (for metadata access) + + The target is resolved in order of priority: + 1. Explicit :target in the action + 2. :source from the original signal's metadata + 3. *default-actuator* configuration variable + + Returns the actuator's result (may be a feedback signal or NIL)." + (let ((payload (proto-get action :payload))) + + ;; Heartbeats don't generate actuation (when (eq (proto-get payload :sensor) :heartbeat) - (return-from dispatch-action nil))) - "Routes an approved action to its registered physical actuator." - (when (and action (listp action)) - (let* ((meta (proto-get context :meta)) - (source (proto-get meta :source)) - (raw-target (or (ignore-errors (getf action :TARGET)) - (ignore-errors (getf action :target)) - source - *default-actuator*)) - (target (intern (string-upcase (string raw-target)) :keyword)) - (actuator-fn (gethash target *actuator-registry*))) - ;; Ensure outbound action has meta if context had it - (when (and meta (null (getf action :meta))) - (setf (getf action :meta) meta)) - (if actuator-fn - (funcall actuator-fn action context) - (harness-log "ACT ERROR: No actuator for ~s (from ~s)" target raw-target))))) + (return-from dispatch-action nil)) + + (when (and action (listp action)) + (let* ((meta (proto-get context :meta)) + (source (proto-get meta :source)) + (raw-target (or (ignore-errors (getf action :TARGET)) + (ignore-errors (getf action :target)) + source + *default-actuator*)) + (target (intern (string-upcase (string raw-target)) :keyword)) + (actuator-fn (gethash target *actuator-registry*))) + + ;; Preserve metadata in outbound action + (when (and meta (null (getf action :meta))) + (setf (getf action :meta) meta)) + + ;; Execute or log error + (if actuator-fn + (funcall actuator-fn action context) + (harness-log "ACT ERROR: No actuator registered for '~s' (requested by ~s)" + target raw-target)))))) (defun execute-system-action (action context) - "Processes internal harness commands. (ACTUATOR)" - (declare (ignore context)) - (let* ((payload (ignore-errors (getf action :payload))) - (cmd (ignore-errors (getf payload :action)))) - (case cmd - (:eval (let ((code (getf payload :code))) - (eval (read-from-string code)))) - (:create-skill (let* ((filename (getf payload :filename)) (content (getf payload :content)) - (skills-dir (merge-pathnames "skills/" (asdf:system-source-directory :opencortex))) - (full-path (merge-pathnames filename skills-dir))) - (with-open-file (out full-path :direction :output :if-exists :supersede) (write-string content out)) - (load-skill-from-org full-path))) - (:message (harness-log "ACT [System]: ~a" (getf payload :text))) - (t (harness-log "ACT ERROR [System]: Unknown command ~s" cmd))))) + "Execute internal harness commands. -(defun format-tool-result (tool-name result) - "Intelligently formats a tool result for user display." - (if (listp result) - (let ((status (getf result :status)) - (content (getf result :content)) - (msg (getf result :message))) - (cond ((and (eq status :success) content) (format nil "~a" content)) - ((and (eq status :error) msg) (format nil "ERROR [~a]: ~a" tool-name msg)) - (t (format nil "TOOL [~a] RESULT: ~s" tool-name result)))) - (format nil "TOOL [~a] RESULT: ~a" tool-name result))) + This actuator handles meta-commands that affect the harness itself, + rather than external side effects. Commands include: + + - :eval - Evaluate arbitrary Lisp code (DANGEROUS, validate first!) + - :create-skill - Write a new skill org file and reload + - :message - Log a message to the harness log + + These commands bypass the normal actuator system since they operate + on the harness internals rather than external systems." + + (declare (ignore context)) + + (let* ((payload (ignore-errors (getf action :payload))) + (cmd (ignore-errors (getf payload :action)))) + + (case cmd + ;; Evaluate Lisp code - guarded by lisp-validator skill + (:eval + (let ((code (getf payload :code))) + (eval (read-from-string code)))) + + ;; Create and load a new skill from content + (:create-skill + (let* ((filename (getf payload :filename)) + (content (getf payload :content)) + (skills-dir (merge-pathnames "skills/" + (asdf:system-source-directory :opencortex))) + (full-path (merge-pathnames filename skills-dir))) + (with-open-file (out full-path + :direction :output + :if-exists :supersede) + (write-string content out)) + (load-skill-from-org full-path))) + + ;; Log an informational message + (:message + (harness-log "ACT [System]: ~a" (getf payload :text))) + + ;; Unknown command + (t + (harness-log "ACT ERROR [System]: Unknown command '~s'" cmd))))) (defun execute-tool-action (action context) - "Executes a registered cognitive tool. (ACTUATOR)" + "Execute a registered cognitive tool. + + Tools are registered functions with: + - A guard function (optional, for safety checks) + - A body function (the actual implementation) + - Metadata (description, parameter specs) + + This actuator: + 1. Looks up the tool by name + 2. Runs the guard function (if present) + 3. Executes the body function with parsed arguments + 4. Returns a feedback signal with the result + + The feedback mechanism allows tool results to trigger further reasoning." + (let* ((payload (getf action :payload)) (tool-name (getf payload :tool)) (tool-args (getf payload :args)) @@ -81,78 +158,156 @@ (meta (getf context :meta)) (source (getf meta :source)) (tool (gethash (string-downcase (string tool-name)) *cognitive-tools*))) - (when tool - ;; Tool Permission Gate: Check permission before execution - (let ((permission (check-tool-permission-gate tool-name context))) - (when (eq permission :deny) - (return-from execute-tool-action - (list :TYPE :EVENT :DEPTH (1+ depth) :META meta - :PAYLOAD (list :SENSOR :tool-error :tool tool-name :message (format nil "Tool PERMISSION DENIED: ~a" tool-name)))))) - (when (listp permission) - (return-from execute-tool-action - (list :TYPE :EVENT :DEPTH (1+ depth) :META meta - :PAYLOAD (list :SENSOR :permission-pending :tool tool-name :args tool-args))))) - (handler-case - (let* ((clean-args (if (and (listp tool-args) (listp (car tool-args))) (car tool-args) tool-args)) + + (if tool + (handler-case + ;; Parse arguments (handle both flat and nested plists) + (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))) - (let ((feedback (list :TYPE :EVENT :DEPTH (1+ depth) :META meta - :PAYLOAD (list :SENSOR :tool-output :RESULT result :TOOL tool-name)))) - ;; If we have a source, send a status message with the result, formatted for humans - (when source - (dispatch-action (list :TYPE :REQUEST :TARGET source - :PAYLOAD (list :ACTION :MESSAGE :TEXT (format-tool-result tool-name result))) - context)) - feedback)) + + ;; Format result for source + (when source + (dispatch-action (list :TYPE :REQUEST + :TARGET source + :PAYLOAD (list :ACTION :MESSAGE + :TEXT (format-tool-result tool-name result))) + context)) + + ;; Return feedback signal for potential further processing + (list :TYPE :EVENT + :DEPTH (1+ depth) + :META meta + :PAYLOAD (list :SENSOR :tool-output + :RESULT result + :TOOL tool-name))) + + ;; Tool execution error (error (c) - (list :TYPE :EVENT :DEPTH (1+ depth) :META meta - :PAYLOAD (list :SENSOR :tool-error :tool tool-name :message (format nil "~a" c))))) - (list :TYPE :EVENT :DEPTH (1+ depth) :META meta - :PAYLOAD (list :SENSOR :tool-error :message "Tool not found")))) + (list :TYPE :EVENT + :DEPTH (1+ depth) + :META meta + :PAYLOAD (list :SENSOR :tool-error + :TOOL tool-name + :MESSAGE (format nil "~a" c))))) + + ;; Tool not found + (list :TYPE :EVENT + :DEPTH (1+ depth) + :META meta + :PAYLOAD (list :SENSOR :tool-error + :MESSAGE (format nil "Tool '~a' not found" tool-name)))))) + +(defun format-tool-result (tool-name result) + "Format a tool result for human-readable display. + + Tools return either: + - A plist: (:status :success :content \"...\") or (:status :error :message \"...\") + - A raw value (string, number, etc.) + + This function normalizes both formats into a consistent string presentation." + + (if (listp result) + (let ((status (getf result :status)) + (content (getf result :content)) + (msg (getf result :message))) + (cond + ((and (eq status :success) content) + (format nil "~a" content)) + ((and (eq status :error) msg) + (format nil "ERROR [~a]: ~a" tool-name msg)) + (t + (format nil "TOOL [~a] RESULT: ~s" tool-name result)))) + (format nil "TOOL [~a] RESULT: ~a" tool-name result))) (defun act-gate (signal) - "Final Stage: Actuation and feedback generation." + "Final stage of the metabolic pipeline: Actuation. + + This stage has three responsibilities: + + 1. Last-mile safety check: Run deterministic gates one more time + before execution (handles race conditions, concurrent modifications) + + 2. Actuation: Dispatch the approved action to its target actuator + + 3. Feedback generation: If the action produced results, create a + feedback signal that feeds back into the pipeline + + Modifies the signal: + - :approved-action - May be modified by last-mile verification + - :status - Set to :acted + + Returns a feedback signal if the action produced results, otherwise NIL." + (let* ((approved (getf signal :approved-action)) (type (getf signal :type)) (meta (getf signal :meta)) (source (getf meta :source)) (feedback nil) - ;; context must keep internal objects for actuators to function (context signal)) - - ;; 1. Last-Mile Safety Check (The Bouncer & Deterministic Gates) + + ;; Step 1: Last-mile deterministic verification + ;; This catches any issues that arose between reasoning and acting (when approved (let* ((original-type (getf approved :type)) (verified (deterministic-verify approved signal))) - (if (and (listp verified) + + ;; Check if deterministic verification blocked the action + (if (and (listp verified) (member (getf verified :type) '(:LOG :EVENT :log :event)) (not (member original-type '(:LOG :EVENT :log :event)))) + + ;; Action was blocked by verification (progn (harness-log "ACT BLOCKED: Action failed last-mile deterministic check.") (setf (getf signal :approved-action) nil) (setf approved nil) (setf feedback verified)) + + ;; Action passed verification (progn (setf (getf signal :approved-action) verified) (setf approved verified))))) - ;; 2. Actuation Logic + ;; Step 2: Actuation based on signal type (case type - (:REQUEST (dispatch-action signal context)) - (:LOG (dispatch-action signal context)) - (:EVENT + ;; Explicit requests go directly to dispatch + (:REQUEST + (dispatch-action signal context)) + + ;; Log messages also dispatch + (:LOG + (dispatch-action signal context)) + + ;; Events with approved actions dispatch to their target + (:EVENT (if approved (let* ((target (getf approved :target)) (result (dispatch-action approved context))) - ;; If the actuator returns a signal (like :tool-output), it becomes the feedback. - ;; Otherwise, generate tool-output feedback for non-silent actuators. - (cond ((and (listp result) (member (getf result :type) '(:EVENT :LOG))) - (setf feedback result)) - ((and result (not (member target *silent-actuators*))) - (setf feedback (list :type :EVENT :depth (1+ (getf signal :depth 0)) :meta meta - :payload (list :sensor :tool-output :result result :tool approved)))))) - ;; If no approved action but we have a source, this might be a raw event/log stimulus. + + ;; Determine feedback based on actuator response + (cond + ;; Actuator returned a signal - use it as feedback + ((and (listp result) + (member (getf result :type) '(:EVENT :LOG))) + (setf feedback result)) + + ;; Non-silent actuator with result - format as tool-output + ((and result + (not (member target *silent-actuators*))) + (setf feedback (list :type :EVENT + :depth (1+ (getf signal :depth 0)) + :meta meta + :payload (list :sensor :tool-output + :result result + :tool approved)))))) + + ;; No approved action, but have source - might be raw event (when source (dispatch-action signal context))))) - + + ;; Step 3: Update signal status (setf (getf signal :status) :acted) feedback)) diff --git a/library/context.lisp b/library/context.lisp index c425fb5..5fc3eda 100644 --- a/library/context.lisp +++ b/library/context.lisp @@ -42,7 +42,7 @@ (defun context-get-system-logs (&optional limit) "Retrieves the most recent lines from the harness's internal log." (let ((log-limit (or limit (ignore-errors (parse-integer (uiop:getenv "CONTEXT_LOG_LIMIT"))) 20))) - (bordeaux-threads:with-lock-held (*logs-lock*) + (bt:with-lock-held (*logs-lock*) (let ((count (min log-limit (length *system-logs*)))) (subseq *system-logs* 0 count))))) diff --git a/library/gen/org-skill-bouncer.lisp b/library/gen/org-skill-bouncer.lisp index 86d09f2..d07aded 100644 --- a/library/gen/org-skill-bouncer.lisp +++ b/library/gen/org-skill-bouncer.lisp @@ -1,109 +1,258 @@ (in-package :opencortex) (defun bouncer-scan-secrets (text) - "Returns the name of the secret found in TEXT, or NIL if clean." + "Scans TEXT for known secrets from the vault. + + RETURNS: The name of the matched secret, or NIL if text is clean. + + This prevents the catastrophic failure mode where the agent + accidentally echoes an API key in its response or log output. + + The check uses substring matching (not regex) for reliability. + Only secrets longer than 5 characters are checked to avoid + false positives on common words." + (when (and text (stringp text)) + (let ((found-secret nil)) + (maphash (lambda (key val) + ;; Only check secrets of meaningful length (when (and val (stringp val) (> (length val) 5)) + ;; Search for secret value in action text (when (search val text) (setf found-secret key)))) + opencortex::*vault-memory*) + found-secret))) +(defvar *bouncer-network-whitelist* + '("api.telegram.org" "matrix.org" "googleapis.com" "openai.com" "anthropic.com") + "Domains that the Bouncer considers safe for outbound connections. + + This whitelist should be minimal—only services explicitly configured + as gateways. All other outbound connections require approval.") + (defun bouncer-check-network-exfil (cmd) - "Returns T if the command appears to target an unwhitelisted external host." + "Detects if CMD attempts to contact an unwhitelisted external host. + + Returns T if the command targets an unknown external host. + Returns NIL if the command is clean or only contacts whitelisted hosts. + + The check looks for HTTP/HTTPS/FTP URLs and extracts the domain. + If the domain isn't in *bouncer-network-whitelist*, it's flagged." + (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)))))))) + + ;; Look for URL patterns in the command + (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))) + + ;; Check if domain is whitelisted + (not (some (lambda (safe) (search safe domain)) + *bouncer-network-whitelist*))))))) (defun bouncer-check (action context) - "The 5-Vector security gate. Blocks or queues actions based on risk." + "The 5-Vector security gate for high-risk actions. + + Evaluates an action against all security vectors and either: + - Returns the action unchanged (pass) + - Returns a blocking LOG event (hard block) + - Returns an approval-required EVENT (soft block) + + Vector evaluation order: + 1. Already approved actions pass immediately + 2. Secret exposure → hard block + 3. Network exfiltration → approval required + 4. High-impact targets → approval required + + The context parameter is not used directly but provided for + consistency with the skill gate signature." + + (declare (ignore context)) + (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)))) + (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) + (cond + + ;; Vector 0: Already approved actions pass through + (approved + action) + + ;; Vector 1: Secret Exposure (Hard Block) + ;; If any vault secret is found in the action text, block immediately ((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))))) + (harness-log "SECURITY VIOLATION: Blocked potential leak of secret '~a'" secret-name) + (list :type :LOG + :payload (list :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"))) + ;; Vector 2: Network Exfiltration (Soft Block) + ;; Shell commands targeting unknown hosts require approval + ((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) + (list :type :EVENT + :payload (list :sensor :approval-required + :action action))) + + ;; Vector 3: High-Impact Targets (Soft Block) + ;; Shell execution, file repair, and eval require approval ((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))) + (and (eq target :tool) + (member (getf payload :tool) '("shell" "repair-file") :test #'string=)) + (and (eq target :emacs) + (eq (getf payload :action) :eval))) - ;; 4. Default Pass - (t action)))) + (harness-log "SECURITY: High-impact action requires approval: ~a" + (or (getf payload :tool) target)) + + (list :type :EVENT + :payload (list :sensor :approval-required + :action action))) + + ;; Vector 4: Default pass + (t + action)))) (defun bouncer-process-approvals () - "Scans the object store for APPROVED flight plans and re-injects their actions." + "Scans the object store for APPROVED flight plans and re-injects them. + + This function is called on every heartbeat, allowing the agent to + check for approvals without blocking the main signal pipeline. + + Flight Plan format: + - Has TAGS including \"FLIGHT_PLAN\" + - Has TODO set to \"APPROVED\" + - Has ACTION containing the serialized action plist + + When an approved flight plan is found: + 1. Deserialize the action from the ACTION attribute + 2. Mark the action as :approved = t (bypasses security gate) + 3. Re-inject into the signal pipeline + 4. Mark the flight plan as DONE + + Returns T if any flight plans were processed." + (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)) + + ;; Only process flight plans (not other APPROVED items) + (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 + + ;; Mark as approved to bypass the security gate on re-injection (setf (getf action :approved) t) + + ;; Re-inject the action into the signal pipeline (inject-stimulus action) - ;; Mark as DONE + + ;; Mark the flight plan as done (setf (getf (org-object-attributes node) :TODO) "DONE") + (setq found-any t)))))) + found-any)) +(defun bouncer-create-flight-plan (blocked-action) + "Creates an Org node representing a pending flight plan for manual approval. + + BLOCKED-ACTION is the action plist that was intercepted. + + The flight plan node contains: + - A title describing the action + - TODO set to PLAN (awaiting approval) + - TAGS including FLIGHT_PLAN + - ACTION attribute containing the serialized action + + The user reviews the flight plan and changes TODO to APPROVED. + On the next heartbeat, bouncer-process-approvals will detect + the approval and re-inject the action. + + Returns the generated org-id for the flight plan." + + (let ((id (org-id-new))) + (harness-log "BOUNCER: Creating flight plan node '~a'..." id) + + ;; Inject a node creation request + (list :type :REQUEST + :target :emacs + :payload (list :action :insert-node + :id id + :attributes (list + :TITLE "Flight Plan: High-Risk Action" + :TODO "PLAN" + :TAGS '("FLIGHT_PLAN") + :ACTION (format nil "~s" blocked-action))))) + (defun bouncer-deterministic-gate (action context) - "Main gate for the bouncer skill." + "Main deterministic gate for the Bouncer skill. + + Handles three types of signals: + 1. :approval-required - Create a flight plan for the blocked action + 2. :heartbeat - Process any pending approvals + 3. otherwise - Run security check on the action + + The trigger is always true (bouncer evaluates all actions) + because security cannot be selective." + (let* ((payload (getf context :payload)) (sensor (getf payload :sensor))) + (case sensor + + ;; Signal type 1: Action was blocked, create flight plan (: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))))) + (let* ((blocked-action (getf payload :action))) + (bouncer-create-flight-plan blocked-action))) + + ;; Signal type 2: Heartbeat, check for approvals (:heartbeat - ;; Periodically check for approvals (bouncer-process-approvals) - (if action (bouncer-check action context) action)) + ;; After processing approvals, still run the security check + (if action + (bouncer-check action context) + action)) + + ;; Signal type 3: Normal action, run security check (otherwise - (if action (bouncer-check action context) action))))) + (if action + (bouncer-check action context) + action))))) (defskill :skill-bouncer :priority 150 - :trigger (lambda (ctx) t) ;; Bouncer evaluates all actions deterministically + :trigger (lambda (ctx) (declare (ignore ctx)) t) :probabilistic nil :deterministic #'bouncer-deterministic-gate) diff --git a/library/gen/org-skill-policy.lisp b/library/gen/org-skill-policy.lisp index 64982d4..995ac20 100644 --- a/library/gen/org-skill-policy.lisp +++ b/library/gen/org-skill-policy.lisp @@ -8,22 +8,40 @@ (:mentorship . 200) (:sustainability . 100)) "Priority alist for policy invariant conflict resolution. -Higher numbers take precedence.") +Higher numbers take precedence. + +When two invariants conflict, the higher priority wins. +Example: Modularity (250) takes precedence over Mentorship (200), +meaning a change that would fatten the harness is blocked +even if it would be educational.") (defun policy-check-transparency (action context) "Ensures the action is inspectable and user-facing actions carry an explanation. -Returns the action if clean, or a blocking LOG event if the action is opaque." + + TRANSPARENCY CHECK: + 1. Action must be a valid plist (not opaque data) + 2. User-facing actions (:cli, :tui, :emacs) must include :explanation + 3. Heartbeat and handshake messages are exempt (they're system status) + + Returns the action if clean, or a blocking LOG event if violated." + (declare (ignore context)) + + ;; Check 1: Action must be a valid plist (unless (listp action) (return-from policy-check-transparency (list :type :LOG :payload (list :level :error :text "POLICY [Transparency]: Action is not a valid plist. Rejected.")))) + (let* ((payload (getf action :payload)) (target (or (getf action :target) (getf action :TARGET))) - (explanation (or (getf payload :explanation) (getf payload :EXPLANATION) - (getf payload :rationale) (getf payload :RATIONALE)))) - ;; User-facing actions (CLI, TUI, Emacs) must explain themselves + (explanation (or (getf payload :explanation) + (getf payload :EXPLANATION) + (getf payload :rationale) + (getf payload :RATIONALE)))) + + ;; Check 2: User-facing actions require explanation (when (and (member target '(:cli :tui :emacs :EMACS :CLI :TUI)) (not explanation) (not (member (getf payload :action) @@ -31,172 +49,320 @@ Returns the action if clean, or a blocking LOG event if the action is opaque." (return-from policy-check-transparency (list :type :LOG :payload (list :level :error - :text "POLICY [Transparency]: User-facing action missing :explanation. Blocked.")))) - action)) + :text "POLICY [Transparency]: User-facing action missing :explanation. Blocked."))))) + + action)) (defvar *proprietary-domain-watchlist* '("googleapis.com" "api.openai.com" "anthropic.com" "api.groq.com" "openrouter.ai") - "Domains that represent centralized, proprietary control. -Actions targeting these are logged as autonomy debt, not hard-blocked, -because tactical gateway usage is permitted under the strategic mandate.") + "Domains representing centralized, proprietary control. + + Actions targeting these are logged as autonomy debt, not hard-blocked. + This is because tactical gateway usage (Telegram, Signal, OpenRouter) + is permitted under the strategic mandate for autonomy. + + Strategic goal: Replace all proprietary APIs with local alternatives. + Tactical reality: Use what's available while building toward that goal.") (defun policy-scan-proprietary-references (action) "Scans ACTION text fields for proprietary domain references. -Returns the first matched domain, or NIL if clean." + + Searches in: + - :text and :TEXT in payload + - :cmd and :CMD in payload + - :cmd in args (for shell tool calls) + + Returns the first matched domain, or NIL if clean." + (let* ((payload (getf action :payload)) (text (or (getf payload :text) (getf payload :TEXT) "")) - (cmd (or (getf payload :cmd) (getf payload :CMD) - (when (equal (getf payload :tool) "shell") - (getf (getf payload :args) :cmd)) - "")) + (cmd (or (getf payload :cmd) + (getf payload :CMD) + (when (equal (getf payload :tool) "shell") + (getf (getf payload :args) :cmd)) + "")) (haystack (concatenate 'string text cmd))) + (dolist (domain *proprietary-domain-watchlist* nil) (when (search domain haystack) (return domain))))) (defun policy-check-autonomy (action context) - "Flags actions that reference proprietary domains. Returns the action -with an autonomy debt log appended, or the action itself if clean." + "Flags actions that reference proprietary domains. + + Does NOT block the action—this is a warning, not a veto. + The agent can use proprietary services tactically, but must + be aware that each usage is a step away from full autonomy. + + Returns a warning LOG if proprietary reference detected, + or the original action if clean." + (declare (ignore context)) + (let ((domain (policy-scan-proprietary-references action))) + (if domain (progn (harness-log "POLICY [Autonomy]: Detected proprietary reference '~a'. Flagged for replacement." domain) - ;; Return a side-effect log but DO NOT block the action + ;; Return a warning log but DO NOT block the action (list :type :LOG :payload (list :level :warn :text (format nil "Autonomy Debt: Action references proprietary domain '~a'. Consider a local alternative." domain) :original-action action))) + action))) (defvar *policy-max-skill-size-chars* 50000 - "Maximum recommended size for a skill file tangled from an Org note.") + "Maximum recommended size for a skill file tangled from an Org note. + + This is a soft limit—the check warns but does not block. + A large, well-documented skill is acceptable; a small, poorly-documented + one that adds unnecessary complexity is not.") (defun policy-check-bloat (action context) "Warns if a :create-skill action exceeds the bloat threshold. -Does not block, because size alone is not a proof of complexity." + + Size alone is not proof of complexity—a 50KB skill that's well-designed + is better than a 5KB skill that's spaghetti. This check flags for review, + not automatic rejection. + + Returns a warning LOG if threshold exceeded, or original action if clean." + (declare (ignore context)) + (let* ((payload (getf action :payload)) (act (getf payload :action)) (content (getf payload :content))) + (when (and (eq act :create-skill) (stringp content) (> (length content) *policy-max-skill-size-chars*)) + (harness-log "POLICY [Bloat]: Proposed skill is ~a chars. Exceeds ~a char threshold." (length content) *policy-max-skill-size-chars*) + (return-from policy-check-bloat (list :type :LOG :payload (list :level :warn :text (format nil "Bloat Warning: Proposed skill (~a chars) exceeds ~a char threshold. Review for earned complexity." - (length content) *policy-max-skill-size-chars*) + (length content) *policy-max-skill-size-chars*) :original-action action)))) - action)) -(defvar *mentorship-required-actions* - '(:create-skill :eval :modify-file :write-file :replace :rename-file :delete-file :shell :create-note) - "Actions that trigger the Mentorship invariant.") - -(defun policy-check-mentorship (action context) - "Blocks high-impact actions that lack a mentorship note." - (declare (ignore context)) - (let* ((payload (getf action :payload)) - (act (or (getf payload :action) (getf action :action))) - (note (or (getf payload :mentorship-note) (getf payload :MENTORSHIP-NOTE))) - (target (or (getf action :target) (getf action :TARGET))) - (tool (when (eq target :tool) (getf payload :tool)))) - (when (or (member act *mentorship-required-actions*) - (member tool '("shell" "eval" "repair-file"))) - (unless note - (return-from policy-check-mentorship - (list :type :LOG - :payload (list :level :error - :text "POLICY [Mentorship]: High-impact action missing :mentorship-note. Explain what you are doing and why. Blocked."))))) - action)) - -(defvar *cloud-only-backends* '(:openrouter :openai :anthropic :groq :gemini-api) - "Backends that require an internet connection and external infrastructure.") - -(defun policy-check-sustainability (action context) - "Logs sustainability debt when the action relies on cloud-only infrastructure. -Does not block, because tactical cloud usage is permitted." - (let* ((payload (getf context :payload)) - (backend (getf payload :backend)) - (provider (getf payload :provider))) - (when (or (member backend *cloud-only-backends*) - (member provider *cloud-only-backends*)) - (harness-log "POLICY [Sustainability]: Cloud provider '~a' used. Logged as sustainability debt." - (or backend provider)) - (return-from policy-check-sustainability - (list :type :LOG - :payload (list :level :warn - :text (format nil "Sustainability Debt: Reliance on cloud provider '~a'. Consider Ollama or local inference." - (or backend provider)))))) - action)) + action)) (defvar *modularity-protected-paths* '("harness/" "opencortex.asd") "Paths that constitute the unbreakable core of the system. -Any action targeting these paths must include a :modularity-justification. -This list is project-specific and should be configured at boot time.") + + Any action targeting these paths must include a :modularity-justification + explaining why the change cannot be implemented as a skill. + + The Thin Harness principle: What belongs in the harness? + - Core signal processing (Perceive-Reason-Act loop) + - Memory and persistence primitives + - Protocol definition and validation + - Skills register and dispatch + + What belongs in skills? + - Policy and security + - LLM integration + - Domain-specific functionality + - New actuators") (defun policy-check-modularity (action context) - "Blocks modifications to the system's protected core unless justified." + "Blocks modifications to the system's protected core unless justified. + + MODULARITY CHECK: + 1. If the action targets a protected path + 2. And no :modularity-justification is provided + 3. Then block with an explanation + + The justification should explain WHY the change cannot be a skill. + Common valid reasons: + - The change fixes a bug in the harness itself + - The change adds a primitive that skills cannot implement + - The change is required for security hardening + + Invalid reasons: + - 'It's easier to modify the harness' + - 'Skills are too slow' + - 'I want to keep it all in one place'" + (declare (ignore context)) + (let* ((payload (getf action :payload)) - (target-file (or (getf payload :file) (getf payload :filename))) + (target-file (or (getf payload :file) + (getf payload :filename))) (justification (or (getf payload :modularity-justification) (getf payload :MODULARITY-JUSTIFICATION)))) + (when (and target-file - (some (lambda (path) (search path target-file)) *modularity-protected-paths*) + (some (lambda (path) (search path target-file)) + *modularity-protected-paths*) (not justification)) + (return-from policy-check-modularity (list :type :LOG :payload (list :level :error :text "POLICY [Modularity]: Modification to protected core path blocked. Provide :modularity-justification explaining why this cannot be a skill." :blocked-path target-file)))) - action)) + + action)) + +(defvar *mentorship-required-actions* + '(:create-skill :eval :modify-file :write-file :replace + :rename-file :delete-file :shell :create-note) + "Actions that trigger the Mentorship invariant. + + These are high-impact actions that should come with explanations + not just for the user, but for future debugging and maintenance.") + +(defun policy-check-mentorship (action context) + "Blocks high-impact actions that lack a mentorship note. + + MENTORSHIP CHECK: + 1. If the action is in *mentorship-required-actions* + 2. Or if the action calls shell/eval/repair-file tools + 3. Then require :mentorship-note explaining what and why + + The mentorship note should be: + - Concise (1-2 sentences) + - Educational (explain the principle, not just the action) + - Actionable (help the user understand the outcome)" + + (declare (ignore context)) + + (let* ((payload (getf action :payload)) + (act (or (getf payload :action) + (getf action :action))) + (note (or (getf payload :mentorship-note) + (getf payload :MENTORSHIP-NOTE))) + (target (or (getf action :target) + (getf action :TARGET))) + (tool (when (eq target :tool) + (getf payload :tool)))) + + (when (or (member act *mentorship-required-actions*) + (member tool '("shell" "eval" "repair-file"))) + + (unless note + (return-from policy-check-mentorship + (list :type :LOG + :payload (list :level :error + :text "POLICY [Mentorship]: High-impact action missing :mentorship-note. Explain what you are doing and why. Blocked."))))) + + action)) + +(defvar *cloud-only-backends* '(:openrouter :openai :anthropic :groq :gemini-api) + "Backends requiring internet connection and external infrastructure. + + These are acceptable as fallbacks when local inference is unavailable, + but should be logged as sustainability debt for tracking purposes.") + +(defun policy-check-sustainability (action context) + "Logs sustainability debt when action relies on cloud-only infrastructure. + + Does NOT block—this is informational, not prohibitive. + Cloud usage is acceptable tactically (when local models fail), + but every cloud usage should be a conscious decision, not a default." + + (let* ((payload (getf context :payload)) + (backend (getf payload :backend)) + (provider (getf payload :provider))) + + (when (or (member backend *cloud-only-backends*) + (member provider *cloud-only-backends*)) + + (harness-log "POLICY [Sustainability]: Cloud provider '~a' used. Logged as sustainability debt." + (or backend provider)) + + (return-from policy-check-sustainability + (list :type :LOG + :payload (list :level :warn + :text (format nil "Sustainability Debt: Reliance on cloud provider '~a'. Consider Ollama or local inference." + (or backend provider)))))) + + action))) (defun policy-explain (invariant-key message &optional original-action) "Formats a policy decision into an auditable explanation plist. -INVARIANT-KEY is one of :transparency, :autonomy, :bloat, :modularity, :mentorship, :sustainability. -MESSAGE is a human-readable string. -ORIGINAL-ACTION is the action that was blocked or modified." + + INVARIANT-KEY is one of: + :transparency, :autonomy, :bloat, :modularity, :mentorship, :sustainability + + MESSAGE is a human-readable string explaining the decision. + + ORIGINAL-ACTION is the action that was blocked or modified. + + Returns a REQUEST plist addressed to the original source, + containing the explanation and original action for transparency." + (list :type :REQUEST - :target (or (ignore-errors (getf (getf original-action :meta) :source)) :cli) + :target (or (ignore-errors + (getf (getf original-action :meta) :source)) + :cli) :payload (list :action :message :text (format nil "[POLICY ~a] ~a" invariant-key message) - :explanation (format nil "Invariant: ~a | Rationale: ~a" invariant-key message) + :explanation (format nil "Invariant: ~a | Rationale: ~a" + invariant-key message) :original-action original-action))) (defun policy-run-invariant-checks (action context) - "Runs all invariant checks in priority order. Returns the final action, -a blocking LOG event, or a warning wrapper." + "Runs all invariant checks in priority order. + + Priority order (from *policy-invariant-priorities*): + 1. Transparency (500) - blocks non-transparent actions + 2. Autonomy (400) - warns on proprietary dependencies + 3. Bloat (300) - warns on oversized skills + 4. Modularity (250) - blocks unprotected core modifications + 5. Mentorship (200) - blocks unexplained high-impact actions + 6. Sustainability (100) - warns on cloud dependencies + + Returns: + - The final action (possibly modified by checks) + - A blocking LOG event (if any check returned :error level) + - A warning wrapper (if checks returned :warn level but no blocks)" + (let ((checks '(policy-check-transparency policy-check-autonomy policy-check-bloat policy-check-modularity policy-check-mentorship policy-check-sustainability))) + (dolist (check-fn checks action) (let ((result (funcall check-fn action context))) - ;; If the check returned a LOG event, treat it as a block/warning + + ;; If the check returned a LOG/EVENT, interpret it (when (and (listp result) (member (getf result :type) '(:LOG :EVENT))) - (let ((level (getf (getf result :payload) :level))) - (cond ((eq level :error) - ;; Hard block: return the log event directly - (return-from policy-run-invariant-checks result)) - (t - ;; Warning: log it, but continue with the original action - (harness-log "~a" (getf (getf result :payload) :text)))))))))) + + (let ((level (getf (getf result :payload) :level))) + + (cond + ;; Hard block: error level stops processing immediately + ((eq level :error) + (return-from policy-run-invariant-checks result)) + + ;; Soft warning: log but continue with original action + (t + (harness-log "~a" (getf (getf result :payload) :text))))))))) + + action)) (defun policy-find-engineering-standards-gate () "Searches for the Engineering Standards gate across known jailed package names. -Returns the function symbol, or NIL if unavailable." + + The standards skill may be in opencortex-contrib submodule, + so we search multiple possible package names with graceful fallback. + + Returns the function symbol, or NIL if unavailable." + (dolist (pkg-name '(:opencortex.skills.org-skill-engineering-standards :opencortex.skills.org-skill-engineering :opencortex.skills.engineering-standards) nil) + (let ((pkg (find-package pkg-name))) (when pkg (let ((sym (find-symbol "ENGINEERING-STANDARDS-GATE" pkg))) @@ -204,18 +370,31 @@ Returns the function symbol, or NIL if unavailable." (return (symbol-function sym)))))))) (defun policy-deterministic-gate (action context) - "The main policy gate. Runs invariant checks, then delegates to engineering standards if available. -Never returns NIL silently; always returns an action or an auditable log event." + "The main policy gate entry point. + + This function is registered as the deterministic-fn for the policy skill. + It runs invariant checks, then delegates to engineering standards if loaded. + + IMPORTANT: Never returns NIL silently. Always returns either: + - An action (possibly modified) + - A blocking LOG event with explanation + - A warning wrapper with explanation" + + ;; Step 1: Run invariant checks (let ((current-action (policy-run-invariant-checks action context))) - ;; If an invariant returned a blocking log, do not proceed further + + ;; Step 2: If an invariant blocked the action, stop here (when (and (listp current-action) (member (getf current-action :type) '(:LOG :EVENT)) (eq (getf (getf current-action :payload) :level) :error)) + (return-from policy-deterministic-gate current-action)) - ;; Delegate to Engineering Standards if loaded + + ;; Step 3: Delegate to Engineering Standards if loaded (let ((eng-gate (policy-find-engineering-standards-gate))) (when eng-gate (setf current-action (funcall eng-gate current-action context)))) + current-action)) (defskill :skill-policy diff --git a/library/gen/org-skill-self-edit.lisp b/library/gen/org-skill-self-edit.lisp index 8f8df45..48578f4 100644 --- a/library/gen/org-skill-self-edit.lisp +++ b/library/gen/org-skill-self-edit.lisp @@ -116,3 +116,62 @@ Provide a fixed version of the code as a lisp form.") (list :status :success :repaired balanced)) (error (c) (list :status :error :message (format nil "Could not repair: ~a" c))))))) + +(defvar *self-edit-skills-backup* nil + "Backup of skill registry before hot-reload.") + +(defun self-edit-hot-reload-skill (skill-name gen-path) + "Reloads a skill from its compiled .lisp source. + + Steps: + 1. Backup current *skills-registry* + 2. Compile the new skill file + 3. Merge new skill into registry + 4. Verify the skill loads without error + 5. If error, rollback to backup + + Returns (values :success t) or (values :error message)." + (unless *skills-registry* + (return-from self-edit-hot-reload-skill + (values :error "Skills engine not initialized"))) + (unless (uiop:file-exists-p gen-path) + (return-from self-edit-hot-reload-skill + (values :error (format nil "Skill file not found: ~a" gen-path)))) + + ;; Step 1: Backup registry + (setf *self-edit-skills-backup* (copy-hash-table *skills-registry*)) + + (handler-case + (progn + ;; Step 2: Compile new skill + (let ((compiled (compile-file gen-path))) + (unless compiled + (error "Compilation returned nil"))) + ;; Step 3: Load the compiled skill + (load gen-path) + ;; Step 4: Verify skill is in registry + (let ((skill (gethash (string skill-name) *skills-registry*))) + (if skill + (progn + (harness-log "SELF-EDIT: Hot-reloaded skill ~a from ~a" + skill-name gen-path) + (values :success t)) + (error "Skill not registered after reload")))) + (error (e) + ;; Step 5: Rollback + (when *self-edit-skills-backup* + (clrhash *skills-registry*) + (maphash (lambda (k v) (setf (gethash k *skills-registry*) v)) + *self-edit-skills-backup*)) + (harness-log "SELF-EDIT: Hot-reload FAILED for ~a: ~a" skill-name e) + (values :error (format nil "Hot-reload failed: ~a" e))))) + +(def-cognitive-tool :reload-skill + "Hot-reloads a skill from its compiled source file without restarting the system." + ((:skill-name :type :string :description "Name of the skill to reload (e.g. :skill-engineering-standards)") + (:gen-path :type :string :description "Absolute path to the compiled .lisp file")) + :body (lambda (args) + (let ((name (getf args :skill-name)) + (path (getf args :gen-path))) + (multiple-value-bind (status message) (self-edit-hot-reload-skill name path) + (list :status status :message message))))) diff --git a/library/loop.lisp b/library/loop.lisp index d4fa14d..b57190f 100644 --- a/library/loop.lisp +++ b/library/loop.lisp @@ -1,99 +1,193 @@ (in-package :opencortex) -(defvar *interrupt-flag* nil) -(defvar *interrupt-lock* (bordeaux-threads:make-lock "harness-interrupt-lock")) -(defvar *heartbeat-thread* nil) +(defvar *interrupt-flag* nil + "Atomic flag set by signal handlers to trigger graceful shutdown. + Using a dedicated variable avoids race conditions in interrupt handling.") + +(defvar *interrupt-lock* (bt:make-lock "harness-interrupt-lock") + "Mutex protecting *interrupt-flag* access. + Locking is required because SBCL's interrupt handlers run in uncertain contexts.") + +(defvar *heartbeat-thread* nil + "Handle to the heartbeat thread, allowing explicit termination on shutdown.") (defun process-signal (signal) - "The entry point to the Metabolic Pipeline: Perceive -> Reason -> Act." + "The entry point to the Metabolic Pipeline: Perceive -> Reason -> Act. + + SIGNAL is a property list with the following structure: + - :type - :EVENT, :REQUEST, :RESPONSE, etc. + - :payload - The actual content (sensor data, approved actions, etc.) + - :meta - Metadata including source, session, reply stream + - :depth - Recursion depth counter (starts at 0) + - :status - Processing status (:perceived, :reasoned, :acted) + + Returns NIL when processing is complete, or a new signal for feedback loop." + (let ((current-signal signal)) (loop while current-signal do + + ;; Depth limiting prevents infinite recursion from feedback loops (let ((depth (getf current-signal :depth 0)) (meta (getf current-signal :meta))) - (when (> depth 10) (harness-log "METABOLISM ERROR: Max depth reached.") (return nil)) - (when (bordeaux-threads:with-lock-held (*interrupt-lock*) *interrupt-flag*) - (harness-log "METABOLISM: Interrupted.") - (bordeaux-threads:with-lock-held (*interrupt-lock*) (setf *interrupt-flag* nil)) + (when (> depth 10) + (harness-log "METABOLISM ERROR: Max recursion depth reached.") (return nil)) + + ;; Check for graceful shutdown interrupt + (when (bt:with-lock-held (*interrupt-lock*) *interrupt-flag*) + (harness-log "METABOLISM: Interrupted by shutdown signal.") + (bt:with-lock-held (*interrupt-lock*) (setf *interrupt-flag* nil)) + (return nil)) + + ;; The three-stage pipeline wrapped in error handling (handler-case (progn + ;; Stage 1: Perceive - normalize sensory input (setf current-signal (perceive-gate current-signal)) + + ;; Stage 2: Reason - generate and verify action proposals (setf current-signal (reason-gate current-signal)) + + ;; Stage 3: Act - execute approved actions (let ((feedback (act-gate current-signal))) - ;; feedback generation (if feedback + ;; Action generated a feedback signal - continue processing (progn - ;; Inherit meta from trigger signal - (unless (getf feedback :meta) (setf (getf feedback :meta) meta)) + ;; Preserve metadata from original signal + (unless (getf feedback :meta) + (setf (getf feedback :meta) meta)) (setf current-signal feedback)) + ;; No feedback - pipeline complete (setf current-signal nil)))) + + ;; Error recovery with differentiated response (error (c) (let ((sensor (ignore-errors (getf (getf current-signal :payload) :sensor)))) (harness-log "METABOLISM CRASH [~a]: ~a" (or sensor :unknown) c) - ;; Only rollback on critical errors, not standard tool or loop errors + + ;; Only rollback memory on critical errors, not transient tool failures + ;; This prevents losing recent context due to a single bad API call (unless (member sensor '(:loop-error :tool-error :syntax-error)) (harness-log "CRITICAL ERROR: Initiating Micro-Rollback.") (rollback-memory 0)) + + ;; At deep recursion or known error types, terminate gracefully (if (or (> depth 2) (member sensor '(:loop-error :tool-error))) (setf current-signal nil) - (setf current-signal (list :type :EVENT :depth (1+ depth) :meta meta - :payload (list :sensor :loop-error :message (format nil "~a" c) :depth depth))))))))))) + ;; Otherwise, convert error to a loop-error signal for retry + (setf current-signal + (list :type :EVENT + :depth (1+ depth) + :meta meta + :payload (list :sensor :loop-error + :message (format nil "~a" c) + :depth depth))))))))))) (defvar *auto-save-interval* 300 - "Save memory to disk every N seconds. Set from MEMORY_AUTO_SAVE_INTERVAL env.") + "Interval in seconds between automatic memory saves. + Defaults to 300 seconds (5 minutes). Set via MEMORY_AUTO_SAVE_INTERVAL env var.") (defvar *heartbeat-save-counter* 0 - "Counter for auto-save triggers.") + "Tracks heartbeats since last save, used to calculate auto-save timing.") (defun start-heartbeat () - "Starts the background heartbeat thread. Interval is loaded from HEARTBEAT_INTERVAL." + "Starts the background heartbeat thread. + + The heartbeat runs in a dedicated thread to avoid blocking the main + signal processing loop. Each heartbeat: + + 1. Injects a :HEARTBEAT signal into the metabolic pipeline + 2. Checks if memory should be auto-saved (based on interval ratio) + + Configuration via environment: + - HEARTBEAT_INTERVAL: Seconds between heartbeats (default: 60) + - MEMORY_AUTO_SAVE_INTERVAL: Seconds between auto-saves (default: 300)" + (let ((interval (or (ignore-errors (parse-integer (uiop:getenv "HEARTBEAT_INTERVAL"))) 60)) (auto-save (or (ignore-errors (parse-integer (uiop:getenv "MEMORY_AUTO_SAVE_INTERVAL"))) *auto-save-interval*))) (setf *auto-save-interval* auto-save) (setf *heartbeat-save-counter* 0) - (setf *heartbeat-thread* - (bordeaux-threads:make-thread - (lambda () - (loop - (sleep interval) + + (setf *heartbeat-thread* + (bt:make-thread + (lambda () + (loop + ;; Wait for interval + (sleep interval) + + ;; Update counter and check if it's time to save (incf *heartbeat-save-counter*) (when (>= *heartbeat-save-counter* (/ *auto-save-interval* interval)) (setf *heartbeat-save-counter* 0) (save-memory-to-disk)) - ;; inject-stimulus is synchronous for heartbeats, preventing accumulation. - (inject-stimulus (list :type :EVENT :payload (list :sensor :heartbeat :unix-time (get-universal-time)))))) - :name "opencortex-heartbeat")))) + + ;; Inject heartbeat signal - this runs through the full pipeline + ;; allowing the agent to do latent reflection even with no input + (inject-stimulus + (list :type :EVENT + :payload (list :sensor :heartbeat + :unix-time (get-universal-time))))) + + :name "opencortex-heartbeat"))))) (defvar *shutdown-save-enabled* t - "If non-nil, save memory to disk on graceful shutdown.") + "When T, save memory to disk on graceful shutdown. + Disable for testing or when memory persistence is handled externally.") (defun main () - "Entry point for the Skeleton MVP. Handles initialization and graceful shutdown." - (let* ((home (uiop:getenv "HOME")) - (env-file (uiop:merge-pathnames* ".local/share/opencortex/.env" (uiop:ensure-directory-pathname home)))) - (when (uiop:file-exists-p env-file) (cl-dotenv:load-env env-file))) + "Entry point for OpenCortex. Initializes the system and enters idle loop. - ;; Load memory from disk if a snapshot exists + Startup sequence: + 1. Load environment from ~/.local/share/opencortex/.env + 2. Restore memory from disk (if snapshot exists) + 3. Initialize actuators (shell, cli, system) + 4. Load all skills from SKILLS_DIR + 5. Start heartbeat thread + 6. Register SIGINT handler for graceful shutdown + 7. Enter idle loop (sleeps in DAEMON_SLEEP_INTERVAL chunks) + + The idle loop checks for interrupts and saves memory before exit." + + ;; Step 1: Load environment variables from standard location + (let* ((home (uiop:getenv "HOME")) + (env-file (uiop:merge-pathnames* + ".local/share/opencortex/.env" + (uiop:ensure-directory-pathname home)))) + (when (uiop:file-exists-p env-file) + (cl-dotenv:load-env env-file))) + + ;; Step 2: Crash recovery - load memory from previous snapshot (load-memory-from-disk) + ;; Step 3-4: Initialize actuators and load skills (initialize-actuators) (initialize-all-skills) + ;; Step 5: Start the heartbeat (start-heartbeat) - - ;; Graceful shutdown handler for SBCL + + ;; Step 6: Register graceful shutdown handler + ;; SBCL-specific: catches Ctrl+C (SIGINT) and saves before exit #+sbcl - (sb-sys:enable-interrupt sb-unix:sigint - (lambda (sig code scp) - (declare (ignore sig code scp)) + (sb-sys:enable-interrupt sb-unix:sigint + (lambda (sig code scp) + (declare (ignore sig code scp)) (harness-log "SHUTDOWN: SIGINT received. Saving memory...") - (when *shutdown-save-enabled* (save-memory-to-disk)) + (when *shutdown-save-enabled* + (save-memory-to-disk)) (uiop:quit 0))) - (let ((sleep-interval (or (ignore-errors (parse-integer (uiop:getenv "DAEMON_SLEEP_INTERVAL"))) 3600))) - (loop - (when (bordeaux-threads:with-lock-held (*interrupt-lock*) *interrupt-flag*) + ;; Step 7: Idle loop - sleep in chunks, checking for interrupts + (let ((sleep-interval (or (ignore-errors + (parse-integer (uiop:getenv "DAEMON_SLEEP_INTERVAL"))) + 3600))) + (loop + ;; Check for interrupt before each sleep cycle + (when (bt:with-lock-held (*interrupt-lock*) *interrupt-flag*) (harness-log "SHUTDOWN: Interrupt flag set. Saving memory...") - (when *shutdown-save-enabled* (save-memory-to-disk)) + (when *shutdown-save-enabled* + (save-memory-to-disk)) (return)) + + ;; Sleep in configured intervals (default: 1 hour) (sleep sleep-interval)))) diff --git a/library/memory.lisp b/library/memory.lisp index cb34d8e..077dc3d 100644 --- a/library/memory.lisp +++ b/library/memory.lisp @@ -8,6 +8,10 @@ (defstruct org-object id type attributes content vector parent-id children version last-sync hash) +;; Enable serialization via make-load-form (standard CL) +(defmethod make-load-form ((obj org-object) &optional env) + (make-load-form-saving-slots obj :environment env)) + (defun compute-merkle-hash (id type attributes content child-hashes) "Computes a SHA-256 Merkle hash for a node based on its core properties and children's hashes." (let* ((alist (loop for (k v) on attributes by #'cddr collect (cons k v))) @@ -79,53 +83,61 @@ (harness-log "MEMORY - Memory rolled back to snapshot ~a" index)) (harness-log "MEMORY ERROR - Snapshot ~a not found." index)))) -(defvar *memory-snapshot-path* nil - "Path to the memory snapshot file. Set from MEMORY_SNAPSHOT_PATH env or default.") +(defvar *embedding-cache* (make-hash-table :test 'equal) + "Cache for embeddings to avoid redundant API calls.") -(defun ensure-memory-snapshot-path () - "Initializes the snapshot path from environment or default location." - (or *memory-snapshot-path* - (let ((env-path (uiop:getenv "MEMORY_SNAPSHOT_PATH"))) - (setf *memory-snapshot-path* - (or env-path - (uiop:merge-pathnames* "memory.snap" (user-homedir-pathname))))))) +(defun get-embedding (text) + "Generates a vector embedding for the given text via Ollama. Returns nil on failure." + (when (or (null text) (string= text "")) + (return-from get-embedding nil)) + (let ((cached (gethash text *embedding-cache*))) + (when cached (return-from get-embedding cached))) + (let ((result (funcall (get-cognitive-tool-body :get-ollama-embedding) (list :text text)))) + (when (eq (getf result :status) :success) + (let ((vec (getf result :vector))) + (setf (gethash text *embedding-cache*) vec) + vec)))) -(defun save-memory-to-disk () - "Serializes *memory* and *history-store* to disk for crash recovery. -Converts hash tables to alists for proper serialization." - (let ((path (ensure-memory-snapshot-path))) - (with-open-file (stream path :direction :output :if-exists :supersede :if-does-not-exist :create) - (format stream ";; OpenCortex Memory Snapshot~%") - (format stream ";; Created: ~a~%~%" (format nil "~a" (get-universal-time))) - (let ((memory-alist nil) - (history-alist nil)) - (maphash (lambda (k v) (push (cons k v) memory-alist)) *memory*) - (maphash (lambda (k v) (push (cons k v) history-alist)) *history-store*) - (prin1 (list :memory memory-alist :history-store history-alist) stream))) - (harness-log "MEMORY - Saved to ~a" path) - path)) +(defun cosine-similarity (vec-a vec-b) + "Computes cosine similarity between two vectors. Both should be sequences of numbers." + (when (or (null vec-a) (null vec-b) (zerop (length vec-a)) (zerop (length vec-b))) + (return-from cosine-similarity 0.0)) + (let ((dot-product (loop for a across vec-a + for b across vec-b + sum (* a b))) + (norm-a (sqrt (loop for a across vec-a sum (* a a)))) + (norm-b (sqrt (loop for b across vec-b sum (* b b))))) + (if (or (zerop norm-a) (zerop norm-b)) + 0.0 + (/ dot-product (* norm-a norm-b))))) -(defun load-memory-from-disk () - "Loads *memory* and *history-store* from disk if the snapshot exists. -Reconstitutes alists into hash tables." - (let ((path (ensure-memory-snapshot-path))) - (when (uiop:file-exists-p path) - (handler-case - (with-open-file (stream path :direction :input) - (let ((data (read stream nil))) - (when data - (let ((memory-alist (getf data :memory)) - (history-alist (getf data :history-store))) - (setf *memory* (make-hash-table :test 'equal :size (length memory-alist))) - (dolist (kv memory-alist) - (setf (gethash (car kv) *memory*) (cdr kv))) - (setf *history-store* (make-hash-table :test 'equal :size (length history-alist))) - (dolist (kv history-alist) - (setf (gethash (car kv) *history-store*) (cdr kv))) - (harness-log "MEMORY - Loaded from ~a (~a objects)" path (hash-table-size *memory*)))))) - (error (c) - (harness-log "MEMORY WARNING - Failed to load snapshot: ~a" c)))) - t)) +(defun semantic-search (query &key (limit 10) (min-similarity 0.5)) + "Searches memory for objects semantically similar to the query. +Returns up to LIMIT objects with similarity >= MIN-SIMILARITY, sorted by similarity descending." + (let* ((query-vec (get-embedding query)) + (results nil)) + (unless query-vec + (harness-log "EMBEDDING: Failed to generate embedding for query: ~a" query) + (return-from semantic-search nil)) + (maphash (lambda (id obj) + (let ((obj-vec (org-object-vector obj))) + (when obj-vec + (let ((sim (cosine-similarity query-vec obj-vec))) + (when (>= sim min-similarity) + (push (list :id id :object obj :similarity sim) results)))))) + *memory*) + (setf results (sort results #'> :key (lambda (r) (getf r :similarity)))) + (subseq results 0 (min limit (length results))))) + +(def-cognitive-tool :semantic-search + "Searches memory for objects semantically similar to a query." + ((:query :type :string :description "The search query.") + (:limit :type :integer :description "Maximum results to return." :default 10) + (:min-similarity :type :number :description "Minimum similarity threshold (0-1)." :default 0.5)) + :body (lambda (args) + (semantic-search (getf args :query) + :limit (or (getf args :limit) 10) + :min-similarity (or (getf args :min-similarity) 0.5)))) (defun org-id-new () "Generates a new UUID string for Org-mode identification." @@ -161,58 +173,3 @@ Reconstitutes alists into hash tables." (defun file-name-nondirectory (path) "Extracts the filename from a full path string." (let ((pos (position #\/ path :from-end t))) (if pos (subseq path (1+ pos)) path))) - -(defvar *embedding-cache* (make-hash-table :test 'equal) - "Cache for embeddings to avoid redundant API calls.") - -(defun get-embedding (text) - "Generates a vector embedding for the given text via Ollama. Returns nil on failure." - (when (or (null text) (string= text "")) - (return-from get-embedding nil)) - (let ((cached (gethash text *embedding-cache*))) - (when cached (return-from get-embedding cached))) - (let ((result (funcall (get-cognitive-tool-body :get-ollama-embedding) (list :text text)))) - (when (eq (getf result :status) :success) - (let ((vec (getf result :vector))) - (setf (gethash text *embedding-cache*) vec) - vec)))) - -(defun cosine-similarity (vec-a vec-b) - "Computes cosine similarity between two vectors. Both should be sequences of numbers." - (when (or (null vec-a) (null vec-b) (zerop (length vec-a)) (zerop (length vec-b))) - (return-from cosine-similarity 0.0)) - (let ((dot-product (loop for a across vec-a - for b across vec-b - sum (* a b))) - (norm-a (sqrt (loop for a across vec-a sum (* a a)))) - (norm-b (sqrt (loop for b across vec-b sum (* b b))))) - (if (or (zerop norm-a) (zerop norm-b)) - 0.0 - (/ dot-product (* norm-a norm-b))))) - -(defun semantic-search (query &key (limit 10) (min-similarity 0.5)) - "Searches memory for objects semantically similar to the query." - (let* ((query-vec (get-embedding query)) - (results nil)) - (unless query-vec - (harness-log "EMBEDDING: Failed to generate embedding for query: ~a" query) - (return-from semantic-search nil)) - (maphash (lambda (id obj) - (let ((obj-vec (org-object-vector obj))) - (when obj-vec - (let ((sim (cosine-similarity query-vec obj-vec))) - (when (>= sim min-similarity) - (push (list :id id :object obj :similarity sim) results)))))) - *memory*) - (setf results (sort results #'> :key (lambda (r) (getf r :similarity)))) - (subseq results 0 (min limit (length results))))) - -(def-cognitive-tool :semantic-search - "Searches memory for objects semantically similar to a query." - ((:query :type :string :description "The search query.") - (:limit :type :integer :description "Maximum results to return." :default 10) - (:min-similarity :type :number :description "Minimum similarity threshold (0-1)." :default 0.5)) - :body (lambda (args) - (semantic-search (getf args :query) - :limit (or (getf args :limit) 10) - :min-similarity (or (getf args :min-similarity) 0.5)))) diff --git a/library/perceive.lisp b/library/perceive.lisp index f34a2a8..58153c6 100644 --- a/library/perceive.lisp +++ b/library/perceive.lisp @@ -1,60 +1,130 @@ (in-package :opencortex) (defvar *async-sensors* '(:chat-message :delegation :user-command) - "List of sensors that should be processed asynchronously to avoid blocking gateways.") + "Sensors that are processed in dedicated threads. + + These sensors can block (waiting for API responses, user input, etc.) + so they run in separate threads to avoid blocking the main pipeline. + + Other sensors (:heartbeat, :interrupt, :buffer-update) are processed + synchronously to maintain temporal ordering.") (defvar *foveal-focus-id* nil - "The Org ID of the node the user is currently interacting with.") + "The Org ID of the node the user is currently interacting with. + + This enables the reasoning engine to provide contextually relevant + responses. When editing a specific note, the agent knows which + note you're referring to without needing explicit ID references. + + Updated on :point-update events from Emacs.") (defun inject-stimulus (raw-message &key stream (depth 0)) - "Enqueues a raw message into the reactive signal pipeline." - (let* ((payload (getf raw-message :payload)) + "Inject a raw message into the signal processing pipeline. + + RAW-MESSAGE is a property list that will be normalized into a Signal. + STREAM is an optional output stream for responses (used by TUI/CLI). + DEPTH tracks recursion depth for feedback loops. + + This function determines whether to process synchronously or + asynchronously based on the sensor type, then calls process-signal + to run through the Perceive -> Reason -> Act pipeline. + + Error handling: Uses restarts to prevent individual signals from + crashing the entire system. Failed signals are logged and dropped." + + (let* ((payload (getf raw-message :payload)) (sensor (getf payload :sensor)) (meta (getf raw-message :meta)) - (async-p (or (getf payload :async-p) (member sensor *async-sensors*)))) - - ;; Ensure META exists and contains the stream if provided - (unless meta (setf meta (list :SOURCE :SYSTEM :SESSION-ID "internal"))) - (when stream (setf (getf meta :reply-stream) stream)) + (async-p (or (getf payload :async-p) + (member sensor *async-sensors*)))) + + ;; Ensure metadata exists + (unless meta + (setf meta (list :SOURCE :SYSTEM :SESSION-ID "internal"))) + + ;; Attach reply stream if provided + (when stream + (setf (getf meta :reply-stream) stream)) + (setf (getf raw-message :meta) meta) - (if async-p - (bordeaux-threads:make-thread - (lambda () - (restart-case (handler-bind ((error (lambda (c) (harness-log "ASYNC ERROR: ~a" c) (invoke-restart 'skip-event)))) - (process-signal raw-message)) - (skip-event () nil))) + (if async-p + ;; Async: process in dedicated thread + (bt:make-thread + (lambda () + (restart-case + (handler-bind ((error (lambda (c) + (harness-log "ASYNC ERROR: ~a" c) + (invoke-restart 'skip-event)))) + (process-signal raw-message)) + (skip-event () nil))) :name "opencortex-async-task") - (restart-case (handler-bind ((error (lambda (c) (harness-log "SYSTEM ERROR: ~a" c) (invoke-restart 'skip-event)))) - (process-signal raw-message)) - (skip-event () (harness-log "SYSTEM RECOVERY: Stimulus dropped.~%")))))) + + ;; Sync: process in main thread with recovery + (restart-case + (handler-bind ((error (lambda (c) + (harness-log "SYSTEM ERROR: ~a" c) + (invoke-restart 'skip-event)))) + (process-signal raw-message)) + (skip-event () + (harness-log "SYSTEM RECOVERY: Stimulus dropped.")))))) (defun perceive-gate (signal) - "Initial processing: Normalizes raw stimuli and updates memory." + "Stage 1 of the metabolic pipeline: Normalize sensory input. + + This function: + 1. Logs the incoming signal for debugging + 2. Handles special sensor types (:buffer-update, :point-update, etc.) + 3. Updates the Memory graph with incoming data + 4. Tracks foveal focus (user's current node) + 5. Sets :status to :perceived + + Modifies the signal in place and returns it for the next stage. + + Memory snapshots are taken before AST updates to enable rollback + if the update causes issues." + (let* ((payload (getf signal :payload)) (type (getf signal :type)) (meta (getf signal :meta)) (sensor (getf payload :sensor))) - (harness-log "GATE [Perceive]: ~a (~a) [Source: ~s]" type (or sensor "no-sensor") (getf meta :source)) - + + ;; Log the incoming signal for debugging + (harness-log "GATE [Perceive]: ~a (~a) [Source: ~s]" + type (or sensor "no-sensor") (getf meta :source)) + + ;; Handle EVENT type sensors (cond ((eq type :EVENT) (case sensor - (:buffer-update - (let ((ast (getf payload :ast))) - (when ast - (snapshot-memory) + + ;; Org buffer was modified - update memory + (:buffer-update + (let ((ast (getf payload :ast))) + (when ast + (snapshot-memory) ; Enable rollback if update causes issues (ingest-ast ast)))) - (:point-update - (let ((element (getf payload :element))) - (when element + + ;; Point moved to different org node - update focus + (:point-update + (let ((element (getf payload :element))) + (when element (snapshot-memory) - (setf *foveal-focus-id* (ignore-errors (getf element :id))) + ;; Track foveal focus for contextual reasoning + (setf *foveal-focus-id* + (ignore-errors (getf element :id))) (ingest-ast element)))) - (:interrupt - (bordeaux-threads:with-lock-held (*interrupt-lock*) (setf *interrupt-flag* t))))) + + ;; System interrupt - trigger shutdown + (:interrupt + (bt:with-lock-held (*interrupt-lock*) + (setf *interrupt-flag* t))))) + + ;; Log responses from actuators ((eq type :RESPONSE) - (harness-log "GATE [Perceive]: Act Result -> ~a" (getf payload :status)))) - + (harness-log "GATE [Perceive]: Act Result -> ~a" + (getf payload :status)))) + + ;; Update signal status (setf (getf signal :status) :perceived) (setf (getf signal :foveal-focus) *foveal-focus-id*) signal)) diff --git a/library/reason.lisp b/library/reason.lisp index dfaecfe..d8eff5b 100644 --- a/library/reason.lisp +++ b/library/reason.lisp @@ -1,33 +1,86 @@ (in-package :opencortex) -(defvar *probabilistic-backends* (make-hash-table :test 'equal)) -(defvar *provider-cascade* nil) -(defvar *model-selector-fn* nil) -(defvar *consensus-enabled-p* nil) +(defvar *probabilistic-backends* (make-hash-table :test 'equal) + "Registry mapping provider keywords (:openrouter, :ollama) to their calling functions.") + +(defvar *provider-cascade* nil + "Ordered list of provider keywords to try. First available provider wins.") + +(defvar *model-selector-fn* nil + "Optional function that selects a specific model for each provider. + Signature: (funcall fn provider context) => model-name-string") + +(defvar *consensus-enabled-p* nil + "When T, run multiple providers and compare results for critical decisions.") (defun register-probabilistic-backend (name fn) - "Registers a neural provider (e.g., :gemini, :anthropic) with its calling function." + "Register a neural provider backend. + + NAME is a keyword like :openrouter or :ollama. + FN is a function with signature: (funcall fn prompt system-prompt &key model) + returning either: + - (list :status :success :content \"response text\") + - (list :status :error :message \"error description\") + - a simple string on success + + Example registration: + (register-probabilistic-backend :openrouter #'openrouter-call)" + (setf (gethash name *probabilistic-backends*) fn)) -(defun probabilistic-call (prompt &key (system-prompt "You are the Probabilistic engine.") (cascade nil) (context nil)) - "Dispatches a neural request through the provider cascade. Returns a Lisp plist or a failure log." +(defun probabilistic-call (prompt &key + (system-prompt "You are the Probabilistic engine.") + (cascade nil) + (context nil)) + "Dispatch a neural request through the provider cascade. + + PROMPT - The user's query or task description. + SYSTEM-PROMPT - Instructions for how the LLM should behave. + CASCADE - Override the default provider cascade. + CONTEXT - Current signal context (for model selection). + + Returns the LLM response as a string, or a failure plist if all providers fail. + + The cascade mechanism ensures reliability: if OpenRouter is rate-limited, + it automatically falls back to OpenAI, then Anthropic, etc." + (let ((backends (or cascade *provider-cascade*))) (or (dolist (backend backends) (let ((backend-fn (gethash backend *probabilistic-backends*))) (when backend-fn (harness-log "PROBABILISTIC: Attempting backend ~a..." backend) - (let* ((model (when *model-selector-fn* (funcall *model-selector-fn* backend context))) - (result (if model + + ;; Optional model selection based on context + (let* ((model (when *model-selector-fn* + (funcall *model-selector-fn* backend context))) + (result (if model (funcall backend-fn prompt system-prompt :model model) (funcall backend-fn prompt system-prompt)))) + + ;; Normalize result format (cond ((and (listp result) (eq (getf result :status) :success)) (return (getf result :content))) - ((stringp result) (return result)) - (t (harness-log "PROBABILISTIC: Backend ~a failed: ~a" backend (getf result :message)))))))) - (list :type :LOG :payload (list :text "Neural Cascade Failure: All providers exhausted."))))) + ((stringp result) + (return result)) + (t + (harness-log "PROBABILISTIC: Backend ~a failed: ~a" + backend (getf result :message)))))))) + + ;; All providers failed + (list :type :LOG + :payload (list :text "Neural Cascade Failure: All providers exhausted."))))) (defun strip-markdown (text) - "Strips common markdown code block markers from text." + "Strip markdown formatting from LLM output. + + LLMs often wrap their responses in code fences (```lisp ...```). + This function removes those markers to extract the raw plist. + + Handles: + - Leading code fences with language tags: ```lisp + - Trailing code fences: ``` + - Orphan closing fences: ```" + (if (and text (stringp text)) (let ((cleaned text)) (setf cleaned (cl-ppcre:regex-replace-all "^```[a-z]*\\n" cleaned "")) @@ -37,7 +90,18 @@ text)) (defun normalize-plist-keywords (plist) - "Normalize all keys in a plist to keywords (e.g., TYPE -> :TYPE)." + "Normalize all keys in a plist to keywords. + + LLMs often return plists with unquoted keys: (TYPE REQUEST ...) + instead of keyword syntax: (:TYPE :REQUEST ...) + + This function converts all symbol keys to their keyword equivalents, + making the plist compatible with standard Lisp property accessors. + + Example transformation: + (TYPE REQUEST PAYLOAD (ACTION MESSAGE TEXT \"Hi\")) + => (:TYPE :REQUEST :PAYLOAD (:ACTION :MESSAGE :TEXT \"Hi\"))" + (when (listp plist) (loop for (k . rest) on plist by #'cddr collect (if (and (symbolp k) (not (keywordp k))) @@ -46,88 +110,252 @@ collect (car rest)))) (defun think (context) - "Generates a Lisp action proposal based on current context." + "Generate a Lisp action proposal based on current context. + + This is the core cognitive function. It: + + 1. Finds the most relevant skill based on context + 2. Assembles global awareness (memory context, system logs) + 3. Constructs a detailed prompt with available tools + 4. Calls the LLM via probabilistic-call + 5. Parses the LLM response into a structured action plist + + The LLM is instructed to respond with exactly ONE plist, never prose. + This constraint makes parsing deterministic and prevents rambling. + + Returns a plist with structure: + (:TYPE :REQUEST :TARGET :CLI :PAYLOAD (:ACTION :MESSAGE :TEXT \"...\"))" + + ;; Gather context components (let* ((active-skill (find-triggered-skill context)) (tool-belt (generate-tool-belt-prompt)) (global-context (context-assemble-global-awareness)) (system-logs (context-get-system-logs)) (assistant-name (or (uiop:getenv "MEMEX_ASSISTANT") "Agent"))) - (let* ((prompt-generator (when active-skill (skill-probabilistic-prompt active-skill))) - (raw-prompt (if prompt-generator + + ;; Generate prompt from skill or raw text + (let* ((prompt-generator (when active-skill + (skill-probabilistic-prompt active-skill))) + (raw-prompt (if prompt-generator (funcall prompt-generator context) + ;; Fallback: use raw user input (let ((p (proto-get (proto-get context :payload) :text))) - (if (and p (stringp p)) p "Maintain metabolic stasis.")))) - (system-prompt (format nil "IDENTITY: ~a. MANDATE: Respond with ONE Lisp plist. ~a ~a RECENT_LOGS: ~a + (if (and p (stringp p)) + p + "Maintain metabolic stasis.")))) + (system-prompt (format nil + "IDENTITY: ~a + +You are a component of the OpenCortex neurosymbolic AI agent. +Your task is to generate exactly ONE valid Lisp plist response. + +MANDATE: Respond with ONE Lisp plist. Never output prose. + IMPORTANT: To reply to the user, you MUST use: (:TYPE :REQUEST :PAYLOAD (:ACTION :MESSAGE :TEXT \"\")) To call a tool, you MUST use: (:TYPE :REQUEST :TARGET :TOOL :ACTION :CALL :TOOL \"\" :ARGS (:arg1 \"val\")) -MANDATORY VALIDATION RULE: Before declaring any Lisp code edit complete, you MUST call the `:validate-lisp` tool with the proposed code. If the tool returns `:status :error`, read the `:reason` and `:failed` fields, fix the defect, and re-validate. You are strictly forbidden from relying on your own paren-balancing or syntax intuition. +MANDATORY VALIDATION RULE: Before declaring any Lisp code edit complete, +you MUST call the `:validate-lisp` tool with the proposed code. If the tool +returns `:status :error`, read the `:reason` and `:failed` fields, fix the +defect, and re-validate. You are strictly forbidden from relying on your +own paren-balancing or syntax intuition. -PROVIDER RULE: Always use the default cascade provider unless a specific model or capability is required for the task." - assistant-name global-context tool-belt system-logs))) - (let* ((thought (probabilistic-call raw-prompt :system-prompt system-prompt :context context)) +PROVIDER RULE: Always use the default cascade provider unless a specific +model or capability is required for the task. + +AVAILABLE TOOLS: +~a + +GLOBAL CONTEXT: +~a + +RECENT LOGS: +~a" + assistant-name + tool-belt + global-context + system-logs))) + + ;; Call LLM and process response + (let* ((thought (probabilistic-call raw-prompt + :system-prompt system-prompt + :context context)) (cleaned (strip-markdown thought)) (meta (proto-get context :meta)) (source (proto-get meta :source))) - (harness-log "THINK: raw cleaned = ~a" (subseq cleaned 0 (min 100 (length cleaned)))) - (if (and cleaned (stringp cleaned)) + + (when cleaned + (harness-log "THINK: LLM raw output = ~a" + (subseq cleaned 0 (min 200 (length cleaned))))) + + ;; Parse LLM response + (if (and cleaned (stringp cleaned) (> (length cleaned) 0)) (let ((*read-eval* nil)) - (if (and (> (length cleaned) 0) (char= (char cleaned 0) #\()) - (handler-case + (if (char= (char cleaned 0) #\() + ;; Response starts with paren - try to parse as plist + (handler-case (let ((parsed (read-from-string cleaned))) - (harness-log "THINK: parsed = ~a" parsed) - (let ((parsed-normalized (normalize-plist-keywords parsed)) - (type (proto-get parsed :TYPE)) - (target (or (proto-get parsed :TARGET) (proto-get parsed :target)))) - (cond ((member type '(:REQUEST :EVENT :STATUS :RESPONSE)) - (unless (proto-get parsed :target) (setf (getf parsed :target) (or source :CLI))) - parsed-normalized) - ((or (eq target :TOOL) (eq target :tool) (getf parsed :TOOL) (getf parsed :tool) - (and (listp parsed) (listp (car parsed)) (keywordp (caar parsed)))) - (list :TYPE :REQUEST :TARGET :TOOL :PAYLOAD (normalize-plist-keywords parsed))) - (t (list :TYPE :REQUEST :TARGET (or source :CLI) :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned)))))) - (error (c) (harness-log "THINK ERROR: ~a" c) (list :TYPE :REQUEST :TARGET (or source :CLI) :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned)))) - (list :TYPE :REQUEST :TARGET (or source :CLI) :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned)))) + (when parsed + (harness-log "THINK: parsed = ~a" parsed) + + ;; Normalize keyword keys (LLM often returns TYPE instead of :TYPE) + (let ((parsed-normalized (normalize-plist-keywords parsed)) + (type (proto-get parsed :TYPE)) + (target (or (proto-get parsed :TARGET) + (proto-get parsed :target)))) + + (cond + ;; Recognized message type - use directly + ((member type '(:REQUEST :EVENT :STATUS :RESPONSE)) + (unless (proto-get parsed :target) + (setf (getf parsed :target) (or source :CLI))) + parsed-normalized) + + ;; Tool call detected - wrap in standard envelope + ((or (eq target :TOOL) + (eq target :tool) + (getf parsed :TOOL) + (getf parsed :tool) + (and (listp parsed) + (listp (car parsed)) + (keywordp (caar parsed)))) + (list :TYPE :REQUEST + :TARGET :TOOL + :PAYLOAD (normalize-plist-keywords parsed))) + + ;; Unknown format - treat as user message + (t + (list :TYPE :REQUEST + :TARGET (or source :CLI) + :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned))))))) + (error (c) + (harness-log "THINK ERROR: ~a" c) + (list :TYPE :REQUEST + :TARGET (or source :CLI) + :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned)))) + + ;; No leading paren - treat as plain text message + (list :TYPE :REQUEST + :TARGET (or source :CLI) + :PAYLOAD (list :ACTION :MESSAGE :TEXT cleaned)))) + + ;; No response from LLM thought))))) (defun deterministic-verify (proposed-action context) - "Iterates through all skill deterministic-gates sorted by priority." + "Run all skill deterministic gates on a proposed action. + + Each skill can define a deterministic function that either: + - Passes the action through unchanged + - Modifies the action (adds explanation, changes target, etc.) + - Blocks the action (returns a :LOG message instead) + + Skills are sorted by priority (highest first). A skill with higher + priority can intercept and modify actions before lower-priority + skills see them. + + The Bouncer Pattern: If any skill returns a :LOG or :EVENT type, + processing stops and that message is returned immediately. This + allows skills to veto actions. + + Example skill chain: + 1. Policy skill (priority 500) - checks for missing explanations + 2. Protocol validator (priority 95) - validates message schema + 3. Shell actuator guard (priority 50) - checks command whitelist" + (let ((current-action proposed-action) (skills nil)) - (maphash (lambda (name skill) (declare (ignore name)) (when (skill-deterministic-fn skill) (push skill skills))) *skills-registry*) + + ;; Collect all skills with deterministic functions + (maphash (lambda (name skill) + (declare (ignore name)) + (when (skill-deterministic-fn skill) + (push skill skills))) + *skills-registry*) + + ;; Sort by priority (highest first) (setf skills (sort skills #'> :key #'skill-priority)) + + ;; Run each skill's gate (dolist (skill skills) (let ((trigger (skill-trigger-fn skill)) (gate (skill-deterministic-fn skill))) - (when (or (null trigger) (ignore-errors (funcall trigger context))) + + ;; Skill activates if no trigger or trigger returns true + (when (or (null trigger) + (ignore-errors (funcall trigger context))) + + ;; Run the gate (let ((next-action (funcall gate current-action context))) (let ((original-type (proto-get current-action :type))) - (when (and (listp next-action) - (member (proto-get next-action :type) '(:LOG :EVENT :log :event)) + + ;; Check if skill intercepted (returned LOG/EVENT instead of REQUEST) + (when (and (listp next-action) + (member (proto-get next-action :type) + '(:LOG :EVENT :log :event)) (or (not (member original-type '(:LOG :EVENT :log :event))) (not (eq next-action current-action)))) - (harness-log "DETERMINISTIC: Intercepted by skill '~a'" (skill-name skill)) + + ;; Skill blocked or modified - stop processing + (harness-log "DETERMINISTIC: Intercepted by skill '~a'" + (skill-name skill)) (return-from deterministic-verify next-action))) + + ;; Action passed through - continue to next skill (setf current-action next-action))))) + + ;; Return final action (may be modified by skills, or original if all passed) current-action)) (defun reason-gate (signal) - "Unified Stage: Combines Probabilistic proposals and Deterministic verification." + "Stage 2 of the metabolic pipeline: Reason. + + Transforms perceived signals into approved actions by combining: + 1. Probabilistic reasoning (LLM generates proposal) + 2. Deterministic verification (skills validate proposal) + + Only processes :EVENT signals with :user-input or :chat-message sensors. + Other signals pass through unchanged (heartbeats, tool outputs, etc.). + + Modifies the signal in place by setting: + - :approved-action - The final verified action, or NIL + - :status - :reasoned + + Returns the modified signal." + (let* ((type (proto-get signal :type)) (payload (proto-get signal :payload)) (sensor (proto-get payload :sensor))) - (unless (and (eq type :EVENT) (member sensor '(:user-input :chat-message))) + + ;; Only reason about user input, not internal signals + (unless (and (eq type :EVENT) + (member sensor '(:user-input :chat-message))) (return-from reason-gate signal)) + + ;; Generate proposal via LLM (let ((candidate (think signal))) - (harness-log "REASON: candidate = ~a" (type-of candidate)) - (if (and candidate (listp candidate) - (or (keywordp (car candidate)) (eq (car candidate) 'TYPE) (eq (car candidate) 'type))) - (setf (getf signal :approved-action) (deterministic-verify candidate signal)) + + (harness-log "REASON: candidate type = ~a" (type-of candidate)) + + ;; Validate candidate is a proper plist (not an error string or symbol) + (if (and candidate + (listp candidate) + (or (keywordp (car candidate)) + (eq (car candidate) 'TYPE) + (eq (car candidate) 'type))) + + ;; Valid proposal - run through deterministic verification + (setf (getf signal :approved-action) + (deterministic-verify candidate signal)) + + ;; Invalid response - log and drop (progn - (harness-log "REASON: Invalid candidate type ~a, dropping" (type-of candidate)) + (harness-log "REASON: Invalid candidate type ~a, dropping" + (type-of candidate)) (setf (getf signal :approved-action) nil))) + (setf (getf signal :status) :reasoned) signal))) diff --git a/library/skills.lisp b/library/skills.lisp index 30d004f..d3a1918 100644 --- a/library/skills.lisp +++ b/library/skills.lisp @@ -173,9 +173,9 @@ Only loads blocks that specify a .lisp tangle target, ignoring tests and example (search ".lisp" tl) (not (search "tests/" tl)) (not (search "test/" tl)))))) - ((uiop:string-prefix-p "#+end_src" (string-downcase clean-line)) - (setf in-lisp-block nil) - (setf collect-this-block nil)) + ((uiop:string-prefix-p "#+end" (string-downcase clean-line)) + (setf in-lisp-block nil) + (setf collect-this-block nil)) ((and in-lisp-block collect-this-block) (unless (or (uiop:string-prefix-p ":PROPERTIES:" (string-upcase clean-line)) (uiop:string-prefix-p ":END:" (string-upcase clean-line))) @@ -322,43 +322,108 @@ EXAMPLES: (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))))) -(eval-when (:compile-toplevel :load-toplevel :execute) - (def-cognitive-tool :reload-skill "Reloads a skill from its Org-mode source file." - ((:skill :type :string :description "The skill name")) - :guard (lambda (args context) - (declare (ignore context)) - (let ((skill (getf args :skill))) - (or (uiop:file-exists-p skill) - (let ((dir (or (ignore-errors (uiop:getenv "SKILLS_DIR")) - (namestring (user-homedir-pathname))))) - (uiop:file-exists-p (merge-pathnames (format nil "~a.org" skill) dir)))))) - :body (lambda (args) - (let ((skill (getf args :skill)) - (dir (or (ignore-errors (uiop:getenv "SKILLS_DIR")) - (namestring (user-homedir-pathname))))) - (let ((file (merge-pathnames (format nil "~a.org" skill) (uiop:ensure-directory-pathname dir)))) - (if (uiop:file-exists-p file) - (format nil "OK: skill ~a found" skill) - (format nil "ERROR: skill ~a not found" skill)))))) +(def-cognitive-tool :reload-skill "Reloads a skill from its Org-mode source file, recompiling into the live image without restarting the daemon." + ((:skill :type :string :description "The skill name (e.g., \"org-skill-policy\") or full path to the .org file")) + :guard (lambda (args context) + (declare (ignore context)) + (let ((skill (getf args :skill))) + (or (uiop:file-exists-p skill) + (let ((skills-dir (or (ignore-errors (uiop:getenv "SKILLS_DIR")) + (namestring (merge-pathnames "notes/" (user-homedir-pathname)))))) + (uiop:file-exists-p (merge-pathnames (format nil "~a.org" skill) skills-dir)))))) + :body (lambda (args) + (let ((skill (getf args :skill))) + (snapshot-memory) + (let ((skills-dir (or (ignore-errors (uiop:getenv "SKILLS_DIR")) + (namestring (merge-pathnames "notes/" (user-homedir-pathname))))) + (resolved-path (context-resolve-path skills-dir)) + (skills-dir-actual (if (ignore-errors (uiop:getenv "SKILLS_DIR")) + (uiop:ensure-directory-pathname (context-resolve-path (uiop:getenv "SKILLS_DIR"))) + (uiop:ensure-directory-pathname (user-homedir-pathname))))) + (let ((file (if (uiop:file-exists-p skill) + (uiop:ensure-pathname skill) + (merge-pathnames (format nil "~a.org" skill) skills-dir-actual)))) + (cond + ((not (uiop:file-exists-p file)) + (format nil "ERROR: Skill file not found: ~a" (uiop:native-namestring file))) + (t + (harness-log "SKILL: Hot-reloading ~a..." (pathname-name file)) + (let ((status (load-skill-with-timeout file 10))) + (if (eq status :success) + (let ((base-name (pathname-name file))) + (setf (skill-entry-status (gethash base-name *skill-catalog*)) :ready) + (format nil "OK: Skill '~a' reloaded successfully." base-name)) + (format nil "ERROR: Reload failed with status ~a" status)))))))))) - (def-cognitive-tool :read-File "Reads the contents of a file." - ((:file :type :string)) - :body (lambda (args) - (uiop:read-file-string (getf args :file)))) +(def-cognitive-tool :read-file "Reads the contents of a file as a string." + ((:file :type :string :description "The path to the file to read")) + :guard (lambda (args context) + (declare (ignore context)) + (let* ((file (getf args :file)) + (memex-root (or (uiop:getenv "MEMEX_DIR") "/home/user/memex")) + (truename (ignore-errors (namestring (truename file))))) + (or (null truename) + (str:starts-with-p memex-root truename)))) + :body (lambda (args) + (let ((file (getf args :file))) + (handler-case + (uiop:read-file-string file) + (error (c) + (format nil "ERROR reading ~a: ~a" file c)))))) - (def-cognitive-tool :write-file "Writes content to a file." - ((:file :type :string) (:content :type :string)) - :body (lambda (args) - (with-open-file (out (getf args :file) :direction :output :if-exists :supersede) - (write-string (getf args :content) out)) - "OK")) +(def-cognitive-tool :write-file "Writes content to a file, creating it if it doesn't exist." + ((:file :type :string :description "The path to the file to write") + (:content :type :string :description "The content to write") + (:append :type :string :description "\"t\" to append instead of overwriting (optional)")) + :guard (lambda (args context) + (declare (ignore context)) + (let* ((file (getf args :file)) + (memex-root (or (uiop:getenv "MEMEX_DIR") "/home/user/memex")) + (truename (ignore-errors (namestring (truename file))))) + (or (null truename) + (str:starts-with-p memex-root truename)))) + :body (lambda (args) + (let ((file (getf args :file)) + (content (getf args :content)) + (append-p (string-equal (getf args :append) "t"))) + (handler-case + (progn + (snapshot-memory) + (with-open-file (out file + :direction :output + :if-exists (if append-p :append :supersede) + :if-does-not-exist :create) + (write-string content out)) + (format nil "OK: ~a written to ~a" + (if append-p "content appended" "file written") + file)) + (error (c) + (format nil "ERROR writing ~a: ~a" file c)))))) - (def-cognitive-tool :replace-string "Replaces text in a file." - ((:file :type :string) (:old :type :string) (:new :type :string)) - :body (lambda (args) - (let ((content (uiop:read-file-string (getf args :file)))) - (setf content (cl-ppcre:regex-replace-all (cl-ppcre:quote-meta-chars (getf args :old)) content (getf args :new))) - (with-open-file (out (getf args :file) :direction :output :if-exists :supersede) - (write-string content out)) - "OK"))) -) +(def-cognitive-tool :replace-string "Replaces occurrences of old-string with new-string in a file." + ((:file :type :string :description "The path to the file") + (:old :type :string :description "The substring to find and replace") + (:new :type :string :description "The replacement string")) + :guard (lambda (args context) + (declare (ignore context)) + (let* ((file (getf args :file)) + (memex-root (or (uiop:getenv "MEMEX_DIR") "/home/user/memex")) + (truename (ignore-errors (namestring (truename file))))) + (or (null truename) + (str:starts-with-p memex-root truename)))) + :body (lambda (args) + (let ((file (getf args :file)) + (old (getf args :old)) + (new (getf args :new))) + (handler-case + (progn + (snapshot-memory) + (let ((content (uiop:read-file-string file))) + (if (search old content) + (let ((new-content (cl-ppcre:regex-replace-all (cl-ppcre:quote-meta-chars old) content new))) + (with-open-file (out file :direction :output :if-exists :supersede) + (write-string new-content out)) + (format nil "OK: Replaced first occurrence in ~a" file)) + (format nil "ERROR: Pattern not found in ~a" file)))) + (error (c) + (format nil "ERROR replacing in ~a: ~a" file c)))))) diff --git a/opencortex.asd b/opencortex.asd index 8c5e66c..2f135c7 100644 --- a/opencortex.asd +++ b/opencortex.asd @@ -19,18 +19,16 @@ :serial t ; Load files in order listed below -:components ((:file "library/package") ; Package definitions, core vars - (:file "library/skills") ; Skill engine, cognitive tools - (:file "library/communication") ; Protocol, framing - (:file "library/communication-validator") ; Schema validation - (:file "library/memory") ; Org-object store, snapshots - (:file "library/gen/org-skill-engineering-standards") ; Enforcement - (:file "library/gen/org-skill-literate-programming") ; LP enforcement - (:file "library/context") ; Context assembly, query - (:file "library/perceive") ; Stage 1: Sensory normalization - (:file "library/reason") ; Stage 2: Neural + deterministic - (:file "library/act") ; Stage 3: Actuation - (:file "library/loop")) ; Main entry, heartbeat + :components ((:file "library/package") ; Package definitions, core vars + (:file "library/skills") ; Skill engine, cognitive tools + (:file "library/communication") ; Protocol, framing + (:file "library/communication-validator") ; Schema validation + (:file "library/memory") ; Org-object store, snapshots + (:file "library/context") ; Context assembly, query + (:file "library/perceive") ; Stage 1: Sensory normalization + (:file "library/reason") ; Stage 2: Neural + deterministic + (:file "library/act") ; Stage 3: Actuation + (:file "library/loop")) ; Main entry, heartbeat :build-operation "program-op" :build-pathname "opencortex-server" @@ -40,40 +38,42 @@ :depends-on (:opencortex ; The harness we're testing :fiveam) ; Testing framework -:components ((:file "library/gen/org-skill-emacs-edit") - (:file "library/gen/org-skill-lisp-utils") - (:file "library/gen/org-skill-tool-permissions") - (:file "tests/communication-tests") - (:file "tests/pipeline-tests") - (:file "tests/act-tests") - (:file "tests/boot-sequence-tests") - (:file "tests/memory-tests") - (:file "tests/immune-system-tests") - (:file "tests/emacs-edit-tests") - (:file "tests/lisp-utils-tests") - (:file "tests/tool-permissions-tests") - (:file "tests/engineering-standards-tests") - (:file "tests/literate-programming-tests")) + :components ((:file "library/gen/org-skill-engineering-standards") + (:file "library/gen/org-skill-literate-programming") + (:file "library/gen/org-skill-self-edit") + (:file "library/gen/org-skill-emacs-edit") + (:file "library/gen/org-skill-lisp-utils") + (:file "tests/engineering-standards-tests") + (:file "tests/literate-programming-tests") + (:file "tests/pipeline-perceive-tests") + (:file "tests/pipeline-reason-tests") + (:file "tests/pipeline-act-tests") + (:file "tests/act-tests") + (:file "tests/boot-sequence-tests") + (:file "tests/memory-tests") + (:file "tests/immune-system-tests") + (:file "tests/emacs-edit-tests") + (:file "tests/lisp-utils-tests") + (:file "tests/lisp-validator-tests") + (:file "tests/self-edit-tests") + (:file "tests/tool-permissions-tests") + (:file "tests/peripheral-vision-tests")) - :perform (test-op (o s) - (uiop:symbol-call :fiveam :run! - (uiop:find-symbol* :communication-protocol-suite :opencortex-tests)) - (uiop:symbol-call :fiveam :run! - (uiop:find-symbol* :pipeline-suite :opencortex-pipeline-tests)) - (uiop:symbol-call :fiveam :run! - (uiop:find-symbol* :boot-suite :opencortex-boot-tests)) - (uiop:symbol-call :fiveam :run! - (uiop:find-symbol* :memory-suite :opencortex-memory-tests)) - (uiop:symbol-call :fiveam :run! - (uiop:find-symbol* :immune-suite :opencortex-immune-system-tests)) - (uiop:symbol-call :fiveam :run! - (uiop:find-symbol* :emacs-edit-suite :opencortex-emacs-edit-tests)) - (uiop:symbol-call :fiveam :run! - (uiop:find-symbol* :lisp-utils-suite :opencortex-lisp-utils-tests)) - (uiop:symbol-call :fiveam :run! - (uiop:find-symbol* :engineering-standards-suite :opencortex-engineering-standards-tests)) - (uiop:symbol-call :fiveam :run! - (uiop:find-symbol* :literate-programming-suite :opencortex-literate-programming-tests)))) + :perform (test-op (o s) + (uiop:symbol-call :fiveam :run! + (uiop:find-symbol* :communication-protocol-suite :opencortex-tests)) + (uiop:symbol-call :fiveam :run! + (uiop:find-symbol* :pipeline-suite :opencortex-pipeline-tests)) + (uiop:symbol-call :fiveam :run! + (uiop:find-symbol* :boot-suite :opencortex-boot-tests)) + (uiop:symbol-call :fiveam :run! + (uiop:find-symbol* :memory-suite :opencortex-memory-tests)) + (uiop:symbol-call :fiveam :run! + (uiop:find-symbol* :immune-suite :opencortex-immune-system-tests)) + (uiop:symbol-call :fiveam :run! + (uiop:find-symbol* :emacs-edit-suite :opencortex-emacs-edit-tests)) + (uiop:symbol-call :fiveam :run! + (uiop:find-symbol* :lisp-utils-suite :opencortex-lisp-utils-tests)))) (defsystem :opencortex/tui :depends-on (:opencortex ; The daemon we're connecting to diff --git a/run-all-tests.lisp b/run-all-tests.lisp index 09e198f..4ea665f 100644 --- a/run-all-tests.lisp +++ b/run-all-tests.lisp @@ -6,24 +6,45 @@ :dexador :jonathan :cl-dotenv :hunchentoot :trivial-garbage :s-sql :str :uuid :cl-json :uiop :fiveam)) -(load "library/package.lisp") -(load "library/skills.lisp") -(load "library/communication.lisp") -(load "library/communication-validator.lisp") -(load "library/memory.lisp") -(load "library/gen/org-skill-engineering-standards.lisp") -(load "library/gen/org-skill-literate-programming.lisp") -(load "library/context.lisp") -(load "library/perceive.lisp") -(load "library/reason.lisp") -(load "library/act.lisp") -(load "library/loop.lisp") +(asdf:load-system :opencortex) +(asdf:load-system :opencortex/tests) (format t "~%=== Running ALL Test Suites ===~%") +;; Engineering Standards tests (when (find-package :OPENCORTEX-ENGINEERING-STANDARDS-TESTS) (fiveam:run! 'OPENCORTEX-ENGINEERING-STANDARDS-TESTS::ENGINEERING-STANDARDS-SUITE)) + +;; Literate Programming tests (when (find-package :OPENCORTEX-LITERATE-PROGRAMMING-TESTS) (fiveam:run! 'OPENCORTEX-LITERATE-PROGRAMMING-TESTS::LITERATE-PROGRAMMING-SUITE)) -(format t "~%=== ALL TESTS COMPLETE ===~%") \ No newline at end of file +;; Communication tests +(when (find-package :OPENCORTEX-TESTS) + (fiveam:run! 'OPENCORTEX-TESTS::COMMUNICATION-PROTOCOL-SUITE)) + +;; Pipeline tests +(when (find-package :OPENCORTEX-PIPELINE-TESTS) + (fiveam:run! 'OPENCORTEX-PIPELINE-TESTS::PIPELINE-SUITE)) + +;; Boot sequence tests +(when (find-package :OPENCORTEX-BOOT-TESTS) + (fiveam:run! 'OPENCORTEX-BOOT-TESTS::BOOT-SUITE)) + +;; Memory tests +(when (find-package :OPENCORTEX-MEMORY-TESTS) + (fiveam:run! 'OPENCORTEX-MEMORY-TESTS::MEMORY-SUITE)) + +;; Immune system tests +(when (find-package :OPENCORTEX-IMMUNE-SYSTEM-TESTS) + (fiveam:run! 'OPENCORTEX-IMMUNE-SYSTEM-TESTS::IMMUNE-SUITE)) + +;; Emacs edit tests +(when (find-package :OPENCORTEX-EMACS-EDIT-TESTS) + (fiveam:run! 'OPENCORTEX-EMACS-EDIT-TESTS::EMACS-EDIT-SUITE)) + +;; Lisp utils tests +(when (find-package :OPENCORTEX-LISP-UTILS-TESTS) + (fiveam:run! 'OPENCORTEX-LISP-UTILS-TESTS::LISP-UTILS-SUITE)) + +(format t "~%=== ALL TESTS COMPLETE ===~%") diff --git a/skills/org-skill-emacs-edit.org b/skills/org-skill-emacs-edit.org index eaa8814..1b35bb9 100644 --- a/skills/org-skill-emacs-edit.org +++ b/skills/org-skill-emacs-edit.org @@ -404,7 +404,7 @@ Use this AFTER modifications to save changes." (let ((id1 (emacs-edit-generate-id)) (id2 (emacs-edit-generate-id))) (is (plusp (length id1))) - (is (not (string= id1 id2)))) ;; Likely unique + (is (not (string= id1 id2))))) ;; Likely unique (test id-format (let ((formatted (emacs-edit-id-format "abc12345"))) diff --git a/skills/org-skill-self-edit.org b/skills/org-skill-self-edit.org index 10c23e6..0220d12 100644 --- a/skills/org-skill-self-edit.org +++ b/skills/org-skill-self-edit.org @@ -161,6 +161,74 @@ Provide a fixed version of the code as a lisp form.") (list :status :error :message (format nil "Could not repair: ~a" c))))))) #+end_src +** Skill Hot-Reload +Swap compiled skill files without breaking active sockets. + +#+begin_src lisp :tangle ../library/gen/org-skill-self-edit.lisp +(defvar *self-edit-skills-backup* nil + "Backup of skill registry before hot-reload.") + +(defun self-edit-hot-reload-skill (skill-name gen-path) + "Reloads a skill from its compiled .lisp source. + + Steps: + 1. Backup current *skills-registry* + 2. Compile the new skill file + 3. Merge new skill into registry + 4. Verify the skill loads without error + 5. If error, rollback to backup + + Returns (values :success t) or (values :error message)." + (unless *skills-registry* + (return-from self-edit-hot-reload-skill + (values :error "Skills engine not initialized"))) + (unless (uiop:file-exists-p gen-path) + (return-from self-edit-hot-reload-skill + (values :error (format nil "Skill file not found: ~a" gen-path)))) + + ;; Step 1: Backup registry + (setf *self-edit-skills-backup* (copy-hash-table *skills-registry*)) + + (handler-case + (progn + ;; Step 2: Compile new skill + (let ((compiled (compile-file gen-path))) + (unless compiled + (error "Compilation returned nil"))) + ;; Step 3: Load the compiled skill + (load gen-path) + ;; Step 4: Verify skill is in registry + (let ((skill (gethash (string skill-name) *skills-registry*))) + (if skill + (progn + (harness-log "SELF-EDIT: Hot-reloaded skill ~a from ~a" + skill-name gen-path) + (values :success t)) + (error "Skill not registered after reload")))) + (error (e) + ;; Step 5: Rollback + (when *self-edit-skills-backup* + (clrhash *skills-registry*) + (maphash (lambda (k v) (setf (gethash k *skills-registry*) v)) + *self-edit-skills-backup*)) + (harness-log "SELF-EDIT: Hot-reload FAILED for ~a: ~a" skill-name e) + (values :error (format nil "Hot-reload failed: ~a" e))))) +#+end_src + +** Cognitive Tool: Reload Skill + +#+begin_src lisp :tangle ../library/gen/org-skill-self-edit.lisp +(def-cognitive-tool :reload-skill + "Hot-reloads a skill from its compiled source file without restarting the system." + ((:skill-name :type :string :description "Name of the skill to reload (e.g. :skill-engineering-standards)") + (:gen-path :type :string :description "Absolute path to the compiled .lisp file")) + :body (lambda (args) + (let ((name (getf args :skill-name)) + (path (getf args :gen-path))) + (multiple-value-bind (status message) (self-edit-hot-reload-skill name path) + (list :status status :message message))))) +#+end_src + * Phase E: Verification #+begin_src lisp :tangle ../tests/self-edit-tests.lisp @@ -176,27 +244,27 @@ Provide a fixed version of the code as a lisp form.") (in-suite self-edit-suite) (test balance-parens-balanced - (let ((result (opencortex:self-edit-balance-parens "(+ 1 2)"))) + (let ((result (opencortex::self-edit-balance-parens "(+ 1 2)"))) (is (string= result "(+ 1 2)")) (is (not (null (read-from-string result)))))) (test balance-parens-missing-open - (let ((result (opencortex:self-edit-balance-parens "+ 1 2)"))) + (let ((result (opencortex::self-edit-balance-parens "+ 1 2)"))) (is (string= result "(+ 1 2)")) (is (not (null (read-from-string result)))))) (test balance-parens-missing-close - (let ((result (opencortex:self-edit-balance-parens "(+ 1 2"))) + (let ((result (opencortex::self-edit-balance-parens "(+ 1 2"))) (is (string= result "(+ 1 2)")) (is (not (null (read-from-string result)))))) (test balance-parens-deep - (let ((result (opencortex:self-edit-balance-parens "((lambda (x) (if x (+ 1 2) 3))"))) + (let ((result (opencortex::self-edit-balance-parens "((lambda (x) (if x (+ 1 2) 3))"))) (is (string= result "((lambda (x) (if x (+ 1 2) 3)))")) (is (not (null (read-from-string result)))))) (test balance-parens-empty - (let ((result (opencortex:self-edit-balance-parens ""))) + (let ((result (opencortex::self-edit-balance-parens ""))) (is (string= result "")))) #+end_src diff --git a/tests/boot-sequence-tests.lisp b/tests/boot-sequence-tests.lisp new file mode 100644 index 0000000..c16b08d --- /dev/null +++ b/tests/boot-sequence-tests.lisp @@ -0,0 +1,47 @@ +(defpackage :opencortex-boot-tests + (:use :cl :fiveam :opencortex) + (:export #:boot-suite)) + +(in-package :opencortex-boot-tests) + +(def-suite boot-suite :description "Verification of the Skill Engine loader") + +(in-suite boot-suite) + +(test test-parse-skill-metadata + "Verify extraction of ID and DEPENDS_ON from Org headers." + (let ((tmp-file "/tmp/org-skill-test-metadata.org")) + (with-open-file (out tmp-file :direction :output :if-exists :supersede) + (format out ":PROPERTIES:~%:ID: test-id~%:END:~%#+DEPENDS_ON: dep1 dep2~%")) + (unwind-protect + (multiple-value-bind (id deps) (opencortex::parse-skill-metadata tmp-file) + (is (equal "test-id" id)) + (is (member "dep1" deps :test #'string=)) + (is (member "dep2" deps :test #'string=))) + (uiop:delete-file-if-exists tmp-file)))) + +(test test-topological-sort-basic + "Verify that skills are ordered by dependency." + (let ((tmp-dir "/tmp/opencortex-boot-test/")) + (uiop:ensure-all-directories-exist (list tmp-dir)) + (with-open-file (out (merge-pathnames "org-skill-a.org" tmp-dir) :direction :output :if-exists :supersede) + (format out "#+DEPENDS_ON: skill-b-id~%")) + (with-open-file (out (merge-pathnames "org-skill-b.org" tmp-dir) :direction :output :if-exists :supersede) + (format out ":PROPERTIES:~%:ID: skill-b-id~%:END:~%")) + (unwind-protect + (let ((sorted (opencortex::topological-sort-skills tmp-dir))) + (let ((pos-a (position "org-skill-a" sorted :key #'pathname-name :test #'string-equal)) + (pos-b (position "org-skill-b" sorted :key #'pathname-name :test #'string-equal))) + (is (< pos-b pos-a))) + (uiop:delete-directory-tree (uiop:ensure-directory-pathname tmp-dir) :validate t)))) + +(test test-skill-jailing + "Verify that skills are loaded into their own packages." + (let ((tmp-skill "/tmp/org-skill-jail-test.org")) + (with-open-file (out tmp-skill :direction :output :if-exists :supersede) + (format out ":PROPERTIES:~%:ID: jail-test-id~%:END:~%#+TITLE: Jail Test Skill~%#+begin_src lisp :tangle no~(defun jail-test-fn () t)~#+end_src")) + (unwind-protect + (progn + (opencortex::load-skill-from-org tmp-skill) + (is (not (null (gethash "org-skill-jail-test" opencortex::*skills-registry*))))) + (uiop:delete-file-if-exists tmp-skill))))) diff --git a/tests/emacs-edit-tests.lisp b/tests/emacs-edit-tests.lisp index 2d10f7b..a6866c3 100644 --- a/tests/emacs-edit-tests.lisp +++ b/tests/emacs-edit-tests.lisp @@ -13,7 +13,7 @@ (let ((id1 (emacs-edit-generate-id)) (id2 (emacs-edit-generate-id))) (is (plusp (length id1))) - (is (not (string= id1 id2))))) + (is (not (string= id1 id2))))) ;; Likely unique (test id-format (let ((formatted (emacs-edit-id-format "abc12345"))) @@ -31,4 +31,4 @@ :properties (list :ID "id:todo001" :TITLE "Task") :contents nil))) (emacs-edit-set-todo ast "id:todo001" "DONE") - (is (string= (getf (getf ast :properties) :TODO) "DONE")))) \ No newline at end of file + (is (string= (getf (getf ast :properties) :TODO) "DONE")))) diff --git a/tests/immune-system-tests.lisp b/tests/immune-system-tests.lisp new file mode 100644 index 0000000..8d3c619 --- /dev/null +++ b/tests/immune-system-tests.lisp @@ -0,0 +1,23 @@ +(defpackage :opencortex-immune-system-tests + (:use :cl :fiveam :opencortex) + (:export #:immune-suite)) + +(in-package :opencortex-immune-system-tests) + +(def-suite immune-suite + :description "Verification of the Immune System (Core Error Hooks)") + +(in-suite immune-suite) + +(test loop-error-injection + "Verify that a crash in think/decide triggers a :loop-error stimulus." + (clrhash opencortex::*skills-registry*) + (opencortex:defskill :evil-skill + :priority 100 + :trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :user-input)) + :probabilistic (lambda (ctx) (error "CRITICAL BRAIN FAILURE")) + :deterministic nil) + (opencortex:harness-log "CLEAN LOG") + (opencortex:process-signal '(:type :EVENT :payload (:sensor :user-input))) + (let ((logs (opencortex:context-get-system-logs 20))) + (is (not (null (find-if (lambda (line) (search "CRITICAL BRAIN FAILURE" line)) logs)))))) diff --git a/tests/lisp-utils-tests.lisp b/tests/lisp-utils-tests.lisp index 2254376..f91768e 100644 --- a/tests/lisp-utils-tests.lisp +++ b/tests/lisp-utils-tests.lisp @@ -94,8 +94,3 @@ (let ((result (opencortex::lisp-utils-validate "(delete-file \"x.txt\")" :strict t))) (is (eq (getf result :status) :error)) (is (eq (getf result :failed) :semantic)))) - -(test unified-semantic-fail - (let ((result (opencortex::lisp-utils-validate "(delete-file \"x.txt\")" :strict t))) - (is (eq (getf result :status) :error)) - (is (eq (getf result :failed) :semantic)))) diff --git a/tests/lisp-validator-tests.lisp b/tests/lisp-validator-tests.lisp new file mode 100644 index 0000000..662e6a4 --- /dev/null +++ b/tests/lisp-validator-tests.lisp @@ -0,0 +1,54 @@ +(defpackage :opencortex-lisp-validator-tests + (:use :cl :fiveam :opencortex) + (:export #:lisp-validator-suite)) + +(in-package :opencortex-lisp-validator-tests) + +(def-suite lisp-validator-suite + :description "Tests for the Lisp Validator structural, syntactic, and semantic gates") + +(in-suite lisp-validator-suite) + +(test structural-balanced + (let ((result (opencortex::lisp-validator-check-structural "(+ 1 2)"))) + (is (eq result t)))) + +(test structural-unbalanced-open + (multiple-value-bind (ok reason line col) + (opencortex::lisp-validator-check-structural "(+ 1 2") + (is (null ok)) + (is (search "Unbalanced" reason)))) + +(test structural-unbalanced-close + (multiple-value-bind (ok reason line col) + (opencortex::lisp-validator-check-structural "+ 1 2)") + (is (null ok)) + (is (search "Unbalanced" reason)))) + +(test syntactic-valid + (multiple-value-bind (ok reason line col) + (opencortex::lisp-validator-check-syntactic "(+ 1 2)") + (is (eq ok t)))) + +(test syntactic-invalid-reader + (multiple-value-bind (ok reason line col) + (opencortex::lisp-validator-check-syntactic "(1+ 2 #\")") + (is (not ok)))) + +(test semantic-safe + (multiple-value-bind (ok reason line col) + (opencortex::lisp-validator-check-semantic "(+ 1 2)") + (is (eq ok t)))) + +(test semantic-blocked-eval + (multiple-value-bind (ok reason line col) + (opencortex::lisp-validator-check-semantic "(eval '(+ 1 2))") + (is (not ok)))) + +(test unified-success + (let ((result (opencortex::lisp-validator-validate "(+ 1 2)" :strict t))) + (is (eq (getf result :status) :success)))) + +(test unified-failure + (let ((result (opencortex::lisp-validator-validate "(+ 1 2" :strict nil))) + (is (eq (getf result :status) :error)))) diff --git a/tests/memory-tests.lisp b/tests/memory-tests.lisp new file mode 100644 index 0000000..13cbb31 --- /dev/null +++ b/tests/memory-tests.lisp @@ -0,0 +1,115 @@ +(defpackage :opencortex-memory-tests + (:use :cl :fiveam :opencortex) + (:export #:memory-suite)) + +(in-package :opencortex-memory-tests) + +(def-suite memory-suite + :description "Tests for the Merkle-Tree Memory.") + +(in-suite memory-suite) + +(test merkle-hash-consistency + (let* ((ast1 '(:type :HEADLINE :properties (:ID "test-1" :TITLE "Node 1") :contents nil)) + (ast2 '(:type :HEADLINE :properties (:ID "test-1" :TITLE "Node 1") :contents nil))) + (clrhash *memory*) + (let ((id1 (ingest-ast ast1))) + (let ((hash1 (org-object-hash (lookup-object id1)))) + (clrhash *memory*) + (let ((id2 (ingest-ast ast2))) + (let ((hash2 (org-object-hash (lookup-object id2)))) + (is (equal hash1 hash2)))))))) + +(test merkle-hash-cascading + (let* ((ast-leaf '(:type :HEADLINE :properties (:ID "leaf" :TITLE "Leaf") :contents nil)) + (ast-root-full '(:type :HEADLINE :properties (:ID "root" :TITLE "Root") + :contents ((:type :HEADLINE :properties (:ID "leaf" :TITLE "Leaf") :contents nil)))) + (id-root (progn (clrhash *memory*) (ingest-ast ast-root-full))) + (initial-root-hash (org-object-hash (lookup-object id-root)))) + + ;; Now ingest a modified version (title change) + (let* ((ast-root-modified '(:type :HEADLINE :properties (:ID "root" :TITLE "Root") + :contents ((:type :HEADLINE :properties (:ID "leaf" :TITLE "Leaf Modified") :contents nil)))) + (id-root-mod (progn (clrhash *memory*) (ingest-ast ast-root-modified))) + (modified-root-hash (org-object-hash (lookup-object id-root-mod)))) + (is (not (equal initial-root-hash modified-root-hash)))))) + +(test history-store-immutability + "Verify that *history-store* retains old versions even after *memory* updates." + (clrhash *memory*) + (clrhash *history-store*) + (let* ((ast-v1 '(:type :HEADLINE :properties (:ID "test-node" :TITLE "Version 1") :contents nil)) + (id-v1 (ingest-ast ast-v1)) + (obj-v1 (lookup-object id-v1)) + (hash-v1 (org-object-hash obj-v1))) + + (let* ((ast-v2 '(:type :HEADLINE :properties (:ID "test-node" :TITLE "Version 2") :contents nil)) + (id-v2 (ingest-ast ast-v2)) + (obj-v2 (lookup-object id-v2)) + (hash-v2 (org-object-hash obj-v2))) + + ;; The active pointer should be v2 + (is (equal (org-object-hash (lookup-object "test-node")) hash-v2)) + + ;; Both v1 and v2 should exist in the immutable history store + (is (not (null (gethash hash-v1 *history-store*)))) + (is (not (null (gethash hash-v2 *history-store*)))) + + ;; Modifying v2 should not affect v1 in the history store + (is (equal (org-object-content (gethash hash-v1 *history-store*)) "Version 1 +")) + (is (equal (org-object-content (gethash hash-v2 *history-store*)) "Version 2 +"))))) + +(test cow-snapshot-and-rollback + "Verify that lightweight snapshots can accurately restore previous pointer states." + (clrhash *memory*) + (clrhash *history-store*) + (setf *object-store-snapshots* nil) + + (let* ((ast-v1 '(:type :HEADLINE :properties (:ID "cow-node" :TITLE "State A") :contents nil)) + (id-v1 (ingest-ast ast-v1)) + (hash-v1 (org-object-hash (lookup-object id-v1)))) + + ;; Take a snapshot at State A + (snapshot-memory) + + (let* ((ast-v2 '(:type :HEADLINE :properties (:ID "cow-node" :TITLE "State B") :contents nil)) + (id-v2 (ingest-ast ast-v2)) + (hash-v2 (org-object-hash (lookup-object id-v2)))) + + ;; Verify we are currently in State B + (is (equal (org-object-hash (lookup-object "cow-node")) hash-v2)) + + ;; Rollback to State A (index 0 because we only took 1 snapshot) + (rollback-memory 0) + + ;; Verify we are back in State A + (is (equal (org-object-hash (lookup-object "cow-node")) hash-v1)) + +;; Verify State B is still safely in the history store (no data loss) + (is (not (null (gethash hash-v2 *history-store*))))))) + +(test merkle-hash-consistency + "Verify that identical ASTs produce identical Merkle hashes." + (let* ((ast1 '(:type :HEADLINE :properties (:ID "test-1" :TITLE "Node 1") :contents nil))) + (clrhash *memory*) + (let ((id1 (ingest-ast ast1))) + (let ((hash1 (org-object-hash (lookup-object id1)))) + (clrhash *memory*) + (let ((id2 (ingest-ast ast1))) + (let ((hash2 (org-object-hash (lookup-object id2)))) + (is (equal hash1 hash2)))))))) + +(test merkle-hash-cascading + "Verify that child changes propagate to parent hashes." + (let* ((ast-root '(:type :HEADLINE :properties (:ID "root" :TITLE "Root") + :contents ((:type :HEADLINE :properties (:ID "leaf" :TITLE "Leaf") :contents nil)))) + (id-root (progn (clrhash *memory*) (ingest-ast ast-root))) + (root-hash (org-object-hash (lookup-object id-root)))) + ;; Now ingest a modified child - parent hash should change + (let* ((ast-mod '(:type :HEADLINE :properties (:ID "root" :TITLE "Root") + :contents ((:type :HEADLINE :properties (:ID "leaf" :TITLE "Changed") :contents nil)))) + (id-mod (progn (clrhash *memory*) (ingest-ast ast-mod))) + (mod-hash (org-object-hash (lookup-object id-mod)))) + (is (not (equal root-hash mod-hash)))))) diff --git a/tests/pipeline-act-tests.lisp b/tests/pipeline-act-tests.lisp new file mode 100644 index 0000000..d0eb5ea --- /dev/null +++ b/tests/pipeline-act-tests.lisp @@ -0,0 +1,33 @@ +(defpackage :opencortex-pipeline-act-tests + (:use :cl :fiveam :opencortex) + (:export #:pipeline-act-suite)) + +(in-package :opencortex-pipeline-act-tests) + +(def-suite pipeline-act-suite + :description "Test suite for Act pipeline") + +(in-suite pipeline-act-suite) + +(test test-act-gate-symbolic-guard-bypass + "Verify that act-gate proceeds normally when no skill intercepts." + (clrhash opencortex::*skills-registry*) + (let* ((signal (list :type :EVENT :status nil :depth 0 :approved-action '(:target :cli :payload (:text "Hello")))) + (result (opencortex:act-gate signal))) + (is (eq :acted (getf signal :status))) + (is (null result)))) + +(test test-act-gate-symbolic-guard-interception + "Verify that act-gate intercepts actions when a skill returns a LOG/EVENT." + (clrhash opencortex::*skills-registry*) + (opencortex::defskill :mock-bouncer + :priority 200 + :trigger (lambda (ctx) t) + :deterministic (lambda (action ctx) + (list :type :LOG :payload '(:text "BLOCKED BY SYMBOLIC GUARD")))) + (let* ((signal (list :type :EVENT :status nil :depth 0 :approved-action '(:target :shell :payload (:cmd "ls")))) + (result (opencortex:act-gate signal))) + (is (eq :acted (getf signal :status))) + (is (not (null result))) + (is (eq :LOG (getf result :type))) + (is (search "BLOCKED BY SYMBOLIC GUARD" (getf (getf result :payload) :text))))) diff --git a/tests/pipeline-perceive-tests.lisp b/tests/pipeline-perceive-tests.lisp new file mode 100644 index 0000000..4eeabf2 --- /dev/null +++ b/tests/pipeline-perceive-tests.lisp @@ -0,0 +1,23 @@ +(defpackage :opencortex-pipeline-perceive-tests + (:use :cl :fiveam :opencortex) + (:export #:pipeline-perceive-suite)) + +(in-package :opencortex-pipeline-perceive-tests) + +(def-suite pipeline-perceive-suite + :description "Test suite for Perceive pipeline") + +(in-suite pipeline-perceive-suite) + +(test test-perceive-gate + "Perceive gate should update the object store and normalize signal." + (clrhash opencortex::*memory*) + (let* ((signal (list :type :EVENT :payload (list :sensor :buffer-update :ast (list :type :HEADLINE :properties (list :ID "test-node" :TITLE "Test") :contents nil)))) + (result (perceive-gate signal))) + (is (eq :perceived (getf result :status))) + (is (not (null (gethash "test-node" opencortex::*memory*)))))) + +(test test-depth-limiting + "Verify that the pipeline terminates runaway feedback loops." + (let ((runaway-signal (list :type :EVENT :depth 11 :payload (list :sensor :heartbeat)))) + (is (null (process-signal runaway-signal))))) diff --git a/tests/pipeline-reason-tests.lisp b/tests/pipeline-reason-tests.lisp new file mode 100644 index 0000000..0820590 --- /dev/null +++ b/tests/pipeline-reason-tests.lisp @@ -0,0 +1,26 @@ +(defpackage :opencortex-pipeline-reason-tests + (:use :cl :fiveam :opencortex) + (:export #:pipeline-reason-suite)) + +(in-package :opencortex-pipeline-reason-tests) + +(def-suite pipeline-reason-suite + :description "Test suite for Reason pipeline") + +(in-suite pipeline-reason-suite) + +(test test-decide-gate-safety + "Decide gate should block unsafe LLM proposals." + ;; Setup: clear skills and register mock + (clrhash opencortex::*skills-registry*) + (opencortex::defskill :mock-safety + :priority 50 + :trigger (lambda (ctx) t) + :probabilistic (lambda (ctx) "Mock probabilistic") + :deterministic (lambda (action ctx) + (list :type :LOG :payload (list :text "Action rejected by skill heuristics")))) + (let* ((candidate (list :type :REQUEST :payload (list :action :eval :code "(shell-command \"rm -rf /\")"))) + (signal (list :type :EVENT :candidate candidate)) + (result (deterministic-verify candidate signal))) + (is (eq :LOG (getf result :type))) + (is (search "Action rejected by skill heuristics" (getf (getf result :payload) :text))))) diff --git a/tests/self-edit-tests.lisp b/tests/self-edit-tests.lisp index 989f792..ae5a334 100644 --- a/tests/self-edit-tests.lisp +++ b/tests/self-edit-tests.lisp @@ -10,25 +10,25 @@ (in-suite self-edit-suite) (test balance-parens-balanced - (let ((result (opencortex:self-edit-balance-parens "(+ 1 2)"))) + (let ((result (opencortex::self-edit-balance-parens "(+ 1 2)"))) (is (string= result "(+ 1 2)")) (is (not (null (read-from-string result)))))) (test balance-parens-missing-open - (let ((result (opencortex:self-edit-balance-parens "+ 1 2)"))) + (let ((result (opencortex::self-edit-balance-parens "+ 1 2)"))) (is (string= result "(+ 1 2)")) (is (not (null (read-from-string result)))))) (test balance-parens-missing-close - (let ((result (opencortex:self-edit-balance-parens "(+ 1 2"))) + (let ((result (opencortex::self-edit-balance-parens "(+ 1 2"))) (is (string= result "(+ 1 2)")) (is (not (null (read-from-string result)))))) (test balance-parens-deep - (let ((result (opencortex:self-edit-balance-parens "((lambda (x) (if x (+ 1 2) 3))"))) + (let ((result (opencortex::self-edit-balance-parens "((lambda (x) (if x (+ 1 2) 3))"))) (is (string= result "((lambda (x) (if x (+ 1 2) 3)))")) (is (not (null (read-from-string result)))))) (test balance-parens-empty - (let ((result (opencortex:self-edit-balance-parens ""))) + (let ((result (opencortex::self-edit-balance-parens ""))) (is (string= result "")))) diff --git a/tests/tool-permissions-tests.lisp b/tests/tool-permissions-tests.lisp new file mode 100644 index 0000000..e1635e2 --- /dev/null +++ b/tests/tool-permissions-tests.lisp @@ -0,0 +1,34 @@ +(defpackage :opencortex-tool-permissions-tests + (:use :cl :fiveam :opencortex) + (:export #:tool-permissions-suite)) + +(in-package :opencortex-tool-permissions-tests) + +(def-suite tool-permissions-suite + :description "Tests for Tool Permissions skill") + +(in-suite tool-permissions-suite) + +(test default-permission-is-allow + "Verify default permission is :allow." + (is (eq (get-tool-permission "unknown-tool") :allow))) + +(test set-and-get-permission + "Verify setting and getting permissions." + (set-tool-permission "test-tool-abc" :deny) + (is (eq (get-tool-permission "test-tool-abc") :deny))) + +(test permission-gate-allow + "Verify :allow tier passes through." + (set-tool-permission "gate-allow-tool" :allow) + (is (eq (check-tool-permission-gate "gate-allow-tool" nil) :allow))) + +(test permission-gate-deny + "Verify :deny tier blocks." + (set-tool-permission "gate-deny-tool" :deny) + (is (eq (check-tool-permission-gate "gate-deny-tool" nil) :deny))) + +(test permission-gate-ask + "Verify :ask tier returns ask list." + (set-tool-permission "gate-ask-tool" :ask) + (is (listp (check-tool-permission-gate "gate-ask-tool" nil))))