Add support for exposing some basic metrics

In a format understood by Prometheus.

1 files changed, 73 insertions, 1 deletions

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