diff options
author | Mathieu Othacehe <othacehe@gnu.org> | 2020-07-25 14:22:20 +0200 |
---|---|---|
committer | Mathieu Othacehe <othacehe@gnu.org> | 2020-07-25 14:22:20 +0200 |
commit | 17395e85d2793ec4cb47e53bcbdb5b06187147bd (patch) | |
tree | a79c6802b67afdd06b41a3bdf0d29e4cfeb71902 | |
parent | d11ce40a10eae8b60eb0d0c076fe83d7861cca30 (diff) | |
download | cuirass-17395e85d2793ec4cb47e53bcbdb5b06187147bd.tar cuirass-17395e85d2793ec4cb47e53bcbdb5b06187147bd.tar.gz |
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.
-rw-r--r-- | src/cuirass/base.scm | 31 | ||||
-rw-r--r-- | src/cuirass/database.scm | 55 | ||||
-rw-r--r-- | tests/database.scm | 4 |
3 files changed, 53 insertions, 37 deletions
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm index 35559ff..51bca6b 100644 --- a/src/cuirass/base.scm +++ b/src/cuirass/base.scm @@ -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*)))) diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm index 3564217..de6b245 100644 --- a/src/cuirass/database.scm +++ b/src/cuirass/database.scm @@ -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. diff --git a/tests/database.scm b/tests/database.scm index 98b5012..944e4bf 100644 --- a/tests/database.scm +++ b/tests/database.scm @@ -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"))) |