feat: implement verified topological boot sequence and micro-loader

org-agent.asd

@@ -25,7 +25,9 @@
   :depends-on (:org-agent :fiveam)
   :components ((:module "tests"
                 :components ((:file "oacp-tests")
-                             (:file "cognitive-loop-tests"))))
+                             (:file "cognitive-loop-tests")
+                             (:file "boot-sequence-tests"))))
   :perform (test-op (o s) 
              (uiop:symbol-call :fiveam :run! (uiop:find-symbol* :oacp-suite :org-agent-tests))
-             (uiop:symbol-call :fiveam :run! (uiop:find-symbol* :cognitive-suite :org-agent-cognitive-tests))))
+             (uiop:symbol-call :fiveam :run! (uiop:find-symbol* :cognitive-suite :org-agent-cognitive-tests))
+             (uiop:symbol-call :fiveam :run! (uiop:find-symbol* :boot-suite :org-agent-boot-tests))))

src/core.lisp

@@ -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)
+(defun cognitive-loop (raw-message &optional (depth 0))
-  (let* ((start-time (get-internal-real-time))
+  (when (> depth 10)
-         (type (getf raw-message :type))
+    (kernel-log "SYSTEM ERROR: Maximum cognitive depth reached.")
-         (perceive-fn (find-symbol "PERCEIVE" :org-agent))
+    (return-from cognitive-loop nil))
-         (context (if perceive-fn (funcall perceive-fn raw-message) raw-message)))
+  (when (bt:with-lock-held (*interrupt-lock*) *interrupt-flag*)
-    (snapshot-object-store)
+    (kernel-log "SYSTEM: Loop interrupted.")
-    (if (eq type :REQUEST)
+    (bt:with-lock-held (*interrupt-lock*) (setf *interrupt-flag* nil))
-        (dispatch-action raw-message context)
+    (return-from cognitive-loop nil))
-        (let* ((skill (find-triggered-skill context))
+
-               (skill-name (when skill (skill-name skill)))
+  (handler-case
-               (proposed-action (think context))
+      (let* ((start-time (get-internal-real-time))
-               (approved-action (decide proposed-action context))
+             (type (getf raw-message :type))
-               (status (if (and proposed-action (null approved-action)) :rejected :success))
+             (perceive-fn (find-symbol "PERCEIVE" :org-agent))
-               (duration (- (get-internal-real-time) start-time)))
+             (context (if perceive-fn (funcall perceive-fn raw-message) raw-message)))
-          (when skill-name (kernel-track-telemetry skill-name duration status))
+        (snapshot-object-store)
-          (dispatch-action approved-action context)))))
+        (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)))))))
+                                (:point-update (let ((element (getf payload :element))) (when element (ingest-ast element))))
-          ((eq type :RESPONSE) (kernel-log "ACT RESULT: ~a" (getf payload :status))))
+                                (: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.
+  "Performs a topological boot sequence.
-   Supports selective loading via SKILLS_WHITELIST environment variable."
+   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)))
+         (skills-dir (if resolved-path (uiop:ensure-directory-pathname resolved-path) nil))
-    (if (and skills-dir (uiop:directory-exists-p skills-dir))
+         (timeout (or (ignore-errors (parse-integer (uiop:getenv "SKILL_LOAD_TIMEOUT"))) 5)))
-        (let ((files (uiop:directory-files skills-dir "org-skill-*.org")))
+    
-          (if files
+    (unless (and skills-dir (uiop:directory-exists-p skills-dir))
-              (dolist (file files)
+      (error "KERNEL FATAL: Skills directory not found: ~a" skills-dir-str))
-                (let ((skill-name (pathname-name file)))
+
-                  (if (or (null whitelist) (member skill-name whitelist :test #'string-equal))
+    ;; 1. The Gateway Handshake
-                      (load-skill-from-org file)
+    (let ((gateway-file (merge-pathnames "org-skill-agent.org" skills-dir)))
-                      (kernel-log "KERNEL: Skipping skill ~a (Not in whitelist)" skill-name))))
+      (unless (uiop:file-exists-p gateway-file)
-              (kernel-log "KERNEL: No skills found in ~a" resolved-path)))
+        (error "KERNEL FATAL: Gateway Skill (org-skill-agent.org) missing from ~a" resolved-path))
-        (kernel-log "KERNEL ERROR: Skills directory not found or invalid path: ~a" skills-dir-str))))
+      (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)

