suzanne.soy/compatibility
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Jepri's changes so that md5 works on ports

Browse Source 
svn: r2194

original commit: a59d668f6dab454494f1daaa0d2b86a5f6f2dee9
This commit is contained in:
Matthew Flatt 2006-02-11 05:35:35 +00:00
parent b3cfb53900
commit b414a65b0e
1 changed files with 485 additions and 419 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

302
collects/mzlib/md5.ss
View File

@ -1,104 +1,113 @@
(module md5 mzscheme (module md5 mzscheme
(provide md5) (provide md5)
;;; -*- mode: scheme; mode: font-lock -*- ;;; -*- mode: scheme; mode: font-lock -*-
;;; ;;;
;;; Copyright (c) 2002, Jens Axel Søgaard ;;; Copyright (c) 2002, Jens Axel Søgaard
;;; ;;;
;;; Permission to copy this software, in whole or in part, to use this ;;; Permission to copy this software, in whole or in part, to use this
;;; software for any lawful purpose, and to redistribute this software ;;; software for any lawful purpose, and to redistribute this software
;;; is hereby granted. ;;; is hereby granted.
;;; ;;;
;;; md5.scm -- Jens Axel Søgaard, 16 oct 2002 ;;; md5.scm -- Jens Axel Søgaard, 16 oct 2002
;;; History ;;; History
; 14-10-2002 /jas ; 14-10-2002 /jas
; - Bored. Initial attempt. Done. Well, except for faulty output. ; - Bored. Initial attempt. Done. Well, except for faulty output.
; 15-10-2002 /jas ; 15-10-2002 /jas
; - It works at last ; - It works at last
; 16-10-2002 /jas ; 16-10-2002 /jas
; - Added R5RS support ; - Added R5RS support
; 16-02-2003 / lth ; 16-02-2003 / lth
; - Removed let-values implementation because Larceny has it already ; - Removed let-values implementation because Larceny has it already
; - Implemented Larceny versions of many bit primitives (note, 0.52 ; - Implemented Larceny versions of many bit primitives (note, 0.52
; or later required due to bignum bug) ; or later required due to bignum bug)
; - Removed most 'personal idiosyncrasies' to give the compiler a fair ; - Removed most 'personal idiosyncrasies' to give the compiler a fair
; chance to inline primitives and improve performance some. ; chance to inline primitives and improve performance some.
; Performance in the interpreter is still really quite awful. ; Performance in the interpreter is still really quite awful.
; - Wrapped entire procedure in a big LET to protect the namespace ; - Wrapped entire procedure in a big LET to protect the namespace
; - Some cleanup of repeated computations ; - Some cleanup of repeated computations
; - Moved test code to separate file ; - Moved test code to separate file
; 17-02-2003 / lth ; 17-02-2003 / lth
; - Removed some of the indirection, for a 30% speedup in Larceny's ; - Removed some of the indirection, for a 30% speedup in Larceny's
; interpreter. Running in the interpreter on my Dell Inspiron 4000 ; interpreter. Running in the interpreter on my Dell Inspiron 4000
; I get a fingerprint of "Lib/Common/bignums-be.sch" in about 63ms, ; I get a fingerprint of "Lib/Common/bignums-be.sch" in about 63ms,
; which is slow but adequate. (The compiled version is not much ; which is slow but adequate. (The compiled version is not much
; faster -- most time is spent in bignum manipulation, which is ; faster -- most time is spent in bignum manipulation, which is
; compiled in either case. To do this well we must either operate ; compiled in either case. To do this well we must either operate
; on the bignum representation or redo the algorithm to use ; on the bignum representation or redo the algorithm to use
; fixnums only.) ; fixnums only.)
; 01-12-2003 / lth ; 01-12-2003 / lth
; - Reimplemented word arithmetic to use two 16-bit fixnums boxed in ; - Reimplemented word arithmetic to use two 16-bit fixnums boxed in
; a cons cell. In Petit Larceny's interpreter this gives a speedup ; a cons cell. In Petit Larceny's interpreter this gives a speedup
; of a factor of almost eight, and in addition this change translates ; of a factor of almost eight, and in addition this change translates
; well to other Scheme systems that support bit operations on fixnums. ; well to other Scheme systems that support bit operations on fixnums.
; Only 17-bit (signed) fixnums are required. ; Only 17-bit (signed) fixnums are required.
; 23-12-2003 / jas ; 23-12-2003 / jas
; - Trivial port to PLT. Rewrote the word macro to syntax-rules. ; - Trivial port to PLT. Rewrote the word macro to syntax-rules.
; Larceny primitives written as syntax-rules macros exanding ; Larceny primitives written as syntax-rules macros exanding
; to their PLT name. ; to their PLT name.
; 5-5-2005 / Greg Pettyjohn ; 5-5-2005 / Greg Pettyjohn
; - It was failing for strings of length 56 bytes i.e. when the length ; - It was failing for strings of length 56 bytes i.e. when the length
; in bits was congruent 448 modulo 512. Changed step 1 to fix this. ; in bits was congruent 448 modulo 512. Changed step 1 to fix this.
; According to RFC 1321, the message should still be padded in this ; According to RFC 1321, the message should still be padded in this
; case. ; case.
; 23-12-2005 / Jepri
; - Mucked around with the insides to get it to read from a port
; - Now it accepts a port or a string as input
; - Doesn't explode when handed large strings anymore
; - Now much slower
; 2-10-2006 / Matthew
; - Cleaned up a little
; - Despite comment above, it seems consistently faster
;;; Summary
; This is an implementation of the md5 message-digest algorithm
; in R5RS Scheme. The algorithm takes an arbitrary string and
; returns a 128-bit "fingerprint".
; The algorithm was invented by Ron Rivest, RSA Security, INC.
; Reference: RFC 1321, <http://www.faqs.org/rfcs/rfc1321.html>
;;; Summary ;;; Contact
; This is an implementation of the md5 message-digest algorithm ; Email jensaxel@soegaard.net if you have problems,
; in R5RS Scheme. The algorithm takes an arbitrary string and ; suggestions, code for 32 bit arithmetic for your
; returns a 128-bit "fingerprint". ; favorite implementation.
; The algorithm was invented by Ron Rivest, RSA Security, INC. ; Check <http://www.scheme.dk/md5/> for new versions.
; Reference: RFC 1321, <http://www.faqs.org/rfcs/rfc1321.html>
;;; Contact ;;; Technicalities
; Email jensaxel@soegaard.net if you have problems, ; The algorithm is designed to be efficiently implemented
; suggestions, code for 32 bit arithmetic for your ; using 32 bit arithmetic. If your implementation supports
; favorite implementation. ; 32 bit arithmetic directly, you should substitute the
; Check <http://www.scheme.dk/md5/> for new versions. ; portable 32 operations with primitives of your implementation.
; See the PLT version below for an example.
;;; Technicalities ;;; Word aritmetic (32 bit)
; The algorithm is designed to be efficiently implemented ; Terminology
; using 32 bit arithmetic. If your implementation supports ; word: 32 bit unsigned integer
; 32 bit arithmetic directly, you should substitute the ; byte: 8 bit unsigned integer
; portable 32 operations with primitives of your implementation.
; See the PLT version below for an example.
;;; Word aritmetic (32 bit) (define md5 'undefined)
; Terminology
; word: 32 bit unsigned integer
; byte: 8 bit unsigned integer
(define md5 'undefined) ; (word c) turns into a quoted pair '(hi . lo). I would have this local to the
; let below except Twobit does not allow transformer to be used with let-syntax,
; only with define-syntax.
; (word c) turns into a quoted pair '(hi . lo). I would have this local to the ;(define-syntax word
; let below except Twobit does not allow transformer to be used with let-syntax, ; (transformer
; only with define-syntax. ; (lambda (expr rename compare)
; (list 'quote (cons (quotient (cadr expr) 65536) (remainder (cadr expr) 65536))))))
;(define-syntax word (define-syntax word
; (transformer
; (lambda (expr rename compare)
; (list 'quote (cons (quotient (cadr expr) 65536) (remainder (cadr expr) 65536))))))
(define-syntax word
(syntax-rules () (syntax-rules ()
[(word c) [(word c)
(cons (quotient c 65536) (remainder c 65536))])) (cons (quotient c 65536) (remainder c 65536))]))
(let ()
(let ()
;;; PORTING NOTES ;;; PORTING NOTES
@ -226,39 +235,88 @@
;; string->bytes : string -> (list byte) ;; string->bytes : string -> (list byte)
(define (string->bytes s) (define (string->bytes s)
(bytes->list s)) (bytes->list s))
;; Converts a list of words to a vector, just like vector-from-string
;; vector-from-list: byte-string -> (vector ...)
(define vector-from-list list->vector)
;; Converts a byte string to a more useful vector
;; vector-from-string: byte string -> (vector ...)
(define vector-from-string
(lambda (l-raw)
(list->vector (bytes->words (string->bytes l-raw)))))
(define empty-port (open-input-bytes #""))
;; List Helper ;; List Helper
;; block/list : list -> (values vector list) ;; block/list : a-port done-n -> (values vector a-port done-n)
;; return a vector of the first 16 elements of the list, ;; reads 512 bytes from the port, turns them into a vector of 16 32-bit words
;; and the rest of the list ;; when the port is exhausted it returns #f for the port and
(define (block/list l) ;; the last few bytes padded
(let* (( v0 (car l)) ( l0 (cdr l))
( v1 (car l0)) ( l1 (cdr l0)) (define (block/list a-port done)
( v2 (car l1)) ( l2 (cdr l1)) (let* ((l-raw (read-bytes (/ 512 8) a-port)))
( v3 (car l2)) ( l3 (cdr l2)) (cond
( v4 (car l3)) ( l4 (cdr l3)) ;; File size was a multiple of 512 bits, or we're doing one more round to
( v5 (car l4)) ( l5 (cdr l4)) ;; add the correct padding from the short case
( v6 (car l5)) ( l6 (cdr l5)) ((eof-object? l-raw)
( v7 (car l6)) ( l7 (cdr l6)) (if (zero? (modulo done (/ 512 8)))
( v8 (car l7)) ( l8 (cdr l7)) ;; The file is a multiple of 512 or was 0, so there hasn't been a
( v9 (car l8)) ( l9 (cdr l8)) ;; chance to add the 1-bit pad, so we need to do a full pad
(v10 (car l9)) (l10 (cdr l9)) (values (vector-from-list (step2 (* 8 done)
(v11 (car l10)) (l11 (cdr l10)) (step1 (string->bytes #""))))
(v12 (car l11)) (l12 (cdr l11)) #f
(v13 (car l12)) (l13 (cdr l12)) done)
(v14 (car l13)) (l14 (cdr l13)) ;; We only enter this block when the previous block didn't have
(v15 (car l14)) (l15 (cdr l14))) ;; enough room to fit the 64-bit file length,
(values (vector v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 v13 v14 v15) ;; so we just add 448 bits of zeros and then the 64-bit file length (step2)
l15))) (values (vector-from-list (step2 (* 8 done)
(vector->list (make-vector (quotient 448 8) 0))))
#f
done)))
;; We read exactly 512 bits, the algorythm proceeds as usual
((= (bytes-length l-raw) (/ 512 8))
(values (vector-from-string l-raw) a-port (+ done (bytes-length l-raw))))
;; We read less than 512 bits, so the file has ended.
;; However, we don't have enough room to add the correct trailer,
;; so we add what we can, then go for one more round which will
;; automatically fall into the (eof-object? case)
((> (* 8 (bytes-length l-raw)) 446)
(let ([done (+ done (bytes-length l-raw))])
(values (vector-from-list (step2 (* 8 done)
(step1 (string->bytes l-raw))))
empty-port
done)))
;; Returning a longer vector than we should, luckily it doesn't matter.
;; We read less than 512 bits and there is enough room for the correct trailer.
;; Add trailer and bail
(else
(let ([done (+ done (bytes-length l-raw))])
(values (vector-from-list (step2 (* 8 done)
(step1 (string->bytes l-raw))))
#f
done))))))
;(step2 (* 8 (bytes-length str))
; (step1 (string->bytes str)))
;; MD5 ;; MD5
;; The algorithm consists of five steps. ;; The algorithm consists of five steps.
;; All we need to do, is to call them in order. ;; All we need to do, is to call them in order.
;; md5 : string -> string ;; md5 : string -> string
(define (md5-computation str) (define (md5-computation a-thing)
(step5 (step4 (step2 (* 8 (bytes-length str)) (let ((a-port (cond
(step1 (string->bytes str)))))) [(bytes? a-thing)
(open-input-bytes a-thing)]
[(input-port? a-thing)
a-thing]
[else
(raise-type-error 'md5
"input-port or bytes"
a-thing)])))
(step5 (step4 a-port))))
;; Step 1 - Append Padding Bits ;; Step 1 - Append Padding Bits
;; The message is padded so the length (in bits) becomes 448 modulo 512. ;; The message is padded so the length (in bits) becomes 448 modulo 512.
@ -304,14 +362,20 @@
;; For each 16 word block, go through a round one to four. ;; For each 16 word block, go through a round one to four.
;; step4 : (list word) -> "(list word word word word)" ;; step4 : (list word) -> "(list word word word word)"
(define (step4 message) (define (step4 a-port)
(define (loop A B C D a-port done)
(define (loop A B C D message) (if (not a-port)
(if (null? message)
(list A B C D) (list A B C D)
(let-values (((X rest) (block/list message))) (let-values (((X b-port done) (block/list a-port done)))
(let* ((AA A) (BB B) (CC C) (DD D) (if (not X)
(list A B C D)
(begin
(let* ((AA A)
(BB B)
(CC C)
(DD D)
(A (word+ B (word<<< (word.4+ A (F B C D) (vector-ref X 0) (word 3614090360)) 7))) (A (word+ B (word<<< (word.4+ A (F B C D) (vector-ref X 0) (word 3614090360)) 7)))
(D (word+ A (word<<< (word.4+ D (F A B C) (vector-ref X 1) (word 3905402710)) 12))) (D (word+ A (word<<< (word.4+ D (F A B C) (vector-ref X 1) (word 3905402710)) 12)))
@ -385,10 +449,12 @@
(B (word+ B BB)) (B (word+ B BB))
(C (word+ C CC)) (C (word+ C CC))
(D (word+ D DD))) (D (word+ D DD)))
(loop A B C D rest)))))
(loop A B C D b-port done)))))))
;; Step 3 :-) (magic constants) ;; Step 3 :-) (magic constants)
(loop (word #x67452301) (word #xefcdab89) (word #x98badcfe) (word #x10325476) message)) ;; (display (format "Message is: ~a~n~n" message))
(loop (word #x67452301) (word #xefcdab89) (word #x98badcfe) (word #x10325476) a-port 0))
;; Each round consists of the application of the following ;; Each round consists of the application of the following
;; basic functions. They functions on a word bitwise, as follows. ;; basic functions. They functions on a word bitwise, as follows.
@ -426,8 +492,8 @@
(apply bytes-append (apply bytes-append
(map number->hex (map number->hex
(apply append (map word->bytes l))))) (apply append (map word->bytes l)))))
(set! md5 md5-computation)
(set! md5 md5-computation)) )
;(define (md5-test) ;(define (md5-test)
; (if (and (equal? (md5 "") ; (if (and (equal? (md5 "")
@ -448,4 +514,4 @@
; 'failed)) ; 'failed))
; ;
;(md5-test) ;(md5-test)
) )