1 | ;;;; message-digest-port.scm |
---|
2 | ;;;; Kon Lovett, May '10 |
---|
3 | ;;;; Kon Lovett, Aug '17 |
---|
4 | |
---|
5 | ;; Issues |
---|
6 | ;; |
---|
7 | ;; - Use of sys namespace routines. |
---|
8 | |
---|
9 | (module message-digest-port |
---|
10 | |
---|
11 | (;export |
---|
12 | digest-output-port? check-digest-output-port error-digest-output-port |
---|
13 | digest-output-port-name |
---|
14 | open-output-digest |
---|
15 | get-output-digest |
---|
16 | call-with-output-digest |
---|
17 | with-output-to-digest) |
---|
18 | |
---|
19 | (import scheme chicken) |
---|
20 | |
---|
21 | (use |
---|
22 | (only data-structures ->string) |
---|
23 | (only ports make-output-port with-input-from-port) |
---|
24 | (only srfi-13 string-suffix-length-ci) |
---|
25 | (only type-checks define-check+error-type check-output-port) |
---|
26 | (only type-errors error-argument-type make-error-type-message signal-type-error) |
---|
27 | message-digest-primitive |
---|
28 | message-digest-type |
---|
29 | message-digest-bv) |
---|
30 | |
---|
31 | ;;; Message Digest Output Port API |
---|
32 | |
---|
33 | ; |
---|
34 | (define (%port-type p) (##sys#slot p 7)) |
---|
35 | (define (%port-type-set! p t) (##sys#setslot p 7 t)) |
---|
36 | |
---|
37 | ; |
---|
38 | (define (%port-name p) (##sys#slot p 3)) |
---|
39 | (define (%port-name-set! p s) (##sys#setslot p 3 s)) |
---|
40 | |
---|
41 | ; |
---|
42 | (define (check-open-port loc obj #!optional argnam) |
---|
43 | (if (port-closed? obj) |
---|
44 | (error-argument-type loc obj "open port" argnam) |
---|
45 | obj ) ) |
---|
46 | |
---|
47 | ; |
---|
48 | (define (check-open-digest-output-port loc obj #!optional argnam) |
---|
49 | (let ((pt (%port-type (check-open-port loc (check-output-port loc obj argnam) argnam)))) |
---|
50 | (unless (eq? 'digest pt) |
---|
51 | (signal-type-error loc (make-error-type-message 'digest-output-port) obj argnam) ) ) |
---|
52 | obj ) |
---|
53 | |
---|
54 | ; Synthesize a port-name from a primitive-name |
---|
55 | (define (make-digest-port-name mdp) |
---|
56 | (let* ((nam (->string (or (message-digest-primitive-name mdp) 'digest)) ) |
---|
57 | (remlen (string-suffix-length-ci nam "-primitive") ) ) |
---|
58 | (string-append |
---|
59 | "(" |
---|
60 | (if (positive? remlen) |
---|
61 | (substring nam 0 (fx- (string-length nam) remlen)) |
---|
62 | nam ) |
---|
63 | ")") ) ) |
---|
64 | |
---|
65 | ;; Returns a digest-output-port for the MDP |
---|
66 | |
---|
67 | (define (open-output-digest mdp) |
---|
68 | (let* ((md (initialize-message-digest mdp) ) |
---|
69 | (writer |
---|
70 | (lambda (obj) |
---|
71 | ;it will only ever be a string for now |
---|
72 | (if (string? obj) |
---|
73 | (message-digest-update-string md obj) |
---|
74 | (message-digest-update-blob md obj))) ) |
---|
75 | (port (make-output-port writer void) ) ) ;use default close behavior |
---|
76 | (##sys#set-port-data! port md) |
---|
77 | (%port-type-set! port 'digest) |
---|
78 | (%port-name-set! port (make-digest-port-name mdp)) |
---|
79 | port ) ) |
---|
80 | |
---|
81 | (define (digest-output-port? obj) |
---|
82 | (and |
---|
83 | (output-port? obj) |
---|
84 | (eq? 'digest (%port-type obj)) ) ) |
---|
85 | |
---|
86 | (define-check+error-type digest-output-port) |
---|
87 | |
---|
88 | (define (digest-output-port-name p) |
---|
89 | (%port-name (check-digest-output-port 'digest-output-port-name p)) ) |
---|
90 | |
---|
91 | ;; Finalizes the digest-output-port and returns the result in the form requested |
---|
92 | |
---|
93 | (define (*close-output-digest loc digest-port result-type) |
---|
94 | (let ((res |
---|
95 | (finalize-message-digest |
---|
96 | (##sys#port-data (check-open-digest-output-port loc digest-port 'digest-port)) |
---|
97 | result-type))) |
---|
98 | (close-output-port digest-port) |
---|
99 | res ) ) |
---|
100 | |
---|
101 | (define (get-output-digest digest-port #!optional (result-type (message-digest-result-form))) |
---|
102 | (*close-output-digest 'get-output-digest digest-port result-type) ) |
---|
103 | |
---|
104 | ;;; |
---|
105 | |
---|
106 | ;; Calls the procedure PROC with a single argument that is a digest-output-port for the MDP. |
---|
107 | ;; Returns the accumulated output string | blob | u8vector | hexstring |
---|
108 | |
---|
109 | (define (call-with-output-digest mdp proc #!optional (result-type (message-digest-result-form))) |
---|
110 | (let ((port (open-output-digest mdp))) |
---|
111 | (proc port) |
---|
112 | (*close-output-digest 'call-with-output-digest port result-type) ) ) |
---|
113 | |
---|
114 | ;; Calls the procedure THUNK with the current-input-port temporarily bound to a |
---|
115 | ;; digest-output-port for the MDP. |
---|
116 | ;; Returns the accumulated output string | blob | u8vector | hexstring |
---|
117 | |
---|
118 | (define (with-output-to-digest mdp thunk #!optional (result-type (message-digest-result-form))) |
---|
119 | (call-with-output-digest mdp (cut with-input-from-port <> thunk) result-type) ) |
---|
120 | |
---|
121 | ) ;module message-digest |
---|