Make fetching metrics work even when having database problems

1 files changed, 26 insertions, 4 deletions

diff --git a/guix-data-service/utils.scm b/guix-data-service/utils.scm
index 7212e9b..361d7c8 100644
--- a/guix-data-service/utils.scm
+++ b/guix-data-service/utils.scm
@@ -273,10 +273,32 @@ available.  Return the resource once PROC has returned."
    pool
    (lambda (resource) exp ...)))
 
-(define (resource-pool-stats pool)
-  (let ((reply (make-channel)))
-    (put-message pool `(stats ,reply))
-    (get-message reply)))
+(define* (resource-pool-stats pool #:key (timeout 5))
+  (let ((reply (make-channel))
+        (start-time (get-internal-real-time)))
+    (perform-operation
+     (choice-operation
+      (wrap-operation
+       (put-operation pool `(stats ,reply))
+       (const #t))
+      (wrap-operation (sleep-operation timeout)
+                      (const #f))))
+
+    (let ((time-remaining
+           (- 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))))))
+            response)
+          (raise-exception
+           (make-resource-pool-timeout-error))))))
 
 (define (defer-to-parallel-fiber thunk)
   (let ((reply (make-channel)))