[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
06/16: pack: Use 'with-build-handler'.
|
From: |
guix-commits |
|
Subject: |
06/16: pack: Use 'with-build-handler'. |
|
Date: |
Sun, 22 Mar 2020 07:43:11 -0400 (EDT) |
civodul pushed a commit to branch master
in repository guix.
commit 5f5e9a5cd63352875ea968f89bc4b8cb4318cc02
Author: Ludovic Courtès <address@hidden>
AuthorDate: Wed Mar 18 23:00:13 2020 +0100
pack: Use 'with-build-handler'.
* guix/scripts/pack.scm (guix-pack): Wrap 'parameterize' in
'with-build-handler'. Remove explicit call to 'show-what-to-build'.
Call 'build-derivations' regardless of whether OPTS contains 'dry-run?'.
---
guix/scripts/pack.scm | 204 +++++++++++++++++++++++++-------------------------
1 file changed, 101 insertions(+), 103 deletions(-)
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 652b4c6..6829d72 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -1022,108 +1022,106 @@ Create a bundle of PACKAGE.\n"))
;; Set the build options before we do anything else.
(set-build-options-from-command-line store opts)
- (parameterize ((%graft? (assoc-ref opts 'graft?))
- (%guile-for-build (package-derivation
- store
- (if (assoc-ref opts 'bootstrap?)
- %bootstrap-guile
- (canonical-package guile-2.2))
- (assoc-ref opts 'system)
- #:graft? (assoc-ref opts 'graft?))))
- (let* ((dry-run? (assoc-ref opts 'dry-run?))
- (derivation? (assoc-ref opts 'derivation-only?))
- (relocatable? (assoc-ref opts 'relocatable?))
- (proot? (eq? relocatable? 'proot))
- (manifest (let ((manifest (manifest-from-args store opts)))
- ;; Note: We cannot honor '--bootstrap' here
because
- ;; 'glibc-bootstrap' lacks 'libc.a'.
- (if relocatable?
- (map-manifest-entries
- (cut wrapped-manifest-entry <> #:proot?
proot?)
- manifest)
- manifest)))
- (pack-format (assoc-ref opts 'format))
- (name (string-append (symbol->string pack-format)
- "-pack"))
- (target (assoc-ref opts 'target))
- (bootstrap? (assoc-ref opts 'bootstrap?))
- (compressor (if bootstrap?
- bootstrap-xz
- (assoc-ref opts 'compressor)))
- (archiver (if (equal? pack-format 'squashfs)
- squashfs-tools
- (if bootstrap?
- %bootstrap-coreutils&co
- tar)))
- (symlinks (assoc-ref opts 'symlinks))
- (build-image (match (assq-ref %formats pack-format)
- ((? procedure? proc) proc)
- (#f
- (leave (G_ "~a: unknown pack format~%")
- pack-format))))
- (localstatedir? (assoc-ref opts 'localstatedir?))
- (entry-point (assoc-ref opts 'entry-point))
- (profile-name (assoc-ref opts 'profile-name))
- (gc-root (assoc-ref opts 'gc-root)))
- (define (lookup-package package)
- (manifest-lookup manifest (manifest-pattern (name package))))
-
- (when (null? (manifest-entries manifest))
- (warning (G_ "no packages specified; building an empty pack~%")))
-
- (when (and (eq? pack-format 'squashfs)
- (not (any lookup-package '("bash" "bash-minimal"))))
- (warning (G_ "Singularity requires you to provide a shell~%"))
- (display-hint (G_ "Add @code{bash} or @code{bash-minimal} \
+ (with-build-handler (build-notifier #:dry-run?
+ (assoc-ref opts 'dry-run?)
+ #:use-substitutes?
+ (assoc-ref opts 'substitutes?))
+ (parameterize ((%graft? (assoc-ref opts 'graft?))
+ (%guile-for-build (package-derivation
+ store
+ (if (assoc-ref opts 'bootstrap?)
+ %bootstrap-guile
+ (canonical-package guile-2.2))
+ (assoc-ref opts 'system)
+ #:graft? (assoc-ref opts
'graft?))))
+ (let* ((derivation? (assoc-ref opts 'derivation-only?))
+ (relocatable? (assoc-ref opts 'relocatable?))
+ (proot? (eq? relocatable? 'proot))
+ (manifest (let ((manifest (manifest-from-args store
opts)))
+ ;; Note: We cannot honor '--bootstrap' here
because
+ ;; 'glibc-bootstrap' lacks 'libc.a'.
+ (if relocatable?
+ (map-manifest-entries
+ (cut wrapped-manifest-entry <> #:proot?
proot?)
+ manifest)
+ manifest)))
+ (pack-format (assoc-ref opts 'format))
+ (name (string-append (symbol->string pack-format)
+ "-pack"))
+ (target (assoc-ref opts 'target))
+ (bootstrap? (assoc-ref opts 'bootstrap?))
+ (compressor (if bootstrap?
+ bootstrap-xz
+ (assoc-ref opts 'compressor)))
+ (archiver (if (equal? pack-format 'squashfs)
+ squashfs-tools
+ (if bootstrap?
+ %bootstrap-coreutils&co
+ tar)))
+ (symlinks (assoc-ref opts 'symlinks))
+ (build-image (match (assq-ref %formats pack-format)
+ ((? procedure? proc) proc)
+ (#f
+ (leave (G_ "~a: unknown pack format~%")
+ pack-format))))
+ (localstatedir? (assoc-ref opts 'localstatedir?))
+ (entry-point (assoc-ref opts 'entry-point))
+ (profile-name (assoc-ref opts 'profile-name))
+ (gc-root (assoc-ref opts 'gc-root)))
+ (define (lookup-package package)
+ (manifest-lookup manifest (manifest-pattern (name package))))
+
+ (when (null? (manifest-entries manifest))
+ (warning (G_ "no packages specified; building an empty
pack~%")))
+
+ (when (and (eq? pack-format 'squashfs)
+ (not (any lookup-package '("bash" "bash-minimal"))))
+ (warning (G_ "Singularity requires you to provide a shell~%"))
+ (display-hint (G_ "Add @code{bash} or @code{bash-minimal} \
to your package list.")))
- (run-with-store store
- (mlet* %store-monad ((profile (profile-derivation
- manifest
-
- ;; Always produce relative
- ;; symlinks for Singularity (see
- ;; <https://bugs.gnu.org/34913>).
- #:relative-symlinks?
- (or relocatable?
- (eq? 'squashfs pack-format))
-
- #:hooks (if bootstrap?
- '()
-
%default-profile-hooks)
- #:locales? (not bootstrap?)
- #:target target))
- (drv (build-image name profile
- #:target
- target
- #:compressor
- compressor
- #:symlinks
- symlinks
- #:localstatedir?
- localstatedir?
- #:entry-point
- entry-point
- #:profile-name
- profile-name
- #:archiver
- archiver)))
- (mbegin %store-monad
- (munless derivation?
- (show-what-to-build* (list drv)
- #:use-substitutes?
- (assoc-ref opts 'substitutes?)
- #:dry-run? dry-run?))
- (mwhen derivation?
- (return (format #t "~a~%"
- (derivation-file-name drv))))
- (munless (or derivation? dry-run?)
- (built-derivations (list drv))
- (mwhen gc-root
- (register-root* (match (derivation->output-paths drv)
- (((names . items) ...)
- items))
- gc-root))
- (return (format #t "~a~%"
- (derivation->output-path drv))))))
- #:system (assoc-ref opts 'system))))))))
+ (run-with-store store
+ (mlet* %store-monad ((profile (profile-derivation
+ manifest
+
+ ;; Always produce relative
+ ;; symlinks for Singularity (see
+ ;;
<https://bugs.gnu.org/34913>).
+ #:relative-symlinks?
+ (or relocatable?
+ (eq? 'squashfs pack-format))
+
+ #:hooks (if bootstrap?
+ '()
+
%default-profile-hooks)
+ #:locales? (not bootstrap?)
+ #:target target))
+ (drv (build-image name profile
+ #:target
+ target
+ #:compressor
+ compressor
+ #:symlinks
+ symlinks
+ #:localstatedir?
+ localstatedir?
+ #:entry-point
+ entry-point
+ #:profile-name
+ profile-name
+ #:archiver
+ archiver)))
+ (mbegin %store-monad
+ (mwhen derivation?
+ (return (format #t "~a~%"
+ (derivation-file-name drv))))
+ (munless derivation?
+ (built-derivations (list drv))
+ (mwhen gc-root
+ (register-root* (match (derivation->output-paths drv)
+ (((names . items) ...)
+ items))
+ gc-root))
+ (return (format #t "~a~%"
+ (derivation->output-path drv))))))
+ #:system (assoc-ref opts 'system)))))))))
- 05/16: deploy: Use 'with-build-handler'., (continued)
- 05/16: deploy: Use 'with-build-handler'., guix-commits, 2020/03/22
- 01/16: syscalls: 'with-file-lock' re-grabs lock when reentering its dynamic extent., guix-commits, 2020/03/22
- 03/16: ui: Add a notification build handler., guix-commits, 2020/03/22
- 04/16: guix build: Use 'with-build-handler'., guix-commits, 2020/03/22
- 08/16: guix system: Use 'with-build-handler'., guix-commits, 2020/03/22
- 10/16: ui: 'show-what-to-build' returns two values, for builds and downloads., guix-commits, 2020/03/22
- 12/16: copy: Factorize 'with-store' & co., guix-commits, 2020/03/22
- 15/16: packages: 'package-field-location' handles missing source properties., guix-commits, 2020/03/22
- 13/16: copy: Actually implement '--dry-run'., guix-commits, 2020/03/22
- 07/16: guix package, pull: Use 'with-build-handler'., guix-commits, 2020/03/22
- 06/16: pack: Use 'with-build-handler'.,
guix-commits <=
- 09/16: ui: 'show-what-to-build' returns true when there are grafts to build., guix-commits, 2020/03/22
- 11/16: ui: 'build-notifier' invokes continuation when there's nothing to do., guix-commits, 2020/03/22
- 14/16: copy: Use 'with-build-handler'., guix-commits, 2020/03/22
- 16/16: hydra: evaluate: Use 'with-build-handler'., guix-commits, 2020/03/22