From 6e73bc321c16eb141797c04ef941806481c8ae71 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Sun, 30 Apr 2023 18:54:35 +0200
Subject: Add basic pages for builds and agents

---
 bffe/server.scm     | 44 ++++++++++++++++++++++++++++++++------------
 bffe/view/agent.scm | 41 +++++++++++++++++++++++++++++++++++++++++
 bffe/view/build.scm | 51 +++++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 124 insertions(+), 12 deletions(-)
 create mode 100644 bffe/view/agent.scm
 create mode 100644 bffe/view/build.scm

(limited to 'bffe')

diff --git a/bffe/server.scm b/bffe/server.scm
index cf1fa30..4c24559 100644
--- a/bffe/server.scm
+++ b/bffe/server.scm
@@ -42,7 +42,7 @@
   #:use-module (fibers channels)
   #:use-module (fibers conditions)
   #:use-module (fibers web server)
-  #:use-module (guix store)
+  #:use-module ((guix store) #:select (%store-prefix))
   #:use-module ((guix build utils) #:select (dump-port))
   #:use-module (guix-data-service web util)
   #:use-module ((guix-build-coordinator utils)
@@ -53,6 +53,8 @@
   #:use-module (guix-build-coordinator client-communication)
   #:use-module (bffe view util)
   #:use-module (bffe view home)
+  #:use-module (bffe view build)
+  #:use-module (bffe view agent)
   #:use-module (bffe view activity)
   #:export (start-bffe-web-server))
 
@@ -436,28 +438,46 @@
               body
               (http-get
                (string->uri
-                (string-append event-source "/build/" uuid)))))
-         (render-json
-          (json-string->scm
-           (utf8->string body)))))
+                (string-append event-source "/build/" uuid
+                               ;; ".json"
+                               )))))
+         (case (most-appropriate-mime-type
+                '(application/json text/html)
+                mime-types)
+           ((application/json)
+            (render-json
+             (json-string->scm
+              (utf8->string body))))
+           (else
+            (render-html
+             #:sxml (build title
+                           (json-string->scm
+                            (utf8->string body))))))))
       (('GET "agent" agent-id)
        (let ((response
               body
               (http-get
                (string->uri
                 (string-append event-source "/agent/" agent-id)))))
-         (render-json
-          (json-string->scm
-           (utf8->string body)))))
-      (('GET "agent" agent-id (or "build-allocation-plan"
-                                  ;; TODO Remove underscore variant
-                                  "build_allocation_plan"))
+         (case (most-appropriate-mime-type
+                '(application/json text/html)
+                mime-types)
+           ((application/json)
+            (render-json
+             (json-string->scm
+              (utf8->string body))))
+           (else
+            (render-html
+             #:sxml (agent title
+                           (json-string->scm
+                            (utf8->string body))))))))
+      (('GET "agent" agent-id "build-allocation-plan")
        (let ((response
               body
               (http-get
                (string->uri
                 (string-append event-source "/agent/" agent-id
-                               "/build_allocation_plan")))))
+                               "/build-allocation-plan")))))
          (render-json
           (json-string->scm
            (utf8->string body)))))
diff --git a/bffe/view/agent.scm b/bffe/view/agent.scm
new file mode 100644
index 0000000..e210402
--- /dev/null
+++ b/bffe/view/agent.scm
@@ -0,0 +1,41 @@
+(define-module (bffe view agent)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-19)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
+  #:use-module (bffe view util)
+  #:use-module ((guix store) #:select (%store-prefix))
+  #:export (agent))
+
+(define (agent title agent-details)
+  (layout
+   #:title (string-append "Agent "
+                          (assoc-ref agent-details "id")
+                          " — " title)
+   #:body
+   `((main
+      (dl
+       (dt "Description")
+       (dd ,(assoc-ref agent-details "description"))
+
+       (dt "Tags")
+       (dd (ul
+            ,@(map (lambda (tag)
+                     `(li ,(assoc-ref tag "key") ": "
+                          ,(assoc-ref tag "value")))
+                   (vector->list
+                    (assoc-ref agent-details "tags")))))
+
+       (dt "Allocated builds")
+       (dl (ul
+            ,@(map (lambda (build)
+                     `(li
+                       (a (@ (href
+                              ,(string-append "/build/"
+                                              (assoc-ref build "uuid"))))
+                          ,(assoc-ref build "derivation_name")
+                          " (derived priority: "
+                          ,(assoc-ref build "derived_priority")
+                          ")")))
+                   (vector->list
+                    (assoc-ref agent-details "allocated_builds"))))))))))
diff --git a/bffe/view/build.scm b/bffe/view/build.scm
new file mode 100644
index 0000000..be33467
--- /dev/null
+++ b/bffe/view/build.scm
@@ -0,0 +1,51 @@
+(define-module (bffe view build)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-19)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
+  #:use-module (bffe view util)
+  #:use-module ((guix store) #:select (%store-prefix))
+  #:export (build))
+
+(define (build title build-details)
+  (layout
+   #:title (string-append
+            "Build " (assoc-ref build-details "uuid") " — " title)
+   #:body
+   `((main
+      (dl
+       (dt "Derivation")
+       (dd ,(assoc-ref build-details "derivation-name"))
+
+       (dt "Tags")
+       (dd (ul
+            ,@(map (lambda (tag)
+                     `(li ,(assoc-ref tag "key") ": "
+                          ,(assoc-ref tag "value")))
+                   (vector->list
+                    (assoc-ref build-details "tags")))))
+
+       (dt "Submitted at")
+       (dd ,(assoc-ref build-details "created-at"))
+
+       (dt "State")
+       (dd ,(if (assoc-ref build-details "cancelled")
+                "Canceled"
+                (if (assoc-ref build-details "processed")
+                    (if (string=? (assoc-ref
+                                   (assoc-ref build-details "result")
+                                   "result")
+                                  "success")
+                        "Succeeded"
+                        "Failed")
+                    "Pending")))
+
+       (dt "Priority")
+       (dd ,(assoc-ref build-details "priority")))
+
+      ,@(if (assoc-ref build-details "processed")
+            `((a (@ (href ,(string-append "/build/"
+                                          (assoc-ref build-details "uuid")
+                                          "/log")))
+                 "View build log"))
+            '())))))
-- 
cgit v1.2.3