base: Move database update from 'evaluate' process to the main process.

Fixes <https://bugs.gnu.org/30618>.
Reported by Andreas Enge <andreas@enge.fr>.

* 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

@@ -6,7 +6,7 @@ export GUILE_LOAD_PATH
 exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
 !#
 ;;;; evaluate -- convert a specification to a job list
-;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;;
@@ -33,19 +33,9 @@ exec ${GUILE:-@GUILE@} --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:-@GUILE@} --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.~%"

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))))))
 
 
 ;;;