;; CREDIT: https://lists.gnu.org/archive/html/guile-user/2018-01/msg00019.html
(define-module (transform uuid)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 iconv)
#:export (bytevector->md5
make-version-3-uuid))
(define (bytevector->md5 bytevector)
"Convert BYTEVECTOR to a bytevector containing the MD5 hash of
BYTEVECTOR."
;; Implemented along RFC 1321. It should be easy to verify that
;; this procedure performs the operations specified therein.
(define (append-padding-bits bytevector)
"Makes a list from BYTEVECTOR with padding as per RFC 1321 3.1."
(let* ((length-in-bits (* 8 (bytevector-length bytevector)))
(padding-bits (- 512 (modulo (- length-in-bits 448) 512))))
(append (bytevector->u8-list bytevector)
'(128) ; #*10000000
(iota
(- (/ padding-bits 8) 1)
0 0))))
(define (append-length msg-list message-length)
"Append MESSAGE-LENGTH as 8 byte values from a uint64 to MSG-LIST."
(append msg-list
;; For numbers too large for an uint64, only the low-order
;; bytes are returned.
(bytevector->u8-list (u64vector
(modulo
(* message-length 8) ; bits
(1+ #xffffffffffffffff))))))
(let hash ((AA #x67452301)
(BB #xefcdab89)
(CC #x98badcfe)
(DD #x10325476)
(to-digest
(append-length
(append-padding-bits
bytevector)
(bytevector-length bytevector))))
(define (F X Y Z)
(logior (logand X Y) (logand (lognot X) Z)))
(define (G X Y Z)
(logior (logand X Z) (logand Y (lognot Z))))
(define (H X Y Z)
(logxor X Y Z))
(define (I X Y Z)
(logxor Y (logior X (lognot Z))))
(define (T i)
(inexact->exact (floor (* 4294967296 (abs (sin i))))))
(define (number->u32 n)
"Cut off all bits that do not fit in a uint32."
(bit-extract n 0 32))
(define (lsh32 n count)
(number->u32 (logior (ash n count)
(bit-extract n (- 32 count) 32))))
(if (not (null? to-digest))
(let* ((block (u8-list->bytevector
(list-head to-digest (/ 512 8))))
(X (lambda (j) (bytevector-u32-ref
block (* 4 j) (endianness little))))
(do-round1
(lambda (A B C D)
(define (operation a b c d k s i)
(number->u32
(+ b (lsh32 (+ a (F b c d) (X k) (T i)) s))))
(let* ((A (operation A B C D 0 7 1))
(D (operation D A B C 1 12 2))
(C (operation C D A B 2 17 3))
(B (operation B C D A 3 22 4))
(A (operation A B C D 4 7 5))
(D (operation D A B C 5 12 6))
(C (operation C D A B 6 17 7))
(B (operation B C D A 7 22 8))
(A (operation A B C D 8 7 9))
(D (operation D A B C 9 12 10))
(C (operation C D A B 10 17 11))
(B (operation B C D A 11 22 12))
(A (operation A B C D 12 7 13))
(D (operation D A B C 13 12 14))
(C (operation C D A B 14 17 15))
(B (operation B C D A 15 22 16)))
(values A B C D))))
(do-round2
(lambda (A B C D)
(define (operation a b c d k s i)
(number->u32
(+ b (lsh32 (+ a (G b c d) (X k) (T i)) s))))
(let* ((A (operation A B C D 1 5 17))
(D (operation D A B C 6 9 18))
(C (operation C D A B 11 14 19))
(B (operation B C D A 0 20 20))
(A (operation A B C D 5 5 21))
(D (operation D A B C 10 9 22))
(C (operation C D A B 15 14 23))
(B (operation B C D A 4 20 24))
(A (operation A B C D 9 5 25))
(D (operation D A B C 14 9 26))
(C (operation C D A B 3 14 27))
(B (operation B C D A 8 20 28))
(A (operation A B C D 13 5 29))
(D (operation D A B C 2 9 30))
(C (operation C D A B 7 14 31))
(B (operation B C D A 12 20 32)))
(values A B C D))))
(do-round3
(lambda (A B C D)
(define (operation a b c d k s i)
(number->u32
(+ b (lsh32 (+ a (H b c d) (X k) (T i)) s))))
(let* ((A (operation A B C D 5 4 33))
(D (operation D A B C 8 11 34))
(C (operation C D A B 11 16 35))
(B (operation B C D A 14 23 36))
(A (operation A B C D 1 4 37))
(D (operation D A B C 4 11 38))
(C (operation C D A B 7 16 39))
(B (operation B C D A 10 23 40))
(A (operation A B C D 13 4 41))
(D (operation D A B C 0 11 42))
(C (operation C D A B 3 16 43))
(B (operation B C D A 6 23 44))
(A (operation A B C D 9 4 45))
(D (operation D A B C 12 11 46))
(C (operation C D A B 15 16 47))
(B (operation B C D A 2 23 48)))
(values A B C D))))
(do-round4
(lambda (A B C D)
(define (operation a b c d k s i)
(number->u32
(+ b (lsh32 (+ a (I b c d) (X k) (T i)) s))))
(let* ((A (operation A B C D 0 6 49))
(D (operation D A B C 7 10 50))
(C (operation C D A B 14 15 51))
(B (operation B C D A 5 21 52))
(A (operation A B C D 12 6 53))
(D (operation D A B C 3 10 54))
(C (operation C D A B 10 15 55))
(B (operation B C D A 1 21 56))
(A (operation A B C D 8 6 57))
(D (operation D A B C 15 10 58))
(C (operation C D A B 6 15 59))
(B (operation B C D A 13 21 60))
(A (operation A B C D 4 6 61))
(D (operation D A B C 11 10 62))
(C (operation C D A B 2 15 63))
(B (operation B C D A 9 21 64)))
(values A B C D)))))
(let*-values (((A B C D) (values AA BB CC DD))
((A B C D) (do-round1 A B C D))
((A B C D) (do-round2 A B C D))
((A B C D) (do-round3 A B C D))
((A B C D) (do-round4 A B C D)))
(hash (number->u32 (+ A AA))
(number->u32 (+ B BB))
(number->u32 (+ C CC))
(number->u32 (+ D DD))
(list-tail to-digest (/ 512 8)))))
;; we’re done:
(u8-list->bytevector
(append
(bytevector->u8-list (u32vector AA))
(bytevector->u8-list (u32vector BB))
(bytevector->u8-list (u32vector CC))
(bytevector->u8-list (u32vector DD)))))))
(define* (make-version-3-uuid namespace-uuid str #:optional (prefix "urn:uuid:"))
"Generates a UUID string by computing the MD5 hash of NAMESPACE-UUID
and STR. NAMESPACE-UUID must be a bytevector consisting of the UUID’s
bytes, *not* the UUID’s string representation."
(define (half-byte->hex-char number)
"Returns the corresponding hexadecimal digit for a number NUMBER
between 0 and 15."
(case number
((0) #\0)
((1) #\1)
((2) #\2)
((3) #\3)
((4) #\4)
((5) #\5)
((6) #\6)
((7) #\7)
((8) #\8)
((9) #\9)
((10) #\a)
((11) #\b)
((12) #\c)
((13) #\d)
((14) #\e)
((15) #\f)))
(define (byte->hex-string bv index)
"Convert the byte at INDEX of bytevector BV to a hex string."
(let ((byte (bytevector-u8-ref bv index)))
(string (half-byte->hex-char (quotient byte 16))
(half-byte->hex-char (modulo byte 16)))))
(let ((md5 (bytevector->md5
(u8-list->bytevector
(append (bytevector->u8-list namespace-uuid)
(bytevector->u8-list (string->utf8 str)))))))
(string-append prefix
;; time_low field:
(byte->hex-string md5 0)
(byte->hex-string md5 1)
(byte->hex-string md5 2)
(byte->hex-string md5 3)
"-"
;; time_mid field:
(byte->hex-string md5 4)
(byte->hex-string md5 5)
"-"
;; time_hi_and_version field:
(let ((byte (bytevector-u8-ref md5 6)))
(string (half-byte->hex-char 3) ; UUID version 3
(half-byte->hex-char (modulo byte 16))))
(byte->hex-string md5 7)
"-"
;; clock_seq_hi_and_reserved field:
(let ((byte (bytevector-u8-ref md5 8)))
(string (half-byte->hex-char
(logior #b1000 ; most significant bits are 10
(bit-extract (quotient byte 16) 0 2)))
(half-byte->hex-char (modulo byte 16))))
;; clock_seq_low field:
(byte->hex-string md5 9)
"-"
;; node field:
(byte->hex-string md5 10)
(byte->hex-string md5 11)
(byte->hex-string md5 12)
(byte->hex-string md5 13)
(byte->hex-string md5 14)
(byte->hex-string md5 15))))