source: project/release/4/crypto-tools/trunk/crypto-tools.scm @ 15239

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

Initial import of chicken3 egg

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