From 3d604516d7f4d95a5819cb4eace0837c5ae47d29 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Fri, 22 Jun 2018 02:20:22 -0700 Subject: [PATCH] =?utf8?q?Punt=20mcrypt=20=C2=B5module;=20autoload=20mcryp?= =?utf8?q?t=20plugin=20version=201.0.?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- src/mcrypt/NEWS | 6 + src/mcrypt/README | 9 +- src/mcrypt/configure.ac | 2 +- src/microcode/configure.ac | 33 -- src/microcode/makegen/Makefile.in.in | 3 - src/microcode/makegen/files-optional.scm | 1 - src/microcode/prmcrypt.c | 397 ----------------------- src/runtime/crypto.scm | 263 ++++----------- src/runtime/make.scm | 1 - src/runtime/runtime.pkg | 5 +- 10 files changed, 77 insertions(+), 643 deletions(-) delete mode 100644 src/microcode/prmcrypt.c diff --git a/src/mcrypt/NEWS b/src/mcrypt/NEWS index 8168798a5..361ad4ba9 100644 --- a/src/mcrypt/NEWS +++ b/src/mcrypt/NEWS @@ -22,6 +22,12 @@ along with MIT/GNU Scheme; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. +mit-scheme-mcrypt 1.0 - Matt Birkholz, 2018-06-22 +================================================= + +Replace the mcrypt µmodule. The largely deprecated (runtime crypto) +package now autoloads this plugin. + mit-scheme-mcrypt 0.2 - Matt Birkholz, 2017-05-18 ================================================= diff --git a/src/mcrypt/README b/src/mcrypt/README index 99e3112f7..2d80c008f 100644 --- a/src/mcrypt/README +++ b/src/mcrypt/README @@ -1,8 +1,7 @@ The Mcrypt option. -This plugin creates an (mcrypt) package, a drop-in replacement for the -microcode module based mcrypt-* procedures in the (runtime crypto) -package. It is built in the customary GNU way: +This plugin creates an (mcrypt) package. It is built in the customary +GNU way: ./configure ... make all check install @@ -14,8 +13,8 @@ To use: Import-mcrypt will modify the REPL's current environment by adding bindings linked to the plugin's exports. They are not exported to the -global environment because they would conflict with the exports from -(runtime crypto). +global environment because they would conflict with the deprecated +exports from (runtime crypto). To import into a CREF package set, add this to your .pkg file: diff --git a/src/mcrypt/configure.ac b/src/mcrypt/configure.ac index 1b29a043c..54947a6f4 100644 --- a/src/mcrypt/configure.ac +++ b/src/mcrypt/configure.ac @@ -2,7 +2,7 @@ dnl Process this file with autoconf to produce a configure script. AC_PREREQ([2.69]) AC_INIT([MIT/GNU Scheme mcrypt plugin], - [0.2], + [1.0], [bug-mit-scheme@gnu.org], [mit-scheme-mcrypt]) AC_CONFIG_SRCDIR([mcrypt.pkg]) diff --git a/src/microcode/configure.ac b/src/microcode/configure.ac index 2a79ec97c..75040e89a 100644 --- a/src/microcode/configure.ac +++ b/src/microcode/configure.ac @@ -130,11 +130,6 @@ AC_ARG_ENABLE([native-code], [Support native compiled code if available [[yes]]])) : ${enable_native_code='yes'} -AC_ARG_WITH([mcrypt], - AS_HELP_STRING([--with-mcrypt], - [Use mcrypt library if available [[yes]]])) -: ${with_mcrypt='yes'} - AC_ARG_WITH([termcap], AS_HELP_STRING([--with-termcap], [Use a termcap library if available [[yes]]])) @@ -810,34 +805,6 @@ no) ;; esac -dnl These libraries might not be installed, so take care generating -dnl file dependencies using "makegen/makegen.scm" when called on -dnl "makegen/files-optional.scm". To wit, "prmcrypt.c" must -dnl conditionalize its dependencies on , respectively, to -dnl avoid warnings in "Makefile.deps" and its embeds. - -dnl The mcrypt library provides blowfish, but its CFB mode is 8 bit. -dnl We have been using 64-bit CFB, so this isn't really compatible. -dnl But mcrypt provides many ciphers and can be loaded in addition. -if test "${with_mcrypt}" != no; then - if test "${with_mcrypt}" != yes; then - CPPFLAGS="${CPPFLAGS} -I${with_mcrypt}/include" - LDFLAGS="${LDFLAGS} -L${with_mcrypt}/lib" - fi - AC_CHECK_HEADER([mcrypt.h], - [ - AC_DEFINE([HAVE_MCRYPT_H], [1], - [Define to 1 if you have the header file.]) - AC_CHECK_LIB([mcrypt], [mcrypt_generic_init], - [ - AC_DEFINE([HAVE_LIBMCRYPT], [1], - [Define to 1 if you have the `mcrypt' library (-lmcrypt).]) - MODULE_LIBS="-lmcrypt ${MODULE_LIBS}" - MODULE_BASES="${MODULE_BASES} prmcrypt" - ]) - ]) -fi - dnl Add support for X if present. if test "${no_x}" != yes; then if test "x${x_includes}" != x; then diff --git a/src/microcode/makegen/Makefile.in.in b/src/microcode/makegen/Makefile.in.in index aa802282d..c1dc434c2 100644 --- a/src/microcode/makegen/Makefile.in.in +++ b/src/microcode/makegen/Makefile.in.in @@ -190,9 +190,6 @@ extract-liarc-decls: extract-liarc-decls.o macosx-starter: macosx-starter.o $(LINK) macosx-starter.o -prmcrypt.so: prmcrypt.o @MODULE_LOADER@ - $(LINK_MODULE) prmcrypt.o -lmcrypt $(MODULE_LIBS) - prx11.so: prx11.o x11base.o x11color.o x11graph.o x11term.o @MODULE_LOADER@ $(LINK_MODULE) prx11.o x11base.o x11color.o x11graph.o x11term.o \ -lX11 $(MODULE_LIBS) diff --git a/src/microcode/makegen/files-optional.scm b/src/microcode/makegen/files-optional.scm index 9e8e215c5..8972e85df 100644 --- a/src/microcode/makegen/files-optional.scm +++ b/src/microcode/makegen/files-optional.scm @@ -28,7 +28,6 @@ USA. "cmpint" "comutl" -"prmcrypt" "pruxdld" "pruxffi" "prx11" diff --git a/src/microcode/prmcrypt.c b/src/microcode/prmcrypt.c deleted file mode 100644 index bd3b25041..000000000 --- a/src/microcode/prmcrypt.c +++ /dev/null @@ -1,397 +0,0 @@ -/* -*-C-*- - -Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, - 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, - 2017, 2018 Massachusetts Institute of Technology - -This file is part of MIT/GNU Scheme. - -MIT/GNU Scheme 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. - -MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software -Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, -USA. - -*/ - -/* Interface to mcrypt library */ - -#include "scheme.h" -#include "prims.h" -#include "usrdef.h" -#include "os.h" - -/* If mcrypt.h unavailable, ignore it. This helps - "makegen/makegen.scm" work properly on systems lacking this - library. */ -#ifdef HAVE_MCRYPT_H -# include -#endif - -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_POINTER (ARG_REF (2))), - (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 -deallocate_list (void * 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 -deallocate_key_sizes (void * 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 * -dload_initialize_file (void) -{ - 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 */ diff --git a/src/runtime/crypto.scm b/src/runtime/crypto.scm index 520c30e9e..6738b8003 100644 --- a/src/runtime/crypto.scm +++ b/src/runtime/crypto.scm @@ -49,189 +49,6 @@ USA. (context ((ucode-primitive md5-init 0)))) ((ucode-primitive md5-update 4) context bytes start end) ((ucode-primitive md5-final 1) context))) - -;;;; The mcrypt library - -(define mcrypt-initialized?) -(define mcrypt-algorithm-names-vector) -(define mcrypt-mode-names-vector) -(define mcrypt-contexts) -(define-structure mcrypt-context index) - -(define (guarantee-mcrypt-context object procedure) - (if (not (mcrypt-context? object)) - (error:wrong-type-argument object "mcrypt context" procedure)) - (if (not (mcrypt-context-index object)) - (error:bad-range-argument object procedure))) - -(define (mcrypt-available?) - (load-library-object-file "prmcrypt" #f) - (and (implemented-primitive-procedure? - (ucode-primitive mcrypt_module_open 2)) - (begin - (if (not mcrypt-initialized?) - (begin - (set! mcrypt-contexts - (make-gc-finalizer (ucode-primitive mcrypt_generic_end 1) - mcrypt-context? - mcrypt-context-index - set-mcrypt-context-index!)) - (set! mcrypt-algorithm-names-vector - ((ucode-primitive mcrypt_list_algorithms 0))) - (set! mcrypt-mode-names-vector - ((ucode-primitive mcrypt_list_modes 0))) - (set! mcrypt-initialized? #t))) - #t))) - -(define (reset-mcrypt-variables!) - (set! mcrypt-initialized? #f) - unspecific) - -(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-interruption - (lambda () - (add-to-gc-finalizer! mcrypt-contexts - (make-mcrypt-context - ((ucode-primitive mcrypt_module_open 2) algorithm - mode)))))) - -(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 (eqv? code 0)) - (error "Error code signalled by mcrypt_generic_init:" code)))) - -(define-integrable (make-mcrypt-transform! name primitive) - (lambda (context bytes start end) - (guarantee-mcrypt-context context name) - (let ((code (primitive (mcrypt-context-index context) bytes start end))) - (if (not (eqv? code 0)) - (error (string "Error code signalled by "name":") code))))) - -(define mcrypt-encrypt! - (make-mcrypt-transform! 'mcrypt-encrypt! - (ucode-primitive mcrypt_generic 4))) - -(define mcrypt-decrypt! - (make-mcrypt-transform! 'mcrypt-decrypt! - (ucode-primitive mdecrypt_generic 4))) - -(define (mcrypt-encrypt context input input-start input-end - output output-start encrypt?) - ((if encrypt? mcrypt-encrypt! mcrypt-decrypt!) - context - output - output-start - (bytevector-copy! output output-start input input-start input-end))) - -(define (mcrypt-end context) - (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))) - ((bytevector? object) (module-op object)) - ((string? object) (module-op (string->utf8 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. - ((port-transformer (lambda () - (let ((context (mcrypt-open-module algorithm mode))) - (mcrypt-init context key init-vector) - context)) - (if encrypt? mcrypt-encrypt! mcrypt-decrypt!) - mcrypt-end) - input - output)) - -;;;; Package initialization - -(define (initialize-package!) - (reset-mcrypt-variables!) - (add-event-receiver! event:after-restart reset-mcrypt-variables!)) - -(define (make-names-vector get-count get-name) - (let ((n (get-count))) - (let ((v (make-vector n))) - (do ((i 0 (fix:+ i 1))) - ((fix:= i n)) - (vector-set! v i - (let ((name (get-name i))) - (and name - (intern name))))) - v))) - -(define (names-vector->list v) - (let ((end (vector-length v))) - (let loop ((index 0) (names '())) - (if (fix:< index end) - (loop (fix:+ index 1) - (let ((name (vector-ref v index))) - (if name - (cons name names) - names))) - names)))) (define (port-consumer initialize update finalize) (lambda (port) @@ -246,22 +63,6 @@ USA. (loop))))) (finalize context)))))) -(define (port-transformer initialize update finalize) - (lambda (input-port output-port) - (call-with-buffer #x1000 - (lambda (buffer) - (let ((context (initialize))) - (let loop () - (let ((n (read-bytevector! buffer input-port))) - (if (and n (fix:> n 0)) - (begin - (update context buffer 0 n) - (let ((n* (write-bytevector buffer output-port 0 n))) - (if (not (eqv? n n*)) - (error "Short write (requested, actual):" n n*))) - (loop))))) - (finalize context)))))) - (define (call-with-buffer n procedure) (let ((buffer (make-bytevector n))) (dynamic-wind @@ -270,4 +71,66 @@ USA. (lambda () (procedure buffer)) (lambda () - (bytevector-fill! buffer 0))))) \ No newline at end of file + (bytevector-fill! buffer 0))))) + +;;;; The mcrypt library + +(define mcrypt-linked? #f) + +(define (mcrypt-available?) + (and (plugin-available? "mcrypt") + (or mcrypt-linked? + (begin + (load-option 'mcrypt) + (mcrypt-link!) + #t)))) + +(define (mcrypt-link!) + (for-each + (let ((runtime (->environment '(runtime crypto))) + (mcrypt (->environment '(mcrypt)))) + (lambda (name) + (environment-link-name runtime mcrypt name))) + mcrypt-names) + (set! mcrypt-linked? #t)) + +(define mcrypt-names + '(mcrypt-algorithm-name + mcrypt-algorithm-names + mcrypt-block-algorithm-mode? + mcrypt-block-algorithm? + mcrypt-block-mode? + mcrypt-context? + mcrypt-decrypt! + mcrypt-encrypt + 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)) + +(define mcrypt-algorithm-name) +(define mcrypt-algorithm-names) +(define mcrypt-block-algorithm-mode?) +(define mcrypt-block-algorithm?) +(define mcrypt-block-mode?) +(define mcrypt-context?) +(define mcrypt-decrypt!) +(define mcrypt-encrypt) +(define mcrypt-encrypt!) +(define mcrypt-encrypt-port) +(define mcrypt-end) +(define mcrypt-init) +(define mcrypt-init-vector-size) +(define mcrypt-key-size) +(define mcrypt-mode-name) +(define mcrypt-mode-names) +(define mcrypt-open-module) +(define mcrypt-self-test) +(define mcrypt-supported-key-sizes) \ No newline at end of file diff --git a/src/runtime/make.scm b/src/runtime/make.scm index a289c1ef8..882d20d9e 100644 --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@ -545,7 +545,6 @@ USA. (runtime debugger) ;; Misc (e.g., version) (runtime) - (runtime crypto) ;; Graphics. The last type initialized is the default for ;; MAKE-GRAPHICS-DEVICE, only the types that are valid for the ;; operating system are actually loaded and initialized. diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index a7a7577f6..3ae5c2491 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -5233,7 +5233,7 @@ USA. (define-package (runtime crypto) (files "crypto") (parent (runtime)) - (export () + (export () deprecated:crypto mcrypt-algorithm-name mcrypt-algorithm-names mcrypt-available? @@ -5253,7 +5253,8 @@ USA. mcrypt-mode-names mcrypt-open-module mcrypt-self-test - mcrypt-supported-key-sizes + mcrypt-supported-key-sizes) + (export () md5-available? md5-bytevector md5-file -- 2.25.1