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

Last change on this file since 35338 was 35338, checked in by kon, 7 months ago

use typed-define, add types

File size: 6.4 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(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
Note: See TracBrowser for help on using the repository browser.