pack: Add support for squashfs images.

* guix/scripts/pack.scm (%formats): Add "squashfs" format.
(guix-pack): Adjust "archiver" dependent on pack-format.
(squashfs-image): New procedure.
* doc/guix.texi (Invoking guix pack): Document it.

2 files changed, 112 insertions, 4 deletions

diff --git a/doc/guix.texi b/doc/guix.texi
index 5eee40fc3c..6ff3e44d8c 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -2856,6 +2856,22 @@ command.  See the
 @uref{https://docs.docker.com/engine/reference/commandline/load/, Docker
 documentation} for more information.
 
+@cindex Singularity, build an image with guix pack
+@cindex SquashFS, build an image with guix pack
+Yet another option is to produce a SquashFS image with the following
+command:
+
+@example
+guix pack -f squashfs guile emacs geiser
+@end example
+
+@noindent
+The result is a SquashFS file system image that can either be mounted or
+directly be used as a file system container image with the
+@uref{http://singularity.lbl.gov, Singularity container execution
+environment}, using commands like @command{singularity shell} or
+@command{singularity exec}.
+
 Several command-line options allow you to customize your pack:
 
 @table @code
@@ -2874,6 +2890,11 @@ specified binaries and symlinks.
 This produces a tarball that follows the
 @uref{https://github.com/docker/docker/blob/master/image/spec/v1.2.md,
 Docker Image Specification}.
+
+@item squashfs
+This produces a SquashFS image containing all the specified binaries and
+symlinks, as well as empty mount points for virtual file systems like
+procfs.
 @end table
 
 @item --relocatable
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 980aef0ed8..35b8a7e729 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
-;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2018 Konrad Hinsen <konrad.hinsen@fastmail.net>
 ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
 ;;;
@@ -214,6 +214,90 @@ added to the pack."
                     build
                     #:references-graphs `(("profile" ,profile))))
 
+(define* (squashfs-image name profile
+                         #:key target
+                         deduplicate?
+                         (compressor (first %compressors))
+                         localstatedir?
+                         (symlinks '())
+                         (archiver squashfs-tools-next))
+  "Return a squashfs image containing a store initialized with the closure of
+PROFILE, a derivation.  The image contains a subset of /gnu/store, empty mount
+points for virtual file systems (like procfs), and optional symlinks.
+
+SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
+added to the pack."
+  (define build
+    (with-imported-modules '((guix build utils)
+                             (guix build store-copy)
+                             (gnu build install))
+      #~(begin
+          (use-modules (guix build utils)
+                       (gnu build install)
+                       (guix build store-copy)
+                       (srfi srfi-1)
+                       (srfi srfi-26)
+                       (ice-9 match))
+
+          (setenv "PATH" (string-append #$archiver "/bin"))
+
+          ;; We need an empty file in order to have a valid file argument when
+          ;; we reparent the root file system.  Read on for why that's
+          ;; necessary.
+          (with-output-to-file ".empty" (lambda () (display "")))
+
+          ;; Create the squashfs image in several steps.
+          ;; Add all store items.  Unfortunately mksquashfs throws away all
+          ;; ancestor directories and only keeps the basename.  We fix this
+          ;; in the following invocations of mksquashfs.
+          (apply invoke "mksquashfs"
+                 `(,@(call-with-input-file "profile"
+                       read-reference-graph)
+                   ,#$output
+
+                   ;; Do not perform duplicate checking because we
+                   ;; don't have any dupes.
+                   "-no-duplicates"
+                   "-comp"
+                   ,#+(compressor-name compressor)))
+
+          ;; Here we reparent the store items.  For each sub-directory of
+          ;; the store prefix we need one invocation of "mksquashfs".
+          (for-each (lambda (dir)
+                      (apply invoke "mksquashfs"
+                             `(".empty"
+                               ,#$output
+                               "-root-becomes" ,dir)))
+                    (reverse (string-tokenize (%store-directory)
+                                              (char-set-complement (char-set #\/)))))
+
+          ;; Add symlinks and mount points.
+          (apply invoke "mksquashfs"
+                 `(".empty"
+                   ,#$output
+                   ;; Create SYMLINKS via pseudo file definitions.
+                   ,@(append-map
+                      (match-lambda
+                        ((source '-> target)
+                         (list "-p"
+                               (string-join
+                                ;; name s mode uid gid symlink
+                                (list source
+                                      "s" "777" "0" "0"
+                                      (string-append #$profile "/" target))))))
+                      '#$symlinks)
+
+                   ;; Create empty mount points.
+                   "-p" "/proc d 555 0 0"
+                   "-p" "/sys d 555 0 0"
+                   "-p" "/dev d 555 0 0")))))
+
+  (gexp->derivation (string-append name
+                                   (compressor-extension compressor)
+                                   ".squashfs")
+                    build
+                    #:references-graphs `(("profile" ,profile))))
+
 (define* (docker-image name profile
                        #:key target
                        deduplicate?
@@ -462,6 +546,7 @@ please email '~a'~%")
 (define %formats
   ;; Supported pack formats.
   `((tarball . ,self-contained-tarball)
+    (squashfs . ,squashfs-image)
     (docker  . ,docker-image)))
 
 (define %options
@@ -626,9 +711,11 @@ Create a bundle of PACKAGE.\n"))
                (compressor  (if bootstrap?
                                 bootstrap-xz
                                 (assoc-ref opts 'compressor)))
-               (archiver    (if bootstrap?
-                                %bootstrap-coreutils&co
-                                tar))
+               (archiver    (if (equal? pack-format 'squashfs)
+                                squashfs-tools-next
+                                (if bootstrap?
+                                    %bootstrap-coreutils&co
+                                    tar)))
                (symlinks    (assoc-ref opts 'symlinks))
                (build-image (match (assq-ref %formats pack-format)
                               ((? procedure? proc) proc)