1 /* -*-C-*-
2
3 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
4 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
5 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
6 Institute of Technology
7
8 This file is part of MIT/GNU Scheme.
9
10 MIT/GNU Scheme is free software; you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation; either version 2 of the License, or (at
13 your option) any later version.
14
15 MIT/GNU Scheme is distributed in the hope that it will be useful, but
16 WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 General Public License for more details.
19
20 You should have received a copy of the GNU General Public License
21 along with MIT/GNU Scheme; if not, write to the Free Software
22 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
23 USA.
24
25 */
26
27 /* Interface to mcrypt library */
28
29 #include "scheme.h"
30 #include "prims.h"
31 #include "usrdef.h"
32 #include "os.h"
33
34 /* If mcrypt.h unavailable, ignore it. This helps
35 "makegen/makegen.scm" work properly on systems lacking this
36 library. */
37 #ifdef HAVE_MCRYPT_H
38 # include <mcrypt.h>
39 #endif
40
41 static SCHEME_OBJECT
cp2s(char * cp)42 cp2s (char * cp)
43 {
44 if (cp == 0)
45 return (SHARP_F);
46 else
47 {
48 SCHEME_OBJECT s = (char_pointer_to_string (cp));
49 mcrypt_free (cp);
50 return (s);
51 }
52 }
53
54 static size_t context_table_length = 0;
55 static MCRYPT * context_table = 0;
56
57 static size_t
search_context_table(MCRYPT context)58 search_context_table (MCRYPT context)
59 {
60 size_t i;
61 for (i = 0; (i < context_table_length); i += 1)
62 if ((context_table[i]) == context)
63 break;
64 return (i);
65 }
66
67 static size_t
allocate_context_entry(void)68 allocate_context_entry (void)
69 {
70 size_t i = (search_context_table (0));
71 if (i < context_table_length)
72 return (i);
73 if (i == 0)
74 {
75 context_table_length = 256;
76 context_table
77 = (OS_malloc ((sizeof (MCRYPT)) * context_table_length));
78 }
79 else
80 {
81 context_table_length *= 2;
82 context_table
83 = (OS_realloc (context_table,
84 ((sizeof (MCRYPT)) * context_table_length)));
85 }
86 {
87 size_t j;
88 for (j = i; (j < context_table_length); j += 1)
89 (context_table[j]) = 0;
90 }
91 return (i);
92 }
93
94 static SCHEME_OBJECT
store_context(MCRYPT context)95 store_context (MCRYPT context)
96 {
97 if (context == MCRYPT_FAILED)
98 return (SHARP_F);
99 {
100 size_t i = (allocate_context_entry ());
101 (context_table[i]) = context;
102 return (ulong_to_integer (i));
103 }
104 }
105
106 static void
forget_context(size_t index)107 forget_context (size_t index)
108 {
109 (context_table[index]) = 0;
110 }
111
112 static size_t
arg_context_index(unsigned int arg)113 arg_context_index (unsigned int arg)
114 {
115 unsigned long n = (arg_ulong_index_integer (arg, context_table_length));
116 if ((context_table[n]) == 0)
117 error_bad_range_arg (arg);
118 return (n);
119 }
120
121 static MCRYPT
arg_context(unsigned int arg)122 arg_context (unsigned int arg)
123 {
124 return (context_table [arg_context_index (arg)]);
125 }
126
127 DEFINE_PRIMITIVE ("MCRYPT_MODULE_OPEN", Prim_mcrypt_module_open, 2, 2, 0)
128 {
129 PRIMITIVE_HEADER (2);
130 PRIMITIVE_RETURN
131 (store_context
132 (mcrypt_module_open ((STRING_ARG (1)), 0, (STRING_ARG (2)), 0)));
133 }
134
135 DEFINE_PRIMITIVE ("MCRYPT_GENERIC_INIT", Prim_mcrypt_generic_init, 3, 3, 0)
136 {
137 PRIMITIVE_HEADER (3);
138 CHECK_ARG (2, STRING_P);
139 PRIMITIVE_RETURN
140 (long_to_integer
141 (mcrypt_generic_init ((arg_context (1)),
142 (STRING_POINTER (ARG_REF (2))),
143 (STRING_LENGTH (ARG_REF (2))),
144 (STRING_ARG (3)))));
145 }
146
147 DEFINE_PRIMITIVE ("MCRYPT_GENERIC", Prim_mcrypt_generic, 4, 4, 0)
148 {
149 PRIMITIVE_HEADER (4);
150 CHECK_ARG (2, STRING_P);
151 {
152 SCHEME_OBJECT string = (ARG_REF (2));
153 unsigned long l = (STRING_LENGTH (string));
154 unsigned long start = (arg_ulong_index_integer (3, l));
155 unsigned long end = (arg_integer_in_range (4, start, (l + 1)));
156 PRIMITIVE_RETURN
157 (long_to_integer
158 (mcrypt_generic ((arg_context (1)),
159 (STRING_LOC (string, start)),
160 (end - start))));
161 }
162 }
163
164 DEFINE_PRIMITIVE ("MDECRYPT_GENERIC", Prim_mdecrypt_generic, 4, 4, 0)
165 {
166 PRIMITIVE_HEADER (4);
167 CHECK_ARG (2, STRING_P);
168 {
169 SCHEME_OBJECT string = (ARG_REF (2));
170 unsigned long l = (STRING_LENGTH (string));
171 unsigned long start = (arg_ulong_index_integer (3, l));
172 unsigned long end = (arg_integer_in_range (4, start, (l + 1)));
173 PRIMITIVE_RETURN
174 (long_to_integer
175 (mdecrypt_generic ((arg_context (1)),
176 (STRING_LOC (string, start)),
177 (end - start))));
178 }
179 }
180
181 DEFINE_PRIMITIVE ("MCRYPT_GENERIC_END", Prim_mcrypt_generic_end, 1, 1, 0)
182 {
183 PRIMITIVE_HEADER (1);
184 {
185 size_t index = (arg_context_index (1));
186 int result = (mcrypt_generic_end (context_table[index]));
187 forget_context (index);
188 PRIMITIVE_RETURN (long_to_integer (result));
189 }
190 }
191
192 #define CONTEXT_OPERATION(name, cvt_val) \
193 { \
194 PRIMITIVE_HEADER (1); \
195 PRIMITIVE_RETURN (cvt_val (name (arg_context (1)))); \
196 }
197
198 DEFINE_PRIMITIVE ("MCRYPT_ENC_SELF_TEST", Prim_mcrypt_enc_self_test, 1, 1, 0)
199 CONTEXT_OPERATION (mcrypt_enc_self_test, long_to_integer)
200
201 DEFINE_PRIMITIVE ("MCRYPT_ENC_IS_BLOCK_ALGORITHM_MODE", Prim_mcrypt_enc_is_block_algorithm_mode, 1, 1, 0)
202 CONTEXT_OPERATION (mcrypt_enc_is_block_algorithm_mode, BOOLEAN_TO_OBJECT)
203
204 DEFINE_PRIMITIVE ("MCRYPT_ENC_IS_BLOCK_ALGORITHM", Prim_mcrypt_enc_is_block_algorithm, 1, 1, 0)
205 CONTEXT_OPERATION (mcrypt_enc_is_block_algorithm, BOOLEAN_TO_OBJECT)
206
207 DEFINE_PRIMITIVE ("MCRYPT_ENC_IS_BLOCK_MODE", Prim_mcrypt_enc_is_block_mode, 1, 1, 0)
208 CONTEXT_OPERATION (mcrypt_enc_is_block_mode, BOOLEAN_TO_OBJECT)
209
210 DEFINE_PRIMITIVE ("MCRYPT_ENC_GET_KEY_SIZE", Prim_mcrypt_enc_get_key_size, 1, 1, 0)
211 CONTEXT_OPERATION (mcrypt_enc_get_key_size, long_to_integer)
212
213 DEFINE_PRIMITIVE ("MCRYPT_ENC_GET_IV_SIZE", Prim_mcrypt_enc_get_iv_size, 1, 1, 0)
214 CONTEXT_OPERATION (mcrypt_enc_get_iv_size, long_to_integer)
215
216 DEFINE_PRIMITIVE ("MCRYPT_ENC_GET_ALGORITHMS_NAME", Prim_mcrypt_enc_get_algorithms_name, 1, 1, 0)
217 CONTEXT_OPERATION (mcrypt_enc_get_algorithms_name, cp2s)
218
219 DEFINE_PRIMITIVE ("MCRYPT_ENC_GET_MODES_NAME", Prim_mcrypt_enc_get_modes_name, 1, 1, 0)
220 CONTEXT_OPERATION (mcrypt_enc_get_modes_name, cp2s)
221
222 #define MODULE_OPERATION(name, cvt_val) \
223 { \
224 PRIMITIVE_HEADER (1); \
225 PRIMITIVE_RETURN (cvt_val (name ((STRING_ARG (1)), 0))); \
226 }
227
228 DEFINE_PRIMITIVE ("MCRYPT_MODULE_SELF_TEST", Prim_mcrypt_module_self_test, 1, 1, 0)
229 MODULE_OPERATION (mcrypt_module_self_test, long_to_integer)
230
231 DEFINE_PRIMITIVE ("MCRYPT_MODULE_IS_BLOCK_ALGORITHM_MODE", Prim_mcrypt_module_is_block_algorithm_mode, 1, 1, 0)
232 MODULE_OPERATION (mcrypt_module_is_block_algorithm_mode, BOOLEAN_TO_OBJECT)
233
234 DEFINE_PRIMITIVE ("MCRYPT_MODULE_IS_BLOCK_ALGORITHM", Prim_mcrypt_module_is_block_algorithm, 1, 1, 0)
235 MODULE_OPERATION (mcrypt_module_is_block_algorithm, BOOLEAN_TO_OBJECT)
236
237 DEFINE_PRIMITIVE ("MCRYPT_MODULE_IS_BLOCK_MODE", Prim_mcrypt_module_is_block_mode, 1, 1, 0)
238 MODULE_OPERATION (mcrypt_module_is_block_mode, BOOLEAN_TO_OBJECT)
239
240 DEFINE_PRIMITIVE ("MCRYPT_MODULE_GET_ALGO_BLOCK_SIZE", Prim_mcrypt_module_get_algo_block_size, 1, 1, 0)
241 MODULE_OPERATION (mcrypt_module_get_algo_block_size, long_to_integer)
242
243 DEFINE_PRIMITIVE ("MCRYPT_MODULE_GET_ALGO_KEY_SIZE", Prim_mcrypt_module_get_algo_key_size, 1, 1, 0)
244 MODULE_OPERATION (mcrypt_module_get_algo_key_size, long_to_integer)
245
246 struct deallocate_list_arg
247 {
248 char ** elements;
249 int n_elements;
250 };
251
252 static void
deallocate_list(void * environment)253 deallocate_list (void * environment)
254 {
255 struct deallocate_list_arg * a = environment;
256 if ((a -> elements) != 0)
257 mcrypt_free_p ((a -> elements), (a -> n_elements));
258 }
259
260 #define LIST_ITEMS(name) \
261 { \
262 PRIMITIVE_HEADER (0); \
263 { \
264 struct deallocate_list_arg a; \
265 (a . elements) = (name (0, (& (a . n_elements)))); \
266 transaction_begin (); \
267 transaction_record_action (tat_always, deallocate_list, (&a)); \
268 if ((a . n_elements) < 0) \
269 error_external_return (); \
270 { \
271 char ** scan = (a . elements); \
272 char ** end = (scan + (a . n_elements)); \
273 SCHEME_OBJECT sa = (make_vector ((a . n_elements), SHARP_F, 1)); \
274 SCHEME_OBJECT * scan_sa = (VECTOR_LOC (sa, 0)); \
275 while (scan < end) \
276 (*scan_sa++) = (char_pointer_to_string (*scan++)); \
277 transaction_commit (); \
278 PRIMITIVE_RETURN (sa); \
279 } \
280 } \
281 }
282
283 DEFINE_PRIMITIVE ("MCRYPT_LIST_ALGORITHMS", Prim_mcrypt_list_algorithms, 0, 0, 0)
LIST_ITEMS(mcrypt_list_algorithms)284 LIST_ITEMS (mcrypt_list_algorithms)
285
286 DEFINE_PRIMITIVE ("MCRYPT_LIST_MODES", Prim_mcrypt_list_modes, 0, 0, 0)
287 LIST_ITEMS (mcrypt_list_modes)
288
289 static void
290 deallocate_key_sizes (void * environment)
291 {
292 if (environment != 0)
293 mcrypt_free (environment);
294 }
295
296 static SCHEME_OBJECT
convert_key_sizes(int * sizes,int n_sizes)297 convert_key_sizes (int * sizes, int n_sizes)
298 {
299 transaction_begin ();
300 transaction_record_action (tat_always, deallocate_key_sizes, sizes);
301 if (n_sizes < 0)
302 error_external_return ();
303 if (n_sizes == 0)
304 {
305 transaction_commit ();
306 return (SHARP_F);
307 }
308 {
309 SCHEME_OBJECT sa = (make_vector (n_sizes, FIXNUM_ZERO, 1));
310 SCHEME_OBJECT * scan_sa = (VECTOR_LOC (sa, 0));
311 int * scan = sizes;
312 int * end = (scan + n_sizes);
313 while (scan < end)
314 (*scan_sa++) = (long_to_integer (*scan++));
315 transaction_commit ();
316 return (sa);
317 }
318 }
319
320 DEFINE_PRIMITIVE ("MCRYPT_ENC_GET_SUPPORTED_KEY_SIZES", Prim_mcrypt_enc_get_supported_key_sizes, 1, 1, 0)
321 {
322 PRIMITIVE_HEADER (1);
323 {
324 int n_sizes;
325 int * sizes
326 = (mcrypt_enc_get_supported_key_sizes ((arg_context (1)), (&n_sizes)));
327 PRIMITIVE_RETURN (convert_key_sizes (sizes, n_sizes));
328 }
329 }
330
331 DEFINE_PRIMITIVE ("MCRYPT_MODULE_GET_ALGO_SUPPORTED_KEY_SIZES", Prim_mcrypt_module_get_algo_supported_key_sizes, 1, 1, 0)
332 {
333 PRIMITIVE_HEADER (1);
334 {
335 int n_sizes;
336 int * sizes
337 = (mcrypt_module_get_algo_supported_key_sizes
338 ((STRING_ARG (1)), 0, (&n_sizes)));
339 PRIMITIVE_RETURN (convert_key_sizes (sizes, n_sizes));
340 }
341 }
342
343 #ifdef COMPILE_AS_MODULE
344
345 char *
dload_initialize_file(void)346 dload_initialize_file (void)
347 {
348 declare_primitive
349 ("MCRYPT_MODULE_OPEN", Prim_mcrypt_module_open, 2, 2, 0);
350 declare_primitive
351 ("MCRYPT_GENERIC_INIT", Prim_mcrypt_generic_init, 3, 3, 0);
352 declare_primitive
353 ("MCRYPT_GENERIC", Prim_mcrypt_generic, 4, 4, 0);
354 declare_primitive
355 ("MDECRYPT_GENERIC", Prim_mdecrypt_generic, 4, 4, 0);
356 declare_primitive
357 ("MCRYPT_GENERIC_END", Prim_mcrypt_generic_end, 1, 1, 0);
358 declare_primitive
359 ("MCRYPT_ENC_SELF_TEST", Prim_mcrypt_enc_self_test, 1, 1, 0);
360 declare_primitive
361 ("MCRYPT_ENC_IS_BLOCK_ALGORITHM_MODE", Prim_mcrypt_enc_is_block_algorithm_mode, 1, 1, 0);
362 declare_primitive
363 ("MCRYPT_ENC_IS_BLOCK_ALGORITHM", Prim_mcrypt_enc_is_block_algorithm, 1, 1, 0);
364 declare_primitive
365 ("MCRYPT_ENC_IS_BLOCK_MODE", Prim_mcrypt_enc_is_block_mode, 1, 1, 0);
366 declare_primitive
367 ("MCRYPT_ENC_GET_KEY_SIZE", Prim_mcrypt_enc_get_key_size, 1, 1, 0);
368 declare_primitive
369 ("MCRYPT_ENC_GET_IV_SIZE", Prim_mcrypt_enc_get_iv_size, 1, 1, 0);
370 declare_primitive
371 ("MCRYPT_ENC_GET_ALGORITHMS_NAME", Prim_mcrypt_enc_get_algorithms_name, 1, 1, 0);
372 declare_primitive
373 ("MCRYPT_ENC_GET_MODES_NAME", Prim_mcrypt_enc_get_modes_name, 1, 1, 0);
374 declare_primitive
375 ("MCRYPT_MODULE_SELF_TEST", Prim_mcrypt_module_self_test, 1, 1, 0);
376 declare_primitive
377 ("MCRYPT_MODULE_IS_BLOCK_ALGORITHM_MODE", Prim_mcrypt_module_is_block_algorithm_mode, 1, 1, 0);
378 declare_primitive
379 ("MCRYPT_MODULE_IS_BLOCK_ALGORITHM", Prim_mcrypt_module_is_block_algorithm, 1, 1, 0);
380 declare_primitive
381 ("MCRYPT_MODULE_IS_BLOCK_MODE", Prim_mcrypt_module_is_block_mode, 1, 1, 0);
382 declare_primitive
383 ("MCRYPT_MODULE_GET_ALGO_BLOCK_SIZE", Prim_mcrypt_module_get_algo_block_size, 1, 1, 0);
384 declare_primitive
385 ("MCRYPT_MODULE_GET_ALGO_KEY_SIZE", Prim_mcrypt_module_get_algo_key_size, 1, 1, 0);
386 declare_primitive
387 ("MCRYPT_LIST_ALGORITHMS", Prim_mcrypt_list_algorithms, 0, 0, 0);
388 declare_primitive
389 ("MCRYPT_LIST_MODES", Prim_mcrypt_list_modes, 0, 0, 0);
390 declare_primitive
391 ("MCRYPT_ENC_GET_SUPPORTED_KEY_SIZES", Prim_mcrypt_enc_get_supported_key_sizes, 1, 1, 0);
392 declare_primitive
393 ("MCRYPT_MODULE_GET_ALGO_SUPPORTED_KEY_SIZES", Prim_mcrypt_module_get_algo_supported_key_sizes, 1, 1, 0);
394 return "#prmcrypt";
395 }
396
397 #endif /* COMPILE_AS_MODULE */
398