;;; Guile Prometheus
;;;
;;; Copyright © 2020 Christopher Baines <mail@cbaines.net>
;;;
;;; This file is part of the Guile Prometheus client.
;;;
;;; The Guile Prometheus client 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 Guile Prometheus client 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 (prometheus)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:use-module (ice-9 threads)
  #:use-module (ice-9 exceptions)
  #:export (make-metrics-registry
            metrics-registry-fetch-metric
            write-metrics
            write-textfile

            make-counter-metric
            make-gauge-metric
            make-histogram-metric

            metric-increment
            metric-decrement
            metric-set
            metric-observe

            call-with-duration-metric))

(define-record-type <metrics-registry>
  (make-metrics-registry-record metrics-hash namespace)
  metrics-registry?
  (metrics-hash    metrics-registry-metrics-hash)
  (namespace       metrics-registry-namespace))

(define* (make-metrics-registry #:key namespace)
  "Create a metrics registry. This record stores named metrics, and
can have an optional @var{namespace}.

The @var{namespace} is used when writing out the metrics, each metric
name will be prefixed by the @var{namespace}, separated with an
underscore. Convention for naming metrics is that the @var{namespace}
should be a single word that identifies the application or area the
metrics relate to."
  (make-metrics-registry-record (make-hash-table)
                                namespace))

(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)
  "Fetch a metric by @var{name} from the @var{registry}"
  (hash-ref (metrics-registry-metrics-hash registry)
            name))

