Package: guix-patches;
Reported by: Ludovic Courtès <ludo <at> gnu.org>
Date: Wed, 6 Sep 2017 21:53:01 UTC
Severity: normal
Tags: patch
Done: ludo <at> gnu.org (Ludovic Courtès)
Bug is archived. No further changes may be made.
To add a comment to this bug, you must first unarchive it, by sending
a message to control AT debbugs.gnu.org, with unarchive 28377 in the body.
You can then email your comments to 28377 AT debbugs.gnu.org in the normal way.
Toggle the display of automated, internal messages from the tracker.
View this report as an mbox folder, status mbox, maintainer mbox
guix-patches <at> gnu.org
:bug#28377
; Package guix-patches
.
(Wed, 06 Sep 2017 21:53:01 GMT) Full text and rfc822 format available.Ludovic Courtès <ludo <at> gnu.org>
:guix-patches <at> gnu.org
.
(Wed, 06 Sep 2017 21:53:01 GMT) Full text and rfc822 format available.Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: guix-patches <at> gnu.org Cc: Danny Milosavljevic <dannym <at> scratchpost.org>, Ludovic Courtès <ludo <at> gnu.org>, Tobias Geerinckx-Rice <me <at> tobias.gr> Subject: [PATCH 00/10] Allow users to specify the UUID of disk images Date: Wed, 6 Sep 2017 23:51:30 +0200
Hello! This is a followup to <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27735#31>: it’s about making it possible to specify the UUID of the root partition of the disk image. To get there, this patch series does a few things: 1. Give a 2nd argument to ‘uuid->string’ et al., which is the name of the UUID format. 2. Move UUID-related code to (gnu system uuid). 3. Introduce a <uuid> record type that ties together a bytevector and a symbol specifying the UUID type (DCE, ISO9660, etc.). This allows ‘uuid->string’ to generate a string in the “right” format as expected by tools such as GRUB. 4. Finally, generate a UUID for generated images. Tested with both an ISO and an ext4/qcow2 image. Feedback welcome! Ludo’. Ludovic Courtès (10): vm: Allow partitions to be initialized with a given UUID. file-systems: Add UUID type dictionaries. services: base: Import the closure of (gnu build file-systems). file-systems: Introduce (gnu system uuid). services: file-system: Use 'file-system->spec'. system: Introduce a disjoint UUID type. system: Serialize the UUID type in the "parameters" file. uuid: 'uuid' macro supports more UUID types. vm: Allow users to specify a UUID for the root partition. vm: Generate a UUID to identify the root file system. gnu/bootloader/grub.scm | 4 +- gnu/build/file-systems.scm | 130 +-------------------- gnu/build/vm.scm | 28 +++-- gnu/local.mk | 1 + gnu/services/base.scm | 15 +-- gnu/system.scm | 48 +++++--- gnu/system/file-systems.scm | 26 ++--- gnu/system/mapped-devices.scm | 7 +- gnu/system/uuid.scm | 265 ++++++++++++++++++++++++++++++++++++++++++ gnu/system/vm.scm | 63 ++++++++-- 10 files changed, 393 insertions(+), 194 deletions(-) create mode 100644 gnu/system/uuid.scm -- 2.14.1
guix-patches <at> gnu.org
:bug#28377
; Package guix-patches
.
(Wed, 06 Sep 2017 22:19:02 GMT) Full text and rfc822 format available.Message #8 received at 28377 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 28377 <at> debbugs.gnu.org Cc: Danny Milosavljevic <dannym <at> scratchpost.org>, Ludovic Courtès <ludo <at> gnu.org>, Tobias Geerinckx-Rice <me <at> tobias.gr> Subject: [PATCH 01/10] vm: Allow partitions to be initialized with a given UUID. Date: Thu, 7 Sep 2017 00:17:47 +0200
* gnu/build/vm.scm (<partition>)[uuid]: New field. (create-ext-file-system): Add #:uuid and honor it. (create-fat-file-system): Add #:uuid. (format-partition): Add #:uuid and honor it. (initialize-partition): Honor the 'uuid' field of PARTITION. --- gnu/build/vm.scm | 26 ++++++++++++++++---------- 1 file changed, 16 insertions(+), 10 deletions(-) diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm index 727494ad9..8dfaf2789 100644 --- a/gnu/build/vm.scm +++ b/gnu/build/vm.scm @@ -163,6 +163,7 @@ the #:references-graphs parameter of 'derivation'." (size partition-size) (file-system partition-file-system (default "ext4")) (label partition-label (default #f)) + (uuid partition-uuid (default #f)) (flags partition-flags (default '())) (initializer partition-initializer (default (const #t)))) @@ -236,22 +237,26 @@ actual /dev name based on DEVICE." (define MS_BIND 4096) ; <sys/mounts.h> again! (define* (create-ext-file-system partition type - #:key label) + #:key label uuid) "Create an ext-family filesystem of TYPE on PARTITION. If LABEL is true, -use that as the volume name." +use that as the volume name. If UUID is true, use it as the partition UUID." (format #t "creating ~a partition...\n" type) (unless (zero? (apply system* (string-append "mkfs." type) "-F" partition - (if label - `("-L" ,label) - '()))) + `(,@(if label + `("-L" ,label) + '()) + ,@(if uuid + `("-U" ,(uuid->string uuid)) + '())))) (error "failed to create partition"))) (define* (create-fat-file-system partition - #:key label) + #:key label uuid) "Create a FAT filesystem on PARTITION. The number of File Allocation Tables will be determined based on filesystem size. If LABEL is true, use that as the volume name." + ;; FIXME: UUID is ignored! (format #t "creating FAT partition...\n") (unless (zero? (apply system* "mkfs.fat" partition (if label @@ -260,13 +265,13 @@ volume name." (error "failed to create FAT partition"))) (define* (format-partition partition type - #:key label) + #:key label uuid) "Create a file system TYPE on PARTITION. If LABEL is true, use that as the volume name." (cond ((string-prefix? "ext" type) - (create-ext-file-system partition type #:label label)) + (create-ext-file-system partition type #:label label #:uuid uuid)) ((or (string-prefix? "fat" type) (string= "vfat" type)) - (create-fat-file-system partition #:label label)) + (create-fat-file-system partition #:label label #:uuid uuid)) (else (error "Unsupported file system.")))) (define (initialize-partition partition) @@ -275,7 +280,8 @@ it, run its initializer, and unmount it." (let ((target "/fs")) (format-partition (partition-device partition) (partition-file-system partition) - #:label (partition-label partition)) + #:label (partition-label partition) + #:uuid (partition-uuid partition)) (mkdir-p target) (mount (partition-device partition) target (partition-file-system partition)) -- 2.14.1
guix-patches <at> gnu.org
:bug#28377
; Package guix-patches
.
(Wed, 06 Sep 2017 22:19:02 GMT) Full text and rfc822 format available.Message #11 received at 28377 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 28377 <at> debbugs.gnu.org Cc: Danny Milosavljevic <dannym <at> scratchpost.org>, Ludovic Courtès <ludo <at> gnu.org>, Tobias Geerinckx-Rice <me <at> tobias.gr> Subject: [PATCH 02/10] file-systems: Add UUID type dictionaries. Date: Thu, 7 Sep 2017 00:17:48 +0200
* gnu/build/file-systems.scm (uuid->string): Rename to... (dce-uuid->string): ... this. (string->uuid): Rename to... (string->dce-uuid): ... this. (vhashq): New macro. (%uuid-parsers, %uuid-printers): New variables. (uuid->string, string->uuid): New procedures. --- gnu/build/file-systems.scm | 49 ++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 43 insertions(+), 6 deletions(-) diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index 203fbdfff..fbaf15895 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -28,6 +28,7 @@ #:use-module (ice-9 rdelim) #:use-module (ice-9 format) #:use-module (ice-9 regex) + #:use-module (ice-9 vlist) #:use-module (system foreign) #:autoload (system repl repl) (start-repl) #:use-module (srfi srfi-1) @@ -42,7 +43,9 @@ canonicalize-device-spec uuid->string + dce-uuid->string string->uuid + string->dce-uuid string->iso9660-uuid string->ext2-uuid string->ext3-uuid @@ -516,7 +519,7 @@ were found." (define-syntax %network-byte-order (identifier-syntax (endianness big))) -(define (uuid->string uuid) +(define (dce-uuid->string uuid) "Convert UUID, a 16-byte bytevector, to its string representation, something like \"6b700d61-5550-48a1-874c-a3d86998990e\"." ;; See <https://tools.ietf.org/html/rfc4122>. @@ -532,7 +535,7 @@ like \"6b700d61-5550-48a1-874c-a3d86998990e\"." ;; The regexp of a UUID. (make-regexp "^([[:xdigit:]]{8})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{12})$")) -(define (string->uuid str) +(define (string->dce-uuid str) "Parse STR as a DCE UUID (see <https://tools.ietf.org/html/rfc4122>) and return its contents as a 16-byte bytevector. Return #f if STR is not a valid UUID representation." @@ -562,10 +565,44 @@ UUID representation." (time-low 4) (time-mid 2) (time-hi 2) (clock-seq 2) (node 6))))))) -(define string->ext2-uuid string->uuid) -(define string->ext3-uuid string->uuid) -(define string->ext4-uuid string->uuid) -(define string->btrfs-uuid string->uuid) +(define string->ext2-uuid string->dce-uuid) +(define string->ext3-uuid string->dce-uuid) +(define string->ext4-uuid string->dce-uuid) +(define string->btrfs-uuid string->dce-uuid) + +(define-syntax vhashq + (syntax-rules (=>) + ((_) + vlist-null) + ((_ (key others ... => value) rest ...) + (vhash-consq key value + (vhashq (others ... => value) rest ...))) + ((_ (=> value) rest ...) + (vhashq rest ...)))) + +(define %uuid-parsers + (vhashq + ('dce 'ext2 'ext3 'ext4 'btrfs 'luks => string->dce-uuid) + ('iso9660 => string->iso9660-uuid))) + +(define %uuid-printers + (vhashq + ('dce 'ext2 'ext3 'ext4 'btrfs 'luks => dce-uuid->string) + ('iso9660 => iso9660-uuid->string) + ('fat32 'fat => fat32-uuid->string))) + +(define* (string->uuid str #:key (type 'dce)) + "Parse STR as a UUID of the given TYPE. On success, return the +corresponding bytevector; otherwise return #f." + (match (vhash-assq type %uuid-parsers) + (#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)))) (define* (canonicalize-device-spec spec #:optional (title 'any)) -- 2.14.1
guix-patches <at> gnu.org
:bug#28377
; Package guix-patches
.
(Wed, 06 Sep 2017 22:19:03 GMT) Full text and rfc822 format available.Message #14 received at 28377 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 28377 <at> debbugs.gnu.org Cc: Danny Milosavljevic <dannym <at> scratchpost.org>, Ludovic Courtès <ludo <at> gnu.org>, Tobias Geerinckx-Rice <me <at> tobias.gr> Subject: [PATCH 03/10] services: base: Import the closure of (gnu build file-systems). Date: Thu, 7 Sep 2017 00:17:49 +0200
* gnu/services/base.scm (file-system-shepherd-service): Use 'source-module-closure' in the 'with-imported-modules' form. --- gnu/services/base.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 5001298ab..23ef2d4bf 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -47,6 +47,7 @@ #:select (mount-flags->bit-mask)) #:use-module (guix gexp) #:use-module (guix records) + #:use-module (guix modules) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (ice-9 match) @@ -286,8 +287,8 @@ FILE-SYSTEM." (dependencies (file-system-dependencies file-system)) (packages (file-system-packages (list file-system)))) (and (file-system-mount? file-system) - (with-imported-modules '((gnu build file-systems) - (guix build bournish)) + (with-imported-modules (source-module-closure + '((gnu build file-systems))) (shepherd-service (provision (list (file-system->shepherd-service-name file-system))) (requirement `(root-file-system -- 2.14.1
guix-patches <at> gnu.org
:bug#28377
; Package guix-patches
.
(Wed, 06 Sep 2017 22:19:03 GMT) Full text and rfc822 format available.Message #17 received at 28377 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 28377 <at> debbugs.gnu.org Cc: Danny Milosavljevic <dannym <at> scratchpost.org>, Ludovic Courtès <ludo <at> gnu.org>, Tobias Geerinckx-Rice <me <at> tobias.gr> Subject: [PATCH 08/10] uuid: 'uuid' macro supports more UUID types. Date: Thu, 7 Sep 2017 00:17:54 +0200
* gnu/system/uuid.scm (string->uuid): Turn 'type' into an optional argument. (uuid): Add clauses to allow for an optional 'type' parameter. --- gnu/system/uuid.scm | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) diff --git a/gnu/system/uuid.scm b/gnu/system/uuid.scm index 60626ebb1..1dd6a1133 100644 --- a/gnu/system/uuid.scm +++ b/gnu/system/uuid.scm @@ -206,7 +206,7 @@ ISO9660 UUID representation." ('iso9660 => iso9660-uuid->string) ('fat32 'fat => fat32-uuid->string))) -(define* (string->uuid str #:key (type 'dce)) +(define* (string->uuid str #:optional (type 'dce)) "Parse STR as a UUID of the given TYPE. On success, return the corresponding bytevector; otherwise return #f." (match (vhash-assq type %uuid-parsers) @@ -233,17 +233,23 @@ corresponding bytevector; otherwise return #f." (define-syntax uuid (lambda (s) "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)) + (syntax-case s (quote) + ((_ str (quote type)) + (and (string? (syntax->datum #'str)) + (identifier? #'type)) ;; A literal string: do the conversion at expansion time. - (let ((bv (string->uuid (syntax->datum #'str)))) + (let ((bv (string->uuid (syntax->datum #'str) + (syntax->datum #'type)))) (unless bv (syntax-violation 'uuid "invalid UUID" s)) - #`(make-uuid 'dce #,(datum->syntax #'str bv)))) + #`(make-uuid 'type #,(datum->syntax s bv)))) ((_ str) - #'(make-uuid 'dce (string->uuid str)))))) + (string? (syntax->datum #'str)) + #'(uuid str 'dce)) + ((_ str) + #'(make-uuid 'dce (string->uuid str 'dce))) + ((_ str type) + #'(make-uuid type (string->uuid str type)))))) (define uuid->string ;; Convert the given bytevector or UUID object, to the corresponding UUID -- 2.14.1
guix-patches <at> gnu.org
:bug#28377
; Package guix-patches
.
(Wed, 06 Sep 2017 22:19:04 GMT) Full text and rfc822 format available.Message #20 received at 28377 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 28377 <at> debbugs.gnu.org Cc: Danny Milosavljevic <dannym <at> scratchpost.org>, Ludovic Courtès <ludo <at> gnu.org>, Tobias Geerinckx-Rice <me <at> tobias.gr> Subject: [PATCH 04/10] file-systems: Introduce (gnu system uuid). Date: Thu, 7 Sep 2017 00:17:50 +0200
* gnu/build/file-systems.scm (sub-bytevector) (latin1->string, %fat32-endianness, fat32-uuid->string) (%iso9660-uuid-rx, string->iso9660-uuid) (iso9660-uuid->string, %network-byte-order) (dce-uuid->string, %uuid-rx, string->dce-uuid) (string->ext2-uuid, string->ext3-uuid, string->ext4-uuid) (vhashq, %uuid-parsers, %uuid-printers, string->uuid) (uuid->string): Move to... * gnu/system/uuid.scm: ... here. New file. * gnu/system/file-systems.scm (uuid): Move to the above file. * gnu/system/vm.scm: Adjust accordingly. * gnu/local.mk (GNU_SYSTEM_MODULES): Add uuid.scm. --- gnu/build/file-systems.scm | 167 +------------------------------- gnu/build/vm.scm | 2 +- gnu/local.mk | 1 + gnu/system/file-systems.scm | 22 +---- gnu/system/uuid.scm | 227 ++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 234 insertions(+), 185 deletions(-) create mode 100644 gnu/system/uuid.scm diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index fbaf15895..32885f1d2 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -19,6 +19,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (gnu build file-systems) + #:use-module (gnu system uuid) #:use-module (guix build utils) #:use-module (guix build bournish) #:use-module (guix build syscalls) @@ -26,9 +27,6 @@ #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) - #:use-module (ice-9 format) - #:use-module (ice-9 regex) - #:use-module (ice-9 vlist) #:use-module (system foreign) #:autoload (system repl repl) (start-repl) #:use-module (srfi srfi-1) @@ -42,17 +40,6 @@ find-partition-by-luks-uuid canonicalize-device-spec - uuid->string - dce-uuid->string - string->uuid - string->dce-uuid - string->iso9660-uuid - string->ext2-uuid - string->ext3-uuid - string->ext4-uuid - string->btrfs-uuid - iso9660-uuid->string - bind-mount mount-flags->bit-mask @@ -98,20 +85,6 @@ takes a bytevector and returns #t when it's a valid superblock." (and (magic? block) block))))))))) -(define (sub-bytevector bv start size) - "Return a copy of the SIZE bytes of BV starting from offset START." - (let ((result (make-bytevector size))) - (bytevector-copy! bv start result 0 size) - result)) - -(define (latin1->string bv terminator) - "Return a string of BV, a latin1 bytevector, or #f. TERMINATOR is a predicate -that takes a number and returns #t when a termination character is found." - (let ((bytes (take-while (negate terminator) (bytevector->u8-list bv)))) - (if (null? bytes) - #f - (list->string (map integer->char bytes))))) - (define null-terminated-latin1->string (cut latin1->string <> zero?)) @@ -199,10 +172,6 @@ if DEVICE does not contain a btrfs file system." ;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-107.pdf>. -(define-syntax %fat32-endianness - ;; Endianness of fat file systems. - (identifier-syntax (endianness little))) - (define (fat32-superblock? sblock) "Return #t when SBLOCK is a fat32 superblock." (bytevector=? (sub-bytevector sblock 82 8) @@ -217,12 +186,6 @@ if DEVICE does not contain a btrfs file system." "Return the Volume ID of a fat superblock SBLOCK as a 4-byte bytevector." (sub-bytevector sblock 67 4)) -(define (fat32-uuid->string uuid) - "Convert fat32 UUID, a 4-byte bytevector, to its string representation." - (let ((high (bytevector-uint-ref uuid 0 %fat32-endianness 2)) - (low (bytevector-uint-ref uuid 2 %fat32-endianness 2))) - (format #f "~:@(~x-~x~)" low high))) - (define (fat32-superblock-volume-name sblock) "Return the volume name of SBLOCK as a string of at most 11 characters, or #f if SBLOCK has no volume name. The volume name is a latin1 string. @@ -244,27 +207,6 @@ Trailing spaces are trimmed." ;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-119.pdf>. -(define %iso9660-uuid-rx - ;; Y m d H M S ss - (make-regexp "^([[:digit:]]{4})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})$")) - -(define (string->iso9660-uuid str) - "Parse STR as a ISO9660 UUID (which is really a timestamp - see /dev/disk/by-uuid). -Return its contents as a 16-byte bytevector. Return #f if STR is not a valid -ISO9660 UUID representation." - (and=> (regexp-exec %iso9660-uuid-rx str) - (lambda (match) - (letrec-syntax ((match-numerals - (syntax-rules () - ((_ index (name rest ...) body) - (let ((name (match:substring match index))) - (match-numerals (+ 1 index) (rest ...) body))) - ((_ index () body) - body)))) - (match-numerals 1 (year month day hour minute second hundredths) - (string->utf8 (string-append year month day - hour minute second hundredths))))))) - (define (iso9660-superblock? sblock) "Return #t when SBLOCK is an iso9660 volume descriptor." (bytevector=? (sub-bytevector sblock 1 6) @@ -311,20 +253,6 @@ SBLOCK as a bytevector. If that's not set, returns the creation time." modification-time))) (sub-bytevector time 0 16))) ; strips GMT offset. -(define (iso9660-uuid->string uuid) - "Given an UUID bytevector, return its timestamp string." - (define (digits->string bytes) - (latin1->string bytes (lambda (c) #f))) - (let* ((year (sub-bytevector uuid 0 4)) - (month (sub-bytevector uuid 4 2)) - (day (sub-bytevector uuid 6 2)) - (hour (sub-bytevector uuid 8 2)) - (minute (sub-bytevector uuid 10 2)) - (second (sub-bytevector uuid 12 2)) - (hundredths (sub-bytevector uuid 14 2)) - (parts (list year month day hour minute second hundredths))) - (string-append (string-join (map digits->string parts) "-")))) - (define (iso9660-superblock-volume-name sblock) "Return the volume name of SBLOCK as a string. The volume name is an ASCII string. Trailing spaces are trimmed." @@ -512,99 +440,6 @@ were found." (find-partition luks-partition-uuid-predicate)) -;;; -;;; UUIDs. -;;; - -(define-syntax %network-byte-order - (identifier-syntax (endianness big))) - -(define (dce-uuid->string uuid) - "Convert UUID, a 16-byte bytevector, to its string representation, something -like \"6b700d61-5550-48a1-874c-a3d86998990e\"." - ;; See <https://tools.ietf.org/html/rfc4122>. - (let ((time-low (bytevector-uint-ref uuid 0 %network-byte-order 4)) - (time-mid (bytevector-uint-ref uuid 4 %network-byte-order 2)) - (time-hi (bytevector-uint-ref uuid 6 %network-byte-order 2)) - (clock-seq (bytevector-uint-ref uuid 8 %network-byte-order 2)) - (node (bytevector-uint-ref uuid 10 %network-byte-order 6))) - (format #f "~8,'0x-~4,'0x-~4,'0x-~4,'0x-~12,'0x" - time-low time-mid time-hi clock-seq node))) - -(define %uuid-rx - ;; The regexp of a UUID. - (make-regexp "^([[:xdigit:]]{8})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{12})$")) - -(define (string->dce-uuid str) - "Parse STR as a DCE UUID (see <https://tools.ietf.org/html/rfc4122>) and -return its contents as a 16-byte bytevector. Return #f if STR is not a valid -UUID representation." - (and=> (regexp-exec %uuid-rx str) - (lambda (match) - (letrec-syntax ((hex->number - (syntax-rules () - ((_ index) - (string->number (match:substring match index) - 16)))) - (put! - (syntax-rules () - ((_ bv index (number len) rest ...) - (begin - (bytevector-uint-set! bv index number - (endianness big) len) - (put! bv (+ index len) rest ...))) - ((_ bv index) - bv)))) - (let ((time-low (hex->number 1)) - (time-mid (hex->number 2)) - (time-hi (hex->number 3)) - (clock-seq (hex->number 4)) - (node (hex->number 5)) - (uuid (make-bytevector 16))) - (put! uuid 0 - (time-low 4) (time-mid 2) (time-hi 2) - (clock-seq 2) (node 6))))))) - -(define string->ext2-uuid string->dce-uuid) -(define string->ext3-uuid string->dce-uuid) -(define string->ext4-uuid string->dce-uuid) -(define string->btrfs-uuid string->dce-uuid) - -(define-syntax vhashq - (syntax-rules (=>) - ((_) - vlist-null) - ((_ (key others ... => value) rest ...) - (vhash-consq key value - (vhashq (others ... => value) rest ...))) - ((_ (=> value) rest ...) - (vhashq rest ...)))) - -(define %uuid-parsers - (vhashq - ('dce 'ext2 'ext3 'ext4 'btrfs 'luks => string->dce-uuid) - ('iso9660 => string->iso9660-uuid))) - -(define %uuid-printers - (vhashq - ('dce 'ext2 'ext3 'ext4 'btrfs 'luks => dce-uuid->string) - ('iso9660 => iso9660-uuid->string) - ('fat32 'fat => fat32-uuid->string))) - -(define* (string->uuid str #:key (type 'dce)) - "Parse STR as a UUID of the given TYPE. On success, return the -corresponding bytevector; otherwise return #f." - (match (vhash-assq type %uuid-parsers) - (#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)))) - - (define* (canonicalize-device-spec spec #:optional (title 'any)) "Return the device name corresponding to SPEC. TITLE is a symbol, one of the following: diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm index 8dfaf2789..4298eebd7 100644 --- a/gnu/build/vm.scm +++ b/gnu/build/vm.scm @@ -26,7 +26,7 @@ #:use-module (guix build syscalls) #:use-module (gnu build linux-boot) #:use-module (gnu build install) - #:use-module (gnu build file-systems) + #:use-module (gnu system uuid) #:use-module (guix records) #:use-module ((guix combinators) #:select (fold2)) #:use-module (ice-9 format) diff --git a/gnu/local.mk b/gnu/local.mk index 643a88db8..6d75ba319 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -468,6 +468,7 @@ GNU_SYSTEM_MODULES = \ %D%/system/nss.scm \ %D%/system/pam.scm \ %D%/system/shadow.scm \ + %D%/system/uuid.scm \ %D%/system/vm.scm \ \ %D%/build/activation.scm \ diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index bbac23fbd..dd30559d7 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -20,9 +20,10 @@ #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (guix records) - #:use-module ((gnu build file-systems) - #:select (string->uuid uuid->string)) - #:re-export (string->uuid + #:use-module ((gnu system uuid) + #:select (uuid string->uuid uuid->string)) + #:re-export (uuid ;backward compatibility + string->uuid uuid->string) #:export (<file-system> file-system @@ -44,7 +45,6 @@ file-system->spec spec->file-system specification->file-system-mapping - uuid %fuse-control-file-system %binary-format-file-system @@ -186,20 +186,6 @@ TARGET in the other system." (target spec) (writable? writable?))))) -(define-syntax uuid - (lambda (s) - "Return the bytevector corresponding to the given UUID representation." - (syntax-case s () - ((_ str) - (string? (syntax->datum #'str)) - ;; A literal string: do the conversion at expansion time. - (let ((bv (string->uuid (syntax->datum #'str)))) - (unless bv - (syntax-violation 'uuid "invalid UUID" s)) - (datum->syntax #'str bv))) - ((_ str) - #'(string->uuid str))))) - ;;; ;;; Common file systems. diff --git a/gnu/system/uuid.scm b/gnu/system/uuid.scm new file mode 100644 index 000000000..64dad5a37 --- /dev/null +++ b/gnu/system/uuid.scm @@ -0,0 +1,227 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016, 2017 Ludovic Courtès <ludo <at> gnu.org> +;;; Copyright © 2017 Danny Milosavljevic <dannym <at> scratchpost.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (gnu system uuid) + #:use-module (srfi srfi-1) + #: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->string + dce-uuid->string + string->uuid + string->dce-uuid + string->iso9660-uuid + string->ext2-uuid + string->ext3-uuid + string->ext4-uuid + string->btrfs-uuid + iso9660-uuid->string + + ;; XXX: For lack of a better place. + sub-bytevector + latin1->string)) + + +;;; +;;; Tools that lack a better place. +;;; + +(define (sub-bytevector bv start size) + "Return a copy of the SIZE bytes of BV starting from offset START." + (let ((result (make-bytevector size))) + (bytevector-copy! bv start result 0 size) + result)) + +(define (latin1->string bv terminator) + "Return a string of BV, a latin1 bytevector, or #f. TERMINATOR is a predicate +that takes a number and returns #t when a termination character is found." + (let ((bytes (take-while (negate terminator) (bytevector->u8-list bv)))) + (if (null? bytes) + #f + (list->string (map integer->char bytes))))) + + +;;; +;;; DCE UUIDs. +;;; + +(define-syntax %network-byte-order + (identifier-syntax (endianness big))) + +(define (dce-uuid->string uuid) + "Convert UUID, a 16-byte bytevector, to its string representation, something +like \"6b700d61-5550-48a1-874c-a3d86998990e\"." + ;; See <https://tools.ietf.org/html/rfc4122>. + (let ((time-low (bytevector-uint-ref uuid 0 %network-byte-order 4)) + (time-mid (bytevector-uint-ref uuid 4 %network-byte-order 2)) + (time-hi (bytevector-uint-ref uuid 6 %network-byte-order 2)) + (clock-seq (bytevector-uint-ref uuid 8 %network-byte-order 2)) + (node (bytevector-uint-ref uuid 10 %network-byte-order 6))) + (format #f "~8,'0x-~4,'0x-~4,'0x-~4,'0x-~12,'0x" + time-low time-mid time-hi clock-seq node))) + +(define %uuid-rx + ;; The regexp of a UUID. + (make-regexp "^([[:xdigit:]]{8})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{12})$")) + +(define (string->dce-uuid str) + "Parse STR as a DCE UUID (see <https://tools.ietf.org/html/rfc4122>) and +return its contents as a 16-byte bytevector. Return #f if STR is not a valid +UUID representation." + (and=> (regexp-exec %uuid-rx str) + (lambda (match) + (letrec-syntax ((hex->number + (syntax-rules () + ((_ index) + (string->number (match:substring match index) + 16)))) + (put! + (syntax-rules () + ((_ bv index (number len) rest ...) + (begin + (bytevector-uint-set! bv index number + (endianness big) len) + (put! bv (+ index len) rest ...))) + ((_ bv index) + bv)))) + (let ((time-low (hex->number 1)) + (time-mid (hex->number 2)) + (time-hi (hex->number 3)) + (clock-seq (hex->number 4)) + (node (hex->number 5)) + (uuid (make-bytevector 16))) + (put! uuid 0 + (time-low 4) (time-mid 2) (time-hi 2) + (clock-seq 2) (node 6))))))) + + +;;; +;;; ISO-9660. +;;; + +;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-119.pdf>. + +(define %iso9660-uuid-rx + ;; Y m d H M S ss + (make-regexp "^([[:digit:]]{4})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})$")) +(define (string->iso9660-uuid str) + "Parse STR as a ISO9660 UUID (which is really a timestamp - see /dev/disk/by-uuid). +Return its contents as a 16-byte bytevector. Return #f if STR is not a valid +ISO9660 UUID representation." + (and=> (regexp-exec %iso9660-uuid-rx str) + (lambda (match) + (letrec-syntax ((match-numerals + (syntax-rules () + ((_ index (name rest ...) body) + (let ((name (match:substring match index))) + (match-numerals (+ 1 index) (rest ...) body))) + ((_ index () body) + body)))) + (match-numerals 1 (year month day hour minute second hundredths) + (string->utf8 (string-append year month day + hour minute second hundredths))))))) +(define (iso9660-uuid->string uuid) + "Given an UUID bytevector, return its timestamp string." + (define (digits->string bytes) + (latin1->string bytes (lambda (c) #f))) + (let* ((year (sub-bytevector uuid 0 4)) + (month (sub-bytevector uuid 4 2)) + (day (sub-bytevector uuid 6 2)) + (hour (sub-bytevector uuid 8 2)) + (minute (sub-bytevector uuid 10 2)) + (second (sub-bytevector uuid 12 2)) + (hundredths (sub-bytevector uuid 14 2)) + (parts (list year month day hour minute second hundredths))) + (string-append (string-join (map digits->string parts) "-")))) + + +;;; +;;; FAT32. +;;; + +(define-syntax %fat32-endianness + ;; Endianness of FAT file systems. + (identifier-syntax (endianness little))) + +(define (fat32-uuid->string uuid) + "Convert fat32 UUID, a 4-byte bytevector, to its string representation." + (let ((high (bytevector-uint-ref uuid 0 %fat32-endianness 2)) + (low (bytevector-uint-ref uuid 2 %fat32-endianness 2))) + (format #f "~:@(~x-~x~)" low high))) + + +;;; +;;; Generic interface. +;;; + +(define string->ext2-uuid string->dce-uuid) +(define string->ext3-uuid string->dce-uuid) +(define string->ext4-uuid string->dce-uuid) +(define string->btrfs-uuid string->dce-uuid) + +(define-syntax vhashq + (syntax-rules (=>) + ((_) + vlist-null) + ((_ (key others ... => value) rest ...) + (vhash-consq key value + (vhashq (others ... => value) rest ...))) + ((_ (=> value) rest ...) + (vhashq rest ...)))) + +(define %uuid-parsers + (vhashq + ('dce 'ext2 'ext3 'ext4 'btrfs 'luks => string->dce-uuid) + ('iso9660 => string->iso9660-uuid))) + +(define %uuid-printers + (vhashq + ('dce 'ext2 'ext3 'ext4 'btrfs 'luks => dce-uuid->string) + ('iso9660 => iso9660-uuid->string) + ('fat32 'fat => fat32-uuid->string))) + +(define* (string->uuid str #:key (type 'dce)) + "Parse STR as a UUID of the given TYPE. On success, return the +corresponding bytevector; otherwise return #f." + (match (vhash-assq type %uuid-parsers) + (#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)))) + +(define-syntax uuid + (lambda (s) + "Return the bytevector corresponding to the given UUID representation." + (syntax-case s () + ((_ str) + (string? (syntax->datum #'str)) + ;; A literal string: do the conversion at expansion time. + (let ((bv (string->uuid (syntax->datum #'str)))) + (unless bv + (syntax-violation 'uuid "invalid UUID" s)) + (datum->syntax #'str bv))) + ((_ str) + #'(string->uuid str))))) -- 2.14.1
guix-patches <at> gnu.org
:bug#28377
; Package guix-patches
.
(Wed, 06 Sep 2017 22:19:04 GMT) Full text and rfc822 format available.Message #23 received at 28377 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 28377 <at> debbugs.gnu.org Cc: Danny Milosavljevic <dannym <at> scratchpost.org>, Ludovic Courtès <ludo <at> gnu.org>, Tobias Geerinckx-Rice <me <at> tobias.gr> Subject: [PATCH 05/10] services: file-system: Use 'file-system->spec'. Date: Thu, 7 Sep 2017 00:17:51 +0200
* gnu/services/base.scm (file-system-shepherd-service): Use 'file-system->spec' instead of in-line code. --- gnu/services/base.scm | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 23ef2d4bf..b8feb725d 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -29,6 +29,7 @@ #:use-module (gnu services networking) #:use-module (gnu system pam) #:use-module (gnu system shadow) ; 'user-account', etc. + #:use-module (gnu system uuid) #:use-module (gnu system file-systems) ; 'file-system', etc. #:use-module (gnu system mapped-devices) #:use-module ((gnu system linux-initrd) @@ -277,12 +278,6 @@ FILE-SYSTEM." "Return the shepherd service for @var{file-system}, or @code{#f} if @var{file-system} is not auto-mounted upon boot." (let ((target (file-system-mount-point file-system)) - (device (file-system-device file-system)) - (type (file-system-type file-system)) - (title (file-system-title file-system)) - (flags (file-system-flags file-system)) - (options (file-system-options file-system)) - (check? (file-system-check? file-system)) (create? (file-system-create-mount-point? file-system)) (dependencies (file-system-dependencies file-system)) (packages (file-system-packages (list file-system)))) @@ -311,8 +306,7 @@ FILE-SYSTEM." '#$packages)))) (lambda () (mount-file-system - `(#$device #$title #$target #$type #$flags - #$options #$check?) + '#$(file-system->spec file-system) #:root "/")) (lambda () (setenv "PATH" $PATH))) -- 2.14.1
guix-patches <at> gnu.org
:bug#28377
; Package guix-patches
.
(Wed, 06 Sep 2017 22:19:04 GMT) Full text and rfc822 format available.Message #26 received at 28377 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 28377 <at> debbugs.gnu.org Cc: Danny Milosavljevic <dannym <at> scratchpost.org>, Ludovic Courtès <ludo <at> gnu.org>, Tobias Geerinckx-Rice <me <at> tobias.gr> Subject: [PATCH 09/10] vm: Allow users to specify a UUID for the root partition. Date: Thu, 7 Sep 2017 00:17:55 +0200
* 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(-) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 1807946cb..73d830bf0 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -240,6 +240,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 @@ -249,7 +250,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, is 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.) @@ -299,6 +303,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)) -- 2.14.1
guix-patches <at> gnu.org
:bug#28377
; Package guix-patches
.
(Wed, 06 Sep 2017 22:19:05 GMT) Full text and rfc822 format available.Message #29 received at 28377 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 28377 <at> debbugs.gnu.org Cc: Danny Milosavljevic <dannym <at> scratchpost.org>, Ludovic Courtès <ludo <at> gnu.org>, Tobias Geerinckx-Rice <me <at> tobias.gr> Subject: [PATCH 10/10] vm: Generate a UUID to identify the root file system. Date: Thu, 7 Sep 2017 00:17:56 +0200
This makes collisions less likely than when using a label to look up the partition. See <https://bugs.gnu.org/27735>. * 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(-) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 73d830bf0..d947fd605 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 @@ -342,6 +343,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") @@ -358,12 +388,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) "/")) @@ -387,8 +425,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))))) @@ -397,7 +435,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 #:bootcfg-drv bootcfg #:bootloader (bootloader-configuration-bootloader @@ -413,6 +451,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) -- 2.14.1
guix-patches <at> gnu.org
:bug#28377
; Package guix-patches
.
(Wed, 06 Sep 2017 22:19:05 GMT) Full text and rfc822 format available.Message #32 received at 28377 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 28377 <at> debbugs.gnu.org Cc: Danny Milosavljevic <dannym <at> scratchpost.org>, Ludovic Courtès <ludo <at> gnu.org>, Tobias Geerinckx-Rice <me <at> tobias.gr> Subject: [PATCH 06/10] system: Introduce a disjoint UUID type. Date: Thu, 7 Sep 2017 00:17:52 +0200
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 <uuid> 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 (<uuid>): 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(-) diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm index a9f0875f3..96e53c5c2 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 6b35e3c0c..a8d2a8131 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 dd30559d7..52f16676f 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 18b9f5b4b..17cf6b716 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 <at> gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo <at> gnu.org> ;;; Copyright © 2016 Andreas Enge <andreas <at> enge.fr> ;;; Copyright © 2017 Mark H Weaver <mhw <at> 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 64dad5a37..60626ebb1 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 b3da11876..1807946cb 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) @@ -223,7 +224,8 @@ INPUTS is a list of inputs (as for packages)." #$os-drv "/xchg/guixsd.iso" #: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 -- 2.14.1
guix-patches <at> gnu.org
:bug#28377
; Package guix-patches
.
(Wed, 06 Sep 2017 22:19:06 GMT) Full text and rfc822 format available.Message #35 received at 28377 <at> debbugs.gnu.org (full text, mbox):
From: Ludovic Courtès <ludo <at> gnu.org> To: 28377 <at> debbugs.gnu.org Cc: Danny Milosavljevic <dannym <at> scratchpost.org>, Ludovic Courtès <ludo <at> gnu.org>, Tobias Geerinckx-Rice <me <at> tobias.gr> Subject: [PATCH 07/10] system: Serialize the UUID type in the "parameters" file. Date: Thu, 7 Sep 2017 00:17:53 +0200
* gnu/system.scm (read-boot-parameters)[device->sexp]: New procedure. Use it for 'root-device' and 'store-device'. (device->sexp): Serialize the UUID type in addition to its bytevector. --- gnu/system.scm | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/gnu/system.scm b/gnu/system.scm index a8d2a8131..6f795d629 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -234,6 +234,15 @@ directly by the user." (define (read-boot-parameters port) "Read boot parameters from PORT and return the corresponding <boot-parameters> object or #f if the format is unrecognized." + (define device-sexp->device + (match-lambda + (('uuid (? symbol? type) (? bytevector? bv)) + (bytevector->uuid bv type)) + ((? bytevector? bv) ;old format + (bytevector->uuid bv 'dce)) + ((? string? device) + device))) + (match (read port) (('boot-parameters ('version 0) ('label label) ('root-device root) @@ -241,7 +250,7 @@ directly by the user." rest ...) (boot-parameters (label label) - (root-device root) + (root-device (device->sexp root)) (bootloader-name (match (assq 'bootloader-name rest) @@ -269,10 +278,8 @@ directly by the user." (store-device (match (assq 'store rest) - (('store ('device (? bytevector? bv)) _ ...) - (bytevector->uuid bv)) (('store ('device device) _ ...) - device) + (device-sexp->device device)) (_ ;the old format ;; Root might be a device path like "/dev/sda1", which is not a ;; suitable GRUB device identifier. @@ -925,8 +932,7 @@ kernel arguments for that derivation to <boot-parameters>." "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)) + `(uuid ,(uuid-type uuid) ,(uuid-bytevector uuid))) (_ device))) -- 2.14.1
guix-patches <at> gnu.org
:bug#28377
; Package guix-patches
.
(Mon, 11 Sep 2017 15:52:02 GMT) Full text and rfc822 format available.Message #38 received at 28377 <at> debbugs.gnu.org (full text, mbox):
From: Danny Milosavljevic <dannym <at> scratchpost.org> To: Ludovic Courtès <ludo <at> gnu.org> Cc: Tobias Geerinckx-Rice <me <at> tobias.gr>, 28377 <at> debbugs.gnu.org Subject: Re: [PATCH 02/10] file-systems: Add UUID type dictionaries. Date: Mon, 11 Sep 2017 17:50:52 +0200
> +(define %uuid-parsers > + (vhashq > + ('dce 'ext2 'ext3 'ext4 'btrfs 'luks => string->dce-uuid) > + ('iso9660 => string->iso9660-uuid))) No fat32? Otherwise LGTM!
guix-patches <at> gnu.org
:bug#28377
; Package guix-patches
.
(Mon, 11 Sep 2017 15:53:02 GMT) Full text and rfc822 format available.Message #41 received at 28377 <at> debbugs.gnu.org (full text, mbox):
From: Danny Milosavljevic <dannym <at> scratchpost.org> To: Ludovic Courtès <ludo <at> gnu.org> Cc: Tobias Geerinckx-Rice <me <at> tobias.gr>, 28377 <at> debbugs.gnu.org Subject: Re: [PATCH 03/10] services: base: Import the closure of (gnu build file-systems). Date: Mon, 11 Sep 2017 17:52:20 +0200
LGTM!
guix-patches <at> gnu.org
:bug#28377
; Package guix-patches
.
(Mon, 11 Sep 2017 15:55:01 GMT) Full text and rfc822 format available.Message #44 received at 28377 <at> debbugs.gnu.org (full text, mbox):
From: Danny Milosavljevic <dannym <at> scratchpost.org> To: Ludovic Courtès <ludo <at> gnu.org> Cc: Tobias Geerinckx-Rice <me <at> tobias.gr>, 28377 <at> debbugs.gnu.org Subject: Re: [PATCH 04/10] file-systems: Introduce (gnu system uuid). Date: Mon, 11 Sep 2017 17:54:23 +0200
LGTM!
guix-patches <at> gnu.org
:bug#28377
; Package guix-patches
.
(Mon, 11 Sep 2017 15:56:02 GMT) Full text and rfc822 format available.Message #47 received at 28377 <at> debbugs.gnu.org (full text, mbox):
From: Danny Milosavljevic <dannym <at> scratchpost.org> To: Ludovic Courtès <ludo <at> gnu.org> Cc: Tobias Geerinckx-Rice <me <at> tobias.gr>, 28377 <at> debbugs.gnu.org Subject: Re: [PATCH 05/10] services: file-system: Use 'file-system->spec'. Date: Mon, 11 Sep 2017 17:55:37 +0200
LGTM!
guix-patches <at> gnu.org
:bug#28377
; Package guix-patches
.
(Mon, 11 Sep 2017 16:02:02 GMT) Full text and rfc822 format available.Message #50 received at 28377 <at> debbugs.gnu.org (full text, mbox):
From: Danny Milosavljevic <dannym <at> scratchpost.org> To: Ludovic Courtès <ludo <at> gnu.org> Cc: Tobias Geerinckx-Rice <me <at> tobias.gr>, 28377 <at> debbugs.gnu.org Subject: Re: [PATCH 06/10] system: Introduce a disjoint UUID type. Date: Mon, 11 Sep 2017 18:01:12 +0200
> +(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. Yes :) Otherwise LGTM!
guix-patches <at> gnu.org
:bug#28377
; Package guix-patches
.
(Mon, 11 Sep 2017 16:03:02 GMT) Full text and rfc822 format available.Message #53 received at 28377 <at> debbugs.gnu.org (full text, mbox):
From: Danny Milosavljevic <dannym <at> scratchpost.org> To: Ludovic Courtès <ludo <at> gnu.org> Cc: Tobias Geerinckx-Rice <me <at> tobias.gr>, 28377 <at> debbugs.gnu.org Subject: Re: [PATCH 07/10] system: Serialize the UUID type in the "parameters" file. Date: Mon, 11 Sep 2017 18:02:03 +0200
> - ;; TODO: Preserve the type of UUID. > - (uuid-bytevector uuid)) > + `(uuid ,(uuid-type uuid) ,(uuid-bytevector uuid))) Ah okay. LGTM!
guix-patches <at> gnu.org
:bug#28377
; Package guix-patches
.
(Mon, 11 Sep 2017 16:05:02 GMT) Full text and rfc822 format available.Message #56 received at 28377 <at> debbugs.gnu.org (full text, mbox):
From: ludo <at> gnu.org (Ludovic Courtès) To: Danny Milosavljevic <dannym <at> scratchpost.org> Cc: Tobias Geerinckx-Rice <me <at> tobias.gr>, 28377 <at> debbugs.gnu.org Subject: Re: [PATCH 02/10] file-systems: Add UUID type dictionaries. Date: Mon, 11 Sep 2017 18:04:18 +0200
Hi Danny, Danny Milosavljevic <dannym <at> scratchpost.org> skribis: >> +(define %uuid-parsers >> + (vhashq >> + ('dce 'ext2 'ext3 'ext4 'btrfs 'luks => string->dce-uuid) >> + ('iso9660 => string->iso9660-uuid))) > > No fat32? Yes, because we don’t have a FAT32 parser currently, only a printer (‘fat32-uuid->string’). > Otherwise LGTM! Thanks for reviewing this! Ludo’.
guix-patches <at> gnu.org
:bug#28377
; Package guix-patches
.
(Mon, 11 Sep 2017 16:11:02 GMT) Full text and rfc822 format available.Message #59 received at 28377 <at> debbugs.gnu.org (full text, mbox):
From: Danny Milosavljevic <dannym <at> scratchpost.org> To: Ludovic Courtès <ludo <at> gnu.org> Cc: Tobias Geerinckx-Rice <me <at> tobias.gr>, 28377 <at> debbugs.gnu.org Subject: Re: [PATCH 09/10] vm: Allow users to specify a UUID for the root partition. Date: Mon, 11 Sep 2017 18:10:45 +0200
On Thu, 7 Sep 2017 00:17:55 +0200 Ludovic Courtès <ludo <at> gnu.org> wrote: > +partition; likewise FILE-SYSTEM-UUID, if true, is the UUID of the root ^^^ ?? ^^^^^^ which is it? Probably meant "not #f". Otherwise LGTM!
guix-patches <at> gnu.org
:bug#28377
; Package guix-patches
.
(Mon, 11 Sep 2017 16:51:02 GMT) Full text and rfc822 format available.Message #62 received at 28377 <at> debbugs.gnu.org (full text, mbox):
From: Danny Milosavljevic <dannym <at> scratchpost.org> To: Ludovic Courtès <ludo <at> gnu.org> Cc: Tobias Geerinckx-Rice <me <at> tobias.gr>, 28377 <at> debbugs.gnu.org Subject: Re: [PATCH 10/10] vm: Generate a UUID to identify the root file system. Date: Mon, 11 Sep 2017 18:50:07 +0200
LGTM!
ludo <at> gnu.org (Ludovic Courtès)
:Ludovic Courtès <ludo <at> gnu.org>
:Message #67 received at 28377-done <at> debbugs.gnu.org (full text, mbox):
From: ludo <at> gnu.org (Ludovic Courtès) To: Danny Milosavljevic <dannym <at> scratchpost.org> Cc: Tobias Geerinckx-Rice <me <at> tobias.gr>, 28377-done <at> debbugs.gnu.org Subject: Re: [PATCH 09/10] vm: Allow users to specify a UUID for the root partition. Date: Mon, 11 Sep 2017 22:53:04 +0200
Danny Milosavljevic <dannym <at> scratchpost.org> skribis: > On Thu, 7 Sep 2017 00:17:55 +0200 > Ludovic Courtès <ludo <at> gnu.org> wrote: > >> +partition; likewise FILE-SYSTEM-UUID, if true, is the UUID of the root > > ^^^ ?? ^^^^^^ which is it? > > Probably meant "not #f". Yes. In Scheme only #f is false; any other value is true. I’ve replaced “is the UUID…” by “specifies the UUID…”, which is hopefully clearer. I’ve now pushed the whole series. Thanks for reviewing! Ludo’.
Debbugs Internal Request <help-debbugs <at> gnu.org>
to internal_control <at> debbugs.gnu.org
.
(Tue, 10 Oct 2017 11:24:04 GMT) Full text and rfc822 format available.
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.