branch: web-interface-rebased commit 6c6f4ae0be308d9977586ff7f99b6c33734c1b1a Author: TSholokhova <tanja201...@gmail.com> 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 <m.othac...@gmail.com> ;;; Copyright © 2018 Ludovic Courtès <l...@gnu.org> ;;; Copyright © 2018 Clément Lassieur <clem...@lassieur.org> +;;; Copyright © 2018 Tatiana Sholokhova <tanja201...@gmail.com> ;;; ;;; 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 <m...@gnu.org> ;;; Copyright © 2017 Mathieu Othacehe <m.othac...@gmail.com> ;;; Copyright © 2018 Ludovic Courtès <l...@gnu.org> ;;; Copyright © 2018 Clément Lassieur <clem...@lassieur.org> +;;; Copyright © 2018 Tatiana Sholokhova <tanja201...@gmail.com> ;;; ;;; 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 <tanja201...@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 (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))))))