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

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

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