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

feat: implement verified topological boot sequence and micro-loader

Browse Source
This commit is contained in:
Amr Gharbeia
2026-04-08 18:03:40 -04:00
parent a475c5c51b
commit 46acece7ba
4 changed files with 306 additions and 39 deletions
Download Patch File Download Diff File Expand all files Collapse all files

134
src/core.lisp
View File

@@ -3,6 +3,8 @@
(defvar *system-logs* nil)
(defvar *logs-lock* (bt:make-lock "kernel-logs-lock"))
(defvar *max-log-history* 100)
(defvar *interrupt-flag* nil)
(defvar *interrupt-lock* (bt:make-lock "kernel-interrupt-lock"))
(defvar *skill-telemetry* (make-hash-table :test 'equal))
(defvar *telemetry-lock* (bt:make-lock "kernel-telemetry-lock"))
@@ -65,22 +67,62 @@
(:message (kernel-log "ACTUATOR [System] - ~a" (getf payload :text)))
(t (kernel-log "ACTUATOR [System] - Unknown command ~s" cmd)))))
(defun cognitive-loop (raw-message)
(let* ((start-time (get-internal-real-time))
(type (getf raw-message :type))
(perceive-fn (find-symbol "PERCEIVE" :org-agent))
(context (if perceive-fn (funcall perceive-fn raw-message) raw-message)))
(snapshot-object-store)
(if (eq type :REQUEST)
(dispatch-action raw-message context)
(let* ((skill (find-triggered-skill context))
(skill-name (when skill (skill-name skill)))
(proposed-action (think context))
(approved-action (decide proposed-action context))
(status (if (and proposed-action (null approved-action)) :rejected :success))
(duration (- (get-internal-real-time) start-time)))
(when skill-name (kernel-track-telemetry skill-name duration status))
(dispatch-action approved-action context)))))
(defun cognitive-loop (raw-message &optional (depth 0))
(when (> depth 10)
(kernel-log "SYSTEM ERROR: Maximum cognitive depth reached.")
(return-from cognitive-loop nil))
(when (bt:with-lock-held (*interrupt-lock*) *interrupt-flag*)
(kernel-log "SYSTEM: Loop interrupted.")
(bt:with-lock-held (*interrupt-lock*) (setf *interrupt-flag* nil))
(return-from cognitive-loop nil))
(handler-case
(let* ((start-time (get-internal-real-time))
(type (getf raw-message :type))
(perceive-fn (find-symbol "PERCEIVE" :org-agent))
(context (if perceive-fn (funcall perceive-fn raw-message) raw-message)))
(snapshot-object-store)
(if (eq type :REQUEST)
(dispatch-action raw-message context)
(let* ((skill (find-triggered-skill context))
(skill-name (when skill (skill-name skill)))
(proposed-action (think context))
(approved-action (decide proposed-action context))
(status (if (and proposed-action (null approved-action)) :rejected :success))
(duration (- (get-internal-real-time) start-time)))
(when skill-name (kernel-track-telemetry skill-name duration status))
(let* ((payload (getf approved-action :payload))
(target (getf approved-action :target))
(action (or (getf payload :action) (getf approved-action :action)))
(tool-name (or (getf payload :tool) (getf approved-action :tool)))
(tool-args (or (getf payload :args) (getf approved-action :args))))
(if (and approved-action (eq target :tool) (eq action :call))
;; Internal Tool Execution
(let* ((tool (gethash (string-downcase (string tool-name)) *cognitive-tools*)))
(if tool
(progn
(kernel-log "SYSTEM 2: Executing tool '~a'..." tool-name)
(let* ((clean-args (if (and (listp tool-args) (listp (car tool-args))) (car tool-args) tool-args))
(tool-result (funcall (cognitive-tool-body tool) clean-args))
(next-stimulus `(:type :EVENT :payload (:sensor :tool-output :result ,tool-result :tool ,tool-name))))
(when (getf raw-message :reply-stream) (setf (getf next-stimulus :reply-stream) (getf raw-message :reply-stream)))
(cognitive-loop next-stimulus (1+ depth))))
(progn
(kernel-log "SYSTEM ERROR: Tool '~a' not found in registry." tool-name)
(let ((err-stimulus `(:type :EVENT :payload (:sensor :tool-error :message "Tool not found"))))
(when (getf raw-message :reply-stream) (setf (getf err-stimulus :reply-stream) (getf raw-message :reply-stream)))
(cognitive-loop err-stimulus (1+ depth))))))
;; Physical Actuation (Emacs, Shell, etc.)
(let ((result (dispatch-action approved-action context)))
(when (and result (not (member target '(:emacs :system-message))))
(let ((fallback-stimulus `(:type :EVENT :payload (:sensor :tool-output :result ,result :tool ,approved-action))))
(when (getf raw-message :reply-stream) (setf (getf fallback-stimulus :reply-stream) (getf raw-message :reply-stream)))
(cognitive-loop fallback-stimulus (1+ depth))))))))))
(error (c)
(kernel-log "LOOP CRASH - Error in recursive turn: ~a~%" c)
nil)))
(defun perceive (raw-message)
(let ((type (getf raw-message :type)) (payload (getf raw-message :payload)))
@@ -88,8 +130,10 @@
(cond ((eq type :EVENT) (let ((sensor (getf payload :sensor)))
(case sensor
(:buffer-update (let ((ast (getf payload :ast))) (when ast (ingest-ast ast))))
(:point-update (let ((element (getf payload :element))) (when element (ingest-ast element)))))))
((eq type :RESPONSE) (kernel-log "ACT RESULT: ~a" (getf payload :status))))
(:point-update (let ((element (getf payload :element))) (when element (ingest-ast element))))
(:interrupt (bt:with-lock-held (*interrupt-lock*) (setf *interrupt-flag* t))))))
((eq type :RESPONSE)
(kernel-log "ACT RESULT: ~a~%PAYLOAD: ~s~%" (getf payload :status) payload)))
raw-message))
(defun start-heartbeat (&optional (interval 60))
@@ -99,29 +143,56 @@
(defun stop-heartbeat () (when (and *heartbeat-thread* (bt:thread-alive-p *heartbeat-thread*)) (bt:destroy-thread *heartbeat-thread*) (setf *heartbeat-thread* nil)))
(defun load-all-skills ()
"Scans the directory defined by SKILLS_DIR and hot-loads skills.
Supports selective loading via SKILLS_WHITELIST environment variable."
"Performs a topological boot sequence.
1. Loads the Gateway Skill (org-skill-agent) first.
2. Performs topological sort of all other skills in SKILLS_DIR.
3. Loads the Minimal Boot Set followed by others."
(let* ((env-path (uiop:getenv "SKILLS_DIR"))
(whitelist-raw (uiop:getenv "SKILLS_WHITELIST"))
(whitelist (when whitelist-raw (uiop:split-string whitelist-raw :separator '(#\,))))
(skills-dir-str (or env-path (namestring (merge-pathnames "notes/" (user-homedir-pathname)))))
(resolved-path (context-resolve-path skills-dir-str))
(skills-dir (if resolved-path (uiop:ensure-directory-pathname resolved-path) nil)))
(if (and skills-dir (uiop:directory-exists-p skills-dir))
(let ((files (uiop:directory-files skills-dir "org-skill-*.org")))
(if files
(dolist (file files)
(let ((skill-name (pathname-name file)))
(if (or (null whitelist) (member skill-name whitelist :test #'string-equal))
(load-skill-from-org file)
(kernel-log "KERNEL: Skipping skill ~a (Not in whitelist)" skill-name))))
(kernel-log "KERNEL: No skills found in ~a" resolved-path)))
(kernel-log "KERNEL ERROR: Skills directory not found or invalid path: ~a" skills-dir-str))))
(skills-dir (if resolved-path (uiop:ensure-directory-pathname resolved-path) nil))
(timeout (or (ignore-errors (parse-integer (uiop:getenv "SKILL_LOAD_TIMEOUT"))) 5)))
(unless (and skills-dir (uiop:directory-exists-p skills-dir))
(error "KERNEL FATAL: Skills directory not found: ~a" skills-dir-str))
;; 1. The Gateway Handshake
(let ((gateway-file (merge-pathnames "org-skill-agent.org" skills-dir)))
(unless (uiop:file-exists-p gateway-file)
(error "KERNEL FATAL: Gateway Skill (org-skill-agent.org) missing from ~a" resolved-path))
(kernel-log "KERNEL: Instantiating Gateway (The Soul)...")
(load-skill-with-timeout gateway-file timeout))
;; 2. Topological Sort
(let ((sorted-files (topological-sort-skills skills-dir)))
(dolist (file sorted-files)
(let ((skill-name (pathname-name file)))
;; Skip the gateway as it's already loaded
(unless (string= skill-name "org-skill-agent")
(if (or (null whitelist) (member skill-name whitelist :test #'string-equal))
(progn
(kernel-log "KERNEL: Loading skill ~a..." skill-name)
(load-skill-with-timeout file timeout))
(kernel-log "KERNEL: Skipping skill ~a (Not in whitelist)" skill-name))))))))
(defvar *daemon-thread* nil) (defvar *daemon-socket* nil)
(defvar *emacs-clients* nil)
(defvar *clients-lock* (bt:make-lock "emacs-clients-lock"))
(defun register-emacs-client (stream)
(bt:with-lock-held (*clients-lock*)
(pushnew stream *emacs-clients*)))
(defun unregister-emacs-client (stream)
(bt:with-lock-held (*clients-lock*)
(setf *emacs-clients* (remove stream *emacs-clients*))))
(defun handle-client (stream)
"Main loop for a single OACP client connection."
(kernel-log "DAEMON: New client connected.~%")
(register-emacs-client stream)
(unwind-protect
(loop
(handler-case
@@ -150,6 +221,7 @@
(kernel-log "DAEMON CLIENT ERROR: ~a~%" c)
(return))))
(kernel-log "DAEMON: Client disconnected.~%")
(unregister-emacs-client stream)
(ignore-errors (close stream))))
(defun start-daemon (&key port interval)

145
src/skills.lisp
View File

@@ -4,6 +4,33 @@
(defstruct skill name priority dependencies trigger-fn neuro-prompt symbolic-fn)
(defvar *cognitive-tools* (make-hash-table :test 'equal))
(defstruct cognitive-tool name description parameters guard body)
(defmacro def-cognitive-tool (name description &key parameters guard body)
`(setf (gethash (string-downcase (string ,name)) *cognitive-tools*)
(make-cognitive-tool :name (string-downcase (string ,name))
:description ,description
:parameters ',parameters
:guard ,guard
:body ,body)))
(defun generate-tool-belt-prompt ()
(let ((output (format nil "AVAILABLE TOOLS:
You can call tools by returning a Lisp plist: (:target :tool :action :call :tool <name> :args (...))
---
")))
(maphash (lambda (name tool)
(setf output (concatenate 'string output
(format nil "- ~a: ~a~% Parameters: ~s~%~%"
name
(cognitive-tool-description tool)
(cognitive-tool-parameters tool)))))
*cognitive-tools*)
output))
(defmacro defskill (name &key priority dependencies trigger neuro symbolic)
`(setf (gethash ,(string-downcase (string name)) *skills-registry*)
(make-skill :name ,(string-downcase (string name)) :priority (or ,priority 10) :dependencies ,dependencies
@@ -22,15 +49,83 @@
(push name resolved))))
(visit skill-name) (nreverse resolved))))
;; --- Boot Sequence & Micro-Loader ---
(defun parse-skill-metadata (filepath)
"Extracts ID and DEPENDS_ON tags using robust line-scanning."
(let ((dependencies nil)
(id nil))
(with-open-file (stream filepath)
(loop for line = (read-line stream nil :eof)
until (eq line :eof)
do (let ((clean (string-trim '(#\Space #\Tab #\Return #\Newline) line)))
(cond
((uiop:string-prefix-p "#+DEPENDS_ON:" (string-upcase clean))
(let* ((deps-part (string-trim " " (subseq clean 13))))
(setf dependencies (append dependencies
(mapcar (lambda (s) (string-trim "[] " s))
(uiop:split-string deps-part :separator '(#\Space #\Tab)))))))
((uiop:string-prefix-p ":ID:" (string-upcase clean))
(setf id (string-trim '(#\Space #\Tab) (subseq clean 4))))))))
(values id (remove-if (lambda (s) (= 0 (length s))) dependencies))))
(defun topological-sort-skills (skills-dir)
"Returns a list of skill filepaths sorted by dependency (dependencies first)."
(let ((files (uiop:directory-files skills-dir "org-skill-*.org"))
(adj (make-hash-table :test 'equal))
(path-map (make-hash-table :test 'equal))
(result nil)
(visited (make-hash-table :test 'equal))
(stack (make-hash-table :test 'equal)))
(dolist (file files)
(let ((name (pathname-name file)))
(setf (gethash name path-map) file)
(multiple-value-bind (id deps) (parse-skill-metadata file)
(declare (ignore id))
(let ((clean-deps (mapcar (lambda (d) (if (uiop:string-prefix-p "id:" (string-downcase d)) (subseq d 3) d)) deps)))
(setf (gethash name adj) clean-deps)))))
(labels ((visit (node)
(let ((node-name (string-downcase node)))
(when (gethash node-name stack) (error "Circular dependency detected: ~a" node-name))
(unless (gethash node-name visited)
(setf (gethash node-name stack) t)
(dolist (dep (gethash node-name adj))
(when (gethash (string-downcase dep) path-map)
(visit (string-downcase dep))))
(setf (gethash node-name stack) nil)
(setf (gethash node-name visited) t)
(push (gethash node-name path-map) result)))))
(let ((names nil))
(maphash (lambda (k v) (declare (ignore v)) (push k names)) path-map)
(dolist (name (sort names #'string<))
(visit name)))
(nreverse result))))
(defun load-skill-with-timeout (filepath timeout-seconds)
"Loads a skill Org file with a hard execution timeout."
(let* ((finished nil)
(thread (bt:make-thread (lambda ()
(load-skill-from-org filepath)
(setf finished t))
:name (format nil "loader-~a" (pathname-name filepath))))
(start-time (get-internal-real-time))
(timeout-units (* timeout-seconds internal-time-units-per-second)))
(loop
(when finished (return :success))
(unless (bt:thread-alive-p thread) (return :error))
(when (> (- (get-internal-real-time) start-time) timeout-units)
#+sbcl (sb-thread:terminate-thread thread)
#-sbcl (bt:destroy-thread thread)
(kernel-log "KERNEL ERROR: Timeout loading skill ~a" (pathname-name filepath))
(return :timeout))
(sleep 0.1))))
(defun load-skill-from-org (filepath)
(when (uiop:file-exists-p filepath)
(let* ((content (uiop:read-file-string filepath)) (lines (uiop:split-string content :separator '(#\Newline)))
(in-lisp-block nil) (lisp-code "") (dependencies nil) (skill-base-name (pathname-name filepath))
(in-lisp-block nil) (lisp-code "") (skill-base-name (pathname-name filepath))
(pkg-name (intern (string-upcase (format nil "ORG-AGENT.SKILLS.~a" skill-base-name)) :keyword)))
(dolist (line lines)
(let ((clean-line (string-trim '(#\Space #\Tab #\Return) line)))
(when (uiop:string-prefix-p "#+DEPENDS_ON:" (string-upcase clean-line))
(setf dependencies (mapcar (lambda (s) (string-trim "[] " s)) (uiop:split-string (subseq clean-line 13) :separator '(#\Space)))))))
(dolist (line lines)
(let ((clean-line (string-trim '(#\Space #\Tab #\Return) line)))
(cond ((uiop:string-prefix-p "#+begin_src lisp" (string-downcase clean-line)) (setf in-lisp-block t))
@@ -43,9 +138,47 @@
(do-external-symbols (sym (find-package :org-agent)) (shadowing-import sym new-pkg))))
(let ((*read-eval* nil) (*package* (find-package pkg-name)))
(handler-case (eval (read-from-string (format nil "(progn ~a)" lisp-code)))
(error (c) (kernel-log "READER ERROR in skill '~a': ~a~%" skill-base-name c))))))))
(error (c)
(kernel-log "READER ERROR in skill '~a': ~a~%" skill-base-name c)
(error c))))))))
(defun validate-lisp-syntax (code-string)
(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)))
(error (c) (values nil (format nil "~a" c)))))
(def-cognitive-tool :eval "Evaluates raw Common Lisp code in the kernel image."
:parameters ((:code :type :string :description "The Lisp code to evaluate"))
:guard (lambda (args context)
(declare (ignore context))
(let ((code (getf args :code)))
(let ((harness-pkg (find-package :org-agent.skills.org-skill-safety-harness)))
(if harness-pkg
(uiop:symbol-call :org-agent.skills.org-skill-safety-harness :safety-harness-validate code)
t))))
:body (lambda (args)
(let ((code (getf args :code)))
(handler-case (let ((result (eval (read-from-string code))))
(format nil "~s" result))
(error (c) (format nil "ERROR: ~a" c))))))
(def-cognitive-tool :grep-search "Searches for a pattern in the project files."
:parameters ((:pattern :type :string :description "The regex pattern to search for")
(:dir :type :string :description "Directory to search in (default is project root)"))
:body (lambda (args)
(let ((pattern (getf args :pattern))
(dir (or (getf args :dir) (uiop:getenv "MEMEX_DIR"))))
(uiop:run-program (list "grep" "-r" "-n" "--exclude-dir=node_modules" pattern dir)
:output :string :ignore-error-status t))))
(def-cognitive-tool :shell "Executes a shell command on the local machine."
:parameters ((:cmd :type :string :description "The full bash command to execute"))
:guard (lambda (args context)
(declare (ignore context))
(let ((cmd (getf args :cmd)))
(not (or (search "rm -rf /" cmd) (search ":(){ :|:& };:" cmd)))))
:body (lambda (args)
(let ((cmd (getf args :cmd)))
(multiple-value-bind (out err code)
(uiop:run-program (list "bash" "-c" cmd) :output :string :error-output :string :ignore-error-status t)
(format nil "EXIT-CODE: ~a~%~%STDOUT:~%~a~%~%STDERR:~%~a" code out err)))))