2 files changed, 120 insertions, 0 deletions
diff --git a/guix-data-service/web/build/controller.scm b/guix-data-service/web/build/controller.scm
new file mode 100644
index 0000000..413f381
--- /dev/null
+++ b/guix-data-service/web/build/controller.scm
@@ -0,0 +1,40 @@
+;;; Guix Data Service -- Information about Guix over time
+;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
+;;;
+;;; 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 (guix-data-service web build controller)
+  #:use-module (ice-9 match)
+  #:use-module (guix-data-service web render)
+  #:use-module (guix-data-service web query-parameters)
+  #:use-module (guix-data-service model build)
+  #:use-module (guix-data-service web build html)
+  #:export (build-controller))
+
+(define (build-controller request
+                          method-and-path-components
+                          mime-types
+                          body
+                          conn)
+  (match method-and-path-components
+    (('GET "builds")
+     (render-builds mime-types
+                    conn))
+    (_ #f)))
+
+(define (render-builds mime-types conn)
+  (render-html
+   #:sxml (view-builds (select-build-stats conn)
+                       (select-builds-with-context conn))))
diff --git a/guix-data-service/web/build/html.scm b/guix-data-service/web/build/html.scm
new file mode 100644
index 0000000..61382aa
--- /dev/null
+++ b/guix-data-service/web/build/html.scm
@@ -0,0 +1,80 @@
+;;; Guix Data Service -- Information about Guix over time
+;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
+;;;
+;;; 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 (guix-data-service web build html)
+  #:use-module (ice-9 match)
+  #:use-module (guix-data-service web query-parameters)
+  #:use-module (guix-data-service web view html)
+  #:export (view-builds))
+
+(define (view-builds stats builds)
+  (layout
+   #:body
+   `(,(header)
+     (div
+      (@ (class "container"))
+      (div
+       (@ (class "row"))
+       (div
+        (@ (class "col-sm-12"))
+        (h1 "Builds")
+        (table
+         (@ (class "table"))
+         (thead
+          (tr
+           (th (@ (class "col-md-2")) "Status")
+           (th (@ (class "col-md-2")) "Count")))
+         (tbody
+          ,@(map
+             (match-lambda
+               ((status count)
+                `(tr
+                  (td ,(build-status-span status))
+                  (td ,count))))
+             stats)))))
+      (div
+       (@ (class "row"))
+       (div
+        (@ (class "col-sm-12"))
+        (table
+         (@ (class "table"))
+         (thead
+          (tr
+           (th (@ (class "col-xs-2")) "Status")
+           (th (@ (class "col-xs-9")) "Derivation")
+           (th (@ (class "col-xs-1")) "Started at")
+           (th (@ (class "col-xs-1")) "Finished at")
+           (th (@ (class "col-xs-1")) "")))
+         (tbody
+          ,@(map
+             (match-lambda
+               ((build-id build-server-url derivation-file-name
+                          timestamp status)
+                `(tr
+                  (td (@ (class "text-center"))
+                      ,(build-status-span status))
+                  (td (a (@ (href ,derivation-file-name))
+                         ,(display-store-item-short derivation-file-name)))
+                  (td ,timestamp)
+                  (td (a (@ (href ,(simple-format
+                                    #f "~Abuild/~A"
+                                    build-server-url
+                                    (string-drop
+                                     derivation-file-name
+                                     (string-length "/gnu/store/")))))
+                         "View build on " ,build-server-url)))))
+             builds)))))))))