guile-user
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

UUID3 implementation for Guile


From: pelzflorian (Florian Pelz)
Subject: UUID3 implementation for Guile
Date: Mon, 8 Jan 2018 15:58:01 +0100
User-agent: NeoMutt/20171208

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: signature.asc
Description: PGP signature


reply via email to

[Prev in Thread] Current Thread [Next in Thread]