From 4138e782dcfea675ebc2347cbd4ea9abeb9dff36 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 3 Sep 2017 10:56:25 +0100 Subject: vm: Remove redundant conditional in system-disk-image. * gnu/system/vm.scm (system-disk-image): Remove redundant conditional for #:file-system-type when calling qemu-image. --- gnu/system/vm.scm | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) (limited to 'gnu/system/vm.scm') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 4494af0031..b3da118765 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -403,10 +403,7 @@ to USB sticks meant to be read-only." (operating-system-bootloader os)) #:disk-image-size disk-image-size #:disk-image-format "raw" - #:file-system-type (if (string=? "iso9660" - file-system-type) - "ext4" - file-system-type) + #:file-system-type file-system-type #:file-system-label root-label #:copy-inputs? #t #:register-closures? #t -- cgit v1.2.3 From e375d3fab7a64246f9c1caa4b23a280f5b84ebc6 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 3 Sep 2017 11:48:20 +0100 Subject: vm: Add support for registering closures to iso9660-image. * gnu/system/vm.scm (iso9660-image): Add support for registering closures. --- gnu/system/vm.scm | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) (limited to 'gnu/system/vm.scm') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index b3da118765..f7a711a72b 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -192,6 +192,7 @@ made available under the /xchg CIFS share." os-drv bootcfg-drv bootloader + register-closures? (inputs '())) "Return a bootable, stand-alone iso9660 image. @@ -207,8 +208,13 @@ INPUTS is a list of inputs (as for packages)." (let ((inputs '#$(append (list qemu parted e2fsprogs dosfstools xorriso) (map canonical-package - (list sed grep coreutils findutils gawk)))) + (list sed grep coreutils findutils gawk)) + (if register-closures? (list guix) '()))) + + (graphs '#$(match inputs + (((names . _) ...) + names))) ;; This variable is unused but allows us to add INPUTS-TO-COPY ;; as inputs. (to-register @@ -222,6 +228,8 @@ INPUTS is a list of inputs (as for packages)." #$bootcfg-drv #$os-drv "/xchg/guixsd.iso" + #:register-closures? #$register-closures? + #:closures graphs #:volume-id #$file-system-label #:volume-uuid #$file-system-uuid) (reboot)))) -- cgit v1.2.3 From b069111f7a5d2c4596b9bc796fd0f56b77eb4c4e Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 3 Sep 2017 11:48:27 +0100 Subject: vm: Call iso9660-image with #:register-closures? as #t. * gnu/system/vm.scm (system-disk-image): Call iso9660-image with #:register-closures? as #t. --- gnu/system/vm.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'gnu/system/vm.scm') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index f7a711a72b..b106dff0a8 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -399,6 +399,7 @@ to USB sticks meant to be read-only." #:file-system-label root-label #:file-system-uuid #f #:os-drv os-drv + #:register-closures? #t #:bootcfg-drv bootcfg #:bootloader (bootloader-configuration-bootloader (operating-system-bootloader os)) -- cgit v1.2.3 From 9b336338cdc0e46a3bf7a2913c2f61cd2410c4d6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 6 Sep 2017 09:28:28 +0200 Subject: system: Introduce a disjoint UUID type. Conceptually a UUID is just a bytevector. However, there's software out there such as GRUB that relies on the string representation of different UUID types (e.g., the string representation of DCE UUIDs differs from that of ISO-9660 UUIDs, even if they are actually bytevectors of the same length). This new record type allows us to preserve information about the type of UUID so we can eventually convert it to a string using the right representation. * gnu/system/uuid.scm (): New record type. (bytevector->uuid): New procedure. (uuid): Return calls to 'make-uuid'. (uuid->string): Rewrite using 'match-lambda*' to accept a single 'uuid?' argument. * gnu/bootloader/grub.scm (grub-root-search): Check for 'uuid?' instead of 'bytevector?'. * gnu/system.scm (bootable-kernel-arguments): Check whether ROOT-DEVICE is 'uuid?'. (read-boot-parameters): Use 'bytevector->uuid' when the store device is a bytevector. (read-boot-parameters-file): Check for 'uuid?' instead of 'bytevector?'. (device->sexp): New procedure. (operating-system-boot-parameters-file): Use it for 'root-device' and 'store'. (operating-system-bootcfg): Remove conditional in definition of 'root-device'. * gnu/system/file-systems.scm (file-system->spec): Check for 'uuid?' on DEVICE and take its bytevector. * gnu/system/mapped-devices.scm (open-luks-device): Likewise. * gnu/system/vm.scm (iso9660-image): Call 'uuid-bytevector' for the #:volume-uuid argument. --- gnu/bootloader/grub.scm | 4 ++-- gnu/system.scm | 38 ++++++++++++++++++++++++---------- gnu/system/file-systems.scm | 8 +++++--- gnu/system/mapped-devices.scm | 7 +++++-- gnu/system/uuid.scm | 48 +++++++++++++++++++++++++++++++++++-------- gnu/system/vm.scm | 4 +++- 6 files changed, 82 insertions(+), 27 deletions(-) (limited to 'gnu/system/vm.scm') diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm index a9f0875f36..96e53c5c2b 100644 --- a/gnu/bootloader/grub.scm +++ b/gnu/bootloader/grub.scm @@ -30,7 +30,7 @@ #:use-module (gnu artwork) #:use-module (gnu system) #:use-module (gnu bootloader) - #:use-module (gnu system file-systems) + #:use-module (gnu system uuid) #:autoload (gnu packages bootloaders) (grub) #:autoload (gnu packages compression) (gzip) #:autoload (gnu packages gtk) (guile-cairo guile-rsvg) @@ -300,7 +300,7 @@ code." (match device ;; Preferably refer to DEVICE by its UUID or label. This is more ;; efficient and less ambiguous, see . - ((? bytevector? uuid) + ((? uuid? uuid) (format #f "search --fs-uuid --set ~a" (uuid->string device))) ((? string? label) diff --git a/gnu/system.scm b/gnu/system.scm index 6b35e3c0c7..a8d2a81316 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -54,6 +54,7 @@ #:use-module (gnu system locale) #:use-module (gnu system pam) #:use-module (gnu system linux-initrd) + #:use-module (gnu system uuid) #:use-module (gnu system file-systems) #:use-module (gnu system mapped-devices) #:use-module (ice-9 match) @@ -128,7 +129,14 @@ (define (bootable-kernel-arguments kernel-arguments system.drv root-device) "Prepend extra arguments to KERNEL-ARGUMENTS that allow SYSTEM.DRV to be booted from ROOT-DEVICE" - (cons* (string-append "--root=" root-device) + (cons* (string-append "--root=" + (if (uuid? root-device) + + ;; Note: Always use the DCE format because that's + ;; what (gnu build linux-boot) expects for the + ;; '--root' kernel command-line option. + (uuid->string (uuid-bytevector root-device) 'dce) + root-device)) #~(string-append "--system=" #$system.drv) #~(string-append "--load=" #$system.drv "/boot") kernel-arguments)) @@ -261,6 +269,8 @@ directly by the user." (store-device (match (assq 'store rest) + (('store ('device (? bytevector? bv)) _ ...) + (bytevector->uuid bv)) (('store ('device device) _ ...) device) (_ ;the old format @@ -289,16 +299,12 @@ The object has its kernel-arguments extended in order to make it bootable." (let* ((file (string-append system "/parameters")) (params (call-with-input-file file read-boot-parameters)) (root (boot-parameters-root-device params)) - (root-device (if (bytevector? root) - (uuid->string root) - root)) (kernel-arguments (boot-parameters-kernel-arguments params))) (if params (boot-parameters (inherit params) (kernel-arguments (bootable-kernel-arguments kernel-arguments - system - root-device))) + system root))) #f))) (define (boot-parameters->menu-entry conf) @@ -875,9 +881,7 @@ listed in OS. The C library expects to find it under (mlet* %store-monad ((system (operating-system-derivation os)) (root-fs -> (operating-system-root-file-system os)) - (root-device -> (if (eq? 'uuid (file-system-title root-fs)) - (uuid->string (file-system-device root-fs)) - (file-system-device root-fs))) + (root-device -> (file-system-device root-fs)) (params (operating-system-boot-parameters os system root-device)) (entry -> (boot-parameters->menu-entry params)) (bootloader-conf -> (operating-system-bootloader os))) @@ -917,6 +921,15 @@ kernel arguments for that derivation to ." (store-device (fs->boot-device store)) (store-mount-point (file-system-mount-point store)))))) +(define (device->sexp device) + "Serialize DEVICE as an sexp (really, as an object with a read syntax.)" + (match device + ((? uuid? uuid) + ;; TODO: Preserve the type of UUID. + (uuid-bytevector uuid)) + (_ + device))) + (define* (operating-system-boot-parameters-file os #:optional (system.drv #f)) "Return a file that describes the boot parameters of OS. The primary use of this file is the reconstruction of GRUB menu entries for old configurations. @@ -934,14 +947,17 @@ being stored into the \"parameters\" file)." #~(boot-parameters (version 0) (label #$(boot-parameters-label params)) - (root-device #$(boot-parameters-root-device params)) + (root-device + #$(device->sexp + (boot-parameters-root-device params))) (kernel #$(boot-parameters-kernel params)) (kernel-arguments #$(boot-parameters-kernel-arguments params)) (initrd #$(boot-parameters-initrd params)) (bootloader-name #$(boot-parameters-bootloader-name params)) (store - (device #$(boot-parameters-store-device params)) + (device + #$(device->sexp (boot-parameters-store-device params))) (mount-point #$(boot-parameters-store-mount-point params)))) #:set-load-path? #f))) diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index dd30559d7e..52f16676f5 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -20,8 +20,7 @@ #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (guix records) - #:use-module ((gnu system uuid) - #:select (uuid string->uuid uuid->string)) + #:use-module (gnu system uuid) #:re-export (uuid ;backward compatibility string->uuid uuid->string) @@ -157,7 +156,10 @@ store--e.g., if FS is the root file system." initrd code." (match fs (($ device title mount-point type flags options _ _ check?) - (list device title mount-point type flags options check?)))) + (list (if (uuid? device) + (uuid-bytevector device) + device) + title mount-point type flags options check?)))) (define (spec->file-system sexp) "Deserialize SEXP, a list, to the corresponding object." diff --git a/gnu/system/mapped-devices.scm b/gnu/system/mapped-devices.scm index 18b9f5b4b6..17cf6b7163 100644 --- a/gnu/system/mapped-devices.scm +++ b/gnu/system/mapped-devices.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès ;;; Copyright © 2016 Andreas Enge ;;; Copyright © 2017 Mark H Weaver ;;; @@ -24,6 +24,7 @@ #:use-module (guix modules) #:use-module (gnu services) #:use-module (gnu services shepherd) + #:use-module (gnu system uuid) #:autoload (gnu packages cryptsetup) (cryptsetup-static) #:autoload (gnu packages linux) (mdadm-static) #:use-module (srfi srfi-1) @@ -99,7 +100,9 @@ 'cryptsetup'." (with-imported-modules (source-module-closure '((gnu build file-systems))) - #~(let ((source #$source)) + #~(let ((source #$(if (uuid? source) + (uuid-bytevector source) + source))) ;; XXX: 'use-modules' should be at the top level. (use-modules (rnrs bytevectors) ;bytevector? ((gnu build file-systems) diff --git a/gnu/system/uuid.scm b/gnu/system/uuid.scm index 64dad5a374..60626ebb12 100644 --- a/gnu/system/uuid.scm +++ b/gnu/system/uuid.scm @@ -19,12 +19,19 @@ (define-module (gnu system uuid) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:use-module (ice-9 vlist) #:use-module (ice-9 regex) #:use-module (ice-9 format) #:export (uuid + uuid? + uuid-type + uuid-bytevector + + bytevector->uuid + uuid->string dce-uuid->string string->uuid @@ -206,15 +213,27 @@ corresponding bytevector; otherwise return #f." (#f #f) ((_ . (? procedure? parse)) (parse str)))) -(define* (uuid->string bv #:key (type 'dce)) - "Convert BV, a bytevector, to the UUID string representation for TYPE." - (match (vhash-assq type %uuid-printers) - (#f #f) - ((_ . (? procedure? unparse)) (unparse bv)))) +;; High-level UUID representation that carries its type with it. +;; +;; This is necessary to serialize bytevectors with the right printer in some +;; circumstances. For instance, GRUB "search --fs-uuid" command compares the +;; string representation of UUIDs, not the raw bytes; thus, when emitting a +;; GRUB 'search' command, we need to procedure the right string representation +;; (see ). +(define-record-type + (make-uuid type bv) + uuid? + (type uuid-type) ;'dce | 'iso9660 | ... + (bv uuid-bytevector)) + +(define* (bytevector->uuid bv #:optional (type 'dce)) + "Return a UUID object make of BV and TYPE." + (make-uuid type bv)) (define-syntax uuid (lambda (s) - "Return the bytevector corresponding to the given UUID representation." + "Return the UUID object corresponding to the given UUID representation." + ;; TODO: Extend to types other than DCE. (syntax-case s () ((_ str) (string? (syntax->datum #'str)) @@ -222,6 +241,19 @@ corresponding bytevector; otherwise return #f." (let ((bv (string->uuid (syntax->datum #'str)))) (unless bv (syntax-violation 'uuid "invalid UUID" s)) - (datum->syntax #'str bv))) + #`(make-uuid 'dce #,(datum->syntax #'str bv)))) ((_ str) - #'(string->uuid str))))) + #'(make-uuid 'dce (string->uuid str)))))) + +(define uuid->string + ;; Convert the given bytevector or UUID object, to the corresponding UUID + ;; string representation. + (match-lambda* + (((? bytevector? bv)) + (uuid->string bv 'dce)) + (((? bytevector? bv) type) + (match (vhash-assq type %uuid-printers) + (#f #f) + ((_ . (? procedure? unparse)) (unparse bv)))) + (((? uuid? uuid)) + (uuid->string (uuid-bytevector uuid) (uuid-type uuid))))) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index b106dff0a8..92f0444ed8 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -57,6 +57,7 @@ #:use-module (gnu system file-systems) #:use-module (gnu system) #:use-module (gnu services) + #:use-module (gnu system uuid) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -231,7 +232,8 @@ INPUTS is a list of inputs (as for packages)." #:register-closures? #$register-closures? #:closures graphs #:volume-id #$file-system-label - #:volume-uuid #$file-system-uuid) + #:volume-uuid #$(and=> file-system-uuid + uuid-bytevector)) (reboot)))) #:system system #:make-disk-image? #f -- cgit v1.2.3 From fd3b4b985d5bbd5d91362aa91079c1155018fa34 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 6 Sep 2017 23:12:32 +0200 Subject: vm: Allow users to specify a UUID for the root partition. * gnu/system/vm.scm (qemu-image): Add #:file-system-uuid parameter; pass it as the 'uuid' field of the root partition. --- gnu/system/vm.scm | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) (limited to 'gnu/system/vm.scm') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 92f0444ed8..9e900182ae 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -248,6 +248,7 @@ INPUTS is a list of inputs (as for packages)." (disk-image-format "qcow2") (file-system-type "ext4") file-system-label + file-system-uuid os-drv bootcfg-drv bootloader @@ -257,7 +258,10 @@ INPUTS is a list of inputs (as for packages)." "Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g., 'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE. Optionally, FILE-SYSTEM-LABEL can be specified as the volume name for the root -partition. The returned image is a full disk image that runs OS-DERIVATION, +partition; likewise FILE-SYSTEM-UUID, if true, specifies the UUID of the root +partition (a UUID object). + +The returned image is a full disk image that runs OS-DERIVATION, with a GRUB installation that uses GRUB-CONFIGURATION as its configuration file (GRUB-CONFIGURATION must be the name of a file in the VM.) @@ -307,6 +311,8 @@ the image." (partitions (list (partition (size root-size) (label #$file-system-label) + (uuid #$(and=> file-system-uuid + uuid-bytevector)) (file-system #$file-system-type) (flags '(boot)) (initializer initialize)) -- cgit v1.2.3 From 5f7fe1c57ecb9525aa7e13e38af2aab022bae078 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 6 Sep 2017 23:16:09 +0200 Subject: vm: Generate a UUID to identify the root file system. This makes collisions less likely than when using a label to look up the partition. See . * gnu/system/vm.scm (operating-system-uuid): New procedure. (system-disk-image): Define 'root-uuid' and use it for the root file system. Pass it to 'iso9660-image' and 'qemu-image'. --- gnu/system/vm.scm | 51 +++++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 45 insertions(+), 6 deletions(-) (limited to 'gnu/system/vm.scm') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 9e900182ae..78143e4f7a 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -61,6 +61,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:export (expression->derivation-in-linux-vm @@ -350,6 +351,35 @@ the image." ;;; VM and disk images. ;;; +(define* (operating-system-uuid os #:optional (type 'dce)) + "Compute UUID object with a deterministic \"UUID\" for OS, of the given +TYPE (one of 'iso9660 or 'dce). Return a UUID object." + (if (eq? type 'iso9660) + (let ((pad (compose (cut string-pad <> 2 #\0) + number->string)) + (h (hash (operating-system-services os) 3600))) + (bytevector->uuid + (string->iso9660-uuid + (string-append "1970-01-01-" + (pad (hash (operating-system-host-name os) 24)) "-" + (pad (quotient h 60)) "-" + (pad (modulo h 60)) "-" + (pad (hash (operating-system-file-systems os) 100)))) + 'iso9660)) + (bytevector->uuid + (uint-list->bytevector + (list (hash file-system-type + (expt 2 32)) + (hash (operating-system-host-name os) + (expt 2 32)) + (hash (operating-system-services os) + (expt 2 32)) + (hash (operating-system-file-systems os) + (expt 2 32))) + (endianness little) + 4) + type))) + (define* (system-disk-image os #:key (name "disk-image") @@ -366,12 +396,20 @@ to USB sticks meant to be read-only." (if (string=? "iso9660" file-system-type) string-upcase identity)) + (define root-label - ;; Volume name of the root file system. Since we don't know which device - ;; will hold it, we use the volume name to find it (using the UUID would - ;; be even better, but somewhat less convenient.) + ;; Volume name of the root file system. (normalize-label "GuixSD_image")) + (define root-uuid + ;; UUID of the root file system, computed in a deterministic fashion. + ;; This is what we use to locate the root file system so it has to be + ;; different from the user's own file system UUIDs. + (operating-system-uuid os + (if (string=? file-system-type "iso9660") + 'iso9660 + 'dce))) + (define file-systems-to-keep (remove (lambda (fs) (string=? (file-system-mount-point fs) "/")) @@ -395,8 +433,8 @@ to USB sticks meant to be read-only." ;; Force our own root file system. (file-systems (cons (file-system (mount-point "/") - (device root-label) - (title 'label) + (device root-uuid) + (title 'uuid) (type file-system-type)) file-systems-to-keep))))) @@ -405,7 +443,7 @@ to USB sticks meant to be read-only." (if (string=? "iso9660" file-system-type) (iso9660-image #:name name #:file-system-label root-label - #:file-system-uuid #f + #:file-system-uuid root-uuid #:os-drv os-drv #:register-closures? #t #:bootcfg-drv bootcfg @@ -422,6 +460,7 @@ to USB sticks meant to be read-only." #:disk-image-format "raw" #:file-system-type file-system-type #:file-system-label root-label + #:file-system-uuid root-uuid #:copy-inputs? #t #:register-closures? #t #:inputs `(("system" ,os-drv) -- cgit v1.2.3