From 96370cc4b1dcfe15518cf125f45c64a88dc78af1 Mon Sep 17 00:00:00 2001 From: Amr Gharbeia Date: Fri, 8 May 2026 18:06:36 -0400 Subject: [PATCH] =?UTF-8?q?v0.7.2:=20tool=20execution=20hardening=20?= =?UTF-8?q?=E2=80=94=20TDD?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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 --- lisp/core-act.lisp | 46 +++++++++++++++++++++++++++++++++- lisp/programming-tools.lisp | 9 ++++--- org/core-act.org | 49 ++++++++++++++++++++++++++++++++++++- org/programming-tools.org | 9 ++++--- 4 files changed, 103 insertions(+), 10 deletions(-) diff --git a/lisp/core-act.lisp b/lisp/core-act.lisp index df03389..4578e1b 100644 --- a/lisp/core-act.lisp +++ b/lisp/core-act.lisp @@ -98,7 +98,33 @@ (list :TYPE :EVENT :DEPTH (1+ depth) :META meta :PAYLOAD (list :SENSOR :tool-error :TOOL tool-name :MESSAGE (format nil "~a" c))))) (list :TYPE :EVENT :DEPTH (1+ depth) :META meta - :PAYLOAD (list :SENSOR :tool-error :MESSAGE (format nil "Tool '~a' not found" tool-name)))))) + :PAYLOAD (list :SENSOR :tool-error :MESSAGE (format nil "Tool '~a' not found" tool-name)))))) + +(defvar *tool-timeouts* (make-hash-table :test 'equal) + "Per-tool timeout in seconds. Default 120s.") + +;; Defaults: shell=300s, search-files=30s, eval-form=10s +(setf (gethash "shell" *tool-timeouts*) 300) +(setf (gethash "search-files" *tool-timeouts*) 30) +(setf (gethash "eval-form" *tool-timeouts*) 10) + +(defun tool-timeout (tool-name) + "Return timeout for tool-name, default 120 seconds." + (gethash (string-downcase (string tool-name)) *tool-timeouts* 120)) + +(defun verify-write (filepath expected-content) + "Verify that FILEPATH contains EXPECTED-CONTENT after write. +Returns T on match, logs and returns NIL on mismatch or read error." + (handler-case + (let ((actual (uiop:read-file-string filepath))) + (if (string= expected-content actual) + t + (progn + (log-message "WRITE-VERIFY: Mismatch in ~a" filepath) + nil))) + (error (c) + (log-message "WRITE-VERIFY: Cannot read ~a: ~a" filepath c) + nil))) (defun tool-result-format (tool-name result) "Format a tool result for display." @@ -227,3 +253,21 @@ For approval-required actions, creates a Flight Plan instead of executing." (let ((result (action-dispatch '(:type :REQUEST :target :system :payload (:action :eval :code "(+ 1 2)")) '(:type :EVENT :depth 0)))) (is (numberp result) "eval should return a number"))) + +(test test-tool-timeout-shell + "Contract v0.7.2: shell timeout is 300 seconds." + (is (= 300 (passepartout::tool-timeout "shell")))) + +(test test-tool-timeout-unknown + "Contract v0.7.2: unknown tool gets default 120s." + (is (= 120 (passepartout::tool-timeout "nonexistent-tool")))) + +(test test-verify-write-match + "Contract v0.7.2: verify-write returns T on match." + (let ((path "/tmp/passepartout-verify-test.org") + (content "test content")) + (with-open-file (f path :direction :output :if-exists :supersede) + (write-string content f)) + (unwind-protect + (is (passepartout::verify-write path content)) + (ignore-errors (delete-file path))))) diff --git a/lisp/programming-tools.lisp b/lisp/programming-tools.lisp index 68959a0..ab23505 100644 --- a/lisp/programming-tools.lisp +++ b/lisp/programming-tools.lisp @@ -101,10 +101,11 @@ (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 + (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)))))))) diff --git a/org/core-act.org b/org/core-act.org index 9f30784..af2c547 100644 --- a/org/core-act.org +++ b/org/core-act.org @@ -197,7 +197,36 @@ The tool's return value is packed into a ~:tool-output~ event and fed back into (list :TYPE :EVENT :DEPTH (1+ depth) :META meta :PAYLOAD (list :SENSOR :tool-error :TOOL tool-name :MESSAGE (format nil "~a" c))))) (list :TYPE :EVENT :DEPTH (1+ depth) :META meta - :PAYLOAD (list :SENSOR :tool-error :MESSAGE (format nil "Tool '~a' not found" tool-name)))))) + :PAYLOAD (list :SENSOR :tool-error :MESSAGE (format nil "Tool '~a' not found" tool-name)))))) +#+end_src + +** v0.7.2 — Tool Execution Hardening +#+begin_src lisp +(defvar *tool-timeouts* (make-hash-table :test 'equal) + "Per-tool timeout in seconds. Default 120s.") + +;; Defaults: shell=300s, search-files=30s, eval-form=10s +(setf (gethash "shell" *tool-timeouts*) 300) +(setf (gethash "search-files" *tool-timeouts*) 30) +(setf (gethash "eval-form" *tool-timeouts*) 10) + +(defun tool-timeout (tool-name) + "Return timeout for tool-name, default 120 seconds." + (gethash (string-downcase (string tool-name)) *tool-timeouts* 120)) + +(defun verify-write (filepath expected-content) + "Verify that FILEPATH contains EXPECTED-CONTENT after write. +Returns T on match, logs and returns NIL on mismatch or read error." + (handler-case + (let ((actual (uiop:read-file-string filepath))) + (if (string= expected-content actual) + t + (progn + (log-message "WRITE-VERIFY: Mismatch in ~a" filepath) + nil))) + (error (c) + (log-message "WRITE-VERIFY: Cannot read ~a: ~a" filepath c) + nil))) #+end_src ** Tool Result Formatting (tool-result-format) @@ -361,4 +390,22 @@ Verifies that the act gate correctly processes an approved action and sets the s (let ((result (action-dispatch '(:type :REQUEST :target :system :payload (:action :eval :code "(+ 1 2)")) '(:type :EVENT :depth 0)))) (is (numberp result) "eval should return a number"))) + +(test test-tool-timeout-shell + "Contract v0.7.2: shell timeout is 300 seconds." + (is (= 300 (passepartout::tool-timeout "shell")))) + +(test test-tool-timeout-unknown + "Contract v0.7.2: unknown tool gets default 120s." + (is (= 120 (passepartout::tool-timeout "nonexistent-tool")))) + +(test test-verify-write-match + "Contract v0.7.2: verify-write returns T on match." + (let ((path "/tmp/passepartout-verify-test.org") + (content "test content")) + (with-open-file (f path :direction :output :if-exists :supersede) + (write-string content f)) + (unwind-protect + (is (passepartout::verify-write path content)) + (ignore-errors (delete-file path))))) #+end_src \ No newline at end of file diff --git a/org/programming-tools.org b/org/programming-tools.org index 59a0fda..74d02ee 100644 --- a/org/programming-tools.org +++ b/org/programming-tools.org @@ -156,10 +156,11 @@ Writes string content to a file, creating parent directories as needed. (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 + (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)))))))) #+end_src