Hello, I need to generate a unique deterministic ID for Haunt and other Web stuff. Therefore I implemented UUID version 3 and MD5 by myself. But I wonder:
* Why is UUID3 support not in Guile proper? Does it belong there? Should I submit a patch? * Is there already a better implementation out there? Apparently there is an implementation in Gauche Scheme. I also find this. https://github.com/marcomaggi/industria/tree/master/weinholt Here the Guile list talked about using gcrypt from Guile. https://lists.gnu.org/archive/html/guile-devel/2013-02/msg00009.html Regards, Florian P.S. If and only if you want to check it out, this is my current implementation. It should probably be made to accept messages from ports instead of taking a complete bytevector as input. (define-module (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) "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 "urn:uuid:" ;; 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))))
signature.asc
Description: PGP signature