Amr Gharbeia
924bf8f479
Some checks failed
Deploy (Gitea) / deploy (push) Failing after 2s
- Restore (in-package :passepartout) to core-reason - Move *VAULT-MEMORY* back to core-skills - Fix ASDF and defstruct/defpackage ordering - Increase daemon timeout to 120s - Handshake: 0.5.0 Verified: daemon processes messages, TUI clean, gate trace works
339 lines
18 KiB
Common Lisp
339 lines
18 KiB
Common Lisp
(in-package :passepartout)
|
|
|
|
(defvar *VAULT-MEMORY* (make-hash-table :test 'equal))
|
|
|
|
(defun vector-cosine-similarity (v1 v2)
|
|
"Computes cosine similarity between two vectors."
|
|
(let* ((len1 (length v1)) (len2 (length v2)))
|
|
(if (or (zerop len1) (zerop len2))
|
|
0.0
|
|
(let* ((dot 0.0d0) (n1 0.0d0) (n2 0.0d0))
|
|
(dotimes (i (min len1 len2))
|
|
(let* ((x (coerce (elt v1 i) 'double-float)) (y (coerce (elt v2 i) 'double-float)))
|
|
(incf dot (* x y)) (incf n1 (* x x)) (incf n2 (* y y))))
|
|
(if (or (zerop n1) (zerop n2)) 0.0 (/ dot (sqrt (* n1 n2))))))))
|
|
|
|
(defstruct skill name priority dependencies trigger-fn probabilistic-prompt deterministic-fn)
|
|
|
|
(defvar *skill-registry* (make-hash-table :test 'equal))
|
|
|
|
(defvar *skill-catalog* (make-hash-table :test 'equal)
|
|
"Tracks all discovered skill files and their loading state.")
|
|
|
|
(defvar *standing-mandates* nil
|
|
"List of functions (context) → string-or-nil. Each is called on every think() cycle.
|
|
When non-nil, the returned string is injected into the IDENTITY section of the system prompt.
|
|
Unlike skills (which activate on triggers), standing mandates are always consulted.")
|
|
|
|
(defstruct skill-entry filename (status :discovered) error-log (load-time 0))
|
|
|
|
;; Alias: find-triggered-skill → skill-triggered-find
|
|
(defun find-triggered-skill (context)
|
|
(skill-triggered-find context))
|
|
|
|
(defun skill-triggered-find (context)
|
|
"Returns the highest priority skill whose trigger matches context."
|
|
(let ((triggered nil))
|
|
(maphash (lambda (name skill)
|
|
(declare (ignore name))
|
|
(when (and (skill-probabilistic-prompt skill)
|
|
(ignore-errors (funcall (skill-trigger-fn skill) context)))
|
|
(push skill triggered)))
|
|
*skill-registry*)
|
|
(first (sort triggered #'> :key #'skill-priority))))
|
|
|
|
(defmacro defskill (name &key priority dependencies trigger probabilistic deterministic)
|
|
"Registers a new skill. NAME is a keyword. TRIGGER is a function (context) → bool."
|
|
`(setf (gethash (string-downcase (string ,name)) *skill-registry*)
|
|
(make-skill :name (string-downcase (string ,name))
|
|
:priority (or ,priority 10)
|
|
:dependencies ',dependencies
|
|
:trigger-fn ,trigger
|
|
:probabilistic-prompt ,probabilistic
|
|
:deterministic-fn ,deterministic)))
|
|
|
|
(defun skill-dependencies-resolve (skill-name)
|
|
"Resolves transitive dependencies. Returns list of skill names in dependency order."
|
|
(let ((resolved nil) (seen nil))
|
|
(labels ((visit (name)
|
|
(unless (member name seen :test #'equal)
|
|
(push name seen)
|
|
(let ((skill (gethash (string-downcase (string name)) *skill-registry*)))
|
|
(when skill
|
|
(dolist (dep (skill-dependencies skill)) (visit dep))))
|
|
(push name resolved))))
|
|
(visit skill-name)
|
|
(nreverse resolved))))
|
|
|
|
(defun skill-metadata-parse (filepath)
|
|
"Extracts ID and DEPENDS_ON tags from org file."
|
|
(let ((dependencies nil) (id nil) (content (uiop:read-file-string filepath)))
|
|
(let ((id-start (search ":ID:" content)))
|
|
(when id-start
|
|
(let ((id-end (position #\Newline content :start id-start)))
|
|
(when id-end (setf id (string-trim " " (subseq content (+ id-start 4) id-end)))))))
|
|
(let ((pos 0))
|
|
(loop while (setf pos (search "#+DEPENDS_ON:" content :start2 pos))
|
|
do (let ((end (position #\Newline content :start pos)))
|
|
(when end
|
|
(let ((line (string-trim " " (subseq content (+ pos 13) end))))
|
|
(dolist (d (uiop:split-string line :separator '(#\Space #\Tab)))
|
|
(unless (string= d "") (push d dependencies))))
|
|
(setf pos end)))))
|
|
(values id (reverse dependencies))))
|
|
|
|
(defun skill-topological-sort (skills-dir)
|
|
"Returns a list of skill filepaths sorted by dependency."
|
|
(let* ((org-files (uiop:directory-files skills-dir "*.org"))
|
|
(lisp-files (uiop:directory-files skills-dir "*.lisp"))
|
|
(all-files (append org-files lisp-files))
|
|
(files (remove-if (lambda (f)
|
|
(let ((n (pathname-name f)))
|
|
(or (string= n "core-package")
|
|
(string= n "core-skills")
|
|
(string= n "core-transport")
|
|
(string= n "core-memory")
|
|
(string= n "core-context")
|
|
(string= n "core-perceive")
|
|
(string= n "core-reason")
|
|
(string= n "core-act")
|
|
(string= n "core-pipeline")
|
|
(string= n "core-manifest")
|
|
(string= n "neuro-router")
|
|
(string= n "neuro-explorer")
|
|
(string= n "channel-tui"))))
|
|
all-files))
|
|
(adj (make-hash-table :test 'equal))
|
|
(name-to-file (make-hash-table :test 'equal))
|
|
(id-to-file (make-hash-table :test 'equal))
|
|
(result nil)
|
|
(visited (make-hash-table :test 'equal))
|
|
(stack (make-hash-table :test 'equal)))
|
|
(dolist (file files)
|
|
(let ((filename (pathname-name file)))
|
|
(if (uiop:string-suffix-p (namestring file) ".lisp")
|
|
(progn
|
|
(setf (gethash (string-downcase filename) name-to-file) file)
|
|
(unless (gethash (string-downcase filename) adj)
|
|
(setf (gethash (string-downcase filename) adj) nil)))
|
|
(multiple-value-bind (id deps) (skill-metadata-parse file)
|
|
(setf (gethash (string-downcase filename) name-to-file) file)
|
|
(when id (setf (gethash (string-downcase id) id-to-file) file))
|
|
(setf (gethash (string-downcase filename) adj) deps)))))
|
|
(labels ((visit (file)
|
|
(let* ((filename (pathname-name file))
|
|
(node-key (string-downcase filename)))
|
|
(unless (gethash node-key visited)
|
|
(setf (gethash node-key stack) t)
|
|
(dolist (dep (gethash node-key adj))
|
|
(let* ((is-id-p (uiop:string-prefix-p "id:" (string-downcase dep)))
|
|
(dep-key (string-downcase (if is-id-p (subseq dep 3) dep)))
|
|
(dep-file (if is-id-p
|
|
(gethash dep-key id-to-file)
|
|
(or (gethash dep-key id-to-file)
|
|
(gethash dep-key name-to-file)))))
|
|
(when dep-file
|
|
(let ((dep-filename (pathname-name dep-file)))
|
|
(if (gethash (string-downcase dep-filename) stack)
|
|
(error "Circular dependency detected")
|
|
(visit dep-file))))))
|
|
(setf (gethash node-key stack) nil)
|
|
(setf (gethash node-key visited) t)
|
|
(push file result)))))
|
|
(let ((filenames (sort (mapcar #'pathname-name files) #'string<)))
|
|
(dolist (name filenames)
|
|
(let ((file (gethash (string-downcase name) name-to-file)))
|
|
(when file (visit file)))))
|
|
(nreverse result))))
|
|
|
|
(defun lisp-syntax-validate (code-string)
|
|
"Checks if a string contains valid Common Lisp forms."
|
|
(handler-case
|
|
(let ((*read-eval* nil))
|
|
(with-input-from-string (s (format nil "(progn ~a)" code-string))
|
|
(loop for form = (read s nil :eof) until (eq form :eof)))
|
|
(values t nil))
|
|
(error (c) (values nil (format nil "~a" c)))))
|
|
|
|
(defun skill-package-forms-strip (code-string)
|
|
"Removes (in-package :passepartout) forms only — preserves test-package
|
|
declarations so embedded test code evaluates in the correct package."
|
|
(let ((lines (uiop:split-string code-string :separator '(#\Newline)))
|
|
(result ""))
|
|
(dolist (line lines)
|
|
(let ((trimmed (string-trim '(#\Space #\Tab) line)))
|
|
(if (uiop:string-prefix-p "(in-package :passepartout)" trimmed)
|
|
(setf result (concatenate 'string result (string #\Newline)))
|
|
(setf result (concatenate 'string result line (string #\Newline))))))
|
|
result))
|
|
|
|
(defun tangle-target-extract (line)
|
|
"Extracts the value of the :tangle header."
|
|
(let ((pos (search ":tangle" line)))
|
|
(when pos
|
|
(let ((rest (string-tirm '(#\Space #\Tab) (subseq line (+ pos 7)))))
|
|
(let ((end (position #\Space rest)))
|
|
(if end (subseq rest 0 end) rest))))))
|
|
|
|
(defun load-skill-from-org (filepath)
|
|
"Parses and evaluates Lisp blocks from an Org file."
|
|
(let* ((skill-base-name (pathname-name filepath))
|
|
(entry (or (gethash skill-base-name *skill-catalog*) (setf (gethash skill-base-name *skill-catalog*) (make-skill-entry :filename skill-base-name)))))
|
|
(setf (skill-entry-status entry) :loading)
|
|
(handler-case
|
|
(let* ((content (uiop:read-file-string filepath))
|
|
(lines (uiop:split-string content :separator '(#\Newline)))
|
|
(in-lisp-block nil) (collect-this-block nil) (lisp-code "")
|
|
(pkg-name (intern (string-upcase (format nil "PASSEPARTOUT.SKILLS.~a" skill-base-name)) :keyword)))
|
|
(dolist (line lines)
|
|
(let ((clean-line (string-trim '(#\Space #\Tab #\Return) line)))
|
|
(cond
|
|
((uiop:string-prefix-p "#+begin_src lisp" clean-line)
|
|
(setf in-lisp-block t)
|
|
(let ((target (tangle-target-extract clean-line)))
|
|
(setf collect-this-block (or (null target)
|
|
(and (not (search "no" target))
|
|
(not (search "/tests" target)))))))
|
|
((uiop:string-prefix-p "#+end_src" clean-line)
|
|
(setf in-lisp-block nil) (setf collect-this-block nil))
|
|
((and in-lisp-block collect-this-block)
|
|
(unless (or (uiop:string-prefix-p ":PROPERTIES:" (string-upcase clean-line))
|
|
(uiop:string-prefix-p ":END:" (string-upcase clean-line))
|
|
(uiop:string-prefix-p ":ID:" (string-upcase clean-line)))
|
|
(setf lisp-code (concatenate 'string lisp-code line (string #\Newline))))))))
|
|
(if (= (length lisp-code) 0)
|
|
(setf (skill-entry-status entry) :ready)
|
|
(progn
|
|
(multiple-value-bind (valid-p err) (lisp-syntax-validate lisp-code)
|
|
(unless valid-p (error err)))
|
|
(unless (find-package pkg-name)
|
|
(let ((new-pkg (make-package pkg-name :use '(:cl)))) (use-package :passepartout new-pkg)))
|
|
(let ((*read-eval* nil) (*package* (find-package pkg-name)))
|
|
(log-message "LOADER: Evaluating code for '~a' in package ~a" skill-base-name (package-name *package*))
|
|
(eval (read-from-string (format nil "(progn ~a)" lisp-code))))
|
|
|
|
(let ((target-pkg (find-package :passepartout))
|
|
(exported 0)
|
|
(seen (make-hash-table :test 'equal)))
|
|
(do-symbols (sym (find-package pkg-name))
|
|
(when (and (eq (symbol-package sym) (find-package pkg-name))
|
|
(or (fboundp sym) (boundp sym))
|
|
(not (gethash (symbol-name sym) seen)))
|
|
(setf (gethash (symbol-name sym) seen) t)
|
|
(incf exported)
|
|
(let ((existing (find-symbol (symbol-name sym) target-pkg)))
|
|
(when existing (unintern existing target-pkg)))
|
|
(import sym target-pkg)
|
|
(export sym target-pkg)))
|
|
(log-message "LOADER: Exported ~a symbols from ~a to :PASSEPARTOUT"
|
|
exported (package-name (find-package pkg-name))))
|
|
|
|
(setf (skill-entry-status entry) :ready)))
|
|
t)
|
|
(error (c)
|
|
(log-message "LOADER ERROR in skill '~a': ~a" skill-base-name c)
|
|
(setf (skill-entry-status entry) :failed) nil))))
|
|
|
|
(defun load-skill-from-lisp (filepath)
|
|
"Loads a .lisp skill file directly, filtering out in-package forms."
|
|
(let* ((skill-base-name (pathname-name filepath))
|
|
(entry (or (gethash skill-base-name *skill-catalog*) (setf (gethash skill-base-name *skill-catalog*) (make-skill-entry :filename skill-base-name)))))
|
|
(setf (skill-entry-status entry) :loading)
|
|
(handler-case
|
|
(let* ((content (skill-package-forms-strip (uiop:read-file-string filepath)))
|
|
(pkg-name (intern (string-upcase (format nil "PASSEPARTOUT.SKILLS.~a" skill-base-name)) :keyword)))
|
|
(multiple-value-bind (valid-p err) (lisp-syntax-validate content)
|
|
(unless valid-p (error err)))
|
|
(unless (find-package pkg-name)
|
|
(let ((new-pkg (make-package pkg-name :use '(:cl)))) (use-package :passepartout new-pkg)))
|
|
(let ((*read-eval* nil) (*package* (find-package pkg-name)))
|
|
(log-message "LOADER: Loading .lisp skill '~a' in package ~a" skill-base-name (package-name *package*))
|
|
(with-input-from-string (s content)
|
|
(loop for form = (read s nil :eof) until (eq form :eof)
|
|
do (handler-case (eval form)
|
|
(error (c) (log-message "LOADER WARNING in '~a': ~a" skill-base-name c))))))
|
|
(let* ((jailed-pkg (find-package pkg-name))
|
|
(restricted '("RUN-PROGRAM" "SHELL" "RUN-SHELL-COMMAND"))
|
|
(violation (loop for r in restricted
|
|
for sym = (find-symbol r :uiop)
|
|
when (and sym (fboundp sym)
|
|
(loop for skill-sym being the symbols of jailed-pkg
|
|
when (and (fboundp skill-sym)
|
|
(eq (symbol-function skill-sym)
|
|
(symbol-function sym)))
|
|
return skill-sym))
|
|
collect (format nil "~a" sym))))
|
|
(when violation
|
|
(log-message "LOADER SANDBOX: Skill '~a' blocked — references restricted symbol(s): ~{~a~^, ~}"
|
|
skill-base-name violation)
|
|
(setf (skill-entry-status entry) :sandbox-blocked)
|
|
(return-from load-skill-from-lisp nil))
|
|
(log-message "LOADER SANDBOX: Skill '~a' passed sandbox check" skill-base-name))
|
|
(let ((target-pkg (find-package :passepartout))
|
|
(exported 0)
|
|
(seen (make-hash-table :test 'equal)))
|
|
(do-symbols (sym (find-package pkg-name))
|
|
(when (and (eq (symbol-package sym) (find-package pkg-name))
|
|
(or (fboundp sym) (boundp sym))
|
|
(not (gethash (symbol-name sym) seen)))
|
|
(setf (gethash (symbol-name sym) seen) t)
|
|
(incf exported)
|
|
(let ((existing (find-symbol (symbol-name sym) target-pkg)))
|
|
(when existing (unintern existing target-pkg)))
|
|
(import sym target-pkg)
|
|
(ignore-errors (export sym target-pkg))))
|
|
(log-message "LOADER: Exported ~a symbols from ~a to :PASSEPARTOUT"
|
|
exported (package-name (find-package pkg-name))))
|
|
(setf (skill-entry-status entry) :ready))
|
|
(error (c)
|
|
(log-message "LOADER ERROR in skill '~a': ~a" skill-base-name c)
|
|
(setf (skill-entry-status entry) :failed) nil))))
|
|
|
|
(defun skill-initialize-all ()
|
|
"Initializes all skills from the XDG data directory."
|
|
(let* ((data-dir (uiop:ensure-directory-pathname (or (uiop:getenv "PASSEPARTOUT_DATA_DIR") (namestring (merge-pathnames ".local/share/passepartout/" (user-homedir-pathname))))))
|
|
(skills-dir (merge-pathnames "lisp/" (uiop:ensure-directory-pathname data-dir))))
|
|
(unless (uiop:directory-exists-p skills-dir) (return-from skill-initialize-all nil))
|
|
(let ((sorted-files (skill-topological-sort skills-dir)))
|
|
(log-message "LOADER: Initializing ~a skills..." (length sorted-files))
|
|
(dolist (file sorted-files)
|
|
(if (uiop:string-suffix-p (namestring file) ".lisp")
|
|
(load-skill-from-lisp file)
|
|
(load-skill-from-org file)))
|
|
(log-message "LOADER: Boot Complete."))))
|
|
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(ql:quickload :fiveam :silent t))
|
|
|
|
(defpackage :passepartout-boot-tests
|
|
(:use :cl :fiveam :passepartout)
|
|
(:export #:boot-suite))
|
|
|
|
(in-package :passepartout-boot-tests)
|
|
|
|
(def-suite boot-suite :description "Verification of the Skill Engine loader")
|
|
(in-suite boot-suite)
|
|
|
|
(test test-topological-sort-basic
|
|
"Contract 2: dependency ordering puts dependencies before dependents."
|
|
(let ((tmp-dir "/tmp/passepartout-boot-test/"))
|
|
(uiop:ensure-all-directories-exist (list tmp-dir))
|
|
(with-open-file (out (merge-pathnames "org-skill-a.org" tmp-dir) :direction :output :if-exists :supersede)
|
|
(format out "#+DEPENDS_ON: skill-b-id~%"))
|
|
(with-open-file (out (merge-pathnames "org-skill-b.org" tmp-dir) :direction :output :if-exists :supersede)
|
|
(format out ":PROPERTIES:~%:ID: skill-b-id~%:END:~%"))
|
|
(unwind-protect
|
|
(let ((sorted (passepartout::skill-topological-sort tmp-dir)))
|
|
(let ((pos-a (position "org-skill-a" sorted :key #'pathname-name :test #'string-equal))
|
|
(pos-b (position "org-skill-b" sorted :key #'pathname-name :test #'string-equal)))
|
|
(is (< pos-b pos-a))))
|
|
(uiop:delete-directory-tree (uiop:ensure-directory-pathname tmp-dir) :validate t))))
|
|
|
|
(test test-lisp-syntax-validate-valid
|
|
"Contract 1: valid Lisp code passes syntax validation."
|
|
(is (eq t (lisp-syntax-validate "(+ 1 2)"))))
|
|
|
|
(test test-lisp-syntax-validate-invalid
|
|
"Contract 1: unbalanced Lisp code fails syntax validation."
|
|
(is (null (lisp-syntax-validate "(+ 1 2"))))
|