Add a web interface.

* Makefile.am (dist_sql_DATA): Add static files.
* src/cuirass/database.scm (assqx-ref): Export it.
(db-get-builds): Add 'evaluation' filter and filters for pagination.
(db-get-evaluations-build-summary, db-get-evaluations-id-min,
db-get-evaluations-id-max, db-get-builds-min, db-get-builds-max): New exported
procedures.
* src/cuirass/http.scm (%static-directory): New parameter.
(%page-size, %file-mime-types, %file-white-list): New variables.
(handle-build-request, handle-builds-request): Move the WITH-CRITICAL-SECTION
call out.
(url-handler): Add RESPOND-HTML, RESPOND-STATIC-FILE and RESPOND-NOT-FOUND
procedures.  Call WITH-CRITICAL-SECTION sooner for the '/build',
'/api/latestbuilds' and '/api/queue' routes.  Add '/', '/jobset/<name>',
'/eval/<id>', '/static/<path>' routes.  Use RESPOND-NOT-FOUND when the route
isn't found.
* src/cuirass/templates.scm: New file.
(html-page, specifications-table, evaluation-info-table,
build-eval-table): New exported procedures.
(pagination): New procedure.

Signed-off-by: Clément Lassieur <clement@lassieur.org>

4 files changed, 505 insertions, 69 deletions

diff --git a/Makefile.am b/Makefile.am
index 4f6c089..ac22601 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -4,6 +4,7 @@
 # Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
 # Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
 # Copyright © 2018 Clément Lassieur <clement@lassieur.org>
+# Copyright © 2018 Tatiana Sholokhova <tanja201396@gmail.com>
 #
 # This file is part of Cuirass.
 #
@@ -34,6 +35,10 @@ pkgobjectdir = $(guileobjectdir)/$(PACKAGE)
 webmoduledir = $(guilesitedir)/web/server
 webobjectdir = $(guileobjectdir)/web/server
 sqldir = $(pkgdatadir)/sql
+staticdir = $(pkgdatadir)/static
+cssdir = $(staticdir)/css
+fontsdir = $(staticdir)/fonts
+imagesdir = $(staticdir)/images
 
 dist_pkgmodule_DATA =				\
   src/cuirass/base.scm				\
@@ -41,7 +46,8 @@ dist_pkgmodule_DATA =				\
   src/cuirass/http.scm				\
   src/cuirass/logging.scm			\
   src/cuirass/ui.scm				\
-  src/cuirass/utils.scm
+  src/cuirass/utils.scm             \
+  src/cuirass/templates.scm
 
 nodist_pkgmodule_DATA = \
   src/cuirass/config.scm
@@ -61,6 +67,18 @@ dist_pkgdata_DATA = src/schema.sql
 dist_sql_DATA = 				\
   src/sql/upgrade-1.sql
 
+dist_css_DATA =					\
+  src/static/css/bootstrap.css			\
+  src/static/css/open-iconic-bootstrap.css
+dist_fonts_DATA =				\
+  src/static/fonts/open-iconic.eot		\
+  src/static/fonts/open-iconic.otf		\
+  src/static/fonts/open-iconic.svg		\
+  src/static/fonts/open-iconic.ttf		\
+  src/static/fonts/open-iconic.woff
+dist_images_DATA =				\
+  src/static/images/logo.png
+
 TEST_EXTENSIONS = .scm .sh
 AM_TESTS_ENVIRONMENT = \
   env GUILE_AUTO_COMPILE='0' \
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index df41d75..9b442c1 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
+;;; Copyright © 2018 Tatiana Sholokhova <tanja201396@gmail.com>
 ;;;
 ;;; This file is part of Cuirass.
 ;;;
@@ -48,10 +49,16 @@
             db-update-build-status!
             db-get-build
             db-get-builds
+            db-get-builds-min
+            db-get-builds-max
             db-get-evaluations
