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