Amr Gharbeia
96370cc4b1
Per-tool timeouts: shell=300s, search-files=30s, eval-form=10s, unknown=120s default. Write verification: after write-file, reads back content and compares, logs mismatches. - core-act: *tool-timeouts* hash, tool-timeout, verify-write - programming-tools: verify-write call in write-file body - Act tests: +3 (timeout shell, timeout unknown, verify match) - Core: 84/84
626 lines
26 KiB
Common Lisp
626 lines
26 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"))
|
|
:read-only-p t
|
|
: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."
|
|
((:name "pattern" :description "The glob pattern to match (e.g. \"*.lisp\")." :type "string")
|
|
(:name "path" :description "Directory to search in." :type "string"))
|
|
:read-only-p t
|
|
: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"))
|
|
:read-only-p t
|
|
: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)
|
|
(verify-write 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"))
|
|
:read-only-p t
|
|
: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"))
|
|
:read-only-p t
|
|
: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"))
|
|
:read-only-p t
|
|
: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"))
|
|
:read-only-p t
|
|
: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))
|
|
|
|
(defpackage :passepartout
|
|
(:use :cl)
|
|
(:export
|
|
#:frame-message
|
|
#:read-framed-message
|
|
#:PROTO-GET
|
|
#:proto-get
|
|
#:*VAULT-MEMORY*
|
|
#:make-hello-message
|
|
#:validate-communication-protocol-schema
|
|
#:start-daemon
|
|
#:log-message
|
|
#:main
|
|
#:diagnostics-run-all
|
|
#:diagnostics-main
|
|
#:diagnostics-dependencies-check
|
|
#:diagnostics-env-check
|
|
#:register-provider
|
|
#:provider-openai-request
|
|
#:provider-config
|
|
#:run-setup-wizard
|
|
#:ingest-ast
|
|
#:memory-object-get
|
|
#:*memory-store*
|
|
#:memory-object
|
|
#:make-memory-object
|
|
#:memory-object-id
|
|
#:memory-object-type
|
|
#:memory-object-attributes
|
|
#:memory-object-parent-id
|
|
#:memory-object-children
|
|
#:memory-object-version
|
|
#:memory-object-last-sync
|
|
#:memory-object-vector
|
|
#:memory-object-content
|
|
#:memory-object-hash
|
|
#:memory-object-scope
|
|
#:snapshot-memory
|
|
#:rollback-memory
|
|
#:context-get-system-logs
|
|
#:context-assemble-global-awareness
|
|
#:context-awareness-assemble
|
|
#:context-query
|
|
#:push-context
|
|
#:pop-context
|
|
#:current-context
|
|
#:current-scope
|
|
#:context-stack-depth
|
|
#:context-save
|
|
#:context-load
|
|
#:focus-project
|
|
#:focus-session
|
|
#:focus-memex
|
|
#:unfocus
|
|
#:process-signal
|
|
#:loop-process
|
|
#:perceive-gate
|
|
#:loop-gate-perceive
|
|
#:act-gate
|
|
#:loop-gate-act
|
|
#:reason-gate
|
|
#:loop-gate-reason
|
|
#:cognitive-verify
|
|
#:backend-cascade-call
|
|
#:json-alist-to-plist
|
|
#:inject-stimulus
|
|
#:stimulus-inject
|
|
#:hitl-create
|
|
#:hitl-approve
|
|
#:hitl-deny
|
|
#:hitl-handle-message
|
|
#:dispatcher-check-secret-path
|
|
#:dispatcher-check-shell-safety
|
|
#:dispatcher-check-privacy-tags
|
|
#:dispatcher-check-network-exfil
|
|
#:dispatcher-gate
|
|
#:wildcard-match
|
|
#:actuator-initialize
|
|
#:action-dispatch
|
|
#:register-actuator
|
|
#:load-skill-from-org
|
|
#:skill-initialize-all
|
|
#:lisp-syntax-validate
|
|
#:defskill
|
|
#:*skill-registry*
|
|
#:*scope-resolver*
|
|
#:*embedding-backend*
|
|
#:*embedding-queue*
|
|
#:*embedding-provider*
|
|
#:embed-queue-object
|
|
#:embed-object
|
|
#:embed-all-pending
|
|
#:embedding-backend-hashing
|
|
#:embedding-backend-native
|
|
#:embedding-native-load-model
|
|
#:embedding-native-unload
|
|
#:embedding-native-ensure-loaded
|
|
#:embedding-native-get-dim
|
|
#:embeddings-compute
|
|
#:mark-vector-stale
|
|
#:skill
|
|
#:skill-name
|
|
#:skill-priority
|
|
#:skill-dependencies
|
|
#:skill-trigger-fn
|
|
#:skill-probabilistic-prompt
|
|
#:skill-deterministic-fn
|
|
#:def-cognitive-tool
|
|
#:*cognitive-tool-registry*
|
|
#:org-read-file
|
|
#:org-write-file
|
|
#:org-headline-add
|
|
#:org-headline-find-by-id
|
|
#:literate-tangle-sync-check
|
|
#:archivist-create-note
|
|
#:gateway-start
|
|
#:org-property-set
|
|
#:org-todo-set
|
|
#:org-id-generate
|
|
#:org-id-format
|
|
#:org-modify
|
|
#:lisp-validate
|
|
#:lisp-structural-check
|
|
#:lisp-syntactic-check
|
|
#:lisp-semantic-check
|
|
#:lisp-eval
|
|
#:lisp-format
|
|
#:lisp-list-definitions
|
|
#:lisp-extract
|
|
#:lisp-inject
|
|
#:lisp-slurp
|
|
#:get-oc-config-dir
|
|
#:get-tool-permission
|
|
#:set-tool-permission
|
|
#:check-tool-permission-gate
|
|
#:permission-get
|
|
#:permission-set
|
|
#:cognitive-tool
|
|
#:cognitive-tool-name
|
|
#:cognitive-tool-description
|
|
#:cognitive-tool-parameters
|
|
#:cognitive-tool-guard
|
|
#:cognitive-tool-body
|
|
#:register-probabilistic-backend
|
|
#:*probabilistic-backends*
|
|
#:*provider-cascade*
|
|
#:vault-get
|
|
#:vault-set
|
|
#:vault-get-secret
|
|
#:vault-set-secret
|
|
#:memory-objects-by-attribute
|
|
#:channel-cli-input
|
|
#:repl-eval
|
|
#:repl-inspect
|
|
#:repl-list-vars
|
|
#:policy-compliance-check
|
|
#:validator-protocol-check
|
|
#:archivist-extract-headlines
|
|
#:archivist-headline-to-filename
|
|
#:literate-extract-lisp-blocks
|
|
#:literate-block-balance-check
|
|
#:gateway-registry-initialize
|
|
#:messaging-link
|
|
#:messaging-unlink
|
|
#:gateway-configured-p))
|
|
|
|
(in-package :passepartout)
|
|
|
|
(defun plist-get (plist key)
|
|
"Robust plist accessor — checks both :KEY and :key variants."
|
|
(let* ((s (string key))
|
|
(up (intern (string-upcase s) :keyword))
|
|
(dn (intern (string-downcase s) :keyword)))
|
|
(or (getf plist up) (getf plist dn))))
|
|
|
|
(defvar *log-buffer* nil)
|
|
(defvar *log-lock* (bordeaux-threads:make-lock "log-messages-lock"))
|
|
(defvar *log-limit* 100)
|
|
|
|
(defvar *skill-registry* (make-hash-table :test 'equal)
|
|
"Global registry of all loaded skills.")
|
|
|
|
(defvar *telemetry-table* (make-hash-table :test 'equal))
|
|
(defvar *telemetry-lock* (bordeaux-threads:make-lock "harness-telemetry-lock"))
|
|
|
|
(defun telemetry-track (skill-name duration status)
|
|
"Updates performance metrics for a skill. STATUS is :success or :rejected."
|
|
(when skill-name
|
|
(bordeaux-threads:with-lock-held (*telemetry-lock*)
|
|
(let ((entry (or (gethash skill-name *telemetry-table*) (list :executions 0 :total-time 0 :failures 0))))
|
|
(incf (getf entry :executions))
|
|
(incf (getf entry :total-time) duration)
|
|
(when (eq status :rejected) (incf (getf entry :failures)))
|
|
(setf (gethash skill-name *telemetry-table*) entry)))))
|
|
|
|
(defvar *cognitive-tool-registry* (make-hash-table :test 'equal))
|
|
|
|
(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))))
|