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.
(lambda (output)
(blowfish-encrypt-port (open-input-bytevector sample)
output
- "secret"
+ (string->utf8 "secret")
(write-blowfish-file-header output)
#t)))
(let ((read-back
(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))
|#
-;;;; The BLOWFISH option.
+;;;; Interface to Blowfish
;;; package: (blowfish)
(declare (usual-integrations))
\f
(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?)
;; 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?)
;; 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)
(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.
;; 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)
(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)))
(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)
#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
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.
(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
|#
-;;;; The GDBM option.
+;;;; The GDBM2 option.
;;; package: (gdbm)
(declare (usual-integrations))
\f
(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.
(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"))
(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.
(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)
(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)
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.
(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-block-algorithm?
mcrypt-block-mode?
mcrypt-context?
+ mcrypt-decrypt!
mcrypt-encrypt
+ mcrypt-encrypt!
mcrypt-encrypt-port
mcrypt-end
mcrypt-init
|#
-;;;; The MCRYPT option.
+;;;; The mcrypt option.
;;; package: (mcrypt)
(declare (usual-integrations))
\f
(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!)
(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)
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)))
(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))))
\f
(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|))))
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)))))
\f
;;;; Mcrypt size lists.
(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)))
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.
;;;; 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
(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.
\f
(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
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.
;;;; 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
(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
mhash-keygen-uses-hash-algorithm
mhash-keygen-uses-salt?
mhash-string
- mhash-substring
- mhash-sum->hexadecimal
- mhash-sum->number
mhash-type-names
mhash-update))
|#
-;;;; The MHASH option.
+;;;; The mhash option.
;;; package: (mhash)
(declare (usual-integrations))
(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)
(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)
(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))
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 ()
(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))
\f
(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)))))))
(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)))
(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))))
(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
(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)))))
\f
(define (initialize-mhash-variables!)
(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"))
(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)
(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)))))
\f
;;;; Package initialization
(vector-set! v i
(let ((name (get-name i)))
(and name
- (intern (utf8->string name))))))
+ (intern name)))))
v)))
(define (names-vector->list v)
projects / mit-scheme.git / commitdiff