Remove usage of error

As I think this is unnecessary.

prometheus.scm

@@ -21,10 +21,12 @@
 (define-module (prometheus)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
+  #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
   #:use-module (ice-9 threads)
   #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 textual-ports)
   #:export (make-metrics-registry
             metrics-registry-fetch-metric
             write-metrics
@@ -32,6 +34,11 @@
 
             make-counter-metric
             make-gauge-metric
+
+            %default-histogram-buckets
+            linear-histogram-buckets
+            exponential-histogram-buckets
+
             make-histogram-metric
 
             metric-increment
@@ -39,7 +46,10 @@
             metric-set
             metric-observe
 
-            call-with-duration-metric))
+            call-with-duration-metric
+
+            get-gc-metrics-updater
+            get-process-metrics-updater))
 
 (define-record-type <metrics-registry>
   (make-metrics-registry-record metrics-hash namespace)
@@ -60,13 +70,12 @@ metrics relate to."
                                 namespace))
 
 (define-record-type <metric>
-  (make-metric type name values registry docstring labels label-preset-values
+  (make-metric type name values 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)
@@ -113,7 +122,6 @@ list of label names to be permitted for this metric and
    (make-metric 'counter
                 name
                 (make-hash-table)
-                registry
                 docstring
                 labels
                 label-preset-values
@@ -142,7 +150,6 @@ list of label names to be permitted for this metric and
    (make-metric 'gauge
                 name
                 (make-hash-table)
-                registry
                 docstring
                 (map canonicalise-label labels)
                 (canonicalise-label-values label-preset-values)
@@ -164,6 +171,47 @@ list of label names to be permitted for this metric and
   ;; 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* (linear-histogram-buckets #:key start step end count)
+  (when (and end count)
+    (raise-exception
+     (make-exception-with-message
+      "you can only specify either end or count to linear-histogram-buckets")))
+
+  (append (if count
+              (map (lambda (index)
+                     (+ start
+                        (* step index)))
+                   (iota count))
+              (let loop ((reverse-result (list start))
+                         (current-value start))
+                (let ((next-value (+ current-value step)))
+                  (if (>= next-value end)
+                      (reverse (cons end reverse-result))
+                      (loop (cons next-value reverse-result)
+                            next-value)))))
+          (list (inf))))
+
+(define* (exponential-histogram-buckets #:key start (factor 2) end count)
+  (when (and end count)
+    (raise-exception
+     (make-exception-with-message
+      "you can only specify either end or count to exponential-histogram-buckets")))
+
+  (append (if count
+              (map (lambda (index)
+                     (* start
+                        (expt factor index)))
+                   (iota count))
+              (let loop ((reverse-result (list start)))
+                (let ((next-value
+                       (* start
+                          (expt factor
+                                (+ 1 (length reverse-result))))))
+                  (if (>= next-value end)
+                      (reverse (cons end reverse-result))
+                      (loop (cons next-value reverse-result))))))
+          (list (inf))))
+
 (define* (make-histogram-metric registry name
                                 #:key
                                 (buckets %default-histogram-buckets)
@@ -193,7 +241,6 @@ list of label names to be permitted for this metric and
    (make-metric (make-histogram-metric-type buckets)
                 name
                 (make-hash-table)
-                registry
                 docstring
                 labels
                 label-preset-values
@@ -244,21 +291,26 @@ To specify values for the labels, pass an alist as
 values are the values."
   (unless (memq (metric-type metric)
                 '(counter gauge))
-    (error "can only increment counter and gauge metrics"))
+    (raise-exception
+     (make-exception-with-message
+      "can only increment counter and gauge metrics")))
 
   (unless (positive? by)
-    (error "can only increment positive values"))
+    (raise-exception
+     (make-exception-with-message "can only increment positive values")))
 
   (let ((canonical-labels
          (canonicalise-label-values label-values))
         (hash
          (metric-values metric)))
-    (with-mutex (metric-mutex metric)
+    (call-with-blocked-asyncs
-      (hash-set! hash
+     (lambda ()
-                 canonical-labels
+       (with-mutex (metric-mutex metric)
-                 (+ by
+         (hash-set! hash
-                    (or (hash-ref hash canonical-labels)
+                    canonical-labels
-                        0))))))
+                    (+ by
+                       (or (hash-ref hash canonical-labels)
+                           0))))))))
 
 (define* (metric-decrement metric
                            #:key
@@ -273,18 +325,21 @@ To specify values for the labels, pass an alist as
 values are the values."
   (unless (memq (metric-type metric)
                 '(gauge))
-    (error "can only increment gauge metrics"))
+    (raise-exception
+     (make-exception-with-message "can only increment gauge metrics")))
 
   (let ((canonical-labels
          (canonicalise-label-values label-values))
         (hash
          (metric-values metric)))
-    (with-mutex (metric-mutex metric)
+    (call-with-blocked-asyncs
-      (hash-set! hash
+     (lambda ()
-                 canonical-labels
+       (with-mutex (metric-mutex metric)
-                 (+ (* -1 by)
+         (hash-set! hash
-                    (or (hash-ref hash canonical-labels)
+                    canonical-labels
-                        0))))))
+                    (+ (* -1 by)
+                       (or (hash-ref hash canonical-labels)
+                           0))))))))
 
 (define* (metric-set metric value
                      #:key (label-values '()))
@@ -297,12 +352,21 @@ To specify values for the labels, pass an alist as
 values are the values."
   (unless (memq (metric-type metric)
                 '(gauge))
-    (error "can only set gauge metrics"))
+    (raise-exception
+     (make-exception-with-message "can only set gauge metrics")))
 
-  (with-mutex (metric-mutex metric)
+  (unless (number? value)
-    (hash-set! (metric-values metric)
+    (raise-exception
-               (canonicalise-label-values label-values)
+     (make-exception-with-message
-               value)))
+      (simple-format #f "metric-set value must be a number: ~A"
+                     value))))
+
+  (call-with-blocked-asyncs
+   (lambda ()
+     (with-mutex (metric-mutex metric)
+       (hash-set! (metric-values metric)
+                  (canonicalise-label-values label-values)
+                  value)))))
 
 (define* (metric-observe metric value
                          #:key (label-values '()))
@@ -315,46 +379,50 @@ To specify values for the labels, pass an alist as
 values are the values."
 
   (unless (histogram-metric-type? (metric-type metric))
-    (error "can only observe histogram metrics"))
+    (raise-exception
+     (make-exception-with-message
+      "can only observe histogram metrics")))
 
   (let ((canonical-labels
          (canonicalise-label-values label-values))
         (hash
          (metric-values metric)))
 
-    (with-mutex (metric-mutex metric)
+    (call-with-blocked-asyncs
-      (let* ((buckets
+     (lambda ()
-              (histogram-metric-type-buckets (metric-type metric)))
+       (with-mutex (metric-mutex metric)
-             (histogram-values-record
+         (let* ((buckets
-              (or (hash-ref hash canonical-labels)
+                 (histogram-metric-type-buckets (metric-type metric)))
-                  (let ((new-record (make-histogram-values (make-vector
+                (histogram-values-record
-                                                            (length buckets)
+                 (or (hash-ref hash canonical-labels)
-                                                            0)
+                     (let ((new-record (make-histogram-values (make-vector
-                                                           0
+                                                               (length buckets)
-                                                           0)))
+                                                               0)
-                    (hash-set! hash canonical-labels new-record)
+                                                              0
-                    new-record))))
+                                                              0)))
+                       (hash-set! hash canonical-labels new-record)
+                       new-record))))
 
-        (set-histogram-values-sum! histogram-values-record
+           (set-histogram-values-sum! histogram-values-record
-                                   (+ value
+                                      (+ value
-                                      (histogram-values-sum
+                                         (histogram-values-sum
-                                       histogram-values-record)))
+                                          histogram-values-record)))
-        (set-histogram-values-count! histogram-values-record
+           (set-histogram-values-count! histogram-values-record
-                                     (+ 1
+                                        (+ 1
-                                        (histogram-values-count
+                                           (histogram-values-count
-                                         histogram-values-record)))
+                                            histogram-values-record)))
-        (let ((bucket-values-vector (histogram-values-buckets
+           (let ((bucket-values-vector (histogram-values-buckets
-                                     histogram-values-record)))
+                                        histogram-values-record)))
-          (for-each
+             (for-each
-           (lambda (index bucket-upper-limit)
+              (lambda (index bucket-upper-limit)
-             (when (<= value bucket-upper-limit)
+                (when (<= value bucket-upper-limit)
-               (vector-set! bucket-values-vector
+                  (vector-set! bucket-values-vector
-                            index
+                               index
-                            (+ 1
+                               (+ 1
-                               (vector-ref bucket-values-vector
+                                  (vector-ref bucket-values-vector
-                                           index)))))
+                                              index)))))
-           (iota (length buckets))
+              (iota (length buckets))
-           buckets))))))
+              buckets))))))))
 
 (define* (call-with-duration-metric registry metric-name thunk
                                     #:key
@@ -372,18 +440,13 @@ The metric with the name @var{metric-name} is fetched from the
 "
   (let* ((metric
           (or (metrics-registry-fetch-metric registry metric-name)
-              (monitor
+              (make-histogram-metric
-               ;; Check once more in case another thread has created
+               registry
-               ;; the metric while this thread was waiting for the
+               metric-name
-               ;; mutex
+               #:buckets buckets
-               (or (metrics-registry-fetch-metric registry metric-name)
+               #:docstring docstring
-                   (make-histogram-metric
+               #:labels labels
-                    registry
+               #:label-preset-values label-preset-values)))
-                    metric-name
-                    #:buckets buckets
-                    #:docstring docstring
-                    #:labels labels
-                    #:label-preset-values label-preset-values)))))
          (start-time (get-internal-real-time)))
     (call-with-values
         thunk
@@ -502,3 +565,162 @@ This procedure takes care of atomically replacing the file."
       (lambda (key . args)
         (false-if-exception (delete-file template))))))
 
+(define (get-gc-metrics-updater registry)
+  (define metrics
+    `((gc-time-taken
+       . ,(make-gauge-metric registry "guile_gc_time_taken_seconds"))
+      (heap-size
+       . ,(make-gauge-metric registry "guile_heap_bytes"))
+      (heap-free-size
+       . ,(make-gauge-metric registry "guile_heap_free_bytes"))
+      (heap-total-allocated
+       . ,(make-gauge-metric registry "guile_heap_total_allocated_bytes"))
+      (heap-allocated-since-gc
+       . ,(make-gauge-metric registry "guile_allocated_since_gc_bytes"))
+      (protected-objects
+       . ,(make-gauge-metric registry "guile_gc_protected_objects_total"))
+      (gc-times
+       . ,(make-gauge-metric registry "guile_gc_times_total"))))
+
+  (lambda ()
+    (let ((stats (gc-stats)))
+      (for-each
+       (match-lambda
+         (('gc-time-taken . metric)
+          (metric-set metric
+                      (/ (assq-ref stats 'gc-time-taken)
+                         internal-time-units-per-second)))
+         ((name . metric)
+          (let ((value (assq-ref stats name)))
+            (metric-set metric value))))
+       metrics))))
+
+(define* (get-process-metrics-updater registry
+                                      #:key (pid (getpid))
+                                      (proc "/proc"))
+  (define cpu-seconds-metric
+    (make-gauge-metric registry
+                       "process_cpu_seconds_total"
+                       #:docstring
+                       "Total user and system CPU time spent in seconds."))
+
+  (define open-fds-metric
+    (make-gauge-metric registry
+                       "process_open_fds"
+                       #:docstring "Number of open file descriptors."))
+
+  (define max-fds-metric
+    (make-gauge-metric registry
+                       "process_max_fds"
+                       #:docstring "Maximum number of open file descriptors."))
+
+  (define virtual-memory-bytes-metric
+    (make-gauge-metric registry
+                       "process_virtual_memory_bytes"
+                       #:docstring "Virtual memory size in bytes."))
+
+  ;; (define virtual-memory-max-bytes-metric
+  ;;   (make-gauge-metric registry
+  ;;                      "process_virtual_memory_max_bytes"
+  ;;                      #:docstring "Maximum amount of virtual memory available in bytes."))
+
+  (define resident-memory-bytes-metric
+    (make-gauge-metric registry
+                       "process_resident_memory_bytes"
+                       #:docstring "Resident memory size in bytes."))
+
+  ;; (define heap-bytes-metric
+  ;;   (make-gauge-metric registry
+  ;;                      "process_heap_bytes"
+  ;;                      #:docstring "Process heap size in bytes."))
+
+  (define start-time-seconds-metric
+    (make-gauge-metric registry
+                       "process_start_time_seconds"
+                       #:docstring "Start time of the process since unix epoch in seconds."))
+
+  (define threads-metric
+    (make-gauge-metric registry
+                       "process_threads"
+                       #:docstring "Number of OS threads in the process."))
+
+  (define boot-time
+    (let ((contents
+           (call-with-input-file (string-append proc "/stat")
+             get-string-all)))
+      (match (string-split
+              (find
+               (lambda (line)
+                 (string-prefix? "btime " line))
+               (string-split contents #\newline))
+              #\space)
+        ((_ btime)
+         (string->number btime)))))
+
+  (define page-size
+    ;; TODO Assume the page size
+    4096)
+
+  (define ticks
+    ;; TODO
+    100)
+
+  (lambda ()
+    (let ((stat-parts
+           (drop
+            (string-split
+             (last
+              (string-split
+               (call-with-input-file
+                   (string-append proc "/" (number->string pid) "/stat")
+                 get-string-all)
+               #\)))
+             #\space)
+            1)))
+
+      (metric-set virtual-memory-bytes-metric
+                  (string->number (list-ref stat-parts 20)))
+
+      (metric-set resident-memory-bytes-metric
+                  (* (string->number (list-ref stat-parts 21)) page-size))
+
+      (metric-set start-time-seconds-metric
+                  (+ (/ (string->number (list-ref stat-parts 19)) ticks) boot-time))
+
+      (let ((utime (/ (string->number (list-ref stat-parts 11)) ticks))
+            (stime (/ (string->number (list-ref stat-parts 12)) ticks)))
+        (metric-set cpu-seconds-metric
+                    (+ utime stime)))
+
+      (metric-set threads-metric
+                  (string->number (list-ref stat-parts 17))))
+
+    (let ((limits-lines
+           (string-split
+            (call-with-input-file
+                (string-append proc "/" (number->string pid) "/limits")
+              get-string-all)
+            #\newline)))
+
+      (let ((max-open-files-data
+             (take-right
+              (remove
+               string-null?
+               (string-split
+                (find
+                 (lambda (line)
+                   (string-prefix? "Max open files" line))
+                 limits-lines)
+                #\space))
+              3)))
+        (metric-set max-fds-metric
+                    (string->number (first max-open-files-data))))
+
+      (metric-set open-fds-metric
+                  (length
+                   ;; In theory 'scandir' cannot return #f, but in practice,
+                   ;; we've seen it before.
+                   (or (scandir "/proc/self/fd"
+                                (lambda (file)
+                                  (not (member file '("." "..")))))
+                       '()))))))