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

[Maxim Cournoyer <maxim.cournoyer@gmail.com>]

Hi,

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

> 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>

Thanks for this great addition.

> Change-Id: I33ebfec623cff1cfcd6f029d2d3054c23ab1949a
> ---
>  doc/guix.texi         |  55 +++++++++++++++++++++-
>  guix/scripts/pack.scm | 104 +++++++++++++++++++++++++++++++++++++++++-
>  tests/pack.scm        |  41 ++++++++++++++++-
>  3 files changed, 197 insertions(+), 3 deletions(-)
>
> diff --git a/doc/guix.texi b/doc/guix.texi
> index ac3a7adef0..18edf8e550 100644
> --- a/doc/guix.texi
> +++ b/doc/guix.texi
> @@ -6949,6 +6949,18 @@ 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 made
> +executable and run without any special privileges:
> +
> +@example
> +guix pack -f appimage --entry-point=bin/guile guile
> +cp @var{file} . && chmod u+x $(basename @var{file})
> +./$(basename @var{file}) --help
> +@end example
> +where @var{file} is the image returned by @command{guix pack}.

The chmod is no longer needed in this v2.  Also, it could be nicer
perhaps to capture the output file in a real variable:

@example
file=$(guix pack -f appimage --entry-point=bin/guile guile)
$file
@end example

> +
>  Several command-line options allow you to customize your pack:
>
>  @table @code
> @@ -7065,6 +7077,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.

Instead of a warning, could we just make it always -RR by default and
document that these are always relocatable, by design?  The no
relocatable flags would be treated as an implicit -RR, and otherwise a
single -R would be treated as a single -R (and -RR as -RR, eh).

> +@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

Are there plans to add support for .DirIcon in the future?

> +@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 +7208,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..95b40a743b 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

Standalone comments (those starting on their own line with ;;) should be
fully punctuated (complete sentence), e.g.: "Add execution permission."
for the last one.

> +              (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

The rest looks good to me, from a quick read.  If you could send a v3,
I'll then give it a real try.

-- 
Thanks,
Maxim