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.
This commit is contained in:
Ricardo Wurmus 2018-05-25 16:24:49 +02:00 committed by Ricardo Wurmus
parent 5ffac538aa
commit b2817f0fa5
No known key found for this signature in database
GPG Key ID: 197A5888235FACAC
2 changed files with 112 additions and 4 deletions

View File

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

View File

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