database: Add a Checkouts table.

It is used to know when a new evaluation must be triggered and to display
input changes.

* Makefile.am (dist_sql_DATA): Add 'src/sql/upgrade-3.sql'.
* bin/cuirass.in (main): Call DB-SET-EVALUATION-DONE at startup to clear
'in-progress' evaluations.
* bin/evaluate.in (input-checkout, format-checkouts): Rename '#:name' to
'#:input'.
* doc/cuirass.texi (Stamps): Remove section.
(Checkouts): New section.
* src/cuirass/base.scm (fetch-input, fetch-inputs, compile-checkouts): Rename
'#:name' to '#:input'.
(evaluate): Remove the COMMITS argument.  Add an EVAL-ID argument.  Don't call
DB-ADD-EVALUATION because it was called sooner.  Remove the EVAL-ID argument
to AUGMENT-JOB because it's a closure.
(build-packages): Add an EVAL-ID argument.  Call DB-SET-EVALUATION-DONE once
all the derivations are registered.
(process-specs): Replace the stamping mechanism by the primary key constraint
of the Checkouts table: call "evaluate" only when DB-ADD-EVALUATION is true,
which means that at least one checkout was added.  Change the EVALUATE and
BUILD-PACKAGES arguments accordingly.
* src/cuirass/database.scm (db-add-stamp, db-get-stamp): Remove procedures.
(db-set-evaluations-done, db-set-evaluation-done): New exported procedure.
(db-add-checkout): New procedure that returns #f if a checkout with the same
revision already exists.
(db-add-evaluation): Replace the EVAL argument with a SPEC-NAME and a
CHECKOUTS arguments.  Insert the evaluation only if at least one checkout was
inserted.  Return #f otherwise.
(db-get-checkouts): New procedure.
(db-get-evaluations, db-get-evaluations-build-summary): Handle the
'in_progress' column, remove the 'commits' column.  Return the result of
DB-GET-CHECKOUTS as part of the evaluation.
* src/cuirass/templates.scm (input-changes, evaluation-badges): New
procedures.
(evaluation-info-table): Rename "Commits" to "Input changes".  Use
INPUT-CHANGES to display the input changes that triggered the evaluation.  Use
EVALUATION-BADGES to display a message indicating that the evaluation is in
progress.
* src/schema.sql (Stamps): Remove table.
(Checkouts): New table.
(Evaluations): Remove the 'commits' column.  Add an 'in_progress' column.
* src/sql/upgrade-3.sql: New file with SQL queries to upgrade the database.
* tests/database.scm (make-dummy-eval): Remove procedure.
(make-dummy-checkouts): New procedure.
("sqlite-exec"): Remove the 'commits' column.  Add the 'in_progress' column.
("db-update-build-status!", "db-get-builds", "db-get-pending-derivations"):
Update the arguments of DB-ADD-EVALUATION accordingly.
* tests/http.scm (hash-table=?): Add support for lists of hash tables.
(evaluations-query-result): Replace '#:commits' with '#:checkouts'.  Return a
list instead of returning one element, for symmetry.
("fill-db"): Add a new input so that the second checkout can refer to it.
Replace EVALUATION1 and EVALUATION2 with CHECKOUTS1 and CHECKOUTS2.  Update
the arguments of DB-ADD-EVALUATION accordingly.
("/api/queue?nr=100"): Take the CAR of the EVALUATIONS-QUERY-RESULT list to
make it symmetrical with the other argument of HASH-TABLE=?.

5 files changed, 175 insertions, 76 deletions

diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index 1ec122c..deee05b 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -178,7 +178,7 @@ read-only directory."
                                                (string-append
                                                 (%package-cachedir) "/" name))
                            directory)))
