diff options
| -rw-r--r-- | bin/cuirass.in | 15 | ||||
| -rw-r--r-- | src/cuirass/base.scm | 6 | ||||
| -rw-r--r-- | src/cuirass/database.scm | 56 | ||||
| -rw-r--r-- | src/cuirass/templates.scm | 61 | ||||
| -rw-r--r-- | src/schema.sql | 2 | ||||
| -rw-r--r-- | src/sql/upgrade-10.sql | 12 | ||||
| -rw-r--r-- | tests/database.scm | 12 | ||||
| -rw-r--r-- | tests/http.scm | 2 |
8 files changed, 97 insertions, 69 deletions
diff --git a/bin/cuirass.in b/bin/cuirass.in index b2721de..c4bcfaa 100644 --- a/bin/cuirass.in +++ b/bin/cuirass.in @@ -162,14 +162,15 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@" (clear-build-queue) - ;; If Cuirass was stopped during an evaluation, consider - ;; it done. Builds that were not registered during this - ;; evaluation will be registered during the next - ;; evaluation. - (db-set-evaluations-done) + ;; If Cuirass was stopped during an evaluation, + ;; abort it. Builds that were not registered + ;; during this evaluation will be registered + ;; during the next evaluation. + (db-abort-pending-evaluations) - ;; First off, restart builds that had not completed or - ;; were not even started on a previous run. + ;; First off, restart builds that had not + ;; completed or were not even started on a + ;; previous run. (spawn-fiber (essential-task 'restart-builds exit-channel diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm index 678c976..ec1b467 100644 --- a/src/cuirass/base.scm +++ b/src/cuirass/base.scm @@ -355,7 +355,8 @@ Return a list of jobs that are associated to EVAL-ID." ;; otherwise, suppose that data read from port are ;; correct and keep things going. ((? eof-object?) - (db-set-evaluation-done eval-id) ;failed! + (db-set-evaluation-status eval-id + (evaluation-status failed)) (close-port (cdr log-pipe)) (raise (condition (&evaluation-error @@ -729,7 +730,8 @@ by PRODUCT-SPECS." (log-message "evaluation ~a registered ~a new derivations" eval-id (length derivations)) - (db-set-evaluation-done eval-id) + (db-set-evaluation-status eval-id + (evaluation-status succeeded)) (spawn-builds store derivations) diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm index caada6e..c1941a1 100644 --- a/src/cuirass/database.scm +++ b/src/cuirass/database.scm @@ -44,9 +44,10 @@ db-remove-specification db-get-specification db-get-specifications + evaluation-status db-add-evaluation - db-set-evaluations-done - db-set-evaluation-done + db-abort-pending-evaluations + db-set-evaluation-status db-set-evaluation-time db-get-pending-derivations build-status @@ -438,6 +439,12 @@ SELECT * FROM Specifications ORDER BY name DESC;"))) ,(with-input-from-string build-outputs read))) specs))))))) +(define-enumeration evaluation-status + (started -1) + (succeeded 0) + (failed 1) + (aborted 2)) + (define* (db-add-evaluation spec-name checkouts #:key (checkouttime 0) @@ -450,9 +457,10 @@ Otherwise, return #f." (with-db-worker-thread db (sqlite-exec db "BEGIN TRANSACTION;") - (sqlite-exec db "INSERT INTO Evaluations (specification, in_progress, + (sqlite-exec db "INSERT INTO Evaluations (specification, status, timestamp, checkouttime, evaltime) -VALUES (" spec-name ", true, " now "," checkouttime "," evaltime ");") +VALUES (" spec-name "," (evaluation-status started) "," +now "," checkouttime "," evaltime ");") (let* ((eval-id (last-insert-rowid db)) (new-checkouts (filter-map (cut db-add-checkout spec-name eval-id <>) @@ -468,18 +476,16 @@ VALUES (" spec-name ", true, " now "," checkouttime "," evaltime ");") (sqlite-exec db "COMMIT;") eval-id))))) -(define (db-set-evaluations-done) +(define (db-abort-pending-evaluations) (with-db-worker-thread db - (sqlite-exec db "UPDATE Evaluations SET in_progress = false;"))) + (sqlite-exec db "UPDATE Evaluations SET status = +" (evaluation-status aborted) " WHERE status = " +(evaluation-status started)))) -(define (db-set-evaluation-done eval-id) +(define (db-set-evaluation-status eval-id status) (with-db-worker-thread db - (sqlite-exec db "UPDATE Evaluations SET in_progress = false -WHERE id = " eval-id ";") - (db-add-event 'evaluation - (time-second (current-time time-utc)) - `((#:evaluation . ,eval-id) - (#:in_progress . #f))))) + (sqlite-exec db "UPDATE Evaluations SET status = +" status " WHERE id = " eval-id ";"))) (define (db-set-evaluation-time eval-id) (define now @@ -795,7 +801,7 @@ FILTERS is an assoc list whose possible keys are 'derivation | 'id | 'jobset | ;; With this order, builds in 'running' state (-1) appear ;; before those in 'scheduled' state (-2). (('order . 'status+submission-time) - "status DESC, Builds.timestamp DESC, Builds.id ASC") + "Builds.status DESC, Builds.timestamp DESC, Builds.id ASC") (_ "Builds.id DESC"))) (define (where-conditions filters) @@ -984,18 +990,18 @@ WHERE evaluation =" eval-id ";")) (define (db-get-evaluations limit) (with-db-worker-thread db - (let loop ((rows (sqlite-exec db "SELECT id, specification, in_progress, + (let loop ((rows (sqlite-exec db "SELECT id, specification, status, timestamp, checkouttime, evaltime FROM Evaluations ORDER BY id DESC LIMIT " limit ";")) (evaluations '())) (match rows (() (reverse evaluations)) - ((#(id specification in-progress timestamp checkouttime evaltime) + ((#(id specification status timestamp checkouttime evaltime) . rest) (loop rest (cons `((#:id . ,id) (#:specification . ,specification) - (#:in-progress . ,in-progress) + (#:status . ,status) (#:timestamp . ,timestamp) (#:checkouttime . ,checkouttime) (#:evaltime . ,evaltime) @@ -1005,9 +1011,9 @@ FROM Evaluations ORDER BY id DESC LIMIT " limit ";")) (define (db-get-evaluations-build-summary spec limit border-low border-high) (with-db-worker-thread db (let loop ((rows (sqlite-exec db " -SELECT E.id, E.in_progress, B.succeeded, B.failed, B.scheduled +SELECT E.id, E.status, B.succeeded, B.failed, B.scheduled FROM -(SELECT id, in_progress +(SELECT id, status FROM Evaluations WHERE (specification=" spec ") AND (" border-low "IS NULL OR (id >" border-low ")) @@ -1024,10 +1030,10 @@ ORDER BY E.id ASC;")) (evaluations '())) (match rows (() evaluations) - ((#(id in-progress succeeded failed scheduled) . rest) + ((#(id status succeeded failed scheduled) . rest) (loop rest (cons `((#:id . ,id) - (#:in-progress . ,in-progress) + (#:status . ,status) (#:checkouts . ,(db-get-checkouts id)) (#:succeeded . ,(or succeeded 0)) (#:failed . ,(or failed 0)) @@ -1053,10 +1059,10 @@ WHERE specification=" spec))) (define (db-get-evaluation-summary id) (with-db-worker-thread db (let ((rows (sqlite-exec db " -SELECT E.id, E.in_progress, E.timestamp, E.checkouttime, E.evaltime, +SELECT E.id, E.status, E.timestamp, E.checkouttime, E.evaltime, B.total, B.succeeded, B.failed, B.scheduled FROM - (SELECT id, in_progress, timestamp, checkouttime, evaltime + (SELECT id, status, timestamp, checkouttime, evaltime FROM Evaluations WHERE (id=" id ")) E LEFT JOIN @@ -1068,10 +1074,10 @@ ON B.evaluation=E.id ORDER BY E.id ASC;"))) (and=> (expect-one-row rows) (match-lambda - (#(id in-progress timestamp checkouttime evaltime + (#(id status timestamp checkouttime evaltime total succeeded failed scheduled) `((#:id . ,id) - (#:in-progress . ,in-progress) + (#:status . ,status) (#:total . ,(or total 0)) (#:timestamp . ,timestamp) (#:checkouttime . ,checkouttime) diff --git a/src/cuirass/templates.scm b/src/cuirass/templates.scm index 66d6de9..3128b45 100644 --- a/src/cuirass/templates.scm +++ b/src/cuirass/templates.scm @@ -31,7 +31,8 @@ #:use-module (guix progress) #:use-module (guix store) #:use-module ((guix utils) #:select (string-replace-substring)) - #:use-module ((cuirass database) #:select (build-status)) + #:use-module ((cuirass database) #:select (build-status + evaluation-status)) #:export (html-page specifications-table evaluation-info-table @@ -372,32 +373,38 @@ system whose names start with " (code "guile-") ":" (br) (if (string=? changes "") '(em "None") changes))) (define (evaluation-badges evaluation) - (if (zero? (assq-ref evaluation #:in-progress)) - (let ((succeeded (assq-ref evaluation #:succeeded)) - (failed (assq-ref evaluation #:failed)) - (scheduled (assq-ref evaluation #:scheduled))) - ;; XXX: Since we don't have information in the database about whether - ;; an evaluation failed, assume that it failed when it produced zero - ;; build jobs. - (if (zero? (+ succeeded failed scheduled)) - `((a (@ (href "/eval/" ,(assq-ref evaluation #:id) "/log/raw") - (class "oi oi-x text-danger") - (title "Failed") - (aria-hidden "true")) - "")) - `((a (@ (href "/eval/" ,(assq-ref evaluation #:id) "?status=succeeded") - (class "badge badge-success") - (title "Succeeded")) - ,succeeded) - (a (@ (href "/eval/" ,(assq-ref evaluation #:id) "?status=failed") - (class "badge badge-danger") - (title "Failed")) - ,failed) - (a (@ (href "/eval/" ,(assq-ref evaluation #:id) "?status=pending") - (class "badge badge-secondary") - (title "Scheduled")) - ,scheduled)))) - '((em "In progress…")))) + (let ((status (assq-ref evaluation #:status))) + (if (= status (evaluation-status started)) + '((em "In progress…")) + (cond + ((= status (evaluation-status failed)) + `((a (@ (href "/eval/" ,(assq-ref evaluation #:id) "/log/raw") + (class "oi oi-x text-danger") + (title "Failed") + (aria-hidden "true")) + ""))) + ((= status (evaluation-status aborted)) + `((a (@ (href "/eval/" ,(assq-ref evaluation #:id) "/log/raw") + (class "oi oi-x text-warning") + (title "Aborted") + (aria-hidden "true")) + ""))) + ((= status (evaluation-status succeeded)) + `((a (@ (href "/eval/" ,(assq-ref evaluation #:id) + "?status=succeeded") + (class "badge badge-success") + (title "Succeeded")) + ,(assq-ref evaluation #:succeeded)) + (a (@ (href "/eval/" ,(assq-ref evaluation #:id) + "?status=failed") + (class "badge badge-danger") + (title "Failed")) + ,(assq-ref evaluation #:failed)) + (a (@ (href "/eval/" ,(assq-ref evaluation #:id) + "?status=pending") + (class "badge badge-secondary") + (title "Scheduled")) + ,(assq-ref evaluation #:scheduled)))))))) (define (evaluation-info-table name evaluations id-min id-max) "Return HTML for the EVALUATION table NAME. ID-MIN and ID-MAX are diff --git a/src/schema.sql b/src/schema.sql index d1b38ae..335a6d4 100644 --- a/src/schema.sql +++ b/src/schema.sql @@ -41,7 +41,7 @@ CREATE TABLE Checkouts ( CREATE TABLE Evaluations ( id INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT, specification TEXT NOT NULL, - in_progress INTEGER NOT NULL, + status INTEGER NOT NULL, timestamp INTEGER NOT NULL, checkouttime INTEGER NOT NULL, evaltime INTEGER NOT NULL, diff --git a/src/sql/upgrade-10.sql b/src/sql/upgrade-10.sql new file mode 100644 index 0000000..0ad299c --- /dev/null +++ b/src/sql/upgrade-10.sql @@ -0,0 +1,12 @@ +BEGIN TRANSACTION; + +ALTER TABLE Evaluations RENAME COLUMN in_progress TO status; + +-- Set all pending evaluations to aborted. +UPDATE Evaluations SET status = 2 WHERE status = 1; + +-- All evaluations that did not trigger any build are set to failed. +UPDATE Evaluations SET status = 1 WHERE id NOT IN +(SELECT evaluation FROM Builds); + +COMMIT; diff --git a/tests/database.scm b/tests/database.scm index 8fd663d..01d7e67 100644 --- a/tests/database.scm +++ b/tests/database.scm @@ -97,14 +97,14 @@ (test-assert "sqlite-exec" (begin (sqlite-exec (%db) "\ -INSERT INTO Evaluations (specification, in_progress, -timestamp, checkouttime, evaltime) VALUES (1, false, 0, 0, 0);") +INSERT INTO Evaluations (specification, status, +timestamp, checkouttime, evaltime) VALUES (1, 0, 0, 0, 0);") (sqlite-exec (%db) "\ -INSERT INTO Evaluations (specification, in_progress, -timestamp, checkouttime, evaltime) VALUES (2, false, 0, 0, 0);") +INSERT INTO Evaluations (specification, status, +timestamp, checkouttime, evaltime) VALUES (2, 0, 0, 0, 0);") (sqlite-exec (%db) "\ -INSERT INTO Evaluations (specification, in_progress, -timestamp, checkouttime, evaltime) VALUES (3, false, 0, 0, 0);") +INSERT INTO Evaluations (specification, status, +timestamp, checkouttime, evaltime) VALUES (3, 0, 0, 0, 0);") (sqlite-exec (%db) "SELECT * FROM Evaluations;"))) (test-equal "db-add-specification" diff --git a/tests/http.scm b/tests/http.scm index f80e515..e2d6982 100644 --- a/tests/http.scm +++ b/tests/http.scm @@ -78,7 +78,7 @@ (define evaluations-query-result #(((#:id . 2) (#:specification . "guix") - (#:in-progress . 1) + (#:status . -1) (#:checkouts . #(((#:commit . "fakesha2") (#:input . "savannah") (#:directory . "dir3"))))))) |