mirror of
https://codeberg.org/guix/guix.git
synced 2025-10-02 02:15:12 +00:00
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'.
This commit is contained in:
Ludovic Courtès
parent
c490a0b037
commit
0c8491cbbe
8 changed files with 87 additions and 87 deletions
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))))))))))
|
||||
|
|
|
|||
|
|
@ -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."
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
(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))))
|
||||
(and (build-derivations store (list prof-drv))
|
||||
(let* ((entries (manifest-entries manifest))
|
||||
;; 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)))))))))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -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?
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue