From e5b29c3c7869af025279ce335736e8111fa712cf Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
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 <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));
+ }
+}
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