refactored ebus code

1 files changed, 202 insertions, 0 deletions

diff --git a/ebus-racket/3rdparty/bzlib/base/uuid.ss b/ebus-racket/3rdparty/bzlib/base/uuid.ss
new file mode 100644
index 0000000..d4cf293
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/base/uuid.ss
@@ -0,0 +1,202 @@
+#lang scheme/base

+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

+;; BASE.plt - common routines that are shared by all other bzlib modules 

+;; 

+;; in a way, base.plt is the most fundamental module of the whole bzlib stack

+;; and as such it also is the lowest level code.  We are not likely to 

+;; fix the code any time soon, and hence any of the functions here are 

+;; explicitly likely to be obsoleted or moved elsewhere. 

+;; 

+;; Proceed with caution. 

+;; 

+;; 

+;; Bonzai Lab, LLC.  All rights reserved.

+;; 

+;; Licensed under LGPL.

+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

+;; uuid.ss  - provide uuid object (currently wrapping over zitterbewegung/uuid-v4) 

+;; yc 9/11/2009 - first version 

+(require (prefix-in z: "../../zitterbewegung/uuid/uuid-v4.ss")

+         "base.ss"

+         scheme/list

+         scheme/string

+         scheme/contract

+         ;; (planet vyzo/crypto/util)

+         )

+

+(define (bytes->integer bytes)

+  (define (helper rest num)

+    (if (null? rest) num

+        (helper (cdr rest) (+ (* num 255) (car rest)))))

+  (helper (bytes->list bytes) 0))

+

