branch master updated: Fix spec reading when restarting builds.

[Mathieu Othacehe]

This is an automated email from the git hooks/post-receive script.

mothacehe pushed a commit to branch master
in repository guix-cuirass.

The following commit(s) were added to refs/heads/master by this push:
     new 17395e8  Fix spec reading when restarting builds.
17395e8 is described below

commit 17395e85d2793ec4cb47e53bcbdb5b06187147bd
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Sat Jul 25 14:22:20 2020 +0200

    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.
---
 src/cuirass/base.scm     | 31 ++++++++++++++-------------
 src/cuirass/database.scm | 55 +++++++++++++++++++++++++++++-------------------
 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")))