From: Matt Birkholz Date: Fri, 5 Sep 2014 00:05:38 +0000 (-0700) Subject: mcrypt: A libmcrypt plugin (separately buildable FFI wrapper). X-Git-Tag: mit-scheme-pucked-9.2.12~401^2 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f603fb2bdd154412ed8529587dbcde3baa17915e;p=mit-scheme.git mcrypt: A libmcrypt plugin (separately buildable FFI wrapper). --- diff --git a/dist/shared.sh b/dist/shared.sh index 1f9f1230a..7d5e681a4 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 md5 mhash" +PLUGINS="blowfish gdbm mcrypt md5 mhash" notify () { diff --git a/src/mcrypt/Makefile.in b/src/mcrypt/Makefile.in new file mode 100644 index 000000000..224393854 --- /dev/null +++ b/src/mcrypt/Makefile.in @@ -0,0 +1,81 @@ +# 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 +# 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. + +MIT_SCHEME_EXE = mit-scheme +exe = '$(MIT_SCHEME_EXE)' --batch-mode + +CFLAGS = @CFLAGS@ +LIBS = @LIBS@ + +all: mcrypt-shim.so mcrypt-types.bin mcrypt-const.bin + echo '(load "compile")' | $(exe) + +check: + echo '(load "check")' | $(exe) + +install: + ( echo '(begin'; \ + echo ' (install-shim "$(DESTDIR)" "mcrypt")'; \ + echo ' (install-load-option "$(DESTDIR)" "mcrypt"))' ) \ + | $(exe) -- *.com *.bci *.pkd make.scm + +clean: + rm -f mcrypt-const.scm mcrypt-const mcrypt-const.c + rm -f mcrypt-shim.c + rm -f mcrypt-*.crf mcrypt-*.fre mcrypt-*.pkd + rm -f *.o *.so *.bin *.ext *.com *.bci *.moc *.fni + rm -f encrypted decrypted + +distclean: clean + rm -f Makefile config.h config.log config.status + +maintainer-clean: distclean + rm -f configure config.h.in + rm -rf autom4te.cache + +mcrypt-shim.so: mcrypt-shim.o mcrypt-adapter.o + echo "(link-shim)" | $(exe) -- -o $@ $^ $(LIBS) + +mcrypt-adapter.o: mcrypt-adapter.c mcrypt-shim.h + echo '(compile-shim)' | $(exe) -- $(CFLAGS) -c $< + +mcrypt-shim.o: mcrypt-shim.c mcrypt-shim.h + echo '(compile-shim)' | $(exe) -- $(CFLAGS) -c $< + +mcrypt-shim.c mcrypt-const.c mcrypt-types.bin: \ + mcrypt.cdecl mcrypt-shim.h + echo '(generate-shim "mcrypt" "#include \"mcrypt-shim.h\"")' \ + | $(exe) + +mcrypt-const.bin: mcrypt-const.scm + echo '(sf "mcrypt-const")' | $(exe) + +mcrypt-const.scm: mcrypt-const + ./mcrypt-const + +mcrypt-const: mcrypt-const.o + $(CC) -o $@ $^ $(LIBS) + +mcrypt-const.o: mcrypt-const.c mcrypt-shim.h + $(CC) $(CFLAGS) -c $< + +.PHONY: all check install clean distclean maintainer-clean diff --git a/src/mcrypt/README b/src/mcrypt/README new file mode 100644 index 000000000..d48e8c2e0 --- /dev/null +++ b/src/mcrypt/README @@ -0,0 +1,18 @@ +The mcrypt wrapper. + +This is a drop-in replacement for the mcrypt microcode module and the +mcrypt-* procedures in runtime/crypto.scm. It is not part of the core +build and can be built outside the core build tree in the customary +way: + + ./configure + make all check install + +The install target copies a shared library shim and compiled Scheme +files into the system library path and re-writes the optiondb.scm +found there. You can override the default command name "mit-scheme" +(and thus the system library path) by setting MIT_SCHEME_EXE. + +To use: (load-option 'MCRYPT) and import the bindings you want. They +are not exported to the global environment because they would conflict +with the exports from (runtime crypto). diff --git a/src/mcrypt/check.scm b/src/mcrypt/check.scm new file mode 100644 index 000000000..fc1f17c31 --- /dev/null +++ b/src/mcrypt/check.scm @@ -0,0 +1,9 @@ +#| -*-Scheme-*- |# + +;;;; Test the mcrypt wrapper. + +(load "make") +(with-system-library-directories + '("./") + (lambda () + (load "mcrypt-check" (->environment '(mcrypt))))) \ No newline at end of file diff --git a/src/mcrypt/compile.scm b/src/mcrypt/compile.scm new file mode 100644 index 000000000..0479bc167 --- /dev/null +++ b/src/mcrypt/compile.scm @@ -0,0 +1,13 @@ +#| -*-Scheme-*- |# + +;;;; Compile the mcrypt wrapper. + +(load-option 'CREF) +(load-option 'FFI) +(with-working-directory-pathname (directory-pathname (current-load-pathname)) + (lambda () + (with-system-library-directories + '("./") + (lambda () + (compile-file "mcrypt" '() (->environment '(RUNTIME))))) + (cref/generate-constructors "mcrypt" 'ALL))) \ No newline at end of file diff --git a/src/mcrypt/configure.ac b/src/mcrypt/configure.ac new file mode 100644 index 000000000..269dfa16a --- /dev/null +++ b/src/mcrypt/configure.ac @@ -0,0 +1,86 @@ +dnl Process this file with autoconf to produce a configure script. + +AC_INIT([MIT/GNU Scheme mcrypt interface], + [0.1], + [bug-mit-scheme@gnu.org], + [mit-scheme-mcrypt]) +AC_CONFIG_SRCDIR([mcrypt.pkg]) +AC_CONFIG_HEADERS([config.h]) + +AC_COPYRIGHT( +[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 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. +]) + +AH_TOP([/* + +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 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. + +*/]) + +AC_ARG_ENABLE([smp], + AS_HELP_STRING([---enable-smp], + [Support multi-processing if available [[yes]]])) +: ${with_smp='no'} + +AC_CHECK_HEADER([mcrypt.h],[],[ + AC_MSG_ERROR([Header file not found.])]) + +dnl Check for SMP support (pthreads... ?). +if test "${enable_smp}" != no; then + AC_CHECK_HEADER([pthread.h], + [ + AC_DEFINE([ENABLE_SMP], [1], + [Define to 1 for Symmetric MultiProcessing support.]) + ], + [AC_MSG_ERROR([Header file not found.])]) +fi + +MCRYPT_CFLAGS=`libmcrypt-config --cflags` +MCRYPT_LIBS=`libmcrypt-config --libs` +CFLAGS="${MCRYPT_CFLAGS} ${CFLAGS}" +LIBS="${LIBS} ${MCRYPT_LIBS}" + +AC_SUBST([CFLAGS]) +AC_SUBST([LIBS]) +AC_CONFIG_FILES([Makefile]) +AC_OUTPUT diff --git a/src/mcrypt/make.scm b/src/mcrypt/make.scm new file mode 100644 index 000000000..3769afb04 --- /dev/null +++ b/src/mcrypt/make.scm @@ -0,0 +1,9 @@ +#| -*-Scheme-*- |# + +;;;; Load the mcrypt option. + +(with-working-directory-pathname (directory-pathname (current-load-pathname)) + (lambda () + (load-package-set "mcrypt"))) + +(add-subsystem-identification! "mcrypt" '(0 1)) \ No newline at end of file diff --git a/src/mcrypt/mcrypt-adapter.c b/src/mcrypt/mcrypt-adapter.c new file mode 100644 index 000000000..0d06c8fdd --- /dev/null +++ b/src/mcrypt/mcrypt-adapter.c @@ -0,0 +1,135 @@ +/* -*-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 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. + +*/ + +/* Adapters for the mcrypt cryptography library. */ + +#include +#include "mcrypt-shim.h" + +#ifdef HAVE_PTHREADS +#include + +static pthread_mutex_t mutex = PTHREAD_MUTEX_INITIALIZER; + +static void +scmcrypt_mutex_lock (void) +{ + int retval = pthread_mutex_lock (&mutex); + + if (retval != 0) + { + outf_error (";mcrypt mutex lock failed: %s\n", strerror (retval)); + outf_flush_error (); + } +} + +static void +scmcrypt_mutex_unlock (void) +{ + int retval = pthread_mutex_unlock (&mutex); + + if (retval != 0) + { + outf_error (";mcrypt mutex unlock failed: %s\n", strerror (retval)); + outf_flush_error (); + } +} + +static __thread const char * scmcrypt_ltdlerror = NULL; + +static void +scmcrypt_set_ltdlerror (const char * errmsg) +{ + scmcrypt_ltdlerror = errmsg; +} +#endif + +extern const char * +scmcrypt_get_ltdlerror (void) +{ +#ifdef HAVE_PTHREADS + return scmcrypt_ltdlerror; +#else + return "consult lt_dlerror"; +#endif +} + +extern void +scmcrypt_mutex_register (void) +{ +#ifdef HAVE_PTHREADS + int retval = mcrypt_mutex_register (&scmcrypt_mutex_lock, + &scmcrypt_mutex_unlock, + &scmcrypt_set_ltdlerror, + &scmcrypt_get_ltdlerror); + if (retval != 0) + { + outf_error (";mcrypt mutex registration failed\n"); + outf_flush_error (); + } +#endif +} + +extern void +scmcrypt_list_algorithms (struct mcrypt_list * mlist) +{ + mlist->elements = (void*) mcrypt_list_algorithms (NULL, &mlist->size); +} + +extern void +scmcrypt_list_modes (struct mcrypt_list * mlist) +{ + mlist->elements = (void*) mcrypt_list_modes (NULL, &mlist->size); +} + +extern int +scmdecrypt_generic (MCRYPT td, char *plaintext, int start, int end) +{ + return (mdecrypt_generic (td, plaintext+start, end - start)); +} + +extern int +scmcrypt_generic (MCRYPT td, char *plaintext, int start, int end) +{ + return (mcrypt_generic (td, plaintext+start, end - start)); +} + +extern void +scmcrypt_enc_get_supported_key_sizes (MCRYPT td, struct mcrypt_list * mlist) +{ + mlist->elements + = (void*) mcrypt_enc_get_supported_key_sizes (td, &mlist->size); +} + +extern void +scmcrypt_module_get_algo_supported_key_sizes (char* algorithm, + char* a_directory, + struct mcrypt_list * mlist) +{ + mlist->elements + = (void*) (mcrypt_module_get_algo_supported_key_sizes + (algorithm, 0, &mlist->size)); +} diff --git a/src/mcrypt/mcrypt-check.scm b/src/mcrypt/mcrypt-check.scm new file mode 100644 index 000000000..7554ec484 --- /dev/null +++ b/src/mcrypt/mcrypt-check.scm @@ -0,0 +1,75 @@ +#| -*-Scheme-*- + +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 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. + +|# + +;;;; Test the mcrypt wrapper. + +(define (random-string length) + (list->string (make-initialized-list length + (lambda (i) + (declare (ignore i)) + (ascii->char (random 256)))))) + +(if (not (mcrypt-available?)) + (warn "mcrypt plugin not found") + (begin + (if (not (member "tripledes" (mcrypt-algorithm-names))) + (error "No tripledes.")) + + (if (not (member "cfb" (mcrypt-mode-names))) + (error "No cipher-feedback mode.")) + + (let ((key (let ((sizes (mcrypt-supported-key-sizes "tripledes"))) + (if (not (vector? sizes)) + (error "Bogus key sizes for tripledes.")) + (random-string (vector-ref sizes + (-1+ (vector-length sizes)))))) + (init-vector (let* ((context + ;; Unfortunately the size is + ;; available only from the MCRYPT(?)! + (mcrypt-open-module "tripledes" "cfb")) + (size (mcrypt-init-vector-size context))) + (mcrypt-end context) + (random-string size)))) + + (call-with-input-file "mcrypt.scm" + (lambda (input) + (call-with-output-file "encrypted" + (lambda (output) + (let ((copy (string-copy init-vector))) + (mcrypt-encrypt-port "tripledes" "cfb" + input output key init-vector #t) + (if (not (string=? copy init-vector)) + (error "Init vector modified."))))))) + + (call-with-input-file "encrypted" + (lambda (input) + (call-with-output-file "decrypted" + (lambda (output) + (mcrypt-encrypt-port "tripledes" "cfb" + input output key init-vector #f)))))) + + (if (not (= 0 (run-shell-command "cmp mcrypt.scm decrypted"))) + (error "En/Decryption failed.")))) \ No newline at end of file diff --git a/src/mcrypt/mcrypt-shim.h b/src/mcrypt/mcrypt-shim.h new file mode 100644 index 000000000..a8dfa8d51 --- /dev/null +++ b/src/mcrypt/mcrypt-shim.h @@ -0,0 +1,50 @@ +/* -*-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 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 the mcrypt cryptography library. */ + +#include "config.h" + +#include +#include +#include +#include + +struct mcrypt_list { + void* elements; + int size; +}; + +extern void scmcrypt_mutex_register (void); +extern const char* scmcrypt_get_ltdlerror (void); +extern void scmcrypt_list_algorithms (struct mcrypt_list* mlist); +extern void scmcrypt_list_modes (struct mcrypt_list* mlist); +extern int scmdecrypt_generic (MCRYPT td, char* plaintext, int start, int end); +extern int scmcrypt_generic (MCRYPT td, char* plaintext, int start, int end); +extern void scmcrypt_enc_get_supported_key_sizes + (MCRYPT td, struct mcrypt_list* mlist); +extern void scmcrypt_module_get_algo_supported_key_sizes + (char* algorithm, char* a_directory, struct mcrypt_list* mlist); diff --git a/src/mcrypt/mcrypt.cdecl b/src/mcrypt/mcrypt.cdecl new file mode 100644 index 000000000..7014c383d --- /dev/null +++ b/src/mcrypt/mcrypt.cdecl @@ -0,0 +1,104 @@ +#| -*-Scheme-*- + +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 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. + +|# + +;;;; C declarations for mcrypt-shim.so. + +(struct mcrypt_list + (elements (* (* char))) + (size int)) + +(typedef MCRYPT (* (struct CRYPT_STREAM))) + +(extern void scmcrypt_mutex_register) + +(extern (* (const char)) scmcrypt_get_ltdlerror) + +(extern (* (const char)) mcrypt_strerror (code int)) + +(extern void scmcrypt_list_algorithms + (mlist (* (struct mcrypt_list)))) + +(extern void scmcrypt_list_modes + (mlist (* (struct mcrypt_list)))) + +(extern MCRYPT mcrypt_module_open + (algorithm (* char)) + (algorithm_directory (* char)) + (mode (* char)) + (mode_directory (* char))) + +(extern int mcrypt_generic_init + (td MCRYPT) (key (* void)) (lenofkey int) (IV (* void))) + +(extern int scmdecrypt_generic + (td MCRYPT) (plaintext (* char)) (start int) (end int)) + +(extern int scmcrypt_generic + (td MCRYPT) (plaintext (* void)) (start int) (end int)) + +(extern int mcrypt_enc_self_test (td MCRYPT)) + +(extern int mcrypt_module_self_test + (algorithm (* char)) (a_directory (* char))) + +(extern int mcrypt_enc_is_block_algorithm_mode (td MCRYPT)) + +(extern int mcrypt_module_is_block_algorithm_mode + (mode (* char)) (m_directory (* char))) + +(extern int mcrypt_enc_is_block_algorithm (td MCRYPT)) + +(extern int mcrypt_module_is_block_algorithm + (algorithm (* char)) (a_directory (* char))) + +(extern int mcrypt_enc_is_block_mode (td MCRYPT)) + +(extern int mcrypt_module_is_block_mode + (mode (* char)) (m_directory (* char))) + +(extern int mcrypt_enc_get_key_size (td MCRYPT)) + +(extern int mcrypt_module_get_algo_key_size + (algorithm (* char)) (a_directory (* char))) + +(extern void scmcrypt_enc_get_supported_key_sizes + (td MCRYPT) (mlist (* (struct mcrypt_list)))) + +(extern void scmcrypt_module_get_algo_supported_key_sizes + (algorithm (* char)) (a_directory (* char)) + (mlist (* (struct mcrypt_list)))) + +(extern int mcrypt_enc_get_iv_size (td MCRYPT)) + +(extern int mcrypt_generic_end (td MCRYPT)) + +(extern void mcrypt_free_p (elements (* (* char))) (size int)) + +(extern void mcrypt_free (elements (* char))) + +(extern (* void) malloc (nbytes int)) + +(extern void free (bytes (* void))) \ No newline at end of file diff --git a/src/mcrypt/mcrypt.pkg b/src/mcrypt/mcrypt.pkg new file mode 100644 index 000000000..41de30c4a --- /dev/null +++ b/src/mcrypt/mcrypt.pkg @@ -0,0 +1,58 @@ +#| -*-Scheme-*- + +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 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. + +|# + +(global-definitions runtime/) + +(define-package (mcrypt global) + ;; Just to get cref to analyze whether all exports are defined. + ) + +(define-package (mcrypt) + (files "mcrypt") + (parent ()) + + ;; You'll have to import these from package (mcrypt). They are + ;; currently bound in () by exports from package (runtime crypto). + ;; Note that CREF will need "(global-definitions mcrypt/)". + (export (mcrypt global) + 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)) \ No newline at end of file diff --git a/src/mcrypt/mcrypt.scm b/src/mcrypt/mcrypt.scm new file mode 100644 index 000000000..2e68061a3 --- /dev/null +++ b/src/mcrypt/mcrypt.scm @@ -0,0 +1,442 @@ +#| -*-Scheme-*- + +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 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. + +|# + +;;;; mcrypt wrapper +;;; package: (mcrypt) + +(declare (usual-integrations)) + +;;;; The mcrypt library +;;; +;;; Multithreading +;;; +;;; The manual page says the library is thread safe except for module +;;; loading, part of mcrypt_module_open. Presumably multiple threads +;;; should NOT use the same "thread descriptor" (ctype MCRYPT, +;;; parameter name often "td") returned by mcrypt_module_open. Also +;;; presumably the mcrypt_mutex_register function should be called "in +;;; multithreaded application... with dynamic module loading support". +;;; It is assumed this is the case for MIT Scheme. +;;; +;;; This wrapper uses an OS mutex to implement lock and unlock +;;; functions passed to mcrypt_mutex_register, and locks and unlocks +;;; it during mcrypt_module_open. The Scheme mcrypt-context object, +;;; representing an MCRYPT "thread", should be used by one Scheme +;;; thread only. This restriction is not currently enforced. +;;; +;;; Memory Management +;;; +;;; Searching the manpage for "free" finds that certain functions +;;; return values allocated by malloc: +;;; mcrypt_enc_get_supported_key_sizes +;;; mcrypt_enc_get_algorithms_name +;;; mcrypt_enc_get_modes_name +;;; mcrypt_module_get_algo_supported_key_sizes "differs [not!]... +;;; because the return value here is allocated". Perhaps it +;;; was not allocated with malloc? Perhaps mcrypt_free should +;;; be used instead of free? +;;; +;;; The arrays returned by two functions should be freed using +;;; mcrypt_free_p: +;;; mcrypt_list_algorithms +;;; mcrypt_list_modes +;;; +;;; Using microcode/prmcrypt.c as a guide: +;;; +;;; mcrypt_free is called by +;;; cp2s, which is called by +;;; mcrypt_enc_get_algorithms_name and +;;; mcrypt_enc_get_modes_name, and +;;; deallocate_key_sizes, which is the abort action for +;;; convert_key_sizes, which is called by +;;; mcrypt_enc_get_supported_key_sizes and +;;; mcyrpt_module_get_algo_supported_key_sizes. +;;; mcrypt_free_p is called by +;;; deallocate_list, which is the abort action for +;;; LIST_ITEMS, which is "called" by +;;; mcrypt_list_algorithms and +;;; mcrypt_list_modes. +;;; +;;; This wrapper ensures that MCRYPTs and size/name lists returned by +;;; the library do not "leak" by putting cleanup thunks on a weak +;;; alist that is periodically scanned for objects that were GCed and +;;; not freed. + +(C-include "mcrypt") + +(define mcrypt-initialized? #f) +(define mcrypt-algorithm-names-vector) +(define mcrypt-mode-names-vector) + +(define (mcrypt-available?) + (let ((path (ignore-errors (lambda () + (system-library-pathname "mcrypt-shim.so"))))) + (and (pathname? path) + (file-loadable? path)))) + +(define (init!) + (if (not mcrypt-initialized?) + (begin + (C-call "scmcrypt_mutex_register") + (set! mcrypt-algorithm-names-vector (mcrypt-list-algorithms)) + (set! mcrypt-mode-names-vector (mcrypt-list-modes)) + (set! mcrypt-initialized? #t)))) + +(define (mcrypt-list-algorithms) + (let ((mlist (make-mcrypt-name-list))) + (C-call "scmcrypt_list_algorithms" mlist) + (let ((vector (mcrypt-name-list-elements mlist))) + (free-mcrypt-name-list mlist) + vector))) + +(define (mcrypt-list-modes) + (let ((mlist (make-mcrypt-name-list))) + (C-call "scmcrypt_list_modes" mlist) + (let ((vector (mcrypt-name-list-elements mlist))) + (free-mcrypt-name-list mlist) + vector))) + +(define (reset-mcrypt-variables!) + (set! mcrypt-initialized? #f) + (set! mcrypt-algorithm-names-vector) + (set! mcrypt-mode-names-vector) + (reset-cleanups!) + unspecific) + +(define (mcrypt-algorithm-names) + (init!) + (vector->list mcrypt-algorithm-names-vector)) + +(define (mcrypt-mode-names) + (init!) + (vector->list mcrypt-mode-names-vector)) + +(define-structure mcrypt-context algorithm mode alien) + +(define (guarantee-mcrypt-context object procedure) + (if (not (mcrypt-context? object)) + (error:wrong-type-argument object "mcrypt context" procedure))) + +(define (mcrypt-open-module algorithm mode) + (init!) + (let* ((alien (make-alien '(struct |CRYPT_STREAM|))) + (context (make-mcrypt-context algorithm mode alien))) + (add-cleanup context (make-mcrypt-context-cleanup alien)) + (C-call "mcrypt_module_open" alien algorithm 0 mode 0) + (if (alien-null? alien) + (error "Failed to open mcrypt module:" + (C-peek-cstring (C-call "scmcrypt_get_ltdlerror")))) + context)) + +(define (make-mcrypt-context-cleanup alien) + (named-lambda (mcrypt-context-cleanup) + (C-call "mcrypt_generic_end" alien))) + +(define (mcrypt-init context key init-vector) + (guarantee-mcrypt-context context 'MCRYPT-INIT) + (let ((code + (C-call "mcrypt_generic_init" + (mcrypt-context-alien context) + key (string-length key) init-vector))) + (if (< code 0) + (error "Error code signalled by mcrypt_generic_init:" + (C-peek-cstring (C-call "mcrypt_strerror" + (make-alien '(const (* char))) + 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 + (let ((alien (mcrypt-context-alien context)) + (start output-start) + (end (+ output-start (- input-end input-start)))) + (if encrypt? + (C-call "scmcrypt_generic" alien output start end) + (C-call "scmdecrypt_generic" alien output start end))))) + (if (< code 0) + (error (string-append "Error code signalled by " + (if encrypt? + "mcrypt_generic" + "mdecrypt_generic") + ":") + code)))) + +(define (mcrypt-end context) + (let ((alien (mcrypt-context-alien context))) + (if (not (alien-null? alien)) + (let ((code (C-call "mcrypt_generic_end" alien))) + (if (< code 0) + (error "Error code returned by mcrypt_generic_end:" code)) + (alien-null! alien) + (remove-cleanup context))))) + +(define (mcrypt-generic-unary name context-op module-op) + (lambda (object) + (cond ((mcrypt-context? object) + (context-op object)) + ((string? object) + (init!) + (module-op object)) + (else + (error:wrong-type-argument object "mcrypt context" name))))) + +(define mcrypt-self-test + (mcrypt-generic-unary + 'MCRYPT-SELF-TEST + (named-lambda (mcrypt-enc-self-test context) + (C-call "mcrypt_enc_self_test" (mcrypt-context-alien context))) + (named-lambda (mcrypt-module-self-test module-name) + (C-call "mcrypt_module_self_test" module-name 0)))) + +(define mcrypt-block-algorithm-mode? + (mcrypt-generic-unary + 'MCRYPT-BLOCK-ALGORITHM-MODE? + (named-lambda (mcrypt-enc-is-block-algorithm-mode? context) + (C-call "mcrypt_enc_is_block_algorithm_mode" + (mcrypt-context-alien context))) + (named-lambda (mcrypt-module-is-block-algorithm-mode? name) + (C-call "mcrypt_module_is_block_algorithm_mode" name 0)))) + +(define mcrypt-block-algorithm? + (mcrypt-generic-unary + 'MCRYPT-BLOCK-ALGORITHM? + (named-lambda (mcrypt-enc-is-block-algorithm context) + (C-call "mcrypt_enc_is_block_algorithm" + (mcrypt-context-alien context))) + (named-lambda (mcrypt-module-is-block-algorithm name) + (C-call "mcrypt_module_is_block_algorithm" name 0)))) + +(define mcrypt-block-mode? + (mcrypt-generic-unary + 'MCRYPT-BLOCK-MODE? + (named-lambda (mcrypt-enc-is-block-mode context) + (C-call "mcrypt_enc_is_block_mode" + (mcrypt-context-alien context))) + (named-lambda (mcrypt-module-is-block-mode context) + (C-call "mcrypt_module_is_block_mode" + (mcrypt-context-alien context) 0)))) + +(define mcrypt-key-size + (mcrypt-generic-unary + 'MCRYPT-KEY-SIZE + (named-lambda (mcrypt-enc-get-key-size context) + (C-call "mcrypt_enc_get_key_size" + (mcrypt-context-alien context))) + (named-lambda (mcrypt-module-get-algo-key-size name) + (C-call "mcrypt_module_get_algo_key_size" name 0)))) + +(define mcrypt-supported-key-sizes + (mcrypt-generic-unary + 'MCRYPT-SUPPORTED-KEY-SIZES + (named-lambda (mcrypt-enc-get-supported-key-sizes context) + (let ((mlist (malloc (C-sizeof "struct mcrypt_list") + '(struct |mcrypt_list|)))) + (C-call "scmcrypt_enc_get_supported_key_sizes" + (mcrypt-context-alien context) mlist) + (let ((sizes (mcrypt-size-list-elements mlist))) + (free mlist) + sizes))) + (named-lambda (mcrypt-module-get-algo-supported-key-sizes name) + (let ((mlist (make-mcrypt-size-list))) + (C-call "scmcrypt_module_get_algo_supported_key_sizes" name 0 mlist) + (let ((sizes (mcrypt-size-list-elements mlist))) + (free-mcrypt-size-list mlist) + sizes))))) + +(define (mcrypt-init-vector-size context) + (guarantee-mcrypt-context context 'MCRYPT-INIT-VECTOR-SIZE) + (C-call "mcrypt_enc_get_iv_size" (mcrypt-context-alien context))) + +(define (mcrypt-algorithm-name context) + (guarantee-mcrypt-context context 'MCRYPT-ALGORITHM-NAME) + (mcrypt-context-algorithm context)) + +(define (mcrypt-mode-name context) + (guarantee-mcrypt-context context 'MCRYPT-MODE-NAME) + (mcrypt-context-mode 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 (= 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))))) + +;;;; Mcrypt size lists. + +(define (mcrypt-size-list-elements mlist) + (let ((elements (C-> mlist "struct mcrypt_list elements")) + (size (C-> mlist "struct mcrypt_list size"))) + (if (= size 0) + #f + (let ((vector (make-vector size))) + (let loop ((i 0)) + (if (< i size) + (begin + (vector-set! vector i (C-> elements "int")) + (alien-byte-increment! elements (C-sizeof "int")) + (loop (1+ i))))) + vector)))) + +(define (make-mcrypt-size-list) + (let ((mlist (make-alien '(struct |mcrypt_list|))) + (copy (make-alien '(struct |mcrypt_list|)))) + (add-cleanup mlist (make-mcrypt-size-list-cleanup copy)) + (C-call "malloc" copy (C-sizeof "struct mcrypt_list")) + (C->= copy "struct mcrypt_list elements" 0) + (copy-alien-address! mlist copy) + mlist)) + +(define (make-mcrypt-size-list-cleanup mlist) + (named-lambda (mcrypt-size-list-cleanup) + (if (not (alien-null? mlist)) + (let ((elements (C-> mlist "struct mcrypt_list elements"))) + (if (not (alien-null? elements)) + (C-call "mcrypt_free" elements)) + (C-call "free" mlist) + (alien-null! mlist))))) + +(define (free-mcrypt-size-list mlist) + (if (not (alien-null? mlist)) + (let ((elements (C-> mlist "struct mcrypt_list elements"))) + (if (not (alien-null? elements)) + (C-call "mcrypt_free" elements)) + (C-call "free" mlist) + (alien-null! mlist) + (remove-cleanup mlist)))) + +;;;; Mcrypt name lists. + +(define (mcrypt-name-list-elements mlist) + (let ((elements (C-> mlist "struct mcrypt_list elements")) + (size (C-> mlist "struct mcrypt_list size"))) + (let ((vector (make-vector size))) + (let loop ((i 0)) + (if (< i size) + (begin + (vector-set! vector i (C-peek-cstringp! elements)) + (loop (1+ i))))) + vector))) + +(define (make-mcrypt-name-list) + (let ((mlist (make-alien '(struct |mcrypt_list|))) + (copy (make-alien '(struct |mcrypt_list|)))) + (add-cleanup mlist (make-mcrypt-name-list-cleanup copy)) + (C-call "malloc" copy (C-sizeof "struct mcrypt_list")) + (C->= copy "struct mcrypt_list elements" 0) + (copy-alien-address! mlist copy) + mlist)) + +(define (make-mcrypt-name-list-cleanup mlist) + (named-lambda (mcrypt-name-list-cleanup) + (if (not (alien-null? mlist)) + (let ((elements (C-> mlist "struct mcrypt_list elements")) + (size (C-> mlist "struct mcrypt_list size"))) + (if (not (alien-null? elements)) + (C-call "mcrypt_free_p" elements size)) + (C-call "free" mlist) + (alien-null! mlist))))) + +(define (free-mcrypt-name-list mlist) + (if (not (alien-null? mlist)) + (let ((elements (C-> mlist "struct mcrypt_list elements")) + (size (C-> mlist "struct mcrypt_list size"))) + (if (not (alien-null? elements)) + (C-call "mcrypt_free_p" elements size)) + (C-call "free" mlist) + (alien-null! mlist) + (remove-cleanup mlist)))) + +;;;; The cleanups list. + +(define cleanups '()) + +(define (add-cleanup object cleaner) + (set! cleanups (cons (weak-cons object cleaner) cleanups))) + +(define (remove-cleanup object) + (let ((entry (weak-assq object cleanups))) + (if entry + (set! cleanups (delq! entry cleanups)) + ;; Already removed! + ))) + +(define (weak-assq obj alist) + (let loop ((alist alist)) + (if (null? alist) #f + (let* ((entry (car alist)) + (key (weak-car entry))) + (if (eq? obj key) entry + (loop (cdr alist))))))) + +(define (cleanup-mcrypt-objects) + (let loop ((entries cleanups) + (prev #f)) + (if (pair? entries) + (let ((entry (car entries)) + (next (cdr entries))) + (if (weak-pair/car? entry) + (loop next entries) + (let ((cleaner (weak-cdr entry))) + (if prev + (set-cdr! prev next) + (set! cleanups next)) + (cleaner) + (loop next prev))))))) + +(define (reset-cleanups!) + (for-each (lambda (entry) + (if (weak-pair/car? entry) + (let ((obj (weak-car entry))) + (cond ((alien? obj) (alien-null! obj)) + ((mcrypt-context? obj) + (alien-null! (mcrypt-context-alien obj))) + (else + (error "Unexpected object on cleanup list:" obj)))))) + cleanups) + (set! cleanups '())) + +(add-gc-daemon! cleanup-mcrypt-objects) +(add-event-receiver! event:after-restart reset-mcrypt-variables!) \ No newline at end of file