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>

4 files changed, 60 insertions, 21 deletions

diff --git a/gnu/bootloader.scm b/gnu/bootloader.scm
index 2c36d8c6cf..ba06de7618 100644
--- a/gnu/bootloader.scm
+++ b/gnu/bootloader.scm
@@ -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 @@ FILES may contain file like objects produced by procedures like plain-file,
 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 @@ HOOKS lists additional hook functions to modify the profile."
 
     (gexp->derivation "efi-bootloader-profile"
                       build
+                      #:system system
                       #:local-build? #t
                       #:substitutable? #f
                       #:properties
diff --git a/guix/channels.scm b/guix/channels.scm
index 681adafc6c..f01903642d 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -926,7 +926,7 @@ specified."
                        (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 @@ be used as a profile hook."
 
     (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
diff --git a/guix/profiles.scm b/guix/profiles.scm
index fea766879d..5d2fb8dc64 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -993,7 +993,7 @@ if not found."
   (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 @@ 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 @@ entries of MANIFEST, or #f if MANIFEST does not have any GHC packages."
     (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 @@ entries of MANIFEST, or #f if MANIFEST does not have any GHC packages."
                             (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 @@ MANIFEST.  Single-file bundles are required by programs such as Git and Lynx."
                #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 @@ MANIFEST.  Single-file bundles are required by programs such as Git and Lynx."
                   (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 @@ loaders discovered in MANIFEST."
 
     (if gdk-pixbuf
         (gexp->derivation "gdk-pixbuf-loaders-cache-file" build
+                          #:system system
                           #:local-build? #t
                           #:substitutable? #f
                           #:properties
@@ -1271,7 +1276,7 @@ loaders discovered in 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 @@ creates the Glib 'gschemas.compiled' file."
     ;; 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 @@ creates the Glib 'gschemas.compiled' file."
                             (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 @@ creates the GTK+ 'icon-theme.cache' file for each theme."
     ;; 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 @@ creates the GTK+ 'icon-theme.cache' file for each theme."
                             (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 @@ for both major versions of GTK+."
                            #t))))
       (if (or gtk+ gtk+-2)
           (gexp->derivation "gtk-im-modules" gexp
+                            #:system system
                             #:local-build? #t
                             #:substitutable? #f
                             #:properties
@@ -1461,7 +1469,7 @@ for both major versions of GTK+."
                               (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 @@ This is meant to be used as a profile hook."
                 (_ (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 @@ MIME type."
     ;; 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 @@ MIME type."
                             (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 @@ 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.
     (if glib
         (gexp->derivation "xdg-mime-database" build
+                          #:system system
                           #:local-build? #t
                           #:substitutable? #f
                           #: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
 ;; 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 @@ files for the fonts of the @var{manifest} entries."
                             directories)))))))
 
   (gexp->derivation "fonts-dir" build
+                    #:system system
                     #:modules '((guix build utils)
                                 (guix build union)
                                 (srfi srfi-26))
@@ -1685,7 +1697,7 @@ files for the fonts of the @var{manifest} entries."
                     `((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 @@ the entries in 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 @@ 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 @@ are cross-built for TARGET."
                        (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)
diff --git a/tests/profiles.scm b/tests/profiles.scm
index 9ad03f2b24..9c419ada93 100644
--- a/tests/profiles.scm
+++ b/tests/profiles.scm
@@ -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 @@
        (_          (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))