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

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

add types to -chunk, bix -bv use before -check, rmv fx-utils dep (in mathh), add typed-define dep (in dsssl-utils), rmv dup type

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