blob: d4cf293ca15f8e2b185c4288e7143e5dca009f20 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
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?))
)
|
