Rework the way metrics are handled

Start writing a proper Prometheus client, hopefully this code can be extracted
at some point.

3 files changed, 223 insertions, 71 deletions

diff --git a/guix-build-coordinator/agent-messaging/http.scm b/guix-build-coordinator/agent-messaging/http.scm
index 6c5bf51..4b569f1 100644
--- a/guix-build-coordinator/agent-messaging/http.scm
+++ b/guix-build-coordinator/agent-messaging/http.scm
@@ -40,6 +40,7 @@
   #:use-module (guix serialization)
   #:use-module (guix build utils)
   #:use-module (guix-build-coordinator utils)
+  #:use-module (guix-build-coordinator metrics)
   #:use-module (guix-build-coordinator datastore)
   #:use-module (guix-build-coordinator metrics)
   #:use-module (guix-build-coordinator coordinator)
@@ -86,6 +87,10 @@ if there was no request body."
     (make-worker-thread-channel (const '())
                                 #:parallelism 4))
 
+  (define update-base-datastore-metrics!
+    (base-datastore-metrics-updater datastore
+                                    coordinator-metrics-registry))
+
   (trigger-build-allocation)
   (call-with-error-handling
    (lambda ()
@@ -105,7 +110,8 @@ if there was no request body."
                            datastore
                            trigger-build-allocation
                            hook-channel
-                           chunked-request-channel)))
+                           chunked-request-channel
+                           update-base-datastore-metrics!)))
       #:host host
       #:port port))
    #:on-error 'backtrace
@@ -146,6 +152,68 @@ port. Also, the port used can be changed by passing the --port option.\n"
   (list (build-response #:code 204)
         ""))
 
