Use the guile-prometheus library for the metrics

Which was extracted from the Guix Build Coordinator.

7 files changed, 31 insertions, 309 deletions

diff --git a/Makefile.am b/Makefile.am
index d73488b..1922446 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -18,5 +18,4 @@ SOURCES =						\
   guix-build-coordinator/datastore/sqlite.scm		\
   guix-build-coordinator/guix-data-service.scm		\
   guix-build-coordinator/hooks.scm			\
-  guix-build-coordinator/metrics.scm			\
   guix-build-coordinator/utils.scm
diff --git a/guix-build-coordinator/agent-messaging/http.scm b/guix-build-coordinator/agent-messaging/http.scm
index 8c6d0e1..1a9a9e9 100644
--- a/guix-build-coordinator/agent-messaging/http.scm
+++ b/guix-build-coordinator/agent-messaging/http.scm
@@ -38,14 +38,13 @@
   #:use-module (web uri)
   #:use-module (fibers channels)
   #:use-module (lzlib)
+  #:use-module (prometheus)
   #:use-module (guix store)
   #:use-module (guix base64)
   #: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)
   #:export (http-agent-messaging-start-server
 
diff --git a/guix-build-coordinator/coordinator.scm b/guix-build-coordinator/coordinator.scm
index 1e54563..33b5afe 100644
--- a/guix-build-coordinator/coordinator.scm
+++ b/guix-build-coordinator/coordinator.scm
@@ -29,11 +29,11 @@
   #:use-module (ice-9 exceptions)
   #:use-module (gcrypt random)
   #:use-module (fibers channels)
+  #:use-module (prometheus)
   #:use-module (guix derivations)
   #:use-module (guix build utils)
   #: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 (make-build-coordinator
diff --git a/guix-build-coordinator/datastore/sqlite.scm b/guix-build-coordinator/datastore/sqlite.scm
index 503e088..f3e3bbf 100644
--- a/guix-build-coordinator/datastore/sqlite.scm
+++ b/guix-build-coordinator/datastore/sqlite.scm
@@ -4,10 +4,10 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 threads)
   #:use-module (sqlite3)
+  #:use-module (prometheus)
   #: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 abstract)
   #:export (sqlite-datastore
             datastore-update
diff --git a/guix-build-coordinator/metrics.scm b/guix-build-coordinator/metrics.scm
deleted file mode 100644
index b44458b..0000000
--- a/guix-build-coordinator/metrics.scm
+++ /dev/null
@@ -1,303 +0,0 @@
-;;; Guix Build Coordinator
-;;;
-;;; Copyright © 2020 Christopher Baines <mail@cbaines.net>
-;;;
-;;; This file is part of the guix-build-coordinator.
-;;;
-;;; The Guix Build Coordinator is free software; you can redistribute
-;;; it and/or modify it under the terms of the GNU General Public
-;;; License as published by the Free Software Foundation; either
-;;; version 3 of the License, or (at your option) any later version.
-;;;
-;;; The Guix Build Coordinator is distributed in the hope that it will
-;;; be useful, but WITHOUT ANY WARRANTY; without even the implied
-;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
-;;; See the GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with the guix-data-service.  If not, see
-;;; <http://www.gnu.org/licenses/>.
-
-(define-module (guix-build-coordinator metrics)
-  #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-9)
-  #:use-module (ice-9 match)
-  #:use-module (ice-9 threads)
-  #:use-module (ice-9 exceptions)
-  #:export (make-metrics-registry
-            metrics-registry-fetch-metric
-            write-metrics
-
-            make-counter-metric
-            make-gauge-metric
-            make-histogram-metric
-
-            metric-increment
-            metric-decrement
-            metric-set
-            metric-observe
-
-            call-with-duration-metric))
-
-(define namespace
-  "guixbuildcoordinator")
-
-(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
-               mutex)
-  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)
-  (mutex                 metric-mutex))
-
-(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 (metrics-registry-fetch-metric registry name)
-  (hash-ref (metrics-registry-metrics-hash registry)
-            name))
-
-(define* (make-counter-metric registry name
-                            #:key
-                            docstring
-                            (labels '())
-                            (label-preset-values '()))
-  (metrics-registry-add-metric
-   registry
-   name
-   (make-metric 'counter
-                name
-                (make-hash-table)
-                registry
-                docstring
-                labels
-                label-preset-values
-                (make-mutex))))
-
-(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
-                (map canonicalise-label labels)
-                (canonicalise-label-values label-preset-values)
-                (make-mutex))))
-
-(define-record-type <histogram-metric-type>
-  (make-histogram-metric-type buckets)
-  histogram-metric-type?
-  (buckets          histogram-metric-type-buckets))
-
-(define %default-histogram-buckets
-  ;; The default buckets used in other client libraries
-  (list 0.005 0.01 0.025 0.05 0.1 0.25 0.5 1 2.5 5 10 (inf)))
-
-(define* (make-histogram-metric registry name
-                                #:key
-                                (buckets %default-histogram-buckets)
-                                docstring
-                                (labels '())
-                                (label-preset-values '()))
-  ;; TODO validate buckets
-
-  (metrics-registry-add-metric
-   registry
-   name
-   (make-metric (make-histogram-metric-type buckets)
-                name
-                (make-hash-table)
-                registry
-                docstring
-                labels
-                label-preset-values
-                (make-mutex))))
-
-(define (canonicalise-label label)
-  (call-with-output-string
-    (lambda (port)
-      (display label port))))
-
-(define (canonicalise-label-value value)
-  (call-with-output-string
-    (lambda (port)
-      (display value port))))
-
-(define (canonicalise-label-values label-values)
-  (let ((canonical-label-values
-         (map (match-lambda
-                ((k . v)
-                 (cons (canonicalise-label k)
-                       (canonicalise-label-value v))))
-              label-values)))
-    (let loop ((lst (map car canonical-label-values)))
-      (unless (null? lst)
-        (let ((element (car lst))
-              (rest    (cdr lst)))
-          (when (member element rest string=?)
-            (raise-exception
-             (make-exception-with-message
-              (simple-format
-               #f "label value specified multiple times: ~A"
-               element))))
-
-          (loop rest))))
-
-    canonical-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 label-values))
-        (hash
-         (metric-values metric)))
-    (with-mutex (metric-mutex 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 label-values))
-        (hash
-         (metric-values metric)))
-    (with-mutex (metric-mutex 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"))
-
-  (with-mutex (metric-mutex metric)
-    (hash-set! (metric-values metric)
-               (canonicalise-label-values label-values)
-               value)))
-
-(define* (metric-observe metric value
-                         #:key (label-values '()))
-  (unless (histogram-metric-type? (metric-type metric))
-    (error "can only observe histogram metrics"))
-
-  (let ((canonical-labels
-         (canonicalise-label-values label-values))
-        (hash
-         (metric-values metric)))
-
-    (with-mutex (metric-mutex metric)
-      (let ((sum-labels
-             `(,@canonical-labels
-               (le . "sum"))))
-
-        (hash-set! hash
-                   sum-labels
-                   (+ value
-                      (or (hash-ref hash sum-labels)
-                          0))))
-
-      (let ((buckets (histogram-metric-type-buckets (metric-type metric))))
-        (for-each
-         (lambda (bucket-upper-limit)
-           (when (<= value bucket-upper-limit)
-             (let ((bucket-labels
-                    `(,@canonical-labels
-                      (le . ,(if (inf? bucket-upper-limit)
-                                 "+Inf"
-                                 (number->string bucket-upper-limit))))))
-               (hash-set! hash
-                          bucket-labels
-                          (+ 1
-                             (or (hash-ref hash bucket-labels)
-                                 0))))))
-         buckets)))))
-
-(define (call-with-duration-metric registry metric-name thunk)
-  (let* ((metric
-          (or (metrics-registry-fetch-metric registry metric-name)
-              (make-histogram-metric
-               registry
-               metric-name)))
-         (start-time (current-time)))
-    (let ((result (thunk)))
-      (metric-observe metric (- (current-time) start-time))
-      result)))
-
-(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)))
diff --git a/guix-dev.scm b/guix-dev.scm
index c2e500c..f00eab9 100644
--- a/guix-dev.scm
+++ b/guix-dev.scm
@@ -55,6 +55,32 @@
       guile-3.0-latest
       guile-next))
 
+(define-public guile-prometheus
+  (package
+    (name "guile-prometheus")
+    (version "0")
+    (source (origin
+              (method git-fetch)
+              (uri (git-reference
+                    (commit "5acbc44d2d6c89fd984ef2353f81f73d4e227a33")
+                    (url "https://git.cbaines.net/git/guile/prometheus")))
+              (sha256
+               (base32
+                "07qzj9nmlih6widndwk47x4nwwy5xdh32i51lym6j0ycbvb3fn0r"))
+              (file-name (string-append name "-" version "-checkout"))))
+    (build-system gnu-build-system)
+    (native-inputs
+     `(("pkg-config" ,pkg-config)
+       ("autoconf" ,autoconf)
+       ("automake" ,automake)))
+    (inputs
+     `(("guile" ,my-guile)))
+    (home-page "https://git.cbaines.net/guile/prometheus/")
+    (synopsis "")
+    (description
+     "")
+    (license license:gpl3+)))
+
 (package
   (name "guix-build-coordinator")
   (version "0.0.0")
@@ -68,6 +94,7 @@
      ("guile-gcrypt" ,guile3.0-gcrypt)
      ("guile-readline" ,guile-readline)
      ("guile-lzlib" ,guile-lzlib)
+     ("guile-prometheus" ,guile-prometheus)
      ("guile" ,my-guile)
      ("postgresql" ,postgresql)
      ("sqlite" ,sqlite)
diff --git a/scripts/guix-build-coordinator.in b/scripts/guix-build-coordinator.in
index 1d2781e..87982c0 100644
--- a/scripts/guix-build-coordinator.in
+++ b/scripts/guix-build-coordinator.in
@@ -28,12 +28,12 @@
              (web uri)
              (fibers)
              (fibers conditions)
+             (prometheus)
              ((guix ui) #:select (read/eval))
              (guix derivations)
              (guix-build-coordinator hooks)
              (guix-build-coordinator utils)
              (guix-build-coordinator config)
-             (guix-build-coordinator metrics)
              (guix-build-coordinator datastore)
              (guix-build-coordinator coordinator)
              (guix-build-coordinator build-allocator)