02/03: Add support for tracking resource pool checkout timeouts

[Christopher Baines]

cbaines pushed a commit to branch master
in repository data-service.

commit f1add8886761f2e6aec3563562b724a886fbe85b
Author: Christopher Baines <mail@cbaines.net>
AuthorDate: Mon Apr 15 13:53:35 2024 +0100

    Add support for tracking resource pool checkout timeouts
---
 guix-data-service/utils.scm | 10 +++++++++-
 1 file changed, 9 insertions(+), 1 deletion(-)

diff --git a/guix-data-service/utils.scm b/guix-data-service/utils.scm
index 6cab904..d01fb5c 100644
--- a/guix-data-service/utils.scm
+++ b/guix-data-service/utils.scm
@@ -39,6 +39,7 @@
             prevent-inlining-for-tests
 
             resource-pool-default-timeout
+            %resource-pool-timeout-handler
             make-resource-pool
             destroy-resource-pool
             call-with-resource-from-pool
@@ -341,7 +342,11 @@
 (define resource-pool-timeout-error?
   (record-predicate &resource-pool-timeout))
 
-(define* (call-with-resource-from-pool pool proc #:key (timeout 'default))
+(define %resource-pool-timeout-handler
+  (make-parameter #f))
+
+(define* (call-with-resource-from-pool pool proc #:key (timeout 'default)
+                                       (timeout-handler 
(%resource-pool-timeout-handler)))
   "Call PROC with a resource from POOL, blocking until a resource becomes
 available.  Return the resource once PROC has returned."
 
@@ -394,6 +399,9 @@ available.  Return the resource once PROC has returned."
 
     (when (or (not resource)
               (eq? resource 'resource-pool-retry-checkout))
+      (when timeout-handler
+        (timeout-handler pool proc timeout))
+
       (raise-exception
        (make-resource-pool-timeout-error)))