aboutsummaryrefslogtreecommitdiff
path: root/transform
diff options
context:
space:
mode:
Diffstat (limited to 'transform')
-rw-r--r--transform/uuid.scm234
1 files changed, 0 insertions, 234 deletions
diff --git a/transform/uuid.scm b/transform/uuid.scm
deleted file mode 100644
index be0e592..0000000
--- a/transform/uuid.scm
+++ /dev/null
@@ -1,234 +0,0 @@
-;; 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))))
generated by cgit v1.2.3 (git 2.44.0) at 2024-11-05 08:34:38 +0000