diff options
author | Mark H Weaver <mhw@netris.org> | 2018-05-28 20:45:37 -0400 |
---|---|---|
committer | Mark H Weaver <mhw@netris.org> | 2018-05-28 20:45:37 -0400 |
commit | 82b695b834f88c5561de40e68f3fe7aa24d3b796 (patch) | |
tree | 41743fff1013584ee4a50852a94cff01c3cc3d1c /guix | |
parent | fe365a3d0e4df7445bf16d3bb422a0bc6bb68ceb (diff) | |
parent | ee3c8fbee21299ce105bafca7dc63bfb096cd7c5 (diff) | |
download | guix-patches-82b695b834f88c5561de40e68f3fe7aa24d3b796.tar guix-patches-82b695b834f88c5561de40e68f3fe7aa24d3b796.tar.gz |
Merge branch 'master' into core-updates
Diffstat (limited to 'guix')
-rw-r--r-- | guix/scripts/pack.scm | 109 | ||||
-rw-r--r-- | guix/scripts/system.scm | 31 |
2 files changed, 115 insertions, 25 deletions
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 1e84459e78..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> ;;; @@ -93,7 +93,7 @@ found." (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 @@ added to the pack." ;; 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 @@ added to the pack." (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. @@ -214,13 +214,97 @@ 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? (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 +352,7 @@ the image." (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" @@ -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))) - (tar (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) @@ -654,8 +741,8 @@ Create a bundle of PACKAGE.\n")) symlinks #:localstatedir? localstatedir? - #:tar - tar))) + #:archiver + archiver))) (mbegin %store-monad (show-what-to-build* (list drv) #:use-substitutes? 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 @@ any, are available. Raise an error if they're not." (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 @@ any, are available. Raise an error if they're not." (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 @@ available in the initrd. Note that mapped devices are responsible for 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? |