From 5f5e9a5cd63352875ea968f89bc4b8cb4318cc02 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 18 Mar 2020 23:00:13 +0100 Subject: 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(-) (limited to 'guix/scripts') 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)))) - - (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 - ;; ). - #: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 + ;; ). + #: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))))))))) -- cgit v1.2.3