amaharaneko/guix-mirrors
1
1
Fork 0
mirror of https://codeberg.org/guix/guix.git synced 2025-10-02 02:15:12 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

Callers of 'build-derivations' & co. now honor its result.

Browse source 
* 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 2017-01-09 23:06:54 +01:00
parent c490a0b037
commit 0c8491cbbe
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
8 changed files with 87 additions and 87 deletions
Download patch file Download diff file Expand all files Collapse all files

5
guix/profiles.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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 © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
@ -1120,8 +1120,7 @@ that fails."
(let* ((drv (run-with-store store (let* ((drv (run-with-store store
(profile-derivation (manifest '()) (profile-derivation (manifest '())
#:locales? #f))) #:locales? #f)))
(prof (derivation->output-path drv "out"))) (prof (build-derivations store (list drv))))
(build-derivations store (list drv))
(switch-symlinks generation prof))) (switch-symlinks generation prof)))
(define (switch-to-generation profile number) (define (switch-to-generation profile number)

34
guix/scripts.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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 © 2014 Deck Pickard <deck.r.pickard@gmail.com>
;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
;;; ;;;
@ -29,6 +29,7 @@
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-37) #:use-module (srfi srfi-37)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 format)
#:export (args-fold* #:export (args-fold*
parse-command-line parse-command-line
maybe-build maybe-build
@ -90,7 +91,8 @@ parameter of 'args-fold'."
(define* (maybe-build drvs (define* (maybe-build drvs
#:key dry-run? use-substitutes?) #:key dry-run? use-substitutes?)
"Show what will/would be built, and actually build DRVS, unless DRY-RUN? is "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 (with-monad %store-monad
(>>= (show-what-to-build* drvs (>>= (show-what-to-build* drvs
#:dry-run? dry-run? #:dry-run? dry-run?
@ -112,12 +114,14 @@ Show what and how will/would be built."
(strip-keyword-arguments '(#:dry-run?) build-options)) (strip-keyword-arguments '(#:dry-run?) build-options))
(mlet %store-monad ((derivation (package->derivation (mlet %store-monad ((derivation (package->derivation
package #:graft? (and (not dry-run?) package #:graft? (and (not dry-run?)
grafting?)))) grafting?)))
(mbegin %store-monad (items (maybe-build (list derivation)
(maybe-build (list derivation) #:use-substitutes?
#:use-substitutes? use-substitutes? use-substitutes?
#:dry-run? dry-run?) #:dry-run? dry-run?)))
(return (show-derivation-outputs derivation)))))) (unless dry-run?
(format #t "~{~a~%~}" items))
(return (or dry-run? items)))))
(define* (build-package-source package (define* (build-package-source package
#:key dry-run? (use-substitutes? #t) #:key dry-run? (use-substitutes? #t)
@ -129,11 +133,13 @@ Show what and how will/would be built."
#:use-substitutes? use-substitutes? #:use-substitutes? use-substitutes?
(strip-keyword-arguments '(#:dry-run?) build-options)) (strip-keyword-arguments '(#:dry-run?) build-options))
(mlet %store-monad ((derivation (origin->derivation (mlet %store-monad ((derivation (origin->derivation
(package-source package)))) (package-source package)))
(mbegin %store-monad (items (maybe-build (list derivation)
(maybe-build (list derivation) #:use-substitutes?
#:use-substitutes? use-substitutes? use-substitutes?
#:dry-run? dry-run?) #:dry-run? dry-run?)))
(return (show-derivation-outputs derivation)))))) (unless dry-run?
(format #t "~{~a~%~}" items))
(return (or dry-run? items)))))
;;; scripts.scm ends here ;;; scripts.scm ends here

36
guix/scripts/archive.scm
View file

@ -256,24 +256,24 @@ resulting archive to the standard output port."
#:use-substitutes? (assoc-ref opts 'substitutes?) #:use-substitutes? (assoc-ref opts 'substitutes?)
#:dry-run? (assoc-ref opts 'dry-run?)) #:dry-run? (assoc-ref opts 'dry-run?))
(if (or (assoc-ref opts 'dry-run?) (let ((files (if (assoc-ref opts 'dry-run?)
(build-derivations store drv)) files
(match (assoc-ref opts 'format) (build-derivations store drv))))
("nar" (match (assoc-ref opts 'format)
(export-paths store files (current-output-port) ("nar"
#:recursive? (assoc-ref opts 'export-recursive?))) (export-paths store files (current-output-port)
("docker" #:recursive? (assoc-ref opts 'export-recursive?)))
(match files ("docker"
((file) (match files
(let ((system (assoc-ref opts 'system))) ((file)
(format #t "~a\n" (let ((system (assoc-ref opts 'system)))
(build-docker-image file #:system 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~%"))))) ;; TODO: Remove this restriction.
(format (leave (_ "only a single item can be exported to Docker~%")))))
(leave (_ "~a: unknown archive format~%") format))) (format
(leave (_ "unable to export the given packages~%"))))) (leave (_ "~a: unknown archive format~%") format))))))
(define (generate-key-pair parameters) (define (generate-key-pair parameters)
"Generate a key pair with PARAMETERS, a canonical sexp, and store it in the "Generate a key pair with PARAMETERS, a canonical sexp, and store it in the

14
guix/scripts/build.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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> ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
@ -726,11 +726,7 @@ needed."
(map (compose list derivation-file-name) drv) (map (compose list derivation-file-name) drv)
roots)) roots))
((not (assoc-ref opts 'dry-run?)) ((not (assoc-ref opts 'dry-run?))
(and (build-derivations store drv mode) (let ((outputs (build-derivations store drv mode)))
(for-each show-derivation-outputs drv) (format #t "~{~a~%~}" outputs)
(for-each (cut register-root store <> <>) (for-each (cut register-root store <> <>)
(map (lambda (drv) outputs roots))))))))))
(map cdr
(derivation->output-paths drv)))
drv)
roots))))))))))

19
guix/scripts/copy.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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. ;;; 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?) #:use-substitutes? (assoc-ref opts 'substitutes?)
#:dry-run? (assoc-ref opts 'dry-run?)) #:dry-run? (assoc-ref opts 'dry-run?))
(and (or (assoc-ref opts 'dry-run?) (let ((items (if (assoc-ref opts 'dry-run?)
(build-derivations local drv)) items
(let* ((session (open-ssh-session host #:user user #:port port)) (build-derivations local drv)))
(sent (send-files local items (session (open-ssh-session host #:user user #:port port))
(connect-to-remote-daemon session) (sent (send-files local items
#:recursive? #t))) (connect-to-remote-daemon session)
(format #t "~{~a~%~}" sent) #:recursive? #t)))
sent))))) (format #t "~{~a~%~}" sent)
sent))))
(define (retrieve-from-remote-host source opts) (define (retrieve-from-remote-host source opts)
"Retrieve ITEMS from SOURCE." "Retrieve ITEMS from SOURCE."

29
guix/scripts/package.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2013, 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2013, 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com>
@ -207,19 +207,20 @@ specified in MANIFEST, a manifest object."
#:use-substitutes? use-substitutes? #:use-substitutes? use-substitutes?
#:dry-run? dry-run?) #:dry-run? dry-run?)
(cond (or dry-run?
(dry-run? #t) (match (build-derivations store (list prof-drv))
((and (file-exists? profile) ((prof)
(and=> (readlink* profile) (cut string=? prof <>))) (cond
(format (current-error-port) (_ "nothing to be done~%"))) ((and (file-exists? profile)
(else (and=> (readlink* profile) (cut string=? prof <>)))
(let* ((number (generation-number profile)) (format (current-error-port) (_ "nothing to be done~%")))
(else
(let* ((number (generation-number profile))
;; Always use NUMBER + 1 for the new profile, possibly ;; Always use NUMBER + 1 for the new profile, possibly
;; overwriting a "previous future generation". ;; overwriting a "previous future generation".
(name (generation-file-name profile (+ 1 number)))) (name (generation-file-name profile (+ 1 number)))
(and (build-derivations store (list prof-drv)) (entries (manifest-entries manifest))
(let* ((entries (manifest-entries manifest))
(count (length entries))) (count (length entries)))
(switch-symlinks name prof) (switch-symlinks name prof)
(switch-symlinks profile name) (switch-symlinks profile name)
@ -230,7 +231,7 @@ specified in MANIFEST, a manifest object."
count) count)
count) count)
(display-search-paths entries (list profile) (display-search-paths entries (list profile)
#:kind 'prefix)))))))) #:kind 'prefix)))))))))
;;; ;;;

31
guix/scripts/system.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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 Alex Kost <alezost@gmail.com>
;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
;;; ;;;
@ -445,20 +445,21 @@ open connection to the store."
entries entries
#:old-entries old-entries)))) #:old-entries old-entries))))
(show-what-to-build store (list grub.cfg)) (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 ;; 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 ;; 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 ;; we don't in general have access to the same version of the GRUB package
;; which was used when installing this other system generation. ;; which was used when installing this other system generation.
(let* ((grub.cfg-path (derivation->output-path grub.cfg)) (match (build-derivations store (list grub.cfg))
(gc-root (string-append %gc-roots-directory "/grub.cfg")) ((grub.cfg-path)
(temp-gc-root (string-append gc-root ".new"))) (let* ((gc-root (string-append %gc-roots-directory "/grub.cfg"))
(switch-symlinks temp-gc-root grub.cfg-path) (temp-gc-root (string-append gc-root ".new")))
(unless (false-if-exception (install-grub-config grub.cfg-path "/")) (switch-symlinks temp-gc-root grub.cfg-path)
(delete-file temp-gc-root) (unless (false-if-exception (install-grub-config grub.cfg-path "/"))
(leave (_ "failed to re-install GRUB configuration file: '~a'~%") (delete-file temp-gc-root)
grub.cfg-path)) (leave (_ "failed to re-install GRUB configuration file: '~a'~%")
(rename-file temp-gc-root gc-root)))) 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 grub)
(list sys grub.cfg)) (list sys grub.cfg))
(list sys))) (list sys)))
(% (if derivations-only? (results (if derivations-only?
(return (for-each (compose println derivation-file-name) (return (map derivation-file-name drvs))
drvs))
(maybe-build drvs #:dry-run? dry-run? (maybe-build drvs #:dry-run? dry-run?
#:use-substitutes? use-substitutes?)))) #:use-substitutes? use-substitutes?))))
(if (or dry-run? derivations-only?) (if (or dry-run? derivations-only?)
(return #f) (return #f)
(begin (begin
(for-each (compose println derivation->output-path) (for-each println results)
drvs)
;; Make sure GRUB is accessible. ;; Make sure GRUB is accessible.
(when grub? (when grub?

6
guix/upstream.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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> ;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
@ -201,9 +201,7 @@ values: 'interactive' (default), 'always', and 'never'."
(run-with-store store (run-with-store store
(mlet %store-monad ((drv (uncompressed-tarball (mlet %store-monad ((drv (uncompressed-tarball
(basename url) tarball))) (basename url) tarball)))
(mbegin %store-monad (built-derivations (list drv))))))
(built-derivations (list drv))
(return (derivation->output-path drv)))))))
(ret (gnupg-verify* sig data #:key-download key-download))) (ret (gnupg-verify* sig data #:key-download key-download)))
(if ret (if ret