me
/
guix
Archived
1
0
Fork 0
Code

profiles: Hooks honor the #:system parameter of ‘profile-derivation’. 

Fixes <https://issues.guix.gnu.org/65225>.

* guix/profiles.scm (info-dir-file, package-cache-file)
(info-dir-file, ghc-package-cache-file, ca-certificate-bundle)
(emacs-subdirs, gdk-pixbuf-loaders-cache-file, glib-schemas)
(gtk-icon-themes, gtk-im-modules, linux-module-database)
(xdg-desktop-database, xdg-mime-database, fonts-dir-file)
(manual-database, manual-database/optional): Add optional #:system
parameter and pass it to ‘gexp->derivation’.
(profile-derivation): Pass HOOK a second parameter, SYSTEM.
* gnu/bootloader.scm (efi-bootloader-profile)[efi-bootloader-profile-hook]:
Add optional #:system parameter and pass it to ‘gexp->derivation’.
* guix/channels.scm (package-cache-file): Likewise.
* tests/profiles.scm ("profile-derivation, #:system, and hooks"): New
test.

Reported-by: Tobias Geerinckx-Rice <me@tobias.gr>
Ludovic Courtès 2023-10-19 16:39:06 +02:00
parent 9d4b720e1f
commit 344e39c928
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
4 changed files with 60 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
gnu/bootloader.scm
View File

