uuid in racket

uuid.rkt

#lang racket/base

(require (for-syntax racket/base
                     syntax/parse)
         racket/stxparam

         (only-in racket/format ~r)
         (only-in racket/port
                  call-with-input-bytes
                  call-with-input-string
                  call-with-output-string)

          (only-in openssl/md5 md5-bytes)
          (only-in openssl/sha1 sha1-bytes)

          racket/contract)

(provide (contract-out
           [uuid? (-> any/c boolean?)]
           [nil-uuid     uuid?]
           [uuid-ns:dns  uuid?]
           [uuid-ns:url  uuid?]
           [uuid-ns:oid  uuid?]
           [uuid-ns:x500 uuid?]
           [uuid3 (-> uuid? bytes? uuid?)]
           [uuid4 (-> uuid?)]
           [uuid5 (-> uuid? bytes? uuid?)]

           [uuid->string (-> uuid? string?)]
           [string->uuid (-> string? (or/c #f immutable-bytes?))]

           [read-uuid-string (-> input-port? (or/c #f immutable-bytes?))]
           [write-uuid-string (->* (uuid?) (output-port?) any)]))

(define (immutable-bytes? b)
  (and (bytes? b) (immutable? b)))

(define-syntax-parameter byte-index
  (lambda (stx)
    (raise-syntax-error
     #f "use of a byte-index keyword not in a for/bytes" stx)))

(define-syntax for/bytes
  (syntax-parser
    [(_ {~seq #:size size} #:immutable . rest)
     #'(bytes->immutable-bytes
         (for/bytes #:size size . rest))]

    [(_ {~seq #:size size} (for-clauses ...) body ...+)
     #:declare body (expr/c #'byte?)
     #:with orig-stx this-syntax
     #'(let ([the-bytes (make-bytes size)])  
         (for/fold/derived orig-stx () ([i (in-range size)] for-clauses ...)
           (define v
             (syntax-parameterize ([byte-index (make-rename-transformer #'i)])
               body.c ...))
           (bytes-set! the-bytes i v)
           (values))
         the-bytes)]))

(define (hexdigits-byte n)
  (~r n #:base 16 #:min-width 2 #:pad-string "0"))

(define (random-byte)
  (random 0 256))

(define (make-random-bytes size)
  (for/bytes #:size size () (random-byte)))

(define-syntax-rule (any-equal? v1 [vs ...])
  (or (= v1 vs) ...))

(define (list->immutable-bytes bs)
  (bytes->immutable-bytes (list->bytes bs)))

(define (uuid? b)
  (and (immutable-bytes? b)
       (= 16 (bytes-length b))
       (let ([version (arithmetic-shift (bytes-ref b 6) -4)])
         (<= 0 version 5))
       (or (let ([variant (arithmetic-shift (bytes-ref b 8) -6)])
             (= variant #b10))
           (bytes=? nil-uuid b))))

(define nil-uuid (bytes->immutable-bytes (make-bytes 16 0)))

(define (format-uuid-bytes some-bytes version)
  (let ([version (arithmetic-shift version 4)])
    (list->immutable-bytes
      (for/list ([b (in-bytes some-bytes)] [i (in-range 16)])
        (cond
          [(= i 6)
           (bitwise-ior version (bitwise-and #x0f b))]
          [(= i 8)
           (bitwise-ior #x80 (bitwise-and #x3f b))]
          [else b])))))

(define ((make-hash-uuid hashf version) namespace name-bytes)
  (format-uuid-bytes
    (call-with-input-bytes
      (bytes-append namespace name-bytes) hashf)
    version))

(define uuid3 (make-hash-uuid md5-bytes 3))
(define uuid5 (make-hash-uuid sha1-bytes 5))

(define (uuid4)
  (format-uuid-bytes (make-random-bytes 16) 4))

(define (write-uuid-string u [out (current-output-port)])
  (for ([b (in-bytes u)] [i (in-range 16)])
    (display (hexdigits-byte b) out)
    (when (any-equal? i [3 5 7 9])
      (display "-" out))))

(define (uuid->string u)
  (call-with-output-string
    (lambda (outp) (write-uuid-string u outp))))

(define (read-uuid-string [in (current-input-port)])
  (let/ec escape
    (define (fail) (escape #f))
    (define (read-octet)
      (define s (read-string 2 in))
      (when (eof-object? s) (fail))
      (or (string->number s 16) (fail)))
    (define (expect-break)
      (define ch (read-char in))
      (when (or (eof-object? ch) (not (char=? ch #\-))) (fail)))
    (for/bytes #:size 16 #:immutable ()
      (begin0
        (read-octet)
        (when (any-equal? byte-index [3 5 7 9])
          (expect-break))))))

(define (string->uuid s)
  (call-with-input-string s read-uuid-string))

(define uuid-ns:dns  (string->uuid "6ba7b810-9dad-11d1-80b4-00c04fd430c8"))
(define uuid-ns:url  (string->uuid "6ba7b811-9dad-11d1-80b4-00c04fd430c8"))
(define uuid-ns:oid  (string->uuid "6ba7b812-9dad-11d1-80b4-00c04fd430c8"))
(define uuid-ns:x500 (string->uuid "6ba7b814-9dad-11d1-80b4-00c04fd430c8"))