feat(core): Skills consolidation and v0.2.0 TUI integration
- NEW: org-skill-utils-lisp (consolidated from org-skill-lisp-utils) * 3-phase validation: structural, syntactic, semantic * Sandboxed eval, AST extraction/injection/wrapping * Format, list-definitions utilities - NEW: org-skill-utils-org (consolidated from org-skill-emacs-edit) * Read/update/delete org headlines * Property management, TODO state handling * ID-link and internal link support - DELETE: org-skill-lisp-utils (merged into utils-lisp) - DELETE: org-skill-emacs-edit (merged into utils-org) - RENAME: run-all-tests.lisp -> run-tests.lisp - HARDEN: Skill loader with improved lisp keyword handling - FIX: Package jailing issues with def-cognitive-tool macro conflicts - ADD: Setup wizard (opencortex setup) and doctor (opencortex doctor) - ADD: TUI client with Croatoan for native terminal rendering - REMOVE: Dynamic loading from opencortex.asd (use :force t instead) - CLEANUP: Test file consolidation (removed duplicate test suites) Co-authored-by: Agent <agent@memex>
This commit is contained in:
@@ -1,258 +1,103 @@
|
||||
(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.
|
||||
"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-scan-secrets (text)
|
||||
"Scans TEXT for known secrets from the vault."
|
||||
(when (and text (stringp text))
|
||||
(let ((found-secret nil))
|
||||
(maphash (lambda (key val)
|
||||
(when (and val (stringp val) (> (length val) 5))
|
||||
(when (search val text)
|
||||
(setf found-secret key))))
|
||||
*vault-memory*)
|
||||
found-secret)))
|
||||
|
||||
(defun bouncer-check-network-exfil (cmd)
|
||||
"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."
|
||||
|
||||
"Detects if CMD attempts to contact an unwhitelisted external host."
|
||||
(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))
|
||||
|
||||
(multiple-value-bind (match regs)
|
||||
(cl-ppcre:scan-to-strings "(http|https|ftp)://([\\w\\.-]+)" cmd)
|
||||
(declare (ignore match))
|
||||
(when regs
|
||||
(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."
|
||||
|
||||
"The 5-Vector security gate for high-risk actions."
|
||||
(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)))
|
||||
|
||||
(let* ((target (proto-get action :target))
|
||||
(payload (proto-get action :payload))
|
||||
(text (or (proto-get payload :text) (proto-get action :text)))
|
||||
(cmd (or (proto-get payload :cmd)
|
||||
(when (and (eq target :tool) (equal (proto-get payload :tool) "shell"))
|
||||
(proto-get (proto-get payload :args) :cmd))))
|
||||
(approved (proto-get 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
|
||||
(approved action)
|
||||
((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
|
||||
(and (eq target :tool) (equal (proto-get 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)))
|
||||
((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))))
|
||||
(and (eq target :tool) (member (proto-get payload :tool) '("shell" "repair-file") :test #'string=))
|
||||
(and (eq target :emacs) (eq (proto-get payload :action) :eval)))
|
||||
(harness-log "SECURITY: High-impact action requires approval: ~a" (or (proto-get payload :tool) target))
|
||||
(list :type :EVENT :payload (list :sensor :approval-required :action action)))
|
||||
(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."
|
||||
|
||||
"Scans for APPROVED flight plans and re-injects them."
|
||||
(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* ((attrs (org-object-attributes node))
|
||||
(tags (getf attrs :TAGS))
|
||||
(action-str (getf attrs :ACTION)))
|
||||
(when (and (member "FLIGHT_PLAN" tags :test #'string-equal) action-str)
|
||||
(harness-log "BOUNCER: Found approved flight plan '~a'. Re-injecting..." (org-object-id node))
|
||||
(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))))))
|
||||
|
||||
(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))))))
|
||||
"Creates a Flight Plan node for manual approval."
|
||||
(let ((id (org-id-new)))
|
||||
(harness-log "BOUNCER: Creating flight plan node '~a'..." id)
|
||||
(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."
|
||||
|
||||
"Main deterministic gate for the Bouncer skill."
|
||||
(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
|
||||
(bouncer-create-flight-plan (getf payload :action)))
|
||||
(: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
|
||||
(if action (bouncer-check action context) action))
|
||||
(otherwise
|
||||
(if action
|
||||
(bouncer-check action context)
|
||||
action)))))
|
||||
(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)
|
||||
|
||||
@@ -8,11 +8,6 @@ The *Bouncer Skill* is the physical security layer of OpenCortex. It enforces op
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** Security Configuration
|
||||
#+begin_src lisp
|
||||
(defvar *bouncer-network-whitelist*
|
||||
@@ -56,34 +51,30 @@ The *Bouncer Skill* is the physical security layer of OpenCortex. It enforces op
|
||||
(let* ((target (proto-get action :target))
|
||||
(payload (proto-get action :payload))
|
||||
(text (or (proto-get payload :text) (proto-get action :text)))
|
||||
(cmd (or (proto-get payload :cmd)
|
||||
(cmd (or (proto-get payload :cmd)
|
||||
(when (and (eq target :tool) (equal (proto-get payload :tool) "shell"))
|
||||
(proto-get (proto-get payload :args) :cmd)))))
|
||||
(proto-get (proto-get payload :args) :cmd))))
|
||||
(approved (proto-get action :approved)))
|
||||
|
||||
(cond
|
||||
(approved action)
|
||||
|
||||
((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)))))
|
||||
|
||||
((and (or (eq target :shell)
|
||||
((and (or (eq target :shell)
|
||||
(and (eq target :tool) (equal (proto-get 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)))
|
||||
|
||||
((or (member target '(:shell))
|
||||
(harness-log "SECURITY WARNING: External network call detected. Queuing for approval.")
|
||||
(list :type :EVENT :payload (list :sensor :approval-required :action action)))
|
||||
((or (member target '(:shell))
|
||||
(and (eq target :tool) (member (proto-get payload :tool) '("shell" "repair-file") :test #'string=))
|
||||
(and (eq target :emacs) (eq (proto-get payload :action) :eval))))
|
||||
(and (eq target :emacs) (eq (proto-get payload :action) :eval)))
|
||||
(harness-log "SECURITY: High-impact action requires approval: ~a" (or (proto-get payload :tool) target))
|
||||
(list :type :EVENT :payload (list :sensor :approval-required :action action)))
|
||||
|
||||
(t action))))
|
||||
|
||||
#+end_src
|
||||
|
||||
** Approval Processing (bouncer-process-approvals)
|
||||
@@ -115,9 +106,9 @@ The *Bouncer Skill* is the physical security layer of OpenCortex. It enforces op
|
||||
(harness-log "BOUNCER: Creating flight plan node '~a'..." id)
|
||||
(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))))))
|
||||
:attributes (list :TITLE "Flight Plan: High-Risk Action"
|
||||
:TODO "PLAN" :TAGS '("FLIGHT_PLAN")
|
||||
:ACTION (format nil "~s" blocked-action))))))
|
||||
#+end_src
|
||||
|
||||
** Gate Logic (bouncer-deterministic-gate)
|
||||
|
||||
@@ -1,83 +1,12 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defvar *cli-port* 9105)
|
||||
(defvar *cli-server-socket* nil)
|
||||
(defvar *cli-server-thread* nil)
|
||||
(defun cli-process-input (text)
|
||||
"Processes raw text from the command line."
|
||||
(inject-stimulus (list :type :EVENT
|
||||
:payload (list :sensor :user-input :text text)
|
||||
:meta (list :source :CLI))))
|
||||
|
||||
(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
|
||||
(defskill :skill-cli-gateway
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (eq (getf (getf ctx :meta) :source) :CLI))
|
||||
:deterministic (lambda (action ctx) (declare (ignore ctx)) action))
|
||||
|
||||
(start-cli-gateway)
|
||||
|
||||
@@ -8,11 +8,6 @@ The *CLI Gateway* provides a command-line interface for interacting with the Ope
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** CLI Command Handling
|
||||
#+begin_src lisp
|
||||
(defun cli-process-input (text)
|
||||
|
||||
@@ -1,96 +1,250 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defparameter *skill-config-manager*
|
||||
'(:name "config-manager"
|
||||
:description "Manages system settings and LLM provider configurations."
|
||||
:capabilities (:configure-provider :run-setup-wizard)
|
||||
:type :deterministic)
|
||||
"Skill metadata for the Config Manager.")
|
||||
|
||||
(defvar *provider-templates*
|
||||
'((:ollama . (:name "Ollama (Local)" :fields ((:url :label "URL") (:model :label "Model")) :default-url "http://localhost:11434" :default-model "llama3"))
|
||||
(:openrouter . (:name "OpenRouter" :fields ((:key :label "API Key" :secret t) (:model :label "Model")) :default-model "anthropic/claude-3-opus-20240229"))
|
||||
(:openai . (:name "OpenAI" :fields ((:key :label "API Key" :secret t) (:model :label "Model")) :default-model "gpt-4-turbo"))
|
||||
(:groq . (:name "Groq" :fields ((:key :label "API Key" :secret t) (:model :label "Model")) :default-model "mixtral-8x7b-32768"))
|
||||
(:gemini . (:name "Google Gemini" :fields ((:key :label "API Key" :secret t) (:model :label "Model")) :default-model "gemini-1.5-pro"))
|
||||
(:anthropic . (:name "Anthropic" :fields ((:key :label "API Key" :secret t) (:model :label "Model")) :default-model "claude-3-5-sonnet-20240620")))
|
||||
"Templates for supported LLM providers.")
|
||||
|
||||
(defvar *providers* nil "Global registry of configured LLM providers.")
|
||||
|
||||
(defun get-oc-config-dir ()
|
||||
"Returns the XDG-compliant config directory for OpenCortex."
|
||||
(let ((env (uiop:getenv "OC_CONFIG_DIR")))
|
||||
(if (and env (> (length env) 0))
|
||||
(uiop:ensure-directory-pathname env)
|
||||
(uiop:merge-pathnames* ".config/opencortex/" (user-homedir-pathname)))))
|
||||
"Returns the absolute path to the opencortex config directory."
|
||||
(let ((xdg (uiop:getenv "OC_CONFIG_DIR")))
|
||||
(if (and xdg (string/= xdg ""))
|
||||
(uiop:ensure-directory-pathname xdg)
|
||||
(uiop:ensure-directory-pathname (merge-pathnames ".config/opencortex/" (user-homedir-pathname))))))
|
||||
|
||||
(defun save-providers ()
|
||||
"Persist provider configuration to XDG config directory."
|
||||
(let ((path (merge-pathnames "providers.lisp" (get-oc-config-dir))))
|
||||
(ensure-directories-exist path)
|
||||
(with-open-file (s path :direction :output :if-exists :supersede)
|
||||
(format s ";;; OpenCortex Provider Metadata~%~s~%" *providers*))))
|
||||
(defun get-config-file ()
|
||||
"Returns the path to the .env config file."
|
||||
(merge-pathnames ".env" (get-oc-config-dir)))
|
||||
|
||||
(defun prompt-for (label &optional default)
|
||||
"Prompts the user for input on the CLI."
|
||||
(format t "~a~@[ [~a]~]: " label default)
|
||||
(defun ensure-config-dir ()
|
||||
"Ensures the config directory exists."
|
||||
(let ((dir (get-oc-config-dir)))
|
||||
(unless (uiop:directory-exists-p dir)
|
||||
(uiop:ensure-directory-pathname dir))
|
||||
dir))
|
||||
|
||||
(defun read-config-file ()
|
||||
"Reads the .env config file and returns an alist of KEY=VALUE pairs."
|
||||
(let ((config-file (get-config-file)))
|
||||
(when (uiop:file-exists-p config-file)
|
||||
(let ((lines (uiop:read-file-lines config-file))
|
||||
(result nil))
|
||||
(dolist (line lines)
|
||||
(when (and line (> (length line) 0)
|
||||
(not (uiop:string-prefix-p "#" line)))
|
||||
(let ((eq-pos (position #\= line)))
|
||||
(when eq-pos
|
||||
(let ((key (string-trim " " (subseq line 0 eq-pos)))
|
||||
(value (string-trim " " (subseq line (1+ eq-pos)))))
|
||||
(push (cons key value) result))))))
|
||||
(nreverse result)))))
|
||||
|
||||
(defun write-config-file (config-alist)
|
||||
"Writes the config alist to the .env file."
|
||||
(ensure-config-dir)
|
||||
(let ((config-file (get-config-file)))
|
||||
(with-open-file (stream config-file :direction :output :if-exists :supersede :if-does-not-exist :create)
|
||||
(format stream "# OpenCortex Configuration~%")
|
||||
(format stream "# Generated by opencortex setup~%~%")
|
||||
(dolist (pair config-alist)
|
||||
(format stream "~a=~a~%" (car pair) (cdr pair))))))
|
||||
|
||||
(defun get-config-value (key)
|
||||
"Gets a config value by key."
|
||||
(let ((config (read-config-file)))
|
||||
(cdr (assoc key config :test #'string=))))
|
||||
|
||||
(defun set-config-value (key value)
|
||||
"Sets a config value and saves to file."
|
||||
(let ((config (read-config-file))
|
||||
(pair (cons key value)))
|
||||
(let ((existing (assoc key config :test #'string=)))
|
||||
(if existing
|
||||
(setf (cdr existing) value)
|
||||
(push pair config))
|
||||
(write-config-file config)))
|
||||
|
||||
(defun prompt (prompt-text)
|
||||
"Simple prompt that returns user input as a string."
|
||||
(format t "~a" prompt-text)
|
||||
(finish-output)
|
||||
(let ((input (read-line)))
|
||||
(if (string= input "")
|
||||
(or default "")
|
||||
input)))
|
||||
(read-line))
|
||||
|
||||
(defun save-secret (provider field val)
|
||||
"Appends a secret to the XDG .env file."
|
||||
(let ((env-file (merge-pathnames ".env" (get-oc-config-dir)))
|
||||
(var-name (format nil "~:@(~a_~a~)" provider field)))
|
||||
(ensure-directories-exist env-file)
|
||||
(with-open-file (out env-file :direction :output :if-exists :append :if-does-not-exist :create)
|
||||
(format out "~a=~a~%" var-name val))
|
||||
(setf (uiop:getenv var-name) val)))
|
||||
(defun prompt-yes-no (prompt-text)
|
||||
"Prompts yes/no question. Returns T for yes, nil for no."
|
||||
(let ((response (prompt (format nil "~a [Y/n]: " prompt-text))))
|
||||
(or (string= response "")
|
||||
(string-equal response "Y")
|
||||
(string-equal response "y")
|
||||
(string-equal response "yes"))))
|
||||
|
||||
(defun register-provider (id config)
|
||||
"Update the global provider registry."
|
||||
(setf (getf *providers* id) config))
|
||||
(defun prompt-choice (prompt-text options)
|
||||
"Prompts user to choose from a list of options. Returns the chosen option or nil."
|
||||
(format t "~a~%" prompt-text)
|
||||
(let ((i 1))
|
||||
(dolist (opt options)
|
||||
(format t " ~a) ~a~%" i opt)
|
||||
(incf i)))
|
||||
(let ((response (prompt "Choice")))
|
||||
(let ((num (ignore-errors (parse-integer response))))
|
||||
(when (and num (<= 1 num) (>= (length options) num))
|
||||
(nth (1- num) options)))))
|
||||
|
||||
(defun configure-provider (id)
|
||||
"Guided configuration for a specific LLM provider template."
|
||||
(let* ((template (cdr (assoc id *provider-templates*)))
|
||||
(fields (getf template :fields))
|
||||
(config nil))
|
||||
(format t "~%--- Configuring ~a ---~%" (getf template :name))
|
||||
(dolist (field-spec fields)
|
||||
(let* ((field (first field-spec))
|
||||
(label (getf (rest field-spec) :label))
|
||||
(is-secret (getf (rest field-spec) :secret))
|
||||
(default-key (intern (format nil "DEFAULT-~a" field) :keyword))
|
||||
(default (getf template default-key))
|
||||
(val (prompt-for label default)))
|
||||
(if is-secret
|
||||
(save-secret id field val)
|
||||
(setf (getf config field) val))))
|
||||
(register-provider id config)
|
||||
(format t "✓ ~a metadata registered.~%" (getf template :name))))
|
||||
(defvar *available-providers*
|
||||
'(("OpenAI" . "OPENAI_API_KEY")
|
||||
("Anthropic" . "ANTHROPIC_API_KEY")
|
||||
("OpenRouter" . "OPENROUTER_API_KEY")
|
||||
("Groq" . "GROQ_API_KEY")
|
||||
("Gemini" . "GEMINI_API_KEY")
|
||||
("Ollama (local)" . "OLLAMA_URL")))
|
||||
|
||||
(defun setup-llm-providers ()
|
||||
"Interactive wizard for configuring LLM providers."
|
||||
(format t "~%~%")
|
||||
(format t "==================================================~%")
|
||||
(format t " LLM Provider Configuration~%")
|
||||
(format t "==================================================~%~%")
|
||||
|
||||
(let ((current-providers (loop for (name . key) in *available-providers*
|
||||
when (get-config-value key)
|
||||
collect name)))
|
||||
(when current-providers
|
||||
(format t "Current providers: ~{~a~^, ~}~%~%" current-providers))
|
||||
|
||||
(format t "Available providers:~%")
|
||||
(dolist (p *available-providers*)
|
||||
(format t " - ~a~%" (car p)))
|
||||
(format t "~%")
|
||||
|
||||
(when (prompt-yes-no "Configure a new provider?")
|
||||
(let ((chosen (prompt-choice "Select provider:" (mapcar #'car *available-providers*))))
|
||||
(when chosen
|
||||
(let ((env-key (cdr (assoc chosen *available-providers* :test #'string= :key #'car))))
|
||||
(if (string= chosen "Ollama (local)")
|
||||
(progn
|
||||
(format t "Enter Ollama URL (e.g., http://localhost:11434): ")
|
||||
(let ((url (read-line)))
|
||||
(set-config-value env-key url)
|
||||
(format t "✓ Ollama configured at ~a~%" url)))
|
||||
(progn
|
||||
(format t "Enter API key for ~a: " chosen)
|
||||
(let ((key (read-line)))
|
||||
(set-config-value env-key key)
|
||||
(format t "✓ ~a API key saved~%" chosen)))))))))
|
||||
|
||||
(format t "~%"))
|
||||
|
||||
(defun setup-add-provider ()
|
||||
"Entry point for adding a single provider (called from CLI)."
|
||||
(setup-llm-providers))
|
||||
|
||||
(defun setup-gateways ()
|
||||
"Interactive wizard for configuring external gateways."
|
||||
(format t "~%~%")
|
||||
(format t "==================================================~%")
|
||||
(format t " Gateway Configuration~%")
|
||||
(format t "==================================================~%~%")
|
||||
|
||||
(format t "Available gateways:~%")
|
||||
(format t " - Slack (https://api.slack.com/)~%")
|
||||
(format t " - Discord (https://discord.com/developers/)~%")
|
||||
(format t "~%")
|
||||
|
||||
(when (prompt-yes-no "Configure a gateway?")
|
||||
(let ((chosen (prompt-choice "Select platform:" '("Slack" "Discord"))))
|
||||
(when chosen
|
||||
(let ((token (prompt (format nil "Enter ~a bot token: " chosen))))
|
||||
(if (string= chosen "Slack")
|
||||
(set-config-value "SLACK_TOKEN" token)
|
||||
(set-config-value "DISCORD_TOKEN" token))
|
||||
(format t "✓ ~a gateway configured~%" chosen))))))
|
||||
|
||||
(format t "~%"))
|
||||
|
||||
(defun setup-skills ()
|
||||
"Interactive wizard for enabling/disabling skills."
|
||||
(format t "~%~%")
|
||||
(format t "==================================================~%")
|
||||
(format t " Skill Management~%")
|
||||
(format t "==================================================~%~%")
|
||||
|
||||
(format t "Note: Skill management is not yet implemented.~%")
|
||||
(format t "Skills are automatically loaded from ~a~%" (or (uiop:getenv "SKILLS_DIR") "default location"))
|
||||
(format t "~%"))
|
||||
|
||||
(defun setup-memory ()
|
||||
"Interactive wizard for memory settings."
|
||||
(format t "~%~%")
|
||||
(format t "==================================================~%")
|
||||
(format t " Memory Settings~%")
|
||||
(format t "==================================================~%~%")
|
||||
|
||||
(let ((auto-save (prompt "Auto-save interval in seconds [300]:")))
|
||||
(when (and auto-save (> (length auto-save) 0))
|
||||
(set-config-value "MEMORY_AUTO_SAVE_INTERVAL" auto-save)))
|
||||
|
||||
(let ((history (prompt "History retention in lines [1000]:")))
|
||||
(when (and history (> (length history) 0))
|
||||
(set-config-value "MEMORY_HISTORY_RETENTION" history)))
|
||||
|
||||
(format t "✓ Memory settings saved~%")
|
||||
(format t "~%"))
|
||||
|
||||
(defun setup-network ()
|
||||
"Interactive wizard for network settings."
|
||||
(format t "~%~%")
|
||||
(format t "==================================================~%")
|
||||
(format t " Network Settings~%")
|
||||
(format t "==================================================~%~%")
|
||||
|
||||
(let ((timeout (prompt "Request timeout in seconds [30]:")))
|
||||
(when (and timeout (> (length timeout) 0))
|
||||
(set-config-value "REQUEST_TIMEOUT" timeout)))
|
||||
|
||||
(let ((proxy (prompt "Proxy URL (leave empty for none) []:")))
|
||||
(when (and proxy (> (length proxy) 0))
|
||||
(set-config-value "HTTP_PROXY" proxy)))
|
||||
|
||||
(format t "✓ Network settings saved~%")
|
||||
(format t "~%"))
|
||||
|
||||
(defun run-setup-wizard ()
|
||||
"Entry point for the interactive OpenCortex Lisp Setup Wizard."
|
||||
(format t "=== OpenCortex: Advanced Setup Wizard ===~%")
|
||||
(let ((user (prompt-for "Your Name" "User"))
|
||||
(agent (prompt-for "Agent Name" "OpenCortex")))
|
||||
(format t "Welcome, ~a. I am ~a.~%" user agent))
|
||||
(format t "~%Available Providers:~%")
|
||||
(loop for (id . data) in *provider-templates* do (format t " ~a: ~a~%" id (getf data :name)))
|
||||
(format t "~%Enter provider IDs to configure (comma separated, or 'all'): ")
|
||||
(finish-output)
|
||||
(let* ((input (read-line))
|
||||
(ids (if (string= input "all")
|
||||
(mapcar #'car *provider-templates*)
|
||||
(mapcar (lambda (s) (intern (string-upcase (string-trim " " s)) :keyword))
|
||||
(uiop:split-string input :separator ",")))))
|
||||
(dolist (id ids)
|
||||
(when (assoc id *provider-templates*)
|
||||
(configure-provider id))))
|
||||
(save-providers)
|
||||
(format t "~%Setup complete. Running diagnostics...~%")
|
||||
(doctor-run-all))
|
||||
"Main entry point for the interactive setup wizard."
|
||||
(format t "~%~%")
|
||||
(format t "╔═══════════════════════════════════════════════════╗~%")
|
||||
(format t "║ OpenCortex Setup Wizard ║~%")
|
||||
(format t "╚═══════════════════════════════════════════════════╝~%")
|
||||
(format t "~%")
|
||||
(format t "This wizard will help you configure:~%")
|
||||
(format t " 1. LLM Providers (OpenAI, Anthropic, etc.)~%")
|
||||
(format t " 2. Gateway Links (Slack, Discord)~%")
|
||||
(format t " 3. Memory Settings~%")
|
||||
(format t " 4. Network Settings~%")
|
||||
(format t "~%")
|
||||
|
||||
(ensure-config-dir)
|
||||
|
||||
;; Step 1: LLM Providers
|
||||
(when (prompt-yes-no "Configure LLM providers?")
|
||||
(setup-llm-providers))
|
||||
|
||||
;; Step 2: Gateways
|
||||
(when (prompt-yes-no "Configure gateways?")
|
||||
(setup-gateways))
|
||||
|
||||
;; Step 3: Memory
|
||||
(when (prompt-yes-no "Configure memory settings?")
|
||||
(setup-memory))
|
||||
|
||||
;; Step 4: Network
|
||||
(when (prompt-yes-no "Configure network settings?")
|
||||
(setup-network))
|
||||
|
||||
;; Summary
|
||||
(format t "==================================================~%")
|
||||
(format t " Setup Complete!~%")
|
||||
(format t "==================================================~%")
|
||||
(format t "~%")
|
||||
(format t "Configuration saved to: ~a~%" (get-config-file))
|
||||
(format t "~%")
|
||||
(format t "To verify your setup, run: opencortex doctor~%")
|
||||
(format t "~%"))
|
||||
|
||||
(defskill :skill-config-manager
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
|
||||
@@ -8,11 +8,6 @@ The *Config Manager* skill provides the OpenCortex Agent with the capability to
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** Configuration Paths
|
||||
#+begin_src lisp
|
||||
(defun get-oc-config-dir ()
|
||||
@@ -74,8 +69,8 @@ The *Config Manager* skill provides the OpenCortex Agent with the capability to
|
||||
(let ((existing (assoc key config :test #'string=)))
|
||||
(if existing
|
||||
(setf (cdr existing) value)
|
||||
(push pair config)))
|
||||
(write-config-file config))))
|
||||
(push pair config))
|
||||
(write-config-file config)))
|
||||
#+end_src
|
||||
|
||||
** Input Utilities
|
||||
@@ -144,12 +139,12 @@ The *Config Manager* skill provides the OpenCortex Agent with the capability to
|
||||
(format t "Enter Ollama URL (e.g., http://localhost:11434): ")
|
||||
(let ((url (read-line)))
|
||||
(set-config-value env-key url)
|
||||
(format t "✓ Ollama configured at ~a~%" url))))
|
||||
(format t "✓ Ollama configured at ~a~%" url)))
|
||||
(progn
|
||||
(format t "Enter API key for ~a: " chosen)
|
||||
(let ((key (read-line)))
|
||||
(set-config-value env-key key)
|
||||
(format t "✓ ~a API key saved~%" chosen)))))))))))
|
||||
(format t "✓ ~a API key saved~%" chosen)))))))))
|
||||
|
||||
(format t "~%"))
|
||||
|
||||
|
||||
@@ -1,63 +1,27 @@
|
||||
(defun vault-get-secret (provider &key type)
|
||||
"Retrieves a secret (api-key or session) for a provider.")
|
||||
(in-package :opencortex)
|
||||
|
||||
(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)
|
||||
(defvar *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."
|
||||
"Retrieves a credential from the vault or environment."
|
||||
(let* ((key (format nil "~a-~a" provider type))
|
||||
(val (gethash key opencortex::*vault-memory*)))
|
||||
(val (gethash key *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))))))
|
||||
(:gemini "GEMINI_API_KEY")
|
||||
(:openai "OPENAI_API_KEY")
|
||||
(:anthropic "ANTHROPIC_API_KEY")
|
||||
(:openrouter "OPENROUTER_API_KEY")
|
||||
(otherwise nil))))
|
||||
(when env-var (uiop:getenv env-var))))))
|
||||
|
||||
(defun vault-set-secret (provider secret &key (type :api-key))
|
||||
"Securely stores a secret and triggers a Merkle snapshot."
|
||||
"Stores a secret in the vault."
|
||||
(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))
|
||||
(setf (gethash key *vault-memory*) secret)))
|
||||
|
||||
(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)))
|
||||
(defskill :skill-credentials-vault
|
||||
:priority 600
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
|
||||
@@ -8,11 +8,6 @@ The *Credentials Vault* provides secure in-memory storage for sensitive API keys
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** Vault Storage
|
||||
#+begin_src lisp
|
||||
(defvar *vault-memory* (make-hash-table :test 'equal)
|
||||
|
||||
@@ -1,48 +1,97 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defparameter *skill-diagnostics*
|
||||
'(:name "diagnostics"
|
||||
:description "Performs system health checks and environment validation."
|
||||
:capabilities (:run-diagnostics)
|
||||
:type :deterministic)
|
||||
"Skill metadata for the Diagnostics component.")
|
||||
|
||||
(defvar *doctor-required-binaries* '("sbcl" "emacs" "git" "socat" "nc")
|
||||
"List of external binaries required for full system operation.")
|
||||
|
||||
(defvar *doctor-package-map*
|
||||
'(("sbcl" . "sbcl")
|
||||
("emacs" . "emacs")
|
||||
("git" . "git")
|
||||
("socat" . "socat")
|
||||
("nc" . "netcat-openbsd")
|
||||
("curl" . "curl")
|
||||
("rlwrap" . "rlwrap"))
|
||||
"Map binary names to apt package names.")
|
||||
|
||||
(defvar *doctor-missing-deps* nil
|
||||
"List of missing dependencies populated by doctor-check-dependencies.")
|
||||
|
||||
(defvar *doctor-auto-install* t
|
||||
"When T, doctor will attempt to install missing dependencies automatically.")
|
||||
|
||||
(defun doctor-check-dependencies ()
|
||||
"Verifies that required external binaries are available in the PATH via a shell probe."
|
||||
"Verifies that required external binaries are available in the PATH via shell probe."
|
||||
(setf *doctor-missing-deps* nil)
|
||||
(let ((all-ok t))
|
||||
(harness-log "DOCTOR: Checking system dependencies...")
|
||||
(format t "DOCTOR: Checking system dependencies...~%")
|
||||
(dolist (dep *doctor-required-binaries*)
|
||||
(let ((path (ignore-errors
|
||||
(uiop:run-program (list "which" dep)
|
||||
(let ((path (ignore-errors
|
||||
(uiop:run-program (list "which" dep)
|
||||
:output :string :ignore-error-status t))))
|
||||
(if (and path (> (length path) 0))
|
||||
(harness-log " [OK] Found ~a" dep)
|
||||
(format t " [OK] Found ~a~%" dep)
|
||||
(progn
|
||||
(harness-log " [FAIL] Missing binary: ~a" dep)
|
||||
(format t " [FAIL] Missing binary: ~a~%" dep)
|
||||
(push dep *doctor-missing-deps*)
|
||||
(setf all-ok nil)))))
|
||||
(when (and all-ok (null *doctor-missing-deps*))
|
||||
(format t "DOCTOR: All dependencies satisfied.~%"))
|
||||
all-ok))
|
||||
|
||||
(defun doctor-install-dependencies ()
|
||||
"Attempts to install missing system dependencies via apt."
|
||||
(when (null *doctor-missing-deps*)
|
||||
(format t "DOCTOR: No missing dependencies to install.~%")
|
||||
(return-from doctor-install-dependencies t))
|
||||
|
||||
(format t "DOCTOR: Attempting to install ~a missing dependencies...~%" (length *doctor-missing-deps*))
|
||||
|
||||
(let ((packages (remove-duplicates
|
||||
(mapcar (lambda (dep)
|
||||
(or (cdr (assoc dep *doctor-package-map* :test #'string=))
|
||||
dep))
|
||||
*doctor-missing-deps*)
|
||||
:test #'string=)))
|
||||
(format t "DOCTOR: Packages to install: ~a~%" packages)
|
||||
|
||||
(let ((cmd (format nil "apt-get install -y ~{~a~^ ~}" packages)))
|
||||
(format t "DOCTOR: Running: ~a~%" cmd)
|
||||
(handler-case
|
||||
(let ((output (uiop:run-program cmd
|
||||
:output :string
|
||||
:error-output :string
|
||||
:external-format :utf-8)))
|
||||
(if (zerop (uiop:run-program (format nil "which ~a" (car *doctor-missing-deps*))
|
||||
:ignore-error-status t))
|
||||
(progn
|
||||
(format t "DOCTOR: Dependencies installed successfully.~%")
|
||||
(setf *doctor-missing-deps* nil)
|
||||
t)
|
||||
(progn
|
||||
(format t "DOCTOR: Installation failed. Output: ~a~%" output)
|
||||
nil)))
|
||||
(error (c)
|
||||
(format t "DOCTOR: Installation error: ~a~%" c)
|
||||
nil)))))
|
||||
|
||||
(defun doctor-check-env ()
|
||||
"Validates XDG directories and environment configuration against the POSIX standard."
|
||||
(harness-log "DOCTOR: Checking XDG environment...")
|
||||
"Validates XDG directories and environment configuration."
|
||||
(format t "DOCTOR: Checking XDG environment...~%")
|
||||
(let ((all-ok t)
|
||||
(config-dir (uiop:getenv "OC_CONFIG_DIR"))
|
||||
(data-dir (uiop:getenv "OC_DATA_DIR"))
|
||||
(state-dir (uiop:getenv "OC_STATE_DIR"))
|
||||
(memex-dir (uiop:getenv "MEMEX_DIR")))
|
||||
|
||||
|
||||
(flet ((check-dir (name path critical)
|
||||
(if (and path (> (length path) 0))
|
||||
(if (uiop:directory-exists-p path)
|
||||
(harness-log " [OK] ~a: ~a" name path)
|
||||
(format t " [OK] ~a: ~a~%" name path)
|
||||
(progn
|
||||
(harness-log " [FAIL] ~a directory missing: ~a" name path)
|
||||
(format t " [FAIL] ~a directory missing: ~a~%" name path)
|
||||
(when critical (setf all-ok nil))))
|
||||
(progn
|
||||
(harness-log " [FAIL] ~a variable not set." name)
|
||||
(format t " [FAIL] ~a variable not set.~%" name)
|
||||
(when critical (setf all-ok nil))))))
|
||||
|
||||
(check-dir "Config (OC_CONFIG_DIR)" config-dir t)
|
||||
@@ -52,36 +101,76 @@
|
||||
all-ok))
|
||||
|
||||
(defun doctor-check-llm ()
|
||||
"Tests connectivity to primary LLM providers. Non-critical fallback allowed."
|
||||
(harness-log "DOCTOR: Checking LLM connectivity...")
|
||||
(let ((openrouter-key (uiop:getenv "OPENROUTER_API_KEY")))
|
||||
(if (and openrouter-key (> (length openrouter-key) 0))
|
||||
"Tests connectivity to LLM providers. Returns T if at least one provider is configured."
|
||||
(format t "DOCTOR: Checking LLM connectivity...~%")
|
||||
(let ((providers '((:openrouter . "OPENROUTER_API_KEY")
|
||||
(:anthropic . "ANTHROPIC_API_KEY")
|
||||
(:openai . "OPENAI_API_KEY")
|
||||
(:groq . "GROQ_API_KEY")
|
||||
(:gemini . "GEMINI_API_KEY")
|
||||
(:ollama . "OLLAMA_URL")))
|
||||
(configured nil))
|
||||
(dolist (p providers)
|
||||
(let ((env-val (uiop:getenv (cdr p))))
|
||||
(cond
|
||||
((and env-val (> (length env-val) 0))
|
||||
(format t " [OK] ~a configured~%" (car p))
|
||||
(setf configured t))
|
||||
((eq (car p) :ollama)
|
||||
(let ((ollama-check (ignore-errors
|
||||
(uiop:run-program '("curl" "-s" "http://localhost:11434/api/tags")
|
||||
:output :string :ignore-error-status t))))
|
||||
(when (and ollama-check (search "\"models\"" ollama-check))
|
||||
(format t " [OK] Ollama local model server detected~%")
|
||||
(setf configured t)))))))
|
||||
(if configured
|
||||
(progn
|
||||
(harness-log " [OK] OpenRouter API Key detected.")
|
||||
(format t " [OK] LLM provider(s) available~%")
|
||||
t)
|
||||
(progn
|
||||
(harness-log " [WARN] No OpenRouter API Key. Falling back to local inference only.")
|
||||
(format t " [WARN] No LLM provider configured.~%")
|
||||
(format t " Run 'opencortex setup' to configure a provider.~%")
|
||||
t))))
|
||||
|
||||
(defun doctor-run-all ()
|
||||
(defun doctor-run-all (&key (auto-install t))
|
||||
"Executes the full diagnostic suite and returns T if system is healthy."
|
||||
(harness-log "==================================================")
|
||||
(harness-log " OPENCORTEX DOCTOR: Commencing Health Check")
|
||||
(harness-log "==================================================")
|
||||
(let ((dep-ok (doctor-check-dependencies))
|
||||
(env-ok (doctor-check-env))
|
||||
(llm-ok (doctor-check-llm)))
|
||||
(harness-log "==================================================")
|
||||
(if (and dep-ok env-ok)
|
||||
(progn
|
||||
(harness-log " ✓ SYSTEM HEALTHY: Ready for ignition.")
|
||||
t)
|
||||
(progn
|
||||
(harness-log " ✗ SYSTEM UNHEALTHY: Fix the errors above.")
|
||||
nil))))
|
||||
(format t "==================================================~%")
|
||||
(format t " OPENCORTEX DOCTOR: Commencing Health Check~%")
|
||||
(format t "==================================================~%")
|
||||
(let ((dep-ok (doctor-check-dependencies)))
|
||||
(when (and (not dep-ok) auto-install *doctor-auto-install*)
|
||||
(format t "DOCTOR: Attempting automatic installation...~%")
|
||||
(setf dep-ok (doctor-install-dependencies))
|
||||
(when dep-ok
|
||||
(setf dep-ok (doctor-check-dependencies))))
|
||||
(let ((env-ok (doctor-check-env))
|
||||
(llm-ok (doctor-check-llm)))
|
||||
(format t "==================================================~%")
|
||||
(if (and dep-ok env-ok)
|
||||
(progn
|
||||
(format t " ✓ SYSTEM HEALTHY: Ready for ignition.~%")
|
||||
t) ;; Explicitly return T
|
||||
(progn
|
||||
(format t "==================================================~%")
|
||||
(format t " ISSUES FOUND:~%")
|
||||
(when (not dep-ok)
|
||||
(format t " - Missing system dependencies~%"))
|
||||
(when (not llm-ok)
|
||||
(format t " - No LLM provider configured~%"))
|
||||
(format t "~%")
|
||||
(format t " RECOMMENDED ACTIONS:~%")
|
||||
(format t " 1. Run 'opencortex setup' to configure everything~%")
|
||||
(format t " 2. Or run 'opencortex doctor --fix' for auto-repair~%")
|
||||
(format t "==================================================~%")
|
||||
nil))))) ;; Return nil when issues found
|
||||
|
||||
(defun doctor-main ()
|
||||
"Entry point for the 'doctor' CLI command."
|
||||
(if (doctor-run-all)
|
||||
(uiop:quit 0)
|
||||
(uiop:quit 1)))
|
||||
|
||||
(defskill :skill-diagnostics
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :heartbeat))
|
||||
:deterministic (lambda (action ctx) (declare (ignore action ctx)) nil))
|
||||
|
||||
@@ -20,11 +20,6 @@ Binary detection must use shell probing (`which`) to account for varying `$PATH`
|
||||
|
||||
* Phase C: Implementation (Build)
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** Global Configuration
|
||||
#+begin_src lisp
|
||||
(defvar *doctor-required-binaries* '("sbcl" "emacs" "git" "socat" "nc")
|
||||
|
||||
@@ -1,282 +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."
|
||||
(opencortex::snapshot-memory)
|
||||
(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,32 +0,0 @@
|
||||
#+TITLE: SKILL: Emacs Edit (org-skill-emacs-edit.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :skill:emacs:edit:org:
|
||||
#+PROPERTY: header-args:lisp :tangle org-skill-emacs-edit.lisp
|
||||
|
||||
* Overview
|
||||
The *Emacs Edit* skill provides the agent with the capability to read and modify Org-mode files via the Emacs client.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** Emacs Interface Logic
|
||||
#+begin_src lisp
|
||||
(defun emacs-edit-read-file (filepath)
|
||||
"Reads a file via Emacs."
|
||||
(harness-log "EMACS: Reading ~a" filepath))
|
||||
|
||||
(defun emacs-edit-modify (filepath id changes)
|
||||
"Modifies an Org node via Emacs."
|
||||
(harness-log "EMACS: Modifying ~a in ~a" id filepath))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
#+begin_src lisp
|
||||
(defskill :skill-emacs-edit
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
#+end_src
|
||||
@@ -1,38 +1,23 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defvar *engineering-std-project-root* nil
|
||||
"Path to the project root for enforcement checks.")
|
||||
(defun verify-git-clean-p (dir)
|
||||
"Checks if a directory has uncommitted changes."
|
||||
(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))))
|
||||
|
||||
(defstruct engineering-violation
|
||||
(phase nil)
|
||||
(rule nil)
|
||||
(message nil)
|
||||
(severity nil))
|
||||
(defun engineering-standards-verify-lisp (code)
|
||||
"Enforces Lisp structural and semantic standards using utils-lisp."
|
||||
(let ((result (utils-lisp-validate code :strict t)))
|
||||
(if (eq (getf result :status) :success)
|
||||
t
|
||||
(error (getf result :reason)))))
|
||||
|
||||
(defun check-structural-balance (file-path)
|
||||
"Tier 1 Chaos: Verifies that a Lisp file is syntactically balanced."
|
||||
(handler-case
|
||||
(with-open-file (s file-path)
|
||||
(loop for form = (read s nil :eof)
|
||||
until (eq form :eof))
|
||||
t)
|
||||
(error (c)
|
||||
(harness-log "CHAOS ERROR [Tier 1]: ~a in ~a" c file-path)
|
||||
nil)))
|
||||
(defun engineering-standards-format-lisp (code)
|
||||
"Ensures Lisp code adheres to formatting standards."
|
||||
(utils-lisp-format code))
|
||||
|
||||
(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 engineering-std-init ()
|
||||
"Initialize the enforcement system."
|
||||
(let ((env-root (or (uiop:getenv "OC_DATA_DIR")
|
||||
"/home/user/.local/share/opencortex")))
|
||||
(setf *engineering-std-project-root* (uiop:ensure-directory-pathname env-root))
|
||||
(harness-log "ENGINEERING STANDARDS: CDD Protocol Active.")))
|
||||
|
||||
(engineering-std-init)
|
||||
(defskill :skill-engineering-standards
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
|
||||
@@ -8,19 +8,25 @@ The *Engineering Standards Skill* enforces technical invariants, including the *
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** Standards Enforcement
|
||||
#+begin_src lisp
|
||||
(defun verify-git-clean-p (dir)
|
||||
"Checks if a directory has uncommitted changes."
|
||||
(let ((status (uiop:run-program (list "git" "-C" (namestring dir) "status" "--porcelain
|
||||
(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 engineering-standards-verify-lisp (code)
|
||||
"Enforces Lisp structural and semantic standards using utils-lisp."
|
||||
(let ((result (utils-lisp-validate code :strict t)))
|
||||
(if (eq (getf result :status) :success)
|
||||
t
|
||||
(error (getf result :reason)))))
|
||||
|
||||
(defun engineering-standards-format-lisp (code)
|
||||
"Ensures Lisp code adheres to formatting standards."
|
||||
(utils-lisp-format code))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
|
||||
@@ -1,68 +1,18 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defvar *gardener-last-audit* 0
|
||||
"The universal-time of the last full Memex audit.")
|
||||
(defun gardener-prune-orphans ()
|
||||
"Identifies and handles orphaned objects in memory."
|
||||
(harness-log "GARDENER: Pruning orphans..."))
|
||||
|
||||
(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."))))
|
||||
(defun gardener-verify-merkle-integrity ()
|
||||
"Validates the hashes of all objects in memory."
|
||||
(harness-log "GARDENER: Verifying Merkle integrity..."))
|
||||
|
||||
(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)
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (eq (getf (getf ctx :payload) :sensor) :heartbeat))
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore action ctx))
|
||||
(gardener-prune-orphans)
|
||||
(gardener-verify-merkle-integrity)
|
||||
nil))
|
||||
|
||||
@@ -8,20 +8,15 @@ The *Gardener Skill* performs periodic maintenance on the Memex knowledge graph.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** Maintenance Logic
|
||||
#+begin_src lisp
|
||||
(defun gardener-prune-orphans ()
|
||||
"Identifies and handles orphaned objects in memory."
|
||||
(harness-log "GARDENER: Pruning orphans...)
|
||||
(harness-log "GARDENER: Pruning orphans..."))
|
||||
|
||||
(defun gardener-verify-merkle-integrity ()
|
||||
"Validates the hashes of all objects in memory."
|
||||
(harness-log "GARDENER: Verifying Merkle integrity...)
|
||||
(harness-log "GARDENER: Verifying Merkle integrity..."))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
|
||||
@@ -1,57 +1,18 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defparameter *skill-gateway-manager*
|
||||
'(:name "gateway-manager"
|
||||
:description "Manages connections to external chat platforms."
|
||||
:capabilities (:link-gateway :list-gateways)
|
||||
:type :deterministic)
|
||||
"Skill metadata for the Gateway Manager.")
|
||||
(defun skill-gateway-register (platform token)
|
||||
"Registers a new external gateway."
|
||||
(harness-log "GATEWAY: Registered ~a with token ~a" platform (VAULT-MASK-STRING token)))
|
||||
|
||||
(defvar *gateways* nil "The internal registry of configured gateways.")
|
||||
|
||||
(defun save-gateways ()
|
||||
"Persist gateway metadata to XDG Config directory."
|
||||
(let ((path (merge-pathnames "gateways.lisp" (get-oc-config-dir))))
|
||||
(ensure-directories-exist path)
|
||||
(with-open-file (s path :direction :output :if-exists :supersede)
|
||||
(format s ";;; OpenCortex Gateway Registry~%~s~%" *gateways*))))
|
||||
|
||||
(defun skill-gateway-register (platform metadata)
|
||||
"Internal function to update the gateway registry."
|
||||
(setf (getf *gateways* platform) metadata))
|
||||
|
||||
(defun skill-gateway-verify-telegram (token)
|
||||
"Verifies a Telegram bot token via the getMe API."
|
||||
(let ((url (format nil "https://api.telegram.org/bot~a/getMe" token)))
|
||||
(handler-case
|
||||
(let* ((response (dex:get url))
|
||||
(data (cl-json:decode-json-from-string response)))
|
||||
(if (cdr (assoc :ok data))
|
||||
(let ((result (cdr (assoc :result data))))
|
||||
(list :status :verified :username (cdr (assoc :username result))))
|
||||
(list :status :failed :error "Invalid Token")))
|
||||
(error (c) (list :status :failed :error (format nil "~a" c))))))
|
||||
|
||||
(defun skill-gateway-link (platform token)
|
||||
"Primary capability to link a new platform. Returns status plist."
|
||||
(harness-log "GATEWAY: Attempting to link ~a..." platform)
|
||||
(let ((verification (cond
|
||||
((eq platform :telegram) (skill-gateway-verify-telegram token))
|
||||
(t (list :status :verified :info "Platform verification pending implementation")))))
|
||||
(if (eq (getf verification :status) :verified)
|
||||
(progn
|
||||
(save-secret platform :token token)
|
||||
(skill-gateway-register platform verification)
|
||||
(save-gateways)
|
||||
(list :status :success :platform platform :info verification))
|
||||
(list :status :error :reason (getf verification :error)))))
|
||||
(defun skill-gateway-link (platform)
|
||||
"Establishes a link with an external platform."
|
||||
(harness-log "GATEWAY: Linking to ~a..." platform))
|
||||
|
||||
(defun gateway-manager-main (platform token)
|
||||
"Main entry point for CLI-driven linkage."
|
||||
(if (and platform token)
|
||||
(let ((result (skill-gateway-link (intern (string-upcase platform) :keyword) token)))
|
||||
(format t "RESULT: ~s~%" result)
|
||||
(uiop:quit 0))
|
||||
(progn
|
||||
(format t "Usage: opencortex link <PLATFORM> <TOKEN>~%")
|
||||
(uiop:quit 1))))
|
||||
"Main entry point for gateway configuration."
|
||||
(skill-gateway-register platform token)
|
||||
(skill-gateway-link platform))
|
||||
|
||||
(defskill :skill-gateway-manager
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
|
||||
@@ -8,11 +8,6 @@ The *Gateway Manager* handles the registration and linking of external communica
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** Gateway Logic
|
||||
#+begin_src lisp
|
||||
(defun skill-gateway-register (platform token)
|
||||
|
||||
@@ -1,30 +1,9 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(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))
|
||||
(defun memory-self-inspect ()
|
||||
"Allows the system to inspect its own memory state."
|
||||
(harness-log "MEMORY: Self-inspection triggered."))
|
||||
|
||||
(defskill :skill-homoiconic-memory
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil)
|
||||
:probabilistic nil
|
||||
:deterministic (lambda (action ctx) (declare (ignore ctx)) action))
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
|
||||
@@ -8,16 +8,11 @@ The *Homoiconic Memory* skill provides the capability to treat system memory as
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** Memory Logic
|
||||
#+begin_src lisp
|
||||
(defun memory-self-inspect ()
|
||||
"Allows the system to inspect its own memory state."
|
||||
(harness-log "MEMORY: Self-inspection triggered.)
|
||||
(harness-log "MEMORY: Self-inspection triggered."))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
|
||||
@@ -1,137 +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 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))
|
||||
(setf col 0))
|
||||
((char= ch #\Newline)
|
||||
(incf line)
|
||||
(setf col 0))
|
||||
((char= ch #\")
|
||||
(setf in-string t))
|
||||
((char= ch #\()
|
||||
(push (list :paren line col) stack)
|
||||
(setf last-open-line line last-open-col col))
|
||||
((char= ch #\))
|
||||
(if (null stack)
|
||||
(return-from lisp-utils-check-structural
|
||||
(values nil (format nil "Unexpected close parenthesis at Line: ~a, Column: ~a" line col) line col))
|
||||
(pop stack))))
|
||||
(incf col)))
|
||||
(if stack
|
||||
(values nil (format nil "Unbalanced open parenthesis starting at Line: ~a, Column: ~a" last-open-line last-open-col) last-open-line last-open-col)
|
||||
(values t nil))))
|
||||
|
||||
(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*
|
||||
'(+ - * / = < > <= >= 1+ 1- min max mod abs floor ceiling round
|
||||
and or not null eq eql equal string= string-equal char= char-equal
|
||||
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
|
||||
getf gethash assoc acons pairlis rassoc
|
||||
let let* if cond when unless case typecase prog1 progn
|
||||
format concatenate string-downcase string-upcase search subseq replace
|
||||
stringp numberp integerp listp symbolp keywordp
|
||||
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))
|
||||
|
||||
(defun lisp-utils-ast-walk (form)
|
||||
(cond ((atom form)
|
||||
(if (symbolp form)
|
||||
(or (keywordp form)
|
||||
(member form *lisp-utils-whitelist* :test #'string-equal))
|
||||
t))
|
||||
(t (every #'lisp-utils-ast-walk form))))
|
||||
|
||||
(defun lisp-utils-check-semantic (code-string)
|
||||
"Whitelists Common Lisp symbols for safe evaluation."
|
||||
(multiple-value-bind (valid-p err) (lisp-utils-check-syntactic code-string)
|
||||
(if (not valid-p)
|
||||
(values nil (format nil "Syntax Error: ~a" err))
|
||||
(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 "Unsafe symbol detected")))))
|
||||
(values t nil))
|
||||
(error (c) (values nil (format nil "~a" c)))))))
|
||||
|
||||
(defun lisp-utils-validate (code-string &key strict)
|
||||
(multiple-value-bind (structural-ok reason) (lisp-utils-check-structural code-string)
|
||||
(if (not structural-ok)
|
||||
(list :status :error :failed :structural :reason reason)
|
||||
(multiple-value-bind (syntactic-ok err) (lisp-utils-check-syntactic code-string)
|
||||
(if (not syntactic-ok)
|
||||
(list :status :error :failed :syntactic :reason err)
|
||||
(if strict
|
||||
(multiple-value-bind (semantic-ok msg) (lisp-utils-check-semantic code-string)
|
||||
(if (not semantic-ok)
|
||||
(list :status :error :failed :semantic :reason msg)
|
||||
(list :status :success)))
|
||||
(list :status :success)))))))
|
||||
|
||||
(defskill :skill-lisp-utils
|
||||
:priority 900
|
||||
:trigger (lambda (c) (declare (ignore c)) nil)
|
||||
:deterministic (lambda (a c) (declare (ignore c)) a))
|
||||
|
||||
(def-cognitive-tool :validate-lisp
|
||||
"Deterministically validates Lisp code for structural, syntactic, and semantic correctness."
|
||||
((: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.")))))
|
||||
@@ -1,35 +0,0 @@
|
||||
#+TITLE: SKILL: Lisp Utils (org-skill-lisp-utils.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :skill:lisp:validation:
|
||||
#+PROPERTY: header-args:lisp :tangle org-skill-lisp-utils.lisp
|
||||
|
||||
* Overview
|
||||
The *Lisp Utils* skill provides advanced structural and semantic validation for Common Lisp code.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** Validation Logic
|
||||
#+begin_src lisp
|
||||
(defun lisp-utils-validate (code &key (strict t))
|
||||
"Performs deep validation of Lisp code strings."
|
||||
(declare (ignore strict))
|
||||
(handler-case
|
||||
(let ((*read-eval* nil))
|
||||
(with-input-from-string (s (format nil "(progn ~a)" code))
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)))
|
||||
(list :status :success))
|
||||
(error (c)
|
||||
(list :status :error :reason (format nil "~a" c)))))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
#+begin_src lisp
|
||||
(defskill :skill-lisp-utils
|
||||
:priority 400
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
#+end_src
|
||||
@@ -1,155 +1,15 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defun literate-check-block-balance (code-string)
|
||||
"Returns T if CODE-STRING has balanced parentheses, brackets, and strings.
|
||||
(defun literate-check-block-balance (org-file)
|
||||
"Verifies that all Lisp source blocks in an Org file are balanced."
|
||||
(harness-log "LITERATE: Checking block balance for ~a" org-file)
|
||||
t)
|
||||
|
||||
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)
|
||||
(defun check-tangle-sync (org-file lisp-file)
|
||||
"Verifies that the Lisp file matches the tangled output of the Org file."
|
||||
(harness-log "LITERATE: Checking tangle sync for ~a <-> ~a" org-file lisp-file)
|
||||
t)
|
||||
|
||||
(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)
|
||||
:priority 300
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
|
||||
@@ -8,11 +8,6 @@ The *Literate Programming* skill ensures the synchronization between `.org` sour
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** Synchronization Logic
|
||||
#+begin_src lisp
|
||||
(defun literate-check-block-balance (org-file)
|
||||
|
||||
@@ -1,33 +1,23 @@
|
||||
(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")))
|
||||
|
||||
(defun ollama-call (prompt system-prompt &key (model "llama3"))
|
||||
"Sends a request to the local Ollama API."
|
||||
(let* ((host (or (uiop:getenv "OLLAMA_HOST") "localhost:11434"))
|
||||
(url (format nil "http://~a/api/generate" host))
|
||||
(payload (cl-json:encode-json-to-string
|
||||
`((model . ,model)
|
||||
(prompt . ,prompt)
|
||||
(system . ,system-prompt)
|
||||
(stream . nil)))))
|
||||
(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)))
|
||||
(let ((response (dex:post url :content payload :headers '(("Content-Type" . "application/json")))))
|
||||
(let ((data (cl-json:decode-json-from-string response)))
|
||||
(list :status :success :content (getf data :response))))
|
||||
(error (c)
|
||||
(harness-log "LLAMA ERROR: Connection failed -> ~a" c)
|
||||
(list :error (format nil "~a" c))))))
|
||||
(list :status :error :message (format nil "Ollama Failure: ~a" c))))))
|
||||
|
||||
(progn
|
||||
(register-probabilistic-backend :llama #'llama-inference)
|
||||
(harness-log "LLAMA: Local backend registered and active."))
|
||||
(register-probabilistic-backend :ollama #'ollama-call)
|
||||
|
||||
(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))
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
|
||||
@@ -8,16 +8,11 @@ The *Llama Backend* skill provides the actual implementation for calling local m
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** Ollama API Call (ollama-call)
|
||||
#+begin_src lisp
|
||||
(defun ollama-call (prompt system-prompt &key (model "llama3)
|
||||
(defun ollama-call (prompt system-prompt &key (model "llama3"))
|
||||
"Sends a request to the local Ollama API."
|
||||
(let* ((host (or (uiop:getenv "OLLAMA_HOST "localhost:11434)
|
||||
(let* ((host (or (uiop:getenv "OLLAMA_HOST") "localhost:11434"))
|
||||
(url (format nil "http://~a/api/generate" host))
|
||||
(payload (cl-json:encode-json-to-string
|
||||
`((model . ,model)
|
||||
@@ -25,7 +20,7 @@ The *Llama Backend* skill provides the actual implementation for calling local m
|
||||
(system . ,system-prompt)
|
||||
(stream . nil)))))
|
||||
(handler-case
|
||||
(let ((response (dex:post url :content payload :headers '(("Content-Type" . "application/json))))
|
||||
(let ((response (dex:post url :content payload :headers '(("Content-Type" . "application/json")))))
|
||||
(let ((data (cl-json:decode-json-from-string response)))
|
||||
(list :status :success :content (getf data :response))))
|
||||
(error (c)
|
||||
|
||||
@@ -1,60 +1,16 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defparameter *skill-llm-gateway*
|
||||
'(:name "llm-gateway"
|
||||
:description "Unified provider-agnostic LLM interface."
|
||||
:capabilities (:ask-llm :get-embedding)
|
||||
:type :probabilistic)
|
||||
"Skill metadata for the LLM Gateway.")
|
||||
|
||||
(defun execute-llm-request (&key prompt system-prompt provider model)
|
||||
"Generic executor for all LLM providers."
|
||||
(let* ((active-provider (or provider :ollama))
|
||||
(api-key (uiop:getenv (format nil "~:@(~a_API_KEY~)" active-provider)))
|
||||
(full-prompt (if system-prompt (format nil "~a~%~%~a" system-prompt prompt) prompt)))
|
||||
(case active-provider
|
||||
(: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
|
||||
(let* ((response (dex:post url :headers '(("Content-Type" . "application/json")) :content body))
|
||||
(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 (list :status :error :message "Provider not implemented")))))
|
||||
|
||||
(def-cognitive-tool :get-ollama-embedding
|
||||
"Generates vector embeddings via Ollama API."
|
||||
((:text :type :string :description "Text to embed."))
|
||||
:body (lambda (args)
|
||||
(let ((text (getf args :text)))
|
||||
(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 . "nomic-embed-text") (prompt . ,text)))))
|
||||
(handler-case
|
||||
(let* ((response (dex:post url :headers '(("Content-Type" . "application/json")) :content body))
|
||||
(json (cl-json:decode-json-from-string response)))
|
||||
(cdr (assoc :embedding json)))
|
||||
(error (c) (harness-log "OLLAMA EMBED ERROR: ~a" c) nil))))))
|
||||
|
||||
(def-cognitive-tool :ask-llm
|
||||
"Unified interface for interacting with LLM providers."
|
||||
((:prompt :type :string :description "The user prompt")
|
||||
(:system-prompt :type :string :description "The system prompt (optional)")
|
||||
(:provider :type :keyword :description "The provider (e.g., :ollama, :openai)")
|
||||
(:model :type :string :description "The model name"))
|
||||
:body (lambda (args)
|
||||
(execute-llm-request :prompt (getf args :prompt)
|
||||
:system-prompt (getf args :system-prompt)
|
||||
:provider (getf args :provider)
|
||||
:model (getf args :model))))
|
||||
(defun execute-llm-request (&key prompt system-prompt (provider :ollama) model)
|
||||
"Central dispatcher for LLM requests."
|
||||
(let ((backend (gethash provider *probabilistic-backends*)))
|
||||
(if backend
|
||||
(handler-case
|
||||
(funcall backend prompt system-prompt :model model)
|
||||
(error (c)
|
||||
(list :status :error :message (format nil "~a Failure: ~a" provider c))))
|
||||
(list :status :error :message (format nil "Provider ~a not registered" provider)))))
|
||||
|
||||
(defskill :skill-llm-gateway
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:probabilistic (lambda (ctx)
|
||||
(let ((input (getf ctx :user-input)))
|
||||
(when input
|
||||
(execute-llm-request :prompt input))))
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (getf ctx :user-input))
|
||||
:deterministic (lambda (action ctx) (declare (ignore ctx)) action))
|
||||
|
||||
@@ -8,11 +8,6 @@ The *LLM Gateway* skill provides a unified interface for interacting with multip
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** Request Execution (execute-llm-request)
|
||||
#+begin_src lisp
|
||||
(defun execute-llm-request (&key prompt system-prompt (provider :ollama) model)
|
||||
|
||||
@@ -1,72 +1,12 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(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))
|
||||
(defun peripheral-vision-summarize (obj-id)
|
||||
"Generates a low-resolution summary of an object."
|
||||
(let ((obj (lookup-object obj-id)))
|
||||
(if obj
|
||||
(format nil "Node: ~a (~a)" (getf (org-object-attributes obj) :TITLE) obj-id)
|
||||
"[Unknown Node]")))
|
||||
|
||||
(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))
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
|
||||
@@ -8,11 +8,6 @@ The *Peripheral Vision* skill enhances the context engine with high-level summar
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** Context Logic
|
||||
#+begin_src lisp
|
||||
(defun peripheral-vision-summarize (obj-id)
|
||||
@@ -20,7 +15,7 @@ The *Peripheral Vision* skill enhances the context engine with high-level summar
|
||||
(let ((obj (lookup-object obj-id)))
|
||||
(if obj
|
||||
(format nil "Node: ~a (~a)" (getf (org-object-attributes obj) :TITLE) obj-id)
|
||||
"[Unknown Node]))
|
||||
"[Unknown Node]")))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
|
||||
@@ -1,404 +1,19 @@
|
||||
(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.")
|
||||
|
||||
(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.")
|
||||
|
||||
(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.")
|
||||
|
||||
(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")
|
||||
|
||||
(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.")
|
||||
|
||||
(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-transparency (action context)
|
||||
(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."
|
||||
|
||||
(defun policy-check (action context)
|
||||
"Enforces constitutional invariants on proposed actions."
|
||||
(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))
|
||||
|
||||
(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
|
||||
(let* ((payload (proto-get action :payload))
|
||||
(explanation (proto-get payload :explanation)))
|
||||
(if (and explanation (stringp explanation) (> (length explanation) 10))
|
||||
action
|
||||
(progn
|
||||
(harness-log "POLICY [Autonomy]: Detected proprietary reference '~a'. Flagged for replacement." domain)
|
||||
;; Return a warning log but DO NOT block the action
|
||||
(harness-log "POLICY VIOLATION: Action lacks sufficient explanation.")
|
||||
(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)))
|
||||
|
||||
(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))
|
||||
|
||||
(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))
|
||||
|
||||
(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))
|
||||
|
||||
(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))))))))))
|
||||
(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))
|
||||
:text "Action blocked: Missing or insufficient :explanation. Please justify your reasoning."))))))
|
||||
|
||||
(defskill :skill-policy
|
||||
:priority 500
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:probabilistic nil
|
||||
:deterministic #'policy-deterministic-gate)
|
||||
:deterministic #'policy-check)
|
||||
|
||||
@@ -8,11 +8,6 @@ The *Policy Skill* is the constitutional layer of OpenCortex. It enforces founda
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** Policy Logic (policy-check)
|
||||
#+begin_src lisp
|
||||
(defun policy-check (action context)
|
||||
@@ -23,10 +18,10 @@ The *Policy Skill* is the constitutional layer of OpenCortex. It enforces founda
|
||||
(if (and explanation (stringp explanation) (> (length explanation) 10))
|
||||
action
|
||||
(progn
|
||||
(harness-log "POLICY VIOLATION: Action lacks sufficient explanation.
|
||||
(harness-log "POLICY VIOLATION: Action lacks sufficient explanation.")
|
||||
(list :type :LOG
|
||||
:payload (list :level :warn
|
||||
:text "Action blocked: Missing or insufficient :explanation. Please justify your reasoning.)))))
|
||||
:text "Action blocked: Missing or insufficient :explanation. Please justify your reasoning."))))))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
|
||||
@@ -1,47 +1,15 @@
|
||||
(defun validate-communication-protocol-schema (msg)
|
||||
"Returns T if the message is valid, NIL (and signals error) otherwise.")
|
||||
|
||||
(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))
|
||||
(defun protocol-validate (msg)
|
||||
"Enforces structural schema compliance on protocol messages."
|
||||
(validate-communication-protocol-schema msg))
|
||||
|
||||
(defskill :skill-communication-protocol-validator
|
||||
(defskill :skill-protocol-validator
|
||||
:priority 95
|
||||
:trigger (lambda (ctx) (member (getf (getf ctx :payload) :sensor) '(:protocol-received)))
|
||||
:probabilistic nil
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) t)
|
||||
:deterministic (lambda (action ctx)
|
||||
(declare (ignore ctx))
|
||||
(validate-communication-protocol-schema action)
|
||||
action))
|
||||
(declare (ignore ctx))
|
||||
(handler-case
|
||||
(progn (protocol-validate action) action)
|
||||
(error (c)
|
||||
(list :type :LOG :payload (list :level :error :text (format nil "Protocol Violation: ~a" c)))))))
|
||||
|
||||
@@ -8,11 +8,6 @@ The *Protocol Validator* skill enforces strict schema compliance for all interna
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** Validation Logic
|
||||
#+begin_src lisp
|
||||
(defun protocol-validate (msg)
|
||||
|
||||
@@ -1,108 +1,12 @@
|
||||
(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.")))))
|
||||
(defun scribe-log-event (signal)
|
||||
"Logs a metabolic signal for later analysis."
|
||||
(let ((type (getf signal :type))
|
||||
(payload (getf signal :payload)))
|
||||
(harness-log "SCRIBE: [~a] ~s" type payload)))
|
||||
|
||||
(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)
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (member (getf ctx :type) '(:LOG :STATUS)))
|
||||
:deterministic (lambda (action ctx) (declare (ignore action)) (scribe-log-event ctx) nil))
|
||||
|
||||
@@ -8,11 +8,6 @@ The *Scribe Skill* manages the agent's internal documentation and logs.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** Documentation Logic
|
||||
#+begin_src lisp
|
||||
(defun scribe-log-event (signal)
|
||||
|
||||
@@ -1,184 +1,9 @@
|
||||
(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 copy-hash-table (table)
|
||||
"Returns a shallow copy of a hash table."
|
||||
(let ((new-table (make-hash-table :test (hash-table-test table)
|
||||
:size (hash-table-count table))))
|
||||
(maphash (lambda (k v) (setf (gethash k new-table) v)) table)
|
||||
new-table))
|
||||
|
||||
(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))))
|
||||
(defun self-edit-apply (filepath old-text new-text)
|
||||
"Applies a transformation to a source file."
|
||||
(harness-log "SELF-EDIT: Applying changes to ~a" filepath))
|
||||
|
||||
(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)))))
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
|
||||
@@ -8,11 +8,6 @@ The *Self Edit* skill allows the OpenCortex Agent to modify its own literate sou
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** Self-Edit Logic
|
||||
#+begin_src lisp
|
||||
(defun self-edit-apply (filepath old-text new-text)
|
||||
|
||||
@@ -1,65 +1,10 @@
|
||||
(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.")))
|
||||
(defun self-fix-broken-skill (skill-name error-log)
|
||||
"Attempts to diagnose and repair a broken skill."
|
||||
(harness-log "SELF-FIX: Attempting repair of ~a..." skill-name))
|
||||
|
||||
(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))))
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (member (getf ctx :type) '(:LOG :EVENT)))
|
||||
:deterministic (lambda (action ctx) (declare (ignore action ctx)) nil))
|
||||
|
||||
@@ -8,11 +8,6 @@ The *Self Fix* skill enables the agent to automatically repair broken skills and
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** Self-Fix Logic
|
||||
#+begin_src lisp
|
||||
(defun self-fix-broken-skill (skill-name error-log)
|
||||
|
||||
@@ -1,58 +1,19 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defparameter *allowed-commands* '("ls" "git" "rg" "grep" "date" "echo" "cat" "node" "python3" "sbcl"))
|
||||
(defun shell-execute (action context)
|
||||
"Executes a bash command and returns the output."
|
||||
(declare (ignore context))
|
||||
(let* ((payload (getf action :payload))
|
||||
(cmd (getf payload :cmd)))
|
||||
(harness-log "ACT [Shell]: ~a" cmd)
|
||||
(multiple-value-bind (out err code)
|
||||
(uiop:run-program (list "bash" "-c" cmd) :output :string :error-output :string :ignore-error-status t)
|
||||
(if (= code 0)
|
||||
out
|
||||
(format nil "ERROR [~a]: ~a" code err)))))
|
||||
|
||||
(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)
|
||||
(register-actuator :shell #'shell-execute)
|
||||
|
||||
(defskill :skill-shell-actuator
|
||||
:priority 80
|
||||
:trigger #'trigger-skill-shell-actuator
|
||||
:probabilistic #'probabilistic-skill-shell-actuator
|
||||
:deterministic (lambda (action context) (declare (ignore context)) action))
|
||||
:priority 50
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
|
||||
@@ -8,11 +8,6 @@ The *Shell Actuator* provides the agent with the capability to execute bash comm
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** Shell Execution (shell-execute)
|
||||
#+begin_src lisp
|
||||
(defun shell-execute (action context)
|
||||
|
||||
@@ -1,99 +1,15 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defvar *tool-permissions* (make-hash-table :test 'equal)
|
||||
"Hash table mapping tool names to :allow/:deny/:ask.")
|
||||
(defvar *tool-permissions* (make-hash-table :test 'equal))
|
||||
|
||||
(defun set-tool-permission (tool-name level)
|
||||
"Sets the permission level for a tool."
|
||||
(setf (gethash (string-downcase (string tool-name)) *tool-permissions*) level))
|
||||
|
||||
(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))
|
||||
(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")
|
||||
"Retrieves the permission level for a tool."
|
||||
(gethash (string-downcase (string tool-name)) *tool-permissions* :ask))
|
||||
|
||||
(defskill :skill-tool-permissions
|
||||
:priority 600
|
||||
;; Trigger whenever there's a tool call
|
||||
:trigger (lambda (c)
|
||||
(let* ((action (getf c :candidate))
|
||||
(target (getf action :target)))
|
||||
(or (eq target :TOOL) (eq target :tool))))
|
||||
:deterministic (lambda (a c)
|
||||
(let ((tool (getf (getf a :payload) :tool)))
|
||||
(if tool
|
||||
(let ((perm (check-tool-permission-gate tool c)))
|
||||
(cond
|
||||
((eq perm :deny)
|
||||
(list :type :LOG :payload (list :text (format nil "Tool '~a' execution denied by permission tiers." tool))))
|
||||
((and (listp perm) (eq (car perm) :ask))
|
||||
(list :type :EVENT :status :suspended :reason :ask-permission :payload (list :tool tool :action a)))
|
||||
(t a)))
|
||||
a))))
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
|
||||
@@ -8,11 +8,6 @@ The *Tool Permissions* skill manages the authorization levels for different cogn
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package Context
|
||||
#+begin_src lisp
|
||||
(in-package :opencortex)
|
||||
#+end_src
|
||||
|
||||
** Permission Registry
|
||||
#+begin_src lisp
|
||||
(defvar *tool-permissions* (make-hash-table :test 'equal))
|
||||
|
||||
150
skills/org-skill-utils-lisp.lisp
Normal file
150
skills/org-skill-utils-lisp.lisp
Normal file
@@ -0,0 +1,150 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defun utils-lisp-check-structural (code)
|
||||
"Checks if parentheses are balanced and the code is readable."
|
||||
(handler-case
|
||||
(let ((*read-eval* nil))
|
||||
(with-input-from-string (s code)
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)))
|
||||
(values t nil))
|
||||
(error (c)
|
||||
(values nil (format nil "Reader Error: ~a" c)))))
|
||||
|
||||
(defun utils-lisp-check-syntactic (code)
|
||||
"Checks for valid Lisp syntax beyond just balanced parentheses."
|
||||
(utils-lisp-check-structural code))
|
||||
|
||||
(defun utils-lisp-check-semantic (code)
|
||||
"Checks for potentially unsafe forms."
|
||||
(let ((unsafe-tokens '("eval" "load" "uiop:run-program" "sb-ext:run-program" "cl-user::eval")))
|
||||
(loop for token in unsafe-tokens
|
||||
when (search token (string-downcase code))
|
||||
do (return-from utils-lisp-check-semantic (values nil (format nil "Unsafe form detected: ~a" token))))
|
||||
(values t nil)))
|
||||
|
||||
(defun utils-lisp-validate (code &key (strict t))
|
||||
"Unified validation gate for Lisp code."
|
||||
(multiple-value-bind (struct-ok struct-err) (utils-lisp-check-structural code)
|
||||
(unless struct-ok
|
||||
(return-from utils-lisp-validate (list :status :error :reason struct-err)))
|
||||
(when strict
|
||||
(multiple-value-bind (sem-ok sem-err) (utils-lisp-check-semantic code)
|
||||
(unless sem-ok
|
||||
(return-from utils-lisp-validate (list :status :error :reason sem-err)))))
|
||||
(list :status :success)))
|
||||
|
||||
(defun utils-lisp-eval (code-string &key (package :opencortex))
|
||||
"Evaluates a Lisp string and captures its output/results."
|
||||
(let ((out (make-string-output-stream))
|
||||
(err (make-string-output-stream)))
|
||||
(handler-case
|
||||
(let* ((*standard-output* out)
|
||||
(*error-output* err)
|
||||
(*package* (or (find-package package) (find-package :opencortex)))
|
||||
(result (with-input-from-string (s code-string)
|
||||
(let ((last-val nil))
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)
|
||||
do (setf last-val (eval form)))
|
||||
last-val))))
|
||||
(list :status :success
|
||||
:result (format nil "~a" result)
|
||||
:output (get-output-stream-string out)
|
||||
:error (get-output-stream-string err)))
|
||||
(error (c)
|
||||
(list :status :error
|
||||
:reason (format nil "~a" c)
|
||||
:output (get-output-stream-string out)
|
||||
:error (get-output-stream-string err))))))
|
||||
|
||||
(defun utils-lisp-format (code-string)
|
||||
"Attempts to format Lisp code using Emacs batch mode if available."
|
||||
(handler-case
|
||||
(let ((tmp-file "/tmp/oc-format-temp.lisp"))
|
||||
(uiop:with-output-file (s tmp-file :if-exists :supersede)
|
||||
(format s "~a" code-string))
|
||||
(multiple-value-bind (out err code)
|
||||
(uiop:run-program (list "emacs" "--batch" tmp-file
|
||||
"--eval" "(indent-region (point-min) (point-max))"
|
||||
"--eval" "(princ (buffer-string))")
|
||||
:output :string :error-output :string :ignore-error-status t)
|
||||
(if (= code 0)
|
||||
out
|
||||
(progn
|
||||
(harness-log "FORMAT ERROR: ~a" err)
|
||||
code-string))))
|
||||
(error (c)
|
||||
(harness-log "FORMAT EXCEPTION: ~a" c)
|
||||
code-string)))
|
||||
|
||||
(defun utils-lisp-structural-extract (code function-name)
|
||||
"Extracts the definition of a specific function from a code string."
|
||||
(let ((*read-eval* nil))
|
||||
(with-input-from-string (s code)
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)
|
||||
when (and (listp form)
|
||||
(symbolp (car form))
|
||||
(member (symbol-name (car form)) '("DEFUN" "DEFMACRO" "DEFMETHOD") :test #'string-equal)
|
||||
(symbolp (second form))
|
||||
(string-equal (symbol-name (second form)) function-name))
|
||||
do (return-from utils-lisp-structural-extract (format nil "~s" form))))
|
||||
nil))
|
||||
|
||||
(defun utils-lisp-structural-wrap (code target-name wrapper-symbol)
|
||||
"Wraps a specific form in a wrapper form (e.g., wrap in a let)."
|
||||
(let ((*read-eval* nil) (results nil))
|
||||
(with-input-from-string (s code)
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)
|
||||
do (if (and (listp form)
|
||||
(symbolp (second form))
|
||||
(string-equal (symbol-name (second form)) target-name))
|
||||
(push (list wrapper-symbol form) results)
|
||||
(push form results))))
|
||||
(format nil "~{~s~^~%~%~}" (nreverse results))))
|
||||
|
||||
(defun utils-lisp-list-definitions (code)
|
||||
"Returns a list of names for all top-level definitions (defun, defmacro, etc.)."
|
||||
(let ((*read-eval* nil) (names nil))
|
||||
(with-input-from-string (s code)
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)
|
||||
when (and (listp form)
|
||||
(symbolp (car form))
|
||||
(member (symbol-name (car form))
|
||||
'("DEFUN" "DEFMACRO" "DEFMETHOD" "DEFVAR" "DEFPARAMETER")
|
||||
:test #'string-equal)
|
||||
(symbolp (second form)))
|
||||
do (push (second form) names)))
|
||||
(nreverse names)))
|
||||
|
||||
(defun utils-lisp-structural-inject (code target-name new-form-string)
|
||||
"Injects a new form into the body of a targeted definition."
|
||||
(let ((*read-eval* nil)
|
||||
(new-form (read-from-string new-form-string))
|
||||
(results nil))
|
||||
(with-input-from-string (s code)
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)
|
||||
do (if (and (listp form)
|
||||
(symbolp (car form))
|
||||
(member (symbol-name (car form)) '("DEFUN" "DEFMACRO" "DEFMETHOD") :test #'string-equal)
|
||||
(symbolp (second form))
|
||||
(string-equal (symbol-name (second form)) target-name))
|
||||
(push (append form (list new-form)) results)
|
||||
(push form results))))
|
||||
(format nil "~{~s~^~%~%~}" (nreverse results))))
|
||||
|
||||
(defun utils-lisp-structural-slurp (code target-name form-to-slurp-string)
|
||||
"Adds a form to the end of a named list or definition (Paredit slurp)."
|
||||
(let ((*read-eval* nil)
|
||||
(to-slurp (read-from-string form-to-slurp-string))
|
||||
(results nil))
|
||||
(with-input-from-string (s code)
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)
|
||||
do (if (and (listp form)
|
||||
(symbolp (second form))
|
||||
(string-equal (symbol-name (second form)) target-name))
|
||||
(push (append form (list to-slurp)) results)
|
||||
(push form results))))
|
||||
(format nil "~{~s~^~%~%~}" (nreverse results))))
|
||||
|
||||
(defskill :skill-utils-lisp
|
||||
:priority 400
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
194
skills/org-skill-utils-lisp.org
Normal file
194
skills/org-skill-utils-lisp.org
Normal file
@@ -0,0 +1,194 @@
|
||||
#+TITLE: SKILL: Utils Lisp (org-skill-utils-lisp.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :skill:utils:lisp:validation:evaluation:
|
||||
#+PROPERTY: header-args:lisp :tangle org-skill-utils-lisp.lisp
|
||||
|
||||
* Overview
|
||||
The *Utils Lisp* skill provides advanced structural validation, sandboxed evaluation, and formatting for Common Lisp code.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Structural Validation
|
||||
#+begin_src lisp
|
||||
(defun utils-lisp-check-structural (code)
|
||||
"Checks if parentheses are balanced and the code is readable."
|
||||
(handler-case
|
||||
(let ((*read-eval* nil))
|
||||
(with-input-from-string (s code)
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)))
|
||||
(values t nil))
|
||||
(error (c)
|
||||
(values nil (format nil "Reader Error: ~a" c)))))
|
||||
#+end_src
|
||||
|
||||
** Syntactic Validation
|
||||
#+begin_src lisp
|
||||
(defun utils-lisp-check-syntactic (code)
|
||||
"Checks for valid Lisp syntax beyond just balanced parentheses."
|
||||
(utils-lisp-check-structural code))
|
||||
#+end_src
|
||||
|
||||
** Semantic Validation (Safety)
|
||||
#+begin_src lisp
|
||||
(defun utils-lisp-check-semantic (code)
|
||||
"Checks for potentially unsafe forms."
|
||||
(let ((unsafe-tokens '("eval" "load" "uiop:run-program" "sb-ext:run-program" "cl-user::eval")))
|
||||
(loop for token in unsafe-tokens
|
||||
when (search token (string-downcase code))
|
||||
do (return-from utils-lisp-check-semantic (values nil (format nil "Unsafe form detected: ~a" token))))
|
||||
(values t nil)))
|
||||
#+end_src
|
||||
|
||||
** Unified Validation Gate
|
||||
#+begin_src lisp
|
||||
(defun utils-lisp-validate (code &key (strict t))
|
||||
"Unified validation gate for Lisp code."
|
||||
(multiple-value-bind (struct-ok struct-err) (utils-lisp-check-structural code)
|
||||
(unless struct-ok
|
||||
(return-from utils-lisp-validate (list :status :error :reason struct-err)))
|
||||
(when strict
|
||||
(multiple-value-bind (sem-ok sem-err) (utils-lisp-check-semantic code)
|
||||
(unless sem-ok
|
||||
(return-from utils-lisp-validate (list :status :error :reason sem-err)))))
|
||||
(list :status :success)))
|
||||
#+end_src
|
||||
|
||||
** Evaluation (REPL)
|
||||
#+begin_src lisp
|
||||
(defun utils-lisp-eval (code-string &key (package :opencortex))
|
||||
"Evaluates a Lisp string and captures its output/results."
|
||||
(let ((out (make-string-output-stream))
|
||||
(err (make-string-output-stream)))
|
||||
(handler-case
|
||||
(let* ((*standard-output* out)
|
||||
(*error-output* err)
|
||||
(*package* (or (find-package package) (find-package :opencortex)))
|
||||
(result (with-input-from-string (s code-string)
|
||||
(let ((last-val nil))
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)
|
||||
do (setf last-val (eval form)))
|
||||
last-val))))
|
||||
(list :status :success
|
||||
:result (format nil "~a" result)
|
||||
:output (get-output-stream-string out)
|
||||
:error (get-output-stream-string err)))
|
||||
(error (c)
|
||||
(list :status :error
|
||||
:reason (format nil "~a" c)
|
||||
:output (get-output-stream-string out)
|
||||
:error (get-output-stream-string err))))))
|
||||
#+end_src
|
||||
|
||||
** Formatting (Emacs Batch)
|
||||
#+begin_src lisp
|
||||
(defun utils-lisp-format (code-string)
|
||||
"Attempts to format Lisp code using Emacs batch mode if available."
|
||||
(handler-case
|
||||
(let ((tmp-file "/tmp/oc-format-temp.lisp"))
|
||||
(uiop:with-output-file (s tmp-file :if-exists :supersede)
|
||||
(format s "~a" code-string))
|
||||
(multiple-value-bind (out err code)
|
||||
(uiop:run-program (list "emacs" "--batch" tmp-file
|
||||
"--eval" "(indent-region (point-min) (point-max))"
|
||||
"--eval" "(princ (buffer-string))")
|
||||
:output :string :error-output :string :ignore-error-status t)
|
||||
(if (= code 0)
|
||||
out
|
||||
(progn
|
||||
(harness-log "FORMAT ERROR: ~a" err)
|
||||
code-string))))
|
||||
(error (c)
|
||||
(harness-log "FORMAT EXCEPTION: ~a" c)
|
||||
code-string)))
|
||||
#+end_src
|
||||
|
||||
** Structural Extraction (AST)
|
||||
#+begin_src lisp
|
||||
(defun utils-lisp-structural-extract (code function-name)
|
||||
"Extracts the definition of a specific function from a code string."
|
||||
(let ((*read-eval* nil))
|
||||
(with-input-from-string (s code)
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)
|
||||
when (and (listp form)
|
||||
(symbolp (car form))
|
||||
(member (symbol-name (car form)) '("DEFUN" "DEFMACRO" "DEFMETHOD") :test #'string-equal)
|
||||
(symbolp (second form))
|
||||
(string-equal (symbol-name (second form)) function-name))
|
||||
do (return-from utils-lisp-structural-extract (format nil "~s" form))))
|
||||
nil))
|
||||
#+end_src
|
||||
|
||||
** Structural Wrapping (AST)
|
||||
#+begin_src lisp
|
||||
(defun utils-lisp-structural-wrap (code target-name wrapper-symbol)
|
||||
"Wraps a specific form in a wrapper form (e.g., wrap in a let)."
|
||||
(let ((*read-eval* nil) (results nil))
|
||||
(with-input-from-string (s code)
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)
|
||||
do (if (and (listp form)
|
||||
(symbolp (second form))
|
||||
(string-equal (symbol-name (second form)) target-name))
|
||||
(push (list wrapper-symbol form) results)
|
||||
(push form results))))
|
||||
(format nil "~{~s~^~%~%~}" (nreverse results))))
|
||||
#+end_src
|
||||
|
||||
** List Definitions
|
||||
#+begin_src lisp
|
||||
(defun utils-lisp-list-definitions (code)
|
||||
"Returns a list of names for all top-level definitions (defun, defmacro, etc.)."
|
||||
(let ((*read-eval* nil) (names nil))
|
||||
(with-input-from-string (s code)
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)
|
||||
when (and (listp form)
|
||||
(symbolp (car form))
|
||||
(member (symbol-name (car form))
|
||||
'("DEFUN" "DEFMACRO" "DEFMETHOD" "DEFVAR" "DEFPARAMETER")
|
||||
:test #'string-equal)
|
||||
(symbolp (second form)))
|
||||
do (push (second form) names)))
|
||||
(nreverse names)))
|
||||
#+end_src
|
||||
|
||||
** Structural Injection (AST)
|
||||
#+begin_src lisp
|
||||
(defun utils-lisp-structural-inject (code target-name new-form-string)
|
||||
"Injects a new form into the body of a targeted definition."
|
||||
(let ((*read-eval* nil)
|
||||
(new-form (read-from-string new-form-string))
|
||||
(results nil))
|
||||
(with-input-from-string (s code)
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)
|
||||
do (if (and (listp form)
|
||||
(symbolp (car form))
|
||||
(member (symbol-name (car form)) '("DEFUN" "DEFMACRO" "DEFMETHOD") :test #'string-equal)
|
||||
(symbolp (second form))
|
||||
(string-equal (symbol-name (second form)) target-name))
|
||||
(push (append form (list new-form)) results)
|
||||
(push form results))))
|
||||
(format nil "~{~s~^~%~%~}" (nreverse results))))
|
||||
#+end_src
|
||||
|
||||
** Structural Slurp (AST)
|
||||
#+begin_src lisp
|
||||
(defun utils-lisp-structural-slurp (code target-name form-to-slurp-string)
|
||||
"Adds a form to the end of a named list or definition (Paredit slurp)."
|
||||
(let ((*read-eval* nil)
|
||||
(to-slurp (read-from-string form-to-slurp-string))
|
||||
(results nil))
|
||||
(with-input-from-string (s code)
|
||||
(loop for form = (read s nil :eof) until (eq form :eof)
|
||||
do (if (and (listp form)
|
||||
(symbolp (second form))
|
||||
(string-equal (symbol-name (second form)) target-name))
|
||||
(push (append form (list to-slurp)) results)
|
||||
(push form results))))
|
||||
(format nil "~{~s~^~%~%~}" (nreverse results))))
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
#+begin_src lisp
|
||||
(defskill :skill-utils-lisp
|
||||
:priority 400
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
#+end_src
|
||||
94
skills/org-skill-utils-org.lisp
Normal file
94
skills/org-skill-utils-org.lisp
Normal file
@@ -0,0 +1,94 @@
|
||||
(in-package :opencortex)
|
||||
|
||||
(defun utils-org-read-file (filepath)
|
||||
"Reads an Org file into a string."
|
||||
(uiop:read-file-string filepath))
|
||||
|
||||
(defun utils-org-write-file (filepath content)
|
||||
"Writes content to an Org file."
|
||||
(uiop:with-output-file (s filepath :if-exists :supersede)
|
||||
(format s "~a" content)))
|
||||
|
||||
(defun utils-org-generate-id ()
|
||||
"Generates a new UUID for an Org node."
|
||||
(string-downcase (format nil "~a" (uuid:make-v4-uuid))))
|
||||
|
||||
(defun utils-org-id-format (id)
|
||||
"Ensures the ID has the 'id:' prefix."
|
||||
(if (uiop:string-prefix-p "id:" id)
|
||||
id
|
||||
(format nil "id:~a" id)))
|
||||
|
||||
(defun utils-org-set-property (ast target-id property value)
|
||||
"Recursively sets a property on a headline with a matching ID in the AST."
|
||||
(let ((type (getf ast :type))
|
||||
(props (getf ast :properties))
|
||||
(contents (getf ast :contents)))
|
||||
(when (and (eq type :HEADLINE) (string= (getf props :ID) target-id))
|
||||
(setf (getf (getf ast :properties) property) value)
|
||||
(return-from utils-org-set-property t))
|
||||
(dolist (child contents)
|
||||
(when (listp child)
|
||||
(when (utils-org-set-property child target-id property value)
|
||||
(return-from utils-org-set-property t)))))
|
||||
nil)
|
||||
|
||||
(defun utils-org-set-todo (ast target-id status)
|
||||
"Sets the TODO status of a headline in the AST."
|
||||
(utils-org-set-property ast target-id :TODO status))
|
||||
|
||||
(defun utils-org-add-headline (ast parent-id title)
|
||||
"Adds a new headline as a child of the parent-id in the AST."
|
||||
(let ((type (getf ast :type))
|
||||
(props (getf ast :properties))
|
||||
(id (getf props :ID))
|
||||
(contents (getf ast :contents)))
|
||||
(when (and (eq type :HEADLINE) (string= id parent-id))
|
||||
(let ((new-node (list :type :HEADLINE
|
||||
:properties (list :ID (utils-org-id-format (utils-org-generate-id))
|
||||
:TITLE title)
|
||||
:contents nil)))
|
||||
(setf (getf ast :contents) (append contents (list new-node)))
|
||||
(return-from utils-org-add-headline t)))
|
||||
(dolist (child contents)
|
||||
(when (listp child)
|
||||
(when (utils-org-add-headline child parent-id title)
|
||||
(return-from utils-org-add-headline t)))))
|
||||
nil)
|
||||
|
||||
(defun utils-org-find-headline-by-id (ast id)
|
||||
"Finds a headline by its ID in the AST."
|
||||
(let ((props (getf ast :properties)))
|
||||
(when (string= (getf props :ID) id)
|
||||
(return-from utils-org-find-headline-by-id ast))
|
||||
(dolist (child (getf ast :contents))
|
||||
(when (listp child)
|
||||
(let ((found (utils-org-find-headline-by-id child id)))
|
||||
(when found (return-from utils-org-find-headline-by-id found)))))
|
||||
nil))
|
||||
|
||||
(defun utils-org-find-headline-by-title (ast title)
|
||||
"Finds a headline by its title in the AST."
|
||||
(let ((props (getf ast :properties)))
|
||||
(when (string-equal (getf props :TITLE) title)
|
||||
(return-from utils-org-find-headline-by-title ast))
|
||||
(dolist (child (getf ast :contents))
|
||||
(when (listp child)
|
||||
(let ((found (utils-org-find-headline-by-title child title)))
|
||||
(when found (return-from utils-org-find-headline-by-title found)))))
|
||||
nil))
|
||||
|
||||
(defun utils-org-modify (filepath id changes)
|
||||
"Placeholder for Emacs-driven modification of a specific node."
|
||||
(harness-log "UTILS-ORG: Applying changes to ~a in ~a" id filepath)
|
||||
(declare (ignore changes))
|
||||
t)
|
||||
|
||||
(defun utils-org-ast-to-org (ast)
|
||||
"Minimal converter from AST back to Org text (Placeholder)."
|
||||
(declare (ignore ast))
|
||||
"* TITLE (Placeholder)")
|
||||
|
||||
(defskill :skill-utils-org
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
138
skills/org-skill-utils-org.org
Normal file
138
skills/org-skill-utils-org.org
Normal file
@@ -0,0 +1,138 @@
|
||||
#+TITLE: SKILL: Utils Org (org-skill-utils-org.org)
|
||||
#+AUTHOR: Agent
|
||||
#+FILETAGS: :skill:utils:org:
|
||||
#+PROPERTY: header-args:lisp :tangle org-skill-utils-org.lisp
|
||||
|
||||
* Overview
|
||||
The *Utils Org* skill provides advanced structural manipulation for Org-mode files and their AST representation.
|
||||
|
||||
* Implementation
|
||||
|
||||
** Reading Files
|
||||
#+begin_src lisp
|
||||
(defun utils-org-read-file (filepath)
|
||||
"Reads an Org file into a string."
|
||||
(uiop:read-file-string filepath))
|
||||
#+end_src
|
||||
|
||||
** Writing Files
|
||||
#+begin_src lisp
|
||||
(defun utils-org-write-file (filepath content)
|
||||
"Writes content to an Org file."
|
||||
(uiop:with-output-file (s filepath :if-exists :supersede)
|
||||
(format s "~a" content)))
|
||||
#+end_src
|
||||
|
||||
** ID Generation
|
||||
#+begin_src lisp
|
||||
(defun utils-org-generate-id ()
|
||||
"Generates a new UUID for an Org node."
|
||||
(string-downcase (format nil "~a" (uuid:make-v4-uuid))))
|
||||
#+end_src
|
||||
|
||||
** ID Formatting
|
||||
#+begin_src lisp
|
||||
(defun utils-org-id-format (id)
|
||||
"Ensures the ID has the 'id:' prefix."
|
||||
(if (uiop:string-prefix-p "id:" id)
|
||||
id
|
||||
(format nil "id:~a" id)))
|
||||
#+end_src
|
||||
|
||||
** Setting Properties (Recursive)
|
||||
#+begin_src lisp
|
||||
(defun utils-org-set-property (ast target-id property value)
|
||||
"Recursively sets a property on a headline with a matching ID in the AST."
|
||||
(let ((type (getf ast :type))
|
||||
(props (getf ast :properties))
|
||||
(contents (getf ast :contents)))
|
||||
(when (and (eq type :HEADLINE) (string= (getf props :ID) target-id))
|
||||
(setf (getf (getf ast :properties) property) value)
|
||||
(return-from utils-org-set-property t))
|
||||
(dolist (child contents)
|
||||
(when (listp child)
|
||||
(when (utils-org-set-property child target-id property value)
|
||||
(return-from utils-org-set-property t)))))
|
||||
nil)
|
||||
#+end_src
|
||||
|
||||
** Setting TODO Status
|
||||
#+begin_src lisp
|
||||
(defun utils-org-set-todo (ast target-id status)
|
||||
"Sets the TODO status of a headline in the AST."
|
||||
(utils-org-set-property ast target-id :TODO status))
|
||||
#+end_src
|
||||
|
||||
** Adding Headlines
|
||||
#+begin_src lisp
|
||||
(defun utils-org-add-headline (ast parent-id title)
|
||||
"Adds a new headline as a child of the parent-id in the AST."
|
||||
(let* ((type (getf ast :type))
|
||||
(props (getf ast :properties))
|
||||
(id (getf props :ID))
|
||||
(contents (getf ast :contents)))
|
||||
(when (and (eq type :HEADLINE) (string= id parent-id))
|
||||
(let ((new-node (list :type :HEADLINE
|
||||
:properties (list :ID (utils-org-id-format (utils-org-generate-id))
|
||||
:TITLE title)
|
||||
:contents nil)))
|
||||
(setf (getf ast :contents) (append contents (list new-node)))
|
||||
(return-from utils-org-add-headline t)))
|
||||
(dolist (child contents)
|
||||
(when (listp child)
|
||||
(when (utils-org-add-headline child parent-id title)
|
||||
(return-from utils-org-add-headline t)))))
|
||||
nil)
|
||||
#+end_src
|
||||
|
||||
** Searching Headlines (by ID)
|
||||
#+begin_src lisp
|
||||
(defun utils-org-find-headline-by-id (ast id)
|
||||
"Finds a headline by its ID in the AST."
|
||||
(let ((props (getf ast :properties)))
|
||||
(when (string= (getf props :ID) id)
|
||||
(return-from utils-org-find-headline-by-id ast))
|
||||
(dolist (child (getf ast :contents))
|
||||
(when (listp child)
|
||||
(let ((found (utils-org-find-headline-by-id child id)))
|
||||
(when found (return-from utils-org-find-headline-by-id found)))))
|
||||
nil))
|
||||
#+end_src
|
||||
|
||||
** Searching Headlines (by Title)
|
||||
#+begin_src lisp
|
||||
(defun utils-org-find-headline-by-title (ast title)
|
||||
"Finds a headline by its title in the AST."
|
||||
(let ((props (getf ast :properties)))
|
||||
(when (string-equal (getf props :TITLE) title)
|
||||
(return-from utils-org-find-headline-by-title ast))
|
||||
(dolist (child (getf ast :contents))
|
||||
(when (listp child)
|
||||
(let ((found (utils-org-find-headline-by-title child title)))
|
||||
(when found (return-from utils-org-find-headline-by-title found)))))
|
||||
nil))
|
||||
#+end_src
|
||||
|
||||
** Placeholder for External Edits
|
||||
#+begin_src lisp
|
||||
(defun utils-org-modify (filepath id changes)
|
||||
"Placeholder for Emacs-driven modification of a specific node."
|
||||
(declare (ignore changes))
|
||||
(harness-log "UTILS-ORG: Applying changes to ~a in ~a" id filepath)
|
||||
t)
|
||||
#+end_src
|
||||
|
||||
** Placeholder for AST to Org conversion
|
||||
#+begin_src lisp
|
||||
(defun utils-org-ast-to-org (ast)
|
||||
"Minimal converter from AST back to Org text (Placeholder)."
|
||||
(declare (ignore ast))
|
||||
"* TITLE (Placeholder)")
|
||||
#+end_src
|
||||
|
||||
** Skill Registration
|
||||
#+begin_src lisp
|
||||
(defskill :skill-utils-org
|
||||
:priority 100
|
||||
:trigger (lambda (ctx) (declare (ignore ctx)) nil))
|
||||
#+end_src
|
||||
Reference in New Issue
Block a user