From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!.POSTED!not-for-mail From: "pelzflorian (Florian Pelz)" Newsgroups: gmane.lisp.guile.user Subject: UUID3 implementation for Guile Date: Mon, 8 Jan 2018 15:58:01 +0100 Message-ID: <20180108145801.zljsglp4fhve2djn@floriannotebook> NNTP-Posting-Host: blaine.gmane.org Mime-Version: 1.0 Content-Type: multipart/signed; micalg=pgp-sha256; protocol="application/pgp-signature"; boundary="n5y4a75f6rprpobb" X-Trace: blaine.gmane.org 1515423371 407 195.159.176.226 (8 Jan 2018 14:56:11 GMT) X-Complaints-To: usenet@blaine.gmane.org NNTP-Posting-Date: Mon, 8 Jan 2018 14:56:11 +0000 (UTC) User-Agent: NeoMutt/20171208 To: guile-user@gnu.org Original-X-From: guile-user-bounces+guile-user=m.gmane.org@gnu.org Mon Jan 08 15:56:07 2018 Return-path: Envelope-to: guile-user@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by blaine.gmane.org with esmtp (Exim 4.84_2) (envelope-from ) id 1eYYq9-0007Bu-4R for guile-user@m.gmane.org; Mon, 08 Jan 2018 15:55:53 +0100 Original-Received: from localhost ([::1]:38955 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1eYYs3-0007hC-8W for guile-user@m.gmane.org; Mon, 08 Jan 2018 09:57:51 -0500 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:50486) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1eYYrZ-0007gD-Hg for guile-user@gnu.org; Mon, 08 Jan 2018 09:57:23 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1eYYrW-0002oE-F1 for guile-user@gnu.org; Mon, 08 Jan 2018 09:57:21 -0500 Original-Received: from pelzflorian.de ([5.45.111.108]:34088 helo=mail.pelzflorian.de) by eggs.gnu.org with esmtps (TLS1.0:DHE_RSA_AES_256_CBC_SHA1:32) (Exim 4.71) (envelope-from ) id 1eYYrW-0002nM-10 for guile-user@gnu.org; Mon, 08 Jan 2018 09:57:18 -0500 Original-Received: from floriannotebook (eduroam-ipv4-4-0312.triple-a.uni-kl.de [131.246.177.56]) by mail.pelzflorian.de (Postfix) with ESMTPSA id 1861C360007 for ; Mon, 8 Jan 2018 15:57:16 +0100 (CET) DKIM-Signature: v=1; a=rsa-sha256; c=simple/simple; d=pelzflorian.de; s=mail; t=1515423436; bh=XGSAK2taeTDFmxBIgeOgcrnobu18+RoSuOdm/4Rke4Y=; h=Date:From:To:Subject; b=I7N1MXNXPZeLALM2mJ4VEwj8sUiBZOnqbiDxTCUZKTEHt1b0rxjn1KPiUWiczBSs9 qdqc+ukkl6cDStEi14jGYLE/JNshE6kuyFcICiM90O65+Mgum0EktdTpGHOOafnf+B PhaYgQp9rn3NbHlrwfXA4k2wQRKldQugdZR0VGqc= Content-Disposition: inline X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] [fuzzy] X-Received-From: 5.45.111.108 X-BeenThere: guile-user@gnu.org X-Mailman-Version: 2.1.21 Precedence: list List-Id: General Guile related discussions List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-user-bounces+guile-user=m.gmane.org@gnu.org Original-Sender: "guile-user" Xref: news.gmane.org gmane.lisp.guile.user:14417 Archived-At: --n5y4a75f6rprpobb Content-Type: text/plain; charset=utf-8 Content-Disposition: inline Content-Transfer-Encoding: quoted-printable 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=E2=80=99re 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=E2=80= =99s bytes, *not* the UUID=E2=80=99s 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)))) --n5y4a75f6rprpobb Content-Type: application/pgp-signature; name="signature.asc" -----BEGIN PGP SIGNATURE----- iQIzBAEBCAAdFiEEwRjGsqAMqXB4uw3y3T6EbElHBVsFAlpThvEACgkQ3T6EbElH BVtgmQ//Z53FyhYcEgf9GABD4CX5owRFFJP/sgEHID78iFlveH3yObCw3Uox1biW Sl/OyBKCYlDqsGOzKrieB5bVDPjBr5RvhP77hM5UqLXf25d1yNYyY8HSLgPQKEah 2GqCNFzLPTLP4gRNJIeR47BeGFFgGdSOXXB7NpeBaK2MBnexcuNyrIXaNTlMVhVL wZYolBDmSdUzjbyL4jKNv/ZurJjfN6DHQrkMSQMVC5nGWDDhMDesORCp0ECGfJJh ZB7r5grIVqHoS6hJdncyRaOabjPy4c/ObtZi6WK9tma82E1YZ8cs76jZxNYYbdC2 sXl6kqVYJ2IFYFtNF3CT1e7TMRKh3HvlSmGELoFcPYGim+IgbbsmLD7bvVG+kIKX vd0hEmKCPgmShrV7CAz0KwgnREULuMcvZC2MqWub4NkPtCTjq8E2DwZZMZaCi//c FV6B1LYwVUSsHCtKTejVLEVJ8bKYtW1ELkR2bzHJpwOFrR3XRy9cTw4xjRhdBEkP 4PQ5f4CFO1iCZ/pNqiScp7VMTKX9zUVP6EwN5XShU+BHlICHjHK5utdYMhMPfCtD 5+Gu0rV4WZ+N8ZUN7F4OhGkixt6563tpAV0gIZOOn4X9lOT/6L09DqTrL2SURmVY PnuHSXaq/qnVuf+DYB869btdb6D3RIDr/md7Q65i+5jBWTDTk34= =NcGI -----END PGP SIGNATURE----- --n5y4a75f6rprpobb--