From 6e1da5700fc43b1e4f98bca2ed8518839cdb2173 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Thu, 8 Feb 2024 13:35:35 +0000
Subject: Expose information about setup failures

---
 guix-build-coordinator/client-communication.scm | 20 +++++++
 guix-build-coordinator/datastore/sqlite.scm     | 71 +++++++++++++++----------
 scripts/guix-build-coordinator.in               | 38 +++++++++++++
 3 files changed, 101 insertions(+), 28 deletions(-)

diff --git a/guix-build-coordinator/client-communication.scm b/guix-build-coordinator/client-communication.scm
index 094ab4e..5a66cdd 100644
--- a/guix-build-coordinator/client-communication.scm
+++ b/guix-build-coordinator/client-communication.scm
@@ -55,6 +55,7 @@
             request-agent-build-allocation-plan
             request-agents-list
             request-failed-builds-with-blocking-count-list
+            request-setup-failures
             send-create-agent-request
             send-agent-set-active-request
             send-create-agent-password-request
@@ -334,6 +335,16 @@
              (render-json
               `((error . 404))
               #:code 404))))
+      (('GET "setup-failures")
+       (let ((query-parameters (request-query-parameters request)))
+         (render-json
+          `((setup_failures
+             . ,(hash-map->list
+                 (lambda (k v)
+                   (cons k (list->vector v)))
+                 (datastore-fetch-setup-failures
+                  datastore
+                  #:agent-id (assq-ref query-parameters 'agent-id))))))))
       (('GET "builds")
        (let* ((query-parameters (request-query-parameters request))
               (fold-builds-args
@@ -944,6 +955,15 @@
                           "false"))
                      ""))))
 
+(define* (request-setup-failures coordinator-uri #:key agent-id)
+  (send-request coordinator-uri
+                'GET
+                (string-append
+                 "/setup-failures"
+                 (if agent-id
+                     (simple-format #f "?agent-id=~A" agent-id)
+                     ""))))
+
 (define* (send-create-agent-request coordinator-uri
                                     #:key
                                     requested-uuid
diff --git a/guix-build-coordinator/datastore/sqlite.scm b/guix-build-coordinator/datastore/sqlite.scm
index e5ae519..5e39849 100644
--- a/guix-build-coordinator/datastore/sqlite.scm
+++ b/guix-build-coordinator/datastore/sqlite.scm
@@ -2893,14 +2893,19 @@ WHERE build_id = :build_id"
          result)))))
 
 (define-method (datastore-fetch-setup-failures
-                (datastore <sqlite-datastore>))
-  (call-with-worker-thread
-   (slot-ref datastore 'worker-reader-thread-channel)
-   (lambda (db)
-     (let ((statement
-            (sqlite-prepare
-             db
-             "
+                (datastore <sqlite-datastore>)
+                .
+                args)
+  (apply
+   (lambda* (#:key agent-id)
+     (call-with-worker-thread
+      (slot-ref datastore 'worker-reader-thread-channel)
+      (lambda (db)
+        (let ((statement
+               (sqlite-prepare
+                db
+                (string-append
+                 "
 SELECT setup_failures.id, builds.uuid, agent_id, failure_reason
 FROM setup_failures
 INNER JOIN builds
@@ -2910,28 +2915,38 @@ WHERE builds.processed = 0
   AND builds.id NOT IN (
     SELECT build_id FROM allocated_builds
   )"
-             #:cache? #t)))
+                 (if agent-id
+                     "
+  AND agent_id = :agent_id"
+                     ""))
+                #:cache? #t)))
 
-       (let ((result (sqlite-fold
-                      (lambda (row result)
-                        (match row
-                          (#(id build-id agent-id failure-reason)
-                           (let ((failures-for-build-id
-                                  (or (hash-ref result build-id)
-                                      '())))
-                             (hash-set!
-                              result
-                              build-id
-                              (cons `((id  . ,id)
-                                      (agent-id . ,agent-id)
-                                      (failure-reason . ,failure-reason))
-                                    failures-for-build-id)))))
-                        result)
-                      (make-hash-table)
-                      statement)))
-         (sqlite-reset statement)
+          (when agent-id
+            (sqlite-bind-arguments
+             statement
+             #:agent_id agent-id))
+
+          (let ((result (sqlite-fold
+                         (lambda (row result)
+                           (match row
+                             (#(id build-id agent-id failure-reason)
+                              (let ((failures-for-build-id
+                                     (or (hash-ref result build-id)
+                                         '())))
+                                (hash-set!
+                                 result
+                                 build-id
+                                 (cons `((id  . ,id)
+                                         (agent-id . ,agent-id)
+                                         (failure-reason . ,failure-reason))
+                                       failures-for-build-id)))))
+                           result)
+                         (make-hash-table)
+                         statement)))
+            (sqlite-reset statement)
 
-         result)))))
+            result)))))
+   args))
 
 (define-method (datastore-list-processed-builds
                 (datastore <sqlite-datastore>))
diff --git a/scripts/guix-build-coordinator.in b/scripts/guix-build-coordinator.in
index 62b48e2..10970d7 100644
--- a/scripts/guix-build-coordinator.in
+++ b/scripts/guix-build-coordinator.in
@@ -156,6 +156,17 @@
     (ensure-all-related-derivation-outputs-have-builds . #f)
     (tags                                              . ())))
 
+(define %setup-failure-options
+  (list
+   (option '("agent-id") #t #f
+           (lambda (opt name arg result)
+             (alist-cons 'agent-id
+                         arg
+                         (alist-delete 'agent-id result))))))
+
+(define %setup-failure-option-defaults
+  `((agent-id . #f)))
+
 (define %common-build-filtering-options
   (list
    (option '("tag") #t #f
@@ -988,6 +999,33 @@ tags:
                 (assoc-ref
                  (request-agents-list (assq-ref opts 'coordinator))
                  "agents")))))
+  (("setup-failures" "list" rest ...)
+   (let ((opts (parse-options (append %client-options
+                                      %base-options
+                                      %setup-failure-options)
+                              (append %client-option-defaults
+                                      %base-option-defaults
+                                      %setup-failure-option-defaults)
+                              rest)))
+     (for-each
+      (match-lambda
+        ((build-id . setup-failures)
+         (for-each
+          (lambda (setup-failure)
+            (simple-format #t "~A:\n"
+                           (assoc-ref setup-failure "id"))
+            (simple-format #t "  build-id: ~A\n"
+                           build-id)
+            (simple-format #t "  agent-id: ~A\n"
+                           (assoc-ref setup-failure "agent-id"))
+            (simple-format #t "  failure-reason: ~A\n"
+                           (assoc-ref setup-failure "failure-reason"))
+            (newline))
+          (vector->list setup-failures))))
+      (assoc-ref
+       (request-setup-failures (assq-ref opts 'coordinator)
+                               #:agent-id (assq-ref opts 'agent-id))
+       "setup_failures"))))
   (("dynamic-auth" "create-token")
    (let ((opts (parse-options (append %client-options
                                       %base-options)
-- 
cgit v1.2.3