scripts: package: Transform before creating manifest entries.
* guix/scripts/package.scm (options->installable): Add TRANSFORM argument, to be able to directly transform the new packages before creating their manifest entries. (process-actions): Remove transform-entry, and step3, transforming directly in step2. * tests/guix-package.sh: Add test. Signed-off-by: Ludovic Courtès <ludo@gnu.org>
This commit is contained in:
parent
a6da02217e
commit
aaf547824e
2 changed files with 42 additions and 24 deletions
|
@ -10,6 +10,7 @@
|
||||||
;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net>
|
;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net>
|
||||||
;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com>
|
;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com>
|
||||||
;;; Copyright © 2018 Steve Sprang <scs@stevesprang.com>
|
;;; Copyright © 2018 Steve Sprang <scs@stevesprang.com>
|
||||||
|
;;; Copyright © 2022 Josselin Poiret <dev@jpoiret.xyz>
|
||||||
;;;
|
;;;
|
||||||
;;; This file is part of GNU Guix.
|
;;; This file is part of GNU Guix.
|
||||||
;;;
|
;;;
|
||||||
|
@ -694,10 +695,10 @@ the resulting manifest entry."
|
||||||
(manifest-entry-with-provenance
|
(manifest-entry-with-provenance
|
||||||
(package->manifest-entry package output)))
|
(package->manifest-entry package output)))
|
||||||
|
|
||||||
(define (options->installable opts manifest transaction)
|
(define (options->installable opts manifest transform transaction)
|
||||||
"Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold',
|
"Given MANIFEST, the current manifest, OPTS, and TRANSFORM, the result of
|
||||||
return an variant of TRANSACTION that accounts for the specified installations
|
'args-fold', return an variant of TRANSACTION that accounts for the specified
|
||||||
and upgrades."
|
installations, upgrades and transformations."
|
||||||
(define upgrade?
|
(define upgrade?
|
||||||
(options->upgrade-predicate opts))
|
(options->upgrade-predicate opts))
|
||||||
|
|
||||||
|
@ -714,13 +715,14 @@ and upgrades."
|
||||||
(('install . (? package? p))
|
(('install . (? package? p))
|
||||||
;; When given a package via `-e', install the first of its
|
;; When given a package via `-e', install the first of its
|
||||||
;; outputs (XXX).
|
;; outputs (XXX).
|
||||||
(package->manifest-entry* p "out"))
|
(package->manifest-entry* (transform p) "out"))
|
||||||
(('install . (? string? spec))
|
(('install . (? string? spec))
|
||||||
(if (store-path? spec)
|
(if (store-path? spec)
|
||||||
(store-item->manifest-entry spec)
|
(store-item->manifest-entry spec)
|
||||||
(let-values (((package output)
|
(let-values (((package output)
|
||||||
(specification->package+output spec)))
|
(specification->package+output spec)))
|
||||||
(package->manifest-entry* package output))))
|
(package->manifest-entry* (transform package)
|
||||||
|
output))))
|
||||||
(('install . obj)
|
(('install . obj)
|
||||||
(leave (G_ "cannot install non-package object: ~s~%")
|
(leave (G_ "cannot install non-package object: ~s~%")
|
||||||
obj))
|
obj))
|
||||||
|
@ -979,16 +981,6 @@ processed, #f otherwise."
|
||||||
(define profile (or (assoc-ref opts 'profile) %current-profile))
|
(define profile (or (assoc-ref opts 'profile) %current-profile))
|
||||||
(define transform (options->transformation opts))
|
(define transform (options->transformation opts))
|
||||||
|
|
||||||
(define (transform-entry entry)
|
|
||||||
(let ((item (transform (manifest-entry-item entry))))
|
|
||||||
(manifest-entry-with-transformations
|
|
||||||
(manifest-entry
|
|
||||||
(inherit entry)
|
|
||||||
(item item)
|
|
||||||
(version (if (package? item)
|
|
||||||
(package-version item)
|
|
||||||
(manifest-entry-version entry)))))))
|
|
||||||
|
|
||||||
(when (equal? profile %current-profile)
|
(when (equal? profile %current-profile)
|
||||||
;; Normally the daemon created %CURRENT-PROFILE when we connected, unless
|
;; Normally the daemon created %CURRENT-PROFILE when we connected, unless
|
||||||
;; it's a version that lacks the fix for <https://bugs.gnu.org/37744>
|
;; it's a version that lacks the fix for <https://bugs.gnu.org/37744>
|
||||||
|
@ -1021,16 +1013,12 @@ processed, #f otherwise."
|
||||||
(map load-manifest files))))))
|
(map load-manifest files))))))
|
||||||
(step1 (options->removable opts manifest
|
(step1 (options->removable opts manifest
|
||||||
(manifest-transaction)))
|
(manifest-transaction)))
|
||||||
(step2 (options->installable opts manifest step1))
|
(step2 (options->installable opts manifest transform step1))
|
||||||
(step3 (manifest-transaction
|
(new (manifest-perform-transaction manifest step2))
|
||||||
(inherit step2)
|
|
||||||
(install (map transform-entry
|
|
||||||
(manifest-transaction-install step2)))))
|
|
||||||
(new (manifest-perform-transaction manifest step3))
|
|
||||||
(trans (if (null? files)
|
(trans (if (null? files)
|
||||||
step3
|
step2
|
||||||
(fold manifest-transaction-install-entry
|
(fold manifest-transaction-install-entry
|
||||||
step3
|
step2
|
||||||
(manifest-entries manifest)))))
|
(manifest-entries manifest)))))
|
||||||
|
|
||||||
(warn-about-old-distro)
|
(warn-about-old-distro)
|
||||||
|
|
|
@ -1,6 +1,7 @@
|
||||||
# GNU Guix --- Functional package management for GNU
|
# GNU Guix --- Functional package management for GNU
|
||||||
# Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org>
|
# Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org>
|
||||||
# Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
|
# Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
|
||||||
|
# Copyright © 2022 Josselin Poiret <dev@jpoiret.xyz>
|
||||||
#
|
#
|
||||||
# This file is part of GNU Guix.
|
# This file is part of GNU Guix.
|
||||||
#
|
#
|
||||||
|
@ -210,6 +211,35 @@ test "$(readlink -f "$profile/bin/guile")" \
|
||||||
test ! -f "$profile/bin/sed"
|
test ! -f "$profile/bin/sed"
|
||||||
rm "$profile" "$profile"-[0-9]-link
|
rm "$profile" "$profile"-[0-9]-link
|
||||||
|
|
||||||
|
# Make sure transformations apply to propagated inputs and don't lead to
|
||||||
|
# conflicts when installing them alongside, see
|
||||||
|
# <https://issues.guix.gnu.org/55316>.
|
||||||
|
mkdir "$module_dir"
|
||||||
|
cat > "$module_dir/test.scm" <<EOF
|
||||||
|
(define-module (test)
|
||||||
|
#:use-module (guix packages)
|
||||||
|
#:use-module (gnu packages base)
|
||||||
|
#:use-module (guix build-system trivial))
|
||||||
|
|
||||||
|
(define-public dummy-package
|
||||||
|
(package
|
||||||
|
(name "dummy-package")
|
||||||
|
(version "1")
|
||||||
|
(source #f)
|
||||||
|
(build-system trivial-build-system)
|
||||||
|
(propagated-inputs
|
||||||
|
(list hello))
|
||||||
|
(synopsis "dummy")
|
||||||
|
(description "dummy")
|
||||||
|
(home-page "dummy")
|
||||||
|
(license #f)))
|
||||||
|
EOF
|
||||||
|
guix package -p "$profile" -L "$module_dir"\
|
||||||
|
-i hello dummy-package \
|
||||||
|
--without-tests=hello -n
|
||||||
|
rm "$module_dir/test.scm"
|
||||||
|
rmdir "$module_dir"
|
||||||
|
|
||||||
# Profiles with a relative file name. Make sure we don't create dangling
|
# Profiles with a relative file name. Make sure we don't create dangling
|
||||||
# symlinks--see bug report at
|
# symlinks--see bug report at
|
||||||
# <https://lists.gnu.org/archive/html/guix-devel/2018-07/msg00036.html>.
|
# <https://lists.gnu.org/archive/html/guix-devel/2018-07/msg00036.html>.
|
||||||
|
|
Reference in a new issue