Subject: bug#51801: No warning when attempting to build unsupported system with --system

From: Ludovic Courtès <[email-masked]>
Date: Thu, 17 Feb 2022 16:44:09 +0100

Hi!

Maxim Cournoyer <[email-masked]> skribis:

> I was surprised that:
>
> guix build fpc --system=armhf-linux
>
> would send me in a dead end without any word of caution, given that
> armhf-linux is *not* listed in the supported-systems field.
>
> We should at least warn near the beginning of the build, and remind of
> that fact at the end of the build in case of failure.

I came up with the patches below.

The first part forbids unsupported packages altogether in user-facing
commands: ‘guix install’, ‘guix shell’, etc.  Until now, they’d just
start building things that were bound to fail.

The second part adds a mere warning for ‘guix build’ (it does not repeat
it at the end, though).

Thanks,
Ludo’.

>From 1b02db917f6b24b7c41dc20e2833fff452d9b900 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <[email-masked]>
Date: Thu, 17 Feb 2022 16:04:15 +0100
Subject: [PATCH 1/3] packages: 'package-transitive-supported-systems' ignores
 '%current-target-system'.

Previously 'package-transitive-supported-systems' would enter an
infinite loop over the cross-compilation tool chain if
%CURRENT-TARGET-SYSTEM was set.

* guix/packages.scm (package-transitive-supported-systems)[supported-systems-procedure]:
Pass explicit SYSTEM and TARGET parameters.
* tests/packages.scm ("supported-package? vs. %current-target-system"):
New test.
---
 guix/packages.scm  |  4 ++--
 tests/packages.scm | 10 ++++++++++
 2 files changed, 12 insertions(+), 2 deletions(-)

diff --git a/guix/packages.scm b/guix/packages.scm
index 9d5b23eb8a..3f0262602d 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <[email-masked]>
+;;; Copyright © 2012-2022 Ludovic Courtès <[email-masked]>
 ;;; Copyright © 2014, 2015, 2017, 2018, 2019 Mark H Weaver <[email-masked]>
 ;;; Copyright © 2015 Eric Bavier <[email-masked]>
 ;;; Copyright © 2016 Alex Kost <[email-masked]>
@@ -1235,7 +1235,7 @@ (define supported-systems
                       (_
                        systems)))
                   (package-supported-systems package)
-                  (bag-direct-inputs (package->bag package))))))
+                  (bag-direct-inputs (package->bag package system #f))))))
 
       supported-systems)
 
diff --git a/tests/packages.scm b/tests/packages.scm
index 55b1c4064f..02bdba5f98 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -508,6 +508,16 @@ (define read-at
     (and (supported-package? p "x86_64-linux")
          (supported-package? p "armhf-linux"))))
 
+(test-assert "supported-package? vs. %current-target-system"
+  ;; The %CURRENT-TARGET-SYSTEM value should have no influence.
+  (parameterize ((%current-target-system "arm-linux-gnueabihf"))
+    (let ((p (dummy-package "foo"
+               (build-system gnu-build-system)
+               (supported-systems '("x86_64-linux" "armhf-linux")))))
+      (and (supported-package? p "x86_64-linux")
+           (not (supported-package? p "i686-linux"))
+           (supported-package? p "armhf-linux")))))
+
 (test-skip (if (not %store) 8 0))
 
 (test-assert "package-source-derivation, file"

base-commit: 6481dbda5100e9b0ff9c5221280d2c0cadd663b7
-- 
2.34.0

>From d492eab963522f2dcea7bad1016fe6b718ddffed Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <[email-masked]>
Date: Thu, 17 Feb 2022 16:06:39 +0100
Subject: [PATCH 2/3] profiles: 'profile-derivation' rejects unsupported
 packages.

Previously user-facing commands would happily start building packages
even if they do not support that system.  With this change, all the
user-facing commands reject unsupported packages without going further.

* guix/profiles.scm (profile-derivation): Add #:allow-unsupported-packages?.
Define 'check-supported-packages' and honor #:allow-unsupported-packages?.
* tests/guix-pack.sh, tests/guix-package.sh, tests/guix-shell.sh: Ensure
that unsupported packages are rejected.
---
 guix/profiles.scm     | 22 ++++++++++++++++++++--
 tests/guix-pack.sh    |  5 ++++-
 tests/guix-package.sh | 13 ++++++++++++-
 tests/guix-shell.sh   |  5 ++++-
 4 files changed, 40 insertions(+), 5 deletions(-)

diff --git a/guix/profiles.scm b/guix/profiles.scm
index 9715a769aa..bad9b95519 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -33,7 +33,7 @@ (define-module (guix profiles)
   #:use-module ((guix utils) #:hide (package-name->name+version))
   #:use-module ((guix build utils)
                 #:select (package-name->name+version mkdir-p))
-  #:use-module ((guix diagnostics) #:select (&fix-hint))
+  #:use-module ((guix diagnostics) #:select (&fix-hint formatted-message))
   #:use-module (guix i18n)
   #:use-module (guix records)
   #:use-module (guix packages)
@@ -1860,6 +1860,7 @@ (define* (profile-derivation manifest
                              (name "profile")
                              (hooks %default-profile-hooks)
                              (locales? #t)
+                             (allow-unsupported-packages? #f)
                              (allow-collisions? #f)
                              (relative-symlinks? #f)
                              system target)
@@ -1868,7 +1869,9 @@ (define* (profile-derivation manifest
 the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc.
 Unless ALLOW-COLLISIONS? is true, a '&profile-collision-error' is raised if
 entries in MANIFEST collide (for instance if there are two same-name packages
-with a different version number.)
+with a different version number.)  Unless ALLOW-UNSUPPORTED-PACKAGES? is true
+or TARGET is set, raise an error if MANIFEST contains a package that does not
+support SYSTEM.
 
 When LOCALES? is true, the build is performed under a UTF-8 locale; this adds
 a dependency on the 'glibc-utf8-locales' package.
@@ -1878,12 +1881,27 @@ (define* (profile-derivation manifest
 
 When TARGET is true, it must be a GNU triplet, and the packages in MANIFEST
 are cross-built for TARGET."
+  (define (check-supported-packages system)
+    ;; Raise an error if a package in MANIFEST does not support SYSTEM.
+    (map-manifest-entries
+     (lambda (entry)
+
+       (match (manifest-entry-item entry)
+         ((? package? package)
+          (unless (supported-package? package system)
+            (raise (formatted-message (G_ "package ~a does not support ~a")
+                                      (package-full-name package) system))))
+         (_ #t)))
+     manifest))
+
   (mlet* %store-monad ((system (if system
                                    (return system)
                                    (current-system)))
                        (target (if target
                                    (return target)
                                    (current-target-system)))
+                       (ok? -> (or allow-unsupported-packages? target
+                                   (check-supported-packages system)))
                        (ok?    (if allow-collisions?
                                    (return #t)
                                    (check-for-collisions manifest system
diff --git a/tests/guix-pack.sh b/tests/guix-pack.sh
index 0339221ac2..1356a74083 100644
--- a/tests/guix-pack.sh
+++ b/tests/guix-pack.sh
@@ -1,6 +1,6 @@
 # GNU Guix --- Functional package management for GNU
 # Copyright © 2018 Chris Marusich <[email-masked]>
-# Copyright © 2018, 2019, 2020 Ludovic Courtès <[email-masked]>
+# Copyright © 2018, 2019, 2020, 2022 Ludovic Courtès <[email-masked]>
 #
 # This file is part of GNU Guix.
 #
@@ -36,6 +36,9 @@ export GUIX_BUILD_OPTIONS
 test_directory="`mktemp -d`"
 trap 'chmod -Rf +w "$test_directory"; rm -rf "$test_directory"' EXIT
 
+# Reject unsuppoted packages.
+! guix pack intelmetool -s armhf-linux -n
+
 # Compute the derivation of a pack.
 drv="`guix pack coreutils -d --no-grafts`"
 guix gc -R "$drv" | grep "`guix build coreutils -d --no-grafts`"
diff --git a/tests/guix-package.sh b/tests/guix-package.sh
index 92ab565c5b..d1b383d2ad 100644
--- a/tests/guix-package.sh
+++ b/tests/guix-package.sh
@@ -1,5 +1,5 @@
 # GNU Guix --- Functional package management for GNU
-# Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <[email-masked]>
+# Copyright © 2012-2022 Ludovic Courtès <[email-masked]>
 # Copyright © 2013 Nikita Karetnikov <[email-masked]>
 #
 # This file is part of GNU Guix.
@@ -59,6 +59,17 @@ test -L "$profile" && test -L "$profile-1-link"
 ! test -f "$profile-2-link"
 test -f "$profile/bin/guile"
 
+# Unsupported packages cannot be installed.
+! guix package -e '(begin (use-modules (guix) (gnu packages base)) (package (inherit sed) (supported-systems (list))))' -n
+case $(uname -m) in
+    x86_64|i[3456]86)
+	! guix package -i novena-eeprom -n
+	break;;
+    *)
+	! guix package -i intelmetool -n
+	break;;
+esac
+
 # Collisions are properly flagged (in this case, 'g-wrap' propagates
 # [email-masked], which conflicts with [email-masked].)
 ! guix package --bootstrap -n -p "$profile" -i g-wrap [email-masked]
diff --git a/tests/guix-shell.sh b/tests/guix-shell.sh
index 23ff1c5bcf..6340f90574 100644
--- a/tests/guix-shell.sh
+++ b/tests/guix-shell.sh
@@ -1,5 +1,5 @@
 # GNU Guix --- Functional package management for GNU
-# Copyright © 2021 Ludovic Courtès <[email-masked]>
+# Copyright © 2021-2022 Ludovic Courtès <[email-masked]>
 #
 # This file is part of GNU Guix.
 #
@@ -35,6 +35,9 @@ guix shell --bootstrap --pure guile-bootstrap -- guile --version
 # '--ad-hoc' is a thing of the past.
 ! guix shell --ad-hoc guile-bootstrap
 
+# Rejecting unsupported packages.
+! guix shell -s armhf-linux intelmetool -n
+
 # Ignoring unauthorized files.
 cat > "$tmpdir/guix.scm" <<EOF
 This is a broken guix.scm file.
-- 
2.34.0

>From d4368c8c307f61b5346df540aaf329b8495fe32c Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <[email-masked]>
Date: Thu, 17 Feb 2022 16:23:42 +0100
Subject: [PATCH 3/3] guix build: Warn when attempting to build an unsupported
 package.

Fixes <https://issues.guix.gnu.org/51801>.
Reported by Maxim Cournoyer <[email-masked]>.

* guix/scripts/build.scm (options->derivations)[warn-if-unsupported]:
New procedure.
[compute-derivation]: Use it.
* tests/guix-build.sh: Add test.
---
 guix/scripts/build.scm | 22 ++++++++++++++++++++--
 tests/guix-build.sh    | 12 +++++++++++-
 2 files changed, 31 insertions(+), 3 deletions(-)

diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 97e2f5a167..d9cdb6e5e0 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021, 2021 Ludovic Courtès <[email-masked]>
+;;; Copyright © 2012-2022 Ludovic Courtès <[email-masked]>
 ;;; Copyright © 2013 Mark H Weaver <[email-masked]>
 ;;; Copyright © 2020 Marius Bakke <[email-masked]>
 ;;; Copyright © 2020 Ricardo Wurmus <[email-masked]>
@@ -559,11 +559,29 @@ (define systems
   (define things-to-build
     (map transform (options->things-to-build opts)))
 
+  (define warn-if-unsupported
+    (let ((target (assoc-ref opts 'target)))
+      (if target
+          (lambda (package system)
+            ;; We cannot tell whether PACKAGE supports TARGET.
+            package)
+          (lambda (package system)
+            (match package
+              ((? package? package)
+               (unless (supported-package? package system)
+                 (warning (package-location package)
+                          (G_ "package ~a does not support ~a~%")
+                          (package-full-name package) system))
+               package)
+              (x x))))))
+
   (define (compute-derivation obj system)
     ;; Compute the derivation of OBJ for SYSTEM.
     (match obj
       ((? package? p)
-       (let ((p (or (and graft? (package-replacement p)) p)))
+       (let ((p (warn-if-unsupported
+                 (or (and graft? (package-replacement p)) p)
+                 system)))
          (match src
            (#f
             (list (package->derivation store p system)))
diff --git a/tests/guix-build.sh b/tests/guix-build.sh
index 86e41e2927..9cbf8fe26d 100644
--- a/tests/guix-build.sh
+++ b/tests/guix-build.sh
@@ -1,5 +1,5 @@
 # GNU Guix --- Functional package management for GNU
-# Copyright © 2012, 2013, 2014, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <[email-masked]>
+# Copyright © 2012-2014, 2016-2022 Ludovic Courtès <[email-masked]>
 # Copyright © 2020 Marius Bakke <[email-masked]>
 # Copyright © 2021 Chris Marusich <[email-masked]>
 #
@@ -31,6 +31,16 @@ guix build --version
 guix build -e '(@ (gnu packages bootstrap) %bootstrap-glibc)' -S
 test "`guix build -e '(@ (gnu packages bootstrap) %bootstrap-glibc)' -S`" = ""
 
+# Warn when attempting to build an unsupported package.
+case "$(guix build intelmetool -s armhf-linux -v0 -n 2>&1)" in
+    *warning:*intelmetool*support*armhf*)
+	true
+	break;;
+    *)
+	false;
+	break;;
+esac
+
 # Should pass.
 guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)' |	\
     grep -e '-guile-'
-- 
2.34.0