-        `((#:name . ,name)
+        `((#:input . ,name)
           (#:directory . ,directory)
           (#:commit . ,commit)
           (#:load-path . ,(assq-ref input #:load-path))
@@ -248,10 +248,10 @@ fibers."
                    (logior (@ (fibers epoll) EPOLLERR)
                            (@ (fibers epoll) EPOLLHUP)))))
 
-(define (evaluate store spec checkouts commits)
+(define (evaluate store spec eval-id checkouts)
   "Evaluate and build package derivations defined in SPEC, using CHECKOUTS.
-Return a list of jobs."
-  (define (augment-job job eval-id)
+Return a list of jobs that are associated to EVAL-ID."
+  (define (augment-job job)
     (let ((drv (read-derivation-from-file
                 (assq-ref job #:derivation))))
       `((#:eval-id . ,eval-id)
@@ -275,14 +275,9 @@ Return a list of jobs."
     (close-pipe port)
     (match result
       (('evaluation jobs)
-       (let* ((spec-name (assq-ref spec #:name))
-              (eval-id (db-add-evaluation
-                        `((#:specification . ,spec-name)
-                          (#:commits . ,commits)))))
-         (log-message "created evaluation ~a for '~a'" eval-id spec-name)
-         (map (lambda (job)
-                (augment-job job eval-id))
-              jobs))))))
+       (let* ((spec-name (assq-ref spec #:name)))
+         (log-message "evaluation ~a for '~a' completed" eval-id spec-name)
+         (map augment-job jobs))))))
 
 
 ;;;
@@ -539,7 +534,7 @@ started)."
       (spawn-builds store valid)
       (log-message "done with restarted builds"))))
 
-(define (build-packages store jobs)
+(define (build-packages store jobs eval-id)
   "Build JOBS and return a list of Build results."
   (define (register job)
     (let* ((name     (assq-ref job #:job-name))
@@ -576,6 +571,10 @@ started)."
   (define derivations
     (filter-map register jobs))
 
+  (log-message "evaluation ~a registered ~a new derivations"
+               eval-id (length derivations))
+  (db-set-evaluation-done eval-id)
+
   (spawn-builds store derivations)
 
   (let* ((results (filter-map (cut db-get-build <>) derivations))
@@ -625,7 +624,7 @@ started)."
          (results (par-map %non-blocking thunks)))
     (map (lambda (checkout)
            (log-message "fetched input '~a' of spec '~a' (commit ~s)"
-                        (assq-ref checkout #:name)
+                        (assq-ref checkout #:input)
                         (assq-ref spec #:name)
                         (assq-ref checkout #:commit))
            checkout)
@@ -638,7 +637,7 @@ started)."
            (lambda (checkout)
              (lambda ()
                (log-message "compiling input '~a' of spec '~a' (commit ~s)"
-                            (assq-ref checkout #:name)
+                            (assq-ref checkout #:input)
                             (assq-ref spec #:name)
                             (assq-ref checkout #:commit))
                (compile checkout)))
@@ -646,7 +645,7 @@ started)."
          (results (par-map %non-blocking thunks)))
     (map (lambda (checkout)
            (log-message "compiled input '~a' of spec '~a' (commit ~s)"
-                        (assq-ref checkout #:name)
+                        (assq-ref checkout #:input)
                         (assq-ref spec #:name)
                         (assq-ref checkout #:commit))
            checkout)
@@ -656,15 +655,10 @@ started)."
   "Evaluate and build JOBSPECS and store results in the database."
   (define (process spec)
     (with-store store
-      (let* ((stamp (db-get-stamp spec))
-             (name (assoc-ref spec #:name))
+      (let* ((name (assoc-ref spec #:name))
              (checkouts (fetch-inputs spec))
-             (commits (map (cut assq-ref <> #:commit) checkouts))
-             (commits-str (string-join commits)))
-        (unless (equal? commits-str stamp)
-          ;; Immediately mark SPEC's INPUTS as being processed so we don't
-          ;; spawn a concurrent evaluation of that same commit.
-          (db-add-stamp spec commits-str)
+             (eval-id (db-add-evaluation name checkouts)))
+        (when eval-id
           (compile-checkouts spec (filter compile? checkouts))
           (spawn-fiber
            (lambda ()
@@ -672,13 +666,12 @@ started)."
                         (log-message "failed to evaluate spec '~a'"
                                      (evaluation-error-spec-name c))
                         #f))
-               (log-message "evaluating spec '~a': stamp ~s different from ~s"
-                            name commits-str stamp)
+               (log-message "evaluating spec '~a'" name)
                (with-store store
-                 (let ((jobs (evaluate store spec checkouts commits)))
+                 (let ((jobs (evaluate store spec eval-id checkouts)))
                    (log-message "building ~a jobs for '~a'"
                                 (length jobs) name)
-                   (build-packages store jobs))))))
+                   (build-packages store jobs eval-id))))))
 
           ;; 'spawn-fiber' returns zero values but we need one.
           *unspecified*))))
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index 912039e..6777d28 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -38,9 +38,9 @@
             db-close
             db-add-specification
             db-get-specifications
-            db-add-stamp
-            db-get-stamp
             db-add-evaluation
+            db-set-evaluations-done
+            db-set-evaluation-done
             db-get-pending-derivations
             build-status
             db-add-build
@@ -265,6 +265,29 @@ tag, revision, no_compile_p) VALUES ("
                  (if (assq-ref input #:no-compile?) 1 0) ");")
     (last-insert-rowid db)))
 
+(define (db-add-checkout spec-name eval-id checkout)
+  "Insert CHECKOUT associated with SPEC-NAME and EVAL-ID.  If a checkout with
+the same revision already exists for SPEC-NAME, return #f."
+  (with-db-critical-section db
+    (catch 'sqlite-error
+      (lambda ()
+        (sqlite-exec db "\
+INSERT INTO Checkouts (specification, revision, evaluation, input,
+directory) VALUES ("
+                     spec-name ", "
+                     (assq-ref checkout #:commit) ", "
+                     eval-id ", "
+                     (assq-ref checkout #:input) ", "
+                     (assq-ref checkout #:directory) ");")
+        (last-insert-rowid db))
+      (lambda (key who code message . rest)
+        ;; If we get a unique-constraint-failed error, that means we have
+        ;; already inserted the same checkout.  That happens for each input
+        ;; that doesn't change between two evaluations.
+        (if (= code SQLITE_CONSTRAINT_PRIMARYKEY)
+            #f
+            (apply throw key who code rest))))))
+
 (define (db-add-specification spec)
   "Store SPEC in database the database.  SPEC inputs are stored in the INPUTS
 table."
@@ -328,13 +351,31 @@ package_path_inputs, proc_input, proc_file, proc, proc_args) \
                        (#:inputs . ,(db-get-inputs name)))
                      specs)))))))
 
-(define (db-add-evaluation eval)
+(define (db-add-evaluation spec-name checkouts)
+  "Add a new evaluation for SPEC-NAME only if one of the CHECKOUTS is new.
+Otherwise, return #f."
   (with-db-critical-section db
-    (sqlite-exec db "\
-INSERT INTO Evaluations (specification, commits) VALUES ("
-                 (assq-ref eval #:specification) ", "
-                 (string-join (assq-ref eval #:commits)) ");")
-    (last-insert-rowid db)))
+    (sqlite-exec db "BEGIN TRANSACTION;")
+    (sqlite-exec db "INSERT INTO Evaluations (specification, in_progress)
+VALUES (" spec-name ", true);")
+    (let* ((eval-id (last-insert-rowid db))
+           (new-checkouts (filter-map
+                           (cut db-add-checkout spec-name eval-id <>)
+                           checkouts)))
+      (if (null? new-checkouts)
+          (begin (sqlite-exec db "ROLLBACK;")
+                 #f)
+          (begin (sqlite-exec db "COMMIT;")
+                 eval-id)))))
+
+(define (db-set-evaluations-done)
+  (with-db-critical-section db
+    (sqlite-exec db "UPDATE Evaluations SET in_progress = false;")))
+
+(define (db-set-evaluation-done eval-id)
+  (with-db-critical-section db
+    (sqlite-exec db "UPDATE Evaluations SET in_progress = false
+WHERE id = " eval-id ";")))
 
 (define-syntax-rule (with-database body ...)
   "Run BODY with %DB-CHANNEL being dynamically bound to a channel implementing
@@ -568,46 +609,44 @@ the database.  The returned list is guaranteed to not have any duplicates."
          (sqlite-exec db "
 SELECT derivation FROM Builds WHERE Builds.status < 0;"))))
 
-(define (db-get-stamp spec)
-  "Return a stamp corresponding to specification SPEC in the database."
-  (with-db-critical-section db
-    (let ((res (sqlite-exec db "SELECT * FROM Stamps WHERE specification="
-                            (assq-ref spec #:name) ";")))
-      (match res
-        (() #f)
-        ((#(spec stamp)) stamp)))))
-
-(define (db-add-stamp spec stamp)
-  "Associate STAMP to specification SPEC in the database."
+(define (db-get-checkouts eval-id)
   (with-db-critical-section db
-    (if (db-get-stamp spec)
-        (sqlite-exec db "UPDATE Stamps SET stamp=" stamp
-                     "WHERE specification=" (assq-ref spec #:name) ";")
-        (sqlite-exec db "\
-INSERT INTO Stamps (specification, stamp) VALUES ("
-                     (assq-ref spec #:name) ", " stamp ");"))))
+    (let loop ((rows (sqlite-exec
+                      db "SELECT revision, input, directory FROM Checkouts
+WHERE evaluation =" eval-id ";"))
+               (checkouts '()))
+      (match rows
+        (() checkouts)
+        ((#(revision input directory)
+           . rest)
+         (loop rest
+               (cons `((#:commit . ,revision)
+                       (#:input . ,input)
+                       (#:directory . ,directory))
+                     checkouts)))))))
 
 (define (db-get-evaluations limit)
   (with-db-critical-section db
-    (let loop ((rows  (sqlite-exec db "SELECT id, specification, commits
+    (let loop ((rows  (sqlite-exec db "SELECT id, specification, in_progress
 FROM Evaluations ORDER BY id DESC LIMIT " limit ";"))
                (evaluations '()))
       (match rows
         (() (reverse evaluations))
-        ((#(id specification commits)
+        ((#(id specification in-progress)
            . rest)
          (loop rest
                (cons `((#:id . ,id)
                        (#:specification . ,specification)
-                       (#:commits . ,(string-tokenize commits)))
+                       (#:in-progress . ,in-progress)
+                       (#:checkouts . ,(db-get-checkouts id)))
                      evaluations)))))))
 
 (define (db-get-evaluations-build-summary spec limit border-low border-high)
   (with-db-critical-section db
     (let loop ((rows (sqlite-exec db "
-SELECT E.id, E.commits, B.succeeded, B.failed, B.scheduled
+SELECT E.id, E.in_progress, B.succeeded, B.failed, B.scheduled
 FROM
-(SELECT id, commits
+(SELECT id, in_progress
 FROM Evaluations
 WHERE (specification=" spec ")
 AND (" border-low "IS NULL OR (id >" border-low "))
@@ -624,10 +663,12 @@ ORDER BY E.id ASC;"))
                (evaluations '()))
       (match rows
         (() evaluations)
-        ((#(id commits succeeded failed scheduled) . rest)
+        ((#(id in-progress succeeded failed scheduled) . rest)
          (loop rest
                (cons `((#:id . ,id)
-                       (#:commits . ,commits)
+                       (#:in-progress . ,in-progress)
+                       (#:checkouts . ,(db-get-checkouts id))
+                       (#:in-progress . ,in-progress)
                        (#:succeeded . ,(or succeeded 0))
                        (#:failed . ,(or failed 0))
                        (#:scheduled . ,(or scheduled 0)))
diff --git a/src/cuirass/templates.scm b/src/cuirass/templates.scm
index 6ba3a06..7ee579c 100644
--- a/src/cuirass/templates.scm
+++ b/src/cuirass/templates.scm
@@ -100,6 +100,27 @@
                        (href ,last-link))
                     "Last >>"))))))
 
+(define (input-changes checkouts)
+  (let ((changes
+         (string-join
+          (map (lambda (checkout)
+                 (let ((input (assq-ref checkout #:input))
+                       (commit (assq-ref checkout #:commit)))
+                   (format #f "~a → ~a" input (substring commit 0 7))))
+               checkouts)
+          ", ")))
+    (if (string=? changes "") '(em "None") changes)))
+
+(define (evaluation-badges evaluation)
+  (if (zero? (assq-ref evaluation #:in-progress))
+      `((a (@ (href "#") (class "badge badge-success"))
+           ,(assq-ref evaluation #:succeeded))
+        (a (@ (href "#") (class "badge badge-danger"))
+           ,(assq-ref evaluation #:failed))
+        (a (@ (href "#") (class "badge badge-secondary"))
+           ,(assq-ref evaluation #:scheduled)))
+      '((em "In progress…"))))
+
 (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."
@@ -111,7 +132,7 @@
            `((thead
               (tr
                (th (@ (scope "col")) "#")
-               (th (@ (scope "col")) Commits)
+               (th (@ (scope "col")) "Input changes")
                (th (@ (scope "col")) Success)))
              (tbody
               ,@(map
@@ -119,16 +140,8 @@
                    `(tr (th (@ (scope "row"))
                             (a (@ (href "/eval/" ,(assq-ref row #:id)))
                                ,(assq-ref row #:id)))
-                        (td ,(string-join
-                              (map (cut substring <> 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)))))
+                        (td ,(input-changes (assq-ref row #:checkouts)))
+                        (td ,@(evaluation-badges row))))
                  evaluations)))))
     ,(if (null? evaluations)
          (pagination "" "" "" "")
diff --git a/src/schema.sql b/src/schema.sql
index 0452495..bfc9ca7 100644
--- a/src/schema.sql
+++ b/src/schema.sql
@@ -24,16 +24,22 @@ CREATE TABLE Inputs (
   FOREIGN KEY (specification) REFERENCES Specifications (name)
 );
 
-CREATE TABLE Stamps (
-  specification TEXT NOT NULL PRIMARY KEY,
-  stamp         TEXT NOT NULL,
-  FOREIGN KEY (specification) REFERENCES Specifications (name)
+CREATE TABLE Checkouts (
+  specification TEXT NOT NULL,
+  revision      TEXT NOT NULL,
+  evaluation    INTEGER NOT NULL,
+  input         TEXT NOT NULL,
+  directory     TEXT NOT NULL,
+  PRIMARY KEY (specification, revision),
+  FOREIGN KEY (evaluation) REFERENCES Evaluations (id),
+  FOREIGN KEY (specification) REFERENCES Specifications (name),
+  FOREIGN KEY (input) REFERENCES Inputs (name)
 );
 
 CREATE TABLE Evaluations (
   id            INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT,
   specification TEXT NOT NULL,
-  commits       TEXT NOT NULL,
+  in_progress   INTEGER NOT NULL,
   FOREIGN KEY (specification) REFERENCES Specifications (name)
 );
 
diff --git a/src/sql/upgrade-3.sql b/src/sql/upgrade-3.sql
new file mode 100644
index 0000000..8e4a1bd
--- /dev/null
+++ b/src/sql/upgrade-3.sql
@@ -0,0 +1,46 @@
+BEGIN TRANSACTION;
+
+ALTER TABLE Evaluations RENAME TO tmp_Evaluations;
+
+CREATE TABLE Evaluations (
+  id            INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT,
+  specification TEXT NOT NULL,
+  in_progress   INTEGER NOT NULL,
+  FOREIGN KEY (specification) REFERENCES Specifications (name)
+);
+
+CREATE TABLE Checkouts (
+  specification TEXT NOT NULL,
+  revision      TEXT NOT NULL,
+  evaluation    INTEGER NOT NULL,
+  input         TEXT NOT NULL,
+  directory     TEXT NOT NULL,
+  PRIMARY KEY (specification, revision),
+  FOREIGN KEY (evaluation) REFERENCES Evaluations (id),
+  FOREIGN KEY (specification) REFERENCES Specifications (name),
+  FOREIGN KEY (input) REFERENCES Inputs (name)
+);
+
+INSERT INTO Evaluations (id, specification, in_progress)
+SELECT id, specification, false
+FROM tmp_Evaluations;
+
+-- Copied from https://www.samuelbosch.com/2018/02/split-into-rows-sqlite.html.
+INSERT OR IGNORE INTO Checkouts (specification, revision, evaluation, input, directory)
+WITH RECURSIVE split(id, specification, revision, rest) AS (
+  SELECT id, specification, '', commits || ' ' FROM tmp_Evaluations
+   UNION ALL
+  SELECT id,
+         specification,
+         substr(rest, 0, instr(rest, ' ')),
+         substr(rest, instr(rest, ' ') + 1)
+    FROM split
+   WHERE rest <> '')
+SELECT specification, revision, id, 'unknown', 'unknown'
+  FROM split
+ WHERE revision <> '';
+
+DROP TABLE tmp_Evaluations;
+DROP TABLE Stamps;
+
+COMMIT;