+            db-get-evaluations-build-summary
+            db-get-evaluations-id-min
+            db-get-evaluations-id-max
             read-sql-file
             read-quoted-string
             sqlite-exec
+            assqx-ref
             ;; Parameters.
             %package-database
             %package-schema-file
@@ -454,20 +461,20 @@ log file for DRV."
        (#:repo-name  . ,repo-name)
        (#:outputs    . ,(db-get-outputs db id))))))
 
+;; XXX Change caller and remove
+(define (assqx-ref filters key)
+  (match filters
+    (()
+     #f)
+    (((xkey xvalue) rest ...)
+     (if (eq? key xkey)
+         xvalue
+         (assqx-ref rest key)))))
+
 (define (db-get-builds db filters)
   "Retrieve all builds in database DB which are matched by given FILTERS.
-FILTERS is an assoc list which possible keys are 'jobset | 'job | 'system |
-'nr | 'order | 'status."
-
-  ;; XXX Change caller and remove
-  (define (assqx-ref filters key)
-    (match filters
-      (()
-       #f)
-      (((xkey xvalue) rest ...)
-       (if (eq? key xkey)
-           xvalue
-           (assqx-ref rest key)))))
+FILTERS is an assoc list whose possible keys are 'id | 'jobset | 'job |
+'system | 'nr | 'order | 'status | 'evaluation."
 
   (define (format-output name path)
     `(,name . ((#:path . ,path))))
@@ -540,41 +547,57 @@ Assumes that if group id stays the same the group headers stay the same."
          (collect-outputs x-builds-id x-repeated-row '() rows)))))
 
   (let* ((order (match (assq 'order filters)
-                  (('order 'build-id) "Builds.id ASC")
-                  (('order 'decreasing-build-id) "Builds.id DESC")
-                  (('order 'finish-time) "Builds.stoptime DESC")
-                  (('order 'start-time) "Builds.starttime DESC")
-                  (('order 'submission-time) "Builds.timestamp DESC")
+                  (('order 'build-id) "id ASC")
+                  (('order 'decreasing-build-id) "id DESC")
+                  (('order 'finish-time) "stoptime DESC")
+                  (('order 'finish-time+build-id) "stoptime DESC, id DESC")
+                  (('order 'start-time) "starttime DESC")
+                  (('order 'submission-time) "timestamp DESC")
                   (('order 'status+submission-time)
                    ;; With this order, builds in 'running' state (-1) appear
                    ;; before those in 'scheduled' state (-2).
-                   "Builds.status DESC, Builds.timestamp DESC")
-                  (_ "Builds.id DESC")))
-         (stmt-text (format #f "\
-SELECT Builds.id, Outputs.name, Outputs.path, Builds.timestamp, Builds.starttime, Builds.stoptime, Builds.log, Builds.status, Builds.derivation,\
-Derivations.job_name, Derivations.system, Derivations.nix_name,\
-Specifications.name \
-FROM Builds \
-INNER JOIN Derivations ON Builds.derivation = Derivations.derivation AND Builds.evaluation = Derivations.evaluation \
-INNER JOIN Evaluations ON Derivations.evaluation = Evaluations.id \
-INNER JOIN Specifications ON Evaluations.specification = Specifications.name \
-LEFT JOIN Outputs ON Outputs.build = Builds.id \
-WHERE (:id IS NULL OR (:id = Builds.id)) \
-AND (:jobset IS NULL OR (:jobset = Specifications.name)) \
-AND (:job IS NULL OR (:job = Derivations.job_name)) \
-AND (:system IS NULL OR (:system = Derivations.system)) \
-AND (:status IS NULL OR (:status = 'done' AND Builds.status >= 0) OR (:status = 'pending' AND Builds.status < 0)) \
-ORDER BY ~a, Builds.id ASC LIMIT :nr;" order))
+                   "status DESC, timestamp DESC")
+                  (_ "id DESC")))
+         (stmt-text (format #f "SELECT * FROM (
+SELECT Builds.id, Outputs.name, Outputs.path, Builds.timestamp,
+Builds.starttime, Builds.stoptime, Builds.log, Builds.status,
+Builds.derivation, Derivations.job_name, Derivations.system,
+Derivations.nix_name,Specifications.name
+FROM Builds
+INNER JOIN Derivations ON Builds.derivation = Derivations.derivation
+AND Builds.evaluation = Derivations.evaluation
+INNER JOIN Evaluations ON Derivations.evaluation = Evaluations.id
+INNER JOIN Specifications ON Evaluations.specification = Specifications.name
+LEFT JOIN Outputs ON Outputs.build = Builds.id
+WHERE (:id IS NULL OR (:id = Builds.id))
+AND (:jobset IS NULL OR (:jobset = Specifications.name))
+AND (:job IS NULL OR (:job = Derivations.job_name))
+AND (:system IS NULL OR (:system = Derivations.system))
+AND (:evaluation IS NULL OR (:evaluation = Builds.evaluation))
+AND (:status IS NULL OR (:status = 'done' AND Builds.status >= 0) OR (:status = 'pending' AND Builds.status < 0))
+AND (:borderlowtime IS NULL OR :borderlowid IS NULL OR ((:borderlowtime, :borderlowid) < (Builds.stoptime, Builds.id)))
+AND (:borderhightime IS NULL OR :borderhighid IS NULL OR ((:borderhightime, :borderhighid) > (Builds.stoptime, Builds.id)))
+ORDER BY
+CASE WHEN :borderlowtime IS NULL OR :borderlowid IS NULL THEN Builds.stoptime ELSE -Builds.stoptime END DESC,
+CASE WHEN :borderlowtime IS NULL OR :borderlowid IS NULL THEN Builds.id ELSE -Builds.id END DESC
+LIMIT :nr)
+ORDER BY ~a, id ASC;" order))
          (stmt (sqlite-prepare db stmt-text #:cache? #t)))
-    (sqlite-bind-arguments stmt #:id (assqx-ref filters 'id)
-                           #:jobset (assqx-ref filters 'jobset)
-                           #:job (assqx-ref filters 'job)
-                           #:system (assqx-ref filters 'system)
-                           #:status (and=> (assqx-ref filters 'status)
-                                           object->string)
-                           #:nr (match (assqx-ref filters 'nr)
-                                  (#f -1)
-                                  (x x)))
+    (sqlite-bind-arguments
+     stmt
+     #:id (assqx-ref filters 'id)
+     #:jobset (assqx-ref filters 'jobset)
+     #:job (assqx-ref filters 'job)
+     #:evaluation (assqx-ref filters 'evaluation)
+     #:system (assqx-ref filters 'system)
+     #:status (and=> (assqx-ref filters 'status) object->string)
+     #:borderlowid (assqx-ref filters 'border-low-id)
+     #:borderhighid (assqx-ref filters 'border-high-id)
+     #:borderlowtime (assqx-ref filters 'border-low-time)
+     #:borderhightime (assqx-ref filters 'border-high-time)
+     #:nr (match (assqx-ref filters 'nr)
+            (#f -1)
+            (x x)))
     (sqlite-reset stmt)
     (group-outputs (sqlite-fold-right cons '() stmt))))
 
@@ -631,3 +654,68 @@ FROM Evaluations ORDER BY id DESC LIMIT " limit ";"))
                      (#:specification . ,specification)
                      (#:commits . ,(string-tokenize commits)))
                    evaluations))))))
+
+(define (db-get-evaluations-build-summary db spec limit border-low border-high)
+  (let loop ((rows (sqlite-exec db "
+SELECT E.id, E.commits, B.succeeded, B.failed, B.scheduled
+FROM (SELECT id, evaluation, SUM(status=0) as succeeded,
+SUM(status>0) as failed, SUM(status<0) as scheduled
+FROM Builds
+GROUP BY evaluation) B
+JOIN
+(SELECT id, commits
+FROM Evaluations
+WHERE (specification=" spec ")
+AND (" border-low "IS NULL OR (id >" border-low "))
+AND (" border-high "IS NULL OR (id <" border-high "))
+ORDER BY CASE WHEN " border-low "IS NULL THEN id ELSE -id END DESC
+LIMIT " limit ") E
+ON B.evaluation=E.id
+ORDER BY E.id ASC;"))
+             (evaluations '()))
+    (match rows
+      (() evaluations)
+      ((#(id commits succeeded failed scheduled) . rest)
+       (loop rest
+             (cons `((#:id . ,id)
+                     (#:commits . ,commits)
+                     (#:succeeded . ,succeeded)
+                     (#:failed . ,failed)
+                     (#:scheduled . ,scheduled))
+                   evaluations))))))
+
+(define (db-get-evaluations-id-min db spec)
+  "Return the min id of evaluations for the given specification SPEC."
+  (let ((rows (sqlite-exec db "
+SELECT MIN(id) FROM Evaluations
+WHERE specification=" spec)))
+    (vector-ref (car rows) 0)))
+
+(define (db-get-evaluations-id-max db spec)
+  "Return the max id of evaluations for the given specification SPEC."
+  (let ((rows (sqlite-exec db "
+SELECT MAX(id) FROM Evaluations
+WHERE specification=" spec)))
+    (vector-ref (car rows) 0)))
+
+(define (db-get-builds-min db eval)
+  "Return the min build (stoptime, id) pair for
+   the given evaluation EVAL."
+  (let ((rows (sqlite-exec db "
+SELECT stoptime, MIN(id) FROM
+(SELECT id, stoptime FROM Builds
+WHERE evaluation=" eval " AND
+stoptime = (SELECT MIN(stoptime)
+FROM Builds WHERE evaluation=" eval "))")))
+    (vector->list (car rows))))
+
+(define (db-get-builds-max db eval)
+  "Return the max build (stoptime, id) pair for
+   the given evaluation EVAL."
+  (let ((rows (sqlite-exec db "
+SELECT stoptime, MAX(id) FROM
+(SELECT id, stoptime FROM Builds
+WHERE evaluation=" eval " AND
+stoptime = (SELECT MAX(stoptime)
+FROM Builds WHERE evaluation=" eval "))")))
+    (vector->list (car rows))))
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index a45e6b1..5a5eb52 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
+;;; Copyright © 2018 Tatiana Sholokhova <tanja201396@gmail.com>
 ;;;
 ;;; This file is part of Cuirass.
 ;;;
@@ -20,11 +21,14 @@
 ;;; along with Cuirass.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (cuirass http)
+  #:use-module (cuirass config)
   #:use-module (cuirass database)
   #:use-module (cuirass utils)
   #:use-module (cuirass logging)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
+  #:use-module (ice-9 binary-ports)
   #:use-module (ice-9 match)
   #:use-module (json)
   #:use-module (web request)
@@ -33,8 +37,37 @@
   #:use-module (web uri)
   #:use-module (fibers)
   #:use-module (fibers channels)
+  #:use-module (sxml simple)
+  #:use-module (cuirass templates)
+  #:use-module (guix utils)
+  #:use-module (guix build union)
   #:export (run-cuirass-server))
 
+(define %static-directory
+  ;; Define to the static file directory.
+  (make-parameter (string-append
+                   (or (getenv "CUIRASS_DATADIR")
+                       (string-append %datadir "/" %package))
+                   "/static")))
+
+(define %page-size 10)
+
+(define %file-mime-types
+  '(("css" . (text/css))
+    ("otf" . (font/otf))
+    ("woff" . (font/woff))
+    ("js"  . (text/javascript))
+    ("png" . (image/png))
+    ("gif" . (image/gif))
+    ("html" . (text/html))))
+
+(define %file-white-list
+  '("css/bootstrap.css"
+    "css/open-iconic-bootstrap.css"
+    "fonts/open-iconic.otf"
+    "fonts/open-iconic.woff"
+    "images/logo.png"))
+
 (define (build->hydra-build build)
   "Convert BUILD to an assoc list matching hydra API format."
   (define (bool->int bool)
@@ -70,19 +103,17 @@
     (#:releasename . #nil)
     (#:buildinputs_builds . #nil)))
 
-(define (handle-build-request db-channel build-id)
-  "Retrieve build identified by BUILD-ID over DB-CHANNEL and convert it to
-hydra format. Return #f is not build was found."
-  (let ((build (with-critical-section db-channel (db)
-                 (db-get-build db build-id))))
+(define (handle-build-request db build-id)
+  "Retrieve build identified by BUILD-ID over DB and convert it
+  to hydra format. Return #f is not build was found."
+  (let ((build (db-get-build db build-id)))
     (and=> build build->hydra-build)))
 
-(define (handle-builds-request db-channel filters)
-  "Retrieve all builds matched by FILTERS in DB-CHANNEL and convert them to
-Hydra format."
-  (let ((builds (with-critical-section db-channel (db)
-                  (with-time-logging "builds request"
-                                     (db-get-builds db filters)))))
+(define (handle-builds-request db filters)
+  "Retrieve all builds matched by FILTERS in DB and convert them
+  to Hydra format."
+  (let ((builds (with-time-logging "builds request"
+                                   (db-get-builds db filters))))
     (map build->hydra-build builds)))
 
 (define (request-parameters request)
@@ -136,6 +167,28 @@ Hydra format."
      (object->json-string
       `((error . ,message)))))
 
+  (define (respond-html body)
+    (respond '((content-type . (application/xhtml+xml)))
+             #:body
+             (lambda (port)
+               (format
+                port "<!DOCTYPE html PUBLIC ~s ~s>"
+                "-//W3C//DTD XHTML 1.0 Transitional//EN"
+                "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd")
+               (sxml->xml body port))))
+
+  (define (respond-static-file path)
+    ;; PATH is a list of path components
+    (let ((file-name (string-join path "/"))
+          (file-path (string-join (cons* (%static-directory) path) "/")))
+      (if (and (member file-name %file-white-list)
+               (file-exists? file-path)
+               (not (file-is-directory? file-path)))
+          (respond `((content-type . ,(assoc-ref %file-mime-types
+                                                 (file-extension file-path))))
+           #:body (call-with-input-file file-path get-bytevector-all))
+          (respond-not-found file-name))))
+
   (define (respond-build-not-found build-id)
     (respond-json-with-error
      404
@@ -147,6 +200,11 @@ Hydra format."
        404
        (format #f "The build log of derivation ~a is not available." drv))))
 
+  (define (respond-not-found resource_name)
+    (respond (build-response #:code 404)
+             #:body (string-append "Resource not found: "
+                                   resource_name)))
+
   (log-message "~a ~a" (request-method request)
                (uri-path (request-uri request)))
 
@@ -159,8 +217,9 @@ Hydra format."
                     (with-critical-section db-channel (db)
                       (db-get-specifications db)))))
     (("build" build-id)
-     (let ((hydra-build (handle-build-request db-channel
-                                              (string->number build-id))))
+     (let ((hydra-build
+            (with-critical-section db-channel (db)
+              (handle-build-request db (string->number build-id)))))
        (if hydra-build
            (respond-json (object->json-string hydra-build))
            (respond-build-not-found build-id))))
@@ -203,11 +262,12 @@ Hydra format."
             (valid-params? (assq-ref params 'nr)))
        (if valid-params?
            ;; Limit results to builds that are "done".
-           (respond-json (object->json-string
-                          (handle-builds-request db-channel
-                                                 `((status done)
-                                                   ,@params
-                                                   (order finish-time)))))
+           (respond-json
+            (object->json-string
+             (with-critical-section db-channel (db)
+               (handle-builds-request db `((status done)
+                                           ,@params
+                                           (order finish-time))))))
            (respond-json-with-error 500 "Parameter not defined!"))))
     (("api" "queue")
      (let* ((params (request-parameters request))
@@ -218,18 +278,66 @@ Hydra format."
             (object->json-string
              ;; Use the 'status+submission-time' order so that builds in
              ;; 'running' state appear before builds in 'scheduled' state.
-             (handle-builds-request db-channel
-                                    `((status pending)
-                                      ,@params
-                                      (order status+submission-time)))))
+             (with-critical-section db-channel (db)
+               (handle-builds-request db `((status pending)
+                                           ,@params
+                                           (order status+submission-time))))))
            (respond-json-with-error 500 "Parameter not defined!"))))
+    ('()
+     (respond-html (html-page
+                    "Cuirass"
+                    (specifications-table
+                     (with-critical-section db-channel (db)
+                       (db-get-specifications db))))))
+
+    (("jobset" name)
+     (respond-html
+      (with-critical-section db-channel (db)
+        (let* ((evaluation-id-max (db-get-evaluations-id-max db name))
+               (evaluation-id-min (db-get-evaluations-id-min db name))
+               (params (request-parameters request))
+               (border-high (assqx-ref params 'border-high))
+               (border-low (assqx-ref params 'border-low))
+               (evaluations (db-get-evaluations-build-summary db
+                                                              name
+                                                              %page-size
+                                                              border-low
+                                                              border-high)))
+          (html-page name (evaluation-info-table name
+                                                 evaluations
+                                                 evaluation-id-min
+                                                 evaluation-id-max))))))
+
+    (("eval" id)
+     (respond-html
+      (with-critical-section db-channel (db)
+        (let* ((builds-id-max (db-get-builds-max db id))
+               (builds-id-min (db-get-builds-min db id))
+               (params (request-parameters request))
+               (border-high-time (assqx-ref params 'border-high-time))
+               (border-low-time (assqx-ref params 'border-low-time))
+               (border-high-id (assqx-ref params 'border-high-id))
+               (border-low-id (assqx-ref params 'border-low-id)))
+          (html-page
+           "Evaluation"
+           (build-eval-table
+            (handle-builds-request db `((evaluation ,id)
+                                        (nr ,%page-size)
+                                        (order finish-time+build-id)
+                                        (border-high-time ,border-high-time)
+                                        (border-low-time ,border-low-time)
+                                        (border-high-id ,border-high-id)
+                                        (border-low-id ,border-low-id)))
+            builds-id-min
+            builds-id-max))))))
+
+    (("static" path ...)
+     (respond-static-file path))
     ('method-not-allowed
      ;; 405 "Method Not Allowed"
      (values (build-response #:code 405) #f db-channel))
     (_
-     (respond (build-response #:code 404)
-              #:body (string-append "Resource not found: "
-                                    (uri->string (request-uri request)))))))
+     (respond-not-found (uri->string (request-uri request))))))
 
 (define* (run-cuirass-server db #:key (host "localhost") (port 8080))
   (let* ((host-info  (gethostbyname host))
diff --git a/src/cuirass/templates.scm b/src/cuirass/templates.scm
new file mode 100644
index 0000000..6ba3a06
--- /dev/null
+++ b/src/cuirass/templates.scm
@@ -0,0 +1,222 @@
+;;; templates.scm -- HTTP API
+;;; Copyright © 2018 Tatiana Sholokhova <tanja201396@gmail.com>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; Cuirass is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation, either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; Cuirass 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Cuirass.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (cuirass templates)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:export (html-page
+            specifications-table
+            evaluation-info-table
+            build-eval-table))
+
+(define (html-page title body)
+  "Return HTML page with given TITLE and BODY."
+  `(html (@ (xmlns "http://www.w3.org/1999/xhtml")
+            (xml:lang "en")
+            (lang "en"))
+         (head
+          (meta (@ (charset "utf-8")))
+          (meta (@ (name "viewport")
+                   (content ,(string-join '("width=device-width"
+                                            "initial-scale=1"
+                                            "shrink-to-fit=no")
+                                          ", "))))
+          (link (@ (rel "stylesheet")
+                   (href "/static/css/bootstrap.css")))
+          (link (@ (rel "stylesheet")
+                   (href "/static/css/open-iconic-bootstrap.css")))
+          (title ,title))
+         (body
+          (nav (@ (class "navbar navbar-expand-lg navbar-light bg-light"))
+               (a (@ (class "navbar-brand") (href "/"))
+                  (img (@ (src "/static/images/logo.png")
+                          (alt "logo")
+                          (height "25")))))
+          (main (@ (role "main") (class "container pt-4 px-1"))
+                ,body
+                (hr)))))
+
+(define (specifications-table specs)
+  "Return HTML for the SPECS table."
+  `((p (@ (class "lead")) "Specifications")
+    (table
+     (@ (class "table table-sm table-hover"))
+     ,@(if (null? specs)
+           `((th (@ (scope "col")) "No elements here."))
+           `((thead (tr (th (@ (scope "col")) Name)
+                        (th (@ (scope "col")) Inputs)))
+             (tbody
+              ,@(map
+                 (lambda (spec)
+                   `(tr (td (a (@ (href "/jobset/" ,(assq-ref spec #:name)))
+                               ,(assq-ref spec #:name)))
+                        (td ,(string-join
+                              (map (lambda (input)
+                                     (format #f "~a (on ~a)"
+                                             (assq-ref input #:name)
+                                             (assq-ref input #:branch)))
+                                   (assq-ref spec #:inputs)) ", "))))
+                 specs)))))))
+
+(define (pagination first-link prev-link next-link last-link)
+  "Return html page navigation buttons with LINKS."
+  `(div (@ (class row))
+        (nav
+         (@ (class "mx-auto") (aria-label "Page navigation"))
+         (ul (@ (class "pagination"))
+             (li (@ (class "page-item"))
+                 (a (@ (class "page-link")
+                       (href ,first-link))
+                    "<< First"))
+             (li (@ (class "page-item"
+                      ,(if (string-null? prev-link) " disabled")))
+                 (a (@ (class "page-link")
+                       (href ,prev-link))
+                    "< Previous"))
+             (li (@ (class "page-item"
+                      ,(if (string-null? next-link) " disabled")))
+                 (a (@ (class "page-link")
+                       (href ,next-link))
+                    "Next >"))
+             (li (@ (class "page-item"))
+                 (a (@ (class "page-link")
+                       (href ,last-link))
+                    "Last >>"))))))
+
+(define (evaluation-info-table name evaluations id-min id-max)
+  "Return HTML for the EVALUATION table NAME. ID-MIN and ID-MAX are
+  global minimal and maximal id."
+  `((p (@ (class "lead")) "Evaluations of " ,name)
+    (table
+     (@ (class "table table-sm table-hover table-striped"))
+     ,@(if (null? evaluations)
+           `((th (@ (scope "col")) "No elements here."))
+           `((thead
+              (tr
+               (th (@ (scope "col")) "#")
+               (th (@ (scope "col")) Commits)
+               (th (@ (scope "col")) Success)))
+             (tbody
+              ,@(map
+                 (lambda (row)
+                   `(tr (th (@ (scope "row"))
+                            (a (@ (href "/eval/" ,(assq-ref row #:id)))
+                               ,(assq-ref row #:id)))
+                        (td ,(string-join
+                              (map (cut substring <> 0 7)
+                                   (string-tokenize (assq-ref row #:commits)))
+                              ", "))
+                        (td (a (@ (href "#") (class "badge badge-success"))
+                               ,(assq-ref row #:succeeded))
+                            (a (@ (href "#") (class "badge badge-danger"))
+                               ,(assq-ref row #:failed))
+                            (a (@ (href "#") (class "badge badge-secondary"))
+                               ,(assq-ref row #:scheduled)))))
+                 evaluations)))))
+    ,(if (null? evaluations)
+         (pagination "" "" "" "")
+         (let* ((eval-ids (map (cut assq-ref <> #:id) evaluations))
+                (page-id-min (last eval-ids))
+                (page-id-max (first eval-ids)))
+           (pagination
+            (format #f "?border-high=~d" (1+ id-max))
+            (if (= page-id-max id-max)
+                ""
+                (format #f "?border-low=~d" page-id-max))
+            (if (= page-id-min id-min)
+                ""
+                (format #f "?border-high=~d" page-id-min))
+            (format #f "?border-low=~d" (1- id-min)))))))
+
+(define (build-eval-table builds build-min build-max)
+  "Return HTML for the BUILDS table NAME. BUILD-MIN and BUILD-MAX are
+   global minimal and maximal (stoptime, id) pairs."
+  (define (table-header)
+    `(thead
+      (tr
+       (th (@ (scope "col")) '())
+       (th (@ (scope "col")) ID)
+       (th (@ (scope "col")) Specification)
+       (th (@ (scope "col")) "Finished at")
+       (th (@ (scope "col")) Job)
+       (th (@ (scope "col")) Nixname)
+       (th (@ (scope "col")) System))))
+
+  (define (table-row build)
+    `(tr
+      (td ,(case (assq-ref build #:buildstatus)
+             ((0) `(span (@ (class "oi oi-check text-success")
+                            (title "Succeeded")
+                            (aria-hidden "true"))
+                         ""))
+             ((1 2 3 4) `(span (@ (class "oi oi-x text-danger")
+                                  (title "Failed")
+                                  (aria-hidden "true"))
+                               ""))
+             (else `(span (@ (class "oi oi-clock text-warning")
+                             (title "Scheduled")
+                             (aria-hidden "true"))
+                          ""))))
+      (th (@ (scope "row")),(assq-ref build #:id))
+      (td ,(assq-ref build #:jobset))
+      (td ,(strftime "%c" (localtime (assq-ref build #:stoptime))))
+      (td ,(assq-ref build #:job))
+      (td ,(assq-ref build #:nixname))
+      (td ,(assq-ref build #:system))))
+
+  (define (build-id build)
+    (match build
+      ((stoptime id) id)))
+
+  (define (build-stoptime build)
+    (match build
+      ((stoptime id) stoptime)))
+
+  `((table
+     (@ (class "table table-sm table-hover table-striped"))
+     ,@(if (null? builds)
+           `((th (@ (scope "col")) "No elements here."))
+           `(,(table-header)
+             (tbody ,@(map table-row builds)))))
+    ,(if (null? builds)
+         (pagination "" "" "" "")
+         (let* ((build-time-ids (map (lambda (row)
+                                       (list (assq-ref row #:stoptime)
+                                             (assq-ref row #:id)))
+                                     builds))
+                (page-build-min (last build-time-ids))
+                (page-build-max (first build-time-ids)))
+           (pagination
+            (format #f "?border-high-time=~d&border-high-id=~d"
+                    (build-stoptime build-max)
+                    (1+ (build-id build-max)))
+            (if (equal? page-build-max build-max)
+                ""
+                (format #f "?border-low-time=~d&border-low-id=~d"
+                        (build-stoptime page-build-max)
+                        (build-id page-build-max)))
+            (if (equal? page-build-min build-min)
+                ""
+                (format #f "?border-high-time=~d&border-high-id=~d"
+                        (build-stoptime page-build-min)
+                        (build-id page-build-min)))
+            (format #f "?border-low-time=~d&border-low-id=~d"
+                    (build-stoptime build-min)
+                    (1- (build-id build-min))))))))