diff options
| -rw-r--r-- | bin/cuirass.in | 88 | ||||
| -rw-r--r-- | src/cuirass/utils.scm | 11 |
2 files changed, 56 insertions, 43 deletions
diff --git a/bin/cuirass.in b/bin/cuirass.in index 611ed44..e086382 100644 --- a/bin/cuirass.in +++ b/bin/cuirass.in @@ -50,12 +50,6 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@" (version (single-char #\V) (value #f)) (help (single-char #\h) (value #f)))) -(define %user-module - ;; Cuirass user module. - (let ((m (make-module))) - (beautify-user-module! m) - m)) - (define (fetch-repository spec) "Get the latest version of repository specified in SPEC. Clone repository if required." @@ -85,21 +79,22 @@ if required." (define (evaluate store db spec) "Evaluate and build package derivations. Return a list a jobs." - (save-module-excursion - (λ () - (set-current-module %user-module) - ;; Handle both relative and absolute file names for SPEC-FILE. - (with-directory-excursion - (string-append (%package-cachedir) "/" (job-spec-name spec)) - (primitive-load (job-spec-file spec))))) - (let* ((proc (module-ref %user-module (job-spec-proc spec))) - (jobs (proc store (job-spec-arguments spec)))) - (map (λ (job) - (let ((id (db-add-evaluation db job))) - (make-job #:name (job-name job) - #:derivation (job-derivation job) - #:metadata (acons 'id id (job-metadata job))))) - jobs))) + (let ((mod (make-user-module))) + (save-module-excursion + (λ () + (set-current-module mod) + ;; Handle both relative and absolute file names for SPEC-FILE. + (with-directory-excursion + (string-append (%package-cachedir) "/" (job-spec-name spec)) + (primitive-load (job-spec-file spec))))) + (let* ((proc (module-ref mod (job-spec-proc spec))) + (jobs (proc store (job-spec-arguments spec)))) + (map (λ (job) + (let ((id (db-add-evaluation db job))) + (make-job #:name (job-name job) + #:derivation (job-derivation job) + #:metadata (acons 'id id (job-metadata job))))) + jobs)))) (define (build-packages store db jobs) "Build JOBS which is a list of <job> objects." @@ -121,6 +116,28 @@ if required." (format #t "~A~%" (derivation-path->output-path drv)))) jobs))) +(define (process-spec db spec) + "Evaluate and build SPEC" + (fetch-repository spec) + (let ((old-path %load-path)) + (and (job-spec-load-path spec) (set-load-path! spec)) + (let ((store ((guix-variable 'store 'open-connection)))) + (dynamic-wind + (const #t) + (λ () + (let ((jobs (evaluate store db spec)) + (set-build-options + (guix-variable 'store 'set-build-options))) + (set-build-options store #:use-substitutes? #f) + (build-packages store db jobs))) + (λ () + ((guix-variable 'store 'close-connection) store) + (set! %load-path old-path)))))) + +(define (process-specs db jobspecs) + "Evaluate and build JOBSPECS and store results in DB." + (for-each (λ (spec) (process-spec db spec)) jobspecs)) + ;;; ;;; Entry point. @@ -142,27 +159,12 @@ if required." (exit 0)) (else (let* ((specfile (option-ref opts 'file "tests/hello-subset.scm")) - (interval (option-ref opts 'interval "60")) - (specs (primitive-load specfile))) + (interval (string->number (option-ref opts 'interval "60"))) + (specs (save-module-excursion + (λ () + (set-current-module (make-user-module)) + (primitive-load specfile))))) (with-database db (while #t - (for-each - (λ (spec) - (fetch-repository spec) - (let ((old-path %load-path)) - (and (job-spec-load-path spec) - (set-load-path! spec)) - (let ((store ((guix-variable 'store 'open-connection)))) - (dynamic-wind - (const #t) - (λ () - (let ((jobs (evaluate store db spec)) - (set-build-options - (guix-variable 'store 'set-build-options))) - (set-build-options store #:use-substitutes? #f) - (build-packages store db jobs))) - (λ () - ((guix-variable 'store 'close-connection) store) - (set! %load-path old-path)))))) - specs) - (sleep (string->number interval)))))))))) + (process-specs db specs) + (sleep interval))))))))) diff --git a/src/cuirass/utils.scm b/src/cuirass/utils.scm index f1ddbf5..56d3fcd 100644 --- a/src/cuirass/utils.scm +++ b/src/cuirass/utils.scm @@ -1,6 +1,7 @@ ;;;; utils.scm -- helper procedures ;;; ;;; Copyright © 2012, 2013, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015 David Thompson <davet@gnu.org> ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org> ;;; ;;; This file is part of Cuirass. @@ -22,6 +23,7 @@ #:use-module (ice-9 match) #:export (;; Procedures mkdir-p + make-user-module ;; Macros. λ* with-directory-excursion)) @@ -64,3 +66,12 @@ (λ () (chdir dir)) (λ () body ...) (λ () (chdir init))))) + +(define* (make-user-module #:optional (modules '())) + "Return a new user module with the additional MODULES loaded." + ;; Module in which the machine description file is loaded. + (let ((module (make-fresh-user-module))) + (for-each (lambda (iface) + (module-use! module (resolve-interface iface))) + modules) + module)) |