NATIVE_OUT=${OUTPUT_DIR}/native
MACOSX_OUT=${OUTPUT_DIR}/macosx
-PLUGINS="blowfish gdbm md5 mhash"
+PLUGINS="blowfish gdbm mcrypt md5 mhash"
notify ()
{
--- /dev/null
+# 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
--- /dev/null
+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).
--- /dev/null
+#| -*-Scheme-*- |#
+
+;;;; Test the mcrypt wrapper.
+
+(load "make")
+(with-system-library-directories
+ '("./")
+ (lambda ()
+ (load "mcrypt-check" (->environment '(mcrypt)))))
\ No newline at end of file
--- /dev/null
+#| -*-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
--- /dev/null
+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 <mcrypt.h> 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 <pthread.h> 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
--- /dev/null
+#| -*-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
--- /dev/null
+/* -*-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 <mit-scheme.h>
+#include "mcrypt-shim.h"
+
+#ifdef HAVE_PTHREADS
+#include <pthread.h>
+
+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));
+}
--- /dev/null
+#| -*-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
--- /dev/null
+/* -*-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 <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <mcrypt.h>
+
+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);
--- /dev/null
+#| -*-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.
+\f
+(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
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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))
+\f
+;;;; 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))
+\f
+(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)))
+\f
+(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))))
+\f
+(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)))))
+\f
+;;;; 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))))
+\f
+;;;; 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))))
+\f
+;;;; 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
projects / mit-scheme.git / commitdiff