Add an extra module for generating unique ids

Signed-off-by: Munyoki Kilyungi <me@bonfacemunyoki.com>

1 files changed, 234 insertions, 0 deletions

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))))