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:
@@ -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
|
||||
Reference in New Issue
Block a user