source: project/release/4/message-digest/tags/3.8.0/message-digest-type.scm @ 35045

Last change on this file since 35045 was 35045, checked in by kon, 5 months ago

rel 3.8.0

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