source: project/release/3/crypto-tools/trunk/crypto-tools.scm @ 13197

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

V1.0

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