From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:4830:134:3::10]:34089) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1fMExn-0004BW-91 for guix-patches@gnu.org; Fri, 25 May 2018 11:49:08 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1fMExi-0008Mh-HV for guix-patches@gnu.org; Fri, 25 May 2018 11:49:07 -0400 Received: from debbugs.gnu.org ([208.118.235.43]:40682) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1fMExi-0008MW-E1 for guix-patches@gnu.org; Fri, 25 May 2018 11:49:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1fMExi-0008H8-6u for guix-patches@gnu.org; Fri, 25 May 2018 11:49:02 -0400 Subject: [bug#31592] [PATCH 4/4] pack: Add support for squashfs images. Resent-Message-ID: From: Ricardo Wurmus Date: Fri, 25 May 2018 17:47:30 +0200 Message-ID: <20180525154730.23955-4-ricardo.wurmus@mdc-berlin.de> In-Reply-To: <20180525154730.23955-1-ricardo.wurmus@mdc-berlin.de> References: <20180525154730.23955-1-ricardo.wurmus@mdc-berlin.de> MIME-Version: 1.0 Content-Type: text/plain; charset="UTF-8" Content-Transfer-Encoding: 8bit List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 31592@debbugs.gnu.org Cc: Ricardo Wurmus * 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 ;;; Copyright © 2017 Efraim Flashner -;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2017, 2018 Ricardo Wurmus ;;; Copyright © 2018 Konrad Hinsen ;;; Copyright © 2018 Chris Marusich ;;; @@ -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