source: project/message-digest/trunk/message-digest.scm @ 5581

Last change on this file since 5581 was 5581, checked in by Kon Lovett, 12 years ago

wiki doc!

File size: 7.8 KB
Line 
1;;;; message-digest.scm
2;;;; Kon Lovett, Jan '06
3
4;; Issues
5;;
6;; - Caches the bindings of R5RS & SRFI-13 string procedures so byte-oriented!
7
8(use extras srfi-1 srfi-4 srfi-9 srfi-13 srfi-69 lolevel)
9(use mathh-int miscmacros)
10
11(eval-when (compile)
12        (declare
13                (not usual-integrations
14                        inexact->exact integer? round number? modulo)
15                (fixnum)
16                (inline)
17                (no-procedure-checks)
18                (no-bound-checks)
19                (constant
20                        ->fixnum
21                        ->blob
22                        ->blob/shared
23                        byte-string->hexadecimal)
24                (export
25                  ; Deperecated
26                        string->substring-list/shared
27                        string->substring-list
28                        string->hexadecimal
29                        ->byte-vector
30                        ;
31                        byte-string->substring-list/shared
32                        byte-string->substring-list
33                        byte-string->hexadecimal
34                        ->blob
35                        ->blob/shared
36                        message-digest-chunk-size
37                        make-binary-message-digest
38                        make-message-digest
39                        make-message-digest-primitive
40                        message-digest-primitive?
41                        message-digest-primitive-name
42                        message-digest-primitive-context-info
43                        message-digest-primitive-digest-length
44                        message-digest-primitive-init
45                        message-digest-primitive-update
46                        message-digest-primitive-final
47                        message-digest-primitive-apply) ) )
48
49;;;
50
51(define (check-procedure obj loc)
52  (unless (procedure? obj)
53    (error loc "invalid procedure" obj) ) )
54
55;;;
56
57(define byte-string->substring-list/shared
58        (let ([byte-string-length string-length]
59                                [byte-substring/shared substring/shared])
60                (lambda (str chunk-size #!optional (start 0) (end (byte-string-length str)))
61                        (let* (
62                                        [rem (remainder (- end start) chunk-size)]
63                                        [len (- end rem)]
64                                        [sublst
65                                                (let loop ([pos start] [lst '()])
66                                                        (if (>= pos len)
67                                                                (reverse! lst)
68                                                                (let ([npos (+ pos chunk-size)])
69                                                                        (loop npos (cons (byte-substring/shared str pos npos) lst)))))])
70                                        (or (and (zero? rem) sublst)
71                                                        (append sublst (list (byte-substring/shared str len end))) ) ) ) ) )
72
73(define byte-string->substring-list
74        (let ([byte-string-length string-length])
75                (lambda (str chunk-size #!optional (start 0) (end (byte-string-length str)))
76                        (map! string-copy (byte-string->substring-list/shared str chunk-size start end)) ) ) )
77
78(define byte-string->hexadecimal
79        (let ([byte-string-length string-length]
80                                [byte-string-for-each string-for-each])
81                (lambda (str . len)
82                        (with-output-to-string
83                                (lambda ()
84                                        (byte-string-for-each
85                                                (lambda (char)
86                                                        (let ([int (char->integer char)])
87                                                                (printf (if (>= int 16) "~X" "0~X") int)))
88                                                str
89                                                0 (optional len (byte-string-length str))))) ) ) )
90
91;;;
92
93;; This is approximate at best!
94
95(define (->fixnum obj)
96        (let (
97                        [->integer
98                                (lambda (obj)
99                                        (cond [(integer? obj)   obj]
100                [(number? obj)    (round obj)]
101                [else             (hash obj most-positive-fixnum)]) )])
102                (cond [(fixnum? obj)    obj]
103          [(char? obj)      (char->integer obj)]
104          [(boolean? obj)   (or (and obj 1) 0)]
105          [else
106            (let ([i (->integer obj)])
107              (inexact->exact
108                (cond [(< i most-negative-fixnum)   (modulo i most-negative-fixnum)]
109                      [(< most-positive-fixnum i)   (modulo i most-positive-fixnum)]
110                      [else                         i ] ) ) ) ]) ) )
111
112(define ->blob
113  (let ([list->byte-string list->string])
114    (lambda (obj)
115      (cond [(blob? obj)            obj]
116            [(string? obj)          (string->blob obj)]
117            [(list? obj)            (->blob (list->byte-string (map ->fixnum obj)))]
118            [(vector? obj)          (->blob (vector->list obj))]
119            [(u8vector? obj)        (u8vector->blob obj)]
120            [(s8vector? obj)        (s8vector->blob obj)]
121            [(u16vector? obj)       (u16vector->blob obj)]
122            [(s16vector? obj)       (s16vector->blob obj)]
123            [(u32vector? obj)       (u32vector->blob obj)]
124            [(s32vector? obj)       (s32vector->blob obj)]
125            [(f32vector? obj)       (f32vector->blob obj)]
126            [(f64vector? obj)       (f64vector->blob obj)]
127            [else                   #f ] ) ) ) )
128
129(define (->blob/shared obj)
130  (cond [(u8vector? obj)        (u8vector->blob/shared obj)]
131        [(s8vector? obj)        (s8vector->blob/shared obj)]
132        [(u16vector? obj)       (u16vector->blob/shared obj)]
133        [(s16vector? obj)       (s16vector->blob/shared obj)]
134        [(u32vector? obj)       (u32vector->blob/shared obj)]
135        [(s32vector? obj)       (s32vector->blob/shared obj)]
136        [(f32vector? obj)       (f32vector->blob/shared obj)]
137        [(f64vector? obj)       (f64vector->blob/shared obj)]
138        [else                   (->blob obj) ] ) )
139
140;;;
141
142(define-constant CHUNK-SIZE 1024)
143
144(define-parameter message-digest-chunk-size CHUNK-SIZE
145  (lambda (x)
146    (if (and (fixnum? x) (positive? x))
147        x
148        (begin
149          (warning "invalid message-digest chunk-size" x)
150          (message-digest-chunk-size) ) ) ) )
151
152(define-record-type message-digest-primitive
153        (%make-message-digest-primitive ctx-info digest-len init update final name)
154        message-digest-primitive?
155        (ctx-info message-digest-primitive-context-info)
156        (digest-len message-digest-primitive-digest-length)
157        (init message-digest-primitive-init)
158        (update message-digest-primitive-update)
159        (final message-digest-primitive-final)
160        (name message-digest-primitive-name) )
161
162(define make-binary-message-digest
163        (let ([byte-string-length string-length]
164                                [make-byte-string make-string])
165                (lambda (obj ctx-info digest-len init update final . caller)
166      (check-procedure init 'make-binary-message-digest)
167      (check-procedure update 'make-binary-message-digest)
168      (check-procedure final 'make-binary-message-digest)
169                        (let ([loc (optional caller 'make-binary-message-digest)]
170                                                [ctx #f])
171                                (dynamic-wind
172                                        (lambda ()
173                                                (set! ctx
174                                                        (cond [(fixnum? ctx-info)     (allocate ctx-info)]
175                    [(procedure? ctx-info)  (ctx-info)]
176                    [else
177                      (error loc "invalid context information" ctx-info)])))
178                                        (lambda ()
179                                                (init ctx)
180                                                (cond [(string? obj)
181                    (update ctx obj (byte-string-length obj))]
182                  [(input-port? obj)
183                   (let* ([siz (message-digest-chunk-size)]
184                          [buf (make-u8vector siz)])
185                     (while* (let ([len (read-u8vector! siz buf obj)]) (and (positive? len) len))
186                       (update ctx buf it) ) ) ]
187                  [else
188                    (if* (->blob/shared obj)
189                      (update ctx it (blob-size it))
190                      (error loc "cannot convert to blob" obj))])
191                                                (let ([result (make-byte-string digest-len)])
192                                                        (final ctx result)
193                                                        result))
194                                        (lambda ()
195                                                (when (fixnum? ctx-info)
196                                                        (free ctx) ) ) ) ) ) ) )
197
198(define (make-message-digest obj ctx-info digest-len init update final . caller)
199        (string->hexadecimal
200                (make-binary-message-digest obj
201                        ctx-info digest-len
202                        init update final
203                        (optional caller 'make-message-digest))
204                digest-len) )
205
206(define (make-message-digest-primitive ctx-info digest-len init update final . name)
207        (%make-message-digest-primitive
208                ctx-info digest-len
209                init update final
210                (optional name (gensym "mdp"))) )
211
212(define (message-digest-primitive-apply md-prim obj . caller)
213        (unless (message-digest-primitive? md-prim)
214                (error 'message-digest-primitive-apply "not a message-digest-primitive" md-prim))
215        (make-binary-message-digest obj
216                (message-digest-primitive-context-info md-prim)
217                (message-digest-primitive-digest-length md-prim)
218                (message-digest-primitive-init md-prim)
219                (message-digest-primitive-update md-prim)
220                (message-digest-primitive-final md-prim)
221                (optional caller 'message-digest-primitive-apply)) )
222
223;;;
224
225(define string->substring-list/shared byte-string->substring-list/shared)
226(define string->substring-list byte-string->substring-list)
227(define string->hexadecimal byte-string->hexadecimal)
228(define ->byte-vector ->blob)
Note: See TracBrowser for help on using the repository browser.