[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[no subject]
|
From: |
Mathieu Othacehe |
|
Date: |
Thu, 10 Sep 2020 09:16:58 -0400 (EDT) |
branch: master
commit f5b0d39328567a20336945bf1e2ff93aff1a9973
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Thu Sep 10 14:25:19 2020 +0200
Add a status field to Evaluation table.
The Evaluation table currently has an 'in_progress' field. Distinction
between
succeeded and failed evaluations are based on the presence of Builds records
for the evaluation. It it also not possible to distinguish aborted
evaluations
from failed evaluations.
Rename 'in_progress' field to 'status'. The 'status' field can be equal to
'started', 'succeeded', 'failed' or 'aborted'.
* src/cuirass/database.scm (evaluation-status): New exported enumeration.
(db-set-evaluations-done, db-set-evaluation-done): Remove them.
(db-abort-pending-evaluations, db-set-evaluation-status): New exported
procedures.
(db-add-evaluation, db-get-builds, db-get-evaluations,
db-get-evaluations-build-summary, db-get-evaluation-summary): Adapt to use
'status' field instead of 'in_progress' field.
* src/cuirass/templates.scm (evaluation-badges): Ditto.
* src/schema.sql (Evaluations): Rename 'in_progress' field to 'status'.
* src/sql/upgrade-10.sql: New file.
* bin/cuirass.in (main): Use "db-abort-pending-evaluations" instead of
"db-set-evaluations-done".
* src/cuirass/base.scm (evaluate): Use "db-set-evaluation-status" instead of
"db-set-evaluations-done".
(build-packages): Use "db-set-evaluation-status" instead of
"db-set-evaluation-done".
* tests/database.scm (sqlite-exec): Adapt accordingly.
* tests/http.scm (evaluations-query-result): Ditto.
---
bin/cuirass.in | 17 ++++++-------
src/cuirass/base.scm | 6 +++--
src/cuirass/database.scm | 56 ++++++++++++++++++++++++-------------------
src/cuirass/templates.scm | 61 ++++++++++++++++++++++++++---------------------
src/schema.sql | 2 +-
src/sql/upgrade-10.sql | 12 ++++++++++
tests/database.scm | 12 +++++-----
tests/http.scm | 2 +-
8 files changed, 98 insertions(+), 70 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)
-
- ;; First off, restart builds that had not
completed or
- ;; were not even started on a previous run.
+ ;; 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.
(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")))))))