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