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

Last change on this file since 38658 was 38658, checked in by Alaric Snell-Pym, 9 months ago

Applied patch from dsp (against original c4 version)

File size: 16.8 KB
Line 
1(module crypto-tools
2(blob->hexstring blob->hexstring/uppercase hexstring->blob
3 blob-xor blob-pad blob-unpad blob-pkcs5-pad blob-pkcs5-unpad no-pad no-unpad
4 make-cbc-encryptor make-cbc-decryptor make-cbc*-encryptor make-cbc*-decryptor
5 make-ctr-encryptor make-ctr-decryptor make-ctr*-encryptor make-ctr*-decryptor)
6
7(import scheme)
8(import (chicken foreign))
9(import (chicken blob))
10(import (chicken base))
11(import (chicken format))
12(import (chicken locative))
13(import (chicken memory))
14
15;zero sizes blob
16(define *the-null-blob* (make-blob 0))
17
18;ensures the input is a blob of certain size
19(define (check-blob blob len function)
20   (if (blob? blob)
21      (if (= (blob-size blob) len)
22         (void)
23         (error (sprintf "~A: Input blob was ~A bytes long, when ~A were required" function (blob-size blob) len)))
24      (error (sprintf "~A: Input was not a blob" function))))
25
26;allocates a new string where every byte of the blob is encoded as a two char hex number
27(define (blob->hexstring blob)
28   (if (zero? (blob-size blob))
29      ""
30      (let ((str (make-string (* 2 (blob-size blob)))))
31         ((foreign-lambda* void ((blob in) (int in_len) ((c-pointer char) out)) "
32            while (in_len--) {
33               *out++ = \"0123456789abcdef\"[(*in) >> 4];
34               *out++ = \"0123456789abcdef\"[(*in) & 0x0f];
35               in++;
36            }
37            ") blob (blob-size blob) (make-locative str))
38         str)))
39
40;same as blob->hexstring but with uppercase hex chars
41(define (blob->hexstring/uppercase blob)
42   (if (zero? (blob-size blob))
43      ""
44      (let ((str (make-string (* 2 (blob-size blob)))))
45         ((foreign-lambda* void ((blob in) (int in_len) ((c-pointer char) out)) "
46            while (in_len--) {
47               *out++ = \"0123456789ABCDEF\"[(*in) >> 4];
48               *out++ = \"0123456789ABCDEF\"[(*in) & 0x0f];
49               in++;
50            }
51            ") blob (blob-size blob) (make-locative str))
52         str)))
53
54;converts a hex encoded string of two chars per byte to a blob
55(define (hexstring->blob string)
56   (let ((len (string-length string)))
57      (cond
58         ((zero? len) *the-null-blob*)
59         ((odd? len)
60            (error "hexstring->blob: The supplied string must have an even length"))
61         (else
62            (let ((blob (make-blob (/ (string-length string) 2))))
63               (if ((foreign-lambda* bool (((c-pointer char) in) (int in_len) (blob out)) "
64                  while (in_len) {
65                     if (*in >= '0' && *in <= '9') *out = (*in - '0') << 4;
66                     else if (*in >= 'A' && *in <= 'F') *out = (*in - 'A' + 10) << 4;
67                     else if (*in >= 'a' && *in <= 'f') *out = (*in - 'a' + 10) << 4;
68                     else C_return(1);
69                     in++;
70           
71                     if (*in >= '0' && *in <= '9') *out |= (*in - '0');
72                     else if (*in >= 'A' && *in <= 'F') *out |= (*in - 'A' + 10);
73                     else if (*in >= 'a' && *in <= 'f') *out |= (*in - 'a' + 10);
74                     else C_return(1);
75                     in++;
76           
77                     out++;
78           
79                     in_len -= 2;
80                  }
81                  C_return(0);
82                  ") (make-locative string) (string-length string) blob)
83                  (error "hexstring->blob: Invalid character(s) in input string")
84                  blob))))))
85
86;makes a new blob and copies in it part of the contents of the original
87(define (subblob blob offset length)
88   (if (not (blob? blob)) (error "subblob: Argument must be a blob"))
89   (if (> (+ offset length) (blob-size blob))
90       (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))))
91       (cond
92         ((and (zero? offset) (= (blob-size blob) length))
93          blob)
94         ((zero? length)
95          *the-null-blob*)
96         (else
97           (let ((out (make-blob length)))
98             (move-memory! blob out length offset 0)
99              out))))
100
101;makes a new blob with contetns the xor of the arguments up to the length of the smallest one.
102(define (blob-xor a b)
103   (if (not (blob? a)) (error "blob-xor: Arguments must be blobs"))
104   (if (= (blob-size a) 0) b)
105   (if (= (blob-size b) 0) a)
106   ;(check-blob b (blob-size a) 'blob-xor)
107   (let* ((minlen (min (blob-size a) (blob-size b)))
108          (out (make-blob minlen)))
109      ((foreign-lambda* void ((int len) (blob a) (blob b) (blob out)) "
110         while (len--) {
111            (*out++) = (*a++) ^ (*b++);
112         }
113      ") minlen a b out)
114      out))
115
116;pads a blob with the a value of the number of bytes of that pad.
117;in case a whole blocklength was added then the padvalue is that blocklength.
118;that means that a pad is always present.
119(define (blob-pkcs5-pad in len)
120  (if (not (blob? in)) (error "blob-pkcs5-pad: Argument must be a blob"))
121  (let* ((inlen (blob-size in))
122         (extrabytes (remainder inlen len))
123         (padsz (if (zero? extrabytes) len extrabytes))
124         (totlen (+ inlen padsz))
125         (out (make-blob (+ inlen padsz))))
126    (move-memory! in out inlen 0 0)
127    ((foreign-lambda* void ((int inlen) (int outlen) (int padnum) (blob out)) "
128       while (inlen < outlen) {
129           out[inlen++ - 1] = (char)padnum;
130       }
131    ") inlen totlen padsz out)
132    out))
133
134;unpads by reading the last byte and removing as many as its value
135(define (blob-pkcs5-unpad in)
136  (if (not (blob? in)) (error "blob-pkcs5-unpad: Argument must be a blob"))
137  (let* ((inlen (blob-size in))
138         (padsz ((foreign-lambda* int ((blob in) (int inlen)) "
139                   char sz;
140                   sz = in[inlen-1];
141                   C_return((int)sz);
142                ") in inlen)))
143    (if (or (<= padsz 0) (> padsz inlen)) (error "blob-pkcs5-unpad: Argument must be a validly padded blob. Got:" padsz " insize:" inlen))
144    (let* ((outlen (- inlen padsz))
145           (out (make-blob outlen)))
146      (move-memory! in out outlen)
147      out)))
148
149;noop. returns the input as is without padding
150(define (no-pad in len) in)
151;noop, returns the input without unpadding
152(define (no-unpad in) in)
153
154;pads by adding the byte 0x80 followed by 0x00 up to the desired length.
155(define (blob-pad in len)
156   (if (not (blob? in)) (error "blob-pad: Argument must be a blob"))
157   (if (>= (blob-size in) len) (error "blob-pad: Argument must be smaller than the block size"))
158   (let ((out (make-blob len))
159         (inlen (blob-size in)))
160      (move-memory! in out inlen 0 0)
161      ((foreign-lambda* void ((int inlen) (int outlen) (blob in) (blob out)) "
162         out[inlen++] = 0x80;
163         while (inlen < outlen) {
164            out[inlen++] = 0x00;
165         }
166      ") inlen len in out)
167      out))
168
169;unpads by removing 0x00 until it discovers a 0x80 byte
170(define (blob-unpad in)
171   (if (not (blob? in)) (error "blob-unpad: Argument must be a blob"))
172   (if (< (blob-size in) 1) (error "blob-unpad: Argument must be at least a byte long"))
173   (let* ((inlen (blob-size in))
174          (outlen
175             ((foreign-lambda* int ((int inlen) (blob in)) "
176                while (inlen > 0 && in[inlen] == 0x00) {
177                  inlen--;
178                }
179                if (in[inlen] != 0x80) C_return(-1);
180                C_return(inlen);
181            ") (- inlen 1) in)))
182         
183         (if (= outlen -1) (error "blob-unpad: Argument must be a validly padded blob"))
184         (if (zero? outlen) *the-null-blob*)
185         (let ((out (make-blob outlen)))
186            (move-memory! in out outlen)
187            out)))
188
189;holds the state of the counter needed for ctr-mode. On every invocation of the resulting
190;function the value of the counter will be increased by one.On completion it should wrap around.
191(define (make-next-ctr iv bsize)
192          (let ((cnt iv)
193                (incblob (foreign-lambda* void ((blob in) (blob out) (int blocksize)) "
194                           unsigned char cur;
195                           int block;
196                           memmove(out,in,blocksize);
197                           for(block=blocksize-1;block>=0;block--) {
198                                cur = in[block];
199                                if (cur >= 0xFF) {
200                                      out[block] = 0;
201                                      continue;
202                                }
203                                out[block] = cur+1;
204                                break;
205                         }
206                     ")))
207            (lambda ()
208                (let* ((ocnt cnt)
209                      (ncnt (make-blob bsize)))
210                      (incblob ocnt ncnt bsize)
211                      (set! cnt ncnt)
212                      ocnt))))
213
214;internal ctr-encrypt function used by the make- variants
215;on each block fetches the current counter state (which increases the counter)
216;encrypts it and xor as much blob as it has available.
217(define (ctr-encrypt input inoffset inputsize nextfn output outoffset encryptor blocksize) 
218  (cond
219     ((= inoffset inputsize) output) ; we just output what we have.
220     ((<= (+ inoffset blocksize) inputsize) ; Just another block
221        (let* ((inblock (subblob input inoffset blocksize))
222               (outblock (blob-xor inblock (encryptor (nextfn)))))
223           (move-memory! outblock output blocksize 0 outoffset)
224           (ctr-encrypt input (+ inoffset blocksize) inputsize nextfn output (+ outoffset blocksize) encryptor blocksize))) ; Recurse
225     (else ; Partial block
226        (let* ((inblock (subblob input inoffset (- inputsize inoffset)))
227               (outblock (blob-xor inblock (encryptor (nextfn)))))
228           (move-memory! outblock output (blob-size outblock) 0 outoffset)
229           output))))
230
231;creates a ctr encryptor that needs an iv and input blob
232(define (make-ctr-encryptor encryptor blocksize)
233  (lambda (input iv)
234     (let* ((inputsize (blob-size input))
235            (outputsize inputsize) ;ct size since no iv and no padding.
236            (output (make-blob outputsize))
237            (nextf (make-next-ctr iv blocksize)))
238        (ctr-encrypt input 0 inputsize nextf output 0 encryptor blocksize))))
239
240;creates a ctr encryptor function that needs an iv and input blob but
241;stores the IV in the first output block (unencrypted since ctr iv is only a counter)
242(define (make-ctr*-encryptor encryptor blocksize)
243  (lambda (input iv)
244     (let* ((inputsize (blob-size input))
245            (outputsize (+ inputsize blocksize)) ;iv + ct cause ctr doesn't need padding.
246            (output (make-blob outputsize))
247            (nextf (make-next-ctr iv blocksize)))
248        (move-memory! iv output blocksize)
249        (ctr-encrypt input 0 inputsize nextf output blocksize encryptor blocksize))))
250
251;internal ctr-decrypt function used by the make- variants
252;gets the current state of the counter (which increases the counter) and then
253;*encrypts* the counter and xors that with as much blob as it has.
254(define (ctr-decrypt input inoffset inputsize nextfn output outoffset encryptor blocksize)
255  (if (> (+ inoffset blocksize) inputsize)
256     ; Last block
257     (let* ((inblock (subblob input inoffset (- (blob-size input) inoffset)))
258            (outblock
259                (blob-xor inblock
260                  (encryptor (nextfn)))))
261           (move-memory! outblock output (blob-size outblock) 0 outoffset)
262           (subblob output 0 (+ outoffset (- (blob-size input) inoffset)))) ; Terminate
263     ; More blocks following
264     (let* ((inblock (subblob input inoffset blocksize))
265            (outblock
266               (blob-xor inblock
267                 (encryptor (nextfn)))))
268           (move-memory! outblock output blocksize 0 outoffset)
269           (ctr-decrypt input (+ inoffset blocksize) inputsize nextfn output (+ outoffset blocksize) encryptor blocksize)))) ; Recurse
270
271;returns a function that requires an input and an iv. it starts decrypting from the first blob.
272;typically ctr mode decryption requires an *encryptor*
273(define (make-ctr-decryptor encryptor blocksize)
274  (lambda (input iv)
275     (let* ((inputsize (blob-size input))
276            (output (make-blob inputsize))
277            (nextf (make-next-ctr iv blocksize)))
278        (ctr-decrypt input 0 inputsize nextf output 0 encryptor blocksize))))
279
280;returns a function that requires an input. it reads the unencrypted iv from the first block
281;and then uses that to start decrypting in ctr mode the blob that follows.
282;typically ctr mode decryption requires an *encryptor*
283(define (make-ctr*-decryptor encryptor blocksize)
284  (lambda (input)
285     (let* ((inputsize (blob-size input))
286            (output (make-blob inputsize))
287            (iv (subblob input 0 blocksize))
288            (nextf (make-next-ctr iv blocksize)))
289        (ctr-decrypt input blocksize inputsize nextf output 0 encryptor blocksize))))
290
291;internal cbc encrypt function used by the make- variants. cbc tradionally requires padding
292(define (cbc-encrypt input inoffset inputsize iv output outoffset padfn encryptor blocksize)
293    (cond
294      ((= inoffset inputsize) ; Zero bytes
295         (let* ((inblock (padfn *the-null-blob* blocksize))
296                (outblock (encryptor (blob-xor iv inblock))))
297            (move-memory! outblock output blocksize 0 outoffset)
298            output)) ; Terminate
299      ((<= (+ inoffset blocksize) inputsize) ; Just another block
300         (let* ((inblock (subblob input inoffset blocksize))
301                (outblock (encryptor (blob-xor iv inblock))))
302            (move-memory! outblock output blocksize 0 outoffset)
303            (cbc-encrypt input (+ inoffset blocksize) inputsize outblock output (+ outoffset blocksize) padfn encryptor blocksize))) ; Recurse
304      (else ; Partial block
305         (let* ((inblock (padfn
306                  (subblob input inoffset (- inputsize inoffset))
307                  blocksize))
308                (outblock (encryptor (blob-xor iv inblock))))
309            (move-memory! outblock output blocksize 0 outoffset)
310            output)))) ; Terminate
311
312;creates a cbs encryptor function that requires an input and an iv in order to start the
313;cbc decryption from the first blob. In the make arguments a padding function like pkcs5 or pad-blob is needed.
314(define (make-cbc-encryptor encryptor padfn blocksize)
315  (lambda (input iv)
316    (let* ((inputsize (blob-size input))
317           (output-whole-blocks (quotient inputsize blocksize))
318           (output-overflow (remainder inputsize blocksize))
319           (outputsize (if (zero? output-overflow)
320              (+ inputsize blocksize)
321              (* (+ 1 output-whole-blocks) blocksize)))
322           (output (make-blob outputsize)))
323       (cbc-encrypt input 0 inputsize iv output 0 padfn encryptor blocksize))))
324
325; As above, but the encryptor stores the IV in the output block (encrypted)...
326(define (make-cbc*-encryptor encryptor padfn blocksize)
327  (lambda (input iv)
328     (let* ((inputsize (blob-size input))
329            (output-whole-blocks (quotient inputsize blocksize))
330            (output-overflow (remainder inputsize blocksize))
331            (outputsize (if (zero? output-overflow) ; Round up to block size, plus an extra block for the IV
332               (+ inputsize blocksize blocksize)
333               (* (+ 2 output-whole-blocks) blocksize)))
334            (output (make-blob outputsize))
335            (encrypted-iv (encryptor iv)))
336        (move-memory! encrypted-iv output blocksize)
337        (cbc-encrypt input 0 inputsize iv output blocksize padfn encryptor blocksize))))
338
339;internal cbc-decrypt function used by the make- variants. an unpad function is needed.
340(define (cbc-decrypt input inoffset inputsize iv output outoffset unpadfn decryptor blocksize)
341    (if (= (+ inoffset blocksize) inputsize)
342       ; Last block
343       (let* ((inblock (subblob input inoffset blocksize))
344              (outblock
345                 (unpadfn
346                    (blob-xor iv
347                      (decryptor inblock)))))
348             (move-memory! outblock output (blob-size outblock) 0 outoffset)
349             (subblob output 0 (+ outoffset (blob-size outblock)))) ; Terminate
350       ; Not last block
351       (let* ((inblock (subblob input inoffset blocksize))
352              (outblock
353                 (blob-xor iv
354                   (decryptor inblock))))
355             (move-memory! outblock output blocksize 0 outoffset)
356             (cbc-decrypt input (+ inoffset blocksize) inputsize inblock output (+ outoffset blocksize) unpadfn decryptor blocksize)))) ; Recurse
357
358;creates a cbc decryptor that uses and iv to start decrypting from the first byte of the input blob.
359;an unpad function is needed in cbc mode decryption.
360(define (make-cbc-decryptor decryptor unpadfn blocksize)
361  (lambda (input iv)
362    (let* ((inputsize (blob-size input))
363           (output (make-blob inputsize)))
364       (cbc-decrypt input 0 inputsize iv output 0 unpadfn decryptor blocksize))))
365
366;same as above but treats the first block of the input as the encrypted IV.
367(define (make-cbc*-decryptor decryptor unpadfn blocksize)
368  (lambda (input)
369    (let* ((inputsize (blob-size input))
370           (output (make-blob inputsize))
371           (iv (decryptor (subblob input 0 blocksize))))
372       (cbc-decrypt input blocksize inputsize iv output 0 unpadfn decryptor blocksize)))) )
Note: See TracBrowser for help on using the repository browser.