aboutsummaryrefslogtreecommitdiff
path: root/guix-build-coordinator/metrics.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix-build-coordinator/metrics.scm')
-rw-r--r--guix-build-coordinator/metrics.scm303
1 files changed, 0 insertions, 303 deletions
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)))
generated by cgit v1.2.3 (git 2.25.4) at 2024-05-10 01:37:40 +0000