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.

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")))))))