database: Add builds only if one of their outputs is new.

* Makefile.am (dist_sql_DATA): Add 'src/sql/upgrade-4.sql'.
* src/cuirass/database.scm (db-add-output): New procedure.
(db-add-build): Call DB-ADD-OUTPUT, rollback the transaction and return #f if
DB-ADD-OUTPUT returned an empty list.
* src/schema.sql (Outputs): Set 'path' as primary key, instead of 'derivation,
name'.
* src/sql/upgrade-4.sql: New file with SQL queries to upgrade the database.
* tests/database.scm (make-dummy-build): Use the #:OUTPUTS key.  Get default
OUTPUTS to depend on DRV.
("db-add-build-with-fixed-output"): New test.

5 files changed, 69 insertions, 17 deletions

diff --git a/Makefile.am b/Makefile.am
index 2f83659..7cea2ff 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -67,7 +67,8 @@ dist_pkgdata_DATA = src/schema.sql
 dist_sql_DATA = 				\
   src/sql/upgrade-1.sql				\
   src/sql/upgrade-2.sql				\
-  src/sql/upgrade-3.sql
+  src/sql/upgrade-3.sql				\
+  src/sql/upgrade-4.sql
 
 dist_css_DATA =					\
   src/static/css/bootstrap.css			\
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index 6777d28..9664f1b 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -425,12 +425,33 @@ string."
   (failed-other      3)
   (canceled          4))
 
+(define (db-add-output derivation output)
+  "Insert OUTPUT associated with DERIVATION.  If an output with the same path
+already exists, return #f."
+  (with-db-critical-section db
+    (catch 'sqlite-error
+      (lambda ()
+        (match output
+          ((name . path)
+           (sqlite-exec db "\
+INSERT INTO Outputs (derivation, name, path) VALUES ("
+                        derivation ", " name ", " path ");")))
+        (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 output.  That happens with fixed-output
+        ;; derivations.
+        (if (= code SQLITE_CONSTRAINT_PRIMARYKEY)
+            #f
+            (apply throw key who code rest))))))
+
 (define (db-add-build build)
-  "Store BUILD in database the database.  BUILD eventual outputs are stored in
-the OUTPUTS table."
+  "Store BUILD in database the database only if one of its outputs is new.
+Return #f otherwise.  BUILD outputs are stored in the OUTPUTS table."
   (with-db-critical-section db
     (catch 'sqlite-error
       (lambda ()
+        (sqlite-exec db "BEGIN TRANSACTION;")
         (sqlite-exec db "
 INSERT INTO Builds (derivation, evaluation, job_name, system, nix_name, log,
 status, timestamp, starttime, stoptime)
@@ -446,21 +467,22 @@ VALUES ("
                      (or (assq-ref build #:timestamp) 0) ", "
                      (or (assq-ref build #:starttime) 0) ", "
                      (or (assq-ref build #:stoptime) 0) ");")
-        (let ((derivation (assq-ref build #:derivation)))
-          (for-each (lambda (output)
-                      (match output
-                        ((name . path)
-                         (sqlite-exec db "\
-INSERT INTO Outputs (derivation, name, path) VALUES ("
-                                      derivation ", " name ", " path ");"))))
-                    (assq-ref build #:outputs))
-          derivation))
+        (let* ((derivation (assq-ref build #:derivation))
+               (outputs (assq-ref build #:outputs))
+               (new-outputs (filter-map (cut db-add-output derivation <>)
+                                        outputs)))
+          (if (null? new-outputs)
+              (begin (sqlite-exec db "ROLLBACK;")
+                     #f)
+              (begin (sqlite-exec db "COMMIT;")
+                     derivation))))
       (lambda (key who code message . rest)
         ;; If we get a unique-constraint-failed error, that means we have
         ;; already inserted the same build.  That happens when several jobs
         ;; produce the same derivation, and we can ignore it.
         (if (= code SQLITE_CONSTRAINT_PRIMARYKEY)
-            #f
+            (begin (sqlite-exec db "ROLLBACK;")
+                   #f)
             (apply throw key who code rest))))))
 
 (define* (db-update-build-status! drv status #:key log-file)
diff --git a/src/schema.sql b/src/schema.sql
index bfc9ca7..a9e4a6a 100644
--- a/src/schema.sql
+++ b/src/schema.sql
@@ -46,8 +46,7 @@ CREATE TABLE Evaluations (
 CREATE TABLE Outputs (
   derivation TEXT NOT NULL,
   name TEXT NOT NULL,
-  path TEXT NOT NULL,
-  PRIMARY KEY (derivation, name),
+  path TEXT NOT NULL PRIMARY KEY,
   FOREIGN KEY (derivation) REFERENCES Builds (derivation)
 );
 
diff --git a/src/sql/upgrade-4.sql b/src/sql/upgrade-4.sql
new file mode 100644
index 0000000..e567f03
--- /dev/null
+++ b/src/sql/upgrade-4.sql
@@ -0,0 +1,18 @@
+BEGIN TRANSACTION;
+
+ALTER TABLE Outputs RENAME TO tmp_Outputs;
+
+CREATE TABLE Outputs (
+  derivation TEXT NOT NULL,
+  name TEXT NOT NULL,
+  path TEXT NOT NULL PRIMARY KEY,
+  FOREIGN KEY (derivation) REFERENCES Builds (derivation)
+);
+
+INSERT OR IGNORE INTO Outputs (derivation, name, path)
+SELECT derivation, name, path
+FROM tmp_Outputs;
+
+DROP TABLE tmp_Outputs;
+
+COMMIT;
diff --git a/tests/database.scm b/tests/database.scm
index 21a12f4..d9dfe13 100644
--- a/tests/database.scm
+++ b/tests/database.scm
@@ -57,14 +57,15 @@
 
 (define* (make-dummy-build drv
                            #:optional (eval-id 42)
-                           #:key (outputs '(("foo" . "/foo"))))
+                           #:key (outputs
+                                  `(("foo" . ,(format #f "~a.output" drv)))))
   `((#:derivation . ,drv)
     (#:eval-id . ,eval-id)
     (#:job-name . "job")
     (#:system . "x86_64-linux")
     (#:nix-name . "foo")
     (#:log . "log")
-    (#:outputs . (("foo" . "/foo")))))
+    (#:outputs . ,outputs)))
 
 (define-syntax-rule (with-temporary-database body ...)
   (call-with-temporary-output-file
@@ -114,6 +115,17 @@ INSERT INTO Evaluations (specification, in_progress) VALUES (3, false);")
       ;; there, see <https://bugs.gnu.org/28094>.
       (db-add-build build)))
 
+  (test-equal "db-add-build-with-fixed-output"
+    #f
+    (let ((build1 (make-dummy-build "/fixed1.drv"
+                                    #:outputs '(("out" . "/fixed-output"))))
+          (build2 (make-dummy-build "/fixed2.drv"
+                                    #:outputs '(("out" . "/fixed-output")))))
+      (db-add-build build1)
+
+      ;; Should return #f because the outputs are the same.
+      (db-add-build build2)))
+
   (test-equal "db-update-build-status!"
     (list (build-status scheduled)
           (build-status started)