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
1 changed files with 97 additions and 99 deletions
|
|
@ -1022,108 +1022,106 @@ Create a bundle of PACKAGE.\n"))
|
||||||
;; Set the build options before we do anything else.
|
;; Set the build options before we do anything else.
|
||||||
(set-build-options-from-command-line store opts)
|
(set-build-options-from-command-line store opts)
|
||||||
|
|
||||||
(parameterize ((%graft? (assoc-ref opts 'graft?))
|
(with-build-handler (build-notifier #:dry-run?
|
||||||
(%guile-for-build (package-derivation
|
(assoc-ref opts 'dry-run?)
|
||||||
store
|
#:use-substitutes?
|
||||||
(if (assoc-ref opts 'bootstrap?)
|
(assoc-ref opts 'substitutes?))
|
||||||
%bootstrap-guile
|
(parameterize ((%graft? (assoc-ref opts 'graft?))
|
||||||
(canonical-package guile-2.2))
|
(%guile-for-build (package-derivation
|
||||||
(assoc-ref opts 'system)
|
store
|
||||||
#:graft? (assoc-ref opts 'graft?))))
|
(if (assoc-ref opts 'bootstrap?)
|
||||||
(let* ((dry-run? (assoc-ref opts 'dry-run?))
|
%bootstrap-guile
|
||||||
(derivation? (assoc-ref opts 'derivation-only?))
|
(canonical-package guile-2.2))
|
||||||
(relocatable? (assoc-ref opts 'relocatable?))
|
(assoc-ref opts 'system)
|
||||||
(proot? (eq? relocatable? 'proot))
|
#:graft? (assoc-ref opts 'graft?))))
|
||||||
(manifest (let ((manifest (manifest-from-args store opts)))
|
(let* ((derivation? (assoc-ref opts 'derivation-only?))
|
||||||
;; Note: We cannot honor '--bootstrap' here because
|
(relocatable? (assoc-ref opts 'relocatable?))
|
||||||
;; 'glibc-bootstrap' lacks 'libc.a'.
|
(proot? (eq? relocatable? 'proot))
|
||||||
(if relocatable?
|
(manifest (let ((manifest (manifest-from-args store opts)))
|
||||||
(map-manifest-entries
|
;; Note: We cannot honor '--bootstrap' here because
|
||||||
(cut wrapped-manifest-entry <> #:proot? proot?)
|
;; 'glibc-bootstrap' lacks 'libc.a'.
|
||||||
manifest)
|
(if relocatable?
|
||||||
manifest)))
|
(map-manifest-entries
|
||||||
(pack-format (assoc-ref opts 'format))
|
(cut wrapped-manifest-entry <> #:proot? proot?)
|
||||||
(name (string-append (symbol->string pack-format)
|
manifest)
|
||||||
"-pack"))
|
manifest)))
|
||||||
(target (assoc-ref opts 'target))
|
(pack-format (assoc-ref opts 'format))
|
||||||
(bootstrap? (assoc-ref opts 'bootstrap?))
|
(name (string-append (symbol->string pack-format)
|
||||||
(compressor (if bootstrap?
|
"-pack"))
|
||||||
bootstrap-xz
|
(target (assoc-ref opts 'target))
|
||||||
(assoc-ref opts 'compressor)))
|
(bootstrap? (assoc-ref opts 'bootstrap?))
|
||||||
(archiver (if (equal? pack-format 'squashfs)
|
(compressor (if bootstrap?
|
||||||
squashfs-tools
|
bootstrap-xz
|
||||||
(if bootstrap?
|
(assoc-ref opts 'compressor)))
|
||||||
%bootstrap-coreutils&co
|
(archiver (if (equal? pack-format 'squashfs)
|
||||||
tar)))
|
squashfs-tools
|
||||||
(symlinks (assoc-ref opts 'symlinks))
|
(if bootstrap?
|
||||||
(build-image (match (assq-ref %formats pack-format)
|
%bootstrap-coreutils&co
|
||||||
((? procedure? proc) proc)
|
tar)))
|
||||||
(#f
|
(symlinks (assoc-ref opts 'symlinks))
|
||||||
(leave (G_ "~a: unknown pack format~%")
|
(build-image (match (assq-ref %formats pack-format)
|
||||||
pack-format))))
|
((? procedure? proc) proc)
|
||||||
(localstatedir? (assoc-ref opts 'localstatedir?))
|
(#f
|
||||||
(entry-point (assoc-ref opts 'entry-point))
|
(leave (G_ "~a: unknown pack format~%")
|
||||||
(profile-name (assoc-ref opts 'profile-name))
|
pack-format))))
|
||||||
(gc-root (assoc-ref opts 'gc-root)))
|
(localstatedir? (assoc-ref opts 'localstatedir?))
|
||||||
(define (lookup-package package)
|
(entry-point (assoc-ref opts 'entry-point))
|
||||||
(manifest-lookup manifest (manifest-pattern (name package))))
|
(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))
|
(when (null? (manifest-entries manifest))
|
||||||
(warning (G_ "no packages specified; building an empty pack~%")))
|
(warning (G_ "no packages specified; building an empty pack~%")))
|
||||||
|
|
||||||
(when (and (eq? pack-format 'squashfs)
|
(when (and (eq? pack-format 'squashfs)
|
||||||
(not (any lookup-package '("bash" "bash-minimal"))))
|
(not (any lookup-package '("bash" "bash-minimal"))))
|
||||||
(warning (G_ "Singularity requires you to provide a shell~%"))
|
(warning (G_ "Singularity requires you to provide a shell~%"))
|
||||||
(display-hint (G_ "Add @code{bash} or @code{bash-minimal} \
|
(display-hint (G_ "Add @code{bash} or @code{bash-minimal} \
|
||||||
to your package list.")))
|
to your package list.")))
|
||||||
|
|
||||||
(run-with-store store
|
(run-with-store store
|
||||||
(mlet* %store-monad ((profile (profile-derivation
|
(mlet* %store-monad ((profile (profile-derivation
|
||||||
manifest
|
manifest
|
||||||
|
|
||||||
;; Always produce relative
|
;; Always produce relative
|
||||||
;; symlinks for Singularity (see
|
;; symlinks for Singularity (see
|
||||||
;; <https://bugs.gnu.org/34913>).
|
;; <https://bugs.gnu.org/34913>).
|
||||||
#:relative-symlinks?
|
#:relative-symlinks?
|
||||||
(or relocatable?
|
(or relocatable?
|
||||||
(eq? 'squashfs pack-format))
|
(eq? 'squashfs pack-format))
|
||||||
|
|
||||||
#:hooks (if bootstrap?
|
#:hooks (if bootstrap?
|
||||||
'()
|
'()
|
||||||
%default-profile-hooks)
|
%default-profile-hooks)
|
||||||
#:locales? (not bootstrap?)
|
#:locales? (not bootstrap?)
|
||||||
#:target target))
|
#:target target))
|
||||||
(drv (build-image name profile
|
(drv (build-image name profile
|
||||||
#:target
|
#:target
|
||||||
target
|
target
|
||||||
#:compressor
|
#:compressor
|
||||||
compressor
|
compressor
|
||||||
#:symlinks
|
#:symlinks
|
||||||
symlinks
|
symlinks
|
||||||
#:localstatedir?
|
#:localstatedir?
|
||||||
localstatedir?
|
localstatedir?
|
||||||
#:entry-point
|
#:entry-point
|
||||||
entry-point
|
entry-point
|
||||||
#:profile-name
|
#:profile-name
|
||||||
profile-name
|
profile-name
|
||||||
#:archiver
|
#:archiver
|
||||||
archiver)))
|
archiver)))
|
||||||
(mbegin %store-monad
|
(mbegin %store-monad
|
||||||
(munless derivation?
|
(mwhen derivation?
|
||||||
(show-what-to-build* (list drv)
|
(return (format #t "~a~%"
|
||||||
#:use-substitutes?
|
(derivation-file-name drv))))
|
||||||
(assoc-ref opts 'substitutes?)
|
(munless derivation?
|
||||||
#:dry-run? dry-run?))
|
(built-derivations (list drv))
|
||||||
(mwhen derivation?
|
(mwhen gc-root
|
||||||
(return (format #t "~a~%"
|
(register-root* (match (derivation->output-paths drv)
|
||||||
(derivation-file-name drv))))
|
(((names . items) ...)
|
||||||
(munless (or derivation? dry-run?)
|
items))
|
||||||
(built-derivations (list drv))
|
gc-root))
|
||||||
(mwhen gc-root
|
(return (format #t "~a~%"
|
||||||
(register-root* (match (derivation->output-paths drv)
|
(derivation->output-path drv))))))
|
||||||
(((names . items) ...)
|
#:system (assoc-ref opts 'system)))))))))
|
||||||
items))
|
|
||||||
gc-root))
|
|
||||||
(return (format #t "~a~%"
|
|
||||||
(derivation->output-path drv))))))
|
|
||||||
#:system (assoc-ref opts 'system))))))))
|
|
||||||
|
|
|
||||||
Reference in a new issue