[bug#73842] [PATCH v4 2/3] pack: Add support for AppImage pack format.

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

From: Sebastian Dümcke <code@sam-d.com>

* guix/scripts/pack.scm: Add Appimage format.
* doc/guix.texi: Document AppImage pack.

Co-authored-by: Noé Lopez <noelopez@free.fr>
Change-Id: I33ebfec623cff1cfcd6f029d2d3054c23ab1949a
---
 doc/guix.texi         |  53 ++++++++++++++++++++-
 guix/scripts/pack.scm | 104 +++++++++++++++++++++++++++++++++++++++++-
 tests/pack.scm        |  41 ++++++++++++++++-
 3 files changed, 195 insertions(+), 3 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 187bae6898..46108dc3f1 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -6949,6 +6949,16 @@ Invoking guix pack
 environment}, using commands like @command{singularity shell} or
 @command{singularity exec}.
 
+@cindex AppImage, create an AppImage file with @command{guix pack}
+Another format internally based on SquashFS is
+@uref{https://appimage.org/, AppImage}. An AppImage file can be created
+and executed without any special privileges:
+
+@example
+file=$(guix pack -f appimage --entry-point=bin/guile guile)
+$file --help
+@end example
+
 Several command-line options allow you to customize your pack:
 
 @table @code
@@ -7065,6 +7075,47 @@ Invoking guix pack
 installation or other, non-rpm packs.
 @end quotation
 
+@item appimage
+@cindex AppImage, create an AppImage file with @command{guix pack}
+This produces an AppImage file with the @samp{.AppImage} extension.
+AppImage is a SquashFS volume prefixed with a runtime that mounts the
+SquashFS file system and executes the binary provided with
+@option{--entry-point}.  This results in a self-contained archive that
+bundles the software and all its requirements into a single file.  When
+the file is made executable it runs the packaged software.
+
+@example
+guix pack -f appimage --entry-point=bin/vlc vlc
+@end example
+
+The runtime used by AppImages makes use of libfuse to mount the image
+quickly.  If libfuse is not available, the AppImage can still be started
+using the @option{--appimage-extract-and-run} flag.
+
+@quotation Warning
+ When building an AppImage, always @emph{pass} the
+@option{--relocatable} option (or @option{-R}, or @option{-RR}) to make
+sure the image can be used on systems where Guix is not installed.  A
+warning is printed when this option is not used.
+@end quotation
+
+@example
+guix pack -f appimage --entry-point=bin/hello --relocatable hello
+@end example
+
+@quotation Note
+The resulting AppImage does not conform to the complete standard as it
+currently does not contain a @file{.DirIcon} file.  This does not impact
+functionality of the AppImage itself, but possibly that of software used
+to manage AppImages.
+@end quotation
+
+@quotation Note
+As the generated AppImage packages the complete dependency graph, it
+will be larger than comparable AppImage files found online, which depend
+on host system libraries.
+@end quotation
+
 @end table
 
 @cindex relocatable binaries
@@ -7155,7 +7206,7 @@ Invoking guix pack
 @cindex entry point, for Docker and Singularity images
 @item --entry-point=@var{command}
 Use @var{command} as the @dfn{entry point} of the resulting pack, if the pack
-format supports it---currently @code{docker} and @code{squashfs} (Singularity)
+format supports it---currently @code{docker}, @code{appimage} and @code{squashfs} (Singularity)
 support it.  @var{command} must be relative to the profile contained in the
 pack.
 
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 7c5fe76fe0..26ba80b80d 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -10,6 +10,8 @@
 ;;; Copyright © 2022 Alex Griffin <a@ajgrf.com>
 ;;; Copyright © 2023 Graham James Addis <graham@addis.org.uk>
 ;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
+;;; Copyright © 2024 Sebastian Dümcke <code@sam-d.com>
+;;; Copyright © 2024 Noé Lopez <noelopez@free.fr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -56,6 +58,7 @@ (define-module (guix scripts pack)
   #:use-module ((gnu packages compression) #:hide (zip))
   #:use-module (gnu packages guile)
   #:use-module (gnu packages base)
+  #:autoload   (gnu packages appimage) (appimage-type2-runtime)
   #:autoload   (gnu packages gnupg) (guile-gcrypt)
   #:autoload   (gnu packages guile) (guile2.0-json guile-json)
   #:use-module (srfi srfi-1)
@@ -64,6 +67,7 @@ (define-module (guix scripts pack)
   #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-37)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 optargs)
   #:export (symlink-spec-option-parser
 
             self-contained-tarball
@@ -71,6 +75,7 @@ (define-module (guix scripts pack)
             rpm-archive
             docker-image
             squashfs-image
+            self-contained-appimage
 
             %formats
             guix-pack))
@@ -974,8 +979,100 @@ (define* (rpm-archive name profile
   (gexp->derivation (string-append name ".rpm") build
                     #:target target
                     #:references-graphs `(("profile" ,profile))))
+\f
+;;;
+;;; AppImage format
+;;;
+(define* (self-contained-appimage name profile
+                                  #:key target
+                                  (profile-name "guix-profile")
+                                  entry-point
+                                  (compressor (lookup-compressor "zstd"))
+                                  localstatedir?
+                                  (symlinks '())
+                                  (archiver tar)
+                                  (extra-options '()))
+  "Return a self-contained AppImage containing a store initialized with the
+closure of PROFILE, a derivation.  The AppImage contains /gnu/store unless
+RELOCATABLE option is used; if LOCALSTATEDIR? is true, it also contains
+/var/guix, including /var/guix/db with a properly initialized store database.
+
+SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
+added to the pack."
+  (unless entry-point
+    (leave (G_ "entry-point must be provided in the '~a' format~%")
+           'appimage))
+  (let-keywords extra-options #f ((relocatable? #f))
+    (unless relocatable?
+      (warning (G_ "AppImages should be built with the --relocatable flag~%"))))
+
+  (define runtime-package appimage-type2-runtime)
+  (define runtime-path "bin/runtime-fuse3")
+  (define %valid-compressors '("gzip" "zstd"))
+
+  (let ((compressor-name (compressor-name compressor)))
+    (unless (member compressor-name %valid-compressors)
+      (leave (G_ "~a is not a valid squashfs archive compressor used in
+generating the AppImage.  Valid compressors are: ~a~%")
+             compressor-name
+             %valid-compressors)))
 
-  \f
+  (define builder
+    (with-extensions (list guile-gcrypt)
+      (with-imported-modules (source-module-closure
+                              '((guix build store-copy)
+                                (guix build utils))
+                              #:select? not-config?)
+        #~(begin
+            (use-modules (guix build utils)
+                         (guix build store-copy)
+                         (rnrs io ports)
+                         (srfi srfi-1)
+                         (srfi srfi-26))
+
+            (define (concatenate-files result file1 file2)
+              "Creates a new file RESULT containing FILE1 followed by FILE2."
+              (call-with-output-file result
+                (lambda (output)
+                  (call-with-input-file file1
+                    (lambda (input)
+                      (dump-port input output)))
+                  (call-with-input-file file2
+                    (lambda (input)
+                      (dump-port input output))))))
+
+            (let* ((appdir "AppDir")
+                   (squashfs "squashfs")
+                   (profile-items (map store-info-item
+                                       (call-with-input-file "profile" read-reference-graph)))
+                   (profile (find (lambda (item)
+                                      (string-suffix? "-profile" item))
+                                  profile-items)))
+              (mkdir-p appdir)
+              ;; Copy all store items from the profile to the AppDir.
+              (populate-store '("profile") appdir)
+              ;; Symlink the provided entry-point to AppDir/AppRun.
+              (symlink (string-append "." profile "/" #$entry-point)
+                       (string-append appdir "/AppRun"))
+              ;; Create .desktop file as required by the spec.
+              (make-desktop-entry-file
+               (string-append appdir "/" #$name ".desktop")
+               #:name #$name
+               #:exec #$entry-point)
+              ;; Compress the AppDir.
+              (invoke #+(file-append squashfs-tools "/bin/mksquashfs") appdir
+                      squashfs "-root-owned" "-noappend"
+                      "-comp" #+(compressor-name compressor))
+              ;; Append runtime and squashFS into file AppImage.
+              (concatenate-files #$output
+                                 #$(file-append runtime-package "/" runtime-path)
+                                 squashfs)
+              ;; Add execution permission.
+              (chmod #$output #o555))))))
+  (gexp->derivation (string-append name ".AppImage") builder
+		    #:target target
+		    #:references-graphs `(("profile" ,profile))))
+\f
 ;;;
 ;;; Compiling C programs.
 ;;;
@@ -1311,6 +1408,7 @@ (define %formats
     (squashfs . ,squashfs-image)
     (docker  . ,docker-image)
     (deb . ,debian-archive)
+    (appimage . ,self-contained-appimage)
     (rpm . ,rpm-archive)))
 
 (define (show-formats)
@@ -1327,6 +1425,8 @@ (define (show-formats)
   deb           Debian archive installable via dpkg/apt"))
   (display (G_ "
   rpm           RPM archive installable via rpm/yum"))
+  (display (G_ "
+  appimage      AppImage self-contained and executable format"))
   (newline))
 
 (define (required-option symbol)
@@ -1694,6 +1794,8 @@ (define-command (guix-pack . args)
                                            (process-file-arg opts 'preun-file)
                                            #:postun-file
                                            (process-file-arg opts 'postun-file)))
+                                    ('appimage
+                                     (list #:relocatable? relocatable?))
                                     (_ '())))
                    (target      (assoc-ref opts 'target))
                    (bootstrap?  (assoc-ref opts 'bootstrap?))
diff --git a/tests/pack.scm b/tests/pack.scm
index f8a9e09c28..6ac9a966af 100644
--- a/tests/pack.scm
+++ b/tests/pack.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2021, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com>
+;;; Copyright © 2024 Noé Lopez <noelopez@free.fr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -32,7 +33,8 @@ (define-module (test-pack)
   #:use-module (guix utils)
   #:use-module ((guix build utils) #:select (%store-directory))
   #:use-module (gnu packages)
-  #:use-module ((gnu packages base) #:select (libc-utf8-locales-for-target))
+  #:use-module ((gnu packages base) #:select (libc-utf8-locales-for-target
+                                              hello))
   #:use-module (gnu packages bootstrap)
   #:use-module ((gnu packages package-management) #:select (rpm))
   #:use-module ((gnu packages compression) #:select (squashfs-tools))
@@ -340,6 +342,43 @@ (define rpm-for-tests
                              (mkdir #$output))))))))
       (built-derivations (list check))))
 
+  (unless store (test-skip 1))
+  (test-assertm "appimage"
+    (mlet* %store-monad
+        ((guile   (set-guile-for-build (default-guile)))
+         (profile -> (profile
+                      (content (packages->manifest (list %bootstrap-guile hello)))
+                      (hooks '())
+                      (locales? #f)))
+         (image   (self-contained-appimage "hello-appimage" profile
+                                           #:entry-point "bin/hello"
+                                           #:extra-options
+                                           (list #:relocatable? #t)))
+         (check   (gexp->derivation
+                   "check-appimage"
+                   #~(begin
+                       (invoke #$image)))))
+      (built-derivations (list check))))
+
+  (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)))
+                      (hooks '())
+                      (locales? #f)))
+         (image   (self-contained-appimage "hello-appimage" profile
+                                           #:entry-point "bin/hello"
+                                           #:localstatedir? #t
+                                           #:extra-options
+                                           (list #:relocatable? #t)))
+         (check   (gexp->derivation
+                   "check-appimage"
+                   #~(begin
+                       (invoke #$image)))))
+      (built-derivations (list check))))
+
   (unless store (test-skip 1))
   (test-assertm "deb archive with symlinks and control files"
     (mlet* %store-monad
-- 
2.46.0