branch: main
commit 5e5912717957d294de83e5dcea894214ad97ac75
Author: Ludovic Courtès <l...@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
