@@ -2,7 +2,7 @@
;;; Copyright © 2017 David Craven <david@craven.ch>
;;; Copyright © 2017, 2020, 2022 Mathieu Othacehe <othacehe@gnu.org>
;;; 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 © 2022 Josselin Poiret <dev@jpoiret.xyz>
;;; Copyright © 2022 Reza Alizadeh Majd <r.majd@pantherx.org>
@@ -335,7 +335,7 @@ (define (efi-bootloader-profile packages files hooks)
local-file, etc., or package contents produced with file-append.
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
(with-imported-modules '((guix build utils))
#~(begin
@@ -383,6 +383,7 @@ (define (efi-bootloader-profile packages files hooks)
(gexp->derivation "efi-bootloader-profile"
build
+ #:system system
#:local-build? #t
#:substitutable? #f
#:properties
@@ -926,7 +926,7 @@ (define* (channel-instances->manifest instances #:key system)
(entries -> (map instance->entry instances derivations)))
(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
be used as a profile hook."
;; Note: Emit a profile in format version 3, which was introduced in 2017
@@ -961,6 +961,7 @@ (define (package-cache-file manifest)
(gexp->derivation-in-inferior "guix-package-cache" build
profile
+ #:system system
;; If the Guix in PROFILE is too old and
;; lacks 'guix repl', don't build the cache
@@ -993,7 +993,7 @@ (define* (manifest-lookup-package manifest name #:optional version)
(anym %store-monad
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
MANIFEST."
(define texinfo ;lazy reference
@@ -1051,13 +1051,14 @@ (define (info-dir-file manifest)
'#$(manifest-inputs manifest)))))))
(gexp->derivation "info-dir" build
+ #:system system
#:local-build? #t
#:substitutable? #f
#:properties
`((type . profile-hook)
(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
entries of MANIFEST, or #f if MANIFEST does not have any GHC packages."
(define ghc ;lazy reference
@@ -1108,6 +1109,7 @@ (define (ghc-package-cache-file manifest)
(if (any (cut string-prefix? "ghc" <>)
(map manifest-entry-name (manifest-entries manifest)))
(gexp->derivation "ghc-package-cache" build
+ #:system system
#:local-build? #t
#:substitutable? #f
#:properties
@@ -1115,7 +1117,7 @@ (define (ghc-package-cache-file manifest)
(hook . ghc-package-cache)))
(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
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."
@@ -1179,13 +1181,14 @@ (define (ca-certificate-bundle manifest)
#t))))))
(gexp->derivation "ca-certificate-bundle" build
+ #:system system
#:local-build? #t
#:substitutable? #f
#:properties
`((type . profile-hook)
(hook . ca-certificate-bundle))))
-(define (emacs-subdirs manifest)
+(define* (emacs-subdirs manifest #:optional system)
(define build
(with-imported-modules (source-module-closure
'((guix build profiles)
@@ -1219,13 +1222,14 @@ (define (emacs-subdirs manifest)
(newline port)
#t)))))))
(gexp->derivation "emacs-subdirs" build
+ #:system system
#:local-build? #t
#:substitutable? #f
#:properties
`((type . profile-hook)
(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
loaders discovered in MANIFEST."
(define gdk-pixbuf ;lazy reference
@@ -1264,6 +1268,7 @@ (define (gdk-pixbuf-loaders-cache-file manifest)
(if gdk-pixbuf
(gexp->derivation "gdk-pixbuf-loaders-cache-file" build
+ #:system system
#:local-build? #t
#:substitutable? #f
#:properties
@@ -1271,7 +1276,7 @@ (define (gdk-pixbuf-loaders-cache-file manifest)
(hook . gdk-pixbuf-loaders-cache-file)))
(return #f))))
-(define (glib-schemas manifest)
+(define* (glib-schemas manifest #:optional system)
"Return a derivation that unions all schemas from manifest entries and
creates the Glib 'gschemas.compiled' file."
(define glib ; lazy reference
@@ -1318,6 +1323,7 @@ (define (glib-schemas manifest)
;; Don't run the hook when there's nothing to do.
(if %glib
(gexp->derivation "glib-schemas" build
+ #:system system
#:local-build? #t
#:substitutable? #f
#:properties
@@ -1325,7 +1331,7 @@ (define (glib-schemas manifest)
(hook . glib-schemas)))
(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
creates the GTK+ 'icon-theme.cache' file for each theme."
(define gtk+ ; lazy reference
@@ -1377,6 +1383,7 @@ (define (gtk-icon-themes manifest)
;; Don't run the hook when there's nothing to do.
(if %gtk+
(gexp->derivation "gtk-icon-themes" build
+ #:system system
#:local-build? #t
#:substitutable? #f
#:properties
@@ -1384,7 +1391,7 @@ (define (gtk-icon-themes manifest)
(hook . gtk-icon-themes)))
(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
for both major versions of GTK+."
@@ -1454,6 +1461,7 @@ (define (gtk-im-modules manifest)
#t))))
(if (or gtk+ gtk+-2)
(gexp->derivation "gtk-im-modules" gexp
+ #:system system
#:local-build? #t
#:substitutable? #f
#:properties
@@ -1461,7 +1469,7 @@ (define (gtk-im-modules manifest)
(hook . gtk-im-modules)))
(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
and creates the dependency graph of all these kernel modules.
@@ -1511,13 +1519,14 @@ (define (linux-module-database manifest)
(_ (error "Specified Linux kernel and Linux kernel modules
are not all of the same version"))))))))
(gexp->derivation "linux-module-database" build
+ #:system system
#:local-build? #t
#:substitutable? #f
#:properties
`((type . profile-hook)
(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
desktop files. It's used to query what applications can handle a given
MIME type."
@@ -1551,6 +1560,7 @@ (define (xdg-desktop-database manifest)
;; Don't run the hook when 'glib' is not referenced.
(if glib
(gexp->derivation "xdg-desktop-database" build
+ #:system system
#:local-build? #t
#:substitutable? #f
#:properties
@@ -1558,7 +1568,7 @@ (define (xdg-desktop-database manifest)
(hook . xdg-desktop-database)))
(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
entries. It's used to query the MIME type of a given file."
(define shared-mime-info ; lazy reference
@@ -1605,6 +1615,7 @@ (define (xdg-mime-database manifest)
;; Don't run the hook when there are no GLib based applications.
(if glib
(gexp->derivation "xdg-mime-database" build
+ #:system system
#:local-build? #t
#:substitutable? #f
#:properties
@@ -1615,7 +1626,7 @@ (define (xdg-mime-database manifest)
;; Several font packages may install font files into same directory, so
;; fonts.dir and fonts.scale file should be generated here, instead of in
;; 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}
files for the fonts of the @var{manifest} entries."
(define mkfontscale
@@ -1676,6 +1687,7 @@ (define (fonts-dir-file manifest)
directories)))))))
(gexp->derivation "fonts-dir" build
+ #:system system
#:modules '((guix build utils)
(guix build union)
(srfi srfi-26))
@@ -1685,7 +1697,7 @@ (define (fonts-dir-file manifest)
`((type . profile-hook)
(hook . fonts-dir))))
-(define (manual-database manifest)
+(define* (manual-database manifest #:optional system)
"Return a derivation that builds the manual page database (\"mandb\") for
the entries in MANIFEST."
(define gdbm-ffi
@@ -1761,23 +1773,24 @@ (define (manual-database manifest)
(force-output))))))
(gexp->derivation "manual-database" build
+ #:system system
#:substitutable? #f
#:local-build? #t
#:properties
`((type . profile-hook)
(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
MANIFEST contains the \"man-db\" package. Otherwise, return #f."
;; Building the man database (for "man -k") is expensive and rarely used.
;; Build it only if the profile also contains "man-db".
(mlet %store-monad ((man-db (manifest-lookup-package manifest "man-db")))
(if man-db
- (manual-database manifest)
+ (manual-database manifest system)
(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
MANIFEST."
(define entry->texlive-input
@@ -1898,6 +1911,7 @@ (define (texlive-font-maps manifest)
;; incomplete modular TeX Live installations to generate errors.
(if (any texlive-scripts-entry? (manifest-entries manifest))
(gexp->derivation "texlive-font-maps" build
+ #:system system
#:substitutable? #f
#:local-build? #t
#:properties
@@ -1977,7 +1991,8 @@ (define* (profile-derivation manifest
(extras (if (null? (manifest-entries manifest))
(return '())
(mapm/accumulate-builds (lambda (hook)
- (hook manifest))
+ (hook manifest
+ system))
hooks))))
(define extra-inputs
(filter-map (lambda (drv)
@@ -1,5 +1,5 @@
;;; 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>
;;;
;;; This file is part of GNU Guix.
@@ -382,6 +382,28 @@ (define glibc
(_ (built-derivations (list drv))))
(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"
(mlet* %store-monad
((entry -> (package->manifest-entry %bootstrap-guile))
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> --- gnu/bootloader.scm | 5 +++-- guix/channels.scm | 3 ++- guix/profiles.scm | 49 ++++++++++++++++++++++++++++++---------------- tests/profiles.scm | 24 ++++++++++++++++++++++- 4 files changed, 60 insertions(+), 21 deletions(-)