From e5b29c3c7869af025279ce335736e8111fa712cf Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 28 Feb 2001 21:42:44 +0000 Subject: [PATCH] Add support for mcrypt library. --- v7/src/microcode/configure.in | 85 +++++---- v7/src/microcode/prmcrypt.c | 331 ++++++++++++++++++++++++++++++++++ v7/src/runtime/blowfish.scm | 48 ++--- v7/src/runtime/crypto.scm | 155 +++++++++++++++- v7/src/runtime/runtime.pkg | 21 ++- v7/src/runtime/version.scm | 6 +- 6 files changed, 578 insertions(+), 68 deletions(-) create mode 100644 v7/src/microcode/prmcrypt.c diff --git a/v7/src/microcode/configure.in b/v7/src/microcode/configure.in index d38747c92..608b51e21 100644 --- a/v7/src/microcode/configure.in +++ b/v7/src/microcode/configure.in @@ -1,6 +1,6 @@ dnl Process this file with autoconf to produce a configure script. -dnl Copyright (c) 2000 Massachusetts Institute of Technology +dnl Copyright (c) 2000-2001 Massachusetts Institute of Technology dnl dnl This program is free software; you can redistribute it and/or dnl modify it under the terms of the GNU General Public License as @@ -16,10 +16,18 @@ dnl You should have received a copy of the GNU General Public License dnl along with this program; if not, write to the Free Software dnl Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -AC_REVISION([$Id: configure.in,v 11.3 2000/12/08 17:47:19 cph Exp $]) +AC_REVISION([$Id: configure.in,v 11.4 2001/02/28 21:41:58 cph Exp $]) AC_INIT(boot.c) AC_CONFIG_HEADER(config.h) +dnl Feature options. +AC_ARG_ENABLE(static-libs, +[ --enable-static-libs Link some libraries statically [no]]) +AC_ARG_WITH(mhash, +[ --with-mhash Use the mhash library if available [yes]]) +AC_ARG_WITH(mcrypt, +[ --with-mcrypt Use the mcrypt library available [yes]]) + dnl Substitution variables to be filled in below. AS_FLAGS= GC_HEAD_FILES= @@ -29,6 +37,7 @@ OPTIONAL_BASES= OPTIONAL_OBJECTS= OPTIONAL_SOURCES= STATIC_LIBS= +QUASI_STATIC_LIBS= STATIC_PREFIX= STATIC_SUFFIX= @@ -48,11 +57,13 @@ AC_CHECK_LIB(m, exp) AC_CHECK_LIB(mhash, mhash_count, [scheme_cv_lib_mhash=yes], [scheme_cv_lib_mhash=no]) -if test "${scheme_cv_lib_mhash}" = "no"; then - AC_CHECK_LIB(md5, MD5Init, - [scheme_cv_lib_md5=yes], - [scheme_cv_lib_md5=no]) -fi +AC_CHECK_LIB(md5, MD5Init, + [scheme_cv_lib_md5=yes], + [scheme_cv_lib_md5=no]) +AC_CHECK_LIB(mcrypt, mcrypt_generic_init, + [scheme_cv_lib_mcrypt=yes], + [scheme_cv_lib_mcrypt=no], + [-lltdl]) AC_CHECK_LIB(blowfish, BF_set_key, [scheme_cv_lib_blowfish=yes], [scheme_cv_lib_blowfish=no]) @@ -74,60 +85,56 @@ AC_CHECK_LIB(termcap, tparam, [scheme_cv_lib_termcap=yes], [scheme_cv_lib_termcap=no]) -if test "${scheme_cv_lib_mhash}" = "yes"; then - AC_DEFINE(HAVE_LIBMHASH) - STATIC_LIBS="${STATIC_LIBS} -lmhash" +if test "${ac_cv_lib_dl_dlopen}" = "yes"; then + OPTIONAL_BASES="${OPTIONAL_BASES} pruxdld" fi -if test "${scheme_cv_lib_md5}" = "yes"; then +if test "${scheme_cv_lib_mhash}" = "yes" && test "${with_mhash}" != "no"; then + AC_DEFINE(HAVE_LIBMHASH) + QUASI_STATIC_LIBS="${QUASI_STATIC_LIBS} -lmhash" + OPTIONAL_BASES="${OPTIONAL_BASES} prmhash" +elif test "${scheme_cv_lib_md5}" = "yes"; then AC_DEFINE(HAVE_LIBMD5) STATIC_LIBS="${STATIC_LIBS} -lmd5" + OPTIONAL_BASES="${OPTIONAL_BASES} prmd5" fi -if test "${scheme_cv_lib_blowfish}" = "yes"; then +if test "${scheme_cv_lib_mcrypt}" = "yes" && test "${with_mcrypt}" != "no"; then + AC_DEFINE(HAVE_LIBMCRYPT) + QUASI_STATIC_LIBS="${QUASI_STATIC_LIBS} -lmcrypt -lltdl" + OPTIONAL_BASES="${OPTIONAL_BASES} prmcrypt" +elif test "${scheme_cv_lib_blowfish}" = "yes"; then AC_DEFINE(HAVE_LIBBLOWFISH) STATIC_LIBS="${STATIC_LIBS} -lblowfish" -fi -if test "${scheme_cv_lib_gdbm}" = "yes"; then - AC_DEFINE(HAVE_LIBGDBM) - STATIC_LIBS="${STATIC_LIBS} -lgdbm" -fi -if test "${scheme_cv_lib_ncurses}" = "yes"; then - AC_DEFINE(HAVE_LIBNCURSES) - STATIC_LIBS="${STATIC_LIBS} -lncurses" -elif test "${scheme_cv_lib_curses}" = "yes"; then - AC_DEFINE(HAVE_LIBCURSES) - STATIC_LIBS="${STATIC_LIBS} -lcurses" -elif test "${scheme_cv_lib_termcap}" = "yes"; then - AC_DEFINE(HAVE_LIBTERMCAP) - STATIC_LIBS="${STATIC_LIBS} -ltermcap" -fi - -if test "${scheme_cv_lib_mhash}" = "yes"; then - OPTIONAL_BASES="${OPTIONAL_BASES} prmhash" -fi -if test "${scheme_cv_lib_md5}" = "yes"; then - OPTIONAL_BASES="${OPTIONAL_BASES} prmd5" -fi -if test "${scheme_cv_lib_blowfish}" = "yes"; then OPTIONAL_BASES="${OPTIONAL_BASES} prbfish" fi if test "${scheme_cv_lib_gdbm}" = "yes"; then + AC_DEFINE(HAVE_LIBGDBM) + QUASI_STATIC_LIBS="${QUASI_STATIC_LIBS} -lgdbm" OPTIONAL_BASES="${OPTIONAL_BASES} prgdbm" fi -if test "${ac_cv_lib_dl_dlopen}" = "yes"; then - OPTIONAL_BASES="${OPTIONAL_BASES} pruxdld" -fi if test "${scheme_cv_lib_ncurses}" = "yes"; then + AC_DEFINE(HAVE_LIBNCURSES) + QUASI_STATIC_LIBS="${QUASI_STATIC_LIBS} -lncurses" if test "${scheme_cv_lib_ncurses_has_tparam}" = "no"; then OPTIONAL_BASES="${OPTIONAL_BASES} terminfo" fi elif test "${scheme_cv_lib_curses}" = "yes"; then + AC_DEFINE(HAVE_LIBCURSES) + QUASI_STATIC_LIBS="${QUASI_STATIC_LIBS} -lcurses" OPTIONAL_BASES="${OPTIONAL_BASES} terminfo" elif test "${scheme_cv_lib_termcap}" = "yes"; then + AC_DEFINE(HAVE_LIBTERMCAP) + QUASI_STATIC_LIBS="${QUASI_STATIC_LIBS} -ltermcap" OPTIONAL_BASES="${OPTIONAL_BASES} tparam" else OPTIONAL_BASES="${OPTIONAL_BASES} termcap tparam" fi +if test "${enable_static_libs}" = "no"; then + LIBS="${LIBS}${QUASI_STATIC_LIBS}" +else + STATIC_LIBS="${STATIC_LIBS}${QUASI_STATIC_LIBS}" +fi + dnl Checks for header files. AC_HEADER_DIRENT AC_HEADER_STDC @@ -136,7 +143,7 @@ AC_HEADER_TIME AC_CHECK_HEADERS(bsdtty.h fcntl.h limits.h malloc.h sgtty.h stropts.h time.h) AC_CHECK_HEADERS(sys/file.h sys/ioctl.h sys/mount.h sys/param.h sys/poll.h) AC_CHECK_HEADERS(sys/ptyio.h sys/socket.h sys/time.h sys/un.h sys/vfs.h) -AC_CHECK_HEADERS(termio.h termios.h unistd.h utime.h) +AC_CHECK_HEADERS(termcap.h termio.h termios.h unistd.h utime.h) dnl Checks for typedefs AC_TYPE_MODE_T diff --git a/v7/src/microcode/prmcrypt.c b/v7/src/microcode/prmcrypt.c new file mode 100644 index 000000000..884414ae1 --- /dev/null +++ b/v7/src/microcode/prmcrypt.c @@ -0,0 +1,331 @@ +/* -*-C-*- + +$Id: prmcrypt.c,v 1.1 2001/02/28 21:42:01 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 + +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)); + } +} diff --git a/v7/src/runtime/blowfish.scm b/v7/src/runtime/blowfish.scm index 9d0ea9955..e5746d315 100644 --- a/v7/src/runtime/blowfish.scm +++ b/v7/src/runtime/blowfish.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: blowfish.scm,v 1.20 2000/11/02 19:13:14 cph Exp $ +$Id: blowfish.scm,v 1.21 2001/02/28 21:42:29 cph Exp $ -Copyright (c) 1997, 1999, 2000 Massachusetts Institute of Technology +Copyright (c) 1997-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 @@ -31,28 +31,32 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (define blowfish-ofb64 (ucode-primitive blowfish-ofb64-substring 8)) (define (blowfish-available?) - (implemented-primitive-procedure? blowfish-cfb64)) + (or (mcrypt-available?) + (implemented-primitive-procedure? blowfish-cfb64))) (define (blowfish-encrypt-port input output key init-vector encrypt?) - ;; Assumes that INPUT is in blocking mode. - (let ((key (blowfish-set-key key)) - (input-buffer (make-string 4096)) - (output-buffer (make-string 4096))) - (dynamic-wind - (lambda () - unspecific) - (lambda () - (let loop ((m 0)) - (let ((n (input-port/read-string! input input-buffer))) - (if (not (fix:= 0 n)) - (let ((m - (blowfish-cfb64 input-buffer 0 n output-buffer 0 - key init-vector m encrypt?))) - (write-substring output-buffer 0 n output) - (loop m)))))) - (lambda () - (string-fill! input-buffer #\NUL) - (string-fill! output-buffer #\NUL))))) + (if (mcrypt-available?) + (mcrypt-encrypt-port "blowfish" "cfb" input output key init-vector + encrypt?) + ;; Assumes that INPUT is in blocking mode. + (let ((key (blowfish-set-key key)) + (input-buffer (make-string 4096)) + (output-buffer (make-string 4096))) + (dynamic-wind + (lambda () + unspecific) + (lambda () + (let loop ((m 0)) + (let ((n (input-port/read-string! input input-buffer))) + (if (not (fix:= 0 n)) + (let ((m + (blowfish-cfb64 input-buffer 0 n output-buffer 0 + key init-vector m encrypt?))) + (write-substring output-buffer 0 n output) + (loop m)))))) + (lambda () + (string-fill! input-buffer #\NUL) + (string-fill! output-buffer #\NUL)))))) (define (compute-blowfish-init-vector) ;; This init vector includes a timestamp with a resolution of diff --git a/v7/src/runtime/crypto.scm b/v7/src/runtime/crypto.scm index f28761aab..25fbc43e3 100644 --- a/v7/src/runtime/crypto.scm +++ b/v7/src/runtime/crypto.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: crypto.scm,v 14.11 2001/01/29 19:32:57 cph Exp $ +$Id: crypto.scm,v 14.12 2001/02/28 21:42:32 cph Exp $ Copyright (c) 2000-2001 Massachusetts Institute of Technology @@ -292,6 +292,147 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (define md5-sum->number mhash-sum->number) (define md5-sum->hexadecimal mhash-sum->hexadecimal) +;;;; The mcrypt library + +(define mcrypt-algorithm-names-vector) +(define mcrypt-mode-names-vector) +(define mcrypt-contexts) +(define-structure mcrypt-context (index #f read-only #t)) + +(define (guarantee-mcrypt-context object procedure) + (if (not (mcrypt-context? object)) + (error:wrong-type-argument object "mcrypt context" procedure))) + +(define (mcrypt-available?) + (implemented-primitive-procedure? (ucode-primitive mcrypt_module_open 2))) + +(define (mcrypt-algorithm-names) + (names-vector->list mcrypt-algorithm-names-vector)) + +(define (mcrypt-mode-names) + (names-vector->list mcrypt-mode-names-vector)) + +(define (mcrypt-open-module algorithm mode) + (without-interrupts + (lambda () + (let ((index ((ucode-primitive mcrypt_module_open 2) algorithm mode))) + (let ((context (make-mcrypt-context index))) + (add-to-gc-finalizer! mcrypt-contexts context index) + context))))) + +(define (mcrypt-init context key init-vector) + (guarantee-mcrypt-context context 'MCRYPT-INIT) + (let ((code + ((ucode-primitive mcrypt_generic_init 3) + (mcrypt-context-index context) key init-vector))) + (if (not (= code 0)) + (error "Error code signalled by mcrypt_generic_init:" code)))) + +(define (mcrypt-encrypt context input input-start input-end + output output-start encrypt?) + (guarantee-mcrypt-context context 'MCRYPT-ENCRYPT) + (substring-move! input input-start input-end output output-start) + (let ((code + ((if encrypt? + (ucode-primitive mcrypt_generic 4) + (ucode-primitive mdecrypt_generic 4)) + (mcrypt-context-index context) + output + output-start + (fix:+ output-start (fix:- input-end input-start))))) + (if (not (= code 0)) + (error (string-append "Error code signalled by " + (if encrypt? + "mcrypt_generic" + "mdecrypt_generic") + ":") + code)))) + +(define (mcrypt-end context) + (guarantee-mcrypt-context context 'MCRYPT-END) + (remove-from-gc-finalizer! mcrypt-contexts context)) + +(define (mcrypt-generic-unary name context-op module-op) + (lambda (object) + (cond ((mcrypt-context? object) (context-op (mcrypt-context-index object))) + ((string? object) (module-op object)) + (else (error:wrong-type-argument object "mcrypt context" name))))) + +(define mcrypt-self-test + (mcrypt-generic-unary + 'MCRYPT-SELF-TEST + (ucode-primitive mcrypt_enc_self_test 1) + (ucode-primitive mcrypt_module_self_test 1))) + +(define mcrypt-block-algorithm-mode? + (mcrypt-generic-unary + 'MCRYPT-BLOCK-ALGORITHM-MODE? + (ucode-primitive mcrypt_enc_is_block_algorithm_mode 1) + (ucode-primitive mcrypt_module_is_block_algorithm_mode 1))) + +(define mcrypt-block-algorithm? + (mcrypt-generic-unary + 'MCRYPT-BLOCK-ALGORITHM? + (ucode-primitive mcrypt_enc_is_block_algorithm 1) + (ucode-primitive mcrypt_module_is_block_algorithm 1))) + +(define mcrypt-block-mode? + (mcrypt-generic-unary + 'MCRYPT-BLOCK-MODE? + (ucode-primitive mcrypt_enc_is_block_mode 1) + (ucode-primitive mcrypt_module_is_block_mode 1))) + +(define mcrypt-key-size + (mcrypt-generic-unary + 'MCRYPT-KEY-SIZE + (ucode-primitive mcrypt_enc_get_key_size 1) + (ucode-primitive mcrypt_module_get_algo_key_size 1))) + +(define mcrypt-supported-key-sizes + (mcrypt-generic-unary + 'MCRYPT-SUPPORTED-KEY-SIZES + (ucode-primitive mcrypt_enc_get_supported_key_sizes 1) + (ucode-primitive mcrypt_module_get_algo_supported_key_sizes 1))) + +(define (mcrypt-init-vector-size context) + (guarantee-mcrypt-context context 'MCRYPT-INIT-VECTOR-SIZE) + ((ucode-primitive mcrypt_enc_get_iv_size 1) + (mcrypt-context-index context))) + +(define (mcrypt-algorithm-name context) + (guarantee-mcrypt-context context 'MCRYPT-ALGORITHM-NAME) + ((ucode-primitive mcrypt_enc_get_algorithms_name 1) + (mcrypt-context-index context))) + +(define (mcrypt-mode-name context) + (guarantee-mcrypt-context context 'MCRYPT-MODE-NAME) + ((ucode-primitive mcrypt_enc_get_modes_name 1) + (mcrypt-context-index context))) + +(define (mcrypt-encrypt-port algorithm mode input output key init-vector + encrypt?) + ;; Assumes that INPUT is in blocking mode. + (let ((context (mcrypt-open-module algorithm mode)) + (input-buffer (make-string 4096)) + (output-buffer (make-string 4096))) + (mcrypt-init context key init-vector) + (dynamic-wind + (lambda () + unspecific) + (lambda () + (let loop () + (let ((n (input-port/read-string! input input-buffer))) + (if (not (fix:= 0 n)) + (begin + (mcrypt-encrypt context input-buffer 0 n output-buffer 0 + encrypt?) + (write-substring output-buffer 0 n output) + (loop))))) + (mcrypt-end context)) + (lambda () + (string-fill! input-buffer #\NUL) + (string-fill! output-buffer #\NUL))))) + ;;;; Package initialization (define (initialize-package!) @@ -306,8 +447,16 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (make-gc-finalizer (ucode-primitive mhash_hmac_end 1))) (set! mhash-keygen-names (make-names-vector (ucode-primitive mhash_keygen_count 0) - (ucode-primitive mhash_get_keygen_name 1))) - unspecific))) + (ucode-primitive mhash_get_keygen_name 1))))) + (if (mcrypt-available?) + (begin + (set! mcrypt-contexts + (make-gc-finalizer (ucode-primitive mcrypt_generic_end 1))) + (set! mcrypt-algorithm-names-vector + ((ucode-primitive mcrypt_list_algorithms 0))) + (set! mcrypt-mode-names-vector + ((ucode-primitive mcrypt_list_modes 0))))) + unspecific) (define (make-names-vector get-count get-name) (let ((n (get-count))) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index dc86a3fe1..4cca60330 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.359 2001/02/05 18:33:19 cph Exp $ +$Id: runtime.pkg,v 14.360 2001/02/28 21:42:42 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -3551,6 +3551,24 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (parent ()) (export () make-mhash-keygen-type + mcrypt-algorithm-name + mcrypt-algorithm-names + mcrypt-available? + mcrypt-block-algorithm-mode? + mcrypt-block-algorithm? + mcrypt-block-mode? + mcrypt-context? + mcrypt-encrypt + mcrypt-encrypt-port + mcrypt-end + mcrypt-init + mcrypt-init-vector-size + mcrypt-key-size + mcrypt-mode-name + mcrypt-mode-names + mcrypt-open-module + mcrypt-self-test + mcrypt-supported-key-sizes md5-available? md5-file md5-string @@ -3558,6 +3576,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. md5-sum->hexadecimal md5-sum->number mhash-available? + mhash-context? mhash-end mhash-file mhash-get-block-size diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm index f63881fe8..328a65d80 100644 --- a/v7/src/runtime/version.scm +++ b/v7/src/runtime/version.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: version.scm,v 14.191 2001/01/04 22:27:50 cph Exp $ +$Id: version.scm,v 14.192 2001/02/28 21:42:44 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -25,10 +25,10 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (declare (usual-integrations)) (define (initialize-package!) - (add-subsystem-identification! "Release" '(7 5 13)) + (add-subsystem-identification! "Release" '(7 5 14)) (snarf-microcode-version!) (add-event-receiver! event:after-restore snarf-microcode-version!) - (add-subsystem-identification! "Runtime" '(14 185))) + (add-subsystem-identification! "Runtime" '(14 186))) (define (snarf-microcode-version!) (add-subsystem-identification! "Microcode" -- 2.25.1