From: Matt Birkholz Date: Sun, 8 Sep 2013 19:34:54 +0000 (-0700) Subject: mhash: A separately buildable FFI wrapper. X-Git-Tag: release-9.2.0~118 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=a6054bea7feefed5f7371975cf2967af1be53be3;p=mit-scheme.git mhash: A separately buildable FFI wrapper. --- diff --git a/src/mhash/Makefile.in b/src/mhash/Makefile.in new file mode 100644 index 000000000..9f8171239 --- /dev/null +++ b/src/mhash/Makefile.in @@ -0,0 +1,67 @@ +# 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 +# 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@ +CPPFLAGS = @CPPFLAGS@ -I. -I$(srcdir) +LDFLAGS = @LDFLAGS@ +LIBS = @LIBS@ + +all: mhash-shim.so + echo '(load "compile")' | $(EXE) + +check: all + echo '(load "check")' | $(EXE) + +install: all + echo '(install-shim "mhash")' | $(EXE) -- *.com *.bci *.pkd make.scm + +clean: + rm -f mhash-const.scm mhash-const mhash-const.c mhash-shim.c + rm -f mhash-*.crf mhash-*.fre mhash-*.pkd + rm -f *.o *.so *.bin *.ext *.com *.bci + rm -f *.moc *.fni *-init.c *-init.h *-init.o + rm -f sample + +distclean: clean + rm -f Makefile config.h config.log config.status + +maintainer-clean: distclean + rm -f configure config.h.in + rm -rf autom4te.cache + +mhash-shim.so: mhash-shim.o mhash-adapter.o + echo "(link-shim)" | $(EXE) -- $(LDFLAGS) -o $@ $^ $(LIBS) + +mhash-adapter.o: mhash-adapter.c mhash-shim.h + echo '(compile-shim)' | $(EXE) -- $(CPPFLAGS) $(CFLAGS) -c $< + +mhash-shim.o: mhash-shim.c mhash-shim.h + echo '(compile-shim)' | $(EXE) -- $(CPPFLAGS) $(CFLAGS) -c $< + +mhash-shim.c: mhash.cdecl mhash-shim.h + echo '(generate-shim "mhash" "#include \"mhash-shim.h\"")' \ + | $(EXE) + +.PHONY: all check install clean distclean maintainer-clean diff --git a/src/mhash/README b/src/mhash/README new file mode 100644 index 000000000..72d4a4db0 --- /dev/null +++ b/src/mhash/README @@ -0,0 +1,18 @@ +mhash/ (prmhash.c): +mhash 4 +mhash_count 0 +mhash_end 1 +mhash_get_block_size 1 +mhash_get_hash_name 1 +mhash_get_hash_pblock 1 +mhash_get_keygen_max_key_size 1 +mhash_get_keygen_name 1 +mhash_get_keygen_salt_size 1 +mhash_hmac_end 1 +mhash_hmac_init 3 +mhash_init 1 +mhash_keygen 4 +mhash_keygen_count 0 +mhash_keygen_uses_count 1 +mhash_keygen_uses_hash_algorithm 1 +mhash_keygen_uses_salt 1 diff --git a/src/mhash/check.scm b/src/mhash/check.scm new file mode 100644 index 000000000..aaaf5065c --- /dev/null +++ b/src/mhash/check.scm @@ -0,0 +1,9 @@ +#| -*-Scheme-*- |# + +;;;; Test the mhash wrapper. + +(load "make") +(with-system-library-directories + '("./") + (lambda () + (load "mhash-check" (->environment '(mhash))))) \ No newline at end of file diff --git a/src/mhash/compile.scm b/src/mhash/compile.scm new file mode 100644 index 000000000..0f4899c2e --- /dev/null +++ b/src/mhash/compile.scm @@ -0,0 +1,12 @@ +#| -*-Scheme-*- |# + +;;;; Compile the mhash wrapper. + +(fluid-let ((load/suppress-loading-message? #t)) + (load-option 'CREF) + (load-option 'FFI)) + +(with-system-library-directories + '("./") + (lambda () + (compile-system "mhash" (directory-pathname (current-load-pathname))))) \ No newline at end of file diff --git a/src/mhash/configure.ac b/src/mhash/configure.ac new file mode 100644 index 000000000..14f2b2db2 --- /dev/null +++ b/src/mhash/configure.ac @@ -0,0 +1,85 @@ +dnl Process this file with autoconf to produce a configure script. + +AC_INIT([MIT/GNU Scheme mhash interface], + [0.1], + [bug-mit-scheme@gnu.org], + [mit-scheme-mhash]) +AC_CONFIG_SRCDIR([mhash.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 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 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_WITH([mhash], + AS_HELP_STRING([--with-mhash], + [Use mhash library if available [[yes]]])) +: ${with_mhash='yes'} + +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).]) + LIBS="-lmhash" + ]) + ]) +fi + +AC_SUBST([LIBS]) +AC_SUBST([CPPFLAGS]) +AC_SUBST([LDFLAGS]) +AC_CONFIG_FILES([Makefile]) +AC_OUTPUT diff --git a/src/mhash/make.scm b/src/mhash/make.scm new file mode 100644 index 000000000..9f2d5000f --- /dev/null +++ b/src/mhash/make.scm @@ -0,0 +1,9 @@ +#| -*-Scheme-*- |# + +;;;; Load the mhash option. + +(with-working-directory-pathname (directory-pathname (current-load-pathname)) + (lambda () + (load-package-set "mhash"))) + +(add-subsystem-identification! "mhash" '(0 1)) \ No newline at end of file diff --git a/src/mhash/mhash-adapter.c b/src/mhash/mhash-adapter.c new file mode 100644 index 000000000..41210eace --- /dev/null +++ b/src/mhash/mhash-adapter.c @@ -0,0 +1,72 @@ +/* -*-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 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 mhash crypto-hash library. */ + +#include "mhash-shim.h" + +extern void +do_mhash (MHASH thread, const char *string, int start, int end) +{ + mhash (thread, string + start, end - start); +} + +extern void +do_mhash_end (MHASH context, char *string, size_t size) +{ + void * digest = mhash_end (context); + memcpy (string, digest, size); + free (digest); +} + +extern void +do_mhash_hmac_end (MHASH context, char *string, size_t size) +{ + void * digest = mhash_hmac_end (context); + memcpy (string, digest, size); + free (digest); +} + +extern int +do_mhash_keygen (keygenid algorithm, + hashid hashid1, hashid hashid2, + int count, + void *salt, int salt_size, + char *keyword, int keysize, + unsigned char *password, int passwordlen) +{ + KEYGEN keygen; + + keygen.hash_algorithm[0] = hashid1; + keygen.hash_algorithm[1] = hashid2; + keygen.count = count; + keygen.salt = salt; + keygen.salt_size = salt_size; + + return (mhash_keygen_ext (algorithm, keygen, + keyword, keysize, + password, passwordlen)); +} diff --git a/src/mhash/mhash-check.scm b/src/mhash/mhash-check.scm new file mode 100644 index 000000000..0fc6caac3 --- /dev/null +++ b/src/mhash/mhash-check.scm @@ -0,0 +1,39 @@ +#| -*-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 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 mhash wrapper. + +(if (not (mhash-available?)) + (warn "mhash wrapper not found") + (let ((sample "Some text to hash.")) + (let ((hash (mhash-sum->hexadecimal (mhash-string 'MD5 sample)))) + (if (not (string=? hash "c8e89c4cbf3abf9aa758d691cbe4b784")) + (error "Bad hash for sample text:" hash))) + (call-with-output-file "sample" + (lambda (port) (write-string sample port) (newline port))) + (let ((hash (mhash-sum->hexadecimal (mhash-file 'MD5 "sample")))) + (if (not (string=? hash "43eb9eccb88c329721925efc04843af1")) + (error "Bad hash for sample file:" hash))))) \ No newline at end of file diff --git a/src/mhash/mhash-shim.h b/src/mhash/mhash-shim.h new file mode 100644 index 000000000..bebfac7a3 --- /dev/null +++ b/src/mhash/mhash-shim.h @@ -0,0 +1,46 @@ +/* -*-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 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 mhash crypto-hash library. */ + +#include "config.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 + +extern void do_mhash (MHASH thread, const char *string, int start, int end); +extern void do_mhash_end (MHASH context, char *string, size_t size); +extern void do_mhash_hmac_end (MHASH context, char *string, size_t size); +extern int do_mhash_keygen (keygenid algorithm, + hashid hashid1, hashid hashid2, + int count, + void *salt, int salt_size, + char *keyword, int keysize, + unsigned char *password, int passwordlen); diff --git a/src/mhash/mhash.cdecl b/src/mhash/mhash.cdecl new file mode 100644 index 000000000..f6aa75c36 --- /dev/null +++ b/src/mhash/mhash.cdecl @@ -0,0 +1,84 @@ +#| -*-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 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 mhash-shim.so. + +(typedef MHASH (* MHASH_INSTANCE)) +(typedef hashid int) +(typedef keygenid int) + +(extern int mhash_count) +(extern (* char) mhash_get_hash_name (id hashid)) +(extern int mhash_get_block_size (id hashid)) +(extern int mhash_get_hash_pblock (id hashid)) + +(extern int mhash_keygen_count) +(extern (* uchar) mhash_get_keygen_name (id keygenid)) +(extern int mhash_get_keygen_salt_size (id keygenid)) +(extern int mhash_get_keygen_max_key_size (id keygenid)) +(extern int mhash_keygen_uses_salt (id keygenid)) +(extern int mhash_keygen_uses_count (id keygenid)) +(extern int mhash_keygen_uses_hash_algorithm (id keygenid)) + +(extern MHASH mhash_init (type hashid)) + +(extern void mhash_deinit (context MHASH) (digest (* void))) + +(extern void do_mhash + (thread MHASH) + (string (* (const char))) + (start int) + (end int)) + +(extern void do_mhash_end + (context MHASH) + (string (* char)) + (size int)) + +(extern MHASH mhash_hmac_init + (type hashid) + (key (* void)) + (keysize int) + (blocksize int)) + +(extern int mhash_hmac_deinit (context MHASH) (digest (* void))) + +(extern void do_mhash_hmac_end + (context MHASH) + (string (* char)) + (size int)) + +(extern int do_mhash_keygen + (id keygenid) + (hashid1 hashid) + (hashid2 hashid) + (count uint) + (salt (* void)) + (salt_size int) + (keyword (* char)) + (keysize int) + (password (* uchar)) + (passwordlen int)) \ No newline at end of file diff --git a/src/mhash/mhash.pkg b/src/mhash/mhash.pkg new file mode 100644 index 000000000..1a248dd40 --- /dev/null +++ b/src/mhash/mhash.pkg @@ -0,0 +1,59 @@ +#| -*-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 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 (mhash) + (files "mhash") + (parent ()) + (initialization (initialize-package!)) + ;; You'll have to import these from (global-definitions mhash/). + ;; They are currently bound in () by exports from (runtime crypto). + #;(export #f + make-mhash-keygen-type + mhash-available? + 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-substring + mhash-sum->hexadecimal + mhash-sum->number + mhash-type-names + mhash-update)) \ No newline at end of file diff --git a/src/mhash/mhash.scm b/src/mhash/mhash.scm new file mode 100644 index 000000000..376f79f05 --- /dev/null +++ b/src/mhash/mhash.scm @@ -0,0 +1,471 @@ +#| -*-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 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. + +|# + +;;;; mhash wrapper +;;; package: (mhash) + +(declare (usual-integrations)) + +(C-include "mhash") + +(define mhash-initialized? #f) +(define mhash-algorithm-names) +(define mhash-contexts '()) +(define mhash-hmac-contexts '()) +(define mhash-contexts-mutex) + +(define (add-context-cleanup context) + (with-thread-mutex-locked mhash-contexts-mutex + (lambda () + (set! mhash-contexts + (cons (weak-cons context (mhash-context-alien context)) + mhash-contexts))))) + +(define (add-hmac-context-cleanup context) + (with-thread-mutex-locked mhash-contexts-mutex + (lambda () + (set! mhash-hmac-contexts + (cons (weak-cons context (mhash-hmac-context-alien context)) + mhash-contexts))))) + +(define (remove-context-cleanup context) + (with-thread-mutex-locked mhash-contexts-mutex + (lambda () + (let ((entry (weak-assq context mhash-contexts))) + (if entry + (set! mhash-contexts (delq! context mhash-contexts))))))) + +(define (remove-hmac-context-cleanup context) + (with-thread-mutex-locked mhash-contexts-mutex + (lambda () + (let ((entry (weak-assq context mhash-hmac-contexts))) + (if entry + (set! mhash-hmac-contexts (delq! context mhash-hmac-contexts))))))) + +(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-contexts) + (let loop ((entries mhash-contexts) + (prev #f)) + (if (pair? entries) + (let ((entry (car entries)) + (next (cdr entries))) + (if (weak-pair/car? entry) + (loop next entries) + (let ((context (weak-cdr entry))) + (if prev + (set-cdr! prev next) + (set! mhash-contexts next)) + (if (not (alien-null? context)) + (begin + (C-call "mhash_deinit" context 0) + (alien-null! context))) + (loop next prev))))))) + +(define (cleanup-hmac-contexts) + (let loop ((entries mhash-hmac-contexts) + (prev #f)) + (if (pair? entries) + (let ((entry (car entries)) + (next (cdr entries))) + (if (weak-pair/car? entry) + (loop next entries) + (let ((context (weak-cdr entry))) + (if prev + (set-cdr! prev next) + (set! mhash-hmac-contexts next)) + (if (not (alien-null? context)) + (begin + (C-call "mhash_hmac_deinit" context 0) + (alien-null! context))) + (loop next prev))))))) + +(define (cleanup-mhash-contexts) + (if (not (thread-mutex-owner mhash-contexts-mutex)) + (begin + (cleanup-contexts) + (cleanup-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 mutex alien id) +(define-structure mhash-hmac-context mutex alien id) + +(define (guarantee-mhash-context object procedure) + (if (not (mhash-context? object)) + (error:wrong-type-argument object "mhash context" procedure)) + (if (alien-null? (mhash-context-alien object)) + (error:bad-range-argument object procedure))) + +(define (guarantee-mhash-hmac-context object procedure) + (if (not (mhash-hmac-context? object)) + (error:wrong-type-argument object "mhash HMAC context" procedure)) + (if (alien-null? (mhash-hmac-context-alien object)) + (error:bad-range-argument object procedure))) + +(define (with-context-locked context thunk) + (with-thread-mutex-locked (mhash-context-mutex context) thunk)) + +(define (with-hmac-context-locked context thunk) + (with-thread-mutex-locked (mhash-hmac-context-mutex context) thunk)) + +(define (with-context-locked-open context operator receiver) + (with-thread-mutex-locked (mhash-context-mutex context) + (lambda () + (let ((alien (mhash-context-alien context))) + (if (alien-null? alien) + (error:bad-range-argument context operator)) + (receiver alien))))) + +(define (with-hmac-context-locked-open context operator receiver) + (with-thread-mutex-locked (mhash-hmac-context-mutex context) + (lambda () + (let ((alien (mhash-hmac-context-alien context))) + (if (alien-null? alien) + (error:bad-range-argument context operator)) + (receiver alien))))) + +(define (mhash-type-names) + (names-vector->list mhash-algorithm-names)) + +(define (mhash-get-block-size name) + (C-call "mhash_get_block_size" + (mhash-name->id name 'MHASH-GET-BLOCK-SIZE))) + +(define (mhash-init name) + (let ((id (mhash-name->id name 'MHASH-INIT)) + (alien (make-alien '|MHASH_INSTANCE|))) + (let ((context (make-mhash-context (make-thread-mutex) alien id))) + (add-context-cleanup context) + (with-context-locked context + (lambda () + (C-call "mhash_init" alien id) + (if (alien-null? alien) ; == MHASH_FAILED + (error "Unable to allocate mhash context:" name)))) + context))) + +(define (mhash-update context string start end) + (guarantee-substring string start end 'MHASH-UPDATE) + (with-context-locked-open context 'MHASH-UPDATE + (lambda (alien) + (C-call "do_mhash" alien string start end)))) + +(define (mhash-end context) + (with-context-locked-open context 'MHASH-END + (lambda (alien) + (let* ((id (mhash-context-id context)) + (size (C-call "mhash_get_block_size" id)) + (digest (make-string size))) + (C-call "do_mhash_end" alien digest size) + (remove-context-cleanup context) + digest)))) + +(define (mhash-hmac-init name key) + (guarantee-string key 'HMASH-HMAC-INIT) + (let ((id (mhash-name->id name 'MHASH-HMAC-INIT)) + (alien (make-alien '|MHASH_INSTANCE|))) + (let ((context (make-mhash-hmac-context (make-thread-mutex) alien id)) + (block-size (C-call "mhash_get_hash_pblock" id)) + (key-size (string-length key))) + (add-hmac-context-cleanup context) + (with-hmac-context-locked context + (lambda () + (C-call "mhash_hmac_init" alien id key key-size block-size) + (if (alien-null? alien) ; == MHASH_FAILED + (error "Unable to allocate mhash HMAC context:" name)))) + context))) + +(define (mhash-hmac-update context string start end) + (guarantee-substring string start end 'MHASH-HMAC-UPDATE) + (with-hmac-context-locked-open context 'MHASH-HMAC-UPDATE + (lambda (alien) + (C-call "do_mhash" alien string start end)))) + +(define (mhash-hmac-end context) + (with-hmac-context-locked-open context 'MHASH-HMAC-END + (lambda (alien) + (let* ((id (mhash-hmac-context-id context)) + (size (C-call "mhash_get_block_size" id)) + (digest (make-string size))) + (C-call "do_mhash_hmac_end" alien digest size) + (remove-hmac-context-cleanup context) + digest)))) + +(define mhash-keygen-names) + +(define (keygen-name->id name procedure) + (let ((n (vector-length mhash-keygen-names))) + (let loop ((i 0)) + (cond ((fix:= i n) (error:bad-range-argument name procedure)) + ((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) + (not (zero? (C-call "mhash_keygen_uses_salt" + (keygen-name->id name 'MHASH-KEYGEN-USES-SALT?))))) + +(define (mhash-keygen-uses-count? name) + (not (zero? (C-call "mhash_keygen_uses_count" + (keygen-name->id name 'MHASH-KEYGEN-USES-COUNT?))))) + +(define (mhash-keygen-uses-hash-algorithm name) + (C-call "mhash_keygen_uses_hash_algorithm" + (keygen-name->id name 'MHASH-KEYGEN-USES-HASH-ALGORITHM))) + +(define (mhash-keygen-salt-size name) + (C-call "mhash_get_keygen_salt_size" + (keygen-name->id name 'MHASH-KEYGEN-SALT-SIZE))) + +(define (mhash-keygen-max-key-size name) + (C-call "mhash_get_keygen_max_key_size" + (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 ((keygenid (mhash-keygen-type-id type)) + (keyword-size (mhash-keygen-type-key-length type))) + (let ((params (salted-keygen-params + keygenid (mhash-keygen-type-parameter-vector type) salt)) + (keyword (make-string keyword-size)) + (max-key-size (C-call "mhash_get_keygen_max_key_size" keygenid))) + + (define (hashid-map params i) + (let ((name (vector-ref params i))) + (if (not name) + 0 + (mhash-name->id name 'MHASH-KEYGEN)))) + + (if (not (or (zero? max-key-size) + (< max-key-size (string-length keyword)))) + (error "keyword size exceeds maximum:" max-key-size type)) + (if (not (zero? (C-call "do_mhash_keygen" + keygenid + (hashid-map params 3) ;hash_algorithm[0] + (hashid-map params 4) ;hash_algorithm[1] + (vector-ref params 1) ;count + (vector-ref params 0) ;salt + (string-length (vector-ref params 0)) + keyword keyword-size + passphrase (string-length passphrase)))) + (error "Error signalled by mhash_keygen.")) + keyword))) + +(define (salted-keygen-params id params #!optional salt) + (if (not (zero? (C-call "mhash_keygen_uses_salt" id))) + (begin + (if (or (default-object? salt) (not salt)) + (error "Salt required:" + (vector-ref mhash-keygen-names id))) + (let ((n (C-call "mhash_get_keygen_salt_size" id))) + (if (not (or (= n 0) + (= n (string-length salt)))) + (error "Salt size incorrect:" + (string-length salt) + (error-irritant/noise "; should be:") + n))) + (let ((p (vector-copy params))) + (vector-set! p 0 salt) + p)) + params)) + +(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) + (if (not (index-fixnum? key-length)) + (error:wrong-type-argument key-length "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?) + (let ((path (ignore-errors (lambda () + (system-library-pathname "mhash-shim.so"))))) + (and (pathname? path) + (file-loadable? path) + (begin + (if (not mhash-initialized?) + (begin + (set! mhash-algorithm-names + (make-names-vector + (lambda () (C-call "mhash_count")) + (lambda (hashid) + (let* ((alien (make-alien-to-free + '(* char) + (lambda (alien) + (C-call "mhash_get_hash_name" + alien hashid)))) + (str (c-peek-cstring alien))) + (free alien) + str)))) + (set! mhash-keygen-names + (make-names-vector + (lambda () (C-call "mhash_keygen_count")) + (lambda (keygenid) + (let* ((alien (make-alien-to-free + '(* char) + (lambda (alien) + (C-call "mhash_get_keygen_name" + alien keygenid)))) + (str (c-peek-cstring alien))) + (free alien) + str)))) + (set! mhash-initialized? #t))) + #t)))) + +(define (reset-mhash-variables!) + (set! mhash-initialized? #f) + (for-each (lambda (weak) (alien-null! (weak-cdr weak))) mhash-contexts) + (set! mhash-contexts '()) + (for-each (lambda (weak) (alien-null! (weak-cdr weak))) mhash-hmac-contexts) + (set! mhash-hmac-contexts '()) + unspecific) + +(define (mhash-file hash-type filename) + (call-with-binary-input-file filename + (lambda (port) + (let ((buffer (make-string 4096)) + (context (mhash-init hash-type))) + (dynamic-wind (lambda () + unspecific) + (lambda () + (let loop () + (let ((n (read-substring! buffer 0 4096 port))) + (if (fix:= 0 n) + (mhash-end context) + (begin + (mhash-update context buffer 0 n) + (loop)))))) + (lambda () + (string-fill! buffer #\NUL))))))) + +(define (mhash-string hash-type string) + (mhash-substring hash-type string 0 (string-length string))) + +(define (mhash-substring hash-type string start end) + (let ((context (mhash-init hash-type))) + (mhash-update context string start end) + (mhash-end context))) + +(define (mhash-sum->number sum) + (let ((l (string-length sum))) + (do ((i 0 (fix:+ i 1)) + (n 0 (+ (* n #x100) (vector-8b-ref sum i)))) + ((fix:= i l) n)))) + +(define (mhash-sum->hexadecimal sum) + (let ((n (string-length sum)) + (digits "0123456789abcdef")) + (let ((s (make-string (fix:* 2 n)))) + (do ((i 0 (fix:+ i 1))) + ((fix:= i n)) + (string-set! s (fix:* 2 i) + (string-ref digits + (fix:lsh (vector-8b-ref sum i) -4))) + (string-set! s (fix:+ (fix:* 2 i) 1) + (string-ref digits + (fix:and (vector-8b-ref sum i) #x0F)))) + s))) + +;;;; Package initialization + +(define (initialize-package!) + (set! mhash-contexts-mutex (make-thread-mutex)) + (reset-mhash-variables!) + (add-gc-daemon! cleanup-mhash-contexts) + (add-event-receiver! event:after-restart reset-mhash-variables!)) + +(define (make-names-vector get-count get-name) + (let ((n (get-count))) + (let ((v (make-vector n))) + (do ((i 0 (fix:+ i 1))) + ((fix:= i n)) + (vector-set! v i + (let ((name (get-name i))) + (and name + (intern name))))) + v))) + +(define (names-vector->list v) + (let ((end (vector-length v))) + (let loop ((index 0) (names '())) + (if (fix:< index end) + (loop (fix:+ index 1) + (let ((name (vector-ref v index))) + (if name + (cons name names) + names))) + names)))) \ No newline at end of file