/* -*-C-*-
$Id: prmcrypt.c,v 1.3 2001/03/09 16:12:56 cph Exp $
Copyright (c) 2001 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.
This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
USA.
*/
/* Interface to mcrypt library */
#include "scheme.h"
#include "prims.h"
#include "usrdef.h"
#include "os.h"
#include <mcrypt.h>
static SCHEME_OBJECT
cp2s (char * cp)
{
if (cp == 0)
return (SHARP_F);
else
{
SCHEME_OBJECT s = (char_pointer_to_string (cp));
mcrypt_free (cp);
return (s);
}
}
static size_t context_table_length = 0;
static MCRYPT * context_table = 0;
static size_t
search_context_table (MCRYPT context)
{
size_t i;
for (i = 0; (i < context_table_length); i += 1)
if ((context_table[i]) == context)
break;
return (i);
}
static size_t
allocate_context_entry (void)
{
size_t i = (search_context_table (0));
if (i < context_table_length)
return (i);
if (i == 0)
{
context_table_length = 256;
context_table
= (OS_malloc ((sizeof (MCRYPT)) * context_table_length));
}
else
{
context_table_length *= 2;
context_table
= (OS_realloc (context_table,
((sizeof (MCRYPT)) * context_table_length)));
}
{
size_t j;
for (j = i; (j < context_table_length); j += 1)
(context_table[j]) = 0;
}
return (i);
}
static SCHEME_OBJECT
store_context (MCRYPT context)
{
if (context == MCRYPT_FAILED)
return (SHARP_F);
{
size_t i = (allocate_context_entry ());
(context_table[i]) = context;
return (ulong_to_integer (i));
}
}
static void
forget_context (size_t index)
{
(context_table[index]) = 0;
}
static size_t
arg_context_index (unsigned int arg)
{
unsigned long n = (arg_ulong_index_integer (arg, context_table_length));
if ((context_table[n]) == 0)
error_bad_range_arg (arg);
return (n);
}
static MCRYPT
arg_context (unsigned int arg)
{
return (context_table [arg_context_index (arg)]);
}
DEFINE_PRIMITIVE ("MCRYPT_MODULE_OPEN", Prim_mcrypt_module_open, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
PRIMITIVE_RETURN
(store_context
(mcrypt_module_open ((STRING_ARG (1)), 0, (STRING_ARG (2)), 0)));
}
DEFINE_PRIMITIVE ("MCRYPT_GENERIC_INIT", Prim_mcrypt_generic_init, 3, 3, 0)
{
PRIMITIVE_HEADER (3);
CHECK_ARG (2, STRING_P);
PRIMITIVE_RETURN
(long_to_integer
(mcrypt_generic_init ((arg_context (1)),
(STRING_LOC ((ARG_REF (2)), 0)),
(STRING_LENGTH (ARG_REF (2))),
(STRING_ARG (3)))));
}
DEFINE_PRIMITIVE ("MCRYPT_GENERIC", Prim_mcrypt_generic, 4, 4, 0)
{
PRIMITIVE_HEADER (4);
CHECK_ARG (2, STRING_P);
{
SCHEME_OBJECT string = (ARG_REF (2));
unsigned long l = (STRING_LENGTH (string));
unsigned long start = (arg_ulong_index_integer (3, l));
unsigned long end = (arg_integer_in_range (4, start, (l + 1)));
PRIMITIVE_RETURN
(long_to_integer
(mcrypt_generic ((arg_context (1)),
(STRING_LOC (string, start)),
(end - start))));
}
}
DEFINE_PRIMITIVE ("MDECRYPT_GENERIC", Prim_mdecrypt_generic, 4, 4, 0)
{
PRIMITIVE_HEADER (4);
CHECK_ARG (2, STRING_P);
{
SCHEME_OBJECT string = (ARG_REF (2));
unsigned long l = (STRING_LENGTH (string));
unsigned long start = (arg_ulong_index_integer (3, l));
unsigned long end = (arg_integer_in_range (4, start, (l + 1)));
PRIMITIVE_RETURN
(long_to_integer
(mdecrypt_generic ((arg_context (1)),
(STRING_LOC (string, start)),
(end - start))));
}
}
DEFINE_PRIMITIVE ("MCRYPT_GENERIC_END", Prim_mcrypt_generic_end, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
{
size_t index = (arg_context_index (1));
int result = (mcrypt_generic_end (context_table[index]));
forget_context (index);
PRIMITIVE_RETURN (long_to_integer (result));
}
}
#define CONTEXT_OPERATION(name, cvt_val) \
{ \
PRIMITIVE_HEADER (1); \
PRIMITIVE_RETURN (cvt_val (name (arg_context (1)))); \
}
DEFINE_PRIMITIVE ("MCRYPT_ENC_SELF_TEST", Prim_mcrypt_enc_self_test, 1, 1, 0)
CONTEXT_OPERATION (mcrypt_enc_self_test, long_to_integer)
DEFINE_PRIMITIVE ("MCRYPT_ENC_IS_BLOCK_ALGORITHM_MODE", Prim_mcrypt_enc_is_block_algorithm_mode, 1, 1, 0)
CONTEXT_OPERATION (mcrypt_enc_is_block_algorithm_mode, BOOLEAN_TO_OBJECT)
DEFINE_PRIMITIVE ("MCRYPT_ENC_IS_BLOCK_ALGORITHM", Prim_mcrypt_enc_is_block_algorithm, 1, 1, 0)
CONTEXT_OPERATION (mcrypt_enc_is_block_algorithm, BOOLEAN_TO_OBJECT)
DEFINE_PRIMITIVE ("MCRYPT_ENC_IS_BLOCK_MODE", Prim_mcrypt_enc_is_block_mode, 1, 1, 0)
CONTEXT_OPERATION (mcrypt_enc_is_block_mode, BOOLEAN_TO_OBJECT)
DEFINE_PRIMITIVE ("MCRYPT_ENC_GET_KEY_SIZE", Prim_mcrypt_enc_get_key_size, 1, 1, 0)
CONTEXT_OPERATION (mcrypt_enc_get_key_size, long_to_integer)
DEFINE_PRIMITIVE ("MCRYPT_ENC_GET_IV_SIZE", Prim_mcrypt_enc_get_iv_size, 1, 1, 0)
CONTEXT_OPERATION (mcrypt_enc_get_iv_size, long_to_integer)
DEFINE_PRIMITIVE ("MCRYPT_ENC_GET_ALGORITHMS_NAME", Prim_mcrypt_enc_get_algorithms_name, 1, 1, 0)
CONTEXT_OPERATION (mcrypt_enc_get_algorithms_name, cp2s)
DEFINE_PRIMITIVE ("MCRYPT_ENC_GET_MODES_NAME", Prim_mcrypt_enc_get_modes_name, 1, 1, 0)
CONTEXT_OPERATION (mcrypt_enc_get_modes_name, cp2s)
#define MODULE_OPERATION(name, cvt_val) \
{ \
PRIMITIVE_HEADER (1); \
PRIMITIVE_RETURN (cvt_val (name ((STRING_ARG (1)), 0))); \
}
DEFINE_PRIMITIVE ("MCRYPT_MODULE_SELF_TEST", Prim_mcrypt_module_self_test, 1, 1, 0)
MODULE_OPERATION (mcrypt_module_self_test, long_to_integer)
DEFINE_PRIMITIVE ("MCRYPT_MODULE_IS_BLOCK_ALGORITHM_MODE", Prim_mcrypt_module_is_block_algorithm_mode, 1, 1, 0)
MODULE_OPERATION (mcrypt_module_is_block_algorithm_mode, BOOLEAN_TO_OBJECT)
DEFINE_PRIMITIVE ("MCRYPT_MODULE_IS_BLOCK_ALGORITHM", Prim_mcrypt_module_is_block_algorithm, 1, 1, 0)
MODULE_OPERATION (mcrypt_module_is_block_algorithm, BOOLEAN_TO_OBJECT)
DEFINE_PRIMITIVE ("MCRYPT_MODULE_IS_BLOCK_MODE", Prim_mcrypt_module_is_block_mode, 1, 1, 0)
MODULE_OPERATION (mcrypt_module_is_block_mode, BOOLEAN_TO_OBJECT)
DEFINE_PRIMITIVE ("MCRYPT_MODULE_GET_ALGO_BLOCK_SIZE", Prim_mcrypt_module_get_algo_block_size, 1, 1, 0)
MODULE_OPERATION (mcrypt_module_get_algo_block_size, long_to_integer)
DEFINE_PRIMITIVE ("MCRYPT_MODULE_GET_ALGO_KEY_SIZE", Prim_mcrypt_module_get_algo_key_size, 1, 1, 0)
MODULE_OPERATION (mcrypt_module_get_algo_key_size, long_to_integer)
struct deallocate_list_arg
{
char ** elements;
int n_elements;
};
static void
DEFUN (deallocate_list, (environment), PTR environment)
{
struct deallocate_list_arg * a = environment;
if ((a -> elements) != 0)
mcrypt_free_p ((a -> elements), (a -> n_elements));
}
#define LIST_ITEMS(name) \
{ \
PRIMITIVE_HEADER (0); \
{ \
struct deallocate_list_arg a; \
(a . elements) = (name (0, (& (a . n_elements)))); \
transaction_begin (); \
transaction_record_action (tat_always, deallocate_list, (&a)); \
if ((a . n_elements) < 0) \
error_external_return (); \
{ \
char ** scan = (a . elements); \
char ** end = (scan + (a . n_elements)); \
SCHEME_OBJECT sa = (make_vector ((a . n_elements), SHARP_F, 1)); \
SCHEME_OBJECT * scan_sa = (VECTOR_LOC (sa, 0)); \
while (scan < end) \
(*scan_sa++) = (char_pointer_to_string (*scan++)); \
transaction_commit (); \
PRIMITIVE_RETURN (sa); \
} \
} \
}
DEFINE_PRIMITIVE ("MCRYPT_LIST_ALGORITHMS", Prim_mcrypt_list_algorithms, 0, 0, 0)
LIST_ITEMS (mcrypt_list_algorithms)
DEFINE_PRIMITIVE ("MCRYPT_LIST_MODES", Prim_mcrypt_list_modes, 0, 0, 0)
LIST_ITEMS (mcrypt_list_modes)
static void
DEFUN (deallocate_key_sizes, (environment), PTR environment)
{
if (environment != 0)
mcrypt_free (environment);
}
static SCHEME_OBJECT
convert_key_sizes (int * sizes, int n_sizes)
{
transaction_begin ();
transaction_record_action (tat_always, deallocate_key_sizes, sizes);
if (n_sizes < 0)
error_external_return ();
if (n_sizes == 0)
{
transaction_commit ();
return (SHARP_F);
}
{
SCHEME_OBJECT sa = (make_vector (n_sizes, FIXNUM_ZERO, 1));
SCHEME_OBJECT * scan_sa = (VECTOR_LOC (sa, 0));
int * scan = sizes;
int * end = (scan + n_sizes);
while (scan < end)
(*scan_sa++) = (long_to_integer (*scan++));
transaction_commit ();
return (sa);
}
}
DEFINE_PRIMITIVE ("MCRYPT_ENC_GET_SUPPORTED_KEY_SIZES", Prim_mcrypt_enc_get_supported_key_sizes, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
{
int n_sizes;
int * sizes
= (mcrypt_enc_get_supported_key_sizes ((arg_context (1)), (&n_sizes)));
PRIMITIVE_RETURN (convert_key_sizes (sizes, n_sizes));
}
}
DEFINE_PRIMITIVE ("MCRYPT_MODULE_GET_ALGO_SUPPORTED_KEY_SIZES", Prim_mcrypt_module_get_algo_supported_key_sizes, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
{
int n_sizes;
int * sizes
= (mcrypt_module_get_algo_supported_key_sizes
((STRING_ARG (1)), 0, (&n_sizes)));
PRIMITIVE_RETURN (convert_key_sizes (sizes, n_sizes));
}
}
#ifdef COMPILE_AS_MODULE
char *
DEFUN_VOID (dload_initialize_file)
{
declare_primitive
("MCRYPT_MODULE_OPEN", Prim_mcrypt_module_open, 2, 2, 0);
declare_primitive
("MCRYPT_GENERIC_INIT", Prim_mcrypt_generic_init, 3, 3, 0);
declare_primitive
("MCRYPT_GENERIC", Prim_mcrypt_generic, 4, 4, 0);
declare_primitive
("MDECRYPT_GENERIC", Prim_mdecrypt_generic, 4, 4, 0);
declare_primitive
("MCRYPT_GENERIC_END", Prim_mcrypt_generic_end, 1, 1, 0);
declare_primitive
("MCRYPT_ENC_SELF_TEST", Prim_mcrypt_enc_self_test, 1, 1, 0);
declare_primitive
("MCRYPT_ENC_IS_BLOCK_ALGORITHM_MODE", Prim_mcrypt_enc_is_block_algorithm_mode, 1, 1, 0);
declare_primitive
("MCRYPT_ENC_IS_BLOCK_ALGORITHM", Prim_mcrypt_enc_is_block_algorithm, 1, 1, 0);
declare_primitive
("MCRYPT_ENC_IS_BLOCK_MODE", Prim_mcrypt_enc_is_block_mode, 1, 1, 0);
declare_primitive
("MCRYPT_ENC_GET_KEY_SIZE", Prim_mcrypt_enc_get_key_size, 1, 1, 0);
declare_primitive
("MCRYPT_ENC_GET_IV_SIZE", Prim_mcrypt_enc_get_iv_size, 1, 1, 0);
declare_primitive
("MCRYPT_ENC_GET_ALGORITHMS_NAME", Prim_mcrypt_enc_get_algorithms_name, 1, 1, 0);
declare_primitive
("MCRYPT_ENC_GET_MODES_NAME", Prim_mcrypt_enc_get_modes_name, 1, 1, 0);
declare_primitive
("MCRYPT_MODULE_SELF_TEST", Prim_mcrypt_module_self_test, 1, 1, 0);
declare_primitive
("MCRYPT_MODULE_IS_BLOCK_ALGORITHM_MODE", Prim_mcrypt_module_is_block_algorithm_mode, 1, 1, 0);
declare_primitive
("MCRYPT_MODULE_IS_BLOCK_ALGORITHM", Prim_mcrypt_module_is_block_algorithm, 1, 1, 0);
declare_primitive
("MCRYPT_MODULE_IS_BLOCK_MODE", Prim_mcrypt_module_is_block_mode, 1, 1, 0);
declare_primitive
("MCRYPT_MODULE_GET_ALGO_BLOCK_SIZE", Prim_mcrypt_module_get_algo_block_size, 1, 1, 0);
declare_primitive
("MCRYPT_MODULE_GET_ALGO_KEY_SIZE", Prim_mcrypt_module_get_algo_key_size, 1, 1, 0);
declare_primitive
("MCRYPT_LIST_ALGORITHMS", Prim_mcrypt_list_algorithms, 0, 0, 0);
declare_primitive
("MCRYPT_LIST_MODES", Prim_mcrypt_list_modes, 0, 0, 0);
declare_primitive
("MCRYPT_ENC_GET_SUPPORTED_KEY_SIZES", Prim_mcrypt_enc_get_supported_key_sizes, 1, 1, 0);
declare_primitive
("MCRYPT_MODULE_GET_ALGO_SUPPORTED_KEY_SIZES", Prim_mcrypt_module_get_algo_supported_key_sizes, 1, 1, 0);
return "#prmcrypt";
}
#endif /* COMPILE_AS_MODULE */
syntax highlighted by Code2HTML, v. 0.9.1