From cb39059345ed77675deef07bb6f9fc8c61040792 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Wed, 17 May 2017 16:01:12 -0700 Subject: [PATCH] plugins: Re-sync with runtime; allow strings as well as bytevectors. --- src/blowfish/NEWS | 15 ++- src/blowfish/blowfish-check.scm | 4 +- src/blowfish/blowfish.scm | 148 +++++++++++++++-------------- src/gdbm/NEWS | 10 +- src/gdbm/gdbm.pkg | 6 +- src/gdbm/gdbm.scm | 63 ++++++++----- src/mcrypt/NEWS | 14 ++- src/mcrypt/mcrypt.pkg | 6 +- src/mcrypt/mcrypt.scm | 162 +++++++++++++++++++------------- src/md5/NEWS | 13 ++- src/md5/md5-check.scm | 4 +- src/md5/md5.pkg | 8 +- src/md5/md5.scm | 71 +++++++------- src/mhash/NEWS | 14 ++- src/mhash/mhash-check.scm | 4 +- src/mhash/mhash.pkg | 6 +- src/mhash/mhash.scm | 158 +++++++++++++++---------------- 17 files changed, 404 insertions(+), 302 deletions(-) diff --git a/src/blowfish/NEWS b/src/blowfish/NEWS index e340c6d36..cd0ac9f2a 100644 --- a/src/blowfish/NEWS +++ b/src/blowfish/NEWS @@ -22,8 +22,19 @@ 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-blowfish 0.2 - Matt Birkholz, 2017-05-18 +=================================================== + +Use byte vectors for binary data instead of strings. This changes +every export except blowfish-file? and perhaps compute-blowfish-init- +vector IF you don't care whether the init vector is a string. Every +procedure that previously accepted/returned strings now +requires/produces byte vectors. If it accepted/returned generic ports +it now requires/produces binary ports. If you are using the md5 +plugin to produce a digest for blowfish-set-key, you're winning, with +blowfish-set-key at least; md5 digests are now byte vectors too. + mit-scheme-blowfish 0.1 - Matt Birkholz, 2016-02-19 =================================================== -* Use libtool and automake, rather than the microcode's disappearing - module support. +Use libtool and automake. diff --git a/src/blowfish/blowfish-check.scm b/src/blowfish/blowfish-check.scm index f1bae2a10..ae2ca5f5b 100644 --- a/src/blowfish/blowfish-check.scm +++ b/src/blowfish/blowfish-check.scm @@ -31,7 +31,7 @@ USA. (lambda (output) (blowfish-encrypt-port (open-input-bytevector sample) output - "secret" + (string->utf8 "secret") (write-blowfish-file-header output) #t))) (let ((read-back @@ -39,7 +39,7 @@ USA. (lambda (input) (call-with-output-bytevector (lambda (output) - (blowfish-encrypt-port input output "secret" + (blowfish-encrypt-port input output (string->utf8 "secret") (read-blowfish-file-header input) #f))))))) (if (not (bytevector=? sample read-back)) diff --git a/src/blowfish/blowfish.scm b/src/blowfish/blowfish.scm index 8a042a8ce..ccd9b2ce3 100644 --- a/src/blowfish/blowfish.scm +++ b/src/blowfish/blowfish.scm @@ -24,26 +24,23 @@ USA. |# -;;;; The BLOWFISH option. +;;;; Interface to Blowfish ;;; package: (blowfish) (declare (usual-integrations)) (C-include "blowfish") -(define (blowfish-set-key string) - ;; Generate a Blowfish key from STRING. - ;; STRING must be 72 bytes or less in length. +(define (blowfish-set-key bytes) + ;; Generate a Blowfish key from BYTES. + ;; BYTES must be 72 bytes or less in length. ;; For text-string keys, use MD5 on the text, and pass the digest here. - (guarantee string? string 'blowfish-set-key) - (let* ((data (string->utf8 string)) - (len (bytevector-length data))) + (guarantee bytevector? bytes 'blowfish-set-key) + (let ((len (bytevector-length bytes))) (if (> len 72) - (error:bad-range-argument - string "a string encodable in UTF8 with fewer than 72 bytes" - 'blowfish-set-key)) + (error:bad-range-argument bytes "72 or fewer bytes" 'blowfish-set-key)) (let ((key (make-bytevector (C-sizeof "BF_KEY")))) - (C-call "BF_set_key" key len data) + (C-call "BF_set_key" key len bytes) key))) (define (blowfish-ecb input output key encrypt?) @@ -51,10 +48,10 @@ USA. ;; INPUT is an 8-byte bytevector. ;; OUTPUT is an 8-byte bytevector. ;; KEY is a Blowfish key. - ;; ENCRYPT? says whether to encrypt (non-#F) or decrypt (#F). - (guarantee-bfkey key 'BLOWFISH-ECB) - (guarantee-8byte-arg input 'BLOWFISH-ECB) - (guarantee-8byte-arg output 'BLOWFISH-ECB) + ;; ENCRYPT? says whether to encrypt (#T) or decrypt (#F). + (guarantee-bfkey key 'blowfish-ecb) + (guarantee-8byte-arg input 'blowfish-ecb) + (guarantee-8byte-arg output 'blowfish-ecb) (C-call "BF_ecb_encrypt" input output key (bf-de/encrypt encrypt?))) (define (blowfish-cbc input output key init-vector encrypt?) @@ -63,39 +60,39 @@ USA. ;; OUTPUT is a bytevector whose length is the same as INPUT. ;; KEY is a Blowfish key. ;; INIT-VECTOR is an 8-byte bytevector; it is modified after each call. - ;; The value from any call may be passed in to a later call. - ;; ENCRYPT? says whether to encrypt (non-#F) or decrypt (#F). - (guarantee-init-vector init-vector 'BLOWFISH-CBC) - (guarantee-bfkey key 'BLOWFISH-CBC) - (guarantee-8Xbyte-arg input 'BLOWFISH-CBC) + ;; The value from any call may be passed in to a later call. + ;; ENCRYPT? says whether to encrypt (#T) or decrypt (#F). + (guarantee-init-vector init-vector 'blowfish-cbc) + (guarantee-bfkey key 'blowfish-cbc) + (guarantee-8Xbyte-arg input 'blowfish-cbc) (if (or (eq? input output) (not (= (bytevector-length output) (bytevector-length input)))) (error:bad-range-argument output "a bytevector as long as the input bytevector" - 'BLOWFISH-CBC)) + 'blowfish-cbc)) (C-call "BF_cbc_encrypt" input output (bytevector-length input) key init-vector (bf-de/encrypt encrypt?))) (define (blowfish-cfb64 input istart iend output ostart key init-vector num encrypt?) ;; Apply Blowfish in Cipher Feed-Back mode. - ;; (INPUT,ISTART,IEND) is an arbitrary subbytevector. - ;; OUTPUT is a bytevector as large as the input subbytevector. - ;; OSTART says where to start writing to the output bytevector. + ;; (INPUT,ISTART,IEND) is an arbitrary bytevector range. + ;; OUTPUT is a bytevector. + ;; OSTART says where to start writing in OUTPUT. ;; KEY is a Blowfish key. ;; INIT-VECTOR is an 8-byte bytevector; it is modified after each call. - ;; The value from any call may be passed in to a later call. - ;; The initial value must be unique for each message/key pair. + ;; The value from any call may be passed in to a later call. + ;; The initial value must be unique for each message/key pair. ;; NUM is a digit from 0 to 7 inclusive; it is the low 3 bits of the - ;; number of bytes that have previously been processed in this stream. - ;; ENCRYPT? says whether to encrypt (non-#F) or decrypt (#F). + ;; number of bytes that have previously been processed in this stream. + ;; ENCRYPT? says whether to encrypt (#T) or decrypt (#F). ;; Returned value is the new value of NUM. - (guarantee-bfkey key 'BLOWFISH-CFB64) - (guarantee-init-vector init-vector 'BLOWFISH-CFB64) - (guarantee-subbytevector input istart iend 'BLOWFISH-CFB64) + (guarantee-bfkey key 'blowfish-cfb64) + (guarantee-init-vector init-vector 'blowfish-cfb64) + (guarantee-subbytevector input istart iend 'blowfish-cfb64) (guarantee-subbytevector output ostart (+ ostart (- iend istart)) - 'BLOWFISH-CFB64) - (guarantee-init-index num 'BLOWFISH-CFB64) + 'blowfish-cfb64) + (guarantee-init-index num 'blowfish-cfb64) (let ((ilen (- iend istart))) (if (and (eq? input output) (< ostart iend) @@ -103,16 +100,16 @@ USA. (error:bad-range-argument ostart "an index of a subbytevector not overlapping the input subbytevector" - 'BLOWFISH-CFB64)) + 'blowfish-cfb64)) (C-call "do_BF_cfb64_encrypt" input istart output ostart ilen key init-vector num (bf-de/encrypt encrypt?)))) (define (blowfish-ofb64 input istart iend output ostart key init-vector num) ;; Apply Blowfish in Output Feed-Back mode. - ;; (INPUT,ISTART,IEND) is an arbitrary subbytevector. - ;; OUTPUT is a bytevector as large as the input subbytevector. - ;; OSTART says where to start writing to the output bytevector. + ;; (INPUT,ISTART,IEND) is an arbitrary bytevector range. + ;; OUTPUT is a bytevector. + ;; OSTART says where to start writing in OUTPUT. ;; KEY is a Blowfish key. ;; INIT-VECTOR is an 8-byte bytevector; it is modified after each call. ;; The value from any call may be passed in to a later call. @@ -120,12 +117,12 @@ USA. ;; NUM is a digit from 0 to 7 inclusive; it is the low 3 bits of the ;; number of bytes that have previously been processed in this stream. ;; Returned value is the new value of NUM. - (guarantee-bfkey key 'BLOWFISH-OFB64) - (guarantee-init-vector init-vector 'BLOWFISH-OFB64) - (guarantee-subbytevector input istart iend 'BLOWFISH-OFB64) + (guarantee-bfkey key 'blowfish-ofb64) + (guarantee-init-vector init-vector 'blowfish-ofb64) + (guarantee-subbytevector input istart iend 'blowfish-ofb64) (guarantee-subbytevector output ostart (+ ostart (- iend istart)) - 'BLOWFISH-OFB64) - (guarantee-init-index num 'BLOWFISH-OFB64) + 'blowfish-ofb64) + (guarantee-init-index num 'blowfish-ofb64) (let ((ilen (- iend istart))) (if (and (eq? input output) (< ostart iend) @@ -133,7 +130,7 @@ USA. (error:bad-range-argument ostart "an index of a subbytevector not overlapping the input subbytevector" - 'BLOWFISH-OFB64)) + 'blowfish-ofb64)) (C-call "do_BF_ofb64_encrypt" input istart output ostart ilen key init-vector num))) @@ -194,12 +191,13 @@ USA. (lambda () (let loop ((m 0)) (let ((n (read-bytevector! input-buffer input))) - (if (and (not (eof-object? n)) - (not (fix:= 0 n))) + (if (and n (not (eof-object? n))) (let ((m (blowfish-cfb64 input-buffer 0 n output-buffer 0 key init-vector m encrypt?))) - (write-bytevector output-buffer output 0 n) + (let ((n* (write-bytevector output-buffer output 0 n))) + (if (not (eqv? n n*)) + (error "Short write (requested, actual):" n n*))) (loop m)))))) (lambda () (bytevector-fill! input-buffer 0) @@ -216,40 +214,50 @@ USA. #x100000) (random #x100000)) (quotient t #x100))) - ((fix:= 8 i)) + ((not (fix:< i 8))) (bytevector-u8-set! iv i (remainder t #x100))) iv)) (define (write-blowfish-file-header port) (write-bytevector blowfish-file-header-v2 port) - (write-u8 (char->integer #\newline) port) (let ((init-vector (compute-blowfish-init-vector))) (write-bytevector init-vector port) init-vector)) (define (read-blowfish-file-header port) - (let ((line (read-header port))) - (cond ((bytevector=? blowfish-file-header-v1 line) - (make-bytevector 8 #\NUL)) - ((bytevector=? blowfish-file-header-v2 line) - (read-bytevector 8 port)) - (else - (error:bad-range-argument port 'READ-BLOWFISH-FILE-HEADER))))) - -(define (read-header port) - (let loop ((bytes '())) - (let ((byte (read-u8 port))) - (if (eof-object? byte) - (apply bytevector (reverse! bytes)) - (if (fix:= byte (char->integer #\newline)) - (apply bytevector (reverse! bytes)) - (loop (cons byte bytes))))))) + (let ((version (try-read-blowfish-file-header port))) + (if (not version) + (error:bad-range-argument port 'read-blowfish-file-header)) + (if (= version 1) + (make-bytevector 8 0) + (or (%safe-read-bytevector 8 port) + (error "Short read while getting init-vector:" port))))) + +(define (try-read-blowfish-file-header port) + (let* ((n (bytevector-length blowfish-file-header-v1)) + (bv1 (%safe-read-bytevector n port))) + (and bv1 + (if (bytevector=? bv1 blowfish-file-header-v1) + 1 + (let* ((m (fix:- (bytevector-length blowfish-file-header-v2) n)) + (bv2 (%safe-read-bytevector m port))) + (and bv2 + (bytevector=? (bytevector-append bv1 bv2) + blowfish-file-header-v2) + 2)))))) + +(define (%safe-read-bytevector n port) + (let ((bv (read-bytevector n port))) + (and bv + (not (eof-object? bv)) + (fix:= (bytevector-length bv) n) + bv))) (define (blowfish-file? pathname) - (let ((line (call-with-binary-input-file pathname read-header))) - (and (not (eof-object? line)) - (or (bytevector=? line blowfish-file-header-v1) - (bytevector=? line blowfish-file-header-v2))))) + (call-with-binary-input-file pathname try-read-blowfish-file-header)) + +(define blowfish-file-header-v1 + (string->utf8 "Blowfish, 16 rounds\n")) -(define blowfish-file-header-v1 (string->utf8 "Blowfish, 16 rounds")) -(define blowfish-file-header-v2 (string->utf8 "Blowfish, 16 rounds, version 2")) \ No newline at end of file +(define blowfish-file-header-v2 + (string->utf8 "Blowfish, 16 rounds, version 2\n")) \ No newline at end of file diff --git a/src/gdbm/NEWS b/src/gdbm/NEWS index fe8d001c6..f0bb04453 100644 --- a/src/gdbm/NEWS +++ b/src/gdbm/NEWS @@ -22,8 +22,14 @@ 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-gdbm 0.2 - Matt Birkholz, 2017-05-18 +=============================================== + +Use new Unicode support. Convert non-ASCII strings (keys and data) to +UTF8. This assumes any other program adding non-ASCII keys or data is +using the same encoding. + mit-scheme-gdbm 0.1 - Matt Birkholz, 2016-02-19 =============================================== -* Use libtool and automake, rather than the microcode's disappearing - module support. +Use libtool and automake. diff --git a/src/gdbm/gdbm.pkg b/src/gdbm/gdbm.pkg index d11a1a988..f862304ab 100644 --- a/src/gdbm/gdbm.pkg +++ b/src/gdbm/gdbm.pkg @@ -30,8 +30,10 @@ USA. (files "gdbm") (parent ()) (initialization (initialize-package!)) - ;; You'll have to import these from (global-definitions gdbm/). - ;; They are currently bound in () by exports from (runtime gdbm). + (import (runtime ustring) + cp1-ref + ustring-cp-size + ustring?) (export (gdbm global) gdbm-close gdbm-delete diff --git a/src/gdbm/gdbm.scm b/src/gdbm/gdbm.scm index 9a6704783..3f7a1e1ee 100644 --- a/src/gdbm/gdbm.scm +++ b/src/gdbm/gdbm.scm @@ -24,13 +24,36 @@ USA. |# -;;;; The GDBM option. +;;;; The GDBM2 option. ;;; package: (gdbm) (declare (usual-integrations)) (C-include "gdbm") +(define-integrable (every-loop proc ref string start end) + (let loop ((i start)) + (if (fix:< i end) + (and (proc (ref string i)) + (loop (fix:+ i 1))) + #t))) + +(define (->bytes string) + (if (and (or (bytevector? string) + (and (ustring? string) + (fix:= 1 (ustring-cp-size string)))) + (let ((end (string-length string))) + (every-loop (lambda (cp) (fix:< cp #x80)) + cp1-ref string 0 end))) + string + (string->utf8 string))) + +(declare (integrate-operator bytes-length)) +(define (bytes-length bytes) + (if (bytevector? bytes) + (bytevector-length bytes) + (string-length bytes))) + ;; Parameters to gdbm_open for READERS, WRITERS, and WRITERS who can ;; create the database. (define GDBM_READER (C-enum "GDBM_READER")) ;A reader. @@ -43,14 +66,15 @@ USA. (guarantee integer? block-size 'GDBM-OPEN) (guarantee integer? mode 'GDBM-OPEN) (let ((args (make-alien '|gdbm_args|)) - (flagsnum (guarantee-gdbm-open-flags flags))) + (flagsnum (guarantee-gdbm-open-flags flags)) + (filename (->namestring (merge-pathnames filename)))) (let ((gdbf (make-gdbf args (make-thread-mutex) filename))) (add-open-gdbf-cleanup gdbf) (with-gdbf-locked gdbf (lambda () (C-call "do_gdbm_open" - args (string->utf8 filename) block-size flagsnum mode) + args (->bytes filename) block-size flagsnum mode) (if (alien-null? args) (error "gdbm_open failed: malloc failed") (if (alien-null? (C-> args "gdbm_args dbf")) @@ -191,13 +215,11 @@ USA. (define (gdbm-strerror errno) (guarantee fixnum? errno 'GDBM-STRERROR) - (utf8->string - (c-peek-cstring (C-call "gdbm_strerror" (make-alien '(* char)) errno)))) + (c-peek-cstring (C-call "gdbm_strerror" (make-alien '(* char)) errno))) (define (strerror errno) (guarantee fixnum? errno 'STRERROR) - (utf8->string - (c-peek-cstring (C-call "strerror" (make-alien '(* char)) errno)))) + (c-peek-cstring (C-call "strerror" (make-alien '(* char)) errno))) ;; Parameters to gdbm_setopt, specifing the type of operation to perform. (define GDBM_CACHESIZE (C-enum "GDBM_CACHESIZE")) ;Set the cache size. @@ -229,8 +251,7 @@ USA. (gdbm-error gdbf "gdbm_setopt")))))) (define (gdbm-version) - (utf8->string - (c-peek-cstring (C-call "get_gdbm_version" (make-alien '(* char)))))) + (c-peek-cstring (C-call "get_gdbm_version" (make-alien '(* char))))) (define (guarantee-nonnull-string obj procedure) (guarantee string? obj procedure) @@ -276,44 +297,44 @@ USA. (strerror (C-> args "gdbm_args sys_errno"))))) (define (gdbf-args-put-key! args key) - (let ((bytevector (string->utf8 key))) - (let ((size (bytevector-length bytevector)) + (let ((bytes (->bytes key))) + (let ((size (bytes-length bytes)) (dptr (make-alien '(* char)))) (if (< size 1) (error "empty key:" key)) (C-call "alloc_gdbm_key" dptr args size) (if (alien-null? dptr) (error "gdbf-args-put-key!: malloc failed" key)) - (c-poke-bytes dptr 0 size bytevector 0)))) + (c-poke-bytes dptr 0 size bytes 0)))) (define (gdbf-args-put-content! args content) - (let ((bytevector (string->utf8 content))) - (let ((size (bytevector-length bytevector)) + (let ((bytes (->bytes content))) + (let ((size (bytes-length bytes)) (dptr (make-alien '(* char)))) (if (< size 1) (error "empty content:" content)) (C-call "alloc_gdbm_content" dptr args size) (if (alien-null? dptr) (error "gdbf-args-put-content!: malloc failed" size)) - (c-poke-bytes dptr 0 size bytevector 0)))) + (c-poke-bytes dptr 0 size bytes 0)))) (define (gdbf-args-get-key args) (let ((data (C-> args "gdbm_args key dptr"))) (if (alien-null? data) #f (let* ((size (C-> args "gdbm_args key dsize")) - (bytevector (make-bytevector size))) - (c-peek-bytes data 0 size bytevector 0) - (utf8->string bytevector))))) + (string ((ucode-primitive string-allocate 1) size))) + (c-peek-bytes data 0 size string 0) + string)))) (define (gdbf-args-get-content args) (let ((data (C-> args "gdbm_args content dptr"))) (if (alien-null? data) #f (let* ((size (C-> args "gdbm_args content dsize")) - (bytevector (make-bytevector size))) - (c-peek-bytes data 0 size bytevector 0) - (utf8->string bytevector))))) + (string ((ucode-primitive string-allocate 1) size))) + (c-peek-bytes data 0 size string 0) + string)))) (define open-gdbfs '()) (define open-gdbfs-mutex) diff --git a/src/mcrypt/NEWS b/src/mcrypt/NEWS index 555b40c43..02cd5c3b7 100644 --- a/src/mcrypt/NEWS +++ b/src/mcrypt/NEWS @@ -22,8 +22,18 @@ along with MIT/GNU Scheme; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. +mit-scheme-mcrypt 0.2 - Matt Birkholz, 2017-05-18 +================================================= + +Use byte vectors for binary data instead of strings. Thus all keys +and init vectors now must be byte vectors of the appropriate length +(per mcrypt-supported-key-sizes or mcrypt-init-vector-size +respectively). The input and output arguments to mcrypt-encrypt +should now be byte vectors, and the input and output arguments to +mcrypt-encrypt-port must now be binary ports. Other changes: mcrypt- +encrypt! and mcrypt-decrypt! were added. + mit-scheme-mcrypt 0.1 - Matt Birkholz, 2016-02-19 ================================================= -* Use libtool and automake, rather than the microcode's disappearing - module support. +Use libtool and automake. diff --git a/src/mcrypt/mcrypt.pkg b/src/mcrypt/mcrypt.pkg index dcea7690b..e3a5b9ebd 100644 --- a/src/mcrypt/mcrypt.pkg +++ b/src/mcrypt/mcrypt.pkg @@ -29,10 +29,6 @@ USA. (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 @@ -40,7 +36,9 @@ USA. mcrypt-block-algorithm? mcrypt-block-mode? mcrypt-context? + mcrypt-decrypt! mcrypt-encrypt + mcrypt-encrypt! mcrypt-encrypt-port mcrypt-end mcrypt-init diff --git a/src/mcrypt/mcrypt.scm b/src/mcrypt/mcrypt.scm index 5aae9cfd4..a8b659286 100644 --- a/src/mcrypt/mcrypt.scm +++ b/src/mcrypt/mcrypt.scm @@ -24,7 +24,7 @@ USA. |# -;;;; The MCRYPT option. +;;;; The mcrypt option. ;;; package: (mcrypt) (declare (usual-integrations)) @@ -130,9 +130,20 @@ USA. (define-structure mcrypt-context algorithm mode alien) -(define (guarantee-mcrypt-context object procedure) +(define (guarantee-mcrypt-context object caller) (if (not (mcrypt-context? object)) - (error:wrong-type-argument object "mcrypt context" procedure))) + (error:wrong-type-argument object "mcrypt context" caller)) + (if (alien-null? (mcrypt-context-alien object)) + (error:bad-range-argument object caller))) + +(define (guarantee-subbytevector object start end operator) + (guarantee bytevector? object operator) + (guarantee index-fixnum? start operator) + (guarantee index-fixnum? end operator) + (if (not (fix:<= start end)) + (error:bad-range-argument start operator)) + (if (not (fix:<= end (bytevector-length object))) + (error:bad-range-argument end operator))) (define (mcrypt-open-module algorithm mode) (init!) @@ -143,8 +154,7 @@ USA. (string->utf8 algorithm) 0 (string->utf8 mode) 0) (if (alien-null? alien) (error "Failed to open mcrypt module:" - (utf8->string - (C-peek-cstring (C-call "scmcrypt_get_ltdlerror"))))) + (C-peek-cstring (C-call "scmcrypt_get_ltdlerror")))) context)) (define (make-mcrypt-context-cleanup alien) @@ -160,31 +170,42 @@ USA. key (bytevector-length key) init-vector))) (if (< code 0) (error "Error code signalled by mcrypt_generic_init:" - (utf8->string - (C-peek-cstring (C-call "mcrypt_strerror" - (make-alien '(const (* char))) - code))))))) + (C-peek-cstring (C-call "mcrypt_strerror" + (make-alien '(const (* char))) + code)))))) + +(define-integrable (make-mcrypt-transform! name procedure) + (lambda (context bytes start end) + (guarantee-mcrypt-context context name) + (guarantee-subbytevector bytes start end name) + (let ((code (procedure context bytes start end))) + (if (< code 0) + (error (string "Error code signalled by "name":") code))))) + +(define mcrypt-encrypt! + (make-mcrypt-transform! + 'mcrypt-encrypt! + (named-lambda (mcrypt_generic context bytes start end) + (C-call "scmcrypt_generic" (mcrypt-context-alien context) + bytes start end)))) + +(define mcrypt-decrypt! + (make-mcrypt-transform! + 'mcrypt-decrypt! + (named-lambda (mdecrypt_generic context bytes start end) + (C-call "scmdecrypt_generic" (mcrypt-context-alien context) + bytes start end)))) (define (mcrypt-encrypt context input input-start input-end output output-start encrypt?) - (guarantee-mcrypt-context context 'MCRYPT-ENCRYPT) + (guarantee-mcrypt-context context 'mcrypt-encrypt) (guarantee bytevector? input 'mcrypt-encrypt) (guarantee bytevector? output 'mcrypt-encrypt) - (bytevector-copy! output output-start input input-start input-end) - (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)))) + ((if encrypt? mcrypt-encrypt! mcrypt-decrypt!) + context + output + output-start + (bytevector-copy! output output-start input input-start input-end))) (define (mcrypt-end context) (let ((alien (mcrypt-context-alien context))) @@ -199,59 +220,62 @@ USA. (lambda (object) (cond ((mcrypt-context? object) (context-op object)) - ((string? object) + ((bytevector? object) (init!) (module-op object)) + ((string? object) + (init!) + (module-op (string->utf8 object))) (else (error:wrong-type-argument object "mcrypt context" name))))) (define mcrypt-self-test (mcrypt-generic-unary - 'MCRYPT-SELF-TEST + '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" (string->utf8 module-name) 0)))) + (C-call "mcrypt_module_self_test" module-name 0)))) (define mcrypt-block-algorithm-mode? (mcrypt-generic-unary - 'MCRYPT-BLOCK-ALGORITHM-MODE? + '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" (string->utf8 name) 0)))) + (C-call "mcrypt_module_is_block_algorithm_mode" name 0)))) (define mcrypt-block-algorithm? (mcrypt-generic-unary - 'MCRYPT-BLOCK-ALGORITHM? + '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" (string->utf8 name) 0)))) + (C-call "mcrypt_module_is_block_algorithm" name 0)))) (define mcrypt-block-mode? (mcrypt-generic-unary - 'MCRYPT-BLOCK-MODE? + '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 name) - (C-call "mcrypt_module_is_block_mode" (string->utf8 name) 0)))) + (C-call "mcrypt_module_is_block_mode" name 0)))) (define mcrypt-key-size (mcrypt-generic-unary - 'MCRYPT-KEY-SIZE + '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" (string->utf8 name) 0)))) + (C-call "mcrypt_module_get_algo_key_size" name 0)))) (define mcrypt-supported-key-sizes (mcrypt-generic-unary - 'MCRYPT-SUPPORTED-KEY-SIZES + 'mcrypt-supported-key-sizes (named-lambda (mcrypt-enc-get-supported-key-sizes context) (let ((mlist (malloc (C-sizeof "struct mcrypt_list") '(struct |mcrypt_list|)))) @@ -262,48 +286,60 @@ USA. 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" - (string->utf8 name) 0 mlist) + (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) + (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) + (guarantee-mcrypt-context context 'mcrypt-algorithm-name) (mcrypt-context-algorithm context)) (define (mcrypt-mode-name context) - (guarantee-mcrypt-context context 'MCRYPT-MODE-NAME) + (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-bytevector 4096)) - (output-buffer (make-bytevector 4096))) - (mcrypt-init context key init-vector) + ((port-transformer (lambda () + (let ((context (mcrypt-open-module algorithm mode))) + (mcrypt-init context key init-vector) + context)) + (if encrypt? mcrypt-encrypt! mcrypt-decrypt!) + mcrypt-end) + input + output)) + +(define (port-transformer initialize update finalize) + (lambda (input-port output-port) + (call-with-buffer #x1000 + (lambda (buffer) + (let ((context (initialize))) + (let loop () + (let ((n (read-bytevector! buffer input-port))) + (if (and n (not (eof-object? n)) (fix:> n 0)) + (begin + (update context buffer 0 n) + (let ((n* (write-bytevector buffer output-port 0 n))) + (if (not (eqv? n n*)) + (error "Short write (requested, actual):" n n*))) + (loop))))) + (finalize context)))))) + +(define (call-with-buffer n procedure) + (let ((buffer (make-bytevector n))) (dynamic-wind - (lambda () - unspecific) - (lambda () - (let loop () - (let ((n (read-bytevector! input-buffer input))) - (if (and (not (eof-object? n)) - (not (= 0 n))) - (begin - (mcrypt-encrypt context input-buffer 0 n output-buffer 0 - encrypt?) - (write-bytevector output-buffer output 0 n) - (loop))))) - (mcrypt-end context)) - (lambda () - (bytevector-fill! input-buffer 0) - (bytevector-fill! output-buffer 0))))) + (lambda () + unspecific) + (lambda () + (procedure buffer)) + (lambda () + (bytevector-fill! buffer 0))))) ;;;; Mcrypt size lists. @@ -357,7 +393,7 @@ USA. (let loop ((i 0)) (if (< i size) (begin - (vector-set! vector i (utf8->string (C-peek-cstringp! elements))) + (vector-set! vector i (C-peek-cstringp! elements)) (loop (1+ i))))) vector))) diff --git a/src/md5/NEWS b/src/md5/NEWS index 0b26cc8ae..7e07103d5 100644 --- a/src/md5/NEWS +++ b/src/md5/NEWS @@ -22,8 +22,17 @@ 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-md5 0.2 - Matt Birkholz, 2017-05-18 +============================================== + +Use byte vectors for binary data instead of strings. Thus all digests +are now byte vectors. Other changes: md5-bytevector was added, +md5-string takes optional start and end indices, so md5-substring was +removed, and md5-sum->hexadecimal and md5-sum->number were removed. +The latter can be replaced by bytevector->hexadecimal and bytevector-> +exact-nonnegative-integer respectively. + mit-scheme-md5 0.1 - Matt Birkholz, 2016-02-19 ============================================== -* Use libtool and automake, rather than the microcode's disappearing - module support. +Use libtool and automake. diff --git a/src/md5/md5-check.scm b/src/md5/md5-check.scm index 73c611df9..cda8de0d9 100644 --- a/src/md5/md5-check.scm +++ b/src/md5/md5-check.scm @@ -27,11 +27,11 @@ USA. ;;;; Test the MD5 option. (let ((sample "Some text to hash.")) - (let ((hash (md5-sum->hexadecimal (md5-string sample)))) + (let ((hash (bytevector->hexadecimal (md5-string 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 (md5-sum->hexadecimal (md5-file "sample")))) + (let ((hash (bytevector->hexadecimal (md5-file "sample")))) (if (not (string=? hash "43EB9ECCB88C329721925EFC04843AF1")) (error "Bad hash for sample file:" hash)))) \ No newline at end of file diff --git a/src/md5/md5.pkg b/src/md5/md5.pkg index 4507658aa..ece7a2878 100644 --- a/src/md5/md5.pkg +++ b/src/md5/md5.pkg @@ -29,14 +29,10 @@ USA. (define-package (md5) (files "md5") (parent ()) - ;; You'll have to import these from (global-definitions md5/). They - ;; are currently bound in () by exports from (runtime crypto). (export (md5 global) + md5-bytevector md5-file - md5-string - md5-substring - md5-sum->hexadecimal - md5-sum->number)) + md5-string)) (define-package (md5 global) ;; Just to get cref to analyze whether all exports are defined. diff --git a/src/md5/md5.scm b/src/md5/md5.scm index e4a4ff6e3..abf60355c 100644 --- a/src/md5/md5.scm +++ b/src/md5/md5.scm @@ -31,53 +31,52 @@ USA. (C-include "md5") -(define-integrable (%md5-init) +(define (%md5-init) (let ((context (make-bytevector (C-sizeof "MD5_CTX")))) (C-call "MD5_INIT" context) context)) -(define-integrable (%md5-update context bytevector start end) +(define (%md5-update context bytevector start end) (C-call "do_MD5_UPDATE" context bytevector start end)) -(define-integrable (%md5-final context) +(define (%md5-final context) (let ((result (make-bytevector (C-enum "MD5_DIGEST_LENGTH")))) (C-call "do_MD5_FINAL" context result) result)) (define (md5-file filename) (call-with-binary-input-file filename - (lambda (port) - (let ((buffer (make-bytevector 4096)) - (context (%md5-init))) - (dynamic-wind (lambda () - unspecific) - (lambda () - (let loop () - (let ((n (read-bytevector! buffer port))) - (if (or (eof-object? n) - (fix:= 0 n)) - (%md5-final context) - (begin - (%md5-update context buffer 0 n) - (loop)))))) - (lambda () - (bytevector-fill! buffer 0))))))) - -(define (md5-string string) - (md5-bytevector (string->utf8 string))) - -(define (md5-substring string start end) - (md5-bytevector (string->utf8 (substring string start end)))) - -(define (md5-bytevector bytevector) - (let ((context (%md5-init))) - (%md5-update context bytevector 0 (bytevector-length bytevector)) - (%md5-final context))) + (port-consumer %md5-init %md5-update %md5-final))) + +(define (md5-string string #!optional start end) + (md5-bytevector (string->utf8 string start end))) -(define (md5-sum->number sum) - (let ((l (bytevector-length sum))) - (do ((i 0 (fix:+ i 1)) - (n 0 (+ (* n #x100) (bytevector-u8-ref sum i)))) - ((fix:= i l) n)))) +(define (md5-bytevector bytes #!optional start end) + (let ((end (fix:end-index end (bytevector-length bytes) 'md5-bytevector)) + (start (fix:start-index start end 'md5-bytevector)) + (context (%md5-init))) + (%md5-update context bytes start end) + (%md5-final context))) -(define md5-sum->hexadecimal bytevector->hexadecimal) \ No newline at end of file +(define (port-consumer initialize update finalize) + (lambda (port) + (call-with-buffer #x1000 + (lambda (buffer) + (let ((context (initialize))) + (let loop () + (let ((n (read-bytevector! buffer port))) + (if (and n (not (eof-object? n))) + (begin + (update context buffer 0 n) + (loop))))) + (finalize context)))))) + +(define (call-with-buffer n procedure) + (let ((buffer (make-bytevector n))) + (dynamic-wind + (lambda () + unspecific) + (lambda () + (procedure buffer)) + (lambda () + (bytevector-fill! buffer 0))))) \ No newline at end of file diff --git a/src/mhash/NEWS b/src/mhash/NEWS index 46c7402d3..3af0d8574 100644 --- a/src/mhash/NEWS +++ b/src/mhash/NEWS @@ -22,8 +22,18 @@ 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-mhash 0.2 - Matt Birkholz, 2017-05-18 +================================================ + +Use byte vectors for binary data instead of strings. Thus all digests +and salts now must be byte vectors; the -update procedures must be fed +byte subvectors, not substrings. Other changes: mhash-bytevector was +added, mhash-string takes optional start and end indices, so mhash- +substring was removed, and mhash-sum->hexadecimal and mhash-sum-> +number were removed. The latter can be replaced by bytevector-> +hexadecimal and bytevector->exact-nonnegative-integer respectively. + mit-scheme-mhash 0.1 - Matt Birkholz, 2016-02-19 ================================================ -* Use libtool and automake, rather than the microcode's disappearing - module support. +Use libtool and automake. diff --git a/src/mhash/mhash-check.scm b/src/mhash/mhash-check.scm index 51d0b7ff0..fc73c6e61 100644 --- a/src/mhash/mhash-check.scm +++ b/src/mhash/mhash-check.scm @@ -27,11 +27,11 @@ USA. ;;;; Test the MHASH option. (let ((sample "Some text to hash.")) - (let ((hash (mhash-sum->hexadecimal (mhash-string 'MD5 sample)))) + (let ((hash (bytevector->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")))) + (let ((hash (bytevector->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.pkg b/src/mhash/mhash.pkg index 1da5b316b..5264c21c9 100644 --- a/src/mhash/mhash.pkg +++ b/src/mhash/mhash.pkg @@ -30,10 +30,9 @@ USA. (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 (mhash global) make-mhash-keygen-type + mhash-bytevector mhash-context? mhash-end mhash-file @@ -51,9 +50,6 @@ USA. mhash-keygen-uses-hash-algorithm mhash-keygen-uses-salt? mhash-string - mhash-substring - mhash-sum->hexadecimal - mhash-sum->number mhash-type-names mhash-update)) diff --git a/src/mhash/mhash.scm b/src/mhash/mhash.scm index 8be528ee8..c618699a5 100644 --- a/src/mhash/mhash.scm +++ b/src/mhash/mhash.scm @@ -24,7 +24,7 @@ USA. |# -;;;; The MHASH option. +;;;; The mhash option. ;;; package: (mhash) (declare (usual-integrations)) @@ -132,17 +132,17 @@ USA. (define-structure mhash-context mutex alien id) (define-structure mhash-hmac-context mutex alien id) -(define (guarantee-mhash-context object procedure) +(define (guarantee-mhash-context object caller) (if (not (mhash-context? object)) - (error:wrong-type-argument object "mhash context" procedure)) + (error:wrong-type-argument object "mhash context" caller)) (if (alien-null? (mhash-context-alien object)) - (error:bad-range-argument object procedure))) + (error:bad-range-argument object caller))) -(define (guarantee-mhash-hmac-context object procedure) +(define (guarantee-mhash-hmac-context object caller) (if (not (mhash-hmac-context? object)) - (error:wrong-type-argument object "mhash HMAC context" procedure)) + (error:wrong-type-argument object "mhash HMAC context" caller)) (if (alien-null? (mhash-hmac-context-alien object)) - (error:bad-range-argument object procedure))) + (error:bad-range-argument object caller))) (define (guarantee-subbytevector object start end operator) (guarantee bytevector? object operator) @@ -180,10 +180,10 @@ USA. (define (mhash-get-block-size name) (C-call "mhash_get_block_size" - (mhash-name->id name 'MHASH-GET-BLOCK-SIZE))) + (mhash-name->id name 'mhash-get-block-size))) (define (mhash-init name) - (let ((id (mhash-name->id name 'MHASH-INIT)) + (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) @@ -194,14 +194,14 @@ USA. (error "Unable to allocate mhash context:" name)))) context))) -(define (mhash-update context bytevector start end) - (guarantee-subbytevector bytevector start end 'MHASH-UPDATE) - (with-context-locked-open context 'MHASH-UPDATE +(define (mhash-update context bytes start end) + (guarantee-subbytevector bytes start end 'mhash-update) + (with-context-locked-open context 'mhash-update (lambda (alien) - (C-call "do_mhash" alien bytevector start end)))) + (C-call "do_mhash" alien bytes start end)))) (define (mhash-end context) - (with-context-locked-open context 'MHASH-END + (with-context-locked-open context 'mhash-end (lambda (alien) (let* ((id (mhash-context-id context)) (size (C-call "mhash_get_block_size" id)) @@ -211,12 +211,13 @@ USA. digest)))) (define (mhash-hmac-init name key) - (guarantee bytevector? key 'hmash-hmac-init) - (let ((id (mhash-name->id name 'MHASH-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 (bytevector-length key))) + (key-size (if (bytevector? key) + (bytevector-length key) + (string-length key)))) (add-hmac-context-cleanup context) (with-hmac-context-locked context (lambda () @@ -225,14 +226,15 @@ USA. (error "Unable to allocate mhash HMAC context:" name)))) context))) -(define (mhash-hmac-update context bytevector start end) - (guarantee-subbytevector bytevector start end 'MHASH-HMAC-UPDATE) - (with-hmac-context-locked-open context 'MHASH-HMAC-UPDATE +(define (mhash-hmac-update context bytes start end) + (guarantee-mhash-hmac-context context 'mhash-hmac-update) + (guarantee-subbytevector bytes start end 'mhash-hmac-update) + (with-hmac-context-locked-open context 'mhash-hmac-update (lambda (alien) - (C-call "do_mhash" alien bytevector start end)))) + (C-call "do_mhash" alien bytes start end)))) (define (mhash-hmac-end context) - (with-hmac-context-locked-open context 'MHASH-HMAC-END + (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)) @@ -243,10 +245,10 @@ USA. (define mhash-keygen-names) -(define (keygen-name->id name procedure) +(define (keygen-name->id name caller) (let ((n (vector-length mhash-keygen-names))) (let loop ((i 0)) - (cond ((fix:= i n) (error:bad-range-argument name procedure)) + (cond ((fix:= i n) (error:bad-range-argument name caller)) ((eq? name (vector-ref mhash-keygen-names i)) i) (else (loop (fix:+ i 1))))))) @@ -255,28 +257,27 @@ USA. (define (mhash-keygen-uses-salt? name) (not (zero? (C-call "mhash_keygen_uses_salt" - (keygen-name->id name '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?))))) + (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))) + (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))) + (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))) + (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)) + (error:wrong-type-argument type "mhash type" 'mhash-keygen)) (let ((keygenid (mhash-keygen-type-id type)) (keyword-size (mhash-keygen-type-key-length type)) (passbytes (string->utf8 passphrase))) @@ -289,7 +290,7 @@ USA. (let ((name (vector-ref params i))) (if (not name) 0 - (mhash-name->id name 'MHASH-KEYGEN)))) + (mhash-name->id name 'mhash-keygen)))) (if (not (or (zero? max-key-size) (< max-key-size (bytevector-length keyword)))) @@ -330,15 +331,13 @@ USA. (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)) + (guarantee index-fixnum? key-length 'make-mhash-keygen-type) (if (not (let ((m (mhash-keygen-max-key-size name))) (or (= m 0) (<= key-length m)))) - (error:bad-range-argument key-length 'MAKE-MHASH-KEYGEN-TYPE)) + (error:bad-range-argument key-length 'make-mhash-keygen-type)) (%make-mhash-keygen-type - (keygen-name->id name '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 @@ -360,13 +359,13 @@ USA. (error "Iteration count required:" name)) (if (not (and (exact-integer? count) (positive? count))) - (error:bad-range-argument count 'MAKE-MHASH-KEYGEN-TYPE)) + (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))) + (mhash-name->id (car names) 'make-mhash-keygen-type))) v))))) (define (initialize-mhash-variables!) @@ -379,10 +378,10 @@ USA. (lambda (alien) (C-call "mhash_get_hash_name" alien hashid)))) - (bytevector (and (not (alien-null? alien)) - (c-peek-cstring alien)))) + (string (and (not (alien-null? alien)) + (c-peek-cstring alien)))) (free alien) - bytevector)))) + string)))) (set! mhash-keygen-names (make-names-vector (lambda () (C-call "mhash_keygen_count")) @@ -392,10 +391,10 @@ USA. (lambda (alien) (C-call "mhash_get_keygen_name" alien keygenid)))) - (bytevector (and (not (alien-null? alien)) - (c-peek-cstring alien)))) + (string (and (not (alien-null? alien)) + (c-peek-cstring alien)))) (free alien) - bytevector))))) + string))))) (define (reset-mhash-variables!) (for-each (lambda (weak) (alien-null! (weak-cdr weak))) mhash-contexts) @@ -407,41 +406,42 @@ USA. (define (mhash-file hash-type filename) (call-with-binary-input-file filename - (lambda (port) - (let ((buffer (make-bytevector 4096)) - (context (mhash-init hash-type))) - (dynamic-wind (lambda () - unspecific) - (lambda () - (let loop () - (let ((n (read-bytevector! buffer port))) - (if (or (eof-object? n) - (fix:= 0 n)) - (mhash-end context) - (begin - (mhash-update context buffer 0 n) - (loop)))))) - (lambda () - (bytevector-fill! buffer 0))))))) - -(define (mhash-string hash-type string) - (mhash-bytevector hash-type (string->utf8 string))) - -(define (mhash-substring hash-type string start end) - (mhash-bytevector hash-type (string->utf8 (substring string start end)))) - -(define (mhash-bytevector hash-type bytevector) - (let ((context (mhash-init hash-type))) - (mhash-update context bytevector 0 (bytevector-length bytevector)) + (port-consumer (lambda () (mhash-init hash-type)) + mhash-update + mhash-end))) + +(define (mhash-string hash-type string #!optional start end) + (mhash-bytevector hash-type (string->utf8 string start end))) + +(define (mhash-bytevector hash-type bytes #!optional start end) + (let* ((end (fix:end-index end (bytevector-length bytes) 'mhash-bytevector)) + (start (fix:start-index start end 'mhash-bytevector)) + (context (mhash-init hash-type))) + (mhash-update context bytes start end) (mhash-end context))) -(define (mhash-sum->number sum) - (let ((l (bytevector-length sum))) - (do ((i 0 (fix:+ i 1)) - (n 0 (+ (* n #x100) (bytevector-u8-ref sum i)))) - ((fix:= i l) n)))) - -(define mhash-sum->hexadecimal bytevector->hexadecimal) +(define (port-consumer initialize update finalize) + (lambda (port) + (call-with-buffer #x1000 + (lambda (buffer) + (let ((context (initialize))) + (let loop () + (let ((n (read-bytevector! buffer port))) + (if (and n (not (eof-object? n))) + (begin + (update context buffer 0 n) + (loop))))) + (finalize context)))))) + +(define (call-with-buffer n procedure) + (let ((buffer (make-bytevector n))) + (dynamic-wind + (lambda () + unspecific) + (lambda () + (procedure buffer)) + (lambda () + (bytevector-fill! buffer 0))))) ;;;; Package initialization @@ -459,7 +459,7 @@ USA. (vector-set! v i (let ((name (get-name i))) (and name - (intern (utf8->string name)))))) + (intern name))))) v))) (define (names-vector->list v) -- 2.25.1