From: "pelzflorian (Florian Pelz)" <pelzflorian@pelzflorian.de>
To: guile-user@gnu.org
Subject: UUID3 implementation for Guile
Date: Mon, 8 Jan 2018 15:58:01 +0100 [thread overview]
Message-ID: <20180108145801.zljsglp4fhve2djn@floriannotebook> (raw)
[-- Attachment #1: Type: text/plain, Size: 11545 bytes --]
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))))
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 833 bytes --]
next reply other threads:[~2018-01-08 14:58 UTC|newest]
Thread overview: 4+ messages / expand[flat|nested] mbox.gz Atom feed top
2018-01-08 14:58 pelzflorian (Florian Pelz) [this message]
2018-01-08 15:47 ` UUID3 implementation for Guile pelzflorian (Florian Pelz)
2018-01-09 10:00 ` Amirouche Boubekki
2018-01-09 13:29 ` pelzflorian (Florian Pelz)
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/guile/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20180108145801.zljsglp4fhve2djn@floriannotebook \
--to=pelzflorian@pelzflorian.de \
--cc=guile-user@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).