@ -2,7 +2,7 @@
;;; Copyright © 2017 David Craven <david@craven.ch> ;;; Copyright © 2017 David Craven <david@craven.ch>
;;; Copyright © 2017, 2020, 2022 Mathieu Othacehe <othacehe@gnu.org> ;;; Copyright © 2017, 2020, 2022 Mathieu Othacehe <othacehe@gnu.org>
;;; Copyright © 2017 Leo Famulari <leo@famulari.name> ;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
;;; Copyright © 2019, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2019, 2021, 2023 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2022 Josselin Poiret <dev@jpoiret.xyz> ;;; Copyright © 2022 Josselin Poiret <dev@jpoiret.xyz>
;;; Copyright © 2022 Reza Alizadeh Majd <r.majd@pantherx.org> ;;; Copyright © 2022 Reza Alizadeh Majd <r.majd@pantherx.org>
@ -335,7 +335,7 @@ FILES may contain file like objects produced by procedures like plain-file,
local-file, etc., or package contents produced with file-append. local-file, etc., or package contents produced with file-append.
HOOKS lists additional hook functions to modify the profile." HOOKS lists additional hook functions to modify the profile."
(define (efi-bootloader-profile-hook manifest) (define* (efi-bootloader-profile-hook manifest #:optional system)
(define build (define build
(with-imported-modules '((guix build utils)) (with-imported-modules '((guix build utils))
#~(begin #~(begin
@ -383,6 +383,7 @@ HOOKS lists additional hook functions to modify the profile."
(gexp->derivation "efi-bootloader-profile" (gexp->derivation "efi-bootloader-profile"
build build
#:system system
#:local-build? #t #:local-build? #t
#:substitutable? #f #:substitutable? #f
#:properties #:properties

3
guix/channels.scm
View File

@ -926,7 +926,7 @@ specified."
(entries -> (map instance->entry instances derivations))) (entries -> (map instance->entry instances derivations)))
(return (manifest entries)))) (return (manifest entries))))
(define (package-cache-file manifest) (define* (package-cache-file manifest #:optional system)
"Build a package cache file for the instance in MANIFEST. This is meant to "Build a package cache file for the instance in MANIFEST. This is meant to
be used as a profile hook." be used as a profile hook."
;; Note: Emit a profile in format version 3, which was introduced in 2017 ;; Note: Emit a profile in format version 3, which was introduced in 2017
@ -961,6 +961,7 @@ be used as a profile hook."
(gexp->derivation-in-inferior "guix-package-cache" build (gexp->derivation-in-inferior "guix-package-cache" build
profile profile
#:system system
;; If the Guix in PROFILE is too old and ;; If the Guix in PROFILE is too old and
;; lacks 'guix repl', don't build the cache ;; lacks 'guix repl', don't build the cache

49
guix/profiles.scm
View File

@ -993,7 +993,7 @@ if not found."
(anym %store-monad (anym %store-monad
entry-lookup-package (manifest-entries manifest))) entry-lookup-package (manifest-entries manifest)))
(define (info-dir-file manifest) (define* (info-dir-file manifest #:optional system)
"Return a derivation that builds the 'dir' file for all the entries of "Return a derivation that builds the 'dir' file for all the entries of
MANIFEST." MANIFEST."
(define texinfo ;lazy reference (define texinfo ;lazy reference
@ -1051,13 +1051,14 @@ MANIFEST."
'#$(manifest-inputs manifest))))))) '#$(manifest-inputs manifest)))))))
(gexp->derivation "info-dir" build (gexp->derivation "info-dir" build
#:system system
#:local-build? #t #:local-build? #t
#:substitutable? #f #:substitutable? #f
#:properties #:properties
`((type . profile-hook) `((type . profile-hook)
(hook . info-dir)))) (hook . info-dir))))
(define (ghc-package-cache-file manifest) (define* (ghc-package-cache-file manifest #:optional system)
"Return a derivation that builds the GHC 'package.cache' file for all the "Return a derivation that builds the GHC 'package.cache' file for all the
entries of MANIFEST, or #f if MANIFEST does not have any GHC packages." entries of MANIFEST, or #f if MANIFEST does not have any GHC packages."
(define ghc ;lazy reference (define ghc ;lazy reference
@ -1108,6 +1109,7 @@ entries of MANIFEST, or #f if MANIFEST does not have any GHC packages."
(if (any (cut string-prefix? "ghc" <>) (if (any (cut string-prefix? "ghc" <>)
(map manifest-entry-name (manifest-entries manifest))) (map manifest-entry-name (manifest-entries manifest)))
(gexp->derivation "ghc-package-cache" build (gexp->derivation "ghc-package-cache" build
#:system system
#:local-build? #t #:local-build? #t
#:substitutable? #f #:substitutable? #f
#:properties #:properties
@ -1115,7 +1117,7 @@ entries of MANIFEST, or #f if MANIFEST does not have any GHC packages."
(hook . ghc-package-cache))) (hook . ghc-package-cache)))
(return #f)))) (return #f))))
(define (ca-certificate-bundle manifest) (define* (ca-certificate-bundle manifest #:optional system)
"Return a derivation that builds a single-file bundle containing the CA "Return a derivation that builds a single-file bundle containing the CA
certificates in the /etc/ssl/certs sub-directories of the packages in certificates in the /etc/ssl/certs sub-directories of the packages in
MANIFEST. Single-file bundles are required by programs such as Git and Lynx." MANIFEST. Single-file bundles are required by programs such as Git and Lynx."
@ -1179,13 +1181,14 @@ MANIFEST. Single-file bundles are required by programs such as Git and Lynx."
#t)))))) #t))))))
(gexp->derivation "ca-certificate-bundle" build (gexp->derivation "ca-certificate-bundle" build
#:system system
#:local-build? #t #:local-build? #t
#:substitutable? #f #:substitutable? #f
#:properties #:properties
`((type . profile-hook) `((type . profile-hook)
(hook . ca-certificate-bundle)))) (hook . ca-certificate-bundle))))
(define (emacs-subdirs manifest) (define* (emacs-subdirs manifest #:optional system)
(define build (define build
(with-imported-modules (source-module-closure (with-imported-modules (source-module-closure
'((guix build profiles) '((guix build profiles)
@ -1219,13 +1222,14 @@ MANIFEST. Single-file bundles are required by programs such as Git and Lynx."
(newline port) (newline port)
#t))))))) #t)))))))
(gexp->derivation "emacs-subdirs" build (gexp->derivation "emacs-subdirs" build
#:system system
#:local-build? #t #:local-build? #t
#:substitutable? #f #:substitutable? #f
#:properties #:properties
`((type . profile-hook) `((type . profile-hook)
(hook . emacs-subdirs)))) (hook . emacs-subdirs))))
(define (gdk-pixbuf-loaders-cache-file manifest) (define* (gdk-pixbuf-loaders-cache-file manifest #:optional system)
"Return a derivation that produces a loaders cache file for every gdk-pixbuf "Return a derivation that produces a loaders cache file for every gdk-pixbuf
loaders discovered in MANIFEST." loaders discovered in MANIFEST."
(define gdk-pixbuf ;lazy reference (define gdk-pixbuf ;lazy reference
@ -1264,6 +1268,7 @@ loaders discovered in MANIFEST."
(if gdk-pixbuf (if gdk-pixbuf
(gexp->derivation "gdk-pixbuf-loaders-cache-file" build (gexp->derivation "gdk-pixbuf-loaders-cache-file" build
#:system system
#:local-build? #t #:local-build? #t
#:substitutable? #f #:substitutable? #f
#:properties #:properties
@ -1271,7 +1276,7 @@ loaders discovered in MANIFEST."
(hook . gdk-pixbuf-loaders-cache-file))) (hook . gdk-pixbuf-loaders-cache-file)))
(return #f)))) (return #f))))
(define (glib-schemas manifest) (define* (glib-schemas manifest #:optional system)
"Return a derivation that unions all schemas from manifest entries and "Return a derivation that unions all schemas from manifest entries and
creates the Glib 'gschemas.compiled' file." creates the Glib 'gschemas.compiled' file."
(define glib ; lazy reference (define glib ; lazy reference
@ -1318,6 +1323,7 @@ creates the Glib 'gschemas.compiled' file."
;; Don't run the hook when there's nothing to do. ;; Don't run the hook when there's nothing to do.
(if %glib (if %glib
(gexp->derivation "glib-schemas" build (gexp->derivation "glib-schemas" build
#:system system
#:local-build? #t #:local-build? #t
#:substitutable? #f #:substitutable? #f
#:properties #:properties
@ -1325,7 +1331,7 @@ creates the Glib 'gschemas.compiled' file."
(hook . glib-schemas))) (hook . glib-schemas)))
(return #f)))) (return #f))))
(define (gtk-icon-themes manifest) (define* (gtk-icon-themes manifest #:optional system)
"Return a derivation that unions all icon themes from manifest entries and "Return a derivation that unions all icon themes from manifest entries and
creates the GTK+ 'icon-theme.cache' file for each theme." creates the GTK+ 'icon-theme.cache' file for each theme."
(define gtk+ ; lazy reference (define gtk+ ; lazy reference
@ -1377,6 +1383,7 @@ creates the GTK+ 'icon-theme.cache' file for each theme."
;; Don't run the hook when there's nothing to do. ;; Don't run the hook when there's nothing to do.
(if %gtk+ (if %gtk+
(gexp->derivation "gtk-icon-themes" build (gexp->derivation "gtk-icon-themes" build
#:system system
#:local-build? #t #:local-build? #t
#:substitutable? #f #:substitutable? #f
#:properties #:properties
@ -1384,7 +1391,7 @@ creates the GTK+ 'icon-theme.cache' file for each theme."
(hook . gtk-icon-themes))) (hook . gtk-icon-themes)))
(return #f)))) (return #f))))
(define (gtk-im-modules manifest) (define* (gtk-im-modules manifest #:optional system)
"Return a derivation that builds the cache files for input method modules "Return a derivation that builds the cache files for input method modules
for both major versions of GTK+." for both major versions of GTK+."
@ -1454,6 +1461,7 @@ for both major versions of GTK+."
#t)))) #t))))
(if (or gtk+ gtk+-2) (if (or gtk+ gtk+-2)
(gexp->derivation "gtk-im-modules" gexp (gexp->derivation "gtk-im-modules" gexp
#:system system
#:local-build? #t #:local-build? #t
#:substitutable? #f #:substitutable? #f
#:properties #:properties
@ -1461,7 +1469,7 @@ for both major versions of GTK+."
(hook . gtk-im-modules))) (hook . gtk-im-modules)))
(return #f))))) (return #f)))))
(define (linux-module-database manifest) (define* (linux-module-database manifest #:optional system)
"Return a derivation that unites all the kernel modules of the manifest "Return a derivation that unites all the kernel modules of the manifest
and creates the dependency graph of all these kernel modules. and creates the dependency graph of all these kernel modules.
@ -1511,13 +1519,14 @@ This is meant to be used as a profile hook."
(_ (error "Specified Linux kernel and Linux kernel modules (_ (error "Specified Linux kernel and Linux kernel modules
are not all of the same version")))))))) are not all of the same version"))))))))
(gexp->derivation "linux-module-database" build (gexp->derivation "linux-module-database" build
#:system system
#:local-build? #t #:local-build? #t
#:substitutable? #f #:substitutable? #f
#:properties #:properties
`((type . profile-hook) `((type . profile-hook)
(hook . linux-module-database)))) (hook . linux-module-database))))
(define (xdg-desktop-database manifest) (define* (xdg-desktop-database manifest #:optional system)
"Return a derivation that builds the @file{mimeinfo.cache} database from "Return a derivation that builds the @file{mimeinfo.cache} database from
desktop files. It's used to query what applications can handle a given desktop files. It's used to query what applications can handle a given
MIME type." MIME type."
@ -1551,6 +1560,7 @@ MIME type."
;; Don't run the hook when 'glib' is not referenced. ;; Don't run the hook when 'glib' is not referenced.
(if glib (if glib
(gexp->derivation "xdg-desktop-database" build (gexp->derivation "xdg-desktop-database" build
#:system system
#:local-build? #t #:local-build? #t
#:substitutable? #f #:substitutable? #f
#:properties #:properties
@ -1558,7 +1568,7 @@ MIME type."
(hook . xdg-desktop-database))) (hook . xdg-desktop-database)))
(return #f)))) (return #f))))
(define (xdg-mime-database manifest) (define* (xdg-mime-database manifest #:optional system)
"Return a derivation that builds the @file{mime.cache} database from manifest "Return a derivation that builds the @file{mime.cache} database from manifest
entries. It's used to query the MIME type of a given file." entries. It's used to query the MIME type of a given file."
(define shared-mime-info ; lazy reference (define shared-mime-info ; lazy reference
@ -1605,6 +1615,7 @@ entries. It's used to query the MIME type of a given file."
;; Don't run the hook when there are no GLib based applications. ;; Don't run the hook when there are no GLib based applications.
(if glib (if glib
(gexp->derivation "xdg-mime-database" build (gexp->derivation "xdg-mime-database" build
#:system system
#:local-build? #t #:local-build? #t
#:substitutable? #f #:substitutable? #f
#:properties #:properties
@ -1615,7 +1626,7 @@ entries. It's used to query the MIME type of a given file."
;; Several font packages may install font files into same directory, so ;; Several font packages may install font files into same directory, so
;; fonts.dir and fonts.scale file should be generated here, instead of in ;; fonts.dir and fonts.scale file should be generated here, instead of in
;; packages. ;; packages.
(define (fonts-dir-file manifest) (define* (fonts-dir-file manifest #:optional system)
"Return a derivation that builds the @file{fonts.dir} and @file{fonts.scale} "Return a derivation that builds the @file{fonts.dir} and @file{fonts.scale}
files for the fonts of the @var{manifest} entries." files for the fonts of the @var{manifest} entries."
(define mkfontscale (define mkfontscale
@ -1676,6 +1687,7 @@ files for the fonts of the @var{manifest} entries."
directories))))))) directories)))))))
(gexp->derivation "fonts-dir" build (gexp->derivation "fonts-dir" build
#:system system
#:modules '((guix build utils) #:modules '((guix build utils)
(guix build union) (guix build union)
(srfi srfi-26)) (srfi srfi-26))
@ -1685,7 +1697,7 @@ files for the fonts of the @var{manifest} entries."
`((type . profile-hook) `((type . profile-hook)
(hook . fonts-dir)))) (hook . fonts-dir))))
(define (manual-database manifest) (define* (manual-database manifest #:optional system)
"Return a derivation that builds the manual page database (\"mandb\") for "Return a derivation that builds the manual page database (\"mandb\") for
the entries in MANIFEST." the entries in MANIFEST."
(define gdbm-ffi (define gdbm-ffi
@ -1761,23 +1773,24 @@ the entries in MANIFEST."
(force-output)))))) (force-output))))))
(gexp->derivation "manual-database" build (gexp->derivation "manual-database" build
#:system system
#:substitutable? #f #:substitutable? #f
#:local-build? #t #:local-build? #t
#:properties #:properties
`((type . profile-hook) `((type . profile-hook)
(hook . manual-database)))) (hook . manual-database))))
(define (manual-database/optional manifest) (define* (manual-database/optional manifest #:optional system)
"Return a derivation to build the manual database of MANIFEST, but only if "Return a derivation to build the manual database of MANIFEST, but only if
MANIFEST contains the \"man-db\" package. Otherwise, return #f." MANIFEST contains the \"man-db\" package. Otherwise, return #f."
;; Building the man database (for "man -k") is expensive and rarely used. ;; Building the man database (for "man -k") is expensive and rarely used.
;; Build it only if the profile also contains "man-db". ;; Build it only if the profile also contains "man-db".
(mlet %store-monad ((man-db (manifest-lookup-package manifest "man-db"))) (mlet %store-monad ((man-db (manifest-lookup-package manifest "man-db")))
(if man-db (if man-db
(manual-database manifest) (manual-database manifest system)
(return #f)))) (return #f))))
(define (texlive-font-maps manifest) (define* (texlive-font-maps manifest #:optional system)
"Return a derivation that builds the TeX Live font maps for the entries in "Return a derivation that builds the TeX Live font maps for the entries in
MANIFEST." MANIFEST."
(define entry->texlive-input (define entry->texlive-input
@ -1898,6 +1911,7 @@ MANIFEST."
;; incomplete modular TeX Live installations to generate errors. ;; incomplete modular TeX Live installations to generate errors.
(if (any texlive-scripts-entry? (manifest-entries manifest)) (if (any texlive-scripts-entry? (manifest-entries manifest))
(gexp->derivation "texlive-font-maps" build (gexp->derivation "texlive-font-maps" build
#:system system
#:substitutable? #f #:substitutable? #f
#:local-build? #t #:local-build? #t
#:properties #:properties
@ -1977,7 +1991,8 @@ are cross-built for TARGET."
(extras (if (null? (manifest-entries manifest)) (extras (if (null? (manifest-entries manifest))
(return '()) (return '())
(mapm/accumulate-builds (lambda (hook) (mapm/accumulate-builds (lambda (hook)
(hook manifest)) (hook manifest
system))
hooks)))) hooks))))
(define extra-inputs (define extra-inputs
(filter-map (lambda (drv) (filter-map (lambda (drv)

24
tests/profiles.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013-2023 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Alex Kost <alezost@gmail.com> ;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
@ -382,6 +382,28 @@
(_ (built-derivations (list drv)))) (_ (built-derivations (list drv))))
(return (file-exists? (string-append bindir "/guile"))))) (return (file-exists? (string-append bindir "/guile")))))
(test-assertm "profile-derivation, #:system, and hooks"
;; Make sure all the profile hooks are built for the system specified with
;; #:system, even if that does not match (%current-system).
;; See <https://issues.guix.gnu.org/65225>.
(mlet* %store-monad
((system -> (if (string=? (%current-system) "riscv64-linux")
"x86_64-linux"
"riscv64-linux"))
(entry -> (package->manifest-entry packages:coreutils))
(_ (set-guile-for-build (default-guile) system))
(drv (profile-derivation (manifest (list entry))
#:system system))
(refs (references* (derivation-file-name drv))))
(return (and (string=? (derivation-system drv) system)
(pair? refs)
(every (lambda (ref)
(or (not (string-suffix? ".drv" ref))
(let ((drv (read-derivation-from-file ref)))
(string=? (derivation-system drv)
system))))
refs)))))
(test-assertm "profile-derivation relative symlinks, one entry" (test-assertm "profile-derivation relative symlinks, one entry"
(mlet* %store-monad (mlet* %store-monad
((entry -> (package->manifest-entry %bootstrap-guile)) ((entry -> (package->manifest-entry %bootstrap-guile))