[bug#74670] [PATCH v2 1/2] pack: Support localstatedir in AppImage format.

["Noé Lopez via Guix-patches" <guix-patches@gnu.org>]

From: Noé Lopez <noe@xn--no-cja.eu>

From: Noé Lopez <noelopez@free.fr>

* guix/scripts/pack.scm (self-contained-appimage): Support localstatedir
option.
* tests/pack.scm: Update tests.

Change-Id: Ibf4758db890b2db0cff4b663fed6564015e347d1
---
 guix/scripts/pack.scm | 13 ++++++++++-
 tests/pack.scm        | 51 ++++++++++++++++++++++++++++---------------
 2 files changed, 45 insertions(+), 19 deletions(-)

diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 58cd55b129..61e2da12e7 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -1018,15 +1018,22 @@ (define* (self-contained-appimage name profile
              compressor-name
              %valid-compressors)))
 
+  (define database
+    (and localstatedir?
+         (file-append (store-database (list profile))
+                      "/db/db.sqlite")))
+
   (define builder
     (with-extensions (list guile-gcrypt)
       (with-imported-modules (source-module-closure
                               '((guix build store-copy)
-                                (guix build utils))
+                                (guix build utils)
+                                (gnu build install))
                               #:select? not-config?)
         #~(begin
             (use-modules (guix build utils)
                          (guix build store-copy)
+                         (gnu build install)
                          (rnrs io ports)
                          (srfi srfi-1)
                          (srfi srfi-26))
@@ -1060,6 +1067,10 @@ (define* (self-contained-appimage name profile
                (string-append appdir "/" #$name ".desktop")
                #:name #$name
                #:exec #$entry-point)
+              ;; Install database and gc roots.
+              (when #+database
+                ;; Initialize /var/guix.
+                (install-database-and-gc-roots appdir #+database profile))
               ;; Compress the AppDir.
               (invoke #+(file-append squashfs-tools "/bin/mksquashfs") appdir
                       squashfs "-root-owned" "-noappend"
diff --git a/tests/pack.scm b/tests/pack.scm
index 2cb643f136..00a8e250ed 100644
--- a/tests/pack.scm
+++ b/tests/pack.scm
@@ -39,9 +39,10 @@ (define-module (test-pack)
   #:use-module ((gnu packages package-management) #:select (rpm))
   #:use-module ((gnu packages compression) #:select (squashfs-tools))
   #:use-module ((gnu packages debian) #:select (dpkg))
-  #:use-module ((gnu packages guile) #:select (guile-sqlite3))
+  #:use-module ((gnu packages guile) #:select (guile-sqlite3 guile-3.0))
   #:use-module ((gnu packages gnupg) #:select (guile-gcrypt))
   #:use-module ((gnu packages linux) #:select (fakeroot))
+  #:use-module ((ice-9 textual-ports) #:select (get-string-all))
   #:use-module (srfi srfi-64))
 
 (define %store
@@ -347,7 +348,9 @@ (define rpm-for-tests
     (mlet* %store-monad
         ((guile   (set-guile-for-build (default-guile)))
          (profile -> (profile
-                      (content (packages->manifest (list %bootstrap-guile hello glibc)))
+                      ;; When using '--appimage-extract-and-run', the dynamic
+                      ;; linker is necessary, hence glibc below.
+                      (content (packages->manifest (list hello glibc)))
                       (hooks '())
                       (locales? #f)))
          (image   (self-contained-appimage "hello-appimage" profile
@@ -366,34 +369,46 @@ (define rpm-for-tests
                              (lambda (port)
                                (dump-port pipe port)))
                            (exit (status:exit-val (close-pipe pipe)))))))))
-      (built-derivations (list (pk 'APPIMAGE-drv check)))))
+      (mbegin %store-monad
+        (built-derivations (list (pk 'APPIMAGE-drv check)))
+        (return (string=? (call-with-input-file (derivation->output-path check)
+                            get-string-all)
+                          "Hello, world!\n")))))
 
   (unless store (test-skip 1))
   (test-assertm "appimage + localstatedir"
     (mlet* %store-monad
         ((guile   (set-guile-for-build (default-guile)))
          (profile -> (profile
-                      (content (packages->manifest (list %bootstrap-guile hello glibc)))
+                      ;; 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)))
-         (image   (self-contained-appimage "hello-appimage" profile
-                                           #:entry-point "bin/hello"
+         (image   (self-contained-appimage "guile-appimage" profile
+                                           #:entry-point "bin/guile"
                                            #:localstatedir? #t
                                            #:extra-options
                                            '(#:relocatable? #t)))
          (check   (gexp->derivation
-                   "check-appimage"
-                   (with-imported-modules '((guix build utils))
-                     #~(begin
-                         (use-modules (ice-9 popen)
-                                      (guix build utils))
-                         (let ((pipe (open-pipe* OPEN_READ
-                                                 #$image "--appimage-extract-and-run")))
-                           (call-with-output-file #$output
-                             (lambda (port)
-                               (dump-port pipe port)))
-                           (exit (status:exit-val (close-pipe pipe)))))))))
-      (built-derivations (list (pk 'APPIMAGE-drv check)))))
+                   "check-appimage-with-localstatedir"
+                   #~(begin
+                       (system* #$image "--appimage-extract-and-run" "-c"
+                                (object->string
+                                 `(call-with-output-file #$output
+                                    (lambda (port)
+                                      (display "Hello from Guile!\n"
+                                               port)))))
+                       (execl #$image #$image "--appimage-extract" "-c"
+                              (object->string
+                               '(exit
+                                 (pk 'db? (getcwd)
+                                     (file-exists? "squashfs-root/var/guix/db/db.sqlite")))))))))
+      (mbegin %store-monad
+        (built-derivations (list (pk 'APPIMAGE-drv check)))
+        (return (string=? (call-with-input-file (derivation->output-path check)
+                            get-string-all)
+                          "Hello from Guile!\n")))))
 
   (unless store (test-skip 1))
   (test-assertm "deb archive with symlinks and control files"
-- 
2.46.0