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 exceptions)
  #:export (make-metrics-registry
            metrics-registry-fetch-metric
            write-metrics

            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)
  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 (metrics-registry-fetch-metric registry name)
  (hash-ref (metrics-registry-metrics-hash registry)
            name))

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

(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* (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-for-metric metric label-values))
        (hash
         (metric-values 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)))