From 477513f4c8db89f4586d39d94af7fd8750dcb503 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 10 Apr 2000 03:32:32 +0000 Subject: [PATCH] Initial revision. --- v7/src/runtime/crypto.scm | 237 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 237 insertions(+) create mode 100644 v7/src/runtime/crypto.scm diff --git a/v7/src/runtime/crypto.scm b/v7/src/runtime/crypto.scm new file mode 100644 index 000000000..46649947a --- /dev/null +++ b/v7/src/runtime/crypto.scm @@ -0,0 +1,237 @@ +#| -*-Scheme-*- + +$Id: crypto.scm,v 14.1 2000/04/10 03:32:32 cph Exp $ + +Copyright (c) 2000 Massachusetts Institute of Technology + +This program 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. + +This program 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 this program; if not, write to the Free Software +Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +|# + +;;;; Interface to cryptography libraries +;;; package: () + +(declare (usual-integrations)) + +;;;; The mhash library + +(define mhash-types) +(define mhash-get-block-size) +(define mhash-init) +(define mhash-hmac-init) +(let ((%mhash-count (ucode-primitive mhash_count 0)) + (%mhash-get-block-size (ucode-primitive mhash_get_block_size 1)) + (%mhash-get-hash-name (ucode-primitive mhash_get_hash_name 1)) + (%mhash-get-hash-pblock (ucode-primitive mhash_get_hash_pblock 1)) + (%mhash-init (ucode-primitive mhash_init 1)) + (%mhash-hmac-init (ucode-primitive mhash_hmac_init 3))) + (let* ((names #f) + (guarantee-names + (lambda () + (if (not names) + (let ((n (%mhash-count))) + (let ((v (make-vector n))) + (do ((i 0 (fix:+ i 1))) + ((fix:= i n)) + (vector-set! + v i (intern (%mhash-get-hash-name i)))) + (set! names v)))))) + (hash-name->id + (lambda (name procedure) + (guarantee-names) + (let ((n (vector-length names))) + (let loop ((i 0)) + (if (fix:< i n) + (if (eq? name (vector-ref names i)) + i + (loop (fix:+ i 1))) + (error:bad-range-argument name procedure))))))) + (set! mhash-types + (lambda () + (guarantee-names) + (vector->list names))) + (set! mhash-get-block-size + (lambda (name) + (%mhash-get-block-size + (hash-name->id name 'MHASH-GET-BLOCK-SIZE)))) + (set! mhash-init + (lambda (name) + (%mhash-init (hash-name->id name 'MHASH-INIT)))) + (set! mhash-hmac-init + (lambda (name key) + (let ((id (hash-name->id name 'MHASH-INIT))) + (%mhash-hmac-init id key (%mhash-get-hash-pblock id))))))) + +(define mhash-update (ucode-primitive mhash 4)) +(define mhash-end (ucode-primitive mhash_end 1)) +(define mhash-hmac-end (ucode-primitive mhash_hmac_end 1)) + +(define mhash-keygen-types) +(define mhash-keygen-uses-salt?) +(define mhash-keygen-uses-count?) +(define mhash-keygen-uses-hash-algorithm) +(define mhash-keygen-salt-size) +(define mhash-keygen-max-key-size) +(define mhash-keygen) +(let ((%mhash-keygen-count (ucode-primitive mhash_keygen_count 0)) + (%mhash-get-keygen-name (ucode-primitive mhash_get_keygen_name 1)) + (%mhash-keygen-uses-salt (ucode-primitive mhash_keygen_uses_salt 1)) + (%mhash-keygen-uses-count (ucode-primitive mhash_keygen_uses_count 1)) + (%mhash-keygen-uses-hash-algorithm + (ucode-primitive mhash_keygen_uses_hash_algorithm 1)) + (%mhash-get-keygen-salt-size + (ucode-primitive mhash_get_keygen_salt_size 1)) + (%mhash-get-keygen-max-key-size + (ucode-primitive mhash_get_keygen_max_key_size 1)) + (%mhash-keygen (ucode-primitive mhash_keygen 4))) + (let* ((names #f) + (guarantee-names + (lambda () + (if (not names) + (let ((n (%mhash-keygen-count))) + (let ((v (make-vector n))) + (do ((i 0 (fix:+ i 1))) + ((fix:= i n)) + (vector-set! + v i (intern (%mhash-get-keygen-name i)))) + (set! names v)))))) + (keygen-name->id + (lambda (name procedure) + (guarantee-names) + (let ((n (vector-length names))) + (let loop ((i 0)) + (if (fix:< i n) + (if (eq? name (vector-ref names i)) + i + (loop (fix:+ i 1))) + (error:bad-range-argument name procedure))))))) + (set! mhash-keygen-types + (lambda () + (guarantee-names) + (vector->list names))) + (set! mhash-keygen-uses-salt? + (lambda (name) + (%mhash-keygen-uses-salt + (keygen-name->id name 'MHASH-KEYGEN-USES-SALT?)))) + (set! mhash-keygen-uses-count? + (lambda (name) + (%mhash-keygen-uses-count + (keygen-name->id name 'MHASH-KEYGEN-USES-COUNT?)))) + (set! mhash-keygen-uses-hash-algorithm + (lambda (name) + (%mhash-keygen-uses-hash-algorithm + (keygen-name->id name 'MHASH-KEYGEN-USES-HASH-ALGORITHM)))) + (set! mhash-keygen-salt-size + (lambda (name) + (%mhash-get-keygen-salt-size + (keygen-name->id name 'MHASH-KEYGEN-SALT-SIZE)))) + (set! mhash-keygen-max-key-size + (lambda (name) + (%mhash-get-keygen-max-key-size + (keygen-name->id name 'MHASH-KEYGEN-MAX-KEY-SIZE)))) + (set! mhash-keygen + (lambda (name parameters keyword passphrase) + (%mhash-keygen (keygen-name->id name 'MHASH-KEYGEN) + parameters + keyword + passphrase))))) + +(define (mhash-available?) + (implemented-primitive-procedure? mhash-update)) + +(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))) + +;;;; MD5 + +(define (md5-available?) + (or (mhash-available?) + (implemented-primitive-procedure? (ucode-primitive md5-init 0)))) + +(define (md5-file filename) + (if (mhash-available?) + (mhash-file 'MD5 filename) + (call-with-binary-input-file filename + (lambda (port) + (let ((buffer (make-string 4096)) + (context ((ucode-primitive md5-init 0)))) + (dynamic-wind (lambda () + unspecific) + (lambda () + (let loop () + (let ((n (read-substring! buffer 0 4096 port))) + (if (fix:= 0 n) + ((ucode-primitive md5-final 1) context) + (begin + ((ucode-primitive md5-update 4) + context buffer 0 n) + (loop)))))) + (lambda () + (string-fill! buffer #\NUL)))))))) + +(define (md5-string string) + (md5-substring string 0 (string-length string))) + +(define (md5-substring string start end) + (if (mhash-available?) + (mhash-substring 'MD5 string start end) + (let ((context ((ucode-primitive md5-init 0)))) + ((ucode-primitive md5-update 4) context string start end) + ((ucode-primitive md5-final 1) context)))) + +(define md5-sum->number mhash-sum->number) +(define md5-sum->hexadecimal mhash-sum->hexadecimal) \ No newline at end of file -- 2.25.1