From aa4c7784940581b5e271b9c7c4ac80b6ee1ee309 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 1 Mar 2018 17:25:14 +0100 Subject: base: Move database update from 'evaluate' process to the main process. Fixes . Reported by Andreas Enge . * 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:-@GUILE@} --no-auto-compile -e main -s "$0" "$@" !# ;;;; evaluate -- convert a specification to a job list -;;; Copyright © 2016 Ludovic Courtès +;;; Copyright © 2016, 2018 Ludovic Courtès ;;; Copyright © 2016, 2017 Mathieu Lirzin ;;; Copyright © 2017 Mathieu Othacehe ;;; @@ -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.~%" 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)))))) ;;; -- cgit v1.2.3