[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
04/10: file-systems: Introduce (gnu system uuid).
|
From: |
Ludovic Courtès |
|
Subject: |
04/10: file-systems: Introduce (gnu system uuid). |
|
Date: |
Mon, 11 Sep 2017 16:52:34 -0400 (EDT) |
civodul pushed a commit to branch master
in repository guix.
commit 47cef4ecad54d112aa3b4bc509194d3d49a10785
Author: Ludovic Courtès <address@hidden>
Date: Tue Sep 5 21:51:12 2017 +0200
file-systems: Introduce (gnu system uuid).
* 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(-)
diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index fbaf158..32885f1 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 ad67a37..6da4fa6 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 e98ee6d..c1bc391 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 bbac23f..dd30559 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 0000000..64dad5a
--- /dev/null
+++ b/gnu/system/uuid.scm
@@ -0,0 +1,227 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016, 2017 Ludovic Courtès <address@hidden>
+;;; Copyright © 2017 Danny Milosavljevic <address@hidden>
+;;;
+;;; 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)))))
- branch master updated (007b92c -> 5f7fe1c), Ludovic Courtès, 2017/09/11
- 03/10: services: base: Import the closure of (gnu build file-systems)., Ludovic Courtès, 2017/09/11
- 01/10: vm: Allow partitions to be initialized with a given UUID., Ludovic Courtès, 2017/09/11
- 05/10: services: file-system: Use 'file-system->spec'., Ludovic Courtès, 2017/09/11
- 07/10: system: Serialize the UUID type in the "parameters" file., Ludovic Courtès, 2017/09/11
- 08/10: uuid: 'uuid' macro supports more UUID types., Ludovic Courtès, 2017/09/11
- 09/10: vm: Allow users to specify a UUID for the root partition., Ludovic Courtès, 2017/09/11
- 10/10: vm: Generate a UUID to identify the root file system., Ludovic Courtès, 2017/09/11
- 02/10: file-systems: Add UUID type dictionaries., Ludovic Courtès, 2017/09/11
- 06/10: system: Introduce a disjoint UUID type., Ludovic Courtès, 2017/09/11
- 04/10: file-systems: Introduce (gnu system uuid).,
Ludovic Courtès <=