Add a build servers page

3 files changed, 38 insertions, 0 deletions

diff --git a/guix-data-service/web/build-server/controller.scm b/guix-data-service/web/build-server/controller.scm
index 29f8b7a..c9db9a0 100644
--- a/guix-data-service/web/build-server/controller.scm
+++ b/guix-data-service/web/build-server/controller.scm
@@ -78,6 +78,12 @@
                      "No build found for this build server and derivation.")
              #:code 404)))))
 
+(define (render-build-servers mime-types
+                              build-servers)
+  (render-html
+   #:sxml
+   (view-build-servers build-servers)))
+
 (define (render-build-server mime-types
                              build-server)
   (render-html
@@ -191,6 +197,10 @@
                                  conn
                                  secret-key-base)
   (match method-and-path-components
+    (('GET "build-servers")
+     (let ((build-servers (select-build-servers conn)))
+       (render-build-servers mime-types
+                             build-servers)))
     (('GET "build-server" build-server-id)
      (let ((build-server (select-build-server conn (string->number
                                                     build-server-id))))
diff --git a/guix-data-service/web/build-server/html.scm b/guix-data-service/web/build-server/html.scm
index 6936e79..bb15e11 100644
--- a/guix-data-service/web/build-server/html.scm
+++ b/guix-data-service/web/build-server/html.scm
@@ -20,6 +20,7 @@
   #:use-module (guix-data-service web view html)
   #:use-module (guix-data-service web html-utils)
   #:export (view-build
+            view-build-servers
             view-build-server
             view-signing-key))
 
@@ -89,6 +90,31 @@
                          required-failed-builds))))))
             '())))))
 
+(define (view-build-servers build-servers)
+  (layout
+   #:body
+   `(,(header)
+     (div
+      (@ (class "container"))
+      (div
+       (@ (class "row"))
+       (div
+        (@ (class "col-sm-12"))
+        (h2 "Build servers")
+        ,@(map
+           (match-lambda
+             ((id url lookup-all-derivations?)
+              `(dl
+                (@ (class "dl-horizontal"))
+                (dt "URL")
+                (dd (a (@ (href ,url))
+                       ,url))
+                (dt "Lookup all " (br) "derivations?")
+                (dd ,(if lookup-all-derivations?
+                         "Yes"
+                         "No")))))
+           build-servers)))))))
+
 (define (view-build-server build-server)
   (layout
    #:body
diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm
index 1eb4f20..f8903c9 100644
--- a/guix-data-service/web/controller.scm
+++ b/guix-data-service/web/controller.scm
@@ -315,6 +315,8 @@
          (not-found (request-uri request))))
     (('GET "gnu" "store" filename "narinfos")
      (render-narinfos conn filename))
+    (('GET "build-servers")
+     (delegate-to-with-secret-key-base build-server-controller))
     (((or 'GET 'POST) "build-server" _ ...)
      (delegate-to-with-secret-key-base build-server-controller))
     (('GET "compare" _ ...)             (delegate-to compare-controller))