[no subject]

[Ludovic Courtès]

branch: master
commit aa4c7784940581b5e271b9c7c4ac80b6ee1ee309
Author: Ludovic Courtès <address@hidden>
Date:   Thu Mar 1 17:25:14 2018 +0100

    base: Move database update from 'evaluate' process to the main process.
    
    Fixes <https://bugs.gnu.org/30618>.
    Reported by Andreas Enge <address@hidden>.
    
    * bin/evaluate.in (fill-job): Remove.
    (main): Remove 'database' command-line argument.  Remove DB and its
    uses.  Write an (evaluation EVAL JOBS) sexp.
    * src/cuirass/base.scm (evaluate)[augment-job]: New procedure.
    Use it.  Adjust to read (evaluation EVAL JOBS) sexp.  Call
    'db-add-evaluation' and 'db-add-derivation'.
---
 bin/evaluate.in      | 37 ++++++++++---------------------------
 src/cuirass/base.scm | 41 +++++++++++++++++++++++++++++------------
 2 files changed, 39 insertions(+), 39 deletions(-)

diff --git a/bin/evaluate.in b/bin/evaluate.in
index 37ba493..a2fa86d 100644
--- a/bin/evaluate.in
+++ b/bin/evaluate.in
@@ -6,7 +6,7 @@ export GUILE_LOAD_PATH
 exec ${GUILE:address@hidden@} --no-auto-compile -e main -s "$0" "$@"
 !#
 ;;;; evaluate -- convert a specification to a job list
-;;; Copyright © 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2016, 2018 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2016, 2017 Mathieu Lirzin <address@hidden>
 ;;; Copyright © 2017 Mathieu Othacehe <address@hidden>
 ;;;
@@ -33,19 +33,9 @@ exec ${GUILE:address@hidden@} --no-auto-compile -e main -s 
"$0" "$@"
              (guix derivations)
              (guix store))
 
-(define (fill-job job eval-id)
-  "Augment the JOB alist with EVAL-ID and additional information
-  gathered from JOB’s #:derivation."
-  (let ((drv (read-derivation-from-file
-              (assq-ref job #:derivation))))
-    `((#:eval-id . ,eval-id)
-      (#:nix-name . ,(derivation-name drv))
-      (#:system . ,(derivation-system drv))
-      ,@job)))
-
 (define* (main #:optional (args (command-line)))
   (match args
-    ((command load-path guix-package-path cachedir specstr database)
+    ((command load-path guix-package-path cachedir specstr)
      ;; Load FILE, a Scheme file that defines Hydra jobs.
      (let ((%user-module (make-fresh-user-module))
            (spec         (with-input-from-string specstr read))
@@ -69,30 +59,23 @@ exec ${GUILE:address@hidden@} --no-auto-compile -e main -s 
"$0" "$@"
                           stderr)
                  (simple-format stderr "'build-things' arguments: ~S~%" args)
                  (exit 1)))
-         (parameterize ((%package-database database)
-                        (%use-substitutes? (assoc-ref spec 
#:use-substitutes?)))
+
+         (parameterize ((%use-substitutes? (assoc-ref spec 
#:use-substitutes?)))
            (unless (string-null? guix-package-path)
              (set-guix-package-path! guix-package-path))
            ;; Call the entry point of FILE and print the resulting job sexp.
            (let* ((proc-name (assq-ref spec #:proc))
                   (proc    (module-ref %user-module proc-name))
                   (thunks  (proc store (assq-ref spec #:arguments)))
-                  (db      (db-open))
                   (commit  (assq-ref spec #:current-commit))
                   (eval    `((#:specification . ,(assq-ref spec #:name))
-                             (#:revision . ,commit)))
-                  (eval-id (db-add-evaluation db eval)))
+                             (#:revision . ,commit))))
              (pretty-print
-              (map (lambda (thunk)
-                     (let* ((job  (call-with-time-display thunk))
-                            ;; Fill job with informations that will later be
-                            ;; added to database.
-                            (job* (fill-job job eval-id)))
-                       (db-add-derivation db job*)
-                       job*))
-                   thunks)
-              stdout)
-             (db-close db))))))
+              `(evaluation ,eval
+                           ,(map (lambda (thunk)
+                                   (call-with-time-display thunk))
+                                 thunks))
+              stdout))))))
     ((command _ ...)
      (simple-format (current-error-port) "Usage: ~A FILE
 Evaluate the Hydra jobs defined in FILE.~%"
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index 8c6cd8c..89f84e9 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -219,6 +219,14 @@ fibers."
 
 (define (evaluate store db spec)
   "Evaluate and build package derivations.  Return a list of jobs."
+  (define (augment-job job eval-id)
+    (let ((drv (read-derivation-from-file
+                (assq-ref job #:derivation))))
+      `((#:eval-id . ,eval-id)
+        (#:nix-name . ,(derivation-name drv))
+        (#:system . ,(derivation-system drv))
+        ,@job)))
+
   (let* ((port (non-blocking-port
                 (open-pipe* OPEN_READ
                             "evaluate"
@@ -227,19 +235,28 @@ fibers."
                                            (assq-ref spec #:load-path))
                             (%guix-package-path)
                             (%package-cachedir)
-                            (object->string spec)
-                            (%package-database))))
-         (jobs (match (read/non-blocking port)
-                 ;; If an error occured during evaluation report it,
-                 ;; otherwise, suppose that data read from port are
-                 ;; correct and keep things going.
-                 ((? eof-object?)
-                  (raise (condition
-                          (&evaluation-error
-                           (name (assq-ref spec #:name))))))
-                 (data data))))
+                            (object->string spec))))
+         (result (match (read/non-blocking port)
+                   ;; If an error occured during evaluation report it,
+                   ;; otherwise, suppose that data read from port are
+                   ;; correct and keep things going.
+                   ((? eof-object?)
+                    (raise (condition
+                            (&evaluation-error
+                             (name (assq-ref spec #:name))))))
+                   (data data))))
     (close-pipe port)
-    jobs))
+    (match result
+      (('evaluation eval jobs)
+       (let ((eval-id (db-add-evaluation db eval)))
+         (log-message "created evaluation ~a for ~a, commit ~a" eval-id
+                      (assq-ref eval #:specification)
+                      (assq-ref eval #:revision))
+         (let ((jobs (map (lambda (job)
+                            (augment-job job eval-id))
+                          jobs)))
+           (for-each (cut db-add-derivation db <>) jobs)
+           jobs))))))
 
 
 ;;;