+(define (bytes->hex bytes)

+  (define (helper rest acc)

+    (if (null? rest) (list->string (map hex-byte->char (reverse acc)))

+        (helper (cdr rest) 

+                (let-values (((quotient remainder)

+                              (quotient/remainder (car rest) 16)))

+                  (list* remainder quotient acc)))))

+  (helper (bytes->list bytes) '()))

+

+;; *uuid structure - representing UUID, and holds bytes format... 

+(define-struct *uuid (bytes)

+  #:property prop:custom-write 

+  (lambda (u out write?)

+    (display (format "#<uuid:~a>" (uuid->string u)) out))

+  #:property prop:equal+hash 

+  (list (lambda (u1 u2 sub?)

+          (bytes=? (*uuid-bytes u1) (*uuid-bytes u2)))

+        (lambda (u recur)

+          (bytes->integer (*uuid-bytes u)))

+        (lambda (u recur)

+          (bytes->integer (*uuid-bytes u)))))

+

+(define (uuid-time-low u)

+  (integer-bytes->integer (subbytes (*uuid-bytes u) 0 4) #f #t))

+

+(define (uuid-time-mid u)

+  (integer-bytes->integer (subbytes (*uuid-bytes u) 4 6) #f #t))

+

+(define (uuid-time-high u)

+  (integer-bytes->integer (subbytes (*uuid-bytes u) 6 8) #f #t))

+

+(define (uuid-clock-high u)

+  (integer-bytes->integer (bytes-append (list->bytes (list 0)) 

+                                        (subbytes (*uuid-bytes u) 8 9)) #f #t))

+

+(define (uuid-clock-low u)

+  (integer-bytes->integer (bytes-append (list->bytes (list 0)) 

+                                        (subbytes (*uuid-bytes u) 9 10)) #f #t))

+

+(define (uuid-node u)

+  (integer-bytes->integer (bytes-append (list->bytes (list 0 0)) 

+                                        (subbytes (*uuid-bytes u) 10 16)) #f #t))

+

+(define (uuid->string u (dash? #t))

+  (define (sub start end)

+    (subbytes (*uuid-bytes u) start end)) 

+  (if (not dash?)

+      (bytes->hex (*uuid-bytes u))

+      (string-join (map (lambda (b)

+                          (bytes->hex b)) 

+                        (list (sub 0 4) (sub 4 6) (sub 6 8) (sub 8 10) (sub 10 16)))

+                   "-")))

+

+

+(define (uuid-string? u)

+  (and (string? u)

+       (regexp-match #px"^(?i:([0-9a-f]{,8})-?([0-9a-f]{,4})-?([0-9a-f]{,4})-?([0-9a-f]{,4})-?([0-9a-f]{,12}))$" u)))

+

+(define (uuid-symbol? u)

+  (and (symbol? u)

+       (uuid-string? (symbol->string u))))

+

+(define (uuid-bytes? u)

+  (and (bytes? u) 

+       (= (bytes-length u) 16)))

+

+;; an uuid should be one of the following:

+;; struct of *uuid

+;; 16-bytes byte string. 

+;; a string of 32 or 36 hex chars. 

+(define (uuid? u)

+  (or (*uuid? u)

+      (uuid-bytes? u)

+      (uuid-string? u)))

+

+(define (make-uuid (u (symbol->string (z:make-uuid))))

+  (cond ((*uuid? u)

+         (make-*uuid (*uuid-bytes u)))

+        ((uuid-bytes? u)

+         (make-*uuid u))

+        (else

+         (uuid-string->uuid u))))

+

+(define (hex-byte->char h)

+  (case h

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

+    (else (error 'hex-byte->char "Not an hex byte: ~a" h))))

+

+(define (hex-char->integer c)

+  (case c

+    ((#\1) 1)

+    ((#\2) 2)

+    ((#\3) 3)

+    ((#\4) 4)

+    ((#\5) 5)

+    ((#\6) 6)

+    ((#\7) 7)

+    ((#\8) 8)

+    ((#\9) 9)

+    ((#\0) 0)

+    ((#\a #\A) 10)

+    ((#\b #\B) 11)

+    ((#\c #\C) 12)

+    ((#\d #\D) 13)

+    ((#\e #\E) 14)

+    ((#\f #\F) 15)

+    (else (error 'hex-char->integer "char ~a out of range" c))))

+

+(define (hex-char? c)

+  (member c '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\a #\A #\b #\B #\c #\C #\d #\D #\e #\E #\f #\F)))

+

+(define (hex-chars->byte chars)

+  (define (helper rest num)

+    (if (null? rest)

+        num

+        (helper (cdr rest) (+ (* 16 num) (hex-char->integer (car rest))))))

+  (helper chars 0))

+

+(define (hex-string->bytes h)

+  (define (helper rest acc)

+    (cond ((null? rest) (reverse acc))

+          ((null? (cdr rest)) ;; wrong

+           (error 'hex-string->bytes "Uneven # of hexdecimal strings: ~a" h))

+          (else

+           (helper (cddr rest)

+                   (cons (hex-chars->byte (list (car rest) (cadr rest)))

+                         acc)))))

+  (helper (string->list h) '()))

+

+(define (uuid-string->uuid uuid)

+  (make-*uuid (list->bytes (flatten (map hex-string->bytes (cdr (uuid-string? uuid)))))))

+

+;; how quickly can all the generation take? 

+;; it seems that 

+(provide/contract 

+ (make-uuid (->* ()

+                 (uuid?)

+                 *uuid?))

+ (uuid->string (->* (*uuid?)

+                    (boolean?) 

+                    string?))

+ (rename *uuid-bytes uuid->bytes (-> *uuid? bytes?))

+ (uuid-string? (-> any/c any))

+ (uuid-bytes? (-> any/c any))

+ (uuid-time-low (-> *uuid? number?))

+ (uuid-time-mid (-> *uuid? number?))

+ (uuid-time-high (-> *uuid? number?))

+ (uuid-clock-low (-> *uuid? number?))

+ (uuid-clock-high (-> *uuid? number?))

+ (uuid-node (-> *uuid? number?))

+ (uuid? (-> any/c any))

+ (bytes->hex (-> bytes? string?))

+ (bytes->integer (-> bytes? number?))

+ )

+