src/skills.lisp

@@ -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)))))

tests/boot-sequence-tests.lisp

@@ -0,0 +1,60 @@
+(defpackage :org-agent-boot-tests
+  (:use :cl :fiveam :org-agent))
+(in-package :org-agent-boot-tests)
+
+(def-suite boot-suite
+  :description "Verification of the Topological Boot Sequence.")
+(in-suite boot-suite)
+
+(defun call-with-temp-dir (fn)
+  (let ((tmp-dir (uiop:ensure-directory-pathname 
+                  (string-right-trim '(#\Newline) 
+                                     (uiop:run-program "mktemp -d" :output :string)))))
+    (unwind-protect
+         (funcall fn tmp-dir)
+      (uiop:delete-directory-tree tmp-dir :validate t))))
+
+(test gateway-enforcement
+  "Prove failure if org-skill-agent.org is missing."
+  (call-with-temp-dir 
+   (lambda (tmp-dir)
+     (let ((old-skills (uiop:getenv "SKILLS_DIR")))
+       (setf (uiop:getenv "SKILLS_DIR") (namestring tmp-dir))
+       (unwind-protect
+            (signals error (org-agent::load-all-skills))
+         (when old-skills (setf (uiop:getenv "SKILLS_DIR") old-skills)))))))
+
+(test topological-sort-logic
+  "Verify that skills are sorted based on #+DEPENDS_ON tags."
+  (call-with-temp-dir
+   (lambda (tmp-dir)
+     (let ((file-a (merge-pathnames "org-skill-a.org" tmp-dir))
+           (file-b (merge-pathnames "org-skill-b.org" tmp-dir))
+           (file-c (merge-pathnames "org-skill-c.org" tmp-dir)))
+       ;; A depends on B, B depends on C. Final order should be C, B, A.
+       (alexandria:write-string-into-file "#+TITLE: Skill A\n#+DEPENDS_ON: id:org-skill-b" file-a)
+       (alexandria:write-string-into-file "#+TITLE: Skill B\n#+DEPENDS_ON: id:org-skill-c" file-b)
+       (alexandria:write-string-into-file "#+TITLE: Skill C" file-c)
+       
+       (let ((sorted (org-agent:topological-sort-skills tmp-dir)))
+         (is (equal "org-skill-c" (pathname-name (first sorted))))
+         (is (equal "org-skill-b" (pathname-name (second sorted))))
+         (is (equal "org-skill-a" (pathname-name (third sorted)))))))))
+
+(test circular-dependency
+  "Verify that circular dependencies signal an error."
+  (call-with-temp-dir
+   (lambda (tmp-dir)
+     (let ((file-a (merge-pathnames "org-skill-a.org" tmp-dir))
+           (file-b (merge-pathnames "org-skill-b.org" tmp-dir)))
+       (alexandria:write-string-into-file "#+DEPENDS_ON: id:org-skill-b" file-a)
+       (alexandria:write-string-into-file "#+DEPENDS_ON: id:org-skill-a" file-b)
+       (signals error (org-agent:topological-sort-skills tmp-dir))))))
+
+(test load-skill-timeout
+  "Verify that slow skills are terminated."
+  (call-with-temp-dir
+   (lambda (tmp-dir)
+     (let ((slow-file (merge-pathnames "org-skill-slow.org" tmp-dir)))
+       (alexandria:write-string-into-file "#+begin_src lisp\n(sleep 10)\n#+end_src" slow-file)
+       (is (eq :timeout (org-agent:load-skill-with-timeout slow-file 1)))))))