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

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.

1 files changed, 51 insertions, 41 deletions

diff --git a/guix-data-service/utils.scm b/guix-data-service/utils.scm
index fda40b3..4b5d7e6 100644
--- a/guix-data-service/utils.scm
+++ b/guix-data-service/utils.scm
@@ -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,47 +401,50 @@ 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)))
-                 (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))))
-
-                 (let ((time-remaining
-                        (- timeout-or-default
-                           (/ (- (get-internal-real-time)
-                                 start-time)
-                              internal-time-units-per-second))))
-                   (if (> time-remaining 0)
-                       (let ((response
-                              (perform-operation
-                               (choice-operation
-                                (get-operation reply)
-                                (wrap-operation (sleep-operation time-remaining)
-                                                (const #f))))))
-                         (if (or (not response)
-                                 (eq? response 'resource-pool-retry-checkout))
-                             (if (> (- timeout-or-default
-                                       (/ (- (get-internal-real-time)
-                                             start-time)
-                                          internal-time-units-per-second))
-                                    0)
-                                 (loop start-time)
-                                 #f)
-                             response))
-                       #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)))))))
+           (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 (or timeout-or-default
+                                                           retry-timeout))
+                                      (const #f))))))
+               (if request-success?
+                   (let ((time-remaining
+                          (- (or timeout-or-default
+                                 retry-timeout)
+                             (/ (- (get-internal-real-time)
+                                   start-time)
+                                internal-time-units-per-second))))
+                     (if (> time-remaining 0)
+                         (let ((response
+                                (perform-operation
+                                 (choice-operation
+                                  (get-operation reply)
+                                  (wrap-operation (sleep-operation time-remaining)
+                                                  (const #f))))))
+                           (if (or (not response)
+                                   (eq? response 'resource-pool-retry-checkout))
+                               (if (> (- (or timeout-or-default
+                                             retry-timeout)
+                                         (/ (- (get-internal-real-time)
+                                               start-time)
+                                            internal-time-units-per-second))
+                                      0)
+                                   (loop start-time)
+                                   (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)))
+                   (if (eq? timeout-or-default #f)
+                       (loop (get-internal-real-time))
+                       #f)))))))
 
     (when (or (not resource)
               (eq? resource 'resource-pool-retry-checkout))