build: remove redundant .lisp artifacts from source tree
Some checks failed
Deploy-Agent-V15-Stdin / JOB-V15-STDIN (push) Failing after 3s
Some checks failed
Deploy-Agent-V15-Stdin / JOB-V15-STDIN (push) Failing after 3s
This commit is contained in:
313
harness/act.lisp
313
harness/act.lisp
@@ -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))
|
|
||||||
@@ -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)))))
|
|
||||||
@@ -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))
|
|
||||||
@@ -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)))
|
|
||||||
@@ -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))
|
|
||||||
@@ -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))))
|
|
||||||
@@ -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)))
|
|
||||||
@@ -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)))
|
|
||||||
@@ -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))
|
|
||||||
@@ -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 \"<Response Text>\"))
|
|
||||||
|
|
||||||
To call a tool, you MUST use:
|
|
||||||
(:TYPE :REQUEST :TARGET :TOOL :ACTION :CALL :TOOL \"<name>\" :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)))
|
|
||||||
@@ -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 <name> :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))))))
|
|
||||||
@@ -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*))))
|
|
||||||
@@ -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)
|
|
||||||
@@ -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)
|
|
||||||
@@ -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))))
|
|
||||||
|#
|
|
||||||
@@ -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)))))
|
|
||||||
@@ -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)
|
|
||||||
@@ -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)
|
|
||||||
@@ -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))
|
|
||||||
@@ -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 <check-key> :reason <string> :line <n> :col <n>)
|
|
||||||
|
|
||||||
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))))
|
|
||||||
@@ -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\")")))
|
|
||||||
@@ -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)
|
|
||||||
@@ -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))
|
|
||||||
@@ -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))
|
|
||||||
@@ -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))
|
|
||||||
@@ -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)
|
|
||||||
@@ -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))
|
|
||||||
@@ -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)
|
|
||||||
@@ -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)))))
|
|
||||||
@@ -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))))
|
|
||||||
@@ -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))
|
|
||||||
@@ -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)))))
|
|
||||||
Reference in New Issue
Block a user