Created
June 25, 2023 03:50
-
-
Save samdphillips/27f398ddd2784b62de5182980efd4439 to your computer and use it in GitHub Desktop.
uuid in racket
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#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")) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment