summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorRicardo Wurmus <ricardo.wurmus@mdc-berlin.de>2018-05-25 16:24:49 +0200
committerRicardo Wurmus <rekado@elephly.net>2018-05-28 17:36:09 +0200
commitb2817f0fa511ddfa4d31846b9d297ad36eea1b43 (patch)
tree8ffa458549c070583ac10281acacecb67e8e6206 /guix
parent5ffac538aa604b71814ac74579626f0d3110b96e (diff)
downloadgnu-guix-b2817f0fa511ddfa4d31846b9d297ad36eea1b43.tar
gnu-guix-b2817f0fa511ddfa4d31846b9d297ad36eea1b43.tar.gz
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.
Diffstat (limited to 'guix')
-rw-r--r--guix/scripts/pack.scm95
1 files changed, 91 insertions, 4 deletions
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)