Support instrumenting the number of database connections

Since this is now quite dynamic, it's useful to have a metric for it.

1 files changed, 50 insertions, 5 deletions

diff --git a/guix-data-service/database.scm b/guix-data-service/database.scm
index 25305b2..8ed87de 100644
--- a/guix-data-service/database.scm
+++ b/guix-data-service/database.scm
@@ -1,5 +1,5 @@
 ;;; Guix Data Service -- Information about Guix over time
-;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
+;;; Copyright © 2019, 2020, 2021, 2022, 2023 Christopher Baines <mail@cbaines.net>
 ;;;
 ;;; This program is free software: you can redistribute it and/or
 ;;; modify it under the terms of the GNU Affero General Public License
@@ -20,8 +20,10 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 threads)
   #:use-module (squee)
+  #:use-module (prometheus)
   #:use-module (guix-data-service config)
   #:export (get-database-config
+            %database-metrics-registry
 
             with-postgresql-connection
 
@@ -42,6 +44,33 @@
 (define pg-conn-finish
   (@@ (squee) pg-conn-finish))
 
+(define %database-metrics-registry
+  (make-parameter #f))
+
+(define (with-connection-gauge-metric proc)
+  (and=>
+   (%database-metrics-registry)
+   (lambda (registry)
+     (proc
+      (or (metrics-registry-fetch-metric registry "postgresql_connections_total")
+          (make-gauge-metric registry
+                             "postgresql_connections_total"
+                             #:labels '(name)))))))
+
+(define (increment-connection-gauge name)
+  (with-connection-gauge-metric
+   (lambda (connection-gauge-metric)
+     (metric-increment connection-gauge-metric
+                       #:label-values
+                       `((name . ,name))))))
+
+(define (decrement-connection-gauge name)
+  (with-connection-gauge-metric
+   (lambda (connection-gauge-metric)
+     (metric-decrement connection-gauge-metric
+                       #:label-values
+                       `((name . ,name))))))
+
 (define (paramstring->alist s)
   (map
    (lambda (param)
@@ -77,6 +106,8 @@
        (simple-format #f "SET statement_timeout = ~A"
                       statement-timeout)))
 
+    (increment-connection-gauge name)
+
     conn))
 
 (define* (with-postgresql-connection name f #:key (statement-timeout #f))
@@ -89,9 +120,13 @@
               (f conn))
           (lambda vals
             (pg-conn-finish conn)
+
+            (decrement-connection-gauge name)
+
             (apply values vals))))
       (lambda (key . args)
-        (pg-conn-finish conn)))))
+        (pg-conn-finish conn)
+        (decrement-connection-gauge name)))))
 
 (define %postgresql-connection-parameters
   (make-parameter #f))
@@ -99,18 +134,24 @@
 (define %postgresql-connections-hash-table
   (make-parameter #f))
 
+(define %postgresql-connections-name
+  (make-parameter #f))
+
 (define* (with-postgresql-connection-per-thread name thunk
                                                 #:key (statement-timeout #f))
   (parameterize ((%postgresql-connection-parameters
                   (list name statement-timeout))
                  (%postgresql-connections-hash-table
-                  (make-hash-table)))
+                  (make-hash-table))
+                 (%postgresql-connections-name
+                  name))
     (call-with-values
         thunk
       (lambda vals
         (hash-for-each
          (lambda (thread conn)
-           (pg-conn-finish conn))
+           (pg-conn-finish conn)
+           (decrement-connection-gauge name))
          (%postgresql-connections-hash-table))
 
         (apply values vals)))))
@@ -136,6 +177,8 @@
         (with-exception-handler
             (lambda (exn)
               (pg-conn-finish conn)
+              (decrement-connection-gauge
+               (%postgresql-connections-name))
               (set-current-thread-connection #f)
               (raise-exception exn))
           (lambda ()
@@ -153,7 +196,9 @@
       (pg-conn-finish conn)
       (hash-remove! (%postgresql-connections-hash-table)
                     (current-thread))
-      (fluid-set! %thread-postgresql-connection #f))))
+      (fluid-set! %thread-postgresql-connection #f)
+      (decrement-connection-gauge
+       (%postgresql-connections-name)))))
 
 (define* (with-postgresql-transaction conn f
                                       #:key always-rollback?)