aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorChristopher Baines <mail@cbaines.net>2024-04-15 13:53:35 +0100
committerChristopher Baines <mail@cbaines.net>2024-04-15 13:53:35 +0100
commitf1add8886761f2e6aec3563562b724a886fbe85b (patch)
tree1752f8de6c0a8495aa79bf533dbdc3ab32161785
parent88b9d34fb16beec09577c30c384a41e9a89bfa4b (diff)
downloaddata-service-f1add8886761f2e6aec3563562b724a886fbe85b.tar
data-service-f1add8886761f2e6aec3563562b724a886fbe85b.tar.gz
Add support for tracking resource pool checkout timeouts
-rw-r--r--guix-data-service/utils.scm10
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)))