[no subject]

[Ludovic Courtès]

branch: main
commit 5e5912717957d294de83e5dcea894214ad97ac75
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Wed Sep 18 13:08:37 2024 +0200

    database: Synchronously update the status of dependent builds.
    
    * src/cuirass/database.scm (db-reschedule-dependent-builds)
    (db-mark-dependent-builds-as-failed, db-get-build-dependents)
    (list->sql-array): New procedures.
    (db-update-build-status!): Use them to synchronously update the status
    of dependent builds.
    * tests/database.scm ("status of dependent builds"): New test.
    ("dependencies trigger"): Rename to…
    ("dependents marked as 'failed-dependency'"): … this.  Change to
    ‘test-equal’.  Remove call to ‘db-update-failed-builds!’, which is no
    longer needed.
---
 src/cuirass/database.scm | 83 ++++++++++++++++++++++++++++++++++++++++++++++--
 tests/database.scm       | 49 ++++++++++++++++++++++------
 2 files changed, 120 insertions(+), 12 deletions(-)

diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index 70e965a..7e929ac 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -333,6 +333,16 @@ parameters matches the number of arguments to bind."
                       (delete-duplicates args))))
     (exec-query db query (map normalize params))))
 
+(define (list->sql-array lst)
+  "Return the SQL array representation of LST, a list of integers or strings."
+  (string-append "{ " (string-join
+                       (map (match-lambda
+                              ((? number? n) (number->string n))
+                              (str str))
+                            lst)
+                       ",")
+                 " }"))
+
 (define %create-database?
   (make-parameter #f))
 
@@ -1125,6 +1135,61 @@ WHERE dep.source = " build))
 
 (define build-dependencies/id (compose db-get-build-dependencies build-id))
 
+(define (db-reschedule-dependent-builds build)
+  "Reschedule builds that depend on BUILD that only have succeeding
+dependencies.
+
+Note: This is an expensive query but is usually rarely needed."
+  (let ((rescheduled (with-db-connection db
+                       (exec-query/bind db "
+UPDATE Builds SET status = " (build-status scheduled) "
+FROM
+  -- Select the dependents of this build with exactly one failing
+  -- dependency.
+  (SELECT dependents.id
+   FROM
+     -- Get all the dependents of this build.
+     (SELECT Builds.id, Builds.derivation FROM Builds
+      LEFT JOIN BuildDependencies as bd ON bd.source = Builds.id
+      WHERE bd.target = " (build-id build) " GROUP BY Builds.id)
+   AS dependents
+   LEFT JOIN BuildDependencies AS bd ON bd.source = dependents.id
+   LEFT JOIN Builds AS dependencies
+          ON dependencies.id = bd.target AND dependencies.status != 0
+   GROUP BY dependents.id HAVING count(dependencies.id) = 0)
+AS relevantdependents
+WHERE Builds.id = relevantdependents.id;"))))
+    (log-info "rescheduled ~a dependent builds of build ~a (~a)"
+              rescheduled (build-id build) (build-derivation build))
+    rescheduled))
+
+(define (db-get-build-dependents id)
+  "Return the list of IDs of builds that depend on ID."
+  (with-db-connection db
+    (match (exec-query/bind db "
+SELECT source FROM BuildDependencies
+WHERE target = " id ";")
+      (((id) ...)
+       (map string->number id)))))
+
+(define (db-mark-dependent-builds-as-failed build)
+  "Change the status of builds that depend on ID to \"failed-dependency\",
+recursively."
+  ;; Since this is recursive, this cannot be done as a single query.
+  (let loop ((dependents (db-get-build-dependents (build-id build))))
+    (let ((marked (with-db-connection db
+                    (exec-query/bind db "
+UPDATE Builds
+SET status = " (build-status failed-dependency) ",
+    stoptime = (extract(epoch from now()))::int
+WHERE id = ANY(" (list->sql-array dependents) ");"))))
+      (unless (zero? marked)
+        (log-info "marked ~a dependent builds of build ~a (~a) as failed"
+                  marked (build-id build) (build-derivation build))
+
+        ;; Recurse.
+        (loop (append-map db-get-build-dependents dependents))))))
+
 (define (db-update-resumable-builds!)
   "Update the build status of the failed-dependency builds which all
 dependencies are successful to scheduled."
@@ -1246,7 +1311,8 @@ log file for DRV."
         ;; times in a row, for instance.  The 'last_status' field is updated
         ;; with the status of the last completed build with the same
         ;; 'job_name' and 'specification'.
-        (let* ((last-status (db-get-last-status drv))
+        (let* ((build (db-get-build drv))
+               (last-status (db-get-last-status drv))
                (weather (build-status->weather status last-status))
                (rows
                 (exec-query/bind db "
@@ -1256,9 +1322,20 @@ UPDATE Builds SET stoptime =" now
 ", weather = " weather
 "WHERE derivation =" drv
 " AND status != " status ";")))
+
           (when (positive? rows)
-            (let* ((build (db-get-build drv))
-                   (spec (build-specification-name build))
+            (when (= status (build-status failed))
+              ;; Update the status of dependent builds.
+              (db-mark-dependent-builds-as-failed build))
+
+            (when (and (= status (build-status succeeded))
+                       (= (build-current-status build) (build-status failed)))
+              ;; Transitioning from "failed" to "succeeded", for instance
+              ;; because the build was restarted, so reschedule every build 
that
+              ;; depends on this one.
+              (db-reschedule-dependent-builds build))
+
+            (let* ((spec (build-specification-name build))
                    (specification (db-get-specification spec))
                    (notifications
                     (specification-notifications specification)))
diff --git a/tests/database.scm b/tests/database.scm
index 2f20cf5..d3bcc60 100644
--- a/tests/database.scm
+++ b/tests/database.scm
@@ -968,7 +968,8 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0, 
0);")
                      (db-update-build-status! drv (build-status submitted)))
                    (cons drv lst)))))))
 
-  (test-assert "dependencies trigger"
+  (test-equal "dependents marked as 'failed-dependency'"
+    (make-list 3 (build-status failed-dependency))
     (with-fibers
       (let ((drv-1 "/build-dep-1.drv")
             (drv-2 "/build-dep-2.drv")
@@ -977,8 +978,7 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0, 
0);")
             (drv-5 "/build-dep-5.drv")
             (drv-6 "/build-dep-6.drv")
             (drv-7 "/build-dep-7.drv")
-            (status (lambda (drv)
-                      (build-current-status (db-get-build drv)))))
+            (status (compose build-current-status db-get-build)))
         (for-each (compose db-add-build make-dummy-build)
                   (list drv-1 drv-2 drv-3 drv-4
                         drv-5 drv-6 drv-7))
@@ -995,12 +995,43 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 
0, 0);")
         (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))
-        (let loop ()
-          (unless (eq? (db-update-failed-builds!) 0)
-            (loop)))
-        (and (eq? (status drv-4) (build-status failed-dependency))
-             (eq? (status drv-6) (build-status failed-dependency))
-             (eq? (status drv-7) (build-status failed-dependency))))))
+
+        (map status (list drv-4 drv-6 drv-7)))))
+
+  (test-equal "status of dependent builds"
+    `((initial ,(build-status failed-dependency)
+               ,(build-status failed-dependency)
+               ,(build-status failed-dependency))
+      (final ,(build-status scheduled)
+             ,(build-status failed-dependency)
+             ,(build-status scheduled)))
+    (with-fibers
+      (let ((drv '("/primary-drv-1.drv" "/dep-1.drv"
+                   "/primary-drv-2.drv" "/dep-2.drv"
+                   "/primary-drv-3.drv"))
+            (status (compose build-current-status db-get-build)))
+        (for-each (compose db-add-build make-dummy-build) drv)
+        (db-add-build-dependencies "/primary-drv-1.drv"
+                                   '("/dep-1.drv"))
+        (db-add-build-dependencies "/primary-drv-2.drv"
+                                   '("/dep-1.drv" "/dep-2.drv"))
+        (db-add-build-dependencies "/primary-drv-3.drv"
+                                   '("/dep-1.drv"))
+
+        ;; This should mark their dependents as "failed-dependency".
+        (db-update-build-status! "/dep-1.drv" (build-status failed))
+        (db-update-build-status! "/dep-2.drv" (build-status failed))
+
+        (let ((initial (map status '("/primary-drv-1.drv"
+                                     "/primary-drv-2.drv"
+                                     "/primary-drv-3.drv"))))
+          ;; This should reschedule its dependents, but only those that have
+          ;; no other failed dependency.
+          (db-update-build-status! "/dep-1.drv" (build-status succeeded))
+          `((initial ,@initial)
+            (final ,@(map status '("/primary-drv-1.drv"
+                                   "/primary-drv-2.drv"
+                                   "/primary-drv-3.drv"))))))))
 
   (test-equal "db-get-first-build-failure"
     '("/thing.drv2"                               ;last success