* [bug#28377] [PATCH 02/10] file-systems: Add UUID type dictionaries.
2017-09-06 22:17 ` [bug#28377] [PATCH 01/10] vm: Allow partitions to be initialized with a given UUID Ludovic Courtès
@ 2017-09-06 22:17 ` Ludovic Courtès
2017-09-11 15:50 ` Danny Milosavljevic
2017-09-06 22:17 ` [bug#28377] [PATCH 03/10] services: base: Import the closure of (gnu build file-systems) Ludovic Courtès
` (7 subsequent siblings)
8 siblings, 1 reply; 21+ messages in thread
From: Ludovic Courtès @ 2017-09-06 22:17 UTC (permalink / raw)
To: 28377
* 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))))
\f
(define* (canonicalize-device-spec spec #:optional (title 'any))
--
2.14.1
^ permalink raw reply related [flat|nested] 21+ messages in thread* [bug#28377] [PATCH 03/10] services: base: Import the closure of (gnu build file-systems).
2017-09-06 22:17 ` [bug#28377] [PATCH 01/10] vm: Allow partitions to be initialized with a given UUID Ludovic Courtès
2017-09-06 22:17 ` [bug#28377] [PATCH 02/10] file-systems: Add UUID type dictionaries Ludovic Courtès
@ 2017-09-06 22:17 ` Ludovic Courtès
2017-09-11 15:52 ` Danny Milosavljevic
2017-09-06 22:17 ` [bug#28377] [PATCH 04/10] file-systems: Introduce (gnu system uuid) Ludovic Courtès
` (6 subsequent siblings)
8 siblings, 1 reply; 21+ messages in thread
From: Ludovic Courtès @ 2017-09-06 22:17 UTC (permalink / raw)
To: 28377
* 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
^ permalink raw reply related [flat|nested] 21+ messages in thread* [bug#28377] [PATCH 04/10] file-systems: Introduce (gnu system uuid).
2017-09-06 22:17 ` [bug#28377] [PATCH 01/10] vm: Allow partitions to be initialized with a given UUID Ludovic Courtès
2017-09-06 22:17 ` [bug#28377] [PATCH 02/10] file-systems: Add UUID type dictionaries Ludovic Courtès
2017-09-06 22:17 ` [bug#28377] [PATCH 03/10] services: base: Import the closure of (gnu build file-systems) Ludovic Courtès
@ 2017-09-06 22:17 ` Ludovic Courtès
2017-09-11 15:54 ` Danny Milosavljevic
2017-09-06 22:17 ` [bug#28377] [PATCH 05/10] services: file-system: Use 'file-system->spec' Ludovic Courtès
` (5 subsequent siblings)
8 siblings, 1 reply; 21+ messages in thread
From: Ludovic Courtès @ 2017-09-06 22:17 UTC (permalink / raw)
To: 28377
* 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))
\f
-;;;
-;;; 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))))
-
-\f
(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)))))
-
\f
;;;
;;; 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@gnu.org>
+;;; Copyright © 2017 Danny Milosavljevic <dannym@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))
+
+\f
+;;;
+;;; 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)))))
+
+\f
+;;;
+;;; 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)))))))
+
+\f
+;;;
+;;; 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) "-"))))
+
+\f
+;;;
+;;; 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)))
+
+\f
+;;;
+;;; 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
^ permalink raw reply related [flat|nested] 21+ messages in thread* [bug#28377] [PATCH 05/10] services: file-system: Use 'file-system->spec'.
2017-09-06 22:17 ` [bug#28377] [PATCH 01/10] vm: Allow partitions to be initialized with a given UUID Ludovic Courtès
` (2 preceding siblings ...)
2017-09-06 22:17 ` [bug#28377] [PATCH 04/10] file-systems: Introduce (gnu system uuid) Ludovic Courtès
@ 2017-09-06 22:17 ` Ludovic Courtès
2017-09-11 15:55 ` Danny Milosavljevic
2017-09-06 22:17 ` [bug#28377] [PATCH 06/10] system: Introduce a disjoint UUID type Ludovic Courtès
` (4 subsequent siblings)
8 siblings, 1 reply; 21+ messages in thread
From: Ludovic Courtès @ 2017-09-06 22:17 UTC (permalink / raw)
To: 28377
* 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
^ permalink raw reply related [flat|nested] 21+ messages in thread* [bug#28377] [PATCH 06/10] system: Introduce a disjoint UUID type.
2017-09-06 22:17 ` [bug#28377] [PATCH 01/10] vm: Allow partitions to be initialized with a given UUID Ludovic Courtès
` (3 preceding siblings ...)
2017-09-06 22:17 ` [bug#28377] [PATCH 05/10] services: file-system: Use 'file-system->spec' Ludovic Courtès
@ 2017-09-06 22:17 ` Ludovic Courtès
2017-09-11 16:01 ` Danny Milosavljevic
2017-09-06 22:17 ` [bug#28377] [PATCH 07/10] system: Serialize the UUID type in the "parameters" file Ludovic Courtès
` (3 subsequent siblings)
8 siblings, 1 reply; 21+ messages in thread
From: Ludovic Courtès @ 2017-09-06 22:17 UTC (permalink / raw)
To: 28377
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@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 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
^ permalink raw reply related [flat|nested] 21+ messages in thread* [bug#28377] [PATCH 07/10] system: Serialize the UUID type in the "parameters" file.
2017-09-06 22:17 ` [bug#28377] [PATCH 01/10] vm: Allow partitions to be initialized with a given UUID Ludovic Courtès
` (4 preceding siblings ...)
2017-09-06 22:17 ` [bug#28377] [PATCH 06/10] system: Introduce a disjoint UUID type Ludovic Courtès
@ 2017-09-06 22:17 ` Ludovic Courtès
2017-09-11 16:02 ` Danny Milosavljevic
2017-09-06 22:17 ` [bug#28377] [PATCH 08/10] uuid: 'uuid' macro supports more UUID types Ludovic Courtès
` (2 subsequent siblings)
8 siblings, 1 reply; 21+ messages in thread
From: Ludovic Courtès @ 2017-09-06 22:17 UTC (permalink / raw)
To: 28377
* 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
^ permalink raw reply related [flat|nested] 21+ messages in thread* [bug#28377] [PATCH 08/10] uuid: 'uuid' macro supports more UUID types.
2017-09-06 22:17 ` [bug#28377] [PATCH 01/10] vm: Allow partitions to be initialized with a given UUID Ludovic Courtès
` (5 preceding siblings ...)
2017-09-06 22:17 ` [bug#28377] [PATCH 07/10] system: Serialize the UUID type in the "parameters" file Ludovic Courtès
@ 2017-09-06 22:17 ` Ludovic Courtès
2017-09-06 22:17 ` [bug#28377] [PATCH 09/10] vm: Allow users to specify a UUID for the root partition Ludovic Courtès
2017-09-06 22:17 ` [bug#28377] [PATCH 10/10] vm: Generate a UUID to identify the root file system Ludovic Courtès
8 siblings, 0 replies; 21+ messages in thread
From: Ludovic Courtès @ 2017-09-06 22:17 UTC (permalink / raw)
To: 28377
* 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
^ permalink raw reply related [flat|nested] 21+ messages in thread* [bug#28377] [PATCH 09/10] vm: Allow users to specify a UUID for the root partition.
2017-09-06 22:17 ` [bug#28377] [PATCH 01/10] vm: Allow partitions to be initialized with a given UUID Ludovic Courtès
` (6 preceding siblings ...)
2017-09-06 22:17 ` [bug#28377] [PATCH 08/10] uuid: 'uuid' macro supports more UUID types Ludovic Courtès
@ 2017-09-06 22:17 ` Ludovic Courtès
2017-09-11 16:10 ` Danny Milosavljevic
2017-09-06 22:17 ` [bug#28377] [PATCH 10/10] vm: Generate a UUID to identify the root file system Ludovic Courtès
8 siblings, 1 reply; 21+ messages in thread
From: Ludovic Courtès @ 2017-09-06 22:17 UTC (permalink / raw)
To: 28377
* 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
^ permalink raw reply related [flat|nested] 21+ messages in thread* [bug#28377] [PATCH 10/10] vm: Generate a UUID to identify the root file system.
2017-09-06 22:17 ` [bug#28377] [PATCH 01/10] vm: Allow partitions to be initialized with a given UUID Ludovic Courtès
` (7 preceding siblings ...)
2017-09-06 22:17 ` [bug#28377] [PATCH 09/10] vm: Allow users to specify a UUID for the root partition Ludovic Courtès
@ 2017-09-06 22:17 ` Ludovic Courtès
2017-09-11 16:50 ` Danny Milosavljevic
8 siblings, 1 reply; 21+ messages in thread
From: Ludovic Courtès @ 2017-09-06 22:17 UTC (permalink / raw)
To: 28377
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
^ permalink raw reply related [flat|nested] 21+ messages in thread