From f1add8886761f2e6aec3563562b724a886fbe85b Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 15 Apr 2024 13:53:35 +0100 Subject: 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))) -- cgit v1.2.3