Support getting resource pool stats

1 files changed, 23 insertions, 0 deletions

diff --git a/guix-data-service/utils.scm b/guix-data-service/utils.scm
index ec974e3..7212e9b 100644
--- a/guix-data-service/utils.scm
+++ b/guix-data-service/utils.scm
@@ -35,6 +35,7 @@
             make-resource-pool
             call-with-resource-from-pool
             with-resource-from-pool
+            resource-pool-stats
 
             parallel-via-fibers
             par-map&
@@ -158,6 +159,23 @@
                   (cons resource available)
                   ;; clear waiters, as they've been notified
                   '()))
+           (('stats reply)
+            (let ((stats
+                   `((resources . ,(length resources))
+                     (available . ,(length available))
+                     (waiters   . ,(length waiters)))))
+
+              (perform-operation
+               (choice-operation
+                (wrap-operation
+                 (put-operation reply stats)
+                 (const #t))
+                (wrap-operation (sleep-operation 0.2)
+                                (const #f)))))
+
+            (loop resources
+                  available
+                  waiters))
            (unknown
             (simple-format
              (current-error-port)
@@ -255,6 +273,11 @@ 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 (defer-to-parallel-fiber thunk)
   (let ((reply (make-channel)))
     (spawn-fiber