+(define (base-datastore-metrics-updater datastore registry)
+  (define namespace
+    "guixbuildcoordinator")
+
+  (let ((builds-total
+         (make-gauge-metric registry
+                            (string-append namespace
+                                           "_builds_total")))
+        (allocated-builds-total
+         (make-gauge-metric registry
+                            (string-append namespace
+                                           "_allocated_builds_total")
+                            #:labels '(agent_id)))
+        (build-results-total
+         (make-gauge-metric registry
+                            (string-append namespace
+                                           "_build_results_total")
+                            #:labels '(agent_id result)))
+        (setup-failures-total
+         (make-gauge-metric registry
+                            (string-append namespace
+                                           "_setup_failures_total")
+                            #:labels '(agent_id reason)))
+        (build-allocation-plan-total
+         (make-gauge-metric registry
+                            (string-append namespace
+                                           "_build_allocation_plan_total")
+                            #:labels '(agent_id))))
+    (lambda ()
+      (metric-set builds-total
+                  (datastore-count-builds datastore))
+      (for-each (match-lambda
+                  ((agent-id . count)
+                   (metric-set allocated-builds-total
+                               count
+                               #:label-values
+                               `((agent_id . ,agent-id)))))
+                (datastore-count-allocated-builds datastore))
+      (for-each (match-lambda
+                  (((agent-id result) . count)
+                   (metric-set build-results-total
+                               count
+                               #:label-values
+                               `((agent_id . ,agent-id)
+                                 (result   . ,result)))))
+                (datastore-count-build-results datastore))
+      (for-each (match-lambda
+                  (((agent-id reason) . count)
+                   (metric-set setup-failures-total
+                               count
+                               #:label-values
+                               `((agent_id . ,agent-id)
+                                 (reason   . ,reason)))))
+                (datastore-count-setup-failures datastore))
+      (for-each (match-lambda
+                  ((agent-id . count)
+                   (metric-set build-allocation-plan-total
+                               count
+                               #:label-values
+                               `((agent_id . ,agent-id)))))
+                (datastore-count-build-allocation-plan-entries  datastore)))))
+
 (define (controller request
                     method-and-path-components
                     body
@@ -153,7 +221,8 @@ port. Also, the port used can be changed by passing the --port option.\n"
                     datastore
                     trigger-build-allocation
                     hook-channel
-                    chunked-request-channel)
+                    chunked-request-channel
+                    update-base-datastore-metrics!)
   (define (authenticated? uuid request)
     (let* ((authorization-base64
             (match (assq-ref (request-headers request)
@@ -299,8 +368,14 @@ port. Also, the port used can be changed by passing the --port option.\n"
               "access denied"
               #:code 403))))
       (('GET "metrics")
-       (render-text
-        (metrics datastore)))
+       (update-base-datastore-metrics!)
+       (list (build-response
+              #:code 200
+              #:headers '((content-type . (text/plain))
+                          (vary . (accept))))
+             (lambda (port)
+               (write-metrics coordinator-metrics-registry
+                              port))))
       (_
        (render-json
         "not-found"
diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm
index 628dc99..4df246f 100644
--- a/guix-build-coordinator/coordinator.scm
+++ b/guix-build-coordinator/coordinator.scm
@@ -30,9 +30,12 @@
   #:use-module (guix derivations)
   #:use-module (guix-build-coordinator utils)
   #:use-module (guix-build-coordinator config)
+  #:use-module (guix-build-coordinator metrics)
   #:use-module (guix-build-coordinator datastore)
   #:use-module (guix-build-coordinator build-allocator)
-  #:export (submit-build
+  #:export (coordinator-metrics-registry
+
+            submit-build
             new-agent
             new-agent-password
             fetch-builds
@@ -45,6 +48,9 @@
             handle-build-result
             handle-setup-failure-report))
 
+(define coordinator-metrics-registry
+  (make-metrics-registry))
+
 (define* (submit-build datastore derivation-file
                        #:key
                        requested-uuid
diff --git a/guix-build-coordinator/metrics.scm b/guix-build-coordinator/metrics.scm
index 00648d3..8878953 100644
--- a/guix-build-coordinator/metrics.scm
+++ b/guix-build-coordinator/metrics.scm
@@ -19,75 +19,146 @@
 ;;; <http://www.gnu.org/licenses/>.
 
 (define-module (guix-build-coordinator metrics)
+  #:use-module (srfi srfi-9)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 exceptions)
   #:use-module (guix-build-coordinator datastore)
-  #:export (metrics))
+  #:export (make-metrics-registry
+            write-metrics
+
+            make-gauge-metric
+
+            metric-increment
+            metric-decrement
+            metric-set))
 
 (define namespace
   "guixbuildcoordinator")
 
-(define (format-metric namespace metric labels-and-values value)
-  (simple-format
-   #f
-   "~A_~A~A ~A"
-   namespace
-   metric
-   (if (null? labels-and-values)
-       ""
-       (string-append
-        "{"
-        (string-join (map
-                      (match-lambda
-                        ((label . value)
-                         (simple-format
-                          #f
-                          "~A=\"~A\""
-                          label value)))
-                      labels-and-values)
-                     ",")
-        "}"))
-   value))
-
-(define (metrics datastore)
-  (string-join
-   (append (list
-            (format-metric
-             namespace
-             "builds_total"
-             '()
-             (datastore-count-builds datastore)))
-           (map (match-lambda
-                  ((agent-id . count)
-                   (format-metric
-                    namespace
-                    "allocated_builds_total"
-                    `((agent_id . ,agent-id))
-                    count)))
-                (datastore-count-allocated-builds datastore))
-           (map (match-lambda
-                  (((agent-id result) . count)
-                   (format-metric
-                    namespace
-                    "build_results_total"
-                    `((agent_id . ,agent-id)
-                      (result   . ,result))
-                    count)))
-                (datastore-count-build-results datastore))
-           (map (match-lambda
-                  (((agent-id reason) . count)
-                   (format-metric
-                    namespace
-                    "setup_failures_total"
-                    `((agent_id . ,agent-id)
-                      (reason   . ,reason))
-                    count)))
-                (datastore-count-setup-failures datastore))
-           (map (match-lambda
-                  ((agent-id . count)
-                   (format-metric
-                    namespace
-                    "build_allocation_plan_total"
-                    `((agent_id . ,agent-id))
-                    count)))
-                (datastore-count-build-allocation-plan-entries  datastore)))
-   "\n"))
+(define-record-type <metrics-registry>
+  (make-metrics-registry-record metrics-hash)
+  metrics-registry?
+  (metrics-hash    metrics-registry-metrics-hash))
+
+(define (make-metrics-registry)
+  (make-metrics-registry-record (make-hash-table)))
+
+(define-record-type <metric>
+  (make-metric type name values registry docstring labels label-preset-values)
+  metric?
+  (type                  metric-type)
+  (name                  metric-name)
+  (values                metric-values)
+  (registry              metric-registry)
+  (docstring             metric-docstring)
+  (labels                metric-labels)
+  (label-preset-values   metric-label-preset-values))
+
+(define (metrics-registry-add-metric registry name metric)
+  (let ((metrics-hash
+         (metrics-registry-metrics-hash registry)))
+    (when (hash-ref metrics-hash name)
+      (raise-exception
+       (make-exception-with-message
+        (simple-format #f "metric ~A already exists"
+                       name))))
+
+    (hash-set! metrics-hash name metric)
+
+    metric))
+
+(define* (make-gauge-metric registry name
+                            #:key
+                            docstring
+                            (labels '())
+                            (label-preset-values '()))
+  (metrics-registry-add-metric
+   registry
+   name
+   (make-metric 'gauge
+                name
+                (make-hash-table)
+                registry
+                docstring
+                labels
+                label-preset-values)))
+
+(define (canonicalise-label-values-for-metric metric
+                                              label-values)
+  label-values)
+
+(define* (metric-increment metric
+                           #:key
+                           (by 1)
+                           (label-values '()))
+  (unless (memq (metric-type metric)
+                '(counter gauge))
+    (error "can only increment counter and gauge metrics"))
+
+  (unless (positive? by)
+    (error "can only increment positive values"))
+
+  (let ((canonical-labels
+         (canonicalise-label-values-for-metric metric label-values))
+        (hash
+         (metric-values metric)))
+    (hash-set! hash
+               canonical-labels
+               (+ by
+                  (or (hash-ref hash canonical-labels)
+                      0)))))
+
+(define* (metric-decrement metric
+                           #:key
+                           (by 1)
+                           (label-values '()))
+  (unless (memq (metric-type metric)
+                '(gauge))
+    (error "can only increment gauge metrics"))
+
+  (let ((canonical-labels
+         (canonicalise-label-values-for-metric metric label-values))
+        (hash
+         (metric-values metric)))
+    (hash-set! hash
+               canonical-labels
+               (+ (* -1 by)
+                  (or (hash-ref hash canonical-labels)
+                      0)))))
+
+(define* (metric-set metric value
+                     #:key (label-values '()))
+  (unless (memq (metric-type metric)
+                '(gauge))
+    (error "can only set gauge metrics"))
+
+  (hash-set! (metric-values metric)
+             (canonicalise-label-values-for-metric metric label-values)
+             value))
+
+(define (write-metrics registry port)
+  (hash-for-each
+   (lambda (name metric)
+     (hash-for-each
+      (lambda (label-values value)
+        (simple-format
+         port
+         "~A~A ~A\n"
+         name
+         (if (null? label-values)
+             ""
+             (string-append
+              "{"
+              (string-join (map
+                            (match-lambda
+                              ((label . value)
+                               (simple-format
+                                #f
+                                "~A=\"~A\""
+                                label value)))
+                            label-values)
+                           ",")
+              "}"))
+         value))
+      (metric-values metric)))
+   (metrics-registry-metrics-hash registry)))