1 | ;;;; message-digest-primitive.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 | ;; - see tiger-hash , sha2 , sha1 , ripemd , md5 , hashes |
---|
10 | ;; |
---|
11 | ;; - synthesize raw-update from update |
---|
12 | |
---|
13 | (module message-digest-primitive |
---|
14 | |
---|
15 | (;export |
---|
16 | ; Algorithm API |
---|
17 | make-message-digest-primitive |
---|
18 | message-digest-primitive? check-message-digest-primitive error-message-digest-primitive |
---|
19 | message-digest-primitive-name |
---|
20 | message-digest-primitive-block-length |
---|
21 | message-digest-primitive-context-info |
---|
22 | message-digest-primitive-digest-length |
---|
23 | message-digest-primitive-init |
---|
24 | message-digest-primitive-update |
---|
25 | message-digest-primitive-final |
---|
26 | message-digest-primitive-raw-update) |
---|
27 | |
---|
28 | (import scheme chicken) |
---|
29 | |
---|
30 | (use |
---|
31 | (only type-checks |
---|
32 | define-check+error-type |
---|
33 | check-positive-fixnum |
---|
34 | check-procedure) |
---|
35 | (only type-errors |
---|
36 | error-argument-type)) |
---|
37 | |
---|
38 | ;;; Support |
---|
39 | |
---|
40 | ;; |
---|
41 | |
---|
42 | (define (positive-fixnum? obj) |
---|
43 | (and (fixnum? obj) (positive? obj)) ) |
---|
44 | |
---|
45 | (define (primitive-ctx-info? obj) |
---|
46 | (or (procedure? obj) (positive-fixnum? obj)) ) |
---|
47 | |
---|
48 | (define (primitive-name? obj) |
---|
49 | #t ) |
---|
50 | |
---|
51 | ;;; Message Digest Algorithm API |
---|
52 | |
---|
53 | ;; |
---|
54 | |
---|
55 | (define (check-message-digest-arguments loc ctx-info digest-len init update final block-len name raw-update) |
---|
56 | (unless (primitive-ctx-info? ctx-info) |
---|
57 | (error-argument-type loc ctx-info "positive-fixnum or procedure" 'context-info) ) |
---|
58 | (check-positive-fixnum loc digest-len 'digest-length) |
---|
59 | (check-procedure loc init 'digest-initializer) |
---|
60 | (check-procedure loc update 'digest-updater) |
---|
61 | (check-procedure loc final 'digest-finalizer) |
---|
62 | (check-positive-fixnum loc block-len 'block-length) |
---|
63 | (unless (primitive-name? name) |
---|
64 | (error-argument-type loc name "symbol or string" 'name) ) |
---|
65 | (when raw-update |
---|
66 | (check-procedure loc raw-update 'digest-raw-updater) ) ) |
---|
67 | |
---|
68 | ;; |
---|
69 | |
---|
70 | (define-record-type message-digest-primitive |
---|
71 | (*make-message-digest-primitive ctxi digest-len init update final block-len name raw-update) |
---|
72 | message-digest-primitive? |
---|
73 | (ctxi message-digest-primitive-context-info) |
---|
74 | (digest-len message-digest-primitive-digest-length) |
---|
75 | (init message-digest-primitive-init) |
---|
76 | (update message-digest-primitive-update) |
---|
77 | (final message-digest-primitive-final) |
---|
78 | (block-len message-digest-primitive-block-length) |
---|
79 | (name message-digest-primitive-name) |
---|
80 | (raw-update message-digest-primitive-raw-update) ) |
---|
81 | |
---|
82 | (define-check+error-type message-digest-primitive) |
---|
83 | |
---|
84 | (define (make-message-digest-primitive ctx-info digest-len init update final . rest) |
---|
85 | ; |
---|
86 | (define (pull-arg args pred defprc) |
---|
87 | (if (and (not (null? args)) (pred (car args))) |
---|
88 | (values (car args) (cdr args)) |
---|
89 | (values (defprc) args) ) ) |
---|
90 | ; |
---|
91 | (let*-values (((block-len rest) (pull-arg rest number? (lambda () 4))) |
---|
92 | ((name rest) (pull-arg rest primitive-name? (lambda () (gensym 'message-digest-primitive)))) |
---|
93 | ((raw-update rest) (pull-arg rest procedure? (lambda () #f))) ) |
---|
94 | (check-message-digest-arguments 'make-message-digest-primitive |
---|
95 | ctx-info digest-len init update final block-len name raw-update) |
---|
96 | (*make-message-digest-primitive |
---|
97 | ctx-info digest-len |
---|
98 | init update final |
---|
99 | block-len |
---|
100 | name |
---|
101 | raw-update) ) ) |
---|
102 | |
---|
103 | ) ;module message-digest-primitive |
---|