branch: main
commit de86524ddb4cef451fee81f680b53f719ea8e47a
Author: Ludovic Courtès <l...@gnu.org>
AuthorDate: Mon Sep 9 11:23:25 2024 +0200
remote-worker: Send ‘build-dependency-failed’ when appropriate.
Previously, builds with a failing dependency that does not have a
corresponding entry in the ‘Builds’ table would be marked as “failed”.
Now they’re marked as “dependency-failed”.
* src/cuirass/remote.scm (build-dependency-failed-message): New
procedure.
* src/cuirass/scripts/remote-server.scm (serve-build-requests): Handle
‘build-dependency-failed’ messages.
* src/cuirass/scripts/remote-worker.scm (run-build): Move
‘perform-build’ calls to ‘run-build-plan’; iterate over the BUILD list
and send ‘build-dependency-failed’ message when appropriate.
* tests/remote.scm ("build with failing dependency"): Adjust
accordingly.
---
src/cuirass/remote.scm | 6 ++++
src/cuirass/scripts/remote-server.scm | 5 ++++
src/cuirass/scripts/remote-worker.scm | 56 ++++++++++++++++++++++++-----------
tests/remote.scm | 4 +--
4 files changed, 52 insertions(+), 19 deletions(-)
diff --git a/src/cuirass/remote.scm b/src/cuirass/remote.scm
index cd0a063..d268e4b 100644
--- a/src/cuirass/remote.scm
+++ b/src/cuirass/remote.scm
@@ -82,6 +82,7 @@
build-started-message
build-rejected-message
build-failed-message
+ build-dependency-failed-message
build-succeeded-message
worker-ping
worker-ready-message
@@ -573,6 +574,11 @@ within TIMEOUT seconds."
"Return a message that indicates that the build of DRV has failed."
`(build-failed (drv ,drv) (url ,url) (log ,log)))
+(define (build-dependency-failed-message drv url dependency)
+ "Return a message indicating that DEPENDENCY, a derivation of DRV, fails to
+build."
+ `(build-dependency-failed (drv ,drv) (url ,url) (dependency ,dependency)))
+
(define* (build-succeeded-message drv url #:optional log)
"Return a message that indicates that the build of DRV is done."
`(build-succeeded (drv ,drv) (url ,url) (log ,log)))
diff --git a/src/cuirass/scripts/remote-server.scm
b/src/cuirass/scripts/remote-server.scm
index 88f168d..99c2052 100644
--- a/src/cuirass/scripts/remote-server.scm
+++ b/src/cuirass/scripts/remote-server.scm
@@ -508,6 +508,11 @@ Use WORKER-DIRECTORY to maintain the list of active
workers."
(log-debug "fetching required for ~a (fail)" drv)
(put-message fetch-worker command)
#t)
+ (('build-dependency-failed ('drv drv) ('url url)
+ ('dependency dependency) _ ...)
+ (log-info "build failed: dependency '~a' of '~a'"
+ dependency drv)
+ (db-update-build-status! drv (build-status failed-dependency)))
(('worker-ready worker properties ...)
(update-worker worker properties))
(`(worker-request-info)
diff --git a/src/cuirass/scripts/remote-worker.scm
b/src/cuirass/scripts/remote-worker.scm
index 9f8b15e..9c0c971 100644
--- a/src/cuirass/scripts/remote-worker.scm
+++ b/src/cuirass/scripts/remote-worker.scm
@@ -271,6 +271,44 @@ process may use up to PARALLELISM cores.
The publish server of the build server is added to the list of the store
substitutes-urls. This way derivations that are not present on the worker can
still be substituted."
+ (define (run-build-plan store drv build)
+ ;; Build DRV and its dependencies, sending a "build failed" message as
+ ;; soon as one of them fails.
+ ;; XXX: Assuming BUILD is in topological order.
+ (log-info "~a: build plan of '~a' includes ~a derivations"
+ (worker-name worker) drv (length build))
+
+ (let loop ((build build))
+ (match build
+ (()
+ (log-info "~a: done building '~a' and its dependencies"
+ (worker-name worker) drv))
+ ((head tail ...)
+ (and (guard (c (#t ;catch all
+ (if (string=? drv (derivation-file-name head))
+ (begin
+ (log-info "~a: '~a' failed to build"
+ (worker-name worker) drv)
+ (reply (build-failed-message
+ drv
+ (worker-publish-url worker))))
+ (begin
+ (log-info "~a: '~a' failed to build\
+ (dependency of ~a)"
+ (worker-name worker)
+ (derivation-file-name head)
+ drv)
+ (reply
+ (build-dependency-failed-message
+ drv
+ (worker-publish-url worker)
+ (derivation-file-name head)))))
+ #f))
+ (perform-build store (derivation-file-name head)
+ worker server reply)
+ #t)
+ (loop tail))))))
+
(with-store/non-blocking store
(let ((publish-url (server-publish-url server)))
;; TODO: Choose PARALLELISM dynamically based on the number of currently
@@ -308,23 +346,7 @@ still be substituted."
(build-succeeded-message drv
(worker-publish-url worker))))
(let ((build (if (null? build) (list drv) build)))
- ;; Build DRV and its dependencies, sending a "build failed"
- ;; message as soon as one of them fails.
- ;; XXX: Assuming BUILD is in topological order.
- (log-info "~a: build plan of '~a' includes ~a derivations"
- (worker-name worker) drv (length build))
- (guard (c (#t ;catch all
- ;; TODO: Distinguish between 'failed' and
- ;; 'failed-dependency'.
- (log-info "~a: '~a' or one of its dependencies \
-failed to build"
- (worker-name worker) drv)
- (reply (build-failed-message
- drv (worker-publish-url worker)))))
- (for-each (lambda (drv)
- (perform-build store (derivation-file-name drv)
- worker server reply))
- build)))))
+ (run-build-plan store drv build))))
(begin
(log-error "~a cannot be fetched; not building it" drv)
(reply (build-rejected-message drv (worker-name worker))))))))
diff --git a/tests/remote.scm b/tests/remote.scm
index bea6f01..712ea52 100644
--- a/tests/remote.scm
+++ b/tests/remote.scm
@@ -298,7 +298,7 @@ Completing build process.\n"))
(test-assert "build with failing dependency"
;; When a build depends on a failing derivation with no corresponding
- ;; build entry, that build must be marked as failing.
+ ;; build entry, that build must be marked as 'failed-dependency'.
(let* ((dependency (with-store store
(derivation-file-name
(run-with-store store
@@ -314,7 +314,7 @@ Failing dependency ~s.\n"
(retry
(lambda ()
(and (= (build-current-status (db-get-build drv))
- (build-status failed))
+ (build-status failed-dependency))
(not (stat (build-log-file drv) #f))))
#:times 10
#:delay 1)))
