source: project/release/5/crypto-tools/trunk/crypto-tools.scm @ 36348

Last change on this file since 36348 was 36348, checked in by Alaric Snell-Pym, 2 years ago

crypto-tools: Applied Vasilij Schneidermann's patch

File size: 11.4 KB
Line 
1(module crypto-tools
2(blob->hexstring blob->hexstring/uppercase hexstring->blob
3 blob-xor blob-pad blob-unpad
4 make-cbc-encryptor make-cbc-decryptor
5 make-cbc*-encryptor make-cbc*-decryptor)
6
7(import scheme)
8(import (chicken foreign))
9(import (chicken base))
10(import (chicken blob))
11(import (chicken format))
12(import (chicken memory))
13(import (chicken locative))
14
15(define *the-null-blob* (make-blob 0))
16
17(define (check-blob blob len function)
18   (if (blob? blob)
19      (if (= (blob-size blob) len)
20         (void)
21         (error (sprintf "~A: Input blob was ~A bytes long, when ~A were required" function (blob-size blob) len)))
22      (error (sprintf "~A: Input was not a blob" function))))
23
24(define (blob->hexstring blob)
25   (if (zero? (blob-size blob))
26      ""
27      (let ((str (make-string (* 2 (blob-size blob)))))
28         ((foreign-lambda* void ((blob in) (int in_len) ((c-pointer char) out)) "
29            while (in_len--) {
30               *out++ = \"0123456789abcdef\"[(*in) >> 4];
31               *out++ = \"0123456789abcdef\"[(*in) & 0x0f];
32               in++;
33            }
34            ") blob (blob-size blob) (make-locative str))
35         str)))
36
37(define (blob->hexstring/uppercase blob)
38   (if (zero? (blob-size blob))
39      ""
40      (let ((str (make-string (* 2 (blob-size blob)))))
41         ((foreign-lambda* void ((blob in) (int in_len) ((c-pointer char) out)) "
42            while (in_len--) {
43               *out++ = \"0123456789ABCDEF\"[(*in) >> 4];
44               *out++ = \"0123456789ABCDEF\"[(*in) & 0x0f];
45               in++;
46            }
47            ") blob (blob-size blob) (make-locative str))
48         str)))
49
50(define (hexstring->blob string)
51   (let ((len (string-length string)))
52      (cond
53         ((zero? len) *the-null-blob*)
54         ((odd? len)
55            (error "hexstring->blob: The supplied string must have an even length"))
56         (else
57            (let ((blob (make-blob (/ (string-length string) 2))))
58               (if ((foreign-lambda* bool (((c-pointer char) in) (int in_len) (blob out)) "
59                  while (in_len) {
60                     if (*in >= '0' && *in <= '9') *out = (*in - '0') << 4;
61                     else if (*in >= 'A' && *in <= 'F') *out = (*in - 'A' + 10) << 4;
62                     else if (*in >= 'a' && *in <= 'f') *out = (*in - 'a' + 10) << 4;
63                     else C_return(1);
64                     in++;
65           
66                     if (*in >= '0' && *in <= '9') *out |= (*in - '0');
67                     else if (*in >= 'A' && *in <= 'F') *out |= (*in - 'A' + 10);
68                     else if (*in >= 'a' && *in <= 'f') *out |= (*in - 'a' + 10);
69                     else C_return(1);
70                     in++;
71           
72                     out++;
73           
74                     in_len -= 2;
75                  }
76                  C_return(0);
77                  ") (make-locative string) (string-length string) blob)
78                  (error "hexstring->blob: Invalid character(s) in input string")
79                  blob))))))
80
81(define (subblob blob offset length)
82   (if (not (blob? blob)) (error "subblob: Argument must be a blob"))
83   (if (> (+ offset length) (blob-size blob)) (error (sprintf "subblob: Argument must be large enough: ~A bytes supplied, but cutting out ~A bytes from ~A would need ~A" (blob-size blob) length offset (+ length offset))))
84
85   (cond
86      ((and (zero? offset) (= (blob-size blob) length))
87         blob)
88      ((zero? length)
89         *the-null-blob*)
90      (else
91         (let ((out (make-blob length)))
92            (move-memory! blob out length offset 0)
93            out))))
94
95(define (blob-xor a b)
96   (if (not (blob? a)) (error "blob-xor: Arguments must be blobs of the same size"))
97   (check-blob b (blob-size a) 'blob-xor)
98   
99   (let ((out (make-blob (blob-size a))))
100      ((foreign-lambda* void ((int len) (blob a) (blob b) (blob out)) "
101         while (len--) {
102            (*out++) = (*a++) ^ (*b++);
103         }
104      ") (blob-size a) a b out)
105      out))
106
107(define (blob-pad in len)
108   (if (not (blob? in)) (error "blob-pad: Argument must be a blob"))
109   (if (>= (blob-size in) len) (error "blob-pad: Argument must be smaller than the block size"))
110   
111   (let ((out (make-blob len))
112         (inlen (blob-size in)))
113      (move-memory! in out inlen 0 0)
114      ((foreign-lambda* void ((int inlen) (int outlen) (blob in) (blob out)) "
115         out[inlen++] = 0x80;
116         while (inlen < outlen) {
117            out[inlen++] = 0x00;
118         }
119      ") inlen len in out)
120      out))
121
122(define (blob-unpad in)
123   (if (not (blob? in)) (error "blob-unpad: Argument must be a blob"))
124   (if (< (blob-size in) 1) (error "blob-unpad: Argument must be at least a byte long"))
125   (let* ((inlen (blob-size in))
126          (outlen
127             ((foreign-lambda* int ((int inlen) (blob in)) "
128                while (inlen > 0 && in[inlen] == 0x00) {
129                  inlen--;
130                }
131                if (in[inlen] != 0x80) C_return(-1);
132                C_return(inlen);
133            ") (- inlen 1) in)))
134         
135         (if (= outlen -1) (error "blob-unpad: Argument must be a validly padded blob"))
136         (if (zero? outlen) *the-null-blob*)
137         (let ((out (make-blob outlen)))
138            (move-memory! in out outlen)
139            out)))
140
141(define (make-cbc-encryptor encryptor blocksize)
142   (letrec ((encrypt (lambda (input inoffset inputsize iv output outoffset)
143         (cond
144            ((= inoffset inputsize) ; Zero bytes
145               (let* ((inblock (blob-pad *the-null-blob* blocksize))
146                      (outblock (encryptor (blob-xor iv inblock))))
147                  (move-memory! outblock output blocksize 0 outoffset)
148                  output)) ; Terminate
149            ((<= (+ inoffset blocksize) inputsize) ; Just another block
150               (let* ((inblock (subblob input inoffset blocksize))
151                      (outblock (encryptor (blob-xor iv inblock))))
152
153                  (move-memory! outblock output blocksize 0 outoffset)
154                  (encrypt input (+ inoffset blocksize) inputsize outblock output (+ outoffset blocksize)))) ; Recurse
155            (else ; Partial block
156               (let* ((inblock (blob-pad
157                        (subblob input inoffset (- inputsize inoffset))
158                        blocksize))
159                      (outblock (encryptor (blob-xor iv inblock))))
160
161                  (move-memory! outblock output blocksize 0 outoffset)
162                  output)))))) ; Terminate
163
164            (lambda (input iv)
165               (let* ((inputsize (blob-size input))
166                      (output-whole-blocks (quotient inputsize blocksize))
167                      (output-overflow (remainder inputsize blocksize))
168                      (outputsize (if (zero? output-overflow)
169                         (+ inputsize blocksize)
170                         (* (+ 1 output-whole-blocks) blocksize)))
171                      (output (make-blob outputsize)))
172                  (encrypt input 0 inputsize iv output 0)))))
173
174(define (make-cbc-decryptor decryptor blocksize)
175   (letrec ((decrypt (lambda (input inoffset inputsize iv output outoffset)
176               (if (= (+ inoffset blocksize) inputsize)
177                  ; Last block
178                  (let* ((inblock (subblob input inoffset blocksize))
179                         (outblock
180                            (blob-unpad
181                               (blob-xor iv
182                                 (decryptor inblock)))))
183                        (move-memory! outblock output (blob-size outblock) 0 outoffset)
184                        (subblob output 0 (+ outoffset (blob-size outblock)))) ; Terminate
185                  ; Not last block
186                  (let* ((inblock (subblob input inoffset blocksize))
187                         (outblock
188                            (blob-xor iv
189                              (decryptor inblock))))
190
191                        (move-memory! outblock output blocksize 0 outoffset)
192                        (decrypt input (+ inoffset blocksize) inputsize inblock output (+ outoffset blocksize))))))) ; Recurse
193
194            (lambda (input iv)
195               (let* ((inputsize (blob-size input))
196                      (output (make-blob inputsize)))
197                  (decrypt input 0 inputsize iv output 0)))))
198
199; As above, but the encryptor stores the IV in the output block (encrypted)...
200
201(define (make-cbc*-encryptor encryptor blocksize)
202   (letrec ((encrypt (lambda (input inoffset inputsize iv output outoffset)
203         (cond
204            ((= inoffset inputsize) ; Zero bytes
205               (let* ((inblock (blob-pad *the-null-blob* blocksize))
206                      (outblock (encryptor (blob-xor iv inblock))))
207                  (move-memory! outblock output blocksize 0 outoffset)
208                  output)) ; Terminate
209            ((<= (+ inoffset blocksize) inputsize) ; Just another block
210               (let* ((inblock (subblob input inoffset blocksize))
211                      (outblock (encryptor (blob-xor iv inblock))))
212
213                  (move-memory! outblock output blocksize 0 outoffset)
214                  (encrypt input (+ inoffset blocksize) inputsize outblock output (+ outoffset blocksize)))) ; Recurse
215            (else ; Partial block
216               (let* ((inblock (blob-pad
217                        (subblob input inoffset (- inputsize inoffset))
218                        blocksize))
219                      (outblock (encryptor (blob-xor iv inblock))))
220
221                  (move-memory! outblock output blocksize 0 outoffset)
222                  output)))))) ; Terminate
223
224            (lambda (input iv)
225               (let* ((inputsize (blob-size input))
226                      (output-whole-blocks (quotient inputsize blocksize))
227                      (output-overflow (remainder inputsize blocksize))
228                      (outputsize (if (zero? output-overflow) ; Round up to block size, plus an extra block for the IV
229                         (+ inputsize blocksize blocksize)
230                         (* (+ 2 output-whole-blocks) blocksize)))
231                      (output (make-blob outputsize))
232                      (encrypted-iv (encryptor iv)))
233                  (move-memory! encrypted-iv output blocksize)
234                  (encrypt input 0 inputsize iv output blocksize)))))
235
236;... and the decryptor retreives it.
237
238(define (make-cbc*-decryptor decryptor blocksize)
239   (letrec ((decrypt (lambda (input inoffset inputsize iv output outoffset)
240               (if (= (+ inoffset blocksize) inputsize)
241                  ; Last block
242                  (let* ((inblock (subblob input inoffset blocksize))
243                         (outblock
244                            (blob-unpad
245                               (blob-xor iv
246                                 (decryptor inblock)))))
247                        (move-memory! outblock output (blob-size outblock) 0 outoffset)
248                        (subblob output 0 (+ outoffset (blob-size outblock)))) ; Terminate
249                  ; Not last block
250                  (let* ((inblock (subblob input inoffset blocksize))
251                         (outblock
252                            (blob-xor iv
253                              (decryptor inblock))))
254
255                        (move-memory! outblock output blocksize 0 outoffset)
256                        (decrypt input (+ inoffset blocksize) inputsize inblock output (+ outoffset blocksize))))))) ; Recurse
257
258            (lambda (input)
259               (let* ((inputsize (blob-size input))
260                      (output (make-blob inputsize))
261                      (iv (decryptor (subblob input 0 blocksize))))
262                  (decrypt input blocksize inputsize iv output 0))))) )
Note: See TracBrowser for help on using the repository browser.