source: project/release/5/message-digest-type/tags/4.2.1/message-digest-type.scm @ 38985

Last change on this file since 38985 was 38985, checked in by Kon Lovett, 7 weeks ago

rel 4.2.1

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