(define* (make-counter-metric registry name
                              #:key
                              docstring
                              (labels '())
                              (label-preset-values '()))
  "Make a counter metric, to track a value that only increases aside
from when it resets to 0 normally when the collector restarts. The
metric is associated with the specified @var{registry} under the given
@var{name}.

A metric record is returned, the value of the metric can be changed
with the @code{metric-increment} procedure.

The following keyword arguments can be used with all metrics:
@var{#:docstring} a short description of the metric, @var{#:labels} a
list of label names to be permitted for this metric and
@var{#:label-preset-values} default values for labels."
  (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 '()))
  "Make a gauge metric, to track a value that can go up or down. The
metric is associated with the specified @var{registry} under the given
@var{name}.

A metric record is returned, the value of the metric can be changed
with the @code{metric-increment}, @code{metric-decrement} or
@code{metric-set} procedures.

The following keyword arguments can be used with all metrics:
@var{#:docstring} a short description of the metric, @var{#:labels} a
list of label names to be permitted for this metric and
@var{#:label-preset-values} default values for labels."
  (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-record-type <histogram-values>
  (make-histogram-values buckets sum count)
  histogram-values?
  (buckets histogram-values-buckets)
  (sum     histogram-values-sum      set-histogram-values-sum!)
  (count   histogram-values-count    set-histogram-values-count!))

(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 '()))
  "Make a histogram metric, to track observations of values in a set
of buckets. Quantiles can be calculated from the histogram, which
makes this metric type good for observing things like durations.

Internally, this metric represents multiple metrics. One for each
bucket, plus one to record the total of all observed values and
another to count the number of observations.

A metric record is returned, this can be used with the
@code{metric-observe} procedure.

The following keyword arguments can be used with all metrics:
@var{#:docstring} a short description of the metric, @var{#:labels} a
list of label names to be permitted for this metric and
@var{#:label-preset-values} default values for labels."
  ;; 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 '()))
  "Increment the value of the given @var{metric} by 1 (or the @var{#:by} value).

This procedure can be used with counter or gauge metrics.

To specify values for the labels, pass an alist as
@var{#:label-values} where the keys are the label names, and the
values are the 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 '()))
  "Decrement the value of the given @var{metric} by 1 (or the @var{#:by} value).

This procedure can be used with gauge metrics.

To specify values for the labels, pass an alist as
@var{#:label-values} where the keys are the label names, and the
values are the 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 '()))
  "Set the value of the given @var{metric} to @var{value}.

This procedure can be used with gauge metrics.

To specify values for the labels, pass an alist as
@var{#:label-values} where the keys are the label names, and the
values are the 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 '()))
  "With the given @var{metric}, observe the given @var{value}.

This procedure can be used with histogram metrics.

To specify values for the labels, pass an alist as
@var{#:label-values} where the keys are the label names, and the
values are the 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* ((buckets
              (histogram-metric-type-buckets (metric-type metric)))
             (histogram-values-record
              (or (hash-ref hash canonical-labels)
                  (let ((new-record (make-histogram-values (make-vector
                                                            (length buckets)
                                                            0)
                                                           0
                                                           0)))
                    (hash-set! hash canonical-labels new-record)
                    new-record))))

        (set-histogram-values-sum! histogram-values-record
                                   (+ value
                                      (histogram-values-sum
                                       histogram-values-record)))
        (set-histogram-values-count! histogram-values-record
                                     (+ 1
                                        (histogram-values-count
                                         histogram-values-record)))
        (let ((bucket-values-vector (histogram-values-buckets
                                     histogram-values-record)))
          (for-each
           (lambda (index bucket-upper-limit)
             (when (<= value bucket-upper-limit)
               (vector-set! bucket-values-vector
                            index
                            (+ 1
                               (vector-ref bucket-values-vector
                                           index)))))
           (iota (length buckets))
           buckets))))))

(define* (call-with-duration-metric registry metric-name thunk
                                    #:key
                                    (buckets %default-histogram-buckets)
                                    docstring
                                    (labels '())
                                    (label-values '())
                                    (label-preset-values '()))
  "Call @var{thunk} while recording the duration in seconds between
calling @var{thunk} and the procedure ending using a metric by the
name of @var{metric-name}.

The metric with the name @var{metric-name} is fetched from the
@var{registry}, or created if it doesn't already exist.
"
  (let* ((metric
          (or (metrics-registry-fetch-metric registry metric-name)
              (monitor
               ;; Check once more in case another thread has created
               ;; the metric while this thread was waiting for the
               ;; mutex
               (or (metrics-registry-fetch-metric registry metric-name)
                   (make-histogram-metric
                    registry
                    metric-name
                    #:buckets buckets
                    #:docstring docstring
                    #:labels labels
                    #:label-preset-values label-preset-values)))))
         (start-time (get-internal-real-time)))
    (call-with-values
        thunk
      (lambda results
        (metric-observe metric
                        (/ (- (get-internal-real-time) start-time)
                           internal-time-units-per-second)
                        #:label-values label-values)

        (apply values results)))))

(define (write-metrics registry port)
  "Write all metrics from the given @var{registry} to @var{port} in
the standard text based exposition format.

Usually, this would be in response to a HTTP request from Prometheus
so that it can receive and store the metric values."

  (define (write-line name label-values value)
    (format
     port
     "~a~a ~f\n"
     name
     (if (null? label-values)
         ""
         (string-append
          "{"
          (string-join (map
                        (match-lambda
                          ((label . (? number? value))
                           (format
                            #f
                            "~a=\"~f\""
                            label value))
                          ((label . value)
                           (format
                            #f
                            "~a=\"~a\""
                            label value)))
                        label-values)
                       ",")
          "}"))
     value))

  (hash-for-each
   (lambda (name metric)
     (let ((full-name
            (string-append
             (or (and=> (metrics-registry-namespace registry)
                        (lambda (namespace)
                          (string-append namespace "_")))
                 "")
             name))
           (type (metric-type metric)))

       (and=> (metric-docstring metric)
              (lambda (docstring)
                (simple-format
                 port
                 "# HELP ~A ~A\n"
                 full-name
                 docstring)))

       (simple-format port "# TYPE ~A ~A\n"
                      full-name
                      (match type
                        ((? histogram-metric-type? type) 'histogram)
                        (type type)))

       (cond
        ((histogram-metric-type? type)
         (let ((buckets  (histogram-metric-type-buckets type)))
           (hash-for-each
            (lambda (label-values value)
              (for-each (lambda (index bucket)
                          (write-line (string-append full-name "_bucket")
                                      `(,@label-values
                                        (le . ,(if (inf? bucket)
                                                   "+Inf"
                                                   (format #f "~f" bucket))))
                                      (vector-ref (histogram-values-buckets value)
                                                  index)))
                        (iota (length buckets))
                        buckets)
              (write-line (string-append full-name "_sum")
                          label-values
                          (histogram-values-sum value))
              (write-line (string-append full-name "_count")
                          label-values
                          (histogram-values-count value)))
            (metric-values metric))))
        (else
         (hash-for-each
          (lambda (label-values value)
            (write-line full-name label-values value))
          (metric-values metric))))))
   (metrics-registry-metrics-hash registry)))

(define (write-textfile registry filename)
  "Write all metrics from the given @var{registry} to @var{filename}
in the standard text based exposition format.

For the node exporter to read the file, the @var{filename} must end
with .prom.

This procedure takes care of atomically replacing the file."
  (let* ((template (string-append filename ".XXXXXX"))
         (out      (mkstemp! template)))
    (with-throw-handler #t
      (lambda ()
        (chmod out(logand #o666 (lognot (umask))))
        (write-metrics registry out)
        (close out)
        (rename-file template filename)
        #t)
      (lambda (key . args)
        (false-if-exception (delete-file template))))))