Fix spec reading when restarting builds.
When "spawn-builds" is called to restart builds, the spec is not known, preventing build products from being created as reported here: https://issues.guix.gnu.org/42523 Fix this issue by reading the specification in database in "set-build-successful!" procedure. * src/cuirass/database.scm (db-get-specification): New exported procedure, (db-get-specifications): add an optional name argument. * tests/database.scm (db-get-specification): Add a corresponding test-case. * src/cuirass/base.scm (set-build-successful!): Remove spec argument and read it directly from database instead, (update-build-statuses!): also remove spec argument, adapt set-build-successful! call accordingly, (spawn-builds): remove spec argument and adapt handle-build-event and update-build-statuses! calls accordingly, (handle-build-event): remove spec argument, adapt set-build-successful! call accordingly, (build-packages): remove spec argument, adapt spawn-builds call accordingly, (process-specs): adapt build-packages call.
This commit is contained in:
parent
d11ce40a10
commit
17395e85d2
|
@ -449,16 +449,19 @@ Essentially this procedure inverts the inversion-of-control that
|
|||
;; Our shuffling algorithm is simple: we sort by .drv file name. :-)
|
||||
(sort drv string<?))
|
||||
|
||||
(define (set-build-successful! spec drv)
|
||||
(define (set-build-successful! drv)
|
||||
"Update the build status of DRV as successful and register any eventual
|
||||
build products according to SPEC."
|
||||
(let ((build (db-get-build drv)))
|
||||
build products."
|
||||
(let* ((build (db-get-build drv))
|
||||
(spec (and build
|
||||
(db-get-specification
|
||||
(assq-ref build #:specification)))))
|
||||
(when (and spec build)
|
||||
(create-build-outputs build
|
||||
(assq-ref spec #:build-outputs))))
|
||||
(db-update-build-status! drv (build-status succeeded)))
|
||||
|
||||
(define (update-build-statuses! store spec lst)
|
||||
(define (update-build-statuses! store lst)
|
||||
"Update the build status of the derivations listed in LST, which have just
|
||||
been passed to 'build-derivations' (meaning that we can assume that, if their
|
||||
outputs are invalid, that they failed to build.)"
|
||||
|
@ -466,7 +469,7 @@ outputs are invalid, that they failed to build.)"
|
|||
(match (derivation-path->output-paths drv)
|
||||
(((_ . outputs) ...)
|
||||
(if (any (cut valid-path? store <>) outputs)
|
||||
(set-build-successful! spec drv)
|
||||
(set-build-successful! drv)
|
||||
(db-update-build-status! drv
|
||||
(if (log-file store drv)
|
||||
(build-status failed)
|
||||
|
@ -488,8 +491,7 @@ and returns the values RESULTS."
|
|||
|
||||
(define* (spawn-builds store drv
|
||||
#:key
|
||||
(max-batch-size 200)
|
||||
spec)
|
||||
(max-batch-size 200))
|
||||
"Build the derivations listed in DRV, updating the database as builds
|
||||
complete. Derivations are submitted in batches of at most MAX-BATCH-SIZE
|
||||
items."
|
||||
|
@ -540,7 +542,7 @@ items."
|
|||
;; from PORT and eventually close it.
|
||||
(catch #t
|
||||
(lambda ()
|
||||
(handle-build-event spec event))
|
||||
(handle-build-event event))
|
||||
(exception-reporter state)))
|
||||
#t)
|
||||
(close-port port)
|
||||
|
@ -552,11 +554,11 @@ items."
|
|||
;; 'build-derivations' doesn't actually do anything and
|
||||
;; 'handle-build-event' doesn't see any event. Because of that,
|
||||
;; adjust the database here.
|
||||
(update-build-statuses! store spec batch)
|
||||
(update-build-statuses! store batch)
|
||||
|
||||
(loop rest (max (- count max-batch-size) 0))))))
|
||||
|
||||
(define* (handle-build-event spec event)
|
||||
(define* (handle-build-event event)
|
||||
"Handle EVENT, a build event sexp as produced by 'build-event-output-port',
|
||||
updating the database accordingly."
|
||||
(define (valid? file)
|
||||
|
@ -586,7 +588,7 @@ updating the database accordingly."
|
|||
(if (valid? drv)
|
||||
(begin
|
||||
(log-message "build succeeded: '~a'" drv)
|
||||
(set-build-successful! spec drv)
|
||||
(set-build-successful! drv)
|
||||
|
||||
(for-each (match-lambda
|
||||
((name . output)
|
||||
|
@ -684,7 +686,7 @@ by PRODUCT-SPECS."
|
|||
(#:path . ,product))))))
|
||||
product-specs))
|
||||
|
||||
(define (build-packages store spec jobs eval-id)
|
||||
(define (build-packages store jobs eval-id)
|
||||
"Build JOBS and return a list of Build results."
|
||||
(define (register job)
|
||||
(let* ((name (assq-ref job #:job-name))
|
||||
|
@ -725,8 +727,7 @@ by PRODUCT-SPECS."
|
|||
eval-id (length derivations))
|
||||
(db-set-evaluation-done eval-id)
|
||||
|
||||
(spawn-builds store derivations
|
||||
#:spec spec)
|
||||
(spawn-builds store derivations)
|
||||
|
||||
(let* ((results (filter-map (cut db-get-build <>) derivations))
|
||||
(status (map (cut assq-ref <> #:status) results))
|
||||
|
@ -825,7 +826,7 @@ by PRODUCT-SPECS."
|
|||
(let ((jobs (evaluate store spec eval-id checkouts)))
|
||||
(log-message "building ~a jobs for '~a'"
|
||||
(length jobs) name)
|
||||
(build-packages store spec jobs eval-id))))))
|
||||
(build-packages store jobs eval-id))))))
|
||||
|
||||
;; 'spawn-fiber' returns zero values but we need one.
|
||||
*unspecified*))))
|
||||
|
|
|
@ -41,6 +41,7 @@
|
|||
db-optimize
|
||||
db-add-specification
|
||||
db-remove-specification
|
||||
db-get-specification
|
||||
db-get-specifications
|
||||
db-add-evaluation
|
||||
db-set-evaluations-done
|
||||
|
@ -392,29 +393,39 @@ DELETE FROM Specifications WHERE name=" name ";")
|
|||
(#:no-compile? . ,(positive? no-compile-p)))
|
||||
inputs)))))))
|
||||
|
||||
(define (db-get-specifications)
|
||||
(define (db-get-specification name)
|
||||
"Retrieve a specification in the database with the given NAME."
|
||||
(with-db-worker-thread db
|
||||
(let loop ((rows (sqlite-exec db "SELECT * FROM Specifications ORDER BY name DESC;"))
|
||||
(specs '()))
|
||||
(match rows
|
||||
(() specs)
|
||||
((#(name load-path-inputs package-path-inputs proc-input proc-file proc
|
||||
proc-args build-outputs)
|
||||
. rest)
|
||||
(loop rest
|
||||
(cons `((#:name . ,name)
|
||||
(#:load-path-inputs .
|
||||
,(with-input-from-string load-path-inputs read))
|
||||
(#:package-path-inputs .
|
||||
,(with-input-from-string package-path-inputs read))
|
||||
(#:proc-input . ,proc-input)
|
||||
(#:proc-file . ,proc-file)
|
||||
(#:proc . ,(with-input-from-string proc read))
|
||||
(#:proc-args . ,(with-input-from-string proc-args read))
|
||||
(#:inputs . ,(db-get-inputs name))
|
||||
(#:build-outputs .
|
||||
,(with-input-from-string build-outputs read)))
|
||||
specs)))))))
|
||||
(expect-one-row (db-get-specifications name))))
|
||||
|
||||
(define* (db-get-specifications #:optional name)
|
||||
(with-db-worker-thread db
|
||||
(let loop
|
||||
((rows (if name
|
||||
(sqlite-exec db "
|
||||
SELECT * FROM Specifications WHERE name =" name ";")
|
||||
(sqlite-exec db "
|
||||
SELECT * FROM Specifications ORDER BY name DESC;")))
|
||||
(specs '()))
|
||||
(match rows
|
||||
(() specs)
|
||||
((#(name load-path-inputs package-path-inputs proc-input proc-file proc
|
||||
proc-args build-outputs)
|
||||
. rest)
|
||||
(loop rest
|
||||
(cons `((#:name . ,name)
|
||||
(#:load-path-inputs .
|
||||
,(with-input-from-string load-path-inputs read))
|
||||
(#:package-path-inputs .
|
||||
,(with-input-from-string package-path-inputs read))
|
||||
(#:proc-input . ,proc-input)
|
||||
(#:proc-file . ,proc-file)
|
||||
(#:proc . ,(with-input-from-string proc read))
|
||||
(#:proc-args . ,(with-input-from-string proc-args read))
|
||||
(#:inputs . ,(db-get-inputs name))
|
||||
(#:build-outputs .
|
||||
,(with-input-from-string build-outputs read)))
|
||||
specs)))))))
|
||||
|
||||
(define (db-add-evaluation spec-name checkouts)
|
||||
"Add a new evaluation for SPEC-NAME only if one of the CHECKOUTS is new.
|
||||
|
|
|
@ -110,6 +110,10 @@ INSERT INTO Evaluations (specification, in_progress) VALUES (3, false);")
|
|||
(db-add-specification example-spec)
|
||||
(car (db-get-specifications))))
|
||||
|
||||
(test-equal "db-get-specification"
|
||||
example-spec
|
||||
(db-get-specification "guix"))
|
||||
|
||||
(test-equal "db-add-build"
|
||||
#f
|
||||
(let ((build (make-dummy-build "/foo.drv")))
|
||||
|
|
Loading…
Reference in New Issue