[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[no subject]
|
From: |
Clément Lassieur |
|
Date: |
Tue, 24 Jul 2018 18:51:49 -0400 (EDT) |
branch: web-interface-rebased
commit 3d0c80985c2ed2db1d5721cc6be51faedf1beb10
Author: TSholokhova <address@hidden>
Date: Sat Jul 21 15:39:10 2018 +0200
Add web-interface.
Add basic HTML templates, main and specification builds pages.
* src/cuirass/templates.scm: New file. Add main page template. Add
builds tables (latest and queue). Add hyperref from the main page to the builds
pages.
* Makefile.am (dist_pkgmodule_DATA): Add it.
* src/cuirass/http.scm (url-handler): Add handler for “statusâ€
endpoint. (%static-directory, file-mime-types): New variables. (url-handler):
Add handler for “/status/<repo_name>â€; add handler for static files.
Implement first feature. Add bootstrap style.
* src/cuirass/templates.scm: Bootstrap based html templates. New
functions: evaluation-info-table, build-eval-table, pagination.
* src/cuirass/database.scm: Add new requests to database:
db-get-evaluations-info, db-get-evaluations-count. Add evaluation filter to
db-get-builds.
* src/cuirass/http.scm (url-handler): Change "status" endpoint to
"/". Add endpoints: ("jobset" name), ("eval" id).
Change HTML5 to XHTML. Fix codestyle.
* src/cuirass/http.scm (respond-html): Add XHTML preamble and
content-type.
* src/cuirass/templates.scm (html-page): Add XHTML preamble; fix
codestyle.
* src/cuirass/database.scm: Fix codestyle.
Add white-list.
* src/cuirass/http.scm (respond-static-file, file-white-list): Add
white list check.
Update id pagination.
* src/cuirass/http.scm: Change parameters.
* src/cuirass/templates.scm: Fix pagination function. Added min and
max functions for lists.
* src/cuirass/database.scm: Add borders parameters to evaluation
request.
Update id pagination (previous+last buttons).
* src/cuirass/templates.scm: Add buttons for pagination.
* src/cuirass/database.scm(db-get-evaluations-build-summary):
Implement different order for low and high borders.
Add pagination for each evaluation page.
* src/cuirass/templates.scm (build-eval-table): Add pagination.
* src/cuirass/database.scm: Add border filters for pagination in
db-get-builds. Add functions for searching max and min stoptimes.
* src/cuirass/http.scm: Add pagination parameters in "eval" query.
Fix codestyle.
* src/cuirass/templates.scm: Fix codestyle.
* src/cuirass/database.scm: Fix codestyle.
* src/cuirass/http.scm: Fix codestyle.
* tests/database.scm: Fix test.
* Makefile.am: Add static files paths.
Fix with-critical-section wrapping.
* /src/cuirass/http.scm: Use one critical-section per function.
Fix pagination for builds.
* src/cuirass/templates.scm: Rewrite pagination template.
* src/cuirass/database.scm: Change build filtering for pagination.
* src/cuirass/http.scm: Add parameters for tuple-pagination.
* tests/database.scm: Fix test.
---
Makefile.am | 19 +++-
src/cuirass/database.scm | 149 +++++++++++++++++++++++------
src/cuirass/http.scm | 190 ++++++++++++++++++++++++++++++-------
src/cuirass/templates.scm | 234 ++++++++++++++++++++++++++++++++++++++++++++++
4 files changed, 530 insertions(+), 62 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index 4f6c089..549713a 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -34,6 +34,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 +45,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 +66,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..f6b78a0 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -3,6 +3,7 @@
;;; Copyright © 2017 Mathieu Othacehe <address@hidden>
;;; Copyright © 2018 Ludovic Courtès <address@hidden>
;;; Copyright © 2018 Clément Lassieur <address@hidden>
+;;; Copyright © 2018 Tatiana Sholokhova <address@hidden>
;;;
;;; This file is part of Cuirass.
;;;
@@ -48,10 +49,17 @@
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-count
+ 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 +462,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)))))
+'nr | 'order | 'status | 'evaluation."
(define (format-output name path)
`(,name . ((#:path . ,path))))
@@ -539,18 +547,26 @@ Assumes that if group id stays the same the group headers
stay the same."
(let ((x-repeated-row (list->vector other-cells)))
(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 '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 "\
+ (let*
+ ((order
+ (match
+ (assq 'order filters)
+ (('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")))
+ "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 \
@@ -563,15 +579,31 @@ 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)) \
-ORDER BY ~a, Builds.id ASC LIMIT :nr;" order))
- (stmt (sqlite-prepare db stmt-text #:cache? #t)))
- (sqlite-bind-arguments stmt #:id (assqx-ref filters 'id)
+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)
+ #: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)))
@@ -631,3 +663,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..a1343aa 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -1,8 +1,10 @@
+
;;;; http.scm -- HTTP API
;;; Copyright © 2016 Mathieu Lirzin <address@hidden>
;;; Copyright © 2017 Mathieu Othacehe <address@hidden>
;;; Copyright © 2018 Ludovic Courtès <address@hidden>
;;; Copyright © 2018 Clément Lassieur <address@hidden>
+;;; Copyright © 2018 Tatiana Sholokhova <address@hidden>
;;;
;;; This file is part of Cuirass.
;;;
@@ -20,11 +22,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,28 +38,51 @@
#: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 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)
(if bool 1 0))
-
(define finished?
(not (memv (assq-ref build #:status)
(list (build-status scheduled)
(build-status started)))))
-
`((#:id . ,(assq-ref build #:id))
(#:jobset . ,(assq-ref build #:repo-name))
(#:job . ,(assq-ref build #:job-name))
-
- ;; Hydra's API uses "timestamp" as the time of the last useful event for
- ;; that build: evaluation or completion.
+ ;; Hydra's API uses "timestamp" as the time of the last useful event
+ ;; for that build: evaluation or completion.
(#:timestamp . ,(if finished?
(assq-ref build #:stoptime)
(assq-ref build #:timestamp)))
-
(#:starttime . ,(assq-ref build #:starttime))
(#:stoptime . ,(assq-ref build #:stoptime))
(#:derivation . ,(assq-ref build #:derivation))
@@ -70,19 +98,20 @@
(#: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))))
- (and=> build build->hydra-build)))
+(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)
@@ -99,11 +128,11 @@ Hydra format."
(match key-symbol
('id (string->number param))
('nr (string->number param))
+ ('page (string->number param))
(_ param)))))))
(string-split query #\&))
'())))
-
;;;
;;; Web server.
;;;
@@ -136,6 +165,27 @@ 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 \"-//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 +197,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,11 +214,15 @@ 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))))
+ (respond-json (object->json-string hydra-build))
+ (respond-build-not-found build-id))))
(("build" build-id "log" "raw")
(let ((build (with-critical-section db-channel (db)
(db-get-build db (string->number build-id)))))
@@ -204,10 +263,12 @@ Hydra format."
(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)))))
+ (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 +279,77 @@ 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)))))
- (respond-json-with-error 500 "Parameter not defined!"))))
+ (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)))
+ (html-page
+ name
+ (evaluation-info-table
+ name
+ (db-get-evaluations-build-summary
+ db
+ name
+ (%pagesize)
+ border-low
+ border-high)
+ 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 ,(%pagesize))
+ (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..6ca65f1
--- /dev/null
+++ b/src/cuirass/templates.scm
@@ -0,0 +1,234 @@
+
+;;;; http.scm -- HTTP API
+;;; Copyright © 2018 Tatiana Sholokhova <address@hidden>
+;;;
+;;; 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 (srfi srfi-1)
+ #:export (html-page
+ specifications-table
+ build-table
+ evaluation-info-table
+ build-eval-table
+ %pagesize))
+
+(define %pagesize
+ ;; Maximal number of items for a page.
+ (make-parameter 10))
+
+(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
+ "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."
+ (let*
+ ((eval-id-list
+ (map (lambda (row) (assq-ref row #:id)) evaluations))
+ (page-id-min (last eval-id-list))
+ (page-id-max (car eval-id-list)))
+ `((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 (lambda (commit)
+ (substring commit 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)))))
+ ,(pagination
+ (format #f "?border-high=~d" (+ id-max 1))
+ (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" (- id-min 1))))))
+
+(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))))
+ (let*
+ ((builds-time-id-list
+ (map (lambda (row) `(,(assq-ref row #:stoptime)
+ ,(assq-ref row #:id)))
+ builds))
+ (page-build-min (last builds-time-id-list))
+ (page-build-max (car builds-time-id-list)))
+ `((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)))))
+ ,(pagination
+ (format
+ #f
+ "?border-high-time=~d&border-high-id=~d"
+ (car build-max)
+ (+ (last build-max) 1))
+ (if (equal? page-build-max build-max)
+ ""
+ (format
+ #f
+ "?border-low-time=~d&border-low-id=~d"
+ (car page-build-max)
+ (last page-build-max)))
+ (if (equal? page-build-min build-min)
+ ""
+ (format
+ #f
+ "?border-high-time=~d&border-high-id=~d"
+ (car page-build-min)
+ (last page-build-min)))
+ (format
+ #f
+ "?border-low-time=~d&border-low-id=~d"
+ (car build-min)
+ (- (last build-min) 1))))))