From: Noé Lopez <[email protected]>

The tested AppImages were not actually relocatable and would rely on items
being available on the environment’s store (apart from glibc).

* guix/scripts/pack.scm (wrapped-manifest): New function.
(guix-pack): Extract relocatable manifest to wrapped-manifest.
* tests/pack.scm: Use relocatable profiles in AppImage tests.

Fixes: <https://issues.guix.gnu.org/76850>
Change-Id: Ib3123054913fce903d215dc0629d806e9fceebc7
Reported-by: Reepca Russelstein <[email protected]>
---
I tried this patch, but it still does *not* resolve the test,
sadly. So there's more investigation to do. I'm puttintg it there to
make it easier for the next person to try.

guix/scripts/pack.scm | 17 +++++++----
 tests/pack.scm        | 68 +++++++++++++++++++++++--------------------
 2 files changed, 48 insertions(+), 37 deletions(-)

diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index a6a7babf595..fb4f2a54938 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -11,7 +11,7 @@
 ;;; Copyright © 2023 Graham James Addis <[email protected]>
 ;;; Copyright © 2023 Oleg Pykhalov <[email protected]>
 ;;; Copyright © 2024 Sebastian Dümcke <[email protected]>
-;;; Copyright © 2024 Noé Lopez <[email protected]>
+;;; Copyright © 2024-2025 Noé Lopez <[email protected]>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -81,7 +81,9 @@ (define-module (guix scripts pack)
             self-contained-appimage
 
             %formats
-            guix-pack))
+            guix-pack
+
+            wrapped-manifest))
 
 ;;; Commentary:
 
@@ -1396,6 +1398,13 @@ (define (wrapped-manifest-entry entry . args)
                          (apply wrapped-manifest-entry entry args))
                        (manifest-entry-dependencies entry)))))
 
