From: "Ludovic Courtès" <ludo@gnu.org>
To: 40130@debbugs.gnu.org
Cc: "Ludovic Courtès" <ludo@gnu.org>
Subject: [bug#40130] [PATCH 6/8] pack: Use 'with-build-handler'.
Date: Thu, 19 Mar 2020 12:02:50 +0100 [thread overview]
Message-ID: <20200319110252.5081-6-ludo@gnu.org> (raw)
In-Reply-To: <20200319110252.5081-1-ludo@gnu.org>
* 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 | 196 +++++++++++++++++++++---------------------
1 file changed, 97 insertions(+), 99 deletions(-)
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 652b4c63c4..6829d7265f 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))))
+ (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 (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} \
+ (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
+ (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))
+ ;; 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))))))))
+ #: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)))))))))
--
2.25.1
next prev parent reply other threads:[~2020-03-19 11:04 UTC|newest]
Thread overview: 11+ messages / expand[flat|nested] mbox.gz Atom feed top
2020-03-19 10:56 [bug#40130] [PATCH 0/8] Add 'with-build-handler' and use it to improve UI feedback Ludovic Courtès
2020-03-19 11:02 ` [bug#40130] [PATCH 1/8] syscalls: 'with-file-lock' re-grabs lock when reentering its dynamic extent Ludovic Courtès
2020-03-19 11:02 ` [bug#40130] [PATCH 2/8] store: Add 'with-build-handler' Ludovic Courtès
2020-03-19 11:02 ` [bug#40130] [PATCH 3/8] ui: Add a notification build handler Ludovic Courtès
2020-03-19 11:02 ` [bug#40130] [PATCH 4/8] guix build: Use 'with-build-handler' Ludovic Courtès
2020-03-19 11:02 ` [bug#40130] [PATCH 5/8] deploy: " Ludovic Courtès
2020-03-19 11:02 ` Ludovic Courtès [this message]
2020-03-19 11:02 ` [bug#40130] [PATCH 7/8] guix package, pull: " Ludovic Courtès
2020-03-19 11:02 ` [bug#40130] [PATCH 8/8] guix system: " Ludovic Courtès
2020-03-22 11:44 ` bug#40130: [PATCH 0/8] Add 'with-build-handler' and use it to improve UI feedback Ludovic Courtès
2020-03-22 12:44 ` [bug#40130] " Ricardo Wurmus
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://guix.gnu.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20200319110252.5081-6-ludo@gnu.org \
--to=ludo@gnu.org \
--cc=40130@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).