~ruther/guix-local

47cef4ecad54d112aa3b4bc509194d3d49a10785 — Ludovic Courtès 8 years ago 943e1b9 
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.
patch browse .tar.gz 
5 files changed, 234 insertions(+), 185 deletions(-)

M gnu/build/file-systems.scm
M gnu/build/vm.scm
M gnu/local.mk
M gnu/system/file-systems.scm
A gnu/system/uuid.scm

M gnu/build/file-systems.scm => gnu/build/file-systems.scm +1 -166
@@ 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:


M gnu/build/vm.scm => gnu/build/vm.scm +1 -1
@@ 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)


M gnu/local.mk => gnu/local.mk +1 -0
@@ 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			\


M gnu/system/file-systems.scm => gnu/system/file-systems.scm +4 -18
@@ 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.


A gnu/system/uuid.scm => gnu/system/uuid.scm +227 -0
@@ 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)))))