[bug#31592] [PATCH 4/4] pack: Add support for squashfs images.

[Ricardo Wurmus <ricardo.wurmus@mdc-berlin.de>]

* guix/scripts/pack.scm (%formats): Add "squashfs" format.
(guix-pack): Adjust "archiver" dependent on pack-format.
(squashfs-image): New procedure.
---
 guix/scripts/pack.scm | 96 ++++++++++++++++++++++++++++++++++++++++++++++++---
 1 file changed, 92 insertions(+), 4 deletions(-)

diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 980aef0ed..88a2495c8 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,91 @@ 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 and .
+
+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.
+          (exit
+           (and
+            ;; 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.
+            (zero? (apply system* "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".
+            (every (lambda (dir)
+                     (zero? (apply system* "mksquashfs"
+                                   `(".empty"
+                                     ,#$output
+                                     "-root-becomes" ,dir))))
+                   (reverse (filter (negate string-null?)
+                                    (string-split (%store-directory) #\/))))
+
+            ;; Add symlinks and mount points.
+            (zero? (apply system* "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 +547,7 @@ please email '~a'~%")
 (define %formats
   ;; Supported pack formats.
   `((tarball . ,self-contained-tarball)
+    (squashfs . ,squashfs-image)
     (docker  . ,docker-image)))
 
 (define %options
@@ -626,9 +712,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)
-- 
2.15.1