diff options
author | Ludovic Courtès <ludo@gnu.org> | 2017-01-09 23:06:54 +0100 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2017-01-11 10:13:32 +0100 |
commit | 0c8491cbbead8d04b84714ee4f970f1f1c7be352 (patch) | |
tree | ae0c3546dbf28c91d5989d43f73a5f29249524cb | |
parent | c490a0b03768231d15f6b9b9df70a92e8fa6a9cb (diff) |
Callers of 'build-derivations' & co. now honor its result.
* guix/profiles.scm (link-to-empty-profile): Use the result of
'build-derivations' instead of calling 'derivation->output-path'.
* guix/scripts.scm (build-package): Likewise, and use 'format' directly
instead of 'show-derivation-outputs'.
(build-package-source): Likewise.
* guix/scripts/archive.scm (export-from-store): Use result of
'build-derivations'.
* guix/scripts/build.scm (guix-build): Likewise. Use 'format' instead
of 'show-derivation-outputs'.
* guix/scripts/copy.scm (send-to-remote-host): Use result of
'build-derivations'.
* guix/scripts/package.scm (build-and-use-profile): Likewise.
* guix/upstream.scm (download-tarball): Likewise.
* guix/scripts/system.scm (reinstall-grub): Likewise.
(perform-action): Use result of 'maybe-build'.
-rw-r--r-- | guix/profiles.scm | 5 | ||||
-rw-r--r-- | guix/scripts.scm | 34 | ||||
-rw-r--r-- | guix/scripts/archive.scm | 36 | ||||
-rw-r--r-- | guix/scripts/build.scm | 14 | ||||
-rw-r--r-- | guix/scripts/copy.scm | 19 | ||||
-rw-r--r-- | guix/scripts/package.scm | 31 | ||||
-rw-r--r-- | guix/scripts/system.scm | 31 | ||||
-rw-r--r-- | guix/upstream.scm | 6 |
8 files changed, 88 insertions, 88 deletions
diff --git a/guix/profiles.scm b/guix/profiles.scm index e7707b6543..58df449069 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> @@ -1120,8 +1120,7 @@ that fails." (let* ((drv (run-with-store store (profile-derivation (manifest '()) #:locales? #f))) - (prof (derivation->output-path drv "out"))) - (build-derivations store (list drv)) + (prof (build-derivations store (list drv)))) (switch-symlinks generation prof))) (define (switch-to-generation profile number) diff --git a/guix/scripts.scm b/guix/scripts.scm index bbee50bc3d..e4e53229b4 100644 --- a/guix/scripts.scm +++ b/guix/scripts.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Deck Pickard <deck.r.pickard@gmail.com> ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com> ;;; @@ -29,6 +29,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-37) #:use-module (ice-9 match) + #:use-module (ice-9 format) #:export (args-fold* parse-command-line maybe-build @@ -90,7 +91,8 @@ parameter of 'args-fold'." (define* (maybe-build drvs #:key dry-run? use-substitutes?) "Show what will/would be built, and actually build DRVS, unless DRY-RUN? is -true." +true. Return #f when DRY-RUN? is true, and the list of store items actually +built otherwise." (with-monad %store-monad (>>= (show-what-to-build* drvs #:dry-run? dry-run? @@ -112,12 +114,14 @@ Show what and how will/would be built." (strip-keyword-arguments '(#:dry-run?) build-options)) (mlet %store-monad ((derivation (package->derivation package #:graft? (and (not dry-run?) - grafting?)))) - (mbegin %store-monad - (maybe-build (list derivation) - #:use-substitutes? use-substitutes? - #:dry-run? dry-run?) - (return (show-derivation-outputs derivation)))))) + grafting?))) + (items (maybe-build (list derivation) + #:use-substitutes? + use-substitutes? + #:dry-run? dry-run?))) + (unless dry-run? + (format #t "~{~a~%~}" items)) + (return (or dry-run? items))))) (define* (build-package-source package #:key dry-run? (use-substitutes? #t) @@ -129,11 +133,13 @@ Show what and how will/would be built." #:use-substitutes? use-substitutes? (strip-keyword-arguments '(#:dry-run?) build-options)) (mlet %store-monad ((derivation (origin->derivation - (package-source package)))) - (mbegin %store-monad - (maybe-build (list derivation) - #:use-substitutes? use-substitutes? - #:dry-run? dry-run?) - (return (show-derivation-outputs derivation)))))) + (package-source package))) + (items (maybe-build (list derivation) + #:use-substitutes? + use-substitutes? + #:dry-run? dry-run?))) + (unless dry-run? + (format #t "~{~a~%~}" items)) + (return (or dry-run? items))))) ;;; scripts.scm ends here diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 9e49c53635..bd64d9ff13 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -256,24 +256,24 @@ resulting archive to the standard output port." #:use-substitutes? (assoc-ref opts 'substitutes?) #:dry-run? (assoc-ref opts 'dry-run?)) - (if (or (assoc-ref opts 'dry-run?) - (build-derivations store drv)) - (match (assoc-ref opts 'format) - ("nar" - (export-paths store files (current-output-port) - #:recursive? (assoc-ref opts 'export-recursive?))) - ("docker" - (match files - ((file) - (let ((system (assoc-ref opts 'system))) - (format #t "~a\n" - (build-docker-image file #:system system)))) - (_ - ;; TODO: Remove this restriction. - (leave (_ "only a single item can be exported to Docker~%"))))) - (format - (leave (_ "~a: unknown archive format~%") format))) - (leave (_ "unable to export the given packages~%"))))) + (let ((files (if (assoc-ref opts 'dry-run?) + files + (build-derivations store drv)))) + (match (assoc-ref opts 'format) + ("nar" + (export-paths store files (current-output-port) + #:recursive? (assoc-ref opts 'export-recursive?))) + ("docker" + (match files + ((file) + (let ((system (assoc-ref opts 'system))) + (format #t "~a\n" + (build-docker-image file #:system system)))) + (_ + ;; TODO: Remove this restriction. + (leave (_ "only a single item can be exported to Docker~%"))))) + (format + (leave (_ "~a: unknown archive format~%") format)))))) (define (generate-key-pair parameters) "Generate a key pair with PARAMETERS, a canonical sexp, and store it in the diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index ccb4c275fc..6c57a6b9f1 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. @@ -726,11 +726,7 @@ needed." (map (compose list derivation-file-name) drv) roots)) ((not (assoc-ref opts 'dry-run?)) - (and (build-derivations store drv mode) - (for-each show-derivation-outputs drv) - (for-each (cut register-root store <> <>) - (map (lambda (drv) - (map cdr - (derivation->output-paths drv))) - drv) - roots)))))))))) + (let ((outputs (build-derivations store drv mode))) + (format #t "~{~a~%~}" outputs) + (for-each (cut register-root store <> <>) + outputs roots)))))))))) diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index 9ae204e6c6..e566a05960 100644 --- a/guix/scripts/copy.scm +++ b/guix/scripts/copy.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -112,14 +112,15 @@ package names, build the underlying packages before sending them." #:use-substitutes? (assoc-ref opts 'substitutes?) #:dry-run? (assoc-ref opts 'dry-run?)) - (and (or (assoc-ref opts 'dry-run?) - (build-derivations local drv)) - (let* ((session (open-ssh-session host #:user user #:port port)) - (sent (send-files local items - (connect-to-remote-daemon session) - #:recursive? #t))) - (format #t "~{~a~%~}" sent) - sent))))) + (let ((items (if (assoc-ref opts 'dry-run?) + items + (build-derivations local drv))) + (session (open-ssh-session host #:user user #:port port)) + (sent (send-files local items + (connect-to-remote-daemon session) + #:recursive? #t))) + (format #t "~{~a~%~}" sent) + sent)))) (define (retrieve-from-remote-host source opts) "Retrieve ITEMS from SOURCE." diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 90e7fa2298..70e68efee9 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2013, 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com> @@ -207,19 +207,20 @@ specified in MANIFEST, a manifest object." #:use-substitutes? use-substitutes? #:dry-run? dry-run?) - (cond - (dry-run? #t) - ((and (file-exists? profile) - (and=> (readlink* profile) (cut string=? prof <>))) - (format (current-error-port) (_ "nothing to be done~%"))) - (else - (let* ((number (generation-number profile)) - - ;; Always use NUMBER + 1 for the new profile, possibly - ;; overwriting a "previous future generation". - (name (generation-file-name profile (+ 1 number)))) - (and (build-derivations store (list prof-drv)) - (let* ((entries (manifest-entries manifest)) + (or dry-run? + (match (build-derivations store (list prof-drv)) + ((prof) + (cond + ((and (file-exists? profile) + (and=> (readlink* profile) (cut string=? prof <>))) + (format (current-error-port) (_ "nothing to be done~%"))) + (else + (let* ((number (generation-number profile)) + + ;; Always use NUMBER + 1 for the new profile, possibly + ;; overwriting a "previous future generation". + (name (generation-file-name profile (+ 1 number))) + (entries (manifest-entries manifest)) (count (length entries))) (switch-symlinks name prof) (switch-symlinks profile name) @@ -230,7 +231,7 @@ specified in MANIFEST, a manifest object." count) count) (display-search-paths entries (list profile) - #:kind 'prefix)))))))) + #:kind 'prefix))))))))) ;;; diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 144a7fd377..ee3334dbb8 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com> ;;; @@ -445,20 +445,21 @@ open connection to the store." entries #:old-entries old-entries)))) (show-what-to-build store (list grub.cfg)) - (build-derivations store (list grub.cfg)) + ;; This is basically the same as install-grub*, but for now we avoid ;; re-installing the GRUB boot loader itself onto a device, mainly because ;; we don't in general have access to the same version of the GRUB package ;; which was used when installing this other system generation. - (let* ((grub.cfg-path (derivation->output-path grub.cfg)) - (gc-root (string-append %gc-roots-directory "/grub.cfg")) - (temp-gc-root (string-append gc-root ".new"))) - (switch-symlinks temp-gc-root grub.cfg-path) - (unless (false-if-exception (install-grub-config grub.cfg-path "/")) - (delete-file temp-gc-root) - (leave (_ "failed to re-install GRUB configuration file: '~a'~%") - grub.cfg-path)) - (rename-file temp-gc-root gc-root)))) + (match (build-derivations store (list grub.cfg)) + ((grub.cfg-path) + (let* ((gc-root (string-append %gc-roots-directory "/grub.cfg")) + (temp-gc-root (string-append gc-root ".new"))) + (switch-symlinks temp-gc-root grub.cfg-path) + (unless (false-if-exception (install-grub-config grub.cfg-path "/")) + (delete-file temp-gc-root) + (leave (_ "failed to re-install GRUB configuration file: '~a'~%") + grub.cfg-path)) + (rename-file temp-gc-root gc-root)))))) ;;; @@ -630,17 +631,15 @@ building anything." (list sys grub.cfg grub) (list sys grub.cfg)) (list sys))) - (% (if derivations-only? - (return (for-each (compose println derivation-file-name) - drvs)) + (results (if derivations-only? + (return (map derivation-file-name drvs)) (maybe-build drvs #:dry-run? dry-run? #:use-substitutes? use-substitutes?)))) (if (or dry-run? derivations-only?) (return #f) (begin - (for-each (compose println derivation->output-path) - drvs) + (for-each println results) ;; Make sure GRUB is accessible. (when grub? diff --git a/guix/upstream.scm b/guix/upstream.scm index 2334c4c0a6..f32f7deeef 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Alex Kost <alezost@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -201,9 +201,7 @@ values: 'interactive' (default), 'always', and 'never'." (run-with-store store (mlet %store-monad ((drv (uncompressed-tarball (basename url) tarball))) - (mbegin %store-monad - (built-derivations (list drv)) - (return (derivation->output-path drv))))))) + (built-derivations (list drv)))))) (ret (gnupg-verify* sig data #:key-download key-download))) (if ret |