Add html pages for build allocation plans.

* bffe/server.scm (make-controller): Add a case for
  "agent/build-allocation-plan".
* bffe/view/agent.scm (build-allocation-plan, allocation->sxml,
  tags->sxml, tag->sxml): New functions.

2 files changed, 100 insertions, 28 deletions

diff --git a/bffe/server.scm b/bffe/server.scm
index 053ad8d..9662d40 100644
--- a/bffe/server.scm
+++ b/bffe/server.scm
@@ -1,6 +1,7 @@
 ;;; Build Farm Front-End
 ;;;
 ;;; Copyright © 2023 Christopher Baines <mail@cbaines.net>
+;;; Copyright © 2025 Andreas Enge <andreas@enge.fr>
 ;;;
 ;;; This program is free software: you can redistribute it and/or
 ;;; modify it under the terms of the GNU Affero General Public License
@@ -528,9 +529,16 @@
                 (string-append event-source "/agent/" agent-id
                                "/build-allocation-plan"))
                #:headers '((accept . ((application/json)))))))
-         (render-json
-          (json->scm body))))
-
+         (case (most-appropriate-mime-type
+                mime-types
+                '(application/json text/html))
+           ((application/json)
+            (render-json
+             (json->scm body)))
+           (else
+            (render-html
+             (build-allocation-plan title agent-id
+                    (json->scm body)))))))
       (('GET "assets" rest ...)
        (or (handle-static-assets (string-join rest "/")
                                  (request-headers request))
diff --git a/bffe/view/agent.scm b/bffe/view/agent.scm
index 1de2f71..a7ac640 100644
--- a/bffe/view/agent.scm
+++ b/bffe/view/agent.scm
@@ -1,7 +1,27 @@
+;;; Build Farm Front-End
+;;;
+;;; Copyright © 2023 Christopher Baines <mail@cbaines.net>
+;;; Copyright © 2025 Andreas Enge <andreas@enge.fr>
+;;;
+;;; This program is free software: you can redistribute it and/or
+;;; modify it under the terms of the GNU Affero General Public License
+;;; as published by the Free Software Foundation, either version 3 of
+;;; the License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Affero General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Affero General Public
+;;; License along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
 (define-module (bffe view agent)
   #:use-module (srfi srfi-1)
   #:use-module (bffe view util)
-  #:export (agent))
+  #:export (agent
+            build-allocation-plan))
 
 (define (agent title agent-details)
   (layout
@@ -9,29 +29,73 @@
                           (assoc-ref agent-details "id")
                           " — " title)
    #:body
-   `((main
-      (dl
-       (dt "Description")
-       (dd ,(assoc-ref agent-details "description"))
+   (let* ((agent-id (assoc-ref agent-details "id"))
+          (build-allocation-plan (string-append "/agent/" agent-id
+                                                "/build-allocation-plan")))
+     `((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"))))))
+        (a  (@ (href ,build-allocation-plan)) "Build allocation plan"))))))
+
+
+(define (tag->sxml tag)
+  `(li ,(assoc-ref tag "key")
+       ": "
+       ,(assoc-ref tag "value")))
 
-       (dt "Tags")
-       (dd (ul
-            ,@(map (lambda (tag)
-                     `(li ,(assoc-ref tag "key") ": "
-                          ,(assoc-ref tag "value")))
-                   (vector->list
-                    (assoc-ref agent-details "tags")))))
+(define (tags->sxml tags)
+  `("Tags"
+    (ul
+      ,(map
+        tag->sxml
+        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"))))))))))
+(define (allocation->sxml alloc)
+  (let ((tags (vector->list (assoc-ref alloc "tags"))))
+    `(li (code ,(assoc-ref alloc "uuid"))
+           " "
+           ,(assoc-ref alloc "derivation_name")
+           (br)
+         ,(assoc-ref alloc "system")
+           ", derived priority: "
+           ,(assoc-ref alloc "derived_priority")
+           (br)
+         ,(tags->sxml tags)
+                       )))
+
+(define (build-allocation-plan title agent-id contents)
+  (layout
+   #:title (string-append "Build allocation plan " agent-id
+                          " — " title)
+   #:body
+   (let ((build-allocation-plan
+          (vector->list (assoc-ref contents "build_allocation_plan"))))
+     `((main
+        (div
+          (ol
+            ,(map
+              allocation->sxml
+              build-allocation-plan))))))))