diff options
Diffstat (limited to 'gnu/system')
| -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 |
4 files changed, 53 insertions, 14 deletions
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 |