diff options
| -rw-r--r-- | gnu/bootloader/grub.scm | 4 | ||||
| -rw-r--r-- | gnu/system.scm | 38 | ||||
| -rw-r--r-- | gnu/system/file-systems.scm | 8 | ||||
| -rw-r--r-- | gnu/system/mapped-devices.scm | 7 | ||||
| -rw-r--r-- | gnu/system/uuid.scm | 48 | ||||
| -rw-r--r-- | gnu/system/vm.scm | 4 |
6 files changed, 82 insertions, 27 deletions
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 <http://bugs.gnu.org/22281>. - ((? 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 <boot-parameters>." (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 (($ <file-system> 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 <file-system> 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 <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2017 Mark H Weaver <mhw@netris.org> ;;; @@ -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 <https://debbugs.gnu.org/cgi/bugreport.cgi?msg=52;att=0;bug=27735>). +(define-record-type <uuid> + (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 |