From a5acc17a3c10a3779b5b8b1a2565ef130be77e51 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 18 May 2018 13:43:07 +0200 Subject: file-systems: Remove 'title' field and add . The 'title' field was easily overlooked and was an endless source of confusion. Now, the value of the 'device' field is self-contained. * gnu/system/file-systems.scm (): Change constructor name to '%file-system'. [title]: Remove. (): New record type with printer. (report-deprecation, device-expression) (process-file-system-declaration, file-system): New macros. (file-system-title): New procedure. (file-system->spec, spec->file-system): Adjust to handle . * gnu/system.scm (bootable-kernel-arguments): Add case for 'file-system-label?'. (read-boot-parameters): Likewise. (mapped-device-user): Avoid 'file-system-title'. (fs->boot-device): Remove. (operating-system-boot-parameters): Use 'file-system-device' instead of 'fs->boot-device'. (device->sexp): Add case for 'file-system-label?'. * gnu/bootloader/grub.scm (grub-root-search): Add case for 'file-system-label?'. * gnu/system/examples/bare-bones.tmpl, gnu/system/examples/beaglebone-black.tmpl, gnu/system/examples/lightweight-desktop.tmpl, gnu/system/examples/vm-image.tmpl: Remove uses of 'title'. * gnu/system/vm.scm (virtualized-operating-system): Remove uses of 'file-system-title'. * guix/scripts/system.scm (check-file-system-availability): Likewise, and adjust fix-it hint. (check-initrd-modules)[file-system-/dev]: Likewise. * gnu/build/file-systems.scm (canonicalize-device-spec): Remove 'title' parameter. [canonical-title]: Remove. Match on SPEC's type rather than on CANONICAL-TITLE. (mount-file-system): Adjust caller. * gnu/build/linux-boot.scm (boot-system): Interpret ROOT here. * gnu/services/base.scm (file-system->fstab-entry): Remove use of 'file-system-title'. * doc/guix.texi (File Systems): Remove documentation of the 'title' field. Rewrite documentation of 'device' and document 'file-system-label'. --- guix/scripts/system.scm | 31 +++++++++++++++++-------------- 1 file changed, 17 insertions(+), 14 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index af501eb8f7..5d0df14924 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -590,17 +590,17 @@ (define relevant (define labeled (filter (lambda (fs) - (eq? (file-system-title fs) 'label)) + (file-system-label? (file-system-device fs))) relevant)) (define literal (filter (lambda (fs) - (eq? (file-system-title fs) 'device)) + (string? (file-system-device fs))) relevant)) (define uuid (filter (lambda (fs) - (eq? (file-system-title fs) 'uuid)) + (uuid? (file-system-device fs))) relevant)) (define fail? #f) @@ -628,15 +628,15 @@ (define (file-system-location* fs) (strerror errno)) (unless (string-prefix? "/" device) (display-hint (format #f (G_ "If '~a' is a file system -label, you need to add @code{(title 'label)} to your @code{file-system} -definition.") - device))))))) +label, write @code{(file-system-label ~s)} in your @code{device} field.") + device device))))))) literal) (for-each (lambda (fs) - (unless (find-partition-by-label (file-system-device fs)) - (error (G_ "~a: error: file system with label '~a' not found~%") - (file-system-location* fs) - (file-system-device fs)))) + (let ((label (file-system-label->string + (file-system-device fs)))) + (unless (find-partition-by-label label) + (error (G_ "~a: error: file system with label '~a' not found~%") + (file-system-location* fs) label)))) labeled) (for-each (lambda (fs) (unless (find-partition-by-uuid (file-system-device fs)) @@ -677,10 +677,13 @@ (define (check-initrd-modules os) checking this by themselves in their 'check' procedure." (define (file-system-/dev fs) (let ((device (file-system-device fs))) - (match (file-system-title fs) - ('device device) - ('uuid (find-partition-by-uuid device)) - ('label (find-partition-by-label device))))) + (match device + ((? string?) + device) + ((? uuid?) + (find-partition-by-uuid device)) + ((? file-system-label?) + (find-partition-by-label (file-system-label->string device)))))) (define file-systems (filter file-system-needed-for-boot? -- cgit v1.2.3 From 5ffac538aa604b71814ac74579626f0d3110b96e Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Fri, 25 May 2018 16:22:30 +0200 Subject: pack: Rename "tar" to "archiver". * guix/scripts/pack.scm (self-contained-tarball, docker-image): Accept "archiver" argument; remove "tar" argument. (guix-pack): Invoke "build-image" with "archiver" argument. --- guix/scripts/pack.scm | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 1e84459e78..980aef0ed8 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -93,7 +93,7 @@ (define* (self-contained-tarball name profile (compressor (first %compressors)) localstatedir? (symlinks '()) - (tar tar)) + (archiver tar)) "Return a self-contained tarball containing a store initialized with the closure of PROFILE, a derivation. The tarball contains /gnu/store; if LOCALSTATEDIR? is true, it also contains /var/guix, including /var/guix/db @@ -142,7 +142,7 @@ (define directives ;; 2014-07-28. For testing, we use the bootstrap tar, which is ;; older and doesn't support it. (define tar-supports-sort? - (zero? (system* (string-append #+tar "/bin/tar") + (zero? (system* (string-append #+archiver "/bin/tar") "cf" "/dev/null" "--files-from=/dev/null" "--sort=name"))) @@ -151,7 +151,7 @@ (define tar-supports-sort? (string-append #$(if localstatedir? (file-append guix "/sbin:") "") - #$tar "/bin")) + #$archiver "/bin")) ;; Note: there is not much to gain here with deduplication and there ;; is the overhead of the '.links' directory, so turn it off. @@ -220,7 +220,7 @@ (define* (docker-image name profile (compressor (first %compressors)) localstatedir? (symlinks '()) - (tar tar)) + (archiver tar)) "Return a derivation to construct a Docker image of PROFILE. The image is a tarball conforming to the Docker Image Specification, compressed with COMPRESSOR. It can be passed to 'docker load'. If TARGET is true, it @@ -268,7 +268,7 @@ (define build (use-modules (guix docker) (srfi srfi-19) (guix build store-copy)) - (setenv "PATH" (string-append #$tar "/bin")) + (setenv "PATH" (string-append #$archiver "/bin")) (build-docker-image #$output (call-with-input-file "profile" @@ -626,7 +626,7 @@ (define (manifest-from-args store opts) (compressor (if bootstrap? bootstrap-xz (assoc-ref opts 'compressor))) - (tar (if bootstrap? + (archiver (if bootstrap? %bootstrap-coreutils&co tar)) (symlinks (assoc-ref opts 'symlinks)) @@ -654,8 +654,8 @@ (define (manifest-from-args store opts) symlinks #:localstatedir? localstatedir? - #:tar - tar))) + #:archiver + archiver))) (mbegin %store-monad (show-what-to-build* (list drv) #:use-substitutes? -- cgit v1.2.3 From b2817f0fa511ddfa4d31846b9d297ad36eea1b43 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Fri, 25 May 2018 16:24:49 +0200 Subject: 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. --- doc/guix.texi | 21 ++++++++++++ guix/scripts/pack.scm | 95 ++++++++++++++++++++++++++++++++++++++++++++++++--- 2 files changed, 112 insertions(+), 4 deletions(-) (limited to 'guix') 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 ;;; Copyright © 2017 Efraim Flashner -;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2017, 2018 Ricardo Wurmus ;;; Copyright © 2018 Konrad Hinsen ;;; Copyright © 2018 Chris Marusich ;;; @@ -214,6 +214,90 @@ (define tar-supports-sort? 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 @@ (define %default-options (define %formats ;; Supported pack formats. `((tarball . ,self-contained-tarball) + (squashfs . ,squashfs-image) (docker . ,docker-image))) (define %options @@ -626,9 +711,11 @@ (define (manifest-from-args store opts) (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) -- cgit v1.2.3