+(define* (wrapped-manifest manifest #:rest args)
+  "Return the MANIFEST with its entries wrapped such that they are
+relocatable. Extra arguments are passed to wrapped-package."
+  (map-manifest-entries
+   (lambda (entry) (apply wrapped-manifest-entry entry args))
+   manifest))
+
 
 ;;;
 ;;; Command-line options.
@@ -1794,9 +1803,7 @@ (define-command (guix-pack . args)
                                   ;; Note: We cannot honor '--bootstrap' here 
because
                                   ;; 'glibc-bootstrap' lacks 'libc.a'.
                                   (if relocatable?
-                                      (map-manifest-entries
-                                       (cut wrapped-manifest-entry <> #:proot? 
proot?)
-                                       manifest)
+                                      (wrapped-manifest manifest #:proot? 
proot?)
                                       manifest)))
                    (pack-format (assoc-ref opts 'format))
                    (extra-options (match pack-format
diff --git a/tests/pack.scm b/tests/pack.scm
index d0a1b72eb94..39185b08d28 100644
--- a/tests/pack.scm
+++ b/tests/pack.scm
@@ -3,7 +3,7 @@
 ;;; Copyright © 2018 Ricardo Wurmus <[email protected]>
 ;;; Copyright © 2021, 2023, 2025 Maxim Cournoyer <[email protected]>
 ;;; Copyright © 2023 Oleg Pykhalov <[email protected]>
-;;; Copyright © 2024 Noé Lopez <[email protected]>
+;;; Copyright © 2024-2025 Noé Lopez <[email protected]>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -81,9 +81,9 @@ (define %ar-bootstrap %bootstrap-binutils)
     (mlet* %store-monad
         ((guile   (set-guile-for-build (default-guile)))
          (profile -> (profile
-                      (content (packages->manifest (list %bootstrap-guile)))
-                      (hooks '())
-                      (locales? #f)))
+                       (content (packages->manifest (list %bootstrap-guile)))
+                       (hooks '())
+                       (locales? #f)))
          (tarball (self-contained-tarball "pack" profile
                                           #:symlinks '(("/bin/Guile"
                                                         -> "bin/guile"))
@@ -134,9 +134,9 @@ (define %ar-bootstrap %bootstrap-binutils)
     (mlet* %store-monad
         ((guile   (set-guile-for-build (default-guile)))
          (profile -> (profile
-                      (content (packages->manifest (list %bootstrap-guile)))
-                      (hooks '())
-                      (locales? #f)))
+                       (content (packages->manifest (list %bootstrap-guile)))
+                       (hooks '())
+                       (locales? #f)))
          (tarball (self-contained-tarball "tar-pack" profile
                                           #:localstatedir? #t))
          (check   (gexp->derivation
@@ -209,9 +209,9 @@ (define %ar-bootstrap %bootstrap-binutils)
     (mlet* %store-monad
         ((guile   (set-guile-for-build (default-guile)))
          (profile -> (profile
-                      (content (packages->manifest (list %bootstrap-guile)))
-                      (hooks '())
-                      (locales? #f)))
+                       (content (packages->manifest (list %bootstrap-guile)))
+                       (hooks '())
+                       (locales? #f)))
          (tarball (docker-image "docker-pack" profile
                                 #:symlinks '(("/bin/Guile" -> "bin/guile"))
                                 #:localstatedir? #t))
@@ -249,9 +249,9 @@ (define %ar-bootstrap %bootstrap-binutils)
     (mlet* %store-monad
         ((guile (set-guile-for-build (default-guile)))
          (profile -> (profile
-                      (content (packages->manifest (list %bootstrap-guile)))
-                      (hooks '())
-                      (locales? #f)))
+                       (content (packages->manifest (list %bootstrap-guile)))
+                       (hooks '())
+                       (locales? #f)))
          (tarball (docker-image "docker-pack" profile
                                 #:symlinks '(("/bin/Guile" -> "bin/guile"))
                                 #:localstatedir? #t
@@ -297,9 +297,9 @@ (define %ar-bootstrap %bootstrap-binutils)
     (mlet* %store-monad
         ((guile   (set-guile-for-build (default-guile)))
          (profile -> (profile
-                      (content (packages->manifest (list %bootstrap-guile)))
-                      (hooks '())
-                      (locales? #f)))
+                       (content (packages->manifest (list %bootstrap-guile)))
+                       (hooks '())
+                       (locales? #f)))
          (image   (squashfs-image "squashfs-pack" profile
                                   #:symlinks '(("/bin" -> "bin"))
                                   #:localstatedir? #t))
@@ -337,11 +337,13 @@ (define %ar-bootstrap %bootstrap-binutils)
     (mlet* %store-monad
         ((guile   (set-guile-for-build (default-guile)))
          (profile -> (profile
-                      ;; When using '--appimage-extract-and-run', the dynamic
-                      ;; linker is necessary, hence glibc below.
-                      (content (packages->manifest (list hello glibc)))
-                      (hooks '())
-                      (locales? #f)))
+                       ;; When using '--appimage-extract-and-run', the dynamic
+                       ;; linker is necessary, hence glibc below.
+                       (content (wrapped-manifest
+                                 (packages->manifest (list hello glibc))))
+                       (relative-symlinks? #t)
+                       (hooks '())
+                       (locales? #f)))
          (image   (self-contained-appimage "hello-appimage" profile
                                            #:entry-point "bin/hello"
                                            #:extra-options
@@ -369,11 +371,13 @@ (define %ar-bootstrap %bootstrap-binutils)
     (mlet* %store-monad
         ((guile   (set-guile-for-build (default-guile)))
          (profile -> (profile
-                      ;; When using '--appimage-extract-and-run', the dynamic
-                      ;; linker is necessary, hence glibc below.
-                      (content (packages->manifest (list guile-3.0 glibc)))
-                      (hooks '())
-                      (locales? #f)))
+                       ;; When using '--appimage-extract-and-run', the dynamic
+                       ;; linker is necessary, hence glibc below.
+                       (content (wrapped-manifest
+                                 (packages->manifest (list guile-3.0 glibc))))
+                       (relative-symlinks? #t)
+                       (hooks '())
+                       (locales? #f)))
          (image   (self-contained-appimage "guile-appimage" profile
                                            #:entry-point "bin/guile"
                                            #:localstatedir? #t
@@ -401,9 +405,9 @@ (define %ar-bootstrap %bootstrap-binutils)
     (mlet* %store-monad
         ((guile   (set-guile-for-build (default-guile)))
          (profile -> (profile
-                      (content (packages->manifest (list %bootstrap-guile)))
-                      (hooks '())
-                      (locales? #f)))
+                       (content (packages->manifest (list %bootstrap-guile)))
+                       (hooks '())
+                       (locales? #f)))
          (deb (debian-archive
                "deb-pack" profile
                #:compressor %gzip-compressor
@@ -490,9 +494,9 @@ (define %ar-bootstrap %bootstrap-binutils)
     (mlet* %store-monad
         ((guile   (set-guile-for-build (default-guile)))
          (profile -> (profile
-                      (content (packages->manifest (list %bootstrap-guile)))
-                      (hooks '())
-                      (locales? #f)))
+                       (content (packages->manifest (list %bootstrap-guile)))
+                       (hooks '())
+                       (locales? #f)))
          (rpm-pack (rpm-archive "rpm-pack" profile
                                 #:compressor %gzip-compressor
                                 #:symlinks '(("/bin/guile" -> "bin/guile"))
-- 
2.51.2




Reply via email to