1 | ;;;; message-digest-type.scm |
---|
2 | ;;;; Kon Lovett, Jan '06 (message-digest.scm) |
---|
3 | ;;;; Kon Lovett, May '10 (message-digest.scm) |
---|
4 | ;;;; Kon Lovett, Apr '12 |
---|
5 | ;;;; Kon Lovett, Aug '17 |
---|
6 | |
---|
7 | ;; Issues |
---|
8 | ;; |
---|
9 | ;; - Uses 'context-info' to determine whether active context is "own" allocation or |
---|
10 | ;; callers. |
---|
11 | |
---|
12 | (module message-digest-type |
---|
13 | |
---|
14 | (;export |
---|
15 | ; MD API |
---|
16 | message-digest-result-form |
---|
17 | message-digest? check-message-digest error-message-digest |
---|
18 | message-digest-algorithm message-digest-context |
---|
19 | initialize-message-digest |
---|
20 | finalize-message-digest finalize-message-digest! |
---|
21 | setup-message-digest-buffer! |
---|
22 | ;DEPRECATED |
---|
23 | message-digest-default-result-type) |
---|
24 | |
---|
25 | (import scheme chicken) |
---|
26 | (use |
---|
27 | (only lolevel allocate free number-of-bytes) |
---|
28 | (only srfi-4 blob->u8vector/shared u8vector-length u8vector?) |
---|
29 | (only blob-hexadecimal blob->hex) |
---|
30 | (only string-hexadecimal string->hex) |
---|
31 | (only type-checks |
---|
32 | define-check+error-type) |
---|
33 | (only type-errors |
---|
34 | error-argument-type) |
---|
35 | miscmacros |
---|
36 | message-digest-primitive |
---|
37 | typed-define) |
---|
38 | |
---|
39 | (declare |
---|
40 | (bound-to-procedure ##sys#slot) ) |
---|
41 | |
---|
42 | ;;; Support |
---|
43 | |
---|
44 | (define-constant MINIMUM-BUFFER-SIZE 8) |
---|
45 | |
---|
46 | #; ;CHICKEN 4.8.0.5 has an issue here |
---|
47 | (define-constant DEFAULT-RESULT-TYPE 'hex-string) |
---|
48 | |
---|
49 | (define (error-result-form loc obj) |
---|
50 | (error-argument-type loc obj "symbol in {string hex blob u8vector}" 'result-form) ) |
---|
51 | |
---|
52 | ;perform any conversion necessary for final result representation |
---|
53 | ;assumes blob 'res' may not be of result size |
---|
54 | #; |
---|
55 | (define (get-result-form loc res rt len) |
---|
56 | (case rt |
---|
57 | ((blob) |
---|
58 | (if (fx= len (blob-size res)) res |
---|
59 | (string->blob (substring (blob->string res) 0 len)) ) ) |
---|
60 | ((byte-string string) |
---|
61 | (let ((str (blob->string res))) |
---|
62 | (if (fx= len (string-length str)) str |
---|
63 | (substring str 0 len) ) ) ) |
---|
64 | ((hex-string hex hexstring) |
---|
65 | (blob->hex res 0 len) ) |
---|
66 | ((u8vector) |
---|
67 | (let ((vec (blob->u8vector/shared res))) |
---|
68 | (if (fx= len (u8vector-length vec)) vec |
---|
69 | (subu8vector vec 0 len) ) ) ) |
---|
70 | (else |
---|
71 | (error-result-form loc rt) ) ) ) |
---|
72 | |
---|
73 | ;perform any conversion necessary for final result representation |
---|
74 | ;assumes blob 'res' is of result size |
---|
75 | (define (get-result-form loc res rt) |
---|
76 | (case (canonical-result-name rt) |
---|
77 | ((blob) res ) |
---|
78 | ((byte-string) (blob->string res) ) |
---|
79 | ((hex-string) (blob->hex res) ) |
---|
80 | ((u8vector) (blob->u8vector/shared res) ) |
---|
81 | (else |
---|
82 | (error-result-form loc rt) ) ) ) |
---|
83 | |
---|
84 | (define (canonical-result-name x) |
---|
85 | (case x |
---|
86 | ((blob) 'blob ) |
---|
87 | ((byte-string string) 'byte-string ) |
---|
88 | ((hex-string hex hexstring) 'hex-string ) |
---|
89 | ((u8vector) 'u8vector ) |
---|
90 | (else |
---|
91 | #f ) ) ) |
---|
92 | |
---|
93 | (define (check-result-type loc mdp obj) |
---|
94 | (let ( |
---|
95 | (siz |
---|
96 | (cond |
---|
97 | ((string? obj) |
---|
98 | (string-length obj)) |
---|
99 | ((blob? obj) |
---|
100 | (blob-size obj)) |
---|
101 | ((u8vector? obj) |
---|
102 | (u8vector-length obj)) |
---|
103 | (else |
---|
104 | (error loc "unsupported result buffer" obj) ) ) ) |
---|
105 | (rqr (message-digest-primitive-digest-length mdp)) ) |
---|
106 | ; |
---|
107 | (unless (<= rqr siz) |
---|
108 | (error loc "result buffer too small" rqr obj) ) ) |
---|
109 | obj ) |
---|
110 | |
---|
111 | ;;; Message Digest API |
---|
112 | |
---|
113 | ;; |
---|
114 | |
---|
115 | (define-parameter message-digest-result-form #;DEFAULT-RESULT-TYPE 'hex-string |
---|
116 | (lambda (x) |
---|
117 | (or |
---|
118 | (if x |
---|
119 | (canonical-result-name x) |
---|
120 | (begin |
---|
121 | (warning 'message-digest-result-form "invalid result-form" x) |
---|
122 | (message-digest-result-form) ) ) ) ) ) |
---|
123 | |
---|
124 | ;; |
---|
125 | |
---|
126 | (define-type srfi4vector (or u8vector s8vector u16vector s16vector u32vector s32vector f32vector f64vector)) |
---|
127 | |
---|
128 | ;(define-type message-digest-buffer (or string blob srfi4vector procedure input-port pointer)) |
---|
129 | (define-type message-digest-buffer (or string blob u8vector)) |
---|
130 | |
---|
131 | (define-type message-digest-result-form (or string blob u8vector)) |
---|
132 | |
---|
133 | (define-type message-digest-context (or fixnum procedure)) |
---|
134 | |
---|
135 | (define-type message-digest-primitive (struct message-digest-primitive)) |
---|
136 | |
---|
137 | (define:-record-type message-digest |
---|
138 | (*make-message-digest mdp ctx buf) |
---|
139 | message-digest? |
---|
140 | (mdp message-digest-primitive message-digest-algorithm) |
---|
141 | (ctx message-digest-context message-digest-context) |
---|
142 | (buf (or boolean message-digest-buffer) message-digest-buffer message-digest-buffer-set!) ) |
---|
143 | |
---|
144 | (define-check+error-type message-digest) |
---|
145 | |
---|
146 | ;; |
---|
147 | |
---|
148 | (define: (get-message-digest-primitive-context (mdp message-digest-primitive)) -> * |
---|
149 | (let ( |
---|
150 | (ctx-info (message-digest-primitive-context-info mdp)) ) |
---|
151 | (if (procedure? ctx-info) |
---|
152 | (ctx-info) |
---|
153 | (set-finalizer! (allocate ctx-info) free) ) ) ) |
---|
154 | |
---|
155 | ;; |
---|
156 | |
---|
157 | (define: (initialize-message-digest (mdp message-digest-primitive)) -> message-digest |
---|
158 | (let ( |
---|
159 | (ctx |
---|
160 | (get-message-digest-primitive-context |
---|
161 | (check-message-digest-primitive 'initialize-message-digest mdp)))) |
---|
162 | ((message-digest-primitive-init mdp) ctx) |
---|
163 | (*make-message-digest mdp ctx #f) ) ) |
---|
164 | |
---|
165 | ;; |
---|
166 | |
---|
167 | (define: (finalize-message-digest (md message-digest) . (opts (list-of message-digest-result-form))) -> message-digest-result-form |
---|
168 | (let* ( |
---|
169 | (result-type |
---|
170 | (optional opts (message-digest-result-form))) |
---|
171 | (mdp |
---|
172 | (message-digest-algorithm (check-message-digest 'finalize-message-digest md))) |
---|
173 | (res |
---|
174 | (make-blob (message-digest-primitive-digest-length mdp))) ) |
---|
175 | ;side-effects res |
---|
176 | ((message-digest-primitive-final mdp) (message-digest-context md) res) |
---|
177 | (get-result-form 'finalize-message-digest res result-type) ) ) |
---|
178 | |
---|
179 | (define: (finalize-message-digest! (md message-digest) (result-buffer message-digest-buffer)) -> message-digest-result-form |
---|
180 | (let* ( |
---|
181 | (mdp |
---|
182 | (message-digest-algorithm (check-message-digest 'finalize-message-digest md))) |
---|
183 | (res |
---|
184 | (check-result-type 'finalize-message-digest mdp result-buffer)) ) |
---|
185 | ;side-effects res |
---|
186 | (let ((buf (if (u8vector? res) (##sys#slot res 1) res))) |
---|
187 | ((message-digest-primitive-final mdp) (message-digest-context md) buf) ) |
---|
188 | res ) ) |
---|
189 | |
---|
190 | ;; |
---|
191 | |
---|
192 | (define: (setup-message-digest-buffer! (md message-digest) (sz fixnum)) -> message-digest-buffer |
---|
193 | (let ( |
---|
194 | (buf (message-digest-buffer md)) |
---|
195 | (sz (fxmax sz MINIMUM-BUFFER-SIZE)) ) |
---|
196 | ;enough space? then reuse, otherwise new buffer |
---|
197 | (if buf (print "buf " buf)) |
---|
198 | (if (and buf (fx<= sz (number-of-bytes buf))) |
---|
199 | buf |
---|
200 | (new-message-digest-buffer! md sz) ) ) ) |
---|
201 | |
---|
202 | (define: (new-message-digest-buffer! (md message-digest) (sz fixnum)) -> message-digest-buffer |
---|
203 | (let ( |
---|
204 | (buf (make-blob sz)) ) |
---|
205 | (message-digest-buffer-set! md buf) |
---|
206 | buf ) ) |
---|
207 | |
---|
208 | ;;DEPRECATED |
---|
209 | |
---|
210 | (: message-digest-default-result-type (deprecated message-digest-result-form)) |
---|
211 | (define message-digest-default-result-type message-digest-result-form) |
---|
212 | |
---|
213 | ) ;module message-digest-type |
---|