mirror of
git://git.savannah.gnu.org/guix.git
synced 2023-12-14 03:33:07 +01:00
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?'.
This commit is contained in:
Ludovic Courtès
parent
bdda46a67d
commit
5f5e9a5cd6
|
|
@ -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)))))))))
|
||||
|
|
|
|||
Loading…
Reference in a new issue