gnu/system/uuid.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2017 Danny Milosavljevic <dannym@scratchpost.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (gnu system uuid)
  21   #:use-module (srfi srfi-1)
  22   #:use-module (srfi srfi-9)
  23   #:use-module (rnrs bytevectors)
  24   #:use-module (ice-9 match)
  25   #:use-module (ice-9 vlist)
  26   #:use-module (ice-9 regex)
  27   #:use-module (ice-9 format)
  28   #:export (uuid
  29             uuid?
  30             uuid-type
  31             uuid-bytevector
  32             uuid=?
  33
  34             bytevector->uuid
  35
  36             uuid->string
  37             dce-uuid->string
  38             string->uuid
  39             string->dce-uuid
  40             string->iso9660-uuid
  41             string->ext2-uuid
  42             string->ext3-uuid
  43             string->ext4-uuid
  44             string->btrfs-uuid
  45             string->fat-uuid
  46             iso9660-uuid->string
  47
  48             ;; XXX: For lack of a better place.
  49             sub-bytevector
  50             latin1->string))
  51
  52 \f
  53 ;;;
  54 ;;; Tools that lack a better place.
  55 ;;;
  56
  57 (define (sub-bytevector bv start size)
  58   "Return a copy of the SIZE bytes of BV starting from offset START."
  59   (let ((result (make-bytevector size)))
  60     (bytevector-copy! bv start result 0 size)
  61     result))
  62
  63 (define (latin1->string bv terminator)
  64   "Return a string of BV, a latin1 bytevector, or #f.  TERMINATOR is a predicate
  65 that takes a number and returns #t when a termination character is found."
  66     (let ((bytes (take-while (negate terminator) (bytevector->u8-list bv))))
  67       (if (null? bytes)
  68           #f
  69           (list->string (map integer->char bytes)))))
  70
  71 \f
  72 ;;;
  73 ;;; DCE UUIDs.
  74 ;;;
  75
  76 (define-syntax %network-byte-order
  77   (identifier-syntax (endianness big)))
  78
  79 (define (dce-uuid->string uuid)
  80   "Convert UUID, a 16-byte bytevector, to its string representation, something
  81 like \"6b700d61-5550-48a1-874c-a3d86998990e\"."
  82   ;; See <https://tools.ietf.org/html/rfc4122>.
  83   (let ((time-low  (bytevector-uint-ref uuid 0 %network-byte-order 4))
  84         (time-mid  (bytevector-uint-ref uuid 4 %network-byte-order 2))
  85         (time-hi   (bytevector-uint-ref uuid 6 %network-byte-order 2))
  86         (clock-seq (bytevector-uint-ref uuid 8 %network-byte-order 2))
  87         (node      (bytevector-uint-ref uuid 10 %network-byte-order 6)))
  88     (format #f "~8,'0x-~4,'0x-~4,'0x-~4,'0x-~12,'0x"
  89             time-low time-mid time-hi clock-seq node)))
  90
  91 (define %uuid-rx
  92   ;; The regexp of a UUID.
  93   (make-regexp "^([[:xdigit:]]{8})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{12})$"))
  94
  95 (define (string->dce-uuid str)
  96   "Parse STR as a DCE UUID (see <https://tools.ietf.org/html/rfc4122>) and
  97 return its contents as a 16-byte bytevector.  Return #f if STR is not a valid
  98 UUID representation."
  99   (and=> (regexp-exec %uuid-rx str)
 100          (lambda (match)
 101            (letrec-syntax ((hex->number
 102                             (syntax-rules ()
 103                               ((_ index)
 104                                (string->number (match:substring match index)
 105                                                16))))
 106                            (put!
 107                             (syntax-rules ()
 108                               ((_ bv index (number len) rest ...)
 109                                (begin
 110                                  (bytevector-uint-set! bv index number
 111                                                        (endianness big) len)
 112                                  (put! bv (+ index len) rest ...)))
 113                               ((_ bv index)
 114                                bv))))
 115              (let ((time-low  (hex->number 1))
 116                    (time-mid  (hex->number 2))
 117                    (time-hi   (hex->number 3))
 118                    (clock-seq (hex->number 4))
 119                    (node      (hex->number 5))
 120                    (uuid      (make-bytevector 16)))
 121                (put! uuid 0
 122                      (time-low 4) (time-mid 2) (time-hi 2)
 123                      (clock-seq 2) (node 6)))))))
 124
 125 \f
 126 ;;;
 127 ;;; ISO-9660.
 128 ;;;
 129
 130 ;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-119.pdf>.
 131
 132 (define %iso9660-uuid-rx
 133   ;;                   Y                m                d                H                M                S                ss
 134   (make-regexp "^([[:digit:]]{4})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})$"))
 135 (define (string->iso9660-uuid str)
 136   "Parse STR as a ISO9660 UUID (which is really a timestamp - see /dev/disk/by-uuid).
 137 Return its contents as a 16-byte bytevector.  Return #f if STR is not a valid
 138 ISO9660 UUID representation."
 139   (and=> (regexp-exec %iso9660-uuid-rx str)
 140          (lambda (match)
 141            (letrec-syntax ((match-numerals
 142                             (syntax-rules ()
 143                               ((_ index (name rest ...) body)
 144                                (let ((name (match:substring match index)))
 145                                  (match-numerals (+ 1 index) (rest ...) body)))
 146                               ((_ index () body)
 147                                body))))
 148             (match-numerals 1 (year month day hour minute second hundredths)
 149               (string->utf8 (string-append year month day
 150                                            hour minute second hundredths)))))))
 151 (define (iso9660-uuid->string uuid)
 152   "Given an UUID bytevector, return its timestamp string."
 153   (define (digits->string bytes)
 154     (latin1->string bytes (lambda (c) #f)))
 155   (let* ((year (sub-bytevector uuid 0 4))
 156          (month (sub-bytevector uuid 4 2))
 157          (day (sub-bytevector uuid 6 2))
 158          (hour (sub-bytevector uuid 8 2))
 159          (minute (sub-bytevector uuid 10 2))
 160          (second (sub-bytevector uuid 12 2))
 161          (hundredths (sub-bytevector uuid 14 2))
 162          (parts (list year month day hour minute second hundredths)))
 163     (string-append (string-join (map digits->string parts) "-"))))
 164
 165 \f
 166 ;;;
 167 ;;; FAT32/FAT16.
 168 ;;;
 169
 170 (define-syntax %fat-endianness
 171   ;; Endianness of FAT32/FAT16 file systems.
 172   (identifier-syntax (endianness little)))
 173
 174 (define (fat-uuid->string uuid)
 175   "Convert FAT32/FAT16 UUID, a 4-byte bytevector, to its string representation."
 176   (let ((high  (bytevector-uint-ref uuid 0 %fat-endianness 2))
 177         (low (bytevector-uint-ref uuid 2 %fat-endianness 2)))
 178     (format #f "~:@(~4,'0x-~4,'0x~)" low high)))
 179
 180 (define %fat-uuid-rx
 181   (make-regexp "^([[:xdigit:]]{4})-([[:xdigit:]]{4})$"))
 182
 183 (define (string->fat-uuid str)
 184   "Parse STR, which is in FAT32/FAT16 format, and return a bytevector or #f."
 185   (match (regexp-exec %fat-uuid-rx str)
 186     (#f
 187      #f)
 188     (rx-match
 189      (uint-list->bytevector (list (string->number
 190                                    (match:substring rx-match 2) 16)
 191                                   (string->number
 192                                    (match:substring rx-match 1) 16))
 193                             %fat-endianness
 194                             2))))
 195
 196 \f
 197 ;;;
 198 ;;; Generic interface.
 199 ;;;
 200
 201 (define string->ext2-uuid string->dce-uuid)
 202 (define string->ext3-uuid string->dce-uuid)
 203 (define string->ext4-uuid string->dce-uuid)
 204 (define string->btrfs-uuid string->dce-uuid)
 205
 206 (define-syntax vhashq
 207   (syntax-rules (=>)
 208     ((_)
 209      vlist-null)
 210     ((_ (key others ... => value) rest ...)
 211      (vhash-consq key value
 212                   (vhashq (others ... => value) rest ...)))
 213     ((_ (=> value) rest ...)
 214      (vhashq rest ...))))
 215
 216 (define %uuid-parsers
 217   (vhashq
 218    ('dce 'ext2 'ext3 'ext4 'btrfs 'luks => string->dce-uuid)
 219    ('fat32 'fat16 'fat => string->fat-uuid)
 220    ('iso9660 => string->iso9660-uuid)))
 221
 222 (define %uuid-printers
 223   (vhashq
 224    ('dce 'ext2 'ext3 'ext4 'btrfs 'luks => dce-uuid->string)
 225    ('iso9660 => iso9660-uuid->string)
 226    ('fat32 'fat16 'fat => fat-uuid->string)))
 227
 228 (define* (string->uuid str #:optional (type 'dce))
 229   "Parse STR as a UUID of the given TYPE.  On success, return the
 230 corresponding bytevector; otherwise return #f."
 231   (match (vhash-assq type %uuid-parsers)
 232     (#f #f)
 233     ((_ . (? procedure? parse)) (parse str))))
 234
 235 ;; High-level UUID representation that carries its type with it.
 236 ;;
 237 ;; This is necessary to serialize bytevectors with the right printer in some
 238 ;; circumstances.  For instance, GRUB "search --fs-uuid" command compares the
 239 ;; string representation of UUIDs, not the raw bytes; thus, when emitting a
 240 ;; GRUB 'search' command, we need to produce the right string representation
 241 ;; (see <https://debbugs.gnu.org/cgi/bugreport.cgi?msg=52;att=0;bug=27735>).
 242 (define-record-type <uuid>
 243   (make-uuid type bv)
 244   uuid?
 245   (type  uuid-type)                               ;'dce | 'iso9660 | ...
 246   (bv    uuid-bytevector))
 247
 248 (define* (bytevector->uuid bv #:optional (type 'dce))
 249   "Return a UUID object make of BV and TYPE."
 250   (make-uuid type bv))
 251
 252 (define-syntax uuid
 253   (lambda (s)
 254     "Return the UUID object corresponding to the given UUID representation or
 255 #f if the string could not be parsed."
 256     (syntax-case s (quote)
 257       ((_ str (quote type))
 258        (and (string? (syntax->datum #'str))
 259             (identifier? #'type))
 260        ;; A literal string: do the conversion at expansion time.
 261        (let ((bv (string->uuid (syntax->datum #'str)
 262                                (syntax->datum #'type))))
 263          (unless bv
 264            (syntax-violation 'uuid "invalid UUID" s))
 265          #`(make-uuid 'type #,(datum->syntax s bv))))
 266       ((_ str)
 267        (string? (syntax->datum #'str))
 268        #'(uuid str 'dce))
 269       ((_ str)
 270        #'(let ((bv (string->uuid str 'dce)))
 271            (and bv (make-uuid 'dce bv))))
 272       ((_ str type)
 273        #'(let ((bv (string->uuid str type)))
 274            (and bv (make-uuid type bv)))))))
 275
 276 (define uuid->string
 277   ;; Convert the given bytevector or UUID object, to the corresponding UUID
 278   ;; string representation.
 279   (match-lambda*
 280     (((? bytevector? bv))
 281      (uuid->string bv 'dce))
 282     (((? bytevector? bv) type)
 283      (match (vhash-assq type %uuid-printers)
 284        (#f #f)
 285        ((_ . (? procedure? unparse)) (unparse bv))))
 286     (((? uuid? uuid))
 287      (uuid->string (uuid-bytevector uuid) (uuid-type uuid)))))
 288
 289 (define uuid=?
 290   ;; Return true if A is equal to B, comparing only the actual bits.
 291   (match-lambda*
 292     (((? bytevector? a) (? bytevector? b))
 293      (bytevector=? a b))
 294     (((? uuid? a) (? bytevector? b))
 295      (bytevector=? (uuid-bytevector a) b))
 296     (((? uuid? a) (? uuid? b))
 297      (bytevector=? (uuid-bytevector a) (uuid-bytevector b)))
 298     ((a b)
 299      (uuid=? b a))))