Archived
1
0
Fork 0

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:
Josselin Poiret 2022-05-09 16:54:10 +02:00 committed by Ludovic Courtès
parent a6da02217e
commit aaf547824e
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 42 additions and 24 deletions

View file

@ -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)

View file

@ -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>.