[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[no subject]
|
From: |
Tatiana |
|
Date: |
Sun, 22 Jul 2018 18:43:32 -0400 (EDT) |
branch: web-interface
commit 504b9199fefb0a1fe30f7963e306de0ae6cc4008
Author: TSholokhova <address@hidden>
Date: Mon Jul 23 00:43:17 2018 +0200
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.
---
src/cuirass/database.scm | 99 +++++++++++++++-------------
src/cuirass/http.scm | 48 +++++++-------
src/cuirass/templates.scm | 161 +++++++++++++++++++++++++++++++---------------
tests/database.scm | 2 +-
4 files changed, 188 insertions(+), 122 deletions(-)
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index dda808c..5e928cf 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -46,8 +46,8 @@
db-update-build-status!
db-get-build
db-get-builds
- db-get-builds-id-min
- db-get-builds-id-max
+ db-get-builds-min
+ db-get-builds-max
db-get-evaluations
db-get-evaluations-build-summary
db-get-evaluations-count
@@ -476,6 +476,7 @@ Assumes that if group id stays the same the group headers
stay the same."
(('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)
@@ -503,9 +504,10 @@ 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 (:borderlow IS NULL OR (:borderlow < Builds.stoptime)) \
-AND (:borderhigh IS NULL OR (:borderhigh > Builds.stoptime))
-ORDER BY CASE WHEN :borderlow IS NULL THEN Builds.stoptime ELSE
-Builds.stoptime END DESC
+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)))
@@ -518,8 +520,14 @@ ORDER BY ~a, id ASC;" order))
#:system (assqx-ref filters 'system)
#:status (and=> (assqx-ref filters 'status)
object->string)
- #:borderlow (assqx-ref filters 'border-low)
- #:borderhigh (assqx-ref filters 'border-high)
+ #: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)))
@@ -581,8 +589,8 @@ FROM Evaluations ORDER BY id DESC LIMIT " limit ";"))
evaluations))))))
(define (db-get-evaluations-build-summary db spec limit border-low border-high)
- (let loop
- ((rows (sqlite-exec db
+ (let loop
+ ((rows (sqlite-exec db
"SELECT E.id, E.revision, 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 \
@@ -597,49 +605,50 @@ 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 revision succeeded failed scheduled) . rest)
- (loop rest
- (cons `((#:id . ,id)
- (#:revision . ,revision)
- (#:succeeded . ,succeeded)
- (#:failed . ,failed)
- (#:scheduled . ,scheduled))
- evaluations))))))
-
-(define (db-get-evaluations-count db spec)
- "Return the number of evaluations of the given specification SPEC."
+ (evaluations '()))
+ (match rows
+ (() evaluations)
+ ((#(id revision succeeded failed scheduled) . rest)
+ (loop rest
+ (cons `((#:id . ,id)
+ (#:revision . ,revision)
+ (#: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 COUNT(id) FROM Evaluations \
+"SELECT MIN(id) FROM Evaluations
WHERE specification=" spec)))
- (array-ref (list-ref rows 0) 0)))
+ (vector-ref (car rows) 0)))
(define (db-get-evaluations-id-max db spec)
- "Return the max id of evaluations of the given specification 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)))
- (array-ref (list-ref rows 0) 0)))
-
-(define (db-get-evaluations-id-min db spec)
- "Return the min id of evaluations of the given specification SPEC."
- (let ((rows (sqlite-exec db
-"SELECT MIN(id) FROM Evaluations
-WHERE specification=" spec)))
- (array-ref (list-ref rows 0) 0)))
+ (vector-ref (car rows) 0)))
-(define (db-get-builds-id-max db eval)
- "Return the min id of build of the given evaluation EVAL."
+(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 MAX(stoptime) FROM Builds \
-WHERE evaluation=" eval)))
- (array-ref (list-ref rows 0) 0)))
-
-(define (db-get-builds-id-min db eval)
- "Return the max id of build of the given evaluation EVAL."
+"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 MIN(stoptime) FROM Builds \
-WHERE evaluation=" eval)))
- (array-ref (list-ref rows 0) 0)))
+"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 38a5f49..52f1a32 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -77,8 +77,8 @@
(#:project . ,(assq-ref build #:repo-name))
(#:jobset . ,(assq-ref build #:branch))
(#: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)))
@@ -143,11 +143,6 @@
(define (request-path-components request)
(split-and-decode-uri-path (uri-path (request-uri request))))
-(define (normalize-parameter parameter)
- (if parameter
- (list-ref parameter 0)
- #f))
-
(define (url-handler request body db-channel)
(define* (respond response #:key body (db-channel db-channel))
@@ -283,11 +278,13 @@
(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"
@@ -323,20 +320,25 @@
(respond-html
(with-critical-section db-channel (db)
(let*
- ((builds-id-max (db-get-builds-id-max db id))
- (builds-id-min (db-get-builds-id-min db id))
+ ((builds-id-max (db-get-builds-max db id))
+ (builds-id-min (db-get-builds-min db id))
(params (request-parameters request))
- (border-high (assqx-ref params 'border-high))
- (border-low (assqx-ref params 'border-low)))
+ (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
- "Evaluations"
+ "Evaluation"
(build-eval-table
- (handle-builds-request db
- `((evaluation ,id)
- (nr ,(%pagesize))
- (order finish-time)
- (border-high ,border-high)
- (border-low ,border-low)))
+ (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))))))
diff --git a/src/cuirass/templates.scm b/src/cuirass/templates.scm
index d9f1e23..d363bc6 100644
--- a/src/cuirass/templates.scm
+++ b/src/cuirass/templates.scm
@@ -18,6 +18,8 @@
;;; 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
@@ -26,16 +28,21 @@
%pagesize))
(define %pagesize
- ;; description
+ ;; 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"))
+ `(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")))
+ (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")
@@ -66,50 +73,47 @@
,@(map
(lambda (spec)
`(tr
- (td (a (@ (href "/jobset/" ,(assq-ref spec #:name)))
,(assq-ref spec #:name)))
+ (td
+ (a (@ (href
+ "/jobset/"
+ ,(assq-ref spec #:name)))
+ ,(assq-ref spec #:name)))
(td ,(assq-ref spec #:branch))))
specs)))))))
-(define (pagination page-id-min page-id-max id-min id-max)
- "Return page navigation buttons."
+(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 "?border-high=" ,(number->string (+ id-max 1))))
+ (href ,first-link))
"<< First"))
- (li (@ (class "page-item" ,(if (= page-id-max id-max) " disabled"
"")))
+ (li (@ (class "page-item"
+ ,(if (string-null? prev-link) " disabled")))
(a (@ (class "page-link")
- (href "?border-low=" ,(number->string page-id-max)))
+ (href ,prev-link))
"< Previous"))
- (li (@ (class "page-item" ,(if (= page-id-min id-min) " disabled"
"")))
+ (li (@ (class "page-item"
+ ,(if (string-null? next-link) " disabled")))
(a (@ (class "page-link")
- (href "?border-high=" ,(number->string page-id-min)))
+ (href ,next-link))
"Next >"))
(li (@ (class "page-item"))
(a (@ (class "page-link")
- (href "?border-low=" ,(number->string (- id-min 1))))
+ (href ,last-link))
"Last >>"))))))
-(define (minimum lst current-min)
- "Return MINIMUM value in LST (list). Initial value is current-min."
- (cond ((null? lst) current-min)
- ((< (car lst) current-min) (minimum (cdr lst) (car lst)))
- (else (minimum (cdr lst) current-min))))
-
-(define (maximum lst current-max)
- "Return MAXIMUM value in LST (list). Initial value is current-max."
- (cond ((null? lst) current-max)
- ((> (car lst) current-max) (maximum (cdr lst) (car lst)))
- (else (maximum (cdr lst) current-max))))
-
-(define (evaluation-info-table name evaluations evaluation-id-min
evaluation-id-max)
- "Return HTML for the EVALUATION table NAME from EVALUATION-ID-MIN to
- EVALUATION-ID-MAX."
- (let ((id-min (minimum (map (lambda (row) (assq-ref row #:id)) evaluations)
evaluation-id-max))
- (id-max (maximum (map (lambda (row) (assq-ref row #:id)) evaluations)
evaluation-id-min)))
+(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"))
@@ -124,18 +128,32 @@
,@(map
(lambda (row)
`(tr
- (th (@ (scope "row")) (a (@ (href "/eval/" ,(assq-ref row
#:id))) ,(assq-ref row #:id)))
+ (th (@ (scope "row"))
+ (a
+ (@ (href "/eval/" ,(assq-ref row #:id)))
+ ,(assq-ref row #:id)))
(td ,(assq-ref row #:revision))
(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)))))
+ (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 id-min id-max evaluation-id-min evaluation-id-max))))
+ ,(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-id-min build-id-max)
- "Return HTML for the BUILDS table NAME from BUILD-ID-MIN to
- BUILD-ID-MAX."
+(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
@@ -145,27 +163,64 @@
(th (@ (scope "col")) "Finished at")
(th (@ (scope "col")) Job)
(th (@ (scope "col")) Nixname)
- (th (@ (scope "col")) System)
- )))
+ (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")) ""))))
+ ((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 #:project))
(td ,(strftime "%c" (localtime (assq-ref build #:stoptime))))
(td ,(assq-ref build #:job))
(td ,(assq-ref build #:nixname))
(td ,(assq-ref build #:system))))
- (let ((id-min (minimum (map (lambda (row) (assq-ref row #:stoptime)) builds)
build-id-max))
- (id-max (maximum (map (lambda (row) (assq-ref row #:stoptime)) builds)
build-id-min)))
- `((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 id-min id-max build-id-min build-id-max))))
+ (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))))))
diff --git a/tests/database.scm b/tests/database.scm
index a396299..847c8a6 100644
--- a/tests/database.scm
+++ b/tests/database.scm
@@ -157,7 +157,7 @@ INSERT INTO Evaluations (specification, revision) VALUES
(3, 3);")
((3 "/baz.drv") (2 "/bar.drv") (1 "/foo.drv")) ;descending order
((3 "/baz.drv") (2 "/bar.drv") (1 "/foo.drv")) ;ditto
((3 "/baz.drv") (2 "/bar.drv") (1 "/foo.drv")) ;ditto
- ((1 "/foo.drv")) ;nr = 1
+ ((3 "/baz.drv")) ;nr = 1
((2 "/bar.drv") (1 "/foo.drv") (3 "/baz.drv"))) ;status+submission-time
(with-temporary-database db
;; Populate the 'Builds', 'Derivations', 'Evaluations', and