path: root/guix-build-coordinator/metrics.scm

;;; 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)))