diff options
| -rw-r--r-- | gnu/build/file-systems.scm | 167 | ||||
| -rw-r--r-- | gnu/build/vm.scm | 2 | ||||
| -rw-r--r-- | gnu/local.mk | 1 | ||||
| -rw-r--r-- | gnu/system/file-systems.scm | 22 | ||||
| -rw-r--r-- | 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 fbaf158951..32885f1d2e 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 ad67a3727f..6da4fa654e 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 e98ee6d7fe..c1bc391101 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 bbac23fbdf..dd30559d7e 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 0000000000..64dad5a374 --- /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)) + + +;;; +;;; 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))))) |