v0.7.2: wire with-tool-timeout into action-tool-execute — TDD

call-with-tool-timeout wraps tool execution with sb-ext:with-timeout
using per-tool timeout from *tool-timeouts*. On timeout returns
(:status :error :message "Timed out after Ns"). Wired into
action-tool-execute before the funcall. Timeout result detected and
propagated as :tool-error.

- core-act: call-with-tool-timeout fn, wired into action-tool-execute
- Act tests: +3 (timeout enforcement test)
- Core: 88/88
This commit is contained in:
2026-05-08 19:30:51 -04:00
parent 029a32ef64
commit 44f927e8f1
2 changed files with 86 additions and 6 deletions

View File

@@ -186,13 +186,20 @@ The tool's return value is packed into a ~:tool-output~ event and fed back into
(if tool
(handler-case
(let* ((clean-args (if (and (listp tool-args) (listp (car tool-args))) (car tool-args) tool-args))
(result (funcall (cognitive-tool-body tool) clean-args)))
(raw-result (call-with-tool-timeout tool-name
(lambda () (funcall (cognitive-tool-body tool) clean-args)))))
;; Timeout: propagate error
(when (and (listp raw-result) (eq (getf raw-result :status) :error))
(return-from action-tool-execute
(list :TYPE :EVENT :DEPTH (1+ depth) :META meta
:PAYLOAD (list :SENSOR :tool-error :TOOL tool-name
:MESSAGE (getf raw-result :message)))))
(when source
(action-dispatch (list :TYPE :REQUEST :TARGET source
:PAYLOAD (list :ACTION :MESSAGE :TEXT (tool-result-format tool-name result)))
:PAYLOAD (list :ACTION :MESSAGE :TEXT (tool-result-format tool-name raw-result)))
context))
(list :TYPE :EVENT :DEPTH (1+ depth) :META meta
:PAYLOAD (list :SENSOR :tool-output :RESULT result :TOOL tool-name)))
:PAYLOAD (list :SENSOR :tool-output :RESULT raw-result :TOOL tool-name)))
(error (c)
(list :TYPE :EVENT :DEPTH (1+ depth) :META meta
:PAYLOAD (list :SENSOR :tool-error :TOOL tool-name :MESSAGE (format nil "~a" c)))))
@@ -214,6 +221,18 @@ The tool's return value is packed into a ~:tool-output~ event and fed back into
"Return timeout for tool-name, default 120 seconds."
(gethash (string-downcase (string tool-name)) *tool-timeouts* 120))
(defun call-with-tool-timeout (tool-name fn)
"Execute FN within the timeout for TOOL-NAME.
On timeout, returns (:status :error :message ...)."
(let ((timeout (tool-timeout tool-name)))
(handler-case
(sb-ext:with-timeout timeout
(funcall fn))
(sb-ext:timeout (c)
(declare (ignore c))
(list :status :error :message
(format nil "Timed out after ~a second~:p" timeout))))))
(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."
@@ -408,4 +427,25 @@ Verifies that the act gate correctly processes an approved action and sets the s
(unwind-protect
(is (passepartout::verify-write path content))
(ignore-errors (delete-file path)))))
(test test-tool-timeout-enforcement
"Contract v0.7.2: tool exceeding timeout returns :error with timeout message."
(setf (gethash "sleep-forever" passepartout::*tool-timeouts*) 1)
(setf (gethash "sleep-forever" passepartout::*cognitive-tool-registry*)
(passepartout::make-cognitive-tool :name "sleep-forever"
:read-only-p nil
:body (lambda (args)
(declare (ignore args))
(sleep 10)
"done")))
(unwind-protect
(let* ((action '(:type :REQUEST :payload (:tool "sleep-forever" :args nil)))
(ctx '(:depth 0))
(result (passepartout::action-tool-execute action ctx)))
(is (eq :EVENT (getf result :TYPE)))
(let ((payload (getf result :PAYLOAD)))
(is (eq :tool-error (getf payload :SENSOR)))
(is (search "timed out" (string-downcase (getf payload :MESSAGE))))))
(remhash "sleep-forever" passepartout::*cognitive-tool-registry*)
(remhash "sleep-forever" passepartout::*tool-timeouts*)))
#+end_src