source: project/release/4/message-digest/trunk/message-digest-type.scm @ 35341

Last change on this file since 35341 was 35341, checked in by kon, 16 months ago

add types, message-digest-result-form -> -type, -form is symbol, -byte-order is symbol, do not type check-/error- (no no no no no)

File size: 6.3 KB
Line 
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;;
45
46(include "message-digest-types")
47
48;;
49
50(define-constant MINIMUM-BUFFER-SIZE 8)
51
52#; ;CHICKEN 4.8.0.5 has an issue here
53(define-constant DEFAULT-RESULT-TYPE 'hex-string)
54
55;-> *
56(define (error-result-form loc obj)
57  (error-argument-type loc obj "symbol in {string hex blob u8vector}" 'result-form) )
58
59;perform any conversion necessary for final result representation
60;assumes blob 'res' may not be of result size
61
62(define: (get-result-form (loc symbol) (res blob) (restyp message-digest-result-form)) -> message-digest-result-type
63  (case (canonical-result-name restyp)
64    ((blob)           res )
65    ((byte-string)    (blob->string res) )
66    ((hex-string)     (blob->hex res) )
67    ((u8vector)       (blob->u8vector/shared res) )
68    (else
69      (error-result-form loc restyp) ) ) )
70
71#;
72(define: (get-result-form (loc symbol) (res blob) (restyp message-digest-result-form)) -> message-digest-result-type
73  (case restyp
74    ((blob)
75      (if (fx= len (blob-size res)) res
76        (string->blob (substring (blob->string res) 0 len)) ) )
77    ((byte-string string)
78      (let ((str (blob->string res)))
79        (if (fx= len (string-length str)) str
80          (substring str 0 len) ) ) )
81    ((hex-string hex hexstring)
82      (blob->hex res 0 len) )
83    ((u8vector)
84      (let ((vec (blob->u8vector/shared res)))
85        (if (fx= len (u8vector-length vec)) vec
86          (subu8vector vec 0 len) ) ) )
87    (else
88      (error-result-form loc restyp) ) ) )
89
90(define: (canonical-result-name (x message-digest-result-form)) -> (or boolean message-digest-result-form)
91  (case x
92    ((blob)                       'blob )
93    ((byte-string string)         'byte-string )
94    ((hex-string hex hexstring)   'hex-string )
95    ((u8vector)                   'u8vector )
96    (else
97      #f ) ) )
98
99(define: (check-result-type (loc symbol) (mdp message-digest-primitive) (obj message-digest-result-type)) -> message-digest-result-type
100  (let (
101    (siz
102      (cond
103        ((string? obj)
104          (string-length obj))
105        ((blob? obj)
106          (blob-size obj))
107        ((u8vector? obj)
108          (u8vector-length obj))
109        (else
110          (error loc "unsupported result buffer" obj) ) ) )
111      (rqr (message-digest-primitive-digest-length mdp)) )
112    ;
113    (unless (<= rqr siz)
114      (error loc "result buffer too small" rqr obj) ) )
115  obj )
116
117;;; Message Digest API
118
119;;
120
121(: message-digest-result-form (#!optional message-digest-result-form -> message-digest-result-form))
122;
123(define-parameter message-digest-result-form #;DEFAULT-RESULT-TYPE 'hex-string
124  (lambda (x)
125    (or
126      (if x
127        (canonical-result-name x)
128        (begin
129          (warning 'message-digest-result-form "invalid result-form" x)
130          (message-digest-result-form) ) ) ) ) )
131
132;;
133
134(define:-record-type message-digest
135  (*make-message-digest mdp ctx buf)
136  message-digest?
137  (mdp message-digest-primitive message-digest-algorithm)
138  (ctx message-digest-context message-digest-context)
139  (buf (or boolean message-digest-buffer) message-digest-buffer message-digest-buffer-set!) )
140
141(define-check+error-type message-digest)
142
143;;
144
145(define: (get-message-digest-primitive-context (mdp message-digest-primitive)) -> *
146  (let (
147    (ctx-info (message-digest-primitive-context-info mdp)) )
148    (if (procedure? ctx-info)
149      (ctx-info)
150      (set-finalizer! (allocate ctx-info) free) ) ) )
151
152;;
153
154(define: (initialize-message-digest (mdp message-digest-primitive)) -> message-digest
155  (let (
156    (ctx
157      (get-message-digest-primitive-context
158        (check-message-digest-primitive 'initialize-message-digest mdp))))
159    ((message-digest-primitive-init mdp) ctx)
160    (*make-message-digest mdp ctx #f) ) )
161
162;;
163
164(define: (finalize-message-digest (md message-digest) . (opts (list message-digest-result-type))) -> message-digest-result-type
165  (let* (
166    (restyp (optional opts (message-digest-result-form)))
167    (mdp (message-digest-algorithm (check-message-digest 'finalize-message-digest md)))
168    (res (make-blob (message-digest-primitive-digest-length mdp))) )
169    ;side-effects res
170    ((message-digest-primitive-final mdp) (message-digest-context md) res)
171    (get-result-form 'finalize-message-digest res restyp) ) )
172
173(define: (finalize-message-digest! (md message-digest) (result-buffer message-digest-buffer)) -> message-digest-result-type
174  (let* (
175    (mdp
176      (message-digest-algorithm (check-message-digest 'finalize-message-digest md)))
177    (res
178      (check-result-type 'finalize-message-digest mdp result-buffer)) )
179    ;side-effects res
180    (let ((buf (if (u8vector? res) (##sys#slot res 1) res)))
181      ((message-digest-primitive-final mdp) (message-digest-context md) buf) )
182    res ) )
183
184;;
185
186(define: (setup-message-digest-buffer! (md message-digest) (sz fixnum)) -> message-digest-buffer
187  (let (
188    (buf (message-digest-buffer md))
189    (sz (fxmax sz MINIMUM-BUFFER-SIZE)) )
190    ;enough space? then reuse, otherwise new buffer
191    (if (and buf (fx<= sz (number-of-bytes buf)))
192      buf
193      (new-message-digest-buffer! md sz) ) ) )
194
195(define: (new-message-digest-buffer! (md message-digest) (sz fixnum)) -> message-digest-buffer
196  (let (
197    (buf (make-blob sz)) )
198    (message-digest-buffer-set! md buf)
199    buf ) )
200
201;;DEPRECATED
202
203(: message-digest-default-result-type (deprecated message-digest-result-form))
204(define message-digest-default-result-type message-digest-result-form)
205
206) ;module message-digest-type
Note: See TracBrowser for help on using the repository browser.