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 |
---|