Add support for tracking resource pool checkout timeouts

1 files changed, 9 insertions, 1 deletions

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)))