From 6846ddb23c9187ee916c01463706825a9c20c894 Mon Sep 17 00:00:00 2001 From: Taylor R Campbell Date: Sat, 4 Nov 2017 03:18:32 +0000 Subject: [PATCH] Rip out microcode mhash module. --- dist/shared.sh | 2 +- doc/user-manual/user.texinfo | 7 +- src/README.txt | 3 +- src/microcode/configure.ac | 35 +- src/microcode/makegen/Makefile.in.in | 3 - src/microcode/makegen/files-optional.scm | 1 - src/microcode/prmhash.c | 426 ----------------------- src/runtime/crypto.scm | 226 ------------ src/runtime/runtime.pkg | 24 +- 9 files changed, 8 insertions(+), 719 deletions(-) delete mode 100644 src/microcode/prmhash.c diff --git a/dist/shared.sh b/dist/shared.sh index ace319d10..352830c12 100644 --- a/dist/shared.sh +++ b/dist/shared.sh @@ -100,7 +100,7 @@ LIARC_OUT=${OUTPUT_DIR}/liarc NATIVE_OUT=${OUTPUT_DIR}/native MACOSX_OUT=${OUTPUT_DIR}/macosx -PLUGINS="blowfish gdbm mcrypt mhash x11 x11-screen" +PLUGINS="blowfish gdbm mcrypt x11 x11-screen" notify () { diff --git a/doc/user-manual/user.texinfo b/doc/user-manual/user.texinfo index a5619d726..8a60c8b24 100644 --- a/doc/user-manual/user.texinfo +++ b/doc/user-manual/user.texinfo @@ -242,12 +242,11 @@ may need super-user privileges to do the installation step. @emph{After} you have installed Scheme, you can install a few dynamically loadable options. These are configured, built and -installed in the customary way. To install the @code{GDBM2} and -@code{MHASH} options: +installed in the customary way. To install the @code{GDBM2} +option: @smallexample (cd gdbm && make && make install) -(cd mhash && ./configure && make && make install) @end smallexample The @code{make install} command will attempt to create a subdirectory @@ -283,8 +282,6 @@ for more information. libssl-dev (-lcrypto) @item GDBM2 libgdbm-dev (-lgdbm) -@item MHASH -libmhash-dev (-lmhash) @end table After installing the software and any options, you can delete the diff --git a/src/README.txt b/src/README.txt index 009ab12ff..63dfa0708 100644 --- a/src/README.txt +++ b/src/README.txt @@ -81,8 +81,7 @@ There are a few C/Unix FFI plugins: * "mcrypt" wraps libmcrypt and provides replacements for the mcrypt-* procedures implemented in (runtime crypto). -* "mhash" wraps libmhash and provides replacements for the mhash-* - procedures in (runtime crypto). +* "mhash" wraps libmhash. These are miscellaneous extras: diff --git a/src/microcode/configure.ac b/src/microcode/configure.ac index 466847458..65c41703e 100644 --- a/src/microcode/configure.ac +++ b/src/microcode/configure.ac @@ -135,11 +135,6 @@ AC_ARG_WITH([openssl], [Use OpenSSL crypto library if available [[yes]]])) : ${with_openssl='yes'} -AC_ARG_WITH([mhash], - AS_HELP_STRING([--with-mhash], - [Use mhash library if available [[yes]]])) -: ${with_mhash='yes'} - AC_ARG_WITH([mcrypt], AS_HELP_STRING([--with-mcrypt], [Use mcrypt library if available [[yes]]])) @@ -850,33 +845,9 @@ fi 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, "prmhash.c" & "prmcrypt.c" -dnl must conditionalize their dependencies on & , -dnl respectively, to avoid warnings in "Makefile.deps" and its embeds. - -dnl The mhash library provides MD5 support. It can be loaded in addition -dnl to other MD5 libraries and provides a rich set of hashes. -if test "${with_mhash}" != no; then - if test "${with_mhash}" != yes; then - CPPFLAGS="${CPPFLAGS} -I${with_mhash}/include" - LDFLAGS="${LDFLAGS} -L${with_mhash}/lib" - fi - AC_CHECK_HEADER([mhash.h], - [ - AC_DEFINE([HAVE_MHASH_H], [1], - [Define to 1 if you have the header file.]) - AC_CHECK_LIB([mhash], [mhash_count], - [ - AC_DEFINE([HAVE_LIBMHASH], [1], - [Define to 1 if you have the `mhash' library (-lmhash).]) - if test ${enable_debugging} != no; then - LIBS="-lmhash ${LIBS}" - fi - MODULE_LIBS="-lmhash ${MODULE_LIBS}" - MODULE_BASES="${MODULE_BASES} prmhash" - ]) - ]) -fi +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. diff --git a/src/microcode/makegen/Makefile.in.in b/src/microcode/makegen/Makefile.in.in index c7847d20b..4a2716eb4 100644 --- a/src/microcode/makegen/Makefile.in.in +++ b/src/microcode/makegen/Makefile.in.in @@ -194,9 +194,6 @@ macosx-starter: macosx-starter.o prbfish.so: prbfish.o @MODULE_LOADER@ $(LINK_MODULE) prbfish.o $(PRBFISH_LIBS) $(MODULE_LIBS) -prmhash.so: prmhash.o @MODULE_LOADER@ - $(LINK_MODULE) prmhash.o -lmhash $(MODULE_LIBS) - prmcrypt.so: prmcrypt.o @MODULE_LOADER@ $(LINK_MODULE) prmcrypt.o -lmcrypt $(MODULE_LIBS) diff --git a/src/microcode/makegen/files-optional.scm b/src/microcode/makegen/files-optional.scm index 6e9666c0f..0c2d6b5f9 100644 --- a/src/microcode/makegen/files-optional.scm +++ b/src/microcode/makegen/files-optional.scm @@ -31,7 +31,6 @@ USA. "prbfish" "prgdbm" "prmcrypt" -"prmhash" "prpgsql" "pruxdld" "pruxffi" diff --git a/src/microcode/prmhash.c b/src/microcode/prmhash.c deleted file mode 100644 index b0ab8056f..000000000 --- a/src/microcode/prmhash.c +++ /dev/null @@ -1,426 +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 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 mhash library */ - -#include "scheme.h" -#include "prims.h" -#include "usrdef.h" -#include "os.h" - -/* If mhash.h unavailable, ignore it. This helps - "makegen/makegen.scm" work properly on systems lacking this - library. */ -#ifdef HAVE_MHASH_H -# include -#endif - -#define UNARY_OPERATION(name, get_arg, cvt_val) \ -{ \ - PRIMITIVE_HEADER (1); \ - PRIMITIVE_RETURN (cvt_val (name (get_arg (1)))); \ -} - -static SCHEME_OBJECT -cp2s (void * cp) -{ - if (cp == 0) - return (SHARP_F); - else - { - SCHEME_OBJECT s = (char_pointer_to_string (cp)); - free (cp); - return (s); - } -} - -typedef struct -{ - MHASH context; - hashid id; -} context_entry; - -static size_t context_table_length = 0; -static context_entry * context_table = 0; - -static size_t -search_context_table (MHASH context) -{ - size_t i; - for (i = 0; (i < context_table_length); i += 1) - if (((context_table[i]) . context) == 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 (context_entry)) * context_table_length)); - } - else - { - context_table_length *= 2; - context_table - = (OS_realloc (context_table, - ((sizeof (context_entry)) * context_table_length))); - } - { - size_t j; - for (j = i; (j < context_table_length); j += 1) - ((context_table[j]) . context) = 0; - } - return (i); -} - -static SCHEME_OBJECT -store_context (MHASH context, hashid id) -{ - if (context == MHASH_FAILED) - return (SHARP_F); - { - size_t i = (allocate_context_entry ()); - ((context_table[i]) . context) = context; - ((context_table[i]) . id) = id; - return (ulong_to_integer (i)); - } -} - -static void -forget_context (size_t index) -{ - ((context_table[index]) . context) = 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]) . context) == 0) - error_bad_range_arg (arg); - return (n); -} - -static MHASH -arg_context (unsigned int arg) -{ - return ((context_table [arg_context_index (arg)]) . context); -} - -static size_t hashid_count; -static hashid * hashid_map = 0; - -static void -initialize_hashid_map (void) -{ - if (hashid_map == 0) - { - size_t i = 0; - size_t j = 0; - hashid_count = (mhash_count ()); - hashid_map = (OS_malloc ((sizeof (hashid)) * hashid_count)); - while (i <= hashid_count) - { - if ((mhash_get_block_size (i)) != 0) - (hashid_map[j++]) = ((hashid) i); - i += 1; - } - } -} - -static hashid -arg_hashid (unsigned int arg) -{ - initialize_hashid_map (); - return (hashid_map [arg_ulong_index_integer (arg, hashid_count)]); -} - -DEFINE_PRIMITIVE ("MHASH_COUNT", Prim_mhash_count, 0, 0, 0) -{ - PRIMITIVE_HEADER (0); - initialize_hashid_map (); - PRIMITIVE_RETURN (ulong_to_integer (hashid_count)); -} - -DEFINE_PRIMITIVE ("MHASH_GET_BLOCK_SIZE", Prim_mhash_get_block_size, 1, 1, 0) - UNARY_OPERATION (mhash_get_block_size, arg_hashid, ulong_to_integer) -DEFINE_PRIMITIVE ("MHASH_GET_HASH_PBLOCK", Prim_mhash_get_hash_pblock, 1, 1, 0) - UNARY_OPERATION (mhash_get_hash_pblock, arg_hashid, ulong_to_integer) -DEFINE_PRIMITIVE ("MHASH_GET_HASH_NAME", Prim_mhash_get_hash_name, 1, 1, 0) - UNARY_OPERATION (mhash_get_hash_name, arg_hashid, cp2s) - -DEFINE_PRIMITIVE ("MHASH_INIT", Prim_mhash_init, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - { - hashid id = (arg_hashid (1)); - PRIMITIVE_RETURN (store_context ((mhash_init (id)), id)); - } -} - -DEFINE_PRIMITIVE ("MHASH_HMAC_INIT", Prim_mhash_hmac_init, 3, 3, 0) -{ - PRIMITIVE_HEADER (3); - CHECK_ARG (2, STRING_P); - { - hashid id = (arg_hashid (1)); - SCHEME_OBJECT key = (ARG_REF (2)); - PRIMITIVE_RETURN - (store_context ((mhash_hmac_init (id, - (STRING_POINTER (key)), - (STRING_LENGTH (key)), - (arg_ulong_integer (3)))), - id)); - } -} - -DEFINE_PRIMITIVE ("MHASH", Prim_mhash, 4, 4, 0) -{ - PRIMITIVE_HEADER (4); - CHECK_ARG (2, STRING_P); - { - SCHEME_OBJECT string = (ARG_REF (2)); - unsigned long end - = (arg_ulong_index_integer (4, ((STRING_LENGTH (string)) + 1))); - unsigned long start = (arg_ulong_index_integer (3, (end + 1))); - mhash ((arg_context (1)), (STRING_LOC (string, start)), (end - start)); - } - PRIMITIVE_RETURN (UNSPECIFIC); -} - -DEFINE_PRIMITIVE ("MHASH_END", Prim_mhash_end, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - { - size_t index = (arg_context_index (1)); - MHASH context = ((context_table[index]) . context); - hashid id = ((context_table[index]) . id); - size_t block_size = (mhash_get_block_size (id)); - /* Must allocate string _before_ calling mhash_end. */ - SCHEME_OBJECT sd = (allocate_string (block_size)); - void * digest = (mhash_end (context)); - forget_context (index); - memcpy ((STRING_POINTER (sd)), digest, block_size); - free (digest); - PRIMITIVE_RETURN (sd); - } -} - -DEFINE_PRIMITIVE ("MHASH_HMAC_END", Prim_mhash_hmac_end, 1, 1, 0) -{ - PRIMITIVE_HEADER (1); - { - size_t index = (arg_context_index (1)); - MHASH context = ((context_table[index]) . context); - hashid id = ((context_table[index]) . id); - size_t block_size = (mhash_get_block_size (id)); - /* Must allocate string _before_ calling mhash_hmac_end. */ - SCHEME_OBJECT sd = (allocate_string (block_size)); - void * digest = (mhash_hmac_end (context)); - forget_context (index); - memcpy ((STRING_POINTER (sd)), digest, block_size); - free (digest); - PRIMITIVE_RETURN (sd); - } -} - -static size_t keygenid_count; -static keygenid * keygenid_map = 0; - -static void -initialize_keygenid_map (void) -{ - if (keygenid_map == 0) - { - size_t i = 0; - size_t j = 0; - keygenid_count = (mhash_keygen_count ()); - keygenid_map = (OS_malloc ((sizeof (keygenid)) * keygenid_count)); - while (j < keygenid_count) - { - void * name = (mhash_get_keygen_name (i)); - if (name != 0) - { - (keygenid_map[j++]) = ((keygenid) i); - free (name); - } - i += 1; - } - } -} - -static keygenid -arg_keygenid (unsigned int arg) -{ - initialize_keygenid_map (); - return (keygenid_map [arg_ulong_index_integer (arg, keygenid_count)]); -} - -DEFINE_PRIMITIVE ("MHASH_KEYGEN_COUNT", Prim_mhash_keygen_count, 0, 0, 0) -{ - PRIMITIVE_HEADER (0); - initialize_keygenid_map (); - PRIMITIVE_RETURN (ulong_to_integer (keygenid_count)); -} - -DEFINE_PRIMITIVE ("MHASH_GET_KEYGEN_NAME", Prim_mhash_get_keygen_name, 1, 1, 0) - UNARY_OPERATION (mhash_get_keygen_name, arg_keygenid, cp2s) -DEFINE_PRIMITIVE ("MHASH_KEYGEN_USES_SALT", Prim_mhash_keygen_uses_salt, 1, 1, 0) - UNARY_OPERATION (mhash_keygen_uses_salt, arg_keygenid, BOOLEAN_TO_OBJECT) -DEFINE_PRIMITIVE ("MHASH_KEYGEN_USES_COUNT", Prim_mhash_keygen_uses_count, 1, 1, 0) - UNARY_OPERATION (mhash_keygen_uses_count, arg_keygenid, BOOLEAN_TO_OBJECT) -DEFINE_PRIMITIVE ("MHASH_KEYGEN_USES_HASH_ALGORITHM", Prim_mhash_keygen_uses_hash_algorithm, 1, 1, 0) - UNARY_OPERATION (mhash_keygen_uses_hash_algorithm, arg_keygenid, long_to_integer) -DEFINE_PRIMITIVE ("MHASH_GET_KEYGEN_SALT_SIZE", Prim_mhash_get_keygen_salt_size, 1, 1, 0) - UNARY_OPERATION (mhash_get_keygen_salt_size, arg_keygenid, ulong_to_integer) -DEFINE_PRIMITIVE ("MHASH_GET_KEYGEN_MAX_KEY_SIZE", Prim_mhash_get_keygen_max_key_size, 1, 1, 0) - UNARY_OPERATION (mhash_get_keygen_max_key_size, arg_keygenid, ulong_to_integer) - -DEFINE_PRIMITIVE ("MHASH_KEYGEN", Prim_mhash_keygen, 4, 4, 0) -{ - /* keygen-id #(salt count hashid ...) keyword passphrase */ - PRIMITIVE_HEADER (4); - CHECK_ARG (2, VECTOR_P); - CHECK_ARG (3, STRING_P); - CHECK_ARG (4, STRING_P); - { - keygenid id = (arg_keygenid (1)); - SCHEME_OBJECT parameters = (ARG_REF (2)); - SCHEME_OBJECT keyword = (ARG_REF (3)); - SCHEME_OBJECT passphrase = (ARG_REF (4)); - unsigned int n_algs = (mhash_keygen_uses_hash_algorithm (id)); - SCHEME_OBJECT salt; - SCHEME_OBJECT count; - KEYGEN cparms; - { - size_t max_key_size = (mhash_get_keygen_max_key_size (id)); - if ((max_key_size != 0) && ((STRING_LENGTH (keyword)) > max_key_size)) - error_bad_range_arg (4); - } - if ((VECTOR_LENGTH (parameters)) != (2 + n_algs)) - error_bad_range_arg (2); - salt = (VECTOR_REF (parameters, 0)); - count = (VECTOR_REF (parameters, 1)); - if (mhash_keygen_uses_salt (id)) - { - if (!STRING_P (salt)) - error_bad_range_arg (2); - { - size_t salt_size = (mhash_get_keygen_salt_size (id)); - if ((salt_size != 0) && ((STRING_LENGTH (salt)) != salt_size)) - error_bad_range_arg (2); - } - (cparms . salt) = (STRING_BYTE_PTR (salt)); - (cparms . salt_size) = (STRING_LENGTH (salt)); - } - else if (salt != SHARP_F) - error_bad_range_arg (2); - if (mhash_keygen_uses_count (id)) - { - if (!integer_to_ulong_p (count)) - error_bad_range_arg (2); - (cparms . count) = (integer_to_ulong (count)); - } - else if (count != SHARP_F) - error_bad_range_arg (2); - { - unsigned int i; - initialize_hashid_map (); - for (i = 0; (i < n_algs); i += 1) - { - SCHEME_OBJECT a = (VECTOR_REF (parameters, (2 + i))); - if (!integer_to_ulong_p (a)) - error_bad_range_arg (2); - { - unsigned long ia = (integer_to_ulong (a)); - if (ia < hashid_count) - ((cparms . hash_algorithm) [i]) = (hashid_map[ia]); - else - error_bad_range_arg (2); - } - } - } - PRIMITIVE_RETURN - (BOOLEAN_TO_OBJECT - ((mhash_keygen_ext (id, cparms, - (STRING_POINTER (keyword)), - (STRING_LENGTH (keyword)), - (STRING_BYTE_PTR (passphrase)), - (STRING_LENGTH (passphrase)))) - == 0)); - } -} - -#ifdef COMPILE_AS_MODULE - -char * -dload_initialize_file (void) -{ - declare_primitive - ("MHASH_COUNT", Prim_mhash_count, 0, 0, 0); - declare_primitive - ("MHASH_GET_BLOCK_SIZE", Prim_mhash_get_block_size, 1, 1, 0); - declare_primitive - ("MHASH_GET_HASH_PBLOCK", Prim_mhash_get_hash_pblock, 1, 1, 0); - declare_primitive - ("MHASH_GET_HASH_NAME", Prim_mhash_get_hash_name, 1, 1, 0); - declare_primitive - ("MHASH_INIT", Prim_mhash_init, 1, 1, 0); - declare_primitive - ("MHASH_HMAC_INIT", Prim_mhash_hmac_init, 3, 3, 0); - declare_primitive - ("MHASH", Prim_mhash, 4, 4, 0); - declare_primitive - ("MHASH_END", Prim_mhash_end, 1, 1, 0); - declare_primitive - ("MHASH_HMAC_END", Prim_mhash_hmac_end, 1, 1, 0); - declare_primitive - ("MHASH_KEYGEN_COUNT", Prim_mhash_keygen_count, 0, 0, 0); - declare_primitive - ("MHASH_GET_KEYGEN_NAME", Prim_mhash_get_keygen_name, 1, 1, 0); - declare_primitive - ("MHASH_KEYGEN_USES_SALT", Prim_mhash_keygen_uses_salt, 1, 1, 0); - declare_primitive - ("MHASH_KEYGEN_USES_COUNT", Prim_mhash_keygen_uses_count, 1, 1, 0); - declare_primitive - ("MHASH_KEYGEN_USES_HASH_ALGORITHM", Prim_mhash_keygen_uses_hash_algorithm, 1, 1, 0); - declare_primitive - ("MHASH_GET_KEYGEN_SALT_SIZE", Prim_mhash_get_keygen_salt_size, 1, 1, 0); - declare_primitive - ("MHASH_GET_KEYGEN_MAX_KEY_SIZE", Prim_mhash_get_keygen_max_key_size, 1, 1, 0); - declare_primitive - ("MHASH_KEYGEN", Prim_mhash_keygen, 4, 4, 0); - return "#prmd5"; -} - -#endif /* COMPILE_AS_MODULE */ diff --git a/src/runtime/crypto.scm b/src/runtime/crypto.scm index 14eaf2bd4..886007607 100644 --- a/src/runtime/crypto.scm +++ b/src/runtime/crypto.scm @@ -29,230 +29,6 @@ USA. (declare (usual-integrations)) -;;;; The mhash library - -(define mhash-initialized?) -(define mhash-algorithm-names) -(define mhash-contexts) -(define mhash-hmac-contexts) - -(define (mhash-name->id name procedure) - (let ((n (vector-length mhash-algorithm-names))) - (let loop ((i 0)) - (cond ((fix:= i n) (error:bad-range-argument name procedure)) - ((eq? name (vector-ref mhash-algorithm-names i)) i) - (else (loop (fix:+ i 1))))))) - -(define-structure mhash-context index) -(define-structure mhash-hmac-context index) - -(define (guarantee-mhash-context object caller) - (if (not (mhash-context? object)) - (error:wrong-type-argument object "mhash context" caller)) - (if (not (mhash-context-index object)) - (error:bad-range-argument object caller))) - -(define (guarantee-mhash-hmac-context object caller) - (if (not (mhash-hmac-context? object)) - (error:wrong-type-argument object "mhash HMAC context" caller)) - (if (not (mhash-hmac-context-index object)) - (error:bad-range-argument object caller))) - -(define (mhash-type-names) - (names-vector->list mhash-algorithm-names)) - -(define (mhash-get-block-size name) - ((ucode-primitive mhash_get_block_size 1) - (mhash-name->id name 'mhash-get-block-size))) - -(define (mhash-init name) - (let ((id (mhash-name->id name 'mhash-init))) - (without-interruption - (lambda () - (let ((index ((ucode-primitive mhash_init 1) id))) - (if (not index) - (error "Unable to allocate mhash context:" name)) - (add-to-gc-finalizer! mhash-contexts (make-mhash-context index))))))) - -(define (mhash-update context bytes start end) - (guarantee-mhash-context context 'mhash-update) - ((ucode-primitive mhash 4) (mhash-context-index context) bytes start end)) - -(define (mhash-end context) - (remove-from-gc-finalizer! mhash-contexts context)) - -(define (mhash-hmac-init name key) - (let* ((id (mhash-name->id name 'mhash-init)) - (pblock ((ucode-primitive mhash_get_hash_pblock 1) id))) - (without-interruption - (lambda () - (let ((index ((ucode-primitive mhash_hmac_init 3) id key pblock))) - (if (not index) - (error "Unable to allocate mhash HMAC context:" name)) - (add-to-gc-finalizer! mhash-hmac-contexts - (make-mhash-hmac-context index))))))) - -(define (mhash-hmac-update context bytes start end) - (guarantee-mhash-hmac-context context 'mhash-hmac-update) - ((ucode-primitive mhash 4) (mhash-hmac-context-index context) - bytes start end)) - -(define (mhash-hmac-end context) - (remove-from-gc-finalizer! mhash-hmac-contexts context)) - -(define mhash-keygen-names) - -(define (keygen-name->id name caller) - (let ((n (vector-length mhash-keygen-names))) - (let loop ((i 0)) - (cond ((fix:= i n) (error:bad-range-argument name caller)) - ((eq? name (vector-ref mhash-keygen-names i)) i) - (else (loop (fix:+ i 1))))))) - -(define (mhash-keygen-type-names) - (names-vector->list mhash-keygen-names)) - -(define (mhash-keygen-uses-salt? name) - ((ucode-primitive mhash_keygen_uses_salt 1) - (keygen-name->id name 'mhash-keygen-uses-salt?))) - -(define (mhash-keygen-uses-count? name) - ((ucode-primitive mhash_keygen_uses_count 1) - (keygen-name->id name 'mhash-keygen-uses-count?))) - -(define (mhash-keygen-uses-hash-algorithm name) - ((ucode-primitive mhash_keygen_uses_hash_algorithm 1) - (keygen-name->id name 'mhash-keygen-uses-hash-algorithm))) - -(define (mhash-keygen-salt-size name) - ((ucode-primitive mhash_get_keygen_salt_size 1) - (keygen-name->id name 'mhash-keygen-salt-size))) - -(define (mhash-keygen-max-key-size name) - ((ucode-primitive mhash_get_keygen_max_key_size 1) - (keygen-name->id name 'mhash-keygen-max-key-size))) - -(define (mhash-keygen type passphrase #!optional salt) - (if (not (mhash-keygen-type? type)) - (error:wrong-type-argument type "mhash type" 'mhash-keygen)) - (let ((id (mhash-keygen-type-id type)) - (keyword (make-bytevector (mhash-keygen-type-key-length type))) - (v (mhash-keygen-type-parameter-vector type))) - (if (not ((ucode-primitive mhash_keygen 4) - id - (if ((ucode-primitive mhash_keygen_uses_salt 1) id) - (begin - (if (or (default-object? salt) (not salt)) - (error "Salt required:" - (vector-ref mhash-keygen-names id))) - (let ((n - ((ucode-primitive mhash_get_keygen_salt_size 1) - id))) - (if (not (or (= n 0) - (= n (bytevector-length salt)))) - (error "Salt size incorrect:" - (bytevector-length salt) - (error-irritant/noise "; should be:") - n))) - (let ((v (vector-copy v))) - (vector-set! v 0 salt) - v)) - v) - keyword - passphrase)) - (error "Error signalled by mhash_keygen.")) - keyword)) - -(define-structure (mhash-keygen-type (constructor %make-mhash-keygen-type)) - (id #f read-only #t) - (key-length #f read-only #t) - (parameter-vector #f read-only #t)) - -(define (make-mhash-keygen-type name key-length hash-names #!optional count) - (guarantee index-fixnum? key-length 'make-mhash-keygen-type) - (if (not (let ((m (mhash-keygen-max-key-size name))) - (or (= m 0) - (<= key-length m)))) - (error:bad-range-argument key-length 'make-mhash-keygen-type)) - (%make-mhash-keygen-type - (keygen-name->id name 'make-mhash-keygen-type) - key-length - (let ((n-algorithms (mhash-keygen-uses-hash-algorithm name)) - (hash-names - (if (list? hash-names) hash-names (list hash-names)))) - (let ((m (length hash-names))) - (if (not (= n-algorithms m)) - (error "Wrong number of hash types supplied:" - m - (error-irritant/noise "; should be:") - n-algorithms))) - (let ((n (+ 2 n-algorithms))) - (let ((v (make-vector n))) - (vector-set! v 0 #f) - (vector-set! - v 1 - (and (mhash-keygen-uses-count? name) - (begin - (if (or (default-object? count) (not count)) - (error "Iteration count required:" name)) - (if (not (and (exact-integer? count) - (positive? count))) - (error:bad-range-argument count 'make-mhash-keygen-type)) - count))) - (do ((i 2 (fix:+ i 1)) - (names hash-names (cdr names))) - ((fix:= i n)) - (vector-set! v i - (mhash-name->id (car names) 'make-mhash-keygen-type))) - v))))) - -(define (mhash-available?) - (load-library-object-file "prmhash" #f) - (and (implemented-primitive-procedure? (ucode-primitive mhash 4)) - (begin - (if (not mhash-initialized?) - (begin - (set! mhash-algorithm-names - (make-names-vector - (ucode-primitive mhash_count 0) - (ucode-primitive mhash_get_hash_name 1))) - (set! mhash-contexts - (make-gc-finalizer (ucode-primitive mhash_end 1) - mhash-context? - mhash-context-index - set-mhash-context-index!)) - (set! mhash-hmac-contexts - (make-gc-finalizer (ucode-primitive mhash_hmac_end 1) - mhash-hmac-context? - mhash-hmac-context-index - set-mhash-hmac-context-index!)) - (set! mhash-keygen-names - (make-names-vector - (ucode-primitive mhash_keygen_count 0) - (ucode-primitive mhash_get_keygen_name 1))) - (set! mhash-initialized? #t))) - #t))) - -(define (reset-mhash-variables!) - (set! mhash-initialized? #f) - unspecific) - -(define (mhash-file hash-type filename) - (call-with-binary-input-file filename - (port-consumer (lambda () (mhash-init hash-type)) - mhash-update - mhash-end))) - -(define (mhash-string hash-type string #!optional start end) - (mhash-bytevector hash-type (string->utf8 string start end))) - -(define (mhash-bytevector hash-type bytes #!optional start end) - (let* ((end (fix:end-index end (bytevector-length bytes) 'mhash-bytevector)) - (start (fix:start-index start end 'mhash-bytevector)) - (context (mhash-init hash-type))) - (mhash-update context bytes start end) - (mhash-end context))) - ;;;; MD5 (define (md5-available?) @@ -432,8 +208,6 @@ USA. ;;;; Package initialization (define (initialize-package!) - (reset-mhash-variables!) - (add-event-receiver! event:after-restart reset-mhash-variables!) (reset-mcrypt-variables!) (add-event-receiver! event:after-restart reset-mcrypt-variables!)) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index ce5cac9be..2717decbb 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -5207,7 +5207,6 @@ USA. (files "crypto") (parent (runtime)) (export () - make-mhash-keygen-type mcrypt-algorithm-name mcrypt-algorithm-names mcrypt-available? @@ -5231,28 +5230,7 @@ USA. md5-available? md5-bytevector md5-file - md5-string - mhash-available? - mhash-bytevector - mhash-context? - mhash-end - mhash-file - mhash-get-block-size - mhash-hmac-end - mhash-hmac-init - mhash-hmac-update - mhash-init - mhash-keygen - mhash-keygen-max-key-size - mhash-keygen-salt-size - mhash-keygen-type-names - mhash-keygen-type? - mhash-keygen-uses-count? - mhash-keygen-uses-hash-algorithm - mhash-keygen-uses-salt? - mhash-string - mhash-type-names - mhash-update) + md5-string) (initialization (initialize-package!))) (define-package (runtime regular-sexpression) -- 2.25.1