From f05283b2ce6d80fd19efd998597eac01fc4f0508 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Sun, 15 Dec 2019 10:33:45 +0000
Subject: Add a page for each build

---
 guix-data-service/model/build.scm                 |  1 +
 guix-data-service/web/build-server/controller.scm | 35 ++++++++++++++++
 guix-data-service/web/build-server/html.scm       | 50 ++++++++++++++++++++++-
 3 files changed, 85 insertions(+), 1 deletion(-)

diff --git a/guix-data-service/model/build.scm b/guix-data-service/model/build.scm
index 6670246..44fdc94 100644
--- a/guix-data-service/model/build.scm
+++ b/guix-data-service/model/build.scm
@@ -1,6 +1,7 @@
 (define-module (guix-data-service model build)
   #:use-module (ice-9 match)
   #:use-module (squee)
+  #:use-module (json)
   #:use-module (guix-data-service model utils)
   #:export (select-build-stats
             select-builds-with-context
diff --git a/guix-data-service/web/build-server/controller.scm b/guix-data-service/web/build-server/controller.scm
index 4ac84dd..accadd2 100644
--- a/guix-data-service/web/build-server/controller.scm
+++ b/guix-data-service/web/build-server/controller.scm
@@ -32,6 +32,32 @@
   #:use-module (guix-data-service web build-server html)
   #:export (build-server-controller))
 
+(define (render-build mime-types
+                      conn
+                      build-server-id
+                      query-parameters)
+  (if (any-invalid-query-parameters? query-parameters)
+      (case (most-appropriate-mime-type
+             '(application/json text/html)
+             mime-types)
+        ((application/json)
+         (render-json
+          `((error . "invalid query"))))
+        (else
+         (render-html
+          #:sxml (view-build query-parameters))))
+      (let* ((derivation-file-name
+              (assq-ref query-parameters 'derivation_file_name))
+             (build
+              (select-build-by-build-server-and-derivation-file-name
+               conn
+               build-server-id
+               derivation-file-name)))
+        (render-html
+         #:sxml
+         (view-build query-parameters
+                     build)))))
+
 (define (handle-build-event-submission parsed-query-parameters
                                        build-server-id-string
                                        body
@@ -139,6 +165,15 @@
                                  conn
                                  secret-key-base)
   (match method-and-path-components
+    (('GET "build-server" build-server-id "build")
+     (let ((parsed-query-parameters
+            (parse-query-parameters
+             request
+             `((derivation_file_name ,identity #:required)))))
+       (render-build mime-types
+                     conn
+                     (string->number build-server-id)
+                     parsed-query-parameters)))
     (('POST "build-server" build-server-id "build-events")
      (let ((parsed-query-parameters
             (parse-query-parameters
diff --git a/guix-data-service/web/build-server/html.scm b/guix-data-service/web/build-server/html.scm
index 9bb70eb..7a94315 100644
--- a/guix-data-service/web/build-server/html.scm
+++ b/guix-data-service/web/build-server/html.scm
@@ -16,9 +16,57 @@
 ;;; <http://www.gnu.org/licenses/>.
 
 (define-module (guix-data-service web build-server html)
+  #:use-module (ice-9 match)
   #:use-module (guix-data-service web view html)
   #:use-module (guix-data-service web html-utils)
-  #:export (view-signing-key))
+  #:export (view-build
+            view-signing-key))
+
+(define (view-build query-parameters
+                    build)
+  (define derivation
+    (assq-ref query-parameters 'derivation_file_name))
+
+  (peek build)
+  (layout
+   #:body
+   `(,(header)
+     (div
+      (@ (class "container"))
+      (div
+       (@ (class "row"))
+       (div
+        (@ (class "col-sm-12"))
+        (h1 "Build")))
+      (div
+       (@ (class "row"))
+       ,@(match build
+           ((url statuses)
+            `((div
+               (@ (class "col-sm-6"))
+               (dl
+                (@ (class "dl-horizontal"))
+                (dt "Derivation")
+                (dd ,(display-possible-store-item derivation))
+                (dt "Build server URL")
+                (dd (a (@ (href ,url))
+                       ,url))))
+              (div
+               (@ (class "col-sm-6"))
+               (h3 "Timeline")
+               (table
+                (@ (class "table"))
+                (thead
+                 (tr
+                  (th "Timestamp")
+                  (th "Status")))
+                (tbody
+                 ,@(map (lambda (status)
+                          `(tr
+                            (td ,(assoc-ref status "timestamp"))
+                            (td ,(build-status-span
+                                  (assoc-ref status "status")))))
+                        (vector->list statuses)))))))))))))
 
 (define (view-signing-key sexp)
   (layout
-- 
cgit v1.2.3