From 97a3116b810fbd848b4a1dc46ab0d0d68f4326dc Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Mon, 6 Jan 2025 19:04:06 +0000
Subject: [PATCH] Support getting the pool from the timeout error

---
 knots/resource-pool.scm | 16 +++++++++++-----
 tests/resource-pool.scm |  8 ++++++++
 2 files changed, 19 insertions(+), 5 deletions(-)

diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm
index 67e9292..9865ba7 100644
--- a/knots/resource-pool.scm
+++ b/knots/resource-pool.scm
@@ -36,6 +36,7 @@
             resource-pool-retry-checkout-timeout
 
             &resource-pool-timeout
+            resource-pool-timeout-error-pool
             resource-pool-timeout-error?
 
             resource-pool-default-timeout-handler
@@ -349,7 +350,12 @@
 (define &resource-pool-timeout
   (make-exception-type '&recource-pool-timeout
                        &error
-                       '(name)))
+                       '(pool)))
+
+(define resource-pool-timeout-error-pool
+  (exception-accessor
+   &resource-pool-timeout
+   (record-accessor &resource-pool-timeout 'pool)))
 
 (define make-resource-pool-timeout-error
   (record-constructor &resource-pool-timeout))
@@ -427,7 +433,7 @@ available.  Return the resource once PROC has returned."
         (timeout-handler pool proc timeout))
 
       (raise-exception
-       (make-resource-pool-timeout-error (resource-pool-name pool))))
+       (make-resource-pool-timeout-error pool)))
 
     (with-exception-handler
         (lambda (exception)
@@ -465,7 +471,7 @@ available.  Return the resource once PROC has returned."
       (wrap-operation (sleep-operation timeout)
                       (lambda _
                         (raise-exception
-                         (make-resource-pool-timeout-error))))))
+                         (make-resource-pool-timeout-error pool))))))
 
     (let ((time-remaining
            (- timeout
@@ -479,7 +485,7 @@ available.  Return the resource once PROC has returned."
             (wrap-operation (sleep-operation time-remaining)
                             (lambda _
                               (raise-exception
-                               (make-resource-pool-timeout-error))))))
+                               (make-resource-pool-timeout-error pool))))))
           (raise-exception
-           (make-resource-pool-timeout-error))))))
+           (make-resource-pool-timeout-error pool))))))
 
diff --git a/tests/resource-pool.scm b/tests/resource-pool.scm
index ebd4682..b6db98f 100644
--- a/tests/resource-pool.scm
+++ b/tests/resource-pool.scm
@@ -15,4 +15,12 @@
                                res)
       2))))
 
+(let* ((error-constructor
+        (record-constructor &resource-pool-timeout))
+       (err
+        (error-constructor 'foo)))
+  (assert-equal
+   (resource-pool-timeout-error-pool err)
+   'foo))
+
 (display "resource-pool test finished successfully\n")