Add support for exposing some basic metrics

In a format understood by Prometheus.

3 files changed, 81 insertions, 3 deletions

diff --git a/guix-dev.scm b/guix-dev.scm
index 1374c36..bd6828f 100644
--- a/guix-dev.scm
+++ b/guix-dev.scm
@@ -60,6 +60,7 @@
      ("guile" ,@(assoc-ref (package-native-inputs guix) "guile"))
      ("guile-sqlite3" ,guile-sqlite3)
      ("guile-lib" ,guile-lib)
+     ("guile-prometheus" ,guile-prometheus)
      ("sqlite" ,sqlite)))
   (native-inputs
    `(("autoconf" ,autoconf)
diff --git a/nar-herder/server.scm b/nar-herder/server.scm
index 97335c0..c977956 100644
--- a/nar-herder/server.scm
+++ b/nar-herder/server.scm
@@ -22,6 +22,7 @@
   #:use-module (web response)
   #:use-module (web request)
   #:use-module (logging logger)
+  #:use-module (prometheus)
   #:use-module (json)
   #:use-module (nar-herder database)
   #:use-module (nar-herder storage)
@@ -45,13 +46,53 @@
       (("") '())
       (() '()))))
 
+(define (get-gc-metrics-updater registry)
+  (define metrics
+    `((gc-time-taken
+       . ,(make-gauge-metric registry "guile_gc_time_taken"))
+      (heap-size
+       . ,(make-gauge-metric registry "guile_heap_size"))
+      (heap-free-size
+       . ,(make-gauge-metric registry "guile_heap_free_size"))
+      (heap-total-allocated
+       . ,(make-gauge-metric registry "guile_heap_total_allocated"))
+      (heap-allocated-since-gc
+       . ,(make-gauge-metric registry "guile_allocated_since_gc"))
+      (protected-objects
+       . ,(make-gauge-metric registry "guile_gc_protected_objects"))
+      (gc-times
+       . ,(make-gauge-metric registry "guile_gc_times"))))
+
+  (lambda ()
+    (let ((stats (gc-stats)))
+      (for-each
+       (match-lambda
+         ((name . metric)
+          (let ((value (assq-ref stats name)))
+            (metric-set metric value))))
+       metrics))))
+
 (define* (make-request-handler database storage-root
-                               #:key ttl negative-ttl logger)
+                               #:key ttl negative-ttl logger
+                               metrics-registry)
   (define (narinfo? str)
     (and
      (= (string-length str) 40)
      (string-suffix? ".narinfo" str)))
 
+  (define gc-metrics-updater
+    (get-gc-metrics-updater metrics-registry))
+
+  (define requests-total-metric
+    (make-counter-metric metrics-registry
+                         "server_requests_total"))
+
+  (define (increment-request-metric category response-code)
+    (metric-increment
+     requests-total-metric
+     #:label-values `((category . ,category)
+                      (response_code . ,response-code))))
+
   (lambda (request body)
     (log-msg logger
              'DEBUG
@@ -67,6 +108,12 @@
               (database-select-narinfo-contents-by-hash
                database
                (string-take narinfo 32))))
+
+         (increment-request-metric "narinfo"
+                                   (if narinfo-contents
+                                       "200"
+                                       "404"))
+
          (if narinfo-contents
              (values `((content-type . (text/plain))
                        ,@(if ttl
@@ -84,6 +131,12 @@
               (database-select-narinfo-contents-by-hash
                database
                (string-take narinfo 32))))
+
+         (increment-request-metric "narinfo/info"
+                                   (if narinfo-contents
+                                       "200"
+                                       "404"))
+
          (if narinfo-contents
              (render-json
               `((stored . ,(store-item-in-local-storage?
@@ -97,6 +150,9 @@
               (or (and=> (uri-query (request-uri request))
                          parse-query-string)
                   '())))
+
+         (increment-request-metric "recent-changes" "200")
+
          (render-json
           `((recent_changes . ,(list->vector
                                 (database-select-recent-changes
@@ -105,11 +161,27 @@
                                   (assoc-ref query-parameters "since")
                                   "1970-01-01 00:00:01"))))))))
       (('GET "latest-database-dump")
+
+       (increment-request-metric "latest-database-dump" "200")
+
        (values (build-response
                 #:code 200
                 #:headers '((X-Accel-Redirect . "/internal/database/nar_herder_dump.db")))
                #f))
+      (('GET "metrics")
+       (gc-metrics-updater)
+       (increment-request-metric "metrics" "200")
+
+       (values (build-response
+                #:code 200
+                #:headers '((content-type . (text/plain))
+                            (vary . (accept))))
+               (lambda (port)
+                 (write-metrics metrics-registry
+                                port))))
       (_
+       (increment-request-metric "unhandled" "404")
+
        (values (build-response #:code 404)
                "404")))))
 
diff --git a/scripts/nar-herder.in b/scripts/nar-herder.in
index fd4b7b4..b0c4498 100644
--- a/scripts/nar-herder.in
+++ b/scripts/nar-herder.in
@@ -45,6 +45,7 @@
              (oop goops)
              (logging logger)
              (logging port-log)
+             (prometheus)
              (fibers)
              (fibers conditions)
              (fibers web server)
@@ -270,7 +271,10 @@
                         (format #f "~a (~5a): ~a~%"
                                 (strftime "%F %H:%M:%S" (localtime time))
                                 lvl
-                                str)))))
+                                str))))
+          (metrics-registry (make-metrics-registry
+                             #:namespace
+                             "narherder")))
 
      (define (download-database)
        (let ((database-uri
@@ -383,6 +387,7 @@
                               canonical-storage
                               #:ttl (assq-ref opts 'narinfo-ttl)
                               #:negative-ttl (assq-ref opts 'narinfo-negative-ttl)
-                              #:logger lgr)
+                              #:logger lgr
+                              #:metrics-registry metrics-registry)
         #:host (assq-ref opts 'host)
         #:port (assq-ref opts 'port))))))