From 241a704db15d36153b21d43742290bf308d05869 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Fri, 24 Nov 2023 16:11:42 +0000
Subject: Instrument handling build events

---
 guix-data-service/web/build-server/controller.scm | 106 ++++++++++++----------
 guix-data-service/web/server.scm                  |   9 +-
 2 files changed, 64 insertions(+), 51 deletions(-)

(limited to 'guix-data-service')

diff --git a/guix-data-service/web/build-server/controller.scm b/guix-data-service/web/build-server/controller.scm
index 911e41d..df3f3d7 100644
--- a/guix-data-service/web/build-server/controller.scm
+++ b/guix-data-service/web/build-server/controller.scm
@@ -21,9 +21,11 @@
   #:use-module (rnrs bytevectors)
   #:use-module (json)
   #:use-module (fibers)
+  #:use-module (prometheus)
   #:use-module (guix-data-service utils)
   #:use-module (guix-data-service database)
   #:use-module (guix-data-service substitutes)
+  #:use-module (guix-data-service web server)
   #:use-module (guix-data-service web render)
   #:use-module (guix-data-service web query-parameters)
   #:use-module (guix-data-service web controller)
@@ -255,56 +257,60 @@
       (render-json
        '((error . "no token provided"))
        #:code 400)
-      (let ((provided-token (assq-ref parsed-query-parameters 'token))
-            (permitted-tokens
-             (with-resource-from-pool (reserved-connection-pool) conn
-               (compute-tokens-for-build-server conn
-                                                secret-key-base
-                                                build-server-id))))
-        (if (member provided-token
-                    (map cdr permitted-tokens)
-                    string=?)
-            (catch
-              'json-invalid
-              (lambda ()
-                (let ((body-string (utf8->string body)))
-                  (let* ((body-json (json-string->scm body-string))
-                         (items (and=> (assoc-ref body-json "items")
-                                       vector->list)))
-                    (cond
-                     ((eq? items #f)
-                      (render-json
-                       '((error . "missing items key"))
-                       #:code 400))
-                     ((null? items)
-                      (render-json
-                       '((error . "no items to process"))
-                       #:code 400))
-                     (else
-                      (catch
-                        #t
-                        (lambda ()
-                          (process-items items)
-                          (no-content))
-                        (lambda (key . args)
-                          (simple-format (current-error-port)
-                                         "error processing events: ~A: ~A\n"
-                                         key
-                                         args)
-                          (for-each (lambda (item)
-                                      (simple-format (current-error-port)
-                                                     "  ~A\n" item))
-                                    items)
-                          (render-json
-                           '((error . "could not process events"))
-                           #:code 500))))))))
-              (lambda (key . args)
-                (render-json
-                 '((error . "could not parse body as JSON"))
-                 #:code 400)))
-            (render-json
-             '((error . "error"))
-             #:code 403)))))
+      (call-with-duration-metric
+       (%guix-data-service-metrics-registry)
+       "build_server_handle_events_submission_duration_seconds"
+       (lambda ()
+         (let ((provided-token (assq-ref parsed-query-parameters 'token))
+               (permitted-tokens
+                (with-resource-from-pool (reserved-connection-pool) conn
+                  (compute-tokens-for-build-server conn
+                                                   secret-key-base
+                                                   build-server-id))))
+           (if (member provided-token
+                       (map cdr permitted-tokens)
+                       string=?)
+               (catch
+                 'json-invalid
+                 (lambda ()
+                   (let ((body-string (utf8->string body)))
+                     (let* ((body-json (json-string->scm body-string))
+                            (items (and=> (assoc-ref body-json "items")
+                                          vector->list)))
+                       (cond
+                        ((eq? items #f)
+                         (render-json
+                          '((error . "missing items key"))
+                          #:code 400))
+                        ((null? items)
+                         (render-json
+                          '((error . "no items to process"))
+                          #:code 400))
+                        (else
+                         (catch
+                           #t
+                           (lambda ()
+                             (process-items items)
+                             (no-content))
+                           (lambda (key . args)
+                             (simple-format (current-error-port)
+                                            "error processing events: ~A: ~A\n"
+                                            key
+                                            args)
+                             (for-each (lambda (item)
+                                         (simple-format (current-error-port)
+                                                        "  ~A\n" item))
+                                       items)
+                             (render-json
+                              '((error . "could not process events"))
+                              #:code 500))))))))
+                 (lambda (key . args)
+                   (render-json
+                    '((error . "could not parse body as JSON"))
+                    #:code 400)))
+               (render-json
+                '((error . "error"))
+                #:code 403)))))))
 
 (define (handle-signing-key-request id)
   (render-html
diff --git a/guix-data-service/web/server.scm b/guix-data-service/web/server.scm
index 7acfb2b..ea14825 100644
--- a/guix-data-service/web/server.scm
+++ b/guix-data-service/web/server.scm
@@ -35,7 +35,9 @@
   #:use-module (guix-data-service database)
   #:use-module (guix-data-service web controller)
   #:use-module (guix-data-service web util)
-  #:export (start-guix-data-service-web-server))
+  #:export (%guix-data-service-metrics-registry
+
+            start-guix-data-service-web-server))
 
 (define (check-startup-completed startup-completed)
   (if (atomic-box-ref startup-completed)
@@ -64,6 +66,9 @@
                        (check-startup-completed startup-completed)
                        render-metrics))))
 
+(define %guix-data-service-metrics-registry
+  (make-parameter #f))
+
 (define* (start-guix-data-service-web-server port host secret-key-base
                                              startup-completed
                                              #:key postgresql-statement-timeout
@@ -73,6 +78,8 @@
 
   (%database-metrics-registry registry)
 
+  (%guix-data-service-metrics-registry registry)
+
   (let ((finished? (make-condition)))
     (call-with-sigint
      (lambda ()
-- 
cgit v1.2.3