Instrument the resource pool checkout timeouts

1 files changed, 16 insertions, 0 deletions

diff --git a/guix-data-service/web/server.scm b/guix-data-service/web/server.scm
index d0be4e4..4f2a4a0 100644
--- a/guix-data-service/web/server.scm
+++ b/guix-data-service/web/server.scm
@@ -142,6 +142,22 @@
 
                (resource-pool-default-timeout 5))
 
+            (let ((resource-pool-checkout-failures-metric
+                   (make-counter-metric registry
+                                        "resource_pool_checkout_timeouts_total"
+                                        #:labels '(pool_name))))
+              (%resource-pool-timeout-handler
+               (lambda (pool proc timeout)
+                 (let ((pool-name
+                        (cond
+                         ((eq? pool (connection-pool)) "normal")
+                         ((eq? pool (reserved-connection-pool)) "reserved")
+                         (else #f))))
+                   (when pool-name
+                     (metric-increment
+                      resource-pool-checkout-failures-metric
+                      #:label-values `((pool_name . ,pool-name))))))))
+
             (spawn-fiber
              (lambda ()
                (with-resource-from-pool (connection-pool) conn