diff --git a/org-agent.asd b/org-agent.asd index 9a53ad0..a4c74c6 100644 --- a/org-agent.asd +++ b/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)))) diff --git a/src/core.lisp b/src/core.lisp index c667209..0d0ad17 100644 --- a/src/core.lisp +++ b/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) - (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) diff --git a/src/skills.lisp b/src/skills.lisp index c7eb183..c77dcdd 100644 --- a/src/skills.lisp +++ b/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 :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))))) diff --git a/tests/boot-sequence-tests.lisp b/tests/boot-sequence-tests.lisp new file mode 100644 index 0000000..7b5cf52 --- /dev/null +++ b/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)))))))