source: project/release/5/message-digest-type/trunk/message-digest-type.scm @ 37389

Last change on this file since 37389 was 37389, checked in by Kon Lovett, 21 months ago

comment

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