Amr Gharbeia
639bc348d9
Some checks failed
Deploy (Gitea) / deploy (push) Failing after 2s
- Remove system-prompt-augment mechanism, introduce *standing-mandates* - Fix false token-overhead claims in DESIGN_DECISIONS + ROADMAP - Update security vector count 9-10 across all docs and dispatcher docstring - Rewrite README with agent section, soften aspirational claims - Register 10 cognitive tools in programming-tools.org with test suite - Enforce NO-HARDCODED-CONSTANTS in .env.example - ROADMAP: mark v0.3.x patches DONE, add LOGBOOKs, mark releases - AGENTS.md: rewrite compact (180 to 50 lines), move refs to CONTRIBUTING - Normalize org tangle directives to file-level PROPERTY inheritance
421 lines
20 KiB
Common Lisp
421 lines
20 KiB
Common Lisp
(in-package :passepartout)
|
|
|
|
(defun tools-write-file (filepath content)
|
|
"Write string CONTENT to FILEPATH, creating parent directories."
|
|
(uiop:ensure-all-directories-exist (list filepath))
|
|
(with-open-file (stream filepath :direction :output :if-exists :supersede :if-does-not-exist :create)
|
|
(write-string content stream)))
|
|
|
|
(def-cognitive-tool search-files
|
|
"Search file contents under a directory for a regex pattern."
|
|
((:name "pattern" :description "The regex pattern to search for." :type "string")
|
|
(:name "path" :description "Directory to search recursively." :type "string")
|
|
(:name "include" :description "Optional glob filter for filenames (e.g. \"*.lisp\")." :type "string"))
|
|
:guard nil
|
|
:body (lambda (args)
|
|
(block nil
|
|
(let* ((pattern (getf args :pattern))
|
|
(path (getf args :path))
|
|
(include (getf args :include))
|
|
(results nil))
|
|
(unless (and pattern path)
|
|
(return (list :status :error :message "search-files requires :pattern and :path")))
|
|
(handler-case
|
|
(dolist (file (directory (merge-pathnames
|
|
(if include
|
|
(make-pathname :name :wild :type (subseq include 2) :defaults path)
|
|
(make-pathname :name :wild :type :wild :defaults path))
|
|
path)))
|
|
(let ((base (file-namestring file)))
|
|
(with-open-file (stream file :direction :input :if-does-not-exist nil)
|
|
(when stream
|
|
(loop for line = (read-line stream nil nil)
|
|
for line-num from 1
|
|
while line
|
|
when (cl-ppcre:scan pattern line)
|
|
do (push (format nil "~a:~d: ~a" base line-num (string-trim '(#\Space #\Tab) line))
|
|
results))))))
|
|
(t (c) (return (list :status :error :message (format nil "~a" c)))))
|
|
(list :status :success
|
|
:content (if results
|
|
(format nil "~d matches:~%~a" (length results)
|
|
(format nil "~{~a~^~%~}" (reverse results)))
|
|
(format nil "No matches for '~a' in ~a" pattern path)))))))
|
|
|
|
(def-cognitive-tool find-files
|
|
"Find files matching a glob pattern under a directory."
|
|
((:name "pattern" :description "Glob pattern (e.g. \"*.lisp\", \"core-*\")." :type "string")
|
|
(:name "path" :description "Directory to search in." :type "string"))
|
|
:guard nil
|
|
:body (lambda (args)
|
|
(block nil
|
|
(let* ((pattern (getf args :pattern))
|
|
(path (getf args :path)))
|
|
(unless (and pattern path)
|
|
(return (list :status :error :message "find-files requires :pattern and :path")))
|
|
(let ((full (merge-pathnames pattern path)))
|
|
(handler-case
|
|
(let ((files (directory full)))
|
|
(list :status :success
|
|
:content (if files
|
|
(format nil "~d files:~%~{~a~^~%~}" (length files) files)
|
|
(format nil "No files matching '~a' in ~a" pattern path))))
|
|
(t (c) (list :status :error :message (format nil "~a" c)))))))))
|
|
|
|
(def-cognitive-tool read-file
|
|
"Read the contents of a file."
|
|
((:name "filepath" :description "Path to the file to read." :type "string")
|
|
(:name "start" :description "Optional: line number to start reading from (1-based)." :type "integer")
|
|
(:name "limit" :description "Optional: maximum number of lines to read." :type "integer"))
|
|
:guard (lambda (args) (declare (ignore args)) nil)
|
|
:body (lambda (args)
|
|
(block nil
|
|
(let* ((filepath (getf args :filepath))
|
|
(start (getf args :start))
|
|
(limit (getf args :limit)))
|
|
(unless filepath
|
|
(return (list :status :error :message "read-file requires :filepath")))
|
|
(handler-case
|
|
(let ((content (uiop:read-file-string filepath)))
|
|
(if (or start limit)
|
|
(let* ((lines (uiop:split-string content :separator '(#\Newline)))
|
|
(start-idx (max 0 (1- (or start 1))))
|
|
(end (if limit (min (length lines) (+ start-idx limit)) (length lines)))
|
|
(selected (subseq lines start-idx end)))
|
|
(list :status :success
|
|
:content (format nil "~{~a~^~%~}" selected)))
|
|
(list :status :success :content content)))
|
|
(error (c) (list :status :error :message (format nil "~a" c))))))))
|
|
|
|
(def-cognitive-tool write-file
|
|
"Write string content to a file. Created directories as needed."
|
|
((:name "filepath" :description "Path to the file to write." :type "string")
|
|
(:name "content" :description "The text content to write." :type "string"))
|
|
:guard nil
|
|
:body (lambda (args)
|
|
(block nil
|
|
(let* ((filepath (getf args :filepath))
|
|
(content (getf args :content)))
|
|
(unless (and filepath content)
|
|
(return (list :status :error :message "write-file requires :filepath and :content")))
|
|
(handler-case
|
|
(progn
|
|
(tools-write-file filepath content)
|
|
(list :status :success
|
|
:content (format nil "Written ~d bytes to ~a" (length content) filepath)))
|
|
(error (c) (list :status :error :message (format nil "~a" c))))))))
|
|
|
|
(def-cognitive-tool list-directory
|
|
"List the contents of a directory."
|
|
((:name "path" :description "Directory path to list." :type "string")
|
|
(:name "pattern" :description "Optional glob filter (e.g. \"*.org\")." :type "string"))
|
|
:guard nil
|
|
:body (lambda (args)
|
|
(block nil
|
|
(let* ((path (getf args :path))
|
|
(pattern (getf args :pattern)))
|
|
(unless path
|
|
(return (list :status :error :message "list-directory requires :path")))
|
|
(let ((full-pattern (if pattern
|
|
(merge-pathnames pattern path)
|
|
(make-pathname :name :wild :type :wild :defaults path))))
|
|
(handler-case
|
|
(let ((entries (directory full-pattern)))
|
|
(list :status :success
|
|
:content (if entries
|
|
(format nil "~d entries in ~a:~%~{~a~^~%~}" (length entries) path entries)
|
|
(format nil "No entries in ~a" path))))
|
|
(t (c) (list :status :error :message (format nil "~a" c)))))))))
|
|
|
|
(def-cognitive-tool run-shell
|
|
"Execute a shell command and return stdout, stderr, and exit code."
|
|
((:name "cmd" :description "The shell command to execute." :type "string")
|
|
(:name "timeout" :description "Optional timeout in seconds (default 30)." :type "integer"))
|
|
:guard nil
|
|
:body (lambda (args)
|
|
(block nil
|
|
(let* ((cmd (getf args :cmd))
|
|
(timeout (or (getf args :timeout) 30)))
|
|
(unless cmd
|
|
(return (list :status :error :message "run-shell requires :cmd")))
|
|
(handler-case
|
|
(multiple-value-bind (out err code)
|
|
(uiop:run-program (list "timeout" (format nil "~a" timeout) "bash" "-c" cmd)
|
|
:output :string :error-output :string
|
|
:ignore-error-status t)
|
|
(list :status :success
|
|
:content (format nil "~a~@[~%~%stderr:~%~a~]~%exit: ~d"
|
|
(or out "") (when (and err (> (length err) 0)) err) code)))
|
|
(error (c) (list :status :error :message (format nil "~a" c))))))))
|
|
|
|
(def-cognitive-tool eval-form
|
|
"Evaluate a Lisp expression in the running image and return the result."
|
|
((:name "code" :description "The Lisp expression to evaluate as a string." :type "string"))
|
|
:guard nil
|
|
:body (lambda (args)
|
|
(block nil
|
|
(let* ((code (getf args :code)))
|
|
(unless code
|
|
(return (list :status :error :message "eval-form requires :code")))
|
|
(handler-case
|
|
(let* ((*read-eval* nil)
|
|
(form (read-from-string code))
|
|
(result (eval form)))
|
|
(list :status :success :content (format nil "~a" result)))
|
|
(error (c) (list :status :error :message (format nil "~a" c))))))))
|
|
|
|
(def-cognitive-tool run-tests
|
|
"Run FiveAM tests. With no arguments, runs all test suites."
|
|
((:name "test-name" :description "Optional: specific test name to run. If nil, runs all tests." :type "string"))
|
|
:guard nil
|
|
:body (lambda (args)
|
|
(block nil
|
|
(let* ((test-name (getf args :test-name)))
|
|
(handler-case
|
|
(if test-name
|
|
(let* ((sym (find-symbol (string-upcase test-name) :passepartout))
|
|
(result (when sym (fiveam:run (intern (string-upcase test-name) :passepartout)))))
|
|
(list :status :success
|
|
:content (format nil "Test '~a' ~a" test-name
|
|
(if result "completed" "not found"))))
|
|
(let ((result (fiveam:run-all-tests)))
|
|
(list :status :success :content (format nil "~a" result))))
|
|
(error (c) (list :status :error :message (format nil "~a" c))))))))
|
|
|
|
(def-cognitive-tool org-find-headline
|
|
"Find an Org headline by ID or title in the memory store."
|
|
((:name "id" :description "Optional: Org ID property to search for." :type "string")
|
|
(:name "title" :description "Optional: headline title to search for (case-insensitive substring)." :type "string"))
|
|
:guard nil
|
|
:body (lambda (args)
|
|
(block nil
|
|
(let* ((id (getf args :id))
|
|
(title (getf args :title))
|
|
(results nil))
|
|
(unless (or id title)
|
|
(return (list :status :error :message "org-find-headline requires :id or :title")))
|
|
(handler-case
|
|
(let ((is-mem (find-symbol "MEMORY-OBJECT-P" :passepartout))
|
|
(get-id (find-symbol "MEMORY-OBJECT-ID" :passepartout))
|
|
(get-title (find-symbol "MEMORY-OBJECT-TITLE" :passepartout)))
|
|
(unless (and is-mem get-id get-title)
|
|
(return (list :status :error :message "Memory store not loaded")))
|
|
(maphash (lambda (k obj)
|
|
(declare (ignore k))
|
|
(when (and (funcall is-mem obj)
|
|
(or (and id (string-equal id (funcall get-id obj)))
|
|
(and title (search title (funcall get-title obj) :test #'char-equal))))
|
|
(push obj results)))
|
|
*memory-store*)
|
|
(list :status :success
|
|
:content (if results
|
|
(format nil "~d headlines found:~%~{~a~^~%~}"
|
|
(length results)
|
|
(mapcar (lambda (r) (funcall get-title r)) results))
|
|
(format nil "No headlines matching ~a" (or id title)))))
|
|
(error (c) (list :status :error :message (format nil "~a" c))))))))
|
|
|
|
(def-cognitive-tool org-modify-file
|
|
"Replace text in an Org file via exact string match. Returns error if old-text not found."
|
|
((:name "filepath" :description "Path to the Org file." :type "string")
|
|
(:name "old-text" :description "Exact text to replace." :type "string")
|
|
(:name "new-text" :description "Text to insert in its place." :type "string"))
|
|
:guard nil
|
|
:body (lambda (args)
|
|
(block nil
|
|
(let* ((filepath (getf args :filepath))
|
|
(old-text (getf args :old-text))
|
|
(new-text (getf args :new-text)))
|
|
(unless (and filepath old-text new-text)
|
|
(return (list :status :error :message "org-modify-file requires :filepath, :old-text, and :new-text")))
|
|
(handler-case
|
|
(let ((content (uiop:read-file-string filepath)))
|
|
(let ((pos (search old-text content)))
|
|
(if pos
|
|
(let ((new-content (concatenate 'string
|
|
(subseq content 0 pos)
|
|
new-text
|
|
(subseq content (+ pos (length old-text))))))
|
|
(tools-write-file filepath new-content)
|
|
(list :status :success
|
|
:content (format nil "Replaced at position ~d in ~a" pos filepath)))
|
|
(list :status :error :message (format nil "Text not found in ~a" filepath)))))
|
|
(error (c) (list :status :error :message (format nil "~a" c))))))))
|
|
|
|
(defskill :passepartout-programming-tools
|
|
:priority 50
|
|
:trigger (lambda (ctx) (declare (ignore ctx)) nil)
|
|
:deterministic (lambda (action ctx) (declare (ignore action ctx)) nil))
|
|
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(ql:quickload :fiveam :silent t))
|
|
|
|
(defpackage :passepartout-programming-tools-tests
|
|
(:use :cl :fiveam :passepartout)
|
|
(:export #:programming-tools-suite))
|
|
|
|
(in-package :passepartout-programming-tools-tests)
|
|
|
|
(def-suite programming-tools-suite :description "Verification of programming cognitive tools")
|
|
(in-suite programming-tools-suite)
|
|
|
|
(defun tools-tmpdir ()
|
|
(let ((d (merge-pathnames "tmp/passepartout-tool-tests/" (user-homedir-pathname))))
|
|
(uiop:ensure-all-directories-exist (list d))
|
|
d))
|
|
|
|
(defun tools-cleanup ()
|
|
(let ((d (tools-tmpdir)))
|
|
(uiop:delete-directory-tree d :validate t :if-does-not-exist :ignore)))
|
|
|
|
(defun tools-write-file (filepath content)
|
|
(uiop:ensure-all-directories-exist (list filepath))
|
|
(with-open-file (stream filepath :direction :output :if-exists :supersede :if-does-not-exist :create)
|
|
(write-string content stream)))
|
|
|
|
(defun call-tool (tool-name &rest args)
|
|
(let ((tool (gethash (string-downcase (string tool-name)) *cognitive-tool-registry*)))
|
|
(unless tool (error "Tool ~a not found" tool-name))
|
|
(funcall (cognitive-tool-body tool) args)))
|
|
|
|
;; search-files
|
|
(test test-search-files-finds-matches
|
|
"Contract 1: search-files finds lines matching a regex pattern."
|
|
(let* ((dir (tools-tmpdir))
|
|
(file-a (merge-pathnames "src-a.lisp" dir))
|
|
(file-b (merge-pathnames "src-b.lisp" dir)))
|
|
(tools-write-file file-a "(defun foo () 'hello)")
|
|
(tools-write-file file-b "(defun bar () 'world)")
|
|
(let ((result (call-tool 'search-files :pattern "defun" :path (namestring dir) :include "*.lisp")))
|
|
(is (eq (getf result :status) :success))
|
|
(is (search "src-a.lisp:1:" (getf result :content)))
|
|
(is (search "src-b.lisp:1:" (getf result :content))))
|
|
(tools-cleanup)))
|
|
|
|
(test test-search-files-missing-params
|
|
"search-files returns error when required params are missing."
|
|
(let ((result (call-tool 'search-files :pattern "x")))
|
|
(is (eq (getf result :status) :error))))
|
|
|
|
;; find-files
|
|
(test test-find-files-by-extension
|
|
"Contract 5: find-files returns files matching a glob."
|
|
(let ((dir (tools-tmpdir)))
|
|
(tools-write-file (merge-pathnames "a.lisp" dir) "test")
|
|
(tools-write-file (merge-pathnames "b.lisp" dir) "test")
|
|
(tools-write-file (merge-pathnames "c.org" dir) "test")
|
|
(let ((result (call-tool 'find-files :pattern "*.lisp" :path (namestring dir))))
|
|
(is (eq (getf result :status) :success))
|
|
(is (search "a.lisp" (getf result :content)))
|
|
(is (search "b.lisp" (getf result :content)))
|
|
(is (not (search "c.org" (getf result :content)))))
|
|
(tools-cleanup)))
|
|
|
|
(test test-find-files-missing-params
|
|
"find-files returns error without required params."
|
|
(let ((result (call-tool 'find-files :pattern "*.lisp")))
|
|
(is (eq (getf result :status) :error))))
|
|
|
|
;; read-file
|
|
(test test-read-file-full
|
|
"Contract 6: read-file returns full file contents."
|
|
(let* ((dir (tools-tmpdir))
|
|
(file (merge-pathnames "readme.txt" dir)))
|
|
(tools-write-file file (format nil "line one~%line two~%line three"))
|
|
(let ((result (call-tool 'read-file :filepath (namestring file))))
|
|
(is (eq (getf result :status) :success))
|
|
(is (search "line one" (getf result :content))))
|
|
(tools-cleanup)))
|
|
|
|
(test test-read-file-missing-params
|
|
"read-file returns error without :filepath."
|
|
(let ((result (call-tool 'read-file)))
|
|
(is (eq (getf result :status) :error))))
|
|
|
|
;; write-file
|
|
(test test-write-file-creates
|
|
"Contract 7: write-file creates file with content."
|
|
(let* ((dir (tools-tmpdir))
|
|
(file (merge-pathnames "output.txt" dir)))
|
|
(let ((result (call-tool 'write-file :filepath (namestring file) :content "hello world")))
|
|
(is (eq (getf result :status) :success))
|
|
(is (search "11 bytes" (getf result :content))))
|
|
(is (string-equal "hello world" (uiop:read-file-string file)))
|
|
(tools-cleanup)))
|
|
|
|
(test test-write-file-missing-params
|
|
"write-file returns error without required params."
|
|
(let ((result (call-tool 'write-file :content "x")))
|
|
(is (eq (getf result :status) :error))))
|
|
|
|
;; list-directory
|
|
(test test-list-directory-all
|
|
"Contract 8: list-directory returns all entries."
|
|
(let ((dir (tools-tmpdir)))
|
|
(tools-write-file (merge-pathnames "alpha.txt" dir) "x")
|
|
(tools-write-file (merge-pathnames "beta.txt" dir) "y")
|
|
(let ((result (call-tool 'list-directory :path (namestring dir))))
|
|
(is (eq (getf result :status) :success))
|
|
(is (search "alpha.txt" (getf result :content)))
|
|
(is (search "beta.txt" (getf result :content))))
|
|
(tools-cleanup)))
|
|
|
|
(test test-list-directory-missing-params
|
|
"list-directory returns error without :path."
|
|
(let ((result (call-tool 'list-directory)))
|
|
(is (eq (getf result :status) :error))))
|
|
|
|
;; run-shell
|
|
(test test-run-shell-echo
|
|
"Contract 9: run-shell executes a command and returns output."
|
|
(let ((result (call-tool 'run-shell :cmd "echo hello")))
|
|
(is (eq (getf result :status) :success))
|
|
(is (search "hello" (getf result :content)))))
|
|
|
|
(test test-run-shell-missing-params
|
|
"run-shell returns error without :cmd."
|
|
(let ((result (call-tool 'run-shell)))
|
|
(is (eq (getf result :status) :error))))
|
|
|
|
;; eval-form
|
|
(test test-eval-form-arithmetic
|
|
"Contract 10: eval-form evaluates a Lisp expression."
|
|
(let ((result (call-tool 'eval-form :code "(+ 1 2)")))
|
|
(is (eq (getf result :status) :success))
|
|
(is (search "3" (getf result :content)))))
|
|
|
|
(test test-eval-form-missing-params
|
|
"eval-form returns error without :code."
|
|
(let ((result (call-tool 'eval-form)))
|
|
(is (eq (getf result :status) :error))))
|
|
|
|
;; org-modify-file
|
|
(test test-org-modify-file-replace
|
|
"Contract 13: org-modify-file replaces exact text in file."
|
|
(let* ((dir (tools-tmpdir))
|
|
(file (merge-pathnames "doc.org" dir)))
|
|
(tools-write-file file "* TODO Buy milk~%* DONE Walk dog~%")
|
|
(let ((result (call-tool 'org-modify-file
|
|
:filepath (namestring file)
|
|
:old-text "TODO" :new-text "WAITING")))
|
|
(is (eq (getf result :status) :success))
|
|
(is (search "WAITING" (uiop:read-file-string file))))
|
|
(tools-cleanup)))
|
|
|
|
(test test-org-modify-file-not-found
|
|
"org-modify-file returns error when text not in file."
|
|
(let* ((dir (tools-tmpdir))
|
|
(file (merge-pathnames "file.org" dir)))
|
|
(tools-write-file file "some content")
|
|
(let ((result (call-tool 'org-modify-file
|
|
:filepath (namestring file)
|
|
:old-text "not-in-file" :new-text "anything")))
|
|
(is (eq (getf result :status) :error))
|
|
(is (search "not found" (getf result :message))))
|
|
(tools-cleanup)))
|
|
|
|
(test test-org-modify-file-missing-params
|
|
"org-modify-file returns error without required params."
|
|
(let ((result (call-tool 'org-modify-file :filepath "x" :old-text "y")))
|
|
(is (eq (getf result :status) :error))))
|