From edb8bed2d96e26d1a7dea2686e515bbb84648cfe Mon Sep 17 00:00:00 2001 From: Amr Gharbeia Date: Mon, 27 Apr 2026 12:55:00 -0400 Subject: [PATCH] build: remove redundant .lisp artifacts from source tree --- harness/act.lisp | 313 -------------- harness/communication-tests.lisp | 41 -- harness/communication-validator.lisp | 44 -- harness/communication.lisp | 78 ---- harness/context.lisp | 119 ------ harness/loop.lisp | 193 --------- harness/memory.lisp | 119 ------ harness/package.lisp | 174 -------- harness/perceive.lisp | 130 ------ harness/reason.lisp | 361 ---------------- harness/skills.lisp | 435 -------------------- harness/tui-client.lisp | 235 ----------- skills/org-skill-bouncer.lisp | 258 ------------ skills/org-skill-cli-gateway.lisp | 81 ---- skills/org-skill-credentials-vault.lisp | 82 ---- skills/org-skill-emacs-edit.lisp | 281 ------------- skills/org-skill-engineering-standards.lisp | 92 ----- skills/org-skill-gardener.lisp | 68 --- skills/org-skill-homoiconic-memory.lisp | 28 -- skills/org-skill-lisp-utils.lisp | 289 ------------- skills/org-skill-lisp-validator.lisp | 125 ------ skills/org-skill-literate-programming.lisp | 155 ------- skills/org-skill-llama-backend.lisp | 33 -- skills/org-skill-llm-gateway.lisp | 128 ------ skills/org-skill-peripheral-vision.lisp | 76 ---- skills/org-skill-policy.lisp | 404 ------------------ skills/org-skill-protocol-validator.lisp | 44 -- skills/org-skill-scribe.lisp | 108 ----- skills/org-skill-self-edit.lisp | 177 -------- skills/org-skill-self-fix.lisp | 65 --- skills/org-skill-shell-actuator.lisp | 56 --- skills/org-skill-tool-permissions.lisp | 87 ---- 32 files changed, 4879 deletions(-) delete mode 100644 harness/act.lisp delete mode 100644 harness/communication-tests.lisp delete mode 100644 harness/communication-validator.lisp delete mode 100644 harness/communication.lisp delete mode 100644 harness/context.lisp delete mode 100644 harness/loop.lisp delete mode 100644 harness/memory.lisp delete mode 100644 harness/package.lisp delete mode 100644 harness/perceive.lisp delete mode 100644 harness/reason.lisp delete mode 100644 harness/skills.lisp delete mode 100644 harness/tui-client.lisp delete mode 100644 skills/org-skill-bouncer.lisp delete mode 100644 skills/org-skill-cli-gateway.lisp delete mode 100644 skills/org-skill-credentials-vault.lisp delete mode 100644 skills/org-skill-emacs-edit.lisp delete mode 100644 skills/org-skill-engineering-standards.lisp delete mode 100644 skills/org-skill-gardener.lisp delete mode 100644 skills/org-skill-homoiconic-memory.lisp delete mode 100644 skills/org-skill-lisp-utils.lisp delete mode 100644 skills/org-skill-lisp-validator.lisp delete mode 100644 skills/org-skill-literate-programming.lisp delete mode 100644 skills/org-skill-llama-backend.lisp delete mode 100644 skills/org-skill-llm-gateway.lisp delete mode 100644 skills/org-skill-peripheral-vision.lisp delete mode 100644 skills/org-skill-policy.lisp delete mode 100644 skills/org-skill-protocol-validator.lisp delete mode 100644 skills/org-skill-scribe.lisp delete mode 100644 skills/org-skill-self-edit.lisp delete mode 100644 skills/org-skill-self-fix.lisp delete mode 100644 skills/org-skill-shell-actuator.lisp delete mode 100644 skills/org-skill-tool-permissions.lisp diff --git a/harness/act.lisp b/harness/act.lisp deleted file mode 100644 index aede5a8..0000000 --- a/harness/act.lisp +++ /dev/null @@ -1,313 +0,0 @@ -(in-package :opencortex) - -(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 () - "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"))) - - ;; Parse silent actuators list - (when silent - (setf *silent-actuators* - (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))) - (when (and stream (open-stream-p stream)) - (format stream "~a" (frame-message action)) - (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)) - - (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) - "Execute internal harness commands. - - 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) - "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)) - (depth (getf context :depth 0)) - (meta (getf context :meta)) - (source (getf meta :source)) - (tool (gethash (string-downcase (string tool-name)) *cognitive-tools*))) - - (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))) - - ;; 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))))) - - ;; 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 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 signal)) - - ;; 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))) - - ;; 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))))) - - ;; Step 2: Actuation based on signal type - (case type - ;; 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))) - - ;; 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/harness/communication-tests.lisp b/harness/communication-tests.lisp deleted file mode 100644 index 15dc7ef..0000000 --- a/harness/communication-tests.lisp +++ /dev/null @@ -1,41 +0,0 @@ -(defpackage :opencortex-communication-tests - (:use :cl :fiveam :opencortex) - (:export #:communication-protocol-suite)) - -(in-package :opencortex-communication-tests) - -(def-suite communication-protocol-suite - :description "Test suite for opencortex Communication Protocol") - -(in-suite communication-protocol-suite) - -(test test-framing - "Verify that messages are correctly prefixed with a 6-character hex length." - (let* ((msg '(:type :EVENT :payload (:action :handshake))) - (framed (frame-message msg)) - (len-str (subseq framed 0 6)) - (payload (subseq framed 6))) - (is (string= "00002C" (string-upcase len-str))) - (is (equalp msg (read-from-string payload))))) - -(test test-parse-message - "Verify that incoming framed strings are parsed into Lisp plists." - (let ((framed "00002c(:type :EVENT :payload (:action :handshake))")) - (is (equal '(:type :EVENT :payload (:action :handshake)) - (read-from-string (subseq framed 6)))))) - -(test test-hello-handshake - "Verify the structure of the HELLO handshake message." - (let ((hello (make-hello-message "0.1.0"))) - (is (eq :EVENT (getf hello :type))) - (is (eq :handshake (getf (getf hello :payload) :action))) - (is (string= "0.1.0" (getf (getf hello :payload) :version))))) - -(test test-find-missing-id - "Verify that the daemon can find a headline missing an ID." - (let* ((ast '(:type :org-data :contents - ((:type :HEADLINE :properties (:TITLE "No ID Here") :contents nil) - (:type :HEADLINE :properties (:ID "exists" :TITLE "Has ID") :contents nil)))) - (found (find-headline-missing-id ast))) - (is (not (null found))) - (is (string= "No ID Here" (getf (getf found :properties) :TITLE))))) diff --git a/harness/communication-validator.lisp b/harness/communication-validator.lisp deleted file mode 100644 index 5b577be..0000000 --- a/harness/communication-validator.lisp +++ /dev/null @@ -1,44 +0,0 @@ -(in-package :opencortex) - -(defun validate-communication-protocol-schema (msg) - "Strict structural validation for incoming communication protocol messages." - (unless (listp msg) - (error "Communication Protocol Schema Error: Message must be a property list (got ~s)" (type-of msg))) - - (let ((type (let ((raw (proto-get msg :type))) (if (keywordp raw) (intern (string-upcase (string raw)) :keyword) raw)))) - (unless (member type '(:REQUEST :EVENT :RESPONSE :LOG :STATUS)) - (progn (harness-log "REJECTED MSG: ~s" msg) (error "Communication Protocol Schema Error: Invalid message type '~a'" type))) - - (case type - (:REQUEST - ;; Allow missing :target if :source is present in :meta, since reason-gate - ;; will infer :target from :source downstream. This preserves "equality of - ;; clients" — gateways need not duplicate routing logic. - (let ((target (proto-get msg :target)) - (source (proto-get (proto-get msg :meta) :source))) - (unless (or target source) - (error "Communication Protocol Schema Error: REQUEST missing mandatory :target and no :source in :meta to infer it")) - (unless (proto-get msg :payload) - (error "Communication Protocol Schema Error: REQUEST missing mandatory :payload")))) - - (:EVENT - (let ((payload (proto-get msg :payload))) - (unless (and payload (listp payload)) - (error "Communication Protocol Schema Error: EVENT missing or invalid :payload")) - (unless (or (proto-get payload :action) (proto-get payload :sensor)) - (error "Communication Protocol Schema Error: EVENT payload must contain :action or :sensor")))) - - (:RESPONSE - (unless (proto-get msg :payload) - (error "Communication Protocol Schema Error: RESPONSE missing mandatory :payload")))) - - t)) - -(defskill :skill-communication-protocol-validator - :priority 95 - :trigger (lambda (ctx) (member (getf (getf ctx :payload) :sensor) '(:protocol-received))) - :probabilistic nil - :deterministic (lambda (action ctx) - (declare (ignore ctx)) - (validate-communication-protocol-schema action) - action)) diff --git a/harness/communication.lisp b/harness/communication.lisp deleted file mode 100644 index c307a3f..0000000 --- a/harness/communication.lisp +++ /dev/null @@ -1,78 +0,0 @@ -(in-package :opencortex) - -(defun proto-get (plist key) - "Robustly retrieves a value from a plist, checking both uppercase and lowercase keyword versions." - (let* ((s (string key)) - (up (intern (string-upcase s) :keyword)) - (dn (intern (string-downcase s) :keyword))) - (or (getf plist up) (getf plist dn)))) - -(in-package :opencortex) - -(defvar *actuator-registry* (make-hash-table :test 'equalp) - "Global registry mapping target keywords to their physical actuator functions.") - -(defun register-actuator (name fn) - "Registers an actuator function. Actuators receive: (ACTION CONTEXT)." - (let ((key (if (keywordp name) name (intern (string-upcase (string name)) :keyword)))) - (setf (gethash key *actuator-registry*) fn))) - -;; Removed duplicate frame-message - kept the sanitized version below - -(defun read-framed-message (stream) - "Reads a hex-length prefixed S-expression from the stream securely. Skips leading whitespace." - (let ((length-buffer (make-string 6))) - (handler-case - (progn - ;; 1. Skip leading whitespace (newlines, spaces, etc.) - (loop for char = (peek-char nil stream nil :eof) - while (and (not (eq char :eof)) (member char '(#\Space #\Newline #\Tab #\Return))) - do (read-char stream)) - - ;; 2. Read the 6-char hex length - (let ((count (read-sequence length-buffer stream))) - (cond ((< count 6) :eof) - (t (let ((len (ignore-errors (parse-integer length-buffer :radix 16)))) - (if (not len) - (progn - (harness-log "PROTOCOL ERROR: Invalid header ~s. Attempting resync..." length-buffer) - :error) - (let ((msg-buffer (make-string len))) - (read-sequence msg-buffer stream) - (let ((*read-eval* nil) - (*print-pretty* nil)) - (handler-case - (let ((msg (read-from-string msg-buffer))) - (validate-communication-protocol-schema msg) - msg) - (error (c) - (harness-log "PROTOCOL PARSE ERROR: ~a in ~s" c msg-buffer) - :error)))))))))) - (error (c) - (harness-log "PROTOCOL READ ERROR: ~a" c) - :error)))) - -(defun make-hello-message (version) - "Constructs the standard HELLO handshake message." - (list :TYPE :EVENT - :PAYLOAD (list :ACTION :handshake - :VERSION version - :CAPABILITIES '(:AUTH :SWANK :ORG-AST)))) - -(defun sanitize-protocol-message (msg) - "Recursively strips non-serializable objects from a protocol plist." - (if (and msg (listp msg)) - (let ((clean nil)) - (loop for (k v) on msg by #'cddr - do (unless (member k '(:reply-stream :socket :stream)) - (push k clean) - (push (if (listp v) (sanitize-protocol-message v) v) clean))) - (nreverse clean)) - msg)) - -(defun frame-message (msg) - "Serializes a message plist and prefixes it with a 6-character hex length." - (let* ((sanitized (sanitize-protocol-message msg)) - (payload (let ((*print-pretty* nil) (*read-eval* nil)) (format nil "~s" sanitized))) - (len (length payload))) - (format nil "~6,'0x~a" len payload))) diff --git a/harness/context.lisp b/harness/context.lisp deleted file mode 100644 index 5fc3eda..0000000 --- a/harness/context.lisp +++ /dev/null @@ -1,119 +0,0 @@ -(in-package :opencortex) - -(defun context-query-store (&key tag todo-state type) - "Filters the Memory based on tags, todo states, or types." - (let ((results nil)) - (maphash (lambda (id obj) - (declare (ignore id)) - (let* ((attrs (org-object-attributes obj)) (state (getf attrs :TODO-STATE)) (match t)) - (when (and type (not (eq (org-object-type obj) type))) (setf match nil)) - (when tag (unless (search tag (format nil "~a" (getf attrs :TAGS)) :test #'string-equal) (setf match nil))) - (when (and todo-state (not (equal state todo-state))) (setf match nil)) - (when match (push obj results)))) - *memory*) - results)) - -(defun context-get-active-projects () - "Returns headlines tagged as 'project' that are not yet marked DONE." - (remove-if (lambda (obj) (equal (getf (org-object-attributes obj) :TODO-STATE) "DONE")) - (context-query-store :tag "project" :type :HEADLINE))) - -(defun context-get-recent-completed-tasks () - "Retrieves recently finished tasks from the store." - (context-query-store :todo-state "DONE" :type :HEADLINE)) - -(defun context-list-all-skills () - "Provides a sorted overview of currently loaded system capabilities." - (let ((results nil)) - (maphash (lambda (name skill) - (declare (ignore name)) - (push (list :name (skill-name skill) :priority (skill-priority skill) :dependencies (skill-dependencies skill)) results)) - *skills-registry*) - (sort results #'> :key (lambda (x) (getf x :priority))))) - -(defun context-get-skill-source (skill-name) - "Reads the raw literate source of a specific skill for inspection." - (let* ((filename (format nil "~a.org" skill-name)) - (skills-dir-str (or (uiop:getenv "SKILLS_DIR") (namestring (merge-pathnames "notes/" (user-homedir-pathname))))) - (skills-dir (uiop:ensure-directory-pathname (context-resolve-path skills-dir-str))) - (full-path (merge-pathnames filename skills-dir))) - (if (uiop:file-exists-p full-path) (uiop:read-file-string full-path) nil))) - -(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))) - (bt:with-lock-held (*logs-lock*) - (let ((count (min log-limit (length *system-logs*)))) - (subseq *system-logs* 0 count))))) - -(defun context-render-to-org (obj &key (depth 1) (foveal-id nil) semantic-threshold (foveal-vector nil)) - "Recursively renders an org-object and its children to an Org string using a Foveal-Peripheral Hybrid model." - (let* ((id (org-object-id obj)) - (is-foveal (equal id foveal-id)) - (title (or (getf (org-object-attributes obj) :TITLE) "Untitled")) - (content (org-object-content obj)) - (children (org-object-children obj)) - (stars (make-string depth :initial-element #\*)) - (obj-vector (org-object-vector obj)) - (threshold (or semantic-threshold (ignore-errors (read-from-string (uiop:getenv "CONTEXT_SEMANTIC_THRESHOLD"))) 0.75)) - (similarity (if (and foveal-vector obj-vector (not is-foveal)) - (cosine-similarity foveal-vector obj-vector) - 0.0)) - (is-semantically-relevant (>= similarity threshold)) - ;; We always render depth 1 and 2 (Projects and main tasks). - ;; We always render the foveal node and its immediate children. - ;; We render deeper nodes ONLY if they are semantically relevant. - (should-render (or (<= depth 2) is-foveal is-semantically-relevant)) - (output "")) - - (when should-render - (setf output (format nil "~a ~a~%:PROPERTIES:~%:ID: ~a~%" stars title id)) - (when is-semantically-relevant - (setf output (concatenate 'string output (format nil ":SEMANTIC_SCORE: ~,2f~%" similarity)))) - (setf output (concatenate 'string output (format nil ":END:~%"))) - - ;; Only include full body content if this is the Foveal focus or highly relevant - (when (and content (or is-foveal is-semantically-relevant)) - (setf output (concatenate 'string output content (string #\Newline)))) - - ;; Recursively render children - (dolist (child-id children) - (let ((child-obj (lookup-object child-id))) - (when child-obj - ;; If the current node is Foveal, its children should be rendered (depth effectively resets) - (let ((next-foveal (if is-foveal child-id foveal-id))) - (setf output (concatenate 'string output - (context-render-to-org child-obj - :depth (1+ depth) - :foveal-id next-foveal - :semantic-threshold threshold - :foveal-vector foveal-vector)))))))) - output)) - -(defun context-resolve-path (path-string) - "Expands environment variables and strips literal quotes from a path string." - (let ((path (if (stringp path-string) - (string-trim '(#\" #\' #\Space) path-string) - path-string))) - (if (and (stringp path) (search "$" path)) - (let ((result path)) - (ppcre:do-register-groups (var-name) ("\\$([A-Za-z0-9_]+)" path) - (let ((var-val (uiop:getenv var-name))) - (when var-val - (setf result (ppcre:regex-replace (format nil "\\$~a" var-name) result var-val))))) - result) - path))) - -(defun context-assemble-global-awareness (&optional signal) - "Produces a high-level skeletal outline of the current Memory for the LLM." - (let* ((foveal-id (or (getf signal :foveal-focus) - (ignore-errors (getf (getf signal :payload) :target-id)))) - (projects (context-get-active-projects)) - (output "GLOBAL MEMEX AWARENESS (Peripheral Vision): -")) - (if projects - (dolist (project projects) - (setf output (concatenate 'string output - (context-render-to-org project :foveal-id foveal-id)))) - (setf output (concatenate 'string output "No active projects found.~%"))) - output)) diff --git a/harness/loop.lisp b/harness/loop.lisp deleted file mode 100644 index b57190f..0000000 --- a/harness/loop.lisp +++ /dev/null @@ -1,193 +0,0 @@ -(in-package :opencortex) - -(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. - - 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 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))) - (if feedback - ;; Action generated a feedback signal - continue processing - (progn - ;; 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 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) - ;; 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 - "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 - "Tracks heartbeats since last save, used to calculate auto-save timing.") - -(defun start-heartbeat () - "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* - (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 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 - "When T, save memory to disk on graceful shutdown. - Disable for testing or when memory persistence is handled externally.") - -(defun main () - "Entry point for OpenCortex. Initializes the system and enters idle loop. - - 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) - - ;; 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)) - (harness-log "SHUTDOWN: SIGINT received. Saving memory...") - (when *shutdown-save-enabled* - (save-memory-to-disk)) - (uiop:quit 0))) - - ;; 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)) - (return)) - - ;; Sleep in configured intervals (default: 1 hour) - (sleep sleep-interval)))) diff --git a/harness/memory.lisp b/harness/memory.lisp deleted file mode 100644 index f2fadf3..0000000 --- a/harness/memory.lisp +++ /dev/null @@ -1,119 +0,0 @@ -(in-package :opencortex) - -(defvar *memory* (make-hash-table :test 'equal)) - -(defvar *history-store* (make-hash-table :test 'equal) - "Immutable Merkle-Tree versioning store mapping hashes to objects.") - -(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))) - (sorted-alist (sort alist #'string< :key (lambda (x) (format nil "~a" (car x))))) - (attr-string (format nil "~s" sorted-alist)) - (children-string (format nil "~{~a~}" child-hashes)) - (data-string (format nil "ID:~a|TYPE:~s|ATTRS:~a|CONTENT:~a|CHILDREN:~a" - id type attr-string (or content "") children-string)) - (digester (ironclad:make-digest :sha256))) - (ironclad:update-digest digester (ironclad:ascii-string-to-byte-array data-string)) - (ironclad:byte-array-to-hex-string (ironclad:produce-digest digester)))) - -(defun ingest-ast (ast &optional parent-id) - "Parses an Org AST into the recursive Lisp Memory with Merkle hashing." - (let* ((type (getf ast :type)) - (props (getf ast :properties)) - (id (or (getf props :ID) (format nil "temp-~a" (get-universal-time)))) - (contents (getf ast :contents)) - (raw-content (when (eq type :HEADLINE) - (format nil "~a~%~a" (getf props :TITLE) (or (cl:getf ast :raw-content) "")))) - (should-embed (and raw-content (equal (getf props :EMBED) "t"))) - (child-ids nil) - (child-hashes nil)) - (dolist (child contents) - (when (listp child) - (let ((child-id (ingest-ast child id))) - (push child-id child-ids) - (let ((child-id-val child-id)) - (let ((child-obj (lookup-object child-id-val))) - (when child-obj (push (org-object-hash child-obj) child-hashes))))))) - (setf child-ids (nreverse child-ids)) - (setf child-hashes (nreverse child-hashes)) - (let* ((hash (compute-merkle-hash id type props raw-content child-hashes)) - (existing-obj (gethash hash *history-store*)) - (obj (or existing-obj - (make-org-object - :id id :type type :attributes props :content raw-content - :vector (when should-embed (get-embedding raw-content)) - :parent-id parent-id :children child-ids - :version (get-universal-time) :last-sync (get-universal-time) - :hash hash)))) - (unless existing-obj - (setf (gethash hash *history-store*) obj)) - (setf (gethash id *memory*) obj) - id))) - -(defvar *object-store-snapshots* nil) - -(defun copy-hash-table (hash-table) - "Creates a shallow copy of a hash table." - (let ((new-table (make-hash-table :test (hash-table-test hash-table) - :size (hash-table-size hash-table)))) - (maphash (lambda (k v) (setf (gethash k new-table) v)) hash-table) - new-table)) - -(defun snapshot-memory () - "Creates a lightweight, Copy-on-Write snapshot using Merkle-Tree pointers." - (let ((snapshot (copy-hash-table *memory*))) - (push (list :timestamp (get-universal-time) :data snapshot) *object-store-snapshots*) - (when (> (length *object-store-snapshots*) 20) - (setf *object-store-snapshots* (subseq *object-store-snapshots* 0 20))) - (harness-log "MEMORY - CoW Memory snapshot created."))) - -(defun rollback-memory (&optional (index 0)) - "Restores the Memory to a previously captured snapshot using immutable history pointers." - (let ((snapshot (nth index *object-store-snapshots*))) - (if snapshot - (progn (setf *memory* (copy-hash-table (getf snapshot :data))) - (harness-log "MEMORY - Memory rolled back to snapshot ~a" index)) - (harness-log "MEMORY ERROR - Snapshot ~a not found." index)))) - -(defun org-id-new () - "Generates a new UUID string for Org-mode identification." - (string-downcase (format nil "~a" (uuid:make-v4-uuid)))) - -(defun lookup-object (id) - "Retrieves an object from the store by its unique ID." - (gethash id *memory*)) - -(defun list-objects-by-type (type) - "Returns a list of all objects matching a specific Org element type." - (let ((results nil)) - (maphash (lambda (id obj) (declare (ignore id)) (when (eq (org-object-type obj) type) (push obj results))) *memory*) - results)) -(defun list-objects-with-attribute (attr-name value) - "Returns a list of all objects where ATTR-NAME matches VALUE." - (let ((results nil)) - (maphash (lambda (id obj) - (declare (ignore id)) - (let ((attrs (org-object-attributes obj))) - (when (equal (getf attrs attr-name) value) - (push obj results)))) - *memory*) - results)) - -(defun find-headline-missing-id (ast) - "Traverses an AST to find headlines that lack an :ID: property." - (when (listp ast) - (if (and (eq (getf ast :type) :HEADLINE) (not (getf (getf ast :properties) :ID))) - ast - (cl:some #'find-headline-missing-id (getf ast :contents))))) - -(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))) diff --git a/harness/package.lisp b/harness/package.lisp deleted file mode 100644 index dab96ce..0000000 --- a/harness/package.lisp +++ /dev/null @@ -1,174 +0,0 @@ -(defpackage :opencortex - (:use :cl) - (:export - ;; --- communication protocol --- - #:frame-message - #:read-framed-message - #:PROTO-GET - #:LIST-OBJECTS-WITH-ATTRIBUTE - #:COSINE-SIMILARITY - #:VAULT-MASK-STRING - #:*VAULT-MEMORY* - #:parse-message - #:make-hello-message - #:validate-communication-protocol-schema - - ;; --- Daemon Lifecycle --- - #:start-daemon - #:stop-daemon - #:harness-log - #:main - - ;; --- Memory (CLOSOS) --- - #:ingest-ast - #:lookup-object - #:list-objects-by-type - #:org-id-new - #:*memory* - #:*history-store* - #:org-object - #:make-org-object - #:org-object-id - #:org-object-type - #:org-object-attributes - #:org-object-parent-id - #:org-object-children - #:org-object-version - #:org-object-last-sync - #:org-object-vector - #:org-object-content - #:org-object-hash - #:snapshot-memory - #:rollback-memory - - ;; --- Context API (Peripheral Vision) --- - #:context-query-store - #:context-get-active-projects - #:context-get-recent-completed-tasks - #:context-list-all-skills - #:context-get-skill-source - #:context-get-system-logs - #:context-resolve-path - #:context-get-skill-telemetry - #:harness-track-telemetry - #:context-assemble-global-awareness - - ;; --- Reactive Signal Pipeline --- - #:process-signal - #:perceive-gate - #:probabilistic-gate - #:consensus-gate - #:act-gate - #:reason-gate - #:perceive-gate - #:dispatch-gate - #:inject-stimulus - #:initialize-actuators - #:dispatch-action - #:register-actuator - - ;; --- Skill Engine --- - #:load-skill-from-org - #:initialize-all-skills - #:load-skill-with-timeout - #:topological-sort-skills - #:validate-lisp-syntax - #:defskill - #:*skills-registry* - #:skill - #:skill-name - #:skill-priority - #:skill-dependencies - #:skill-trigger-fn - #:skill-probabilistic-prompt - #:skill-deterministic-fn - - ;; --- Tool Registry --- - #:def-cognitive-tool - #:*cognitive-tools* - #:cognitive-tool - #:cognitive-tool-name - #:cognitive-tool-description - #:cognitive-tool-parameters - #:cognitive-tool-guard - #:cognitive-tool-body - - ;; --- Emacs Client Registry --- - #:*emacs-clients* - #:*clients-lock* - #:register-emacs-client - #:unregister-emacs-client - - ;; --- Probabilistic Engine --- - #:ask-probabilistic - #:register-probabilistic-backend - #:distill-prompt - #:*provider-cascade* - - ;; --- Security Vault --- - #:vault-get-secret - #:vault-set-secret - - ;; --- Deterministic Logic --- - #:list-objects-with-attribute - #:deterministic-verify - - ;; --- AST Helpers --- - #:find-headline-missing-id)) - -(in-package :opencortex) - -(defun proto-get (plist key) - "Robustly retrieves a value from a plist, checking both uppercase and lowercase keyword versions." - (let* ((s (string key)) - (up (intern (string-upcase s) :keyword)) - (dn (intern (string-downcase s) :keyword))) - (or (getf plist up) (getf plist dn)))) - -(defvar *system-logs* nil) -(defvar *logs-lock* (bordeaux-threads:make-lock "harness-logs-lock")) -(defvar *max-log-history* 100) - -(defvar *skills-registry* (make-hash-table :test 'equal) - "Global registry of all loaded skills.") - -(defvar *skill-telemetry* (make-hash-table :test 'equal)) -(defvar *telemetry-lock* (bordeaux-threads:make-lock "harness-telemetry-lock")) - -(defun harness-track-telemetry (skill-name duration status) - "Updates performance metrics for a specific skill. Status should be :success or :rejected." - (when skill-name - (bordeaux-threads:with-lock-held (*telemetry-lock*) - (let ((entry (or (gethash skill-name *skill-telemetry*) (list :executions 0 :total-time 0 :failures 0)))) - (incf (getf entry :executions)) - (incf (getf entry :total-time) duration) - (when (eq status :rejected) (incf (getf entry :failures))) - (setf (gethash skill-name *skill-telemetry*) entry))))) - -(defvar *cognitive-tools* (make-hash-table :test 'equal)) - -(defstruct cognitive-tool - name - description - parameters - guard - body) - -(defmacro def-cognitive-tool (name description parameters &key guard body) - "Registers a new cognitive tool into the global registry. Parameters must be a list of property lists." - `(setf (gethash (string-downcase (string ',name)) *cognitive-tools*) - (make-cognitive-tool :name (string-downcase (string ',name)) - :description ,description - :parameters ',parameters - :guard ,guard - :body ,body))) - -(defun harness-log (msg &rest args) - "Centralized logging for the harness." - (let ((formatted-msg (apply #'format nil msg args))) - (bordeaux-threads:with-lock-held (*logs-lock*) - (push formatted-msg *system-logs*) - (when (> (length *system-logs*) *max-log-history*) - (setq *system-logs* (subseq *system-logs* 0 *max-log-history*)))) - (format t "~a~%" formatted-msg) - (finish-output))) diff --git a/harness/perceive.lisp b/harness/perceive.lisp deleted file mode 100644 index 58153c6..0000000 --- a/harness/perceive.lisp +++ /dev/null @@ -1,130 +0,0 @@ -(in-package :opencortex) - -(defvar *async-sensors* '(:chat-message :delegation :user-command) - "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. - - 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)) - "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 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 - ;; 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") - - ;; 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) - "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))) - - ;; 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 - - ;; 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 moved to different org node - update focus - (:point-update - (let ((element (getf payload :element))) - (when element - (snapshot-memory) - ;; Track foveal focus for contextual reasoning - (setf *foveal-focus-id* - (ignore-errors (getf element :id))) - (ingest-ast element)))) - - ;; 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)))) - - ;; Update signal status - (setf (getf signal :status) :perceived) - (setf (getf signal :foveal-focus) *foveal-focus-id*) - signal)) diff --git a/harness/reason.lisp b/harness/reason.lisp deleted file mode 100644 index d8eff5b..0000000 --- a/harness/reason.lisp +++ /dev/null @@ -1,361 +0,0 @@ -(in-package :opencortex) - -(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) - "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)) - "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) - - ;; 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)))))))) - - ;; All providers failed - (list :type :LOG - :payload (list :text "Neural Cascade Failure: All providers exhausted."))))) - -(defun strip-markdown (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 "")) - (setf cleaned (cl-ppcre:regex-replace-all "\\n```$" cleaned "")) - (setf cleaned (cl-ppcre:regex-replace-all "```" cleaned "")) - (string-trim '(#\Space #\Newline #\Tab) cleaned)) - text)) - -(defun normalize-plist-keywords (plist) - "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))) - (intern (string k) :keyword) - k) - collect (car rest)))) - -(defun think (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"))) - - ;; 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 - -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. - -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))) - - (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 (char= (char cleaned 0) #\() - ;; Response starts with paren - try to parse as plist - (handler-case - (let ((parsed (read-from-string 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) - "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)) - - ;; 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))) - - ;; 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))) - - ;; 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)))) - - ;; 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) - "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))) - - ;; 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 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)) - (setf (getf signal :approved-action) nil))) - - (setf (getf signal :status) :reasoned) - signal))) diff --git a/harness/skills.lisp b/harness/skills.lisp deleted file mode 100644 index 500eda4..0000000 --- a/harness/skills.lisp +++ /dev/null @@ -1,435 +0,0 @@ -(in-package :opencortex) - -(defun COSINE-SIMILARITY (v1 v2) - "Computes cosine similarity between two vectors." - (let* ((len1 (length v1)) - (len2 (length v2))) - (if (or (zerop len1) (zerop len2)) - 0.0 - (let* ((dot 0.0d0) - (n1 0.0d0) - (n2 0.0d0)) - (dotimes (i (min len1 len2)) - (let* ((x (coerce (elt v1 i) 'double-float)) - (y (coerce (elt v2 i) 'double-float))) - (incf dot (* x y)) - (incf n1 (* x x)) - (incf n2 (* y y)))) - (if (or (zerop n1) (zerop n2)) - 0.0 - (/ dot (sqrt (* n1 n2)))))))) - -;; TODO: Stub for vault - implement later -(defun VAULT-MASK-STRING (s) "[MASKED]") - -(defvar *VAULT-MEMORY* (make-hash-table :test 'equal)) - - -(defstruct skill name priority dependencies trigger-fn probabilistic-prompt deterministic-fn) - -(defvar *skill-catalog* (make-hash-table :test 'equal) - "A stateful tracking table for all skill files discovered in the environment.") - -(defstruct skill-entry - filename - (status :discovered) ;; :discovered, :loading, :ready, :failed - error-log - (load-time 0)) - -(defun find-triggered-skill (context) - "Returns the highest priority skill whose trigger matches context AND has a probabilistic prompt." - (let ((triggered nil)) - (maphash (lambda (name skill) - (declare (ignore name)) - (when (and (skill-probabilistic-prompt skill) - (ignore-errors (funcall (skill-trigger-fn skill) context))) - (push skill triggered))) - *skills-registry*) - (first (sort triggered #'> :key #'skill-priority)))) - -(defmacro defskill (name &key priority dependencies trigger probabilistic deterministic) - "Registers a new skill into the global registry." - `(setf (gethash (string-downcase (string ,name)) *skills-registry*) - (make-skill :name (string-downcase (string ,name)) - :priority (or ,priority 10) - :dependencies ',dependencies - :trigger-fn ,trigger - :probabilistic-prompt ,probabilistic - :deterministic-fn ,deterministic))) - -(defun resolve-skill-dependencies (skill-name) - "Recursively resolves dependencies for a given skill name." - (let ((resolved nil) (seen nil)) - (labels ((visit (name) - (unless (member name seen :test #'equal) - (push name seen) - (let ((skill (gethash (string-downcase (string name)) *skills-registry*))) - (when skill - (dolist (dep (skill-dependencies skill)) - (visit dep)))) - (push name resolved)))) - (visit skill-name) - (nreverse resolved)))) - -(defun parse-skill-metadata (filepath) - "Extracts ID and DEPENDS_ON tags from org file." - (let ((dependencies nil) - (id nil) - (content (uiop:read-file-string filepath))) - ;; Simple ID extraction using string search - (let ((id-start (search ":ID:" content))) - (when id-start - (let ((id-end (position #\Newline content :start id-start))) - (when id-end - (setf id (subseq content (+ id-start 4) id-end))))))) - ;; Simple DEPENDS_ON extraction - (let ((pos 0)) - (loop while (setf pos (search "#+DEPENDS_ON:" content :start2 pos)) - do (let ((end (position #\Newline content :start pos))) - (when end - (push (subseq content (+ pos 13) end) dependencies) - (setf pos end)))) - (values id (reverse dependencies)))) - -(defun topological-sort-skills (skills-dir) - "Returns a list of skill filepaths sorted by dependency (dependencies first)." - (let ((files (uiop:directory-files skills-dir "org-skill-*.org")) - (adj (make-hash-table :test 'equal)) - (name-to-file (make-hash-table :test 'equal)) - (id-to-file (make-hash-table :test 'equal)) - (result nil) - (visited (make-hash-table :test 'equal)) - (stack (make-hash-table :test 'equal))) - (dolist (file files) - (let ((filename (pathname-name file))) - (multiple-value-bind (id deps) (parse-skill-metadata file) - (setf (gethash (string-downcase filename) name-to-file) file) - (when id (setf (gethash (string-downcase id) id-to-file) file)) - (setf (gethash (string-downcase filename) adj) deps)))) - (labels ((visit (file) - (let* ((filename (pathname-name file)) - (node-key (string-downcase filename))) - (unless (gethash node-key visited) - (setf (gethash node-key stack) t) - (dolist (dep (gethash node-key adj)) - (let* ((is-id-p (uiop:string-prefix-p "id:" (string-downcase dep))) - (dep-key (string-downcase (if is-id-p (subseq dep 3) dep))) - (dep-file (if is-id-p - (gethash dep-key id-to-file) - (or (gethash dep-key id-to-file) - (gethash dep-key name-to-file))))) - (when dep-file - (let ((dep-filename (pathname-name dep-file))) - (if (gethash (string-downcase dep-filename) stack) - (error "Circular dependency detected: ~a -> ~a" filename dep-filename) - (visit dep-file)))))) - (setf (gethash node-key stack) nil) - (setf (gethash node-key visited) t) - (push file result))))) - (let ((filenames (sort (mapcar #'pathname-name files) #'string<))) - (dolist (name filenames) - (let ((file (gethash (string-downcase name) name-to-file))) - (when file (visit file))))) - (nreverse result)))) - -(defun validate-lisp-syntax (code-string) - "Checks if a string contains valid, readable Common Lisp forms. -Delegates to the Lisp Validator skill when available; falls back to a basic -reader check during early boot before the validator skill is loaded." - (let ((result - (if (fboundp 'lisp-validator-validate) - (lisp-validator-validate code-string :strict nil) - (handler-case - (let ((*read-eval* nil)) - (with-input-from-string (stream (format nil "(progn ~a)" code-string)) - (loop for form = (read stream nil :eof) until (eq form :eof))) - (list :status :success)) - (error (c) - (list :status :error :reason (format nil "~a" c))))))) - (if (eq (getf result :status) :success) - (values t nil) - (values nil (or (getf result :reason) "Lisp Validator rejected code."))))) - -(defun load-skill-from-org (filepath) - "Parses and evaluates Lisp blocks with :tangle directives from an Org file. -Only loads blocks that specify a .lisp tangle target, ignoring tests and examples." - (let* ((skill-base-name (pathname-name filepath)) - (entry (or (gethash skill-base-name *skill-catalog*) (make-skill-entry :filename skill-base-name)))) - (setf (skill-entry-status entry) :loading) - (setf (gethash skill-base-name *skill-catalog*) entry) - - (handler-case - (let* ((content (uiop:read-file-string filepath)) - (lines (uiop:split-string content :separator '(#\Newline))) - (in-lisp-block nil) - (collect-this-block nil) - (lisp-code "") - (pkg-name (intern (string-upcase (format nil "OPENCORTEX.SKILLS.~a" skill-base-name)) :keyword))) - - (dolist (line lines) - (let ((clean-line (string-trim '(#\Space #\Tab #\Return) line))) - (cond ((uiop:string-prefix-p "#+begin_src lisp" (string-downcase clean-line)) - (setf in-lisp-block t) - ;; Only collect blocks with a :tangle directive pointing to a - ;; runtime .lisp file (exclude tests and :tangle no) - (let ((tl (string-downcase clean-line))) - (setf collect-this-block - (and (search ":tangle" tl) - (not (search ":tangle no" tl)) - (search ".lisp" tl) - (not (search "tests/" tl)) - (not (search "test/" tl)))))) - ((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))) - (setf lisp-code (concatenate 'string lisp-code line (string #\Newline))))))) - - (if (= (length lisp-code) 0) - (progn (setf (skill-entry-status entry) :ready) t) - (progn - (multiple-value-bind (valid-p err) (validate-lisp-syntax lisp-code) - (unless valid-p (error "Syntax Error: ~a" err))) - (harness-log "HARNESS: Jailing skill '~a' in package ~a" skill-base-name pkg-name) - (unless (find-package pkg-name) - (let ((new-pkg (make-package pkg-name :use '(:cl)))) - (use-package :opencortex new-pkg))) - (let ((*read-eval* nil) (*package* (find-package pkg-name))) - (eval (read-from-string (format nil "(progn ~a)" lisp-code)))) - (setf (skill-entry-status entry) :ready) - t))) - (error (c) - (let ((msg (format nil "~a" c))) - (harness-log "LOADER ERROR in skill '~a': ~a" skill-base-name msg) - (setf (skill-entry-status entry) :failed) - (setf (skill-entry-error-log entry) msg) - nil)))) - -(defun load-skill-with-timeout (filepath timeout-seconds) - "Loads a skill Org file with a hard execution timeout." - (let* ((finished nil) - (thread (bt:make-thread (lambda () - (if (load-skill-from-org filepath) - (setf finished t) - (setf finished :error))) - :name (format nil "loader-~a" (pathname-name filepath)))) - (start-time (get-internal-real-time)) - (timeout-units (truncate (* timeout-seconds internal-time-units-per-second)))) - (loop - (when (eq finished t) (return :success)) - (when (eq finished :error) (return :error)) - (unless (bt:thread-alive-p thread) (return :error)) - (when (> (- (get-internal-real-time) start-time) timeout-units) - (harness-log "HARNESS: Timing out skill ~a..." (pathname-name filepath)) - #+sbcl (sb-thread:terminate-thread thread) - #-sbcl (bt:destroy-thread thread) - (return :timeout)) - (sleep 0.05)))))) - -(defun initialize-all-skills () - "Scans the directory defined by SKILLS_DIR and hot-loads skills using topological order." - (let* ((env-path (uiop:getenv "SKILLS_DIR")) - (skills-dir-str (or env-path (namestring (merge-pathnames "notes/" (user-homedir-pathname))))) - (resolved-path (context-resolve-path skills-dir-str)) - (skills-dir (if resolved-path (uiop:ensure-directory-pathname resolved-path) nil))) - - (unless (and skills-dir (uiop:directory-exists-p skills-dir)) - (harness-log "HARNESS ERROR: Skills directory not found: ~a" skills-dir-str) - (return-from initialize-all-skills nil)) - - (let ((sorted-files (topological-sort-skills skills-dir))) - (let* ((mandatory-env (uiop:getenv "MANDATORY_SKILLS")) - (mandatory-skills (if mandatory-env - (mapcar (lambda (s) (string-trim '(#\Space #\" #\') s)) - (uiop:split-string mandatory-env :separator '( #\,))) - '("org-skill-policy" "org-skill-bouncer")))) - (dolist (req mandatory-skills) - (unless (member req sorted-files :key #'pathname-name :test #'string-equal) - (error "BOOT FAILURE: Mandatory skill '~a' not found in skills directory: ~a" req (uiop:native-namestring skills-dir)))) - - (harness-log "==================================================") - (harness-log " LOADER: Initializing ~a skills..." (length sorted-files)) - - (dolist (file sorted-files) - (let* ((skill-name (pathname-name file)) - (is-mandatory (member skill-name mandatory-skills :test #'string-equal))) - (harness-log " LOADER: Loading ~a..." skill-name) - (let ((status (load-skill-with-timeout file 5))) - (unless (eq status :success) - (if is-mandatory - (error "BOOT FAILURE: Mandatory skill '~a' failed to load (Status: ~a)." skill-name status) - (harness-log "LOADER WARNING: Skill '~a' failed to load." skill-name)))))) - - (let ((ready 0) (failed 0)) - (maphash (lambda (k v) - (declare (ignore k)) - (if (eq (skill-entry-status v) :ready) (incf ready) (incf failed))) - *skill-catalog*) - (harness-log " LOADER: Boot Complete. [Ready: ~a] [Failed: ~a]" ready failed) - (harness-log "==================================================") - (values ready failed)))))) - -(defun generate-tool-belt-prompt () - "Aggregates all registered cognitive tools into a descriptive prompt." - (let ((output (format nil "AVAILABLE TOOLS: -You can call tools by returning a Lisp plist: (:target :tool :action :call :tool :args (...)) - -EXAMPLES: -(:target :tool :action :call :tool \"eval\" :args (:code \"(+ 1 1)\")) -(:target :tool :action :call :tool \"grep-search\" :args (:pattern \"autonomousty\")) -(:target :tool :action :call :tool \"shell\" :args (:cmd \"ls -la\")) - ---- -" ))) - (maphash (lambda (name tool) - (setf output (concatenate 'string output - (format nil "- ~a: ~a~% Parameters: ~s~%~%" - name - (cognitive-tool-description tool) - (cognitive-tool-parameters tool))))) - *cognitive-tools*) - output)) - -(def-cognitive-tool :eval "Evaluates raw Common Lisp code in the harness image. Use this for complex calculations or internal state inspection." - ((:code :type :string :description "The Lisp code to evaluate")) - :guard (lambda (args context) - (declare (ignore context)) - (let ((code (getf args :code))) - (let ((harness-pkg (find-package :opencortex.skills.org-skill-lisp-validator))) - (if harness-pkg - (uiop:symbol-call :opencortex.skills.org-skill-lisp-validator :lisp-validator-validate code) - t)))) - :body (lambda (args) - (let ((code (getf args :code))) - (handler-case (let ((result (eval (read-from-string code)))) - (format nil "~s" result)) - (error (c) (format nil "ERROR: ~a" c)))))) - -(def-cognitive-tool :grep-search "Searches for a pattern in the project files." - ((:pattern :type :string :description "The regex pattern to search for") - (:dir :type :string :description "Directory to search in (default is project root)")) - :body (lambda (args) - (let ((pattern (getf args :pattern)) - (dir (or (getf args :dir) (uiop:getenv "MEMEX_DIR")))) - (uiop:run-program (list "grep" "-r" "-n" "--exclude-dir=node_modules" pattern dir) - :output :string :ignore-error-status t)))) - -(def-cognitive-tool :shell "Executes a shell command on the local machine. Use this for file operations, system checks, or running tests." - ((:cmd :type :string :description "The full bash command to execute")) - :guard (lambda (args context) - (declare (ignore context)) - (let ((cmd (getf args :cmd))) - (not (or (search "rm -rf /" cmd) (search ":(){ :|:& };:" cmd))))) - :body (lambda (args) - (let ((cmd (getf args :cmd))) - (multiple-value-bind (out err code) - (uiop:run-program (list "bash" "-c" cmd) :output :string :error-output :string :ignore-error-status t) - (format nil "EXIT-CODE: ~a~%~%STDOUT:~%~a~%~%STDERR:~%~a" code out err))))) - -(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 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, 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 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/harness/tui-client.lisp b/harness/tui-client.lisp deleted file mode 100644 index d50b3f9..0000000 --- a/harness/tui-client.lisp +++ /dev/null @@ -1,235 +0,0 @@ -(in-package :cl-user) -(defpackage :opencortex.tui - (:use :cl :croatoan) - (:export :main)) -(in-package :opencortex.tui) - -(defvar *daemon-host* "127.0.0.1") -(defvar *daemon-port* 9105) -(defvar *socket* nil) -(defvar *stream* nil) -(defvar *chat-history* (list)) -(defvar *status-text* "Connecting...") -(defvar *input-buffer* (make-array 0 :element-type 'char :fill-pointer 0 :adjustable t)) -(defvar *command-history* (make-array 0 :element-type 't :fill-pointer 0 :adjustable t)) -(defvar *history-index* -1) -(defvar *input-mode* :single) ; :single or :multi -(defvar *is-running* t) -(defvar *queue-lock* (bt:make-lock)) -(defvar *incoming-msgs* nil) - -(defun enqueue-msg (msg) - (bt:with-lock-held (*queue-lock*) - (push msg *incoming-msgs*))) - -(defun add-to-history (cmd) - "Add command to history, preserving most recent." - (when (and cmd (> (length cmd) 0)) - ;; Don't duplicate the last command - (unless (and (> (length *command-history*) 0) - (string= cmd (aref *command-history* (1- (length *command-history*)))))) - (vector-push-extend cmd *command-history* :adjustable t)) - (setf *history-index* (length *command-history*)))) - -(defun history-previous () - "Navigate to previous command in history." - (when (> (length *command-history*) 0) - (setf *history-index* (max 0 (1- *history-index*))) - (let ((cmd (aref *command-history* *history-index*))) - (setf (fill-pointer *input-buffer*) 0) - (loop for ch across cmd do (vector-push-extend ch *input-buffer*)) - cmd))) - -(defun history-next () - "Navigate to next command in history." - (when (and *history-index* (< *history-index* (1- (length *command-history*)))) - (setf *history-index* (1+ *history-index*)) - (let ((cmd (aref *command-history* *history-index*))) - (setf (fill-pointer *input-buffer*) 0) - (loop for ch across cmd do (vector-push-extend ch *input-buffer*)) - cmd)) - (when (>= *history-index* (1- (length *command-history*))) - (setf (fill-pointer *input-buffer*) 0))) - -(defun dequeue-msgs () - (bt:with-lock-held (*queue-lock*) - (let ((msgs (nreverse *incoming-msgs*))) - (setf *incoming-msgs* nil) - msgs))) - -(defun clean-keywords (msg) - (if (listp msg) - (let ((clean nil)) - (loop for (k v) on msg by #'cddr - do (push (intern (string k) :keyword) clean) - (push v clean)) - (nreverse clean)) - msg)) - -(defun format-payload (payload) - "Extracts human-readable text from a protocol payload, handling nested tool calls." - (let* ((action (getf payload :ACTION)) - (text (getf payload :TEXT)) - (msg (getf payload :MESSAGE)) - (tool (getf payload :TOOL)) - (prompt (getf payload :PROMPT)) - (args (getf payload :ARGS)) - (result (getf payload :RESULT))) - (cond (text text) - (msg msg) - ((eq action :MESSAGE) (getf payload :TEXT)) - ((and tool prompt) (format nil "🤔 ~a: ~a" tool prompt)) - ((and tool args) - (let ((inner-prompt (or (getf args :PROMPT) (getf args :TEXT)))) - (if inner-prompt - (format nil "🤔 ~a: ~a" tool inner-prompt) - (format nil "🔧 ~a args: ~s" tool args)))) - (result (format nil "✅ ~a" result)) - (t (format nil "~s" payload))))) - -(defun format-incoming (msg) - "Formats incoming message with styling." - (let ((type (or (getf msg :TYPE) (getf msg :type))) - (payload (or (getf msg :PAYLOAD) (getf msg :payload)))) - (cond - ((and (listp msg) (eq type :EVENT)) - (let ((action (or (getf payload :ACTION) (getf payload :action))) - (text (or (getf payload :TEXT) (getf payload :text) (getf payload :MESSAGE) (getf payload :message))))) - (cond ((eq action :handshake) (format nil "👋 ~a" (or text "Connected"))) - ((eq action :thinking) (format nil "🤔 ~a" (or text "Thinking..."))) - ((eq action :tool-complete) (format nil "🔧 Done")) - (text (format nil "💬 ~a" text)) - (t (format nil "📢 ~s" msg))))) - ((and (listp msg) (eq type :STATUS)) - (format nil "🔄 Scribe: ~a | Gardener: ~a" - (or (getf msg :SCRIBE) "idle") - (or (getf msg :GARDENER) "idle"))) - ((and (listp msg) (member type '(:REQUEST :RESPONSE :LOG))) - (format-payload payload)) - ((and (listp msg) (eq type :EVENT) (eq (getf payload :SENSOR) :TOOL-OUTPUT)) - (format nil "🔧 ~a" (getf payload :RESULT))) - (t (format nil "~s" msg)))) - -(defun listen-thread () - (loop while *is-running* do - (handler-case - (when (and *stream* (open-stream-p *stream*)) - (let ((raw-msg (opencortex:read-framed-message *stream*))) - (unless (member raw-msg '(:eof :error)) - (let* ((msg (clean-keywords raw-msg)) - (type (or (getf msg :TYPE) (getf msg :type))) - (payload (or (getf msg :PAYLOAD) (getf msg :payload)))) - (cond ((and (listp msg) (eq type :EVENT)) - (let ((action (or (getf payload :ACTION) (getf payload :action))) - (text (or (getf payload :TEXT) (getf payload :text) (getf payload :MESSAGE) (getf payload :message)))) - (cond ((eq action :handshake) (setf *status-text* "Ready")) - (text (enqueue-msg (format nil "SYSTEM: ~a" text)))))) - ((and (listp msg) (eq type :STATUS)) - (setf *status-text* (format nil "[Scribe: ~a] [Gardener: ~a]" - (or (getf msg :SCRIBE) (getf msg :scribe)) - (or (getf msg :GARDENER) (getf msg :gardener))))) - ((and (listp msg) (member type '(:REQUEST :RESPONSE :LOG))) - (let ((formatted (format-payload payload))) - (when formatted (enqueue-msg formatted)))) - ((and (listp msg) (eq type :EVENT) (eq (getf payload :SENSOR) :TOOL-OUTPUT)) - (let ((formatted (format-payload payload))) - (when formatted (enqueue-msg formatted)))) - (t (harness-log "TUI: Ignored unknown type ~a" type))))) - (when (eq raw-msg :eof) (setf *is-running* nil)) - (when (eq raw-msg :error) (setf *status-text* "Protocol Error")))) - (error (c) (setf *status-text* (format nil "Net Error: ~a" c)) (setf *is-running* nil))) - (sleep 0.05))) - -(defun main () - (handler-case - (setf *socket* (usocket:socket-connect *daemon-host* *daemon-port*)) - (error (e) (format t "Error connecting: ~a~%" e) (return-from main))) - (setf *stream* (usocket:socket-stream *socket*)) - (bt:make-thread #'listen-thread :name "tui-listener") - - (unwind-protect - (with-screen (scr :input-echoing nil :input-blocking nil :enable-colors t :cursor-visible t :window-border-chars #\┌#\─#\┐#\│#\└#\┘#\─#\│) - (let* ((h (height scr)) - (w (width scr)) - (chat-height (- h 5)) - (chat-win (make-instance 'window :height chat-height :width (- w 2) :position (list 1 1) :border t)) - (status-win (make-instance 'window :height 1 :width (- w 2) :position (list (- h 4) 1) :border t)) - (help-win (make-instance 'window :height 1 :width (- w 2) :position (list (- h 3) 1))) - (input-win (make-instance 'window :height 1 :width (- w 2) :position (list (- h 2) 1) :border t)) - (last-status nil)) - - ;; Draw help once - (add-string help-win "↑↓ History | Esc Clear | /help /exit | Multi-line: Shift+Enter" :y 0 :x 0 :attributes '(:bold)) - (refresh help-win) - - (setf (function-keys-enabled-p input-win) t) - (setf (input-blocking input-win) nil) - - (loop while *is-running* do - ;; 1. Handle incoming messages - (let ((new-msgs (dequeue-msgs))) - (when new-msgs - (dolist (msg new-msgs) - (let ((formatted (format-incoming msg))) - (when formatted - (push formatted *chat-history*) - (setf *chat-history* (subseq *chat-history* 0 (min (length *chat-history*) 500)))))) - - (clear chat-win) - (let ((line-num 1)) - (dolist (m (reverse (subseq *chat-history* 0 (min (length *chat-history*) (- chat-height 3))))) - (add-string chat-win (format nil "│ ~a" m) :y line-num :x 1) - (incf line-num))) - ;; Add border line count - (add-string chat-win (format nil "├─ ~d messages" (length *chat-history*)) :y (1- chat-height) :x 1 :attributes '(:dim)) - (refresh chat-win))) - - ;; 2. Render Status Bar ONLY if changed - (unless (equal *status-text* last-status) - (clear status-win) - (add-string status-win (format nil "┤ ~a ┤" *status-text*) :y 0 :x 1 :attributes '(:reverse)) - (refresh status-win) - (setf last-status *status-text*)) - - ;; 3. Handle Keyboard Input - (let* ((event (get-wide-event input-win)) - (ch (and event (typep event 'event) (event-key event)))) - (when ch - (cond - ((or (eq ch #\Newline) (eq ch #\Return)) - (let ((cmd (coerce *input-buffer* 'string))) - (setf (fill-pointer *input-buffer*) 0) - (when (> (length cmd) 0) - (add-to-history cmd) - (enqueue-msg (format nil "⬆ ~a" cmd)) - (let ((framed (opencortex:frame-message (list :TYPE :EVENT - :META (list :SOURCE :tui :SESSION-ID "default") - :PAYLOAD (list :SENSOR :user-input :TEXT cmd))))) - (format *stream* "~a" framed) - (finish-output *stream*))) - (when (string= cmd "/exit") (setf *is-running* nil)) - (when (string= cmd "/clear") (setf *chat-history* nil)) - (when (string= cmd "/help") - (enqueue-msg "Available commands: /help /exit /clear /status") - (enqueue-msg "Use ↑↓ for history, Esc to clear input")))) - ((eq ch :up) (history-previous)) - ((eq ch :down) (history-next)) - ((eq ch :escape) - (setf (fill-pointer *input-buffer*) 0) - (setf *history-index* (length *command-history*))) - ((or (eq ch :backspace) (eq ch #\Backspace) (eq ch #\Rubout) (eq ch #\Del)) - (when (> (fill-pointer *input-buffer*) 0) - (decf (fill-pointer *input-buffer*)))) - ((eq ch :shift-left) ; Shift+Enter for multi-line - (vector-push-extend #\Newline *input-buffer*)) - ((characterp ch) - (vector-push-extend ch *input-buffer*)))) - - (clear input-win) - (let ((prompt (if (> (fill-pointer *input-buffer*) 0) "│" "▶"))) - (add-string input-win (format nil "~a ~a" prompt (coerce *input-buffer* 'string)) :y 0 :x 1 :attributes (when (> (fill-pointer *input-buffer*) 0) '(:bold)))) - (refresh input-win)) - - (sleep 0.02)))) - (setf *is-running* nil) - (when *socket* (usocket:socket-close *socket*)))) diff --git a/skills/org-skill-bouncer.lisp b/skills/org-skill-bouncer.lisp deleted file mode 100644 index d07aded..0000000 --- a/skills/org-skill-bouncer.lisp +++ /dev/null @@ -1,258 +0,0 @@ -(in-package :opencortex) - -(defun bouncer-scan-secrets (text) - "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) - "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)) - - ;; 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 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)))) - (approved (getf action :approved))) - - (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 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))))) - - ;; 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.") - - (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 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 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))) - - ;; 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 security gate on re-injection - (setf (getf action :approved) t) - - ;; Re-inject the action into the signal pipeline - (inject-stimulus action) - - ;; 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 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))) - (bouncer-create-flight-plan blocked-action))) - - ;; Signal type 2: Heartbeat, check for approvals - (:heartbeat - (bouncer-process-approvals) - ;; 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))))) - -(defskill :skill-bouncer - :priority 150 - :trigger (lambda (ctx) (declare (ignore ctx)) t) - :probabilistic nil - :deterministic #'bouncer-deterministic-gate) diff --git a/skills/org-skill-cli-gateway.lisp b/skills/org-skill-cli-gateway.lisp deleted file mode 100644 index 0a1a889..0000000 --- a/skills/org-skill-cli-gateway.lisp +++ /dev/null @@ -1,81 +0,0 @@ -(defvar *cli-port* 9105) -(defvar *cli-server-socket* nil) -(defvar *cli-server-thread* nil) - -(defun execute-cli-action (action context) - "Sends a framed message back to the connected CLI client." - (let* ((payload (proto-get action :PAYLOAD)) - (meta (getf context :meta)) - (stream (getf meta :reply-stream))) - (handler-case - (if (and stream (open-stream-p stream)) - (progn - (format stream "~a" (frame-message action)) - (finish-output stream) - (format stream "~a" (frame-message '(:TYPE :STATUS :SCRIBE :IDLE :GARDENER :SLEEPING))) - (finish-output stream)) - (harness-log "CLI ERROR: No active or open reply stream for signal.")) - (error (c) (harness-log "CLI ACTUATOR ERROR: ~a" c))))) - -(defun handle-cli-slash-command (cmd stream) - (cond - ((string= cmd "/exit") (return-from handle-cli-slash-command :exit)) - (t (format stream "~a" (frame-message (list :TYPE :REQUEST :PAYLOAD (list :ACTION :MESSAGE :TEXT (format nil "Unknown command: ~a" cmd)))))))) - -(defun handle-cli-client (stream) - "Reads framed messages from a CLI client and injects them as stimuli." - (harness-log "CLI: Client connected.") - (handler-case - (progn - ;; 1. Send Handshake - (format stream "~a" (frame-message (make-hello-message "0.1.0"))) - (finish-output stream) - (format stream "~a" (frame-message '(:TYPE :STATUS :SCRIBE :IDLE :GARDENER :SLEEPING))) - (finish-output stream) - - ;; 2. Communication Loop - (loop - (let ((msg (read-framed-message stream))) - (cond ((eq msg :eof) (return)) - ((eq msg :error) (return)) - (t (let* ((payload (proto-get msg :payload)) - (text (proto-get payload :text)) - (meta (proto-get msg :meta))) - (if (and text (stringp text) (char= (char text 0) #\/)) - (when (eq (handle-cli-slash-command text stream) :exit) (return)) - (progn - ;; Default meta if missing - (unless meta - (setf (getf msg :meta) (list :SOURCE :CLI :SESSION-ID "default"))) - (harness-log "CLI: Received input -> ~s" msg) - (inject-stimulus msg :stream stream))))))))) - (error (c) (harness-log "CLI CLIENT DISCONNECT: ~a" c))) - (harness-log "CLI: Client disconnected.")) - -(defun start-cli-gateway (&optional (port *cli-port*)) - "Starts the TCP listener for local CLI clients." - (setf *cli-server-socket* (usocket:socket-listen "0.0.0.0" port :reuse-address t)) - (setf *cli-server-thread* - (bt:make-thread - (lambda () - (unwind-protect - (loop - (let* ((socket (usocket:socket-accept *cli-server-socket*)) - (stream (usocket:socket-stream socket))) - (bt:make-thread (lambda () - (unwind-protect (handle-cli-client stream) - (usocket:socket-close socket))) - :name "opencortex-cli-client-handler"))) - (usocket:socket-close *cli-server-socket*))) - :name "opencortex-cli-gateway")) - (harness-log "CLI: Gateway listening on port ~a" port)) - -(register-actuator :CLI #'execute-cli-action) - -(defskill :skill-gateway-cli - :priority 200 - :trigger (lambda (ctx) (declare (ignore ctx)) nil) - :probabilistic nil - :deterministic (lambda (action ctx) (declare (ignore ctx)) action)) - -(start-cli-gateway) diff --git a/skills/org-skill-credentials-vault.lisp b/skills/org-skill-credentials-vault.lisp deleted file mode 100644 index 91c1119..0000000 --- a/skills/org-skill-credentials-vault.lisp +++ /dev/null @@ -1,82 +0,0 @@ -(defun vault-get-secret (provider &key type) - "Retrieves a secret (api-key or session) for a provider.") - -(defun vault-set-secret (provider secret &key type) - "Securely stores a secret and triggers a Merkle snapshot.") - - - -(defvar opencortex::*vault-memory* (make-hash-table :test 'equal) - "In-memory cache of sensitive credentials.") - -(defun vault-mask-string (str) - "Returns a masked version of a sensitive string." - (if (and str (> (length str) 8)) - (format nil "~a...~a" (subseq str 0 4) (subseq str (- (length str) 4))) - "[REDACTED]")) - -(defun vault-get-secret (provider &key (type :api-key)) - "Retrieves a credential. Type can be :api-key or :session." - (let* ((key (format nil "~a-~a" provider type)) - (val (gethash key opencortex::*vault-memory*))) - (if val - val - ;; Fallback to environment - (let ((env-var (case provider - ((:gemini :gemini-api) "GEMINI_API_KEY") - (:openai "OPENAI_API_KEY") - (:anthropic "ANTHROPIC_API_KEY") - (:groq "GROQ_API_KEY") - (:openrouter "OPENROUTER_API_KEY") - (:telegram "TELEGRAM_BOT_TOKEN") - (:signal "SIGNAL_ACCOUNT_NUMBER") - (:matrix-homeserver "MATRIX_HOMESERVER") - (:matrix-token "MATRIX_ACCESS_TOKEN") - (t nil)))) - (when (and env-var (eq type :api-key)) - (uiop:getenv env-var)))))) - -(defun vault-set-secret (provider secret &key (type :api-key)) - "Securely stores a secret and triggers a Merkle snapshot." - (let ((key (format nil "~a-~a" provider type))) - (setf (gethash key opencortex::*vault-memory*) secret) - (harness-log "VAULT - Updated ~a for ~a. Triggering Merkle snapshot..." type provider) - (snapshot-memory) - t)) - -(defun vault-onboard-gemini-web () - "Instructions for the Autonomous Cookie Handshake." - (harness-log "--- GEMINI WEB ONBOARDING ---") - (harness-log "1. Visit gemini.google.com") - (harness-log "2. Run the 'Get Gemini Cookies' Bookmarklet.") - (harness-log " CODE: javascript:(function(){const c=document.cookie.split('; ').reduce((r,v)=>{const [n,val]=v.split('=');r[n]=val;return r},{});const target=['__Secure-1PSID','__Secure-1PSIDTS'];const out=target.map(n=>({name:n,value:c[n]}));prompt('Copy JSON:',JSON.stringify(out));})();") - (harness-log "PLATFORM GUIDE: Chrome/Firefox/Safari all support Bookmarklets via 'Add Page' or 'New Bookmark'.") - t) - -(progn - (defskill :skill-credentials-vault - :priority 200 ; High priority, foundational - :trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :onboarding-request)) - :probabilistic nil - :deterministic (lambda (action ctx) - (vault-onboard-gemini-web) - action))) - -#| -(defpackage :opencortex-vault-tests - (:use :cl :fiveam :opencortex)) -(in-package :opencortex-vault-tests) - -(def-suite vault-suite :description "Tests for the Credentials Vault.") -(in-suite vault-suite) - -(test test-masking - (is (equal "sk-t...-key" (opencortex::vault-mask-string "sk-test-key"))) - (is (equal "[REDACTED]" (opencortex::vault-mask-string "short")))) - -(test test-vault-persistence - "Verify that setting a secret triggers a snapshot (mock check)." - (let ((old-version (opencortex::org-object-version (gethash "root" *memory*)))) - (opencortex:vault-set-secret :test "secret-val") - (is (> (opencortex::org-object-version (gethash "root" *memory*)) old-version)))) -|# diff --git a/skills/org-skill-emacs-edit.lisp b/skills/org-skill-emacs-edit.lisp deleted file mode 100644 index 905eab7..0000000 --- a/skills/org-skill-emacs-edit.lisp +++ /dev/null @@ -1,281 +0,0 @@ -(in-package :opencortex) - -(defun emacs-edit-generate-id () - "Generates a unique ID for org-mode headlines. -Format: 8-char hex + timestamp for uniqueness." - (let* ((data (format nil "~a-~a" (get-universal-time) (random 999999))) - (digest (ironclad:digest-sequence :sha256 (ironclad:ascii-string-to-byte-array data))) - (uuid (ironclad:byte-array-to-hex-string digest))) - (subseq uuid 0 8))) - -(defun emacs-edit-id-format (id) - "Formats ID for org-mode (e.g., 'abc12345')." - (if (search "id:" id) - id - (format nil "id:~a" id))) - -(defun emacs-edit-print-headline (ast &key indent-level) - "Converts a HEADLINE AST node to org text. -INDENT-LEVEL is number of leading asterisks." - (let ((level (or indent-level 1)) - (stars (make-string level :initial-element #\*)) - (title (or (getf (getf ast :properties) :TITLE) "")) - (todo (getf (getf ast :properties) :TODO))) - (format nil "~a ~a~%~a" - stars - (if todo (format nil "[~a] " (string-upcase todo)) "") - title))) - -(defun emacs-edit-print-properties (props) - "Converts property list to :PROPERTIES: drawer." - (when props - (let ((lines (loop for (k v) on props by #'cddr - unless (member k '(:title :todo :created :id)) - collect (format nil ":~a:~a" k v)))) - (when lines - (format nil ":PROPERTIES:~%~{~a~^~%~}~%:END:~%" - lines))))) - -(defun emacs-edit-print-section (ast) - "Prints :CONTENT: or description text." - (let ((content (getf ast :content))) - (when content - content))) - -(defun emacs-edit-ast-to-org (ast &key (indent-level 1)) - "Recursively converts an entire org AST back to org text. -Preserves structure including #+begin_src blocks." - (let ((type (getf ast :type)) - (props (getf ast :properties)) - (contents (getf ast :contents)) - (elements (getf ast :elements))) - - (cond - ;; Headline - ((eq type :headline) - (format nil "~%~a~a~%~a~{~a~}" - (emacs-edit-print-headline ast :indent-level indent-level) - (emacs-edit-print-properties props) - (emacs-edit-print-section ast) - (mapcar (lambda (child) - (emacs-edit-ast-to-org child :indent-level (1+ indent-level))) - (or contents elements)))) - - ;; Section (body text) - ((eq type :section) - (emacs-edit-print-section ast)) - - ;; Plain text / paragraph - ((or (eq type :paragraph) (stringp ast)) - (format nil "~a~%" (if (stringp ast) ast (getf ast :raw-content)))) - - ;; Code block (preserve exactly) - ((eq type :src-block) - (let ((lang (or (getf ast :language) "")) - (code (or (getf ast :value) ""))) - (format nil "#+begin_src ~a~%~a~%#+end_src~%" - lang code))) - - ;; Unknown - return as-is - (t (format nil ""))))) - -(defvar *org-parser-cache* (make-hash-table :test 'equal) - "Cache for parsed org files.") - -(defun emacs-edit-parse-file (file-path) - "Parses an org FILE-PATH using existing ingest-ast. -Returns the parsed AST. Uses cache for performance." - (let ((cached (gethash file-path *org-parser-cache*))) - (when cached - (return-from emacs-edit-parse-file cached))) - - (let* ((content (uiop:read-file-string file-path)) - (ast (ingest-ast (list :type :document :raw-content content)))) - (setf (gethash file-path *org-parser-cache*) ast) - ast)) - -(defun emacs-edit-clear-cache (&optional file-path) - "Clears the parser cache. If FILE-PATH provided, clears only that entry." - (if file-path - (remhash file-path *org-parser-cache*) - (clrhash *org-parser-cache*))) - -(defun emacs-edit-write-file (file-path ast) - "Writes AST back to FILE-PATH, preserving org structure. -Clears cache after write." - (let ((org-text (emacs-edit-ast-to-org ast))) - (with-open-file (out file-path :direction :output :if-exists :supersede) - (write-string org-text out))) - (emacs-edit-clear-cache file-path) - (harness-log "EMACS-EDIT: Wrote ~a" file-path)) - -(defun emacs-edit-add-headline (ast title &key todo properties) - "Adds a new headline to AST. -Returns modified AST." - (let ((new-id (emacs-edit-generate-id)) - (new-props (list :ID new-id - :TITLE title - :TODO (or todo "TODO") - :CREATED (format nil "[~a]" - (multiple-value-bind (s mi h d mo y) - (decode-universal-time (get-universal-time)) - (format nil "~a-~a-~a ~a:~a" - y mo d h mi))))) - (merged-props (loop for (k v) on properties by #'cddr - collect k collect v))) - - (setf merged-props (append merged-props new-props)) - - (let ((new-headline (list :type :headline - :properties merged-props - :contents nil - :raw-content title))) - (push new-headline (getf ast :contents)) - ast))) - -(defun emacs-edit-find-headline-by-id (ast target-id) - "Recursively finds headline with matching :ID: property." - (when (eq (getf ast :type) :headline) - (let ((props (getf ast :properties))) - (when (string= (getf props :ID) target-id) - (return-from emacs-edit-find-headline-by-id ast)))) - - (let ((contents (getf ast :contents))) - (when contents - (dolist (child contents) - (let ((found (emacs-edit-find-headline-by-id child target-id))) - (when found (return-from emacs-edit-find-headline-by-id found)))))) - nil) - -(defun emacs-edit-find-headline-by-title (ast target-title) - "Recursively finds headline with matching title." - (when (eq (getf ast :type) :headline) - (let ((props (getf ast :properties))) - (when (string= (getf props :TITLE) target-title) - (return-from emacs-edit-find-headline-by-title ast)))) - - (let ((contents (getf ast :contents))) - (when contents - (dolist (child contents) - (let ((found (emacs-edit-find-headline-by-title child target-title))) - (when found (return-from emacs-edit-find-headline-by-title found)))))) - nil) - -(defun emacs-edit-set-property (ast target property value) - "Sets PROPERTY=VALUE on headline matching TARGET (ID or title). -Returns modified AST." - (let ((headline (if (search "id:" target) - (emacs-edit-find-headline-by-id ast target) - (emacs-edit-find-headline-by-title ast target)))) - (when headline - (setf (getf (getf headline :properties) property) value) - (harness-log "EMACS-EDIT: Set ~a=~a on ~a" property value target))) - ast) - -(defun emacs-edit-set-todo (ast target new-state) - "Sets TODO state on headline matching TARGET. -NEW-STATE should be 'TODO', 'DONE', 'IN-PROGRESS', etc." - (emacs-edit-set-property ast target :TODO new-state) - (harness-log "EMACS-EDIT: Set TODO to ~a on ~a" new-state target)) - -(defun emacs-edit-modify (file-path operation &key params) - "Main entry point for org-mode file manipulation. -OPERATIONS: - :read - Parse file to AST, return AST - :write - Write AST back to file (AST in params) - :add-headline - Add headline (params: :title, :todo, :properties) - :set-property - Set property (params: :target, :property, :value) - :set-todo - Set TODO (params: :target, :state)" - (let ((ast (emacs-edit-parse-file file-path))) - - (case operation - (:read - ast) - - (:write - (let ((ast-to-write (getf params :ast))) - (emacs-edit-write-file file-path ast-to-write))) - - (:add-headline - (let ((title (getf params :title)) - (todo (getf params :todo)) - (properties (getf params :properties))) - (emacs-edit-add-headline ast title :todo todo :properties properties))) - - (:set-property - (let ((target (getf params :target)) - (property (getf params :property)) - (value (getf params :value))) - (emacs-edit-set-property ast target property value))) - - (:set-todo - (let ((target (getf params :target)) - (state (getf params :state))) - (emacs-edit-set-todo ast target state))) - - (t - (harness-log "EMACS-EDIT ERROR: Unknown operation ~a" operation))))) - -(def-cognitive-tool :org-read - "Reads an org-mode file and parses it to structured AST. -Use this BEFORE modifying org files to understand their structure." - ((:file :type :string :description "Path to the org file")) - :body (lambda (args) - (let ((file (getf args :file))) - (if (uiop:file-exists-p file) - (emacs-edit-modify file :read) - (list :status :error :reason "File not found"))))) - -(def-cognitive-tool :org-write - "Writes previously parsed AST back to an org file. -Use this AFTER modifications to save changes." - ((:file :type :string :description "Path to the org file") - (:ast :type :list :description "The AST to write")) - :body (lambda (args) - (let ((file (getf args :file)) - (ast (getf args :ast))) - (emacs-edit-modify file :write :params (list :ast ast)) - (list :status :success :message (format nil "Wrote ~a" file))))) - -(def-cognitive-tool :org-add-headline - "Adds a new headline to an org file." - ((:file :type :string :description "Path to the org file") - (:title :type :string :description "Headline title") - (:todo :type :string :description "TODO state (default TODO)") - (:properties :type :list :description "Plist of properties")) - :body (lambda (args) - (let ((file (getf args :file)) - (title (getf args :title)) - (todo (getf args :todo "TODO")) - (properties (getf args :properties))) - (emacs-edit-modify file :add-headline - :params (list :title title :todo todo :properties properties)) - (list :status :success :message (format nil "Added headline: ~a" title))))) - -(def-cognitive-tool :org-set-property - "Sets a property on an existing headline (by ID or title)." - ((:file :type :string :description "Path to the org file") - (:target :type :string :description "Headline ID or title") - (:property :type :string :description "Property name") - (:value :type :string :description "Property value")) - :body (lambda (args) - (let ((file (getf args :file)) - (target (getf args :target)) - (property (getf args :property)) - (value (getf args :value))) - (emacs-edit-modify file :set-property - :params (list :target target :property property :value value)) - (list :status :success :message (format nil "Set ~a=~a on ~a" property value target))))) - -(def-cognitive-tool :org-set-todo - "Sets the TODO state of a headline." - ((:file :type :string :description "Path to the org file") - (:target :type :string :description "Headline ID or title") - (:state :type :string :description "New TODO state (TODO, DONE, etc)")) - :body (lambda (args) - (let ((file (getf args :file)) - (target (getf args :target)) - (state (getf args :state))) - (emacs-edit-modify file :set-todo - :params (list :target target :state state)) - (list :status :success :message (format nil "Set ~a to ~a" target state))))) diff --git a/skills/org-skill-engineering-standards.lisp b/skills/org-skill-engineering-standards.lisp deleted file mode 100644 index 95e2b25..0000000 --- a/skills/org-skill-engineering-standards.lisp +++ /dev/null @@ -1,92 +0,0 @@ -(in-package :opencortex) - -(defvar *engineering-std-*project-root* nil - "Path to the project root for enforcement checks.") - -(defun engineering-std-set-project-root (path) - (setf *engineering-std-*project-root* (uiop:ensure-directory-pathname path))) - -(defstruct engineering-violation - (phase nil) - (rule nil) - (message nil) - (severity nil)) - -(defvar *enforcement-rules* - '((:pre-task - (:git-clean "Working tree must be clean before modifications") - (:skill-queried "Skill catalog should be queried before analysis")) - (:during-task - (:org-only "Only .org files may be edited; .lisp is generated") - (:one-per-block "One definition per src block") - (:prose-required "Every block must have preceding prose")) - (:post-task - (:tests-pass "All tests must pass") - (:no-artifacts "No orphaned .bak, .log, .tmp files")))) - -(defun verify-git-clean-p (&optional (dir *engineering-std-*project-root*)) - "Returns T if the git repository at DIR has no uncommitted changes." - (when dir - (let ((status (uiop:run-program (list "git" "-C" (namestring dir) "status" "--porcelain") - :output :string - :ignore-error-status t))) - (string= "" (string-trim '(#\Space #\Newline #\Tab) status))))) - -(defun check-git-clean (&optional (dir *engineering-std-*project-root*)) - "Returns violation if git is dirty, nil if clean." - (unless (verify-git-clean-p dir) - (make-engineering-violation - :phase :pre-task - :rule :git-clean - :message "ENGINEERING STANDARDS VIOLATION: Working tree is dirty. Commit changes before modifying files." - :severity :blocker))) - -(defun engineering-standards-gate (action context) - "The deterministic HARD BLOCK gate for Engineering Standards. - - BLOCKING checks (return :LOG on violation): - - Git tree must be clean before file modifications - - WARNING checks (log only): - - Skill catalog should be queried first - - Returns modified action, or :LOG/:EVENT on violation." - (let* ((payload (getf action :payload)) - (tool (getf payload :tool)) - (file (getf payload :file)) - (code (getf payload :code)) - (modifies-files-p (or file code tool))) - - ;; BLOCKING: Git clean required for file modifications - (when modifies-files-p - (let ((git-check (check-git-clean *engineering-std-*project-root*))) - (when git-check - (harness-log "~a" (engineering-violation-message git-check)) - (return-from engineering-standards-gate - (list :type :log - :payload (list :text (engineering-violation-message git-check))))))) - - action)) - -(defskill :skill-engineering-standards - :priority 1000 - :trigger (lambda (ctx) - (declare (ignore ctx)) - t) - :probabilistic nil - :deterministic #'engineering-standards-gate) - -(defvar *engineering-std-initialized* nil) - -(defun engineering-std-init () - "Initialize the enforcement system with project root." - (unless *engineering-std-initialized* - (let ((env-root (or (uiop:getenv "OPENCORTEX_ROOT") - (uiop:getenv "MEMEX_DIR") - "/home/user/memex/projects/opencortex"))) - (engineering-std-set-project-root env-root) - (setf *engineering-std-initialized* t) - (harness-log "ENGINEERING STANDARDS: Initialized with root ~a" *engineering-std-*project-root*)))) - -;; Auto-initialize on load -(engineering-std-init) diff --git a/skills/org-skill-gardener.lisp b/skills/org-skill-gardener.lisp deleted file mode 100644 index 4339cf0..0000000 --- a/skills/org-skill-gardener.lisp +++ /dev/null @@ -1,68 +0,0 @@ -(in-package :opencortex) - -(defvar *gardener-last-audit* 0 - "The universal-time of the last full Memex audit.") - -(defun gardener-find-broken-links () - "Returns a list of broken ID links found in the Memex." - (let ((broken nil)) - (maphash (lambda (id obj) - (let ((content (org-object-content obj))) - (when content - (cl-ppcre:do-register-groups (target-id) ("id:([A-Za-z0-9-]+)" content) - (unless (lookup-object target-id) - (push (list :source id :broken-target target-id) broken)))))) - *memory*) - broken)) - -(defun gardener-find-orphans () - "Returns a list of IDs for headlines that are structurally isolated." - (let ((inbound (make-hash-table :test 'equal)) - (outbound (make-hash-table :test 'equal)) - (orphans nil)) - ;; 1. Map all connections - (maphash (lambda (id obj) - (let ((content (org-object-content obj))) - (when content - (cl-ppcre:do-register-groups (target-id) ("id:([A-Za-z0-9-]+)" content) - (setf (gethash id outbound) t) - (setf (gethash target-id inbound) t))))) - *memory*) - ;; 2. Identify nodes with zero connections - (maphash (lambda (id obj) - (declare (ignore obj)) - (unless (or (gethash id inbound) (gethash id outbound)) - (push id orphans))) - *memory*) - orphans)) - -(defun gardener-deterministic-gate (action context) - "Main gate for the Gardener skill. Audits graph integrity." - (declare (ignore action context)) - (let ((broken (gardener-find-broken-links)) - (orphans (gardener-find-orphans))) - - (when (or broken orphans) - (harness-log "GARDENER: Audit found ~a broken links and ~a orphans." - (length broken) (length orphans)) - - (dolist (link broken) - (harness-log " [BROKEN LINK] Node ~a -> ~a" (getf link :source) (getf link :broken-target))) - - (dolist (orphan orphans) - (harness-log " [ORPHAN] Node ~a is isolated." orphan))) - - (setf *gardener-last-audit* (get-universal-time)) - ;; Return a log to stop the loop - (list :type :LOG :payload (list :text "Gardener audit complete.")))) - -(defskill :skill-gardener - :priority 40 - :trigger (lambda (ctx) - (let* ((payload (getf ctx :payload)) - (sensor (getf payload :sensor))) - (and (eq sensor :heartbeat) - ;; Only audit once per day - (> (- (get-universal-time) *gardener-last-audit*) 86400)))) - :probabilistic nil - :deterministic #'gardener-deterministic-gate) diff --git a/skills/org-skill-homoiconic-memory.lisp b/skills/org-skill-homoiconic-memory.lisp deleted file mode 100644 index 10899de..0000000 --- a/skills/org-skill-homoiconic-memory.lisp +++ /dev/null @@ -1,28 +0,0 @@ -(defun memory-org-to-json (source) - "Converts Org-mode source to JSON AST." - (declare (ignore source)) - "") - -(defun memory-json-to-org (ast) - "Converts JSON AST back to Org-mode text." - (declare (ignore ast)) - "") - -(defun memory-normalize-ast (ast) - "Recursively ensures ID uniqueness across the AST." - (declare (ignore ast)) - nil) - -(defun make-memory-node (headline &key content properties children) - "Constructor for a normalized Org node alist." - (declare (ignore headline)) - (list :TYPE :HEADLINE - :PROPERTIES (or properties nil) - :CONTENT content - :CONTENTS children)) - -(defskill :skill-homoiconic-memory - :priority 100 - :trigger (lambda (ctx) (declare (ignore ctx)) nil) - :probabilistic nil - :deterministic (lambda (action ctx) (declare (ignore ctx)) action)) diff --git a/skills/org-skill-lisp-utils.lisp b/skills/org-skill-lisp-utils.lisp deleted file mode 100644 index 6e4af76..0000000 --- a/skills/org-skill-lisp-utils.lisp +++ /dev/null @@ -1,289 +0,0 @@ -(in-package :opencortex) - -(defun count-char (char string) - "Counts occurrences of CHAR in STRING. -Returns an integer count." - (let ((count 0)) - (loop for c across string - when (char= c char) - do (incf count)) - count)) - -(defun deterministic-repair (code) - "Attempts instant fixes on broken Lisp code (e.g., balancing parens). -Returns the fixed code string." - (let* ((open-parens (count-char #\( code)) - (close-parens (count-char #\) code)) - (diff (- open-parens close-parens))) - (if (> diff 0) - (concatenate 'string code (make-string diff :initial-element #\))) - code))) - -(defun neural-repair (code error-message) - "Uses the Probabilistic Engine to deeply repair the syntax structure. -Returns the fixed code string." - (let ((prompt (format nil "The following Lisp code failed to parse. -ERROR: ~a -CODE: ~a -MANDATE: Output EXACTLY ONE valid Common Lisp list. Do not explain. Do not use markdown blocks." - error-message code)) - (system-prompt "You are a Lisp Syntax Repair Actuator. Return only valid, balanced Lisp code.")) - (let ((repaired (ask-probabilistic prompt :system-prompt system-prompt))) - (string-trim '(#\Space #\Newline #\Tab) repaired)))) - -(defun lisp-utils-check-structural (code-string) - "Checks for balanced parens, brackets, and terminated strings. -Returns (VALUES t nil) if clean, or (VALUES nil reason-string line col)." - (let ((stack nil) - (in-string nil) - (escaped nil) - (line 1) - (col 0) - (last-open-line 1) - (last-open-col 0)) - (dotimes (i (length code-string)) - (let ((ch (char code-string i))) - (cond (escaped (setf escaped nil)) - ((char= ch #\\) (setf escaped t)) - (in-string - (when (char= ch #\") (setf in-string nil))) - ((char= ch #\;) - (loop while (and (< i (1- (length code-string))) - (not (char= (char code-string (1+ i)) #\Newline))) - do (incf i)) - (incf line) (setf col 0)) - ((char= ch #\") - (setf in-string t)) - ((member ch '(#\( #\[)) - (push (list (string ch) line col) stack) - (setf last-open-line line last-open-col col)) - ((char= ch #\)) - (cond ((null stack) - (return-from lisp-utils-check-structural - (values nil (format nil "Unexpected ')' at line ~a, col ~a" line col) line col))) - ((string= (caar stack) "[") - (return-from lisp-utils-check-structural - (values nil (format nil "Mismatched ']' expected at line ~a, col ~a" line col) line col))) - (t (pop stack)))) - ((char= ch #\]) - (cond ((null stack) - (return-from lisp-utils-check-structural - (values nil (format nil "Unexpected ']' at line ~a, col ~a" line col) line col))) - ((string= (caar stack) "(") - (return-from lisp-utils-check-structural - (values nil (format nil "Mismatched ')' expected at line ~a, col ~a" line col) line col))) - (t (pop stack)))) - ((char= ch #\Newline) - (incf line) (setf col 0))) - (unless (char= ch #\Newline) (incf col)))) - (if (null stack) - (values t nil nil nil) - (values nil (format nil "Unbalanced '~a' opened at line ~a, col ~a" - (caar stack) last-open-line last-open-col) - last-open-line last-open-col)))) - -(defun lisp-utils-check-syntactic (code-string) - "Checks if the code can be read by SBCL with *read-eval* nil. -Returns (VALUES t nil) if clean, or (VALUES nil error-message nil nil)." - (handler-case - (let ((*read-eval* nil)) - (with-input-from-string (stream (format nil "(progn ~a)" code-string)) - (loop for form = (read stream nil :eof) until (eq form :eof))) - (values t nil nil nil)) - (error (c) - (let ((msg (format nil "~a" c))) - (values nil msg nil nil))))) - -(defparameter *lisp-utils-whitelist* - '(;; Math & Logic - + - * / = < > <= >= 1+ 1- min max mod abs floor ceiling round - and or not null eq eql equal string= string-equal char= char-equal - ;; List Manipulation - list cons car cdr cadr cddr cdar caar caddr cdddr append mapcar remove-if remove-if-not - length reverse sort nth nthcdr push pop last butlast subseq - ;; Plists, Alists, and Hash Tables - getf gethash assoc acons pairlis rassoc - ;; Control Flow - let let* if cond when unless case typecase prog1 progn - ;; Strings - format concatenate string-downcase string-upcase search subseq replace - ;; Type predicates - stringp numberp integerp listp symbolp keywordp null - ;; Kernel safe symbols - opencortex::harness-log - opencortex::snapshot-memory opencortex::rollback-memory - opencortex::lookup-object opencortex::list-objects-by-type - opencortex::ingest-ast opencortex::find-headline-missing-id - opencortex::context-query-store opencortex::context-get-active-projects - opencortex::context-get-recent-completed-tasks opencortex::context-list-all-skills - opencortex::context-get-system-logs opencortex::context-assemble-global-awareness - opencortex::org-object-id opencortex::org-object-type opencortex::org-object-attributes - opencortex::org-object-content opencortex::org-object-parent-id - opencortex::org-object-children opencortex::org-object-version - opencortex::org-object-last-sync opencortex::org-object-hash - opencortex::org-object-vector - ;; Essential macros and special operators - declare ignore quote function lambda defun defvar defparameter defmacro - ;; Safe I/O - with-open-file write-string read-line - ;; Package introspection - find-package make-package in-package do-external-symbols find-symbol - ;; Safe system interaction - uiop:run-program uiop:getenv uiop:merge-pathnames* uiop:file-exists-p - uiop:directory-exists-p uiop:read-file-string uiop:split-string - ;; Time - get-universal-time get-internal-real-time sleep - ;; Equality - equalp = equal eq eql) - "Static whitelist of symbols permitted in the Lisp Utils sandbox.") - -(defun lisp-utils-ast-walk (form) - "Recursively walks the Lisp AST. Returns T if safe, NIL if unsafe." - (cond - ((or (stringp form) (numberp form) (keywordp form) (characterp form)) t) - ((symbolp form) - (or (member form *lisp-utils-whitelist* :test #'string-equal) - (member (format nil "~a" form) *lisp-utils-whitelist* :test #'string-equal))) - ((listp form) - (let ((head (car form))) - (cond - ((eq head 'quote) t) - ((not (symbolp head)) nil) - ((member head *lisp-utils-whitelist* :test #'string-equal) - (every #'lisp-utils-ast-walk (cdr form))) - (t - (harness-log "LISP UTILS: Blocked call to non-whitelisted function ~a" head) - nil)))) - (t nil))) - -(defun lisp-utils-check-semantic (code-string) - "Checks if all symbols in CODE-STRING are whitelisted. -Returns (VALUES t nil) if clean, or (VALUES nil reason-string nil nil)." - (handler-case - (let ((*read-eval* nil)) - (with-input-from-string (stream (format nil "(progn ~a)" code-string)) - (loop for form = (read stream nil :eof) - until (eq form :eof) - do (unless (lisp-utils-ast-walk form) - (return-from lisp-utils-check-semantic - (values nil "Code contains non-whitelisted symbols." nil nil))))) - (values t nil nil nil)) - (error (c) - (values nil (format nil "Semantic check failed: ~a" c) nil nil)))) - -(defun lisp-utils-validate (code-string &key strict) - "Validates Lisp code through structural, syntactic, and optional semantic checks. -Returns a plist: - (:status :success :checks (:structural t :syntactic t :semantic t)) -or - (:status :error :failed :reason :line :col ) - -When STRICT is non-nil, the semantic whitelist check is enforced." - (let ((structural-ok nil) (syntactic-ok nil) (semantic-ok nil) - (reason nil) (line nil) (col nil)) - ;; Phase 1: Structural - (multiple-value-setq (structural-ok reason line col) - (lisp-utils-check-structural code-string)) - (unless structural-ok - (return-from lisp-utils-validate - (list :status :error :failed :structural :reason reason :line line :col col))) - ;; Phase 2: Syntactic - (multiple-value-setq (syntactic-ok reason line col) - (lisp-utils-check-syntactic code-string)) - (unless syntactic-ok - (return-from lisp-utils-validate - (list :status :error :failed :syntactic :reason reason :line line :col col))) - ;; Phase 3: Semantic (only when strict) - (when strict - (multiple-value-setq (semantic-ok reason line col) - (lisp-utils-check-semantic code-string)) - (unless semantic-ok - (return-from lisp-utils-validate - (list :status :error :failed :semantic :reason reason :line line :col col)))) - ;; All clear - (list :status :success - :checks (list :structural t :syntactic t :semantic (or (not strict) semantic-ok))))) - -(def-cognitive-tool :validate-lisp - "Deterministically validates Lisp code for structural, syntactic, and semantic correctness. -Use this BEFORE declaring any Lisp code edit complete." - ((:code :type :string :description "The Lisp code string to validate.") - (:strict :type :boolean :description "If non-nil, enforces the semantic whitelist.")) - :body (lambda (args) - (let ((code (getf args :code)) - (strict (getf args :strict))) - (if (and code (stringp code)) - (lisp-utils-validate code :strict strict) - (list :status :error :reason "Missing :code argument."))))) - -(def-cognitive-tool :repair-lisp - "Repairs broken Lisp code using deterministic first, then neural escalation." - ((:code :type :string :description "The broken Lisp code string") - (:error :type :string :description "The error message from parsing failure")) - :body (lambda (args) - (let ((code (getf args :code)) - (error-msg (getf args :error))) - (if (and code error-msg) - (let ((fast-fix (deterministic-repair code))) - (handler-case - (let ((repaired (read-from-string fast-fix))) - (format nil "~a" repaired)) - (error () - (let ((deep-fix (neural-repair code error-msg))) - (handler-case - (let ((repaired (read-from-string deep-fix))) - (format nil "~a" repaired)) - (error () - "REPAIR FAILED")))))) - (list :status :error :reason "Missing :code or :error argument."))))) - -(defskill :skill-lisp-repair - :priority 90 - :trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :syntax-error)) - :probabilistic nil - :deterministic (lambda (action context) - (declare (ignore action)) - (let* ((payload (getf context :payload)) - (code (getf payload :code)) - (error-msg (getf payload :error))) - (harness-log "LISP REPAIR: Reacting to syntax error...") - (let ((fast-fix (deterministic-repair code))) - (handler-case - (let ((repaired (read-from-string fast-fix))) - (harness-log "LISP REPAIR: Deterministic repair SUCCESS.") - repaired) - (error () - (harness-log "LISP REPAIR: Deterministic failed. Escalating to neural...") - (let ((deep-fix (neural-repair code error-msg))) - (handler-case - (let ((repaired (read-from-string deep-fix))) - (harness-log "LISP REPAIR: Neural repair SUCCESS.") - repaired) - (error () - (harness-log "LISP REPAIR: Neural repair failed.") - (list :type :LOG :payload (list :text "Lisp Repair Failed."))))))))))) - -(defskill :skill-lisp-validator - :priority 900 - :trigger (lambda (ctx) - (let ((candidate (getf ctx :approved-action))) - (when candidate - (let ((payload (getf candidate :payload))) - (member (getf payload :action) '(:eval :shell)))))) - :probabilistic nil - :deterministic (lambda (action context) - (declare (ignore context)) - (let ((payload (getf action :payload))) - (if (eq (getf payload :action) :eval) - (let* ((code (getf payload :code)) - (result (lisp-utils-validate code :strict t))) - (if (eq (getf result :status) :error) - (progn - (harness-log "LISP VALIDATOR: Blocked unsafe :eval action. ~a" - (getf result :reason)) - (list :type :LOG - :payload (list :level :error - :text (format nil "LISP VALIDATOR: Blocked unsafe eval. ~a" - (getf result :reason))))) - action)) - action)))) diff --git a/skills/org-skill-lisp-validator.lisp b/skills/org-skill-lisp-validator.lisp deleted file mode 100644 index bee8e23..0000000 --- a/skills/org-skill-lisp-validator.lisp +++ /dev/null @@ -1,125 +0,0 @@ - - -(defparameter *lisp-validator-whitelist* - '(;; Math & Logic - + - * / = < > <= >= 1+ 1- min max - and or not null eq eql equal string= string-equal - ;; List Manipulation - list cons car cdr cadr cddr cdar caar append mapcar remove-if remove-if-not - length reverse sort nth nthcdr push pop - ;; Plists and Hash Tables - getf gethash - ;; Control Flow - let let* if cond when unless case typecase - ;; Strings - format concatenate string-downcase string-upcase search - ;; Kernel specifics - opencortex::harness-log - opencortex::snapshot-memory - opencortex::rollback-memory - opencortex::lookup-object - opencortex::list-objects-by-type - opencortex::ingest-ast - opencortex::find-headline-missing-id - opencortex::context-query-store - opencortex::context-get-active-projects - opencortex::context-get-recent-completed-tasks - opencortex::context-list-all-skills - opencortex::context-get-system-logs - opencortex::context-assemble-global-awareness - opencortex::org-object-id - opencortex::org-object-type - opencortex::org-object-attributes - opencortex::org-object-content - opencortex::org-object-parent-id - opencortex::org-object-children - opencortex::org-object-version - opencortex::org-object-last-sync - opencortex::org-object-hash - ;; Essential macros - declare ignore - ;; Let's also add simple data types - t nil quote function)) - -(defvar *lisp-validator-registry* nil - "List of dynamically registered safe symbols.") - -(defun lisp-validator-register (symbols) - "Adds symbols to the global validator registry." - (setf *lisp-validator-registry* (append *lisp-validator-registry* (if (listp symbols) symbols (list symbols)))) - (harness-log "LISP VALIDATOR: Registered ~a new safe symbols." (length (if (listp symbols) symbols (list symbols))))) - -(defun lisp-validator-is-safe (symbol) - "Checks if a symbol is in the static whitelist or the dynamic registry." - (or (member symbol *lisp-validator-whitelist* :test #'string-equal) - (member symbol *lisp-validator-registry* :test #'string-equal))) - -(defun lisp-validator-ast-walk (form) - "Recursively walks the Lisp AST. Returns T if safe, NIL if unsafe." - (cond - ;; Self-evaluating objects (strings, numbers, keywords) are safe. - ((or (stringp form) (numberp form) (keywordp form) (characterp form)) - t) - ;; Symbols used as variables (in non-function position) - ((symbolp form) - (lisp-validator-is-safe form)) - ;; Lists represent function calls or special forms. - ((listp form) - (let ((head (car form))) - (cond - ((eq head 'quote) t) - ((not (symbolp head)) nil) - ((lisp-validator-is-safe head) - (every #'lisp-validator-ast-walk (cdr form))) - (t - (harness-log "LISP VALIDATOR: Blocked call to non-whitelisted function ~a" head) - nil)))) - (t nil))) - -(opencortex:def-cognitive-tool :lisp-validator-status "Returns validator-related telemetry, including blocked actions and harness status." - nil - :body (lambda (args) - (declare (ignore args)) - (format nil "LISP VALIDATOR STATUS: -- Static Whitelist: ~a symbols -- Dynamic Registry: ~a symbols -- Total Blocked Actions: ~a" - (length *lisp-validator-whitelist*) - (length *lisp-validator-registry*) - "Not implemented"))) - -(opencortex:defskill :skill-lisp-validator - :priority 900 ; High priority, before most skills - :trigger (lambda (ctx) - ;; Check if any proposed action is an :eval or :shell call - (let ((candidate (getf ctx :candidate))) - (when candidate - (let ((payload (getf candidate :payload))) - (member (getf payload :action) '(:eval :shell)))))) - :probabilistic nil ; Purely deterministic/safety skill - :deterministic (lambda (action context) - (harness-log "DETERMINISTIC ENGINE [Lisp-Validator]: Intercepted critical action for structural validation.") - action)) - -(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.") -(in-suite lisp-validator-suite) - -(test test-basic-math-safe - (is (opencortex:lisp-validator-validate "(+ 1 2)"))) - -(test test-blocked-eval - (is (not (opencortex:lisp-validator-validate "(eval '(+ 1 2))")))) - -(test test-blocked-shell - (is (not (opencortex:lisp-validator-validate "(uiop:run-program \"ls\")")))) - -(test test-nested-unsafe - (is (not (opencortex:lisp-validator-validate "(let ((x 1)) (delete-file \"test.txt\"))")))) - -(test test-safe-kernel-api - (is (opencortex:lisp-validator-validate "(opencortex::lookup-object \"node-1\")"))) diff --git a/skills/org-skill-literate-programming.lisp b/skills/org-skill-literate-programming.lisp deleted file mode 100644 index 38898ae..0000000 --- a/skills/org-skill-literate-programming.lisp +++ /dev/null @@ -1,155 +0,0 @@ -(in-package :opencortex) - -(defun literate-check-block-balance (code-string) - "Returns T if CODE-STRING has balanced parentheses, brackets, and strings. - - Ignores comments (after ;) and tracks string contents to avoid - counting parens inside string literals." - (let ((depth 0) (in-string nil) (escaped nil)) - (dotimes (i (length code-string)) - (let ((ch (char code-string i))) - (cond - ;; Escape handling (affects next char only) - (escaped (setf escaped nil)) - ((char= ch #\\) (setf escaped t)) - ;; String boundaries - (in-string (when (char= ch #\") (setf in-string nil))) - ((char= ch #\") (setf in-string t)) - ;; Comment boundaries (skip to end of line) - ((char= ch #\;) - (loop while (and (< i (1- (length code-string))) - (not (char= (char code-string (1+ i)) #\Newline))) - do (incf i))) - ;; Structural parens - ((member ch '(#\( #\[)) (incf depth)) - ((member ch '(#\) #\])) - (if (<= depth 0) - (return-from literate-check-block-balance - (values nil (format nil "Unexpected close paren at position ~a" i))) - (decf depth)))))) - (if (zerop depth) - t - (values nil (format nil "Unbalanced parens: depth ~a at end of string" depth))))) - -(defun literate-audit-org-file (filepath) - "Audits all tangled lisp blocks in an Org file for structural balance. - - Returns a list of imbalance reports, or NIL if all blocks are balanced." - (let* ((content (with-open-file (s filepath) - (let ((seq (make-string (file-length s)))) - (read-sequence seq s) - seq))) - (idx 0) - (reports nil) - (block-num 0)) - (loop - (let ((pos (search "#+begin_src lisp" content :start2 idx :test #'string-equal))) - (when (null pos) (return (nreverse reports))) - (let* ((eol (or (position #\Newline content :start pos) (length content))) - (header (subseq content pos eol)) - (header-lower (string-downcase header)) - (tangle-p (and (search ".lisp" header-lower) - (not (search ":tangle no" header-lower))))) - (if (not tangle-p) - (setf idx (1+ eol)) - (let ((end-pos (search "#+end_src" content :start2 eol :test #'string-equal))) - (if (null end-pos) - (progn - (push (list :block (incf block-num) :status :missing-end-src) reports) - (return (nreverse reports))) - (let ((raw-block (subseq content (1+ eol) end-pos)) - (clean-lines nil)) - ;; Strip PROPERTIES drawers and :END: markers - (dolist (line (uiop:split-string raw-block :separator '(#\Newline))) - (let ((trimmed (string-trim '(#\Space #\Tab #\Return) line))) - (when (and (plusp (length trimmed)) - (not (string= (subseq trimmed 0 (min 12 (length trimmed))) ":PROPERTIES:")) - (not (string= (subseq trimmed 0 (min 5 (length trimmed))) ":END:"))) - (push line clean-lines)))) - (let ((code (format nil "~{~a~^~%~}" (nreverse clean-lines)))) - (multiple-value-bind (ok reason) (literate-check-block-balance code) - (unless ok - (push (list :block (incf block-num) - :status :unbalanced - :reason reason - :code code) - reports)))) - (setf idx (+ end-pos 9))))))))))) - -(defvar *tangle-targets* - '(("skills/org-skill-engineering-standards.org" . "library/gen/org-skill-engineering-standards.lisp") - ("skills/org-skill-literate-programming.org" . "library/gen/org-skill-literate-programming.lisp") - ("harness/memory.org" . "library/memory.lisp") - ("harness/loop.org" . "library/loop.lisp") - ("harness/perceive.org" . "library/perceive.lisp") - ("harness/reason.org" . "library/reason.lisp") - ("harness/act.org" . "library/act.lisp") - ("harness/skills.org" . "library/skills.lisp") - ("harness/communication.org" . "library/communication.lisp"))) - -(defvar *lp-project-root* nil) - -(defun lp-set-project-root (path) - (setf *lp-project-root* (uiop:ensure-directory-pathname path))) - -(defun check-tangle-sync (&optional (root *lp-project-root*)) - "Returns violation if any tangled .lisp file is newer than its Org source. - -This detects direct .lisp edits (which violate the LP workflow)." - (when root - (dolist (pair *tangle-targets*) - (let* ((org-file (merge-pathnames (car pair) root)) - (lisp-file (merge-pathnames (cdr pair) root)) - (org-time (ignore-errors (file-write-date org-file))) - (lisp-time (ignore-errors (file-write-date lisp-file)))) - (when (and org-time lisp-time (> lisp-time org-time)) - (return-from check-tangle-sync - (list :type :log - :payload (list :text (format nil "LITERATE PROGRAMMING VIOLATION: ~a is newer than ~a. Edit Org source, not .lisp directly." - (file-namestring lisp-file) (file-namestring org-file))))))))) - nil) - -(defskill :skill-literate-programming - :priority 1100 - :trigger (lambda (ctx) - (declare (ignore ctx)) - t) - :probabilistic nil - :deterministic (lambda (action context) - (declare (ignore context)) - (block skill-literate-programming - ;; Check tangle sync before any file modification - (let ((file (and (listp action) (getf action :payload) (getf (getf action :payload) :file)))) - (when file - (let ((tangle-check (check-tangle-sync *lp-project-root*))) - (when tangle-check - (return-from skill-literate-programming - (progn - (harness-log "~a" (getf (getf tangle-check :payload) :text)) - tangle-check)))))) - ;; Audit org files for structural balance - (when (and (listp action) - (stringp (getf action :file))) - (let ((file (getf action :file))) - (when (and (search ".org" file) - (search "skill" file :test #'string-equal)) - (let ((issues (literate-audit-org-file file))) - (when issues - (harness-log "LITERATE PROGRAMMING: Structural issues found in ~a: ~a" - file issues)))))) - action))) - -(defvar *lp-initialized* nil) - -(defun lp-init () - "Initialize the LP system with project root." - (unless *lp-initialized* - (let ((env-root (or (uiop:getenv "OPENCORTEX_ROOT") - (uiop:getenv "MEMEX_DIR") - "/home/user/memex/projects/opencortex"))) - (lp-set-project-root env-root) - (setf *lp-initialized* t) - (harness-log "LITERATE PROGRAMMING: Initialized with root ~a" *lp-project-root*)))) - -;; Auto-initialize on load -(lp-init) diff --git a/skills/org-skill-llama-backend.lisp b/skills/org-skill-llama-backend.lisp deleted file mode 100644 index c25454f..0000000 --- a/skills/org-skill-llama-backend.lisp +++ /dev/null @@ -1,33 +0,0 @@ -(in-package :opencortex) - -(defun llama-inference (prompt system-prompt &key (model "local-model")) - "Sends a completion request to the local llama.cpp server." - (let ((endpoint (uiop:getenv "LLAMACPP_ENDPOINT"))) - (unless endpoint - (harness-log "LLAMA ERROR: LLAMACPP_ENDPOINT not set in environment.") - (return-from llama-inference (list :error "LLAMACPP_ENDPOINT_MISSING"))) - - (handler-case - (let* ((full-prompt (format nil "System: ~a~%User: ~a~%Assistant:" system-prompt prompt)) - (payload (cl-json:encode-json-to-string - `((:prompt . ,full-prompt) - (:n_predict . 1024) - (:stop . ("User:" "System:"))))) - (response (dex:post (format nil "~a/completion" endpoint) - :content payload - :headers '(("Content-Type" . "application/json")))) - (data (cl-json:decode-json-from-string response))) - (cdr (assoc :content data))) - (error (c) - (harness-log "LLAMA ERROR: Connection failed -> ~a" c) - (list :error (format nil "~a" c)))))) - -(progn - (register-probabilistic-backend :llama #'llama-inference) - (harness-log "LLAMA: Local backend registered and active.")) - -(defskill :skill-llama-backend - :priority 50 - :trigger (lambda (ctx) (declare (ignore ctx)) nil) ; Pure infrastructure skill - :probabilistic nil - :deterministic (lambda (action ctx) (declare (ignore ctx)) action)) diff --git a/skills/org-skill-llm-gateway.lisp b/skills/org-skill-llm-gateway.lisp deleted file mode 100644 index f7d3c9b..0000000 --- a/skills/org-skill-llm-gateway.lisp +++ /dev/null @@ -1,128 +0,0 @@ -(defun get-nested (alist &rest keys) - "Recursively extracts nested values from an alist, handling both objects and arrays." - (let ((val alist)) - (dolist (k keys) - ;; Descend into arrays (cl-json style: ((key . val)) or ( ( (key . val) ) )) - (loop while (and (listp val) (listp (car val)) (not (keywordp (caar val)))) - do (setf val (car val))) - (let ((pair (or (assoc k val) - (assoc (intern (string-upcase (string k)) :keyword) val) - (assoc (intern (string-downcase (string k)) :keyword) val)))) - (if pair - (setf val (cdr pair)) - (return-from get-nested nil)))) - val)) - -(defun execute-llm-request (prompt system-prompt &key provider model) - "Unified entry point for all LLM providers. Respects the global cascade." - (let* ((active-provider (or provider (car opencortex::*provider-cascade*) :openrouter)) - (api-key (vault-get-secret active-provider :type :api-key)) - (full-prompt (format nil "~a~%~%Prompt: ~a" system-prompt prompt))) - - (harness-log "PROBABILISTIC ENGINE: Requesting ~a (Model: ~s)" - active-provider (or model "default")) - - ;; If the specifically requested provider has no key, try falling back to the cascade - (when (or (null api-key) (string= api-key "")) - (harness-log "GATEWAY: Provider ~a has no key. Cascade fallback would trigger here." active-provider) - (return-from execute-llm-request (list :status :error :message "API Key missing."))) - - (case active-provider - (:gemini-web - (let ((res (uiop:symbol-call :opencortex.skills.org-skill-web-research :ask-gemini-web full-prompt))) - (if res (list :status :success :content res) (list :status :error :message "Web Research Failure")))) - - (:ollama - (let* ((host (or (uiop:getenv "OLLAMA_HOST") "localhost:11434")) - (url (format nil "http://~a/api/generate" host)) - (body (cl-json:encode-json-to-string `((model . ,(or model "llama3")) (prompt . ,full-prompt) (stream . :false))))) - (handler-case - (progn - (harness-log "LLM DEBUG: Requesting Ollama...") - (let* ((response (dex:post url :headers '(("Content-Type" . "application/json")) :content body :connect-timeout 5 :read-timeout 60)) - (json (cl-json:decode-json-from-string response))) - (list :status :success :content (cdr (assoc :response json))))) - (error (c) (list :status :error :message (format nil "Ollama Failure: ~a" c)))))) - - (t ;; Cloud Providers (Anthropic, Gemini API, Groq, OpenAI, OpenRouter) - (let* ((endpoint (case active-provider - (:anthropic "https://api.anthropic.com/v1/messages") - (:gemini-api (format nil "https://generativelanguage.googleapis.com/v1/models/~a:generateContent" (or model "gemini-1.5-flash-latest"))) - (:groq "https://api.groq.com/openai/v1/chat/completions") - (:openai "https://api.openai.com/v1/chat/completions") - (:openrouter "https://openrouter.ai/api/v1/chat/completions"))) - (headers (case active-provider - (:anthropic `(("Content-Type" . "application/json") ("x-api-key" . ,api-key) ("anthropic-version" . "2023-06-01"))) - (:gemini-api `(("Content-Type" . "application/json") ("x-goog-api-key" . ,api-key))) - (:openrouter `(("Content-Type" . "application/json") ("Authorization" . ,(format nil "Bearer ~a" api-key)) - ("HTTP-Referer" . "https://github.com/amr/opencortex") ("X-Title" . "opencortex Autonomous Kernel"))) - (t `(("Content-Type" . "application/json") ("Authorization" . ,(format nil "Bearer ~a" api-key)))))) - (body (case active-provider - (:anthropic (cl-json:encode-json-to-string `((model . ,(or model "claude-3-5-sonnet-20240620")) (max_tokens . 4096) (system . ,system-prompt) (messages . (( (role . "user") (content . ,prompt) )))))) - (:gemini-api (cl-json:encode-json-to-string `((contents . (((parts . (((text . ,full-prompt)))))))))) - (t (cl-json:encode-json-to-string `((model . ,(or model (case active-provider (:groq "llama-3.3-70b-versatile") (t "google/gemini-2.0-flash-001")))) - (messages . (( (role . "system") (content . ,system-prompt) ) ( (role . "user") (content . ,prompt) ))))))))) - (handler-case - (progn - (harness-log "LLM DEBUG: Requesting ~a..." active-provider) - (let* ((response (dex:post endpoint :headers headers :content body :connect-timeout 10 :read-timeout 30)) - (json (cl-json:decode-json-from-string response))) - (let ((content (case active-provider - (:anthropic (get-nested json :content :text)) - (:gemini-api (get-nested json :candidates :parts :text)) - (t (get-nested json :choices :message :content))))) - (if content - (list :status :success :content content) - (list :status :error :message (format nil "Failed to parse ~a response structure." active-provider)))))) - (error (c) (list :status :error :message (format nil "LLM Gateway Failure (~a): ~a" active-provider c))))))))) - -;; Initialize Cascade -(let* ((env-cascade (uiop:getenv "PROVIDER_CASCADE")) - (default-list '(:openrouter :openai :anthropic :groq :gemini-api :ollama)) - (final-list (if (and env-cascade (not (string= env-cascade ""))) - (mapcar (lambda (s) (intern (string-upcase (string-trim '(#\Space) s)) :keyword)) - (uiop:split-string env-cascade :separator '(#\,))) - default-list))) - (setf opencortex::*provider-cascade* final-list) - (opencortex:harness-log "PROBABILISTIC: Neural Cascade Initialized -> ~a" final-list)) - -;; Register Providers -(dolist (p '(:anthropic :gemini-api :gemini-web :groq :ollama :openrouter :openai)) - (opencortex:register-probabilistic-backend p (lambda (prompt system-prompt &key model) - (execute-llm-request prompt system-prompt :provider p :model model)))) - -(def-cognitive-tool :get-ollama-embedding - "Generates vector embeddings via Ollama API for semantic search." - ((text :type :string :description "Text to embed.")) - :body (lambda (args) - (let* ((text (getf args :text)) - (host (or (uiop:getenv "OLLAMA_HOST") "localhost:11434")) - (url (format nil "http://~a/api/embeddings" host)) - (model (or (uiop:getenv "OLLAMA_EMBEDDING_MODEL") "nomic-embed-text")) - (body (cl-json:encode-json-to-string `((model . ,model) (prompt . ,text))))) - (handler-case - (let* ((response (dex:post url :headers '(("Content-Type" . "application/json")) :content body :connect-timeout 5 :read-timeout 30)) - (json (cl-json:decode-json-from-string response))) - (let ((embedding (cdr (assoc :embedding json)))) - (if embedding - (list :status :success :vector embedding) - (list :status :error :message "No embedding in response")))) - (error (c) (list :status :error :message (format nil "Ollama Embedding Failure: ~a" c))))))) - -(def-cognitive-tool :ask-llm - "Queries an LLM provider via the unified gateway." - ((:prompt :type :string :description "The user prompt.") - (:system-prompt :type :string :description "The system instructions.") - (:provider :type :keyword :description "Optional specific provider.") - (:model :type :string :description "Optional specific model ID.")) - :body (lambda (args) - (execute-llm-request (getf args :prompt) - (or (getf args :system-prompt) "You are a helpful assistant.") - :provider (getf args :provider) - :model (getf args :model)))) - -(defskill :skill-llm-gateway - :priority 150 - :trigger (lambda (context) (declare (ignore context)) nil) - :probabilistic (lambda (context) (declare (ignore context)) nil) - :deterministic (lambda (action context) (declare (ignore context)) action)) diff --git a/skills/org-skill-peripheral-vision.lisp b/skills/org-skill-peripheral-vision.lisp deleted file mode 100644 index 2800259..0000000 --- a/skills/org-skill-peripheral-vision.lisp +++ /dev/null @@ -1,76 +0,0 @@ -(defun context-render-to-org (obj &key depth foveal-id semantic-threshold foveal-vector) - "Recursively renders an org-object with foveal-peripheral pruning.") - -(defun context-assemble-global-awareness (&optional signal) - "Assembles the full context block for a neural request.") - -(defun context-render-to-org (obj &key (depth 1) (foveal-id nil) (semantic-threshold 0.75) (foveal-vector nil)) - "Recursively renders an org-object and its children to an Org string using a Foveal-Peripheral Hybrid model." - (let* ((id (org-object-id obj)) - (is-foveal (equal id foveal-id)) - (title (or (getf (org-object-attributes obj) :TITLE) "Untitled")) - (content (org-object-content obj)) - (children (org-object-children obj)) - (stars (make-string depth :initial-element #\*)) - (obj-vector (org-object-vector obj)) - (similarity (if (and foveal-vector obj-vector (not is-foveal)) - (cosine-similarity foveal-vector obj-vector) - 0.0)) - (is-semantically-relevant (>= similarity semantic-threshold)) - ;; We always render depth 1 and 2 (Projects and main tasks). - ;; We always render the foveal node and its immediate children. - ;; We render deeper nodes ONLY if they are semantically relevant. - (should-render (or (<= depth 2) is-foveal is-semantically-relevant)) - (output "")) - - (when should-render - (setf output (format nil "~a ~a~%:PROPERTIES:~%:ID: ~a~%" stars title id)) - (when (and is-semantically-relevant (> similarity 0)) - (setf output (concatenate 'string output (format nil ":SEMANTIC_SCORE: ~,2f~%" similarity)))) - (setf output (concatenate 'string output (format nil ":END:~%"))) - - ;; Only include full body content if this is the Foveal focus or highly relevant - (when (and content (or is-foveal is-semantically-relevant)) - (setf output (concatenate 'string output content (string #\Newline)))) - - ;; Recursively render children - (dolist (child-id children) - (let ((child-obj (lookup-object child-id))) - (when child-obj - ;; If the current node is Foveal, its children should be rendered (depth effectively resets) - (let ((next-foveal (if is-foveal child-id foveal-id))) - (setf output (concatenate 'string output - (context-render-to-org child-obj - :depth (1+ depth) - :foveal-id next-foveal - :semantic-threshold semantic-threshold - :foveal-vector foveal-vector)))))))) - output)) - -(defun context-assemble-global-awareness (&optional signal) - "Produces a high-level skeletal outline of the current Memory for the LLM." - (let* ((payload (when signal (getf signal :payload))) - (foveal-id (when payload (getf payload :target-id))) - (foveal-vector (when foveal-id (org-object-vector (lookup-object foveal-id)))) - (projects (context-get-active-projects)) - (output "GLOBAL MEMEX AWARENESS (Peripheral Vision): -")) - (if projects - (dolist (project projects) - (setf output (concatenate 'string output - (context-render-to-org project - :foveal-id foveal-id - :foveal-vector foveal-vector)))) - (setf output (concatenate 'string output "No active projects found.~%"))) - output)) - -(defskill :skill-peripheral-vision - :priority 90 - :dependencies ("org-skill-embedding") - :trigger (lambda (ctx) (member (getf (getf ctx :payload) :sensor) '(:perceive :context-refresh))) - :probabilistic nil - :deterministic (lambda (action ctx) - (declare (ignore action ctx)) - ;; This skill primarily provides the context-assemble-global-awareness function - ;; used by the probabilistic-gate, rather than handling specific actions. - nil)) diff --git a/skills/org-skill-policy.lisp b/skills/org-skill-policy.lisp deleted file mode 100644 index 995ac20..0000000 --- a/skills/org-skill-policy.lisp +++ /dev/null @@ -1,404 +0,0 @@ -(in-package :opencortex) - -(defvar *policy-invariant-priorities* - '((:transparency . 500) - (:autonomy . 400) - (:bloat . 300) - (:modularity . 250) - (:mentorship . 200) - (:sustainability . 100)) - "Priority alist for policy invariant conflict resolution. -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. - - 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)))) - - ;; Check 2: User-facing actions require explanation - (when (and (member target '(:cli :tui :emacs :EMACS :CLI :TUI)) - (not explanation) - (not (member (getf payload :action) - '(:handshake :heartbeat :status-update)))) - (return-from policy-check-transparency - (list :type :LOG - :payload (list :level :error - :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 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. - - 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)) - "")) - (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. - - 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 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. - - 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. - - 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*) - :original-action 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 - 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. - - 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))) - (justification (or (getf payload :modularity-justification) - (getf payload :MODULARITY-JUSTIFICATION)))) - - (when (and target-file - (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)) - -(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 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) - :payload (list :action :message - :text (format nil "[POLICY ~a] ~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. - - 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, interpret it - (when (and (listp result) - (member (getf result :type) '(:LOG :EVENT))) - - (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. - - 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))) - (when (and sym (fboundp sym)) - (return (symbol-function sym)))))))) - -(defun policy-deterministic-gate (action context) - "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))) - - ;; 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)) - - ;; 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 - :priority 500 - :trigger (lambda (ctx) (declare (ignore ctx)) t) - :probabilistic nil - :deterministic #'policy-deterministic-gate) diff --git a/skills/org-skill-protocol-validator.lisp b/skills/org-skill-protocol-validator.lisp deleted file mode 100644 index 5c9411a..0000000 --- a/skills/org-skill-protocol-validator.lisp +++ /dev/null @@ -1,44 +0,0 @@ -(in-package :opencortex) - -(defun validate-communication-protocol-schema (msg) - "Strict structural validation for incoming communication protocol messages." - (unless (listp msg) - (error "Communication Protocol Schema Error: Message must be a property list (got ~s)" (type-of msg))) - - (let ((type (let ((raw (proto-get msg :type))) (if (keywordp raw) (intern (string-upcase (string raw)) :keyword) raw)))) - (unless (member type '(:REQUEST :EVENT :RESPONSE :LOG :STATUS :CHAT)) - (progn (harness-log "REJECTED MSG: ~s" msg) (error "Communication Protocol Schema Error: Invalid message type '~a'" type))) - - (case type - (:REQUEST - ;; Allow missing :target if :source is present in :meta, since reason-gate - ;; will infer :target from :source downstream. This preserves "equality of - ;; clients" — gateways need not duplicate routing logic. - (let ((target (proto-get msg :target)) - (source (proto-get (proto-get msg :meta) :source))) - (unless (or target source) - (error "Communication Protocol Schema Error: REQUEST missing mandatory :target and no :source in :meta to infer it")) - (unless (proto-get msg :payload) - (error "Communication Protocol Schema Error: REQUEST missing mandatory :payload")))) - - (:EVENT - (let ((payload (proto-get msg :payload))) - (unless (and payload (listp payload)) - (error "Communication Protocol Schema Error: EVENT missing or invalid :payload")) - (unless (or (proto-get payload :action) (proto-get payload :sensor)) - (error "Communication Protocol Schema Error: EVENT payload must contain :action or :sensor")))) - - (:RESPONSE - (unless (proto-get msg :payload) - (error "Communication Protocol Schema Error: RESPONSE missing mandatory :payload")))) - - t)) - -(defskill :skill-communication-protocol-validator - :priority 95 - :trigger (lambda (ctx) (member (getf (getf ctx :payload) :sensor) '(:protocol-received))) - :probabilistic nil - :deterministic (lambda (action ctx) - (declare (ignore ctx)) - (validate-communication-protocol-schema action) - action)) diff --git a/skills/org-skill-scribe.lisp b/skills/org-skill-scribe.lisp deleted file mode 100644 index 9d51c09..0000000 --- a/skills/org-skill-scribe.lisp +++ /dev/null @@ -1,108 +0,0 @@ -(in-package :opencortex) - -(defvar *scribe-last-checkpoint* 0 - "The universal-time of the last successful distillation run.") - -(defun scribe-load-state () - "Loads the scribe checkpoint from the state directory." - (let ((state-file (uiop:merge-pathnames* "state/scribe-checkpoint.lisp" (asdf:system-source-directory :opencortex)))) - (if (uiop:file-exists-p state-file) - (setf *scribe-last-checkpoint* (read-from-string (uiop:read-file-string state-file))) - (setf *scribe-last-checkpoint* 0)))) - -(defun scribe-save-state () - "Saves the current universal-time as the new checkpoint." - (let ((state-file (uiop:merge-pathnames* "state/scribe-checkpoint.lisp" (asdf:system-source-directory :opencortex)))) - (ensure-directories-exist state-file) - (with-open-file (out state-file :direction :output :if-exists :supersede) - (format out "~a" (get-universal-time))))) - -(defun scribe-get-distillable-nodes () - "Returns a list of org-objects from the daily/ folder that require distillation." - (let ((results nil)) - (maphash (lambda (id obj) - (declare (ignore id)) - (let* ((attrs (org-object-attributes obj)) - (tags (getf attrs :TAGS)) - (type (org-object-type obj)) - (version (org-object-version obj))) - (when (and (eq type :HEADLINE) - (> version *scribe-last-checkpoint*) - (not (member "@personal" tags :test #'string-equal))) - (push obj results)))) - *memory*) - results)) - -(defun probabilistic-skill-scribe (context) - "Generates the extraction prompt for the Scribe." - (let* ((payload (getf context :payload)) - (nodes (scribe-get-distillable-nodes))) - (if nodes - (let ((text-to-process "")) - (dolist (node nodes) - (setf text-to-process (concatenate 'string text-to-process - (format nil "ID: ~a~%TITLE: ~a~%CONTENT: ~a~%---~%" - (org-object-id node) - (getf (org-object-attributes node) :TITLE) - (org-object-content node))))) - (format nil "DISTILLATION TASK: -Below are raw chronological logs from my daily journal. -Extract ATOMIC EVERGREEN NOTES from this text. - -RULES: -1. One note per distinct concept. -2. Output a list of Lisp plists: ((:title \"...\" :content \"...\" :source-id \"...\") ...) -3. The content should be in Org-mode format. -4. Keep titles descriptive and snake_case. - -TEXT: -~a" text-to-process)) - nil))) - -(defun scribe-commit-notes (proposals) - "Writes proposed atomic notes to the notes/ directory. Appends if the note exists." - (let ((notes-dir (uiop:merge-pathnames* "notes/" (asdf:system-source-directory :opencortex)))) - (ensure-directories-exist notes-dir) - (dolist (note proposals) - (let* ((title (getf note :title)) - (content (getf note :content)) - (source-id (getf note :source-id)) - (filename (format nil "~a.org" (string-downcase (cl-ppcre:regex-replace-all " " title "_")))) - (path (merge-pathnames filename notes-dir))) - (if (uiop:file-exists-p path) - (with-open-file (out path :direction :output :if-exists :append) - (format out "~%~%* Appended insight from ~a~%~a" source-id content)) - (with-open-file (out path :direction :output :if-exists :supersede) - (format out ":PROPERTIES:~%:ID: ~a~%:SOURCE_ID: ~a~%:END:~%#+TITLE: ~a~%~%~a" - (org-id-new) source-id title content))) - (harness-log "SCRIBE: Processed evergreen note ~a" filename))))) - -(defun verify-skill-scribe (action context) - "Executes the note creation and marks source nodes as distilled." - (declare (ignore context)) - (let ((data (cond ((and (listp action) (eq (getf action :type) :REQUEST)) - (getf (getf action :payload) :payload)) - ((and (listp action) (not (member (getf action :type) '(:LOG :EVENT)))) - action) - (t nil)))) - (when data - (harness-log "SCRIBE: Committing ~a atomic notes..." (length data)) - (scribe-commit-notes data) - (scribe-save-state) - (harness-log "SCRIBE: Distillation complete.") - ;; Return a log event to stop the loop - (list :type :LOG :payload (list :text "Distillation successful."))))) - -(defskill :skill-scribe - :priority 50 - :trigger (lambda (ctx) - (let* ((payload (getf ctx :payload)) - (sensor (getf payload :sensor))) - (and (eq sensor :heartbeat) - ;; Only run once per hour to check if we need to distill - (> (- (get-universal-time) *scribe-last-checkpoint*) 3600) - (scribe-get-distillable-nodes)))) - :probabilistic #'probabilistic-skill-scribe - :deterministic #'verify-skill-scribe) - -(scribe-load-state) diff --git a/skills/org-skill-self-edit.lisp b/skills/org-skill-self-edit.lisp deleted file mode 100644 index 48578f4..0000000 --- a/skills/org-skill-self-edit.lisp +++ /dev/null @@ -1,177 +0,0 @@ -(in-package :opencortex) - -(defun self-edit-count-char (char string) - "Counts occurrences of CHAR in STRING." - (loop for c across string count (char= c char))) - -(defun self-edit-balance-parens (code) - "Balances parentheses in CODE." - (let ((opens (self-edit-count-char #\( code)) - (closes (self-edit-count-char #\) code))) - (cond - ((= opens closes) code) - ((> opens closes) - (concatenate 'string code (make-string (- opens closes) :initial-element #\)))) - ((> closes opens) - (concatenate 'string (make-string (- closes opens) :initial-element #\() code))))) - -(defun self-edit-parse-location (context) - "Extracts file and line from error context payload." - (let* ((payload (getf context :payload)) - (message (getf payload :message "")) - (file (or (getf payload :file) - (when (search "file" message) - (car (cl-ppcre:all-matches-as-strings "[a-zA-Z0-9_/-]+\\.lisp" message))))) - (line (or (getf payload :line) - (let ((match (cl-ppcre:scan-to-strings "line.?(\\d+)" message))) - (when match (parse-integer (aref match 0))))))) - (list :file file :line line))) - -(defun self-edit-apply (target-file old-code new-code) - "Applies surgical edit to TARGET-FILE: replace OLD-CODE with NEW-CODE. -Returns list with :status and :message keys." - (unless (uiop:file-exists-p target-file) - (return-from self-edit-apply - (list :status :error :message (format nil "File not found: ~a" target-file)))) - - (snapshot-memory) - (harness-log "SELF-EDIT: Attempting surgical fix on ~a..." target-file) - - (let ((original-content (uiop:read-file-string target-file))) - (handler-case - (if (search old-code original-content) - (let ((new-content (cl-ppcre:regex-replace-all - (cl-ppcre:quote-meta-chars old-code) - original-content - new-code))) - (with-open-file (out target-file :direction :output :if-exists :supersede) - (write-string new-content out)) - (harness-log "SELF-EDIT: Edit applied successfully.") - (list :status :success :message "Edit applied.")) - (progn - (harness-log "SELF-EDIT: Pattern not found in file.") - (list :status :error :message "Pattern not found in file."))) - (error (c) - (harness-log "SELF-EDIT: Edit failed: ~a" c) - (rollback-memory 0) - (list :status :error :message (format nil "Edit failed: ~a" c)))))) - -(def-cognitive-tool :self-edit - "Applies a surgical code modification to a file with automatic rollback on failure." - ((:file :type :string :description "Path to the target file") - (:old :type :string :description "The code block to find") - (:new :type :string :description "The code block to replace with")) - :body (lambda (args) - (let* ((file (getf args :file)) - (old (getf args :old)) - (new (getf args :new))) - (self-edit-apply file old new)))) - -(defskill :skill-self-edit - :priority 95 - :trigger (lambda (ctx) - (let ((sensor (getf (getf ctx :payload) :sensor))) - (member sensor '(:syntax-error :repair-request :self-edit)))) - :probabilistic (lambda (ctx) - (let ((sensor (getf (getf ctx :payload) :sensor))) - (cond - ((eq sensor :syntax-error) - "You are the Self-Edit Agent. A syntax error occurred. -Provide a fixed version of the code as a lisp form.") - ((eq sensor :repair-request) - "You are the Self-Edit Agent. Apply the surgical fix to the file.") - (t nil)))) - :deterministic (lambda (action ctx) - (let* ((payload (getf ctx :payload)) - (sensor (getf payload :sensor))) - (cond - ((eq sensor :syntax-error) - (let ((code (getf payload :code))) - (harness-log "SELF-EDIT: Fast paren balancing...") - (let ((balanced (self-edit-balance-parens code))) - (handler-case - (progn - (read-from-string balanced) - (harness-log "SELF-EDIT: Fast fix SUCCESS.") - (list :status :success :repaired balanced)) - (error () - (harness-log "SELF-EDIT: Fast fix failed, need neural repair.") - (list :status :error :reason "needs-llm")))))) - ((eq sensor :repair-request) - (let ((file (getf payload :file)) - (old (getf payload :old)) - (new (getf payload :new))) - (self-edit-apply file old new))) - (t nil))))) - -(def-cognitive-tool :balance-parens - "Balances parentheses in a code string." - ((:code :type :string :description "The code to balance")) - :body (lambda (args) - (let ((code (getf args :code)) - (balanced (self-edit-balance-parens code))) - (handler-case - (progn - (read-from-string balanced) - (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/skills/org-skill-self-fix.lisp b/skills/org-skill-self-fix.lisp deleted file mode 100644 index 681be81..0000000 --- a/skills/org-skill-self-fix.lisp +++ /dev/null @@ -1,65 +0,0 @@ -(in-package :opencortex) - -(defun self-fix-apply (action context) - "Applies a surgical code fix and reloads the modified skill." - (declare (ignore context)) - (let* ((payload (getf action :payload)) - (target-file (getf payload :file)) - (old-code (getf payload :old)) - (new-code (getf payload :new)) - (is-skill (and (stringp (namestring target-file)) - (search "skills/" (namestring target-file))))) - - (opencortex:snapshot-memory) - (opencortex:harness-log "SELF-FIX - Attempting surgical fix on ~a..." target-file) - - (handler-case - (if (uiop:file-exists-p target-file) - (let ((content (uiop:read-file-string target-file))) - (if (search old-code content) - (let ((new-content (cl-ppcre:regex-replace-all (cl-ppcre:quote-meta-chars old-code) content new-code))) - (with-open-file (out target-file :direction :output :if-exists :supersede) - (write-string new-content out)) - - (if is-skill - (progn - (opencortex:harness-log "SELF-FIX - Reloading modified skill ~a..." target-file) - (if (opencortex:load-skill-from-org target-file) - (progn - (opencortex:harness-log "SELF-FIX SUCCESS - Applied and reloaded.") - t) - (progn - (opencortex:harness-log "SELF-FIX FAILURE - Skill reload failed. Rolling back.") - (with-open-file (out target-file :direction :output :if-exists :supersede) - (write-string content out)) - (opencortex:rollback-memory 0) - nil))) - (progn - (opencortex:harness-log "SELF-FIX SUCCESS - Applied fix to file.") - t))) - (progn (opencortex:harness-log "SELF-FIX FAILURE - Pattern not found.") nil))) - (progn (opencortex:harness-log "SELF-FIX FAILURE - File not found.") nil)) - (error (c) - (opencortex:harness-log "SELF-FIX CRASH - ~a. Rolling back." c) - (opencortex:rollback-memory 0) - nil)))) - -(def-cognitive-tool :repair-file - "Applies a surgical code modification to a file and reloads the skill if applicable." - ((:file :type :string :description "Path to the target file") - (:old :type :string :description "The literal code block to find") - (:new :type :string :description "The literal code block to replace it with")) - :body (lambda (args) - (if (self-fix-apply (list :payload args) nil) - "REPAIR SUCCESSFUL." - "REPAIR FAILED."))) - -(defskill :skill-self-fix - :priority 95 - :trigger (lambda (context) (eq (getf (getf context :payload) :sensor) :repair-request)) - :probabilistic (lambda (context) - (format nil "You are the opencortex Repair Actuator. Synthesize a surgical fix for the reported failure. -Return a Lisp plist for :repair-file.")) - :deterministic (lambda (action context) - (let ((payload (getf action :payload))) - (self-fix-apply action context)))) diff --git a/skills/org-skill-shell-actuator.lisp b/skills/org-skill-shell-actuator.lisp deleted file mode 100644 index 04c262d..0000000 --- a/skills/org-skill-shell-actuator.lisp +++ /dev/null @@ -1,56 +0,0 @@ -(defparameter *allowed-commands* '("ls" "git" "rg" "grep" "date" "echo" "cat" "node" "python3" "sbcl")) - -(defparameter *shell-metacharacters* '(#\; #\& #\| #\> #\< #\$ #\` #\\ #\!)) - -(defun shell-command-safe-p (cmd-string) - "Returns T if the command string contains no dangerous metacharacters." - (not (some (lambda (char) (find char cmd-string)) *shell-metacharacters*))) - -(defun execute-shell-safely (action context) - (let* ((payload (getf action :PAYLOAD)) - (cmd-string (getf payload :cmd)) - (executable (car (uiop:split-string (string-trim " " cmd-string) :separator '(#\Space))))) - - (cond - ((not (shell-command-safe-p cmd-string)) - (opencortex:inject-stimulus - `(:TYPE :EVENT :PAYLOAD (:SENSOR :shell-response :cmd ,cmd-string :stdout "" :stderr "ERROR - Security Violation: Dangerous metacharacters detected." :exit-code 1)) - :stream (getf context :reply-stream))) - - ((not (member executable *allowed-commands* :test #'string=)) - (opencortex:inject-stimulus - `(:TYPE :EVENT :PAYLOAD (:SENSOR :shell-response :cmd ,cmd-string :stdout "" :stderr "ERROR - Command not in security whitelist." :exit-code 1)) - :stream (getf context :reply-stream))) - - (t - (multiple-value-bind (stdout stderr exit-code) - (uiop:run-program cmd-string :output :string :error-output :string :ignore-error-status t) - (opencortex:inject-stimulus - `(:TYPE :EVENT :PAYLOAD (:SENSOR :shell-response :cmd ,cmd-string :stdout ,(or stdout "") :stderr ,(or stderr "") :exit-code ,exit-code)) - :stream (getf context :reply-stream))))))) - -(defun trigger-skill-shell-actuator (context) - (let ((type (getf context :TYPE)) - (payload (getf context :PAYLOAD))) - (and (eq type :EVENT) - (eq (getf payload :SENSOR) :shell-response)))) - -(defun probabilistic-skill-shell-actuator (context) - (let* ((p (getf context :PAYLOAD)) - (cmd (getf p :cmd)) - (stdout (getf p :stdout)) - (stderr (getf p :stderr)) - (exit-code (getf p :exit-code))) - (format nil "SHELL COMMAND RESULT: -Command: ~a -Exit Code: ~a -STDOUT: ~a -STDERR: ~a" cmd exit-code stdout stderr))) - -(opencortex:register-actuator :shell #'execute-shell-safely) - -(defskill :skill-shell-actuator - :priority 80 - :trigger #'trigger-skill-shell-actuator - :probabilistic #'probabilistic-skill-shell-actuator - :deterministic (lambda (action context) (declare (ignore context)) action)) diff --git a/skills/org-skill-tool-permissions.lisp b/skills/org-skill-tool-permissions.lisp deleted file mode 100644 index a972f0e..0000000 --- a/skills/org-skill-tool-permissions.lisp +++ /dev/null @@ -1,87 +0,0 @@ -(in-package :opencortex) - -(defvar *tool-permissions* (make-hash-table :test 'equal) - "Hash table mapping tool names to :allow/:deny/:ask.") - -(defun get-tool-permission (tool-name) - (let ((key (string-downcase (string tool-name)))) - (or (gethash key *tool-permissions*) :allow))) - -(defun set-tool-permission (tool-name tier) - (setf (gethash (string-downcase (string tool-name)) *tool-permissions*) tier) - (harness-log "TOOL PERMISSION: Set ~a = ~a" tool-name tier)) - -(defun check-tool-permission-gate (tool-name context) - (declare (ignore context)) - (let ((perm (get-tool-permission tool-name))) - (case perm - (:allow :allow) - (:deny :deny) - (:ask (list :ask tool-name context)) - (t :allow)))) - -(def-cognitive-tool :get-embedding - "Generates vector embeddings via Ollama or llama.cpp API." - ((:text :type :string :description "Text to embed.")) - :body (lambda (args) - (let* ((text (getf args :text)) - (provider (or (uiop:getenv "EMBEDDING_PROVIDER") "ollama")) - (model (or (uiop:getenv "EMBEDDING_MODEL") "nomic-embed-text")) - (embedding nil)) - (cond - ((string= provider "ollama") - (let* ((host (or (uiop:getenv "OLLAMA_HOST") "localhost:11434")) - (url (format nil "http://~a/api/embeddings" host)) - (body (cl-json:encode-json-to-string `((model . ,model) (prompt . ,text))))) - (handler-case - (let* ((response (dex:post url :headers '(("Content-Type" . "application/json")) :content body :connect-timeout 5 :read-timeout 30)) - (json (cl-json:decode-json-from-string response)) - (vec (cdr (assoc :embedding json)))) - (when vec (setf embedding vec))) - (error (c) (harness-log "EMBEDDING: Ollama failed: ~a" c))))) - ((string= provider "llama.cpp") - (let* ((host (or (uiop:getenv "LLAMA_HOST") "localhost:8080")) - (url (format nil "http://~a/v1/embeddings" host)) - (body (cl-json:encode-json-to-string `((model . ,model) (input . ,text))))) - (handler-case - (let* ((response (dex:post url :headers '(("Content-Type" . "application/json")) :content body :connect-timeout 5 :read-timeout 30)) - (json (cl-json:decode-json-from-string response)) - (data (cdr (assoc :data json))) - (vec (when data (cdr (assoc :embedding (car data)))))) - (when vec (setf embedding vec))) - (error (c) (harness-log "EMBEDDING: llama.cpp failed: ~a" c)))))) - (if embedding - (list :status :success :vector embedding) - (list :status :error :message "Embedding generation failed"))))) - -(def-cognitive-tool :tool-permissions - "View or set tool permission tiers." - ((:tool :type :string :description "Tool name") - (:action :type :keyword :description "Action: :get, :set, :list" :default :get) - (:tier :type :keyword :description "For :set: :allow/:deny/:ask")) - :body (lambda (args) - (let ((tool (getf args :tool)) - (action (getf args :action :get)) - (tier (getf args :tier))) - (case action - (:get (list :status :success :tool tool :permission (get-tool-permission tool))) - (:set (progn (set-tool-permission tool tier) - (list :status :success :message (format nil "Set ~a = ~a" tool tier)))) - (:list (let ((r nil)) - (maphash (lambda (k v) (push (list :tool k :permission v) r)) *tool-permissions*) - (list :status :success :tools r))) - (t (list :status :error :message "Invalid action")))))) - -;; Defaults -(set-tool-permission :shell :deny) -(set-tool-permission :delete-file :deny) -(set-tool-permission :eval :ask) -(set-tool-permission :write-file :ask) -(harness-log "TOOL PERMISSIONS: Initialized") - -(defskill :skill-tool-permissions - :priority 600 - :trigger (lambda (c) (declare (ignore c)) nil) - :deterministic (lambda (a c) - (let ((tool (getf (getf a :payload) :tool))) - (when tool (check-tool-permission-gate tool c)))))