cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Ensure that call-with-resource-from-pool doesn't get stuck

Browse source 
As I think this was happening when it missed the resource-pool-retry-checkout
reply from the resource pool. Handle this case by periodically retrying with a
configurable timeout.
This commit is contained in:
Christopher Baines 2024-10-31 16:45:09 +00:00
parent 2d7100e75d
commit de5e036ab1
1 changed files with 51 additions and 41 deletions
Download patch file Download diff file Expand all files Collapse all files

38
guix-data-service/utils.scm
View file

@ -44,6 +44,7 @@
prevent-inlining-for-tests
resource-pool-default-timeout
resource-pool-retry-checkout-timeout
%resource-pool-timeout-handler
resource-pool-timeout-error?
make-resource-pool
@ -368,6 +369,9 @@
(define resource-pool-default-timeout
(make-parameter #f))
(define resource-pool-retry-checkout-timeout
(make-parameter 5))
(define &resource-pool-timeout
(make-exception-type '&recource-pool-timeout
&error
@ -387,6 +391,9 @@
"Call PROC with a resource from POOL, blocking until a resource becomes
available. Return the resource once PROC has returned."
(define retry-timeout
(resource-pool-retry-checkout-timeout))
(define timeout-or-default
(if (eq? timeout 'default)
(resource-pool-default-timeout)
@ -394,19 +401,21 @@ available. Return the resource once PROC has returned."
(let ((resource
(let ((reply (make-channel)))
(if timeout-or-default
(let loop ((start-time (get-internal-real-time)))
(let ((request-success?
(perform-operation
(choice-operation
(wrap-operation
(put-operation (resource-pool-channel pool)
`(checkout ,reply))
(const #t))
(wrap-operation (sleep-operation timeout-or-default)
(const #f))))
(wrap-operation (sleep-operation (or timeout-or-default
retry-timeout))
(const #f))))))
(if request-success?
(let ((time-remaining
(- timeout-or-default
(- (or timeout-or-default
retry-timeout)
(/ (- (get-internal-real-time)
start-time)
internal-time-units-per-second))))
@ -419,22 +428,23 @@ available. Return the resource once PROC has returned."
(const #f))))))
(if (or (not response)
(eq? response 'resource-pool-retry-checkout))
(if (> (- timeout-or-default
(if (> (- (or timeout-or-default
retry-timeout)
(/ (- (get-internal-real-time)
start-time)
internal-time-units-per-second))
0)
(loop start-time)
#f)
(if (eq? timeout-or-default #f)
(loop (get-internal-real-time))
#f))
response))
(if (eq? timeout-or-default #f)
(loop (get-internal-real-time))
#f)))
(let loop ()
(put-message (resource-pool-channel pool)
`(checkout ,reply))
(let ((response (get-message reply)))
(if (eq? response 'resource-pool-retry-checkout)
(loop)
response)))))))
(if (eq? timeout-or-default #f)
(loop (get-internal-real-time))
#f)))))))
(when (or (not resource)
(eq? resource 'resource-pool-retry-checkout))