[no subject]

[Mathieu Othacehe]

branch: wip-dependencies
commit 53023bae525154b2ce22ba37cda0b9ce6af32354
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Sat May 1 17:30:19 2021 +0200

    Add build dependencies support.
    
    * src/schema.sql (BuildDependencies): New table.
    * src/cuirass/database.scm (db-add-build-dependencies,
    db-get-build-dependencies): New procedures.
    * tests/database.scm ("db-add-build-dependencies",
    "db-get-build-dependencies", "dependencies trigger", "dependencies trigger
    restart"): New tests.
---
 src/cuirass/database.scm | 28 ++++++++++++++++++++
 src/schema.sql           | 36 ++++++++++++++++++++++++++
 tests/database.scm       | 66 ++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 130 insertions(+)

diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index 4f4fd98..259008d 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -71,6 +71,8 @@
             db-get-build-percentages
             db-get-jobs
             db-get-jobs-history
+            db-add-build-dependencies
+            db-get-build-dependencies
             db-register-builds
             db-update-build-status!
             db-update-build-worker!
@@ -788,6 +790,32 @@ AND Jobs.name = ANY(:names);")
                                (#:jobs . ,(list job)))
                              evaluations))))))))))
 
+(define (db-add-build-dependencies source-derivation target-derivations)
+  "Insert into the BuildDependencies table the TARGET-DERIVATIONS as
+dependencies of the given SOURCE-DERIVATION."
+  (define target
+    (format #f "{~a}"
+            (string-join target-derivations ",")))
+
+  (with-db-worker-thread db
+    (exec-query/bind db "
+INSERT INTO BuildDependencies
+(SELECT Builds.id, deps.id FROM Builds,
+(SELECT id FROM Builds WHERE derivation = ANY(" target ")) deps
+WHERE Builds.derivation = " source-derivation ");")))
+
+(define (db-get-build-dependencies build)
+  "Return the list of the given BUILD dependencies."
+  (with-db-worker-thread db
+    (let loop ((rows (exec-query/bind db "
+SELECT target FROM BuildDependencies WHERE source = " build))
+               (dependencies '()))
+      (match rows
+        (() (reverse dependencies))
+        (((target) . rest)
+         (loop rest
+               (cons (string->number target) dependencies)))))))
+
 (define (db-register-builds jobs eval-id specification)
   (define (new-outputs? outputs)
     (let ((new-outputs
diff --git a/src/schema.sql b/src/schema.sql
index d1479a0..17e1147 100644
--- a/src/schema.sql
+++ b/src/schema.sql
@@ -58,6 +58,13 @@ CREATE TABLE Builds (
   FOREIGN KEY (evaluation) REFERENCES Evaluations(id) ON DELETE CASCADE
 );
 
+CREATE TABLE BuildDependencies (
+  source        INTEGER NOT NULL,
+  target        INTEGER NOT NULL,
+  FOREIGN KEY (source) REFERENCES Builds(id) ON DELETE CASCADE,
+  FOREIGN KEY (target) REFERENCES Builds(id) ON DELETE CASCADE
+);
+
 CREATE TABLE Jobs (
   name          TEXT NOT NULL,
   evaluation    INTEGER NOT NULL,
@@ -145,6 +152,35 @@ CREATE TRIGGER build_status AFTER UPDATE ON Builds
 FOR EACH ROW
 EXECUTE PROCEDURE update_job_status();
 
+CREATE OR REPLACE FUNCTION pending_dependencies(build bigint)
+RETURNS TABLE (pending_count bigint) AS $$
+SELECT COALESCE(count(dep.id), 0) AS pending_count FROM Builds
+LEFT JOIN BuildDependencies AS bd ON builds.id = bd.source
+LEFT JOIN Builds AS dep ON bd.target = dep.id AND dep.status != 0
+WHERE Builds.id = $1 GROUP BY builds.id;
+$$ LANGUAGE sql;
+
+CREATE OR REPLACE FUNCTION update_build_dependencies()
+RETURNS TRIGGER AS $$
+BEGIN
+IF NEW.status = ANY('{-2, 1, 2, 3, 4}') THEN
+UPDATE builds SET status = dep.status FROM
+(SELECT source,
+CASE
+WHEN NEW.status = 1 OR NEW.status = 2 OR NEW.status = 3 THEN 2
+WHEN NEW.status = 4 THEN 4
+ELSE NEW.status END status
+FROM BuildDependencies WHERE target = NEW.id) AS dep
+WHERE dep.source = Builds.id;
+END IF;
+RETURN null;
+END
+$$ LANGUAGE plpgsql;
+
+CREATE TRIGGER build_dependencies AFTER UPDATE ON Builds
+FOR EACH ROW
+EXECUTE PROCEDURE update_build_dependencies();
+
 CREATE INDEX Jobs_name ON Jobs (name);
 CREATE INDEX Jobs_system_status ON Jobs (system, status);
 CREATE INDEX Jobs_build ON Jobs (build); --speeds up delete cascade.
diff --git a/tests/database.scm b/tests/database.scm
index b54bae2..a6ed03b 100644
--- a/tests/database.scm
+++ b/tests/database.scm
@@ -679,6 +679,72 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 
0, 0);")
     (let ((id (db-register-dashboard "guix" "emacs")))
       (assq-ref (db-get-dashboard id) #:specification)))
 
+  (test-assert "db-add-build-dependencies"
+    (begin
+      (db-add-build-dependencies "/build-1.drv"
+                                 (list "/build-2.drv"))))
+
+  (test-assert "db-get-build-dependencies"
+    (begin
+      (let* ((drv1 "/build-1.drv")
+             (drv2 "/build-2.drv")
+             (id1 (assq-ref (db-get-build drv1) #:id))
+             (id2 (assq-ref (db-get-build drv2) #:id)))
+        (match (db-get-build-dependencies id1)
+          ((id) (eq? id id2))))))
+
+  (test-assert "dependencies trigger"
+    (begin
+      (let ((drv-1
+             (db-add-build (make-dummy-build "/build-dep-1.drv")))
+            (drv-2
+             (db-add-build (make-dummy-build "/build-dep-2.drv")))
+            (drv-3
+             (db-add-build (make-dummy-build "/build-dep-3.drv")))
+            (drv-4
+             (db-add-build (make-dummy-build "/build-dep-4.drv")))
+            (drv-5
+             (db-add-build (make-dummy-build "/build-dep-5.drv")))
+            (drv-6
+             (db-add-build (make-dummy-build "/build-dep-6.drv")))
+            (drv-7
+             (db-add-build (make-dummy-build "/build-dep-7.drv")))
+            (status (lambda (drv)
+                      (assq-ref (db-get-build drv) #:status))))
+        (db-add-build-dependencies "/build-dep-2.drv"
+                                   (list "/build-dep-1.drv"))
+        (db-add-build-dependencies "/build-dep-4.drv"
+                                   (list "/build-dep-1.drv"
+                                         "/build-dep-3.drv"))
+        (db-add-build-dependencies "/build-dep-6.drv"
+                                   (list "/build-dep-4.drv"
+                                         "/build-dep-5.drv"))
+        (db-add-build-dependencies "/build-dep-7.drv"
+                                   (list "/build-dep-4.drv"))
+        (db-update-build-status! drv-1 (build-status failed))
+        (db-update-build-status! drv-2 (build-status succeeded))
+        (db-update-build-status! drv-5 (build-status canceled))
+        (and (eq? (status drv-4) (build-status failed-dependency))
+             (eq? (status drv-6) (build-status canceled))
+             (eq? (status drv-7) (build-status failed-dependency))))))
+
+  (test-assert "dependencies trigger restart"
+    (begin
+      (let ((drv-1 "/build-dep-1.drv")
+            (drv-2 "/build-dep-2.drv")
+            (drv-4 "/build-dep-4.drv")
+            (drv-5 "/build-dep-5.drv")
+            (drv-6 "/build-dep-6.drv")
+            (drv-7 "/build-dep-7.drv")
+            (status (lambda (drv)
+                      (assq-ref (db-get-build drv) #:status))))
+        (db-update-build-status! drv-1 (build-status scheduled))
+        (and (eq? (status drv-2) (build-status scheduled))
+             (eq? (status drv-4) (build-status scheduled))
+             (eq? (status drv-5) (build-status canceled))
+             (eq? (status drv-6) (build-status scheduled))
+             (eq? (status drv-7) (build-status scheduled))))))
+
   (test-assert "db-close"
     (begin
       (false-if-exception (delete-file tmp-mail))