source: project/release/5/message-digest-type/tags/4.0.1/message-digest-type.scm @ 35919

Last change on this file since 35919 was 35919, checked in by Kon Lovett, 2 years ago

rel 4.0.1

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