From 4990ac117319ef7c7f2963cc8d3c0cbf1094ca86 Mon Sep 17 00:00:00 2001 From: Munyoki Kilyungi Date: Wed, 23 Aug 2023 17:00:54 +0300 Subject: Add an extra module for generating unique ids Signed-off-by: Munyoki Kilyungi --- transform/uuid.scm | 234 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 234 insertions(+) create mode 100644 transform/uuid.scm (limited to 'transform/uuid.scm') diff --git a/transform/uuid.scm b/transform/uuid.scm new file mode 100644 index 0000000..be0e592 --- /dev/null +++ b/transform/uuid.scm @@ -0,0 +1,234 @@ +;; 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)))) -- cgit v1.2.3