From 14f14eeaedf0135e212160b1ab2aa0c0ecc49037 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 31 Aug 2020 13:54:20 +0100 Subject: Use the guile-prometheus library for the metrics Which was extracted from the Guix Build Coordinator. --- Makefile.am | 1 - guix-build-coordinator/agent-messaging/http.scm | 3 +- guix-build-coordinator/coordinator.scm | 2 +- guix-build-coordinator/datastore/sqlite.scm | 2 +- guix-build-coordinator/metrics.scm | 303 ------------------------ guix-dev.scm | 27 +++ scripts/guix-build-coordinator.in | 2 +- 7 files changed, 31 insertions(+), 309 deletions(-) delete mode 100644 guix-build-coordinator/metrics.scm 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 -;;; -;;; 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 -;;; . - -(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 - (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 - (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 - (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) -- cgit v1.2.3