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

some more touchups

Browse Source 
svn: r2916
This commit is contained in:
Eli Barzilay 2006-05-12 04:42:52 +00:00
parent fd96a129f3
commit 283cb0dffd
1 changed files with 54 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

101
collects/mzlib/md5.ss
View File

@ -2,6 +2,7 @@
(provide md5) (provide md5)
;;; Copyright (c) 2006, PLT Scheme Inc.
;;; Copyright (c) 2002, Jens Axel Soegaard ;;; Copyright (c) 2002, Jens Axel Soegaard
;;; ;;;
;;; 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
@ -17,13 +18,6 @@
;; The algorithm was invented by Ron Rivest, RSA Security, INC. ;; The algorithm was invented by Ron Rivest, RSA Security, INC.
;; Reference: RFC 1321, <http://www.faqs.org/rfcs/rfc1321.html> ;; Reference: RFC 1321, <http://www.faqs.org/rfcs/rfc1321.html>
;;; Technicalities
;; The algorithm is designed to be efficiently implemented
;; using 32 bit arithmetic. If your implementation supports
;; 32 bit arithmetic directly, you should substitute the
;; portable 32 operations with primitives of your implementation.
;; See the PLT version below for an example.
;;; 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.
@ -79,6 +73,7 @@
; 11-5-2006 / Eli ; 11-5-2006 / Eli
; - Cleaned up a lot, removed Larceny-isms ; - Cleaned up a lot, removed Larceny-isms
; - Heavy optimization: not consing anything throughout the loop
;;; Word aritmetic (32 bit) ;;; Word aritmetic (32 bit)
@ -102,9 +97,8 @@
(if (<= 0 n 4294967296) (if (<= 0 n 4294967296)
(cons (quotient n 65536) (remainder n 65536)) (cons (quotient n 65536) (remainder n 65536))
(error 'word "out of range: ~e" n)))] (error 'word "out of range: ~e" n)))]
;; to use when the number is known to be in range ;; use when the number is known to be in range
[(word #:safe #:new c) #'(word #:new #:safe c)] [(word #:new+safe c)
[(word #:new #:safe c)
#'(let ([n c]) (cons (quotient n 65536) (remainder n 65536)))] #'(let ([n c]) (cons (quotient n 65536) (remainder n 65536)))]
;; default form: compute at compile-time if possible ;; default form: compute at compile-time if possible
[(word c) [(word c)
@ -131,38 +125,30 @@
(define (word+=! a b) (define (word+=! a b)
(let ([t1 (+ (car a) (car b))] (let ([t1 (+ (car a) (car b))]
[t2 (+ (cdr a) (cdr b))]) [t2 (+ (cdr a) (cdr b))])
(set-car! a (bitwise-and (+ t1 (arithmetic-shift t2 -16)) 65535)) (cons! a
(set-cdr! a (bitwise-and t2 65535)) (bitwise-and (+ t1 (arithmetic-shift t2 -16)) 65535)
a)) (bitwise-and t2 65535))))
(define word<<<! (define word<<<!
(let* ([masks '#(#x0 #x1 #x3 #x7 #xF #x1F #x3F #x7F #xFF #x1FF #x3FF #x7FF (let* ([masks '#(#x0 #x1 #x3 #x7 #xF #x1F #x3F #x7F #xFF #x1FF #x3FF #x7FF
#xFFF #x1FFF #x3FFF #x7FFF #xFFFF)]) #xFFF #x1FFF #x3FFF #x7FFF #xFFFF)])
(lambda (a s) (lambda (a s)
(let ([rot (lambda (hi lo s) (let-values ([(hi lo s)
(cond [(< 0 s 16) (values (car a) (cdr a) s)]
[(< s 32) (values (cdr a) (car a) (- s 16))]
[else (error 'word<<< "shift out of range: ~e"
s)])])
(cons! a (cons! a
(bitwise-ior (bitwise-ior
(arithmetic-shift (arithmetic-shift (bitwise-and hi (vector-ref masks (- 16 s)))
(bitwise-and hi (vector-ref masks (- 16 s)))
s) s)
(bitwise-and (arithmetic-shift lo (- s 16)) (bitwise-and (arithmetic-shift lo (- s 16))
(vector-ref masks s))) (vector-ref masks s)))
(bitwise-ior (bitwise-ior
(arithmetic-shift (arithmetic-shift (bitwise-and lo (vector-ref masks (- 16 s)))
(bitwise-and lo (vector-ref masks (- 16 s)))
s) s)
(bitwise-and (arithmetic-shift hi (- s 16)) (bitwise-and (arithmetic-shift hi (- s 16))
(vector-ref masks s)))))]) (vector-ref masks s))))))))
(cond [(< 0 s 16) (rot (car a) (cdr a) s)]
[(< s 32) (rot (cdr a) (car a) (- s 16))]
[else (error 'word<<< "shift out of range: ~e" s)])))))
;; word->bytesl : word -> (list byte byte byte byte), little endian!
(define (word->bytesl w)
(list (bitwise-and (cdr w) 255)
(bitwise-and (arithmetic-shift (cdr w) -8) 255)
(bitwise-and (car w) 255)
(bitwise-and (arithmetic-shift (car w) -8) 255)))
;; Bytes and words ;; Bytes and words
;; The least significant byte of a word is the first ;; The least significant byte of a word is the first
@ -171,15 +157,16 @@
;; bytes->word-vector! : vector byte-string -> void ;; bytes->word-vector! : vector byte-string -> void
(define (bytes->word-vector! result l-raw) (define (bytes->word-vector! result l-raw)
;; assumption: always getting a byte-string with 64 places ;; assumption: always getting a byte-string with 64 places
(unless (= 64 (bytes-length l-raw)) ;; (unless (= 64 (bytes-length l-raw))
(error 'bytes->word-vector! "something bad happened")) ;; (error 'bytes->word-vector! "something bad happened"))
(let loop ([n 15]) (let loop ([n 15])
(when (<= 0 n) (when (<= 0 n)
(let ([w (vector-ref result n)] [n (* 4 n)]) (let ([m (* 4 n)])
(set-car! w (+ (bytes-ref l-raw (+ 2 n)) (cons! (vector-ref result n)
(* 256 (bytes-ref l-raw (+ 3 n))))) (+ (bytes-ref l-raw (+ 2 m))
(set-cdr! w (+ (bytes-ref l-raw n) (* 256 (bytes-ref l-raw (+ 3 m))))
(* 256 (bytes-ref l-raw (+ 1 n)))))) (+ (bytes-ref l-raw m)
(* 256 (bytes-ref l-raw (+ 1 m))))))
(loop (sub1 n))))) (loop (sub1 n)))))
(define empty-port (open-input-bytes #"")) (define empty-port (open-input-bytes #""))
@ -190,8 +177,9 @@
;; 32-bit words when the port is exhausted it returns #f for the port and the ;; 32-bit words when the port is exhausted it returns #f for the port and the
;; last few bytes padded ;; last few bytes padded
(define (read-block! a-port done result) (define (read-block! a-port done result)
(define (write-words! done buf) (define-syntax write-words!
(bytes->word-vector! result (step2 (* 8 done) buf))) (syntax-rules ()
[(_ done buf) (bytes->word-vector! result (step2 (* 8 done) buf))]))
(let ([l-raw (read-bytes 512/8 a-port)]) (let ([l-raw (read-bytes 512/8 a-port)])
(cond (cond
;; File size was a multiple of 512 bits, or we're doing one more round ;; File size was a multiple of 512 bits, or we're doing one more round
@ -237,8 +225,7 @@
(let ([a-port (let ([a-port
(cond [(bytes? a-thing) (open-input-bytes a-thing)] (cond [(bytes? a-thing) (open-input-bytes a-thing)]
[(input-port? a-thing) a-thing] [(input-port? a-thing) a-thing]
[else (raise-type-error [else (raise-type-error 'md5 "input-port or bytes" a-thing)])])
'md5 "input-port or bytes" a-thing)])])
(step5 (step4 a-port)))) (step5 (step4 a-port))))
;; Step 1 - Append Padding Bits ;; Step 1 - Append Padding Bits
@ -248,11 +235,11 @@
;; step1 : bytes -> bytes ;; step1 : bytes -> bytes
(define (step1 message) (define (step1 message)
(let* ([z-b-t-a (modulo (- 448 (* 8 (bytes-length message))) 512)] (let* ([nbytes (modulo (- 448/8 (bytes-length message)) 512/8)]
[zero-bits-to-append (if (zero? z-b-t-a) 512 z-b-t-a)]) [nbytes (if (zero? nbytes) 512/8 nbytes)])
(bytes-append message (bytes-append message
#"\x80" ; the 1 bit byte => one less 0 bytes to append #"\x80" ; the 1 bit byte => one less 0 bytes to append
(make-bytes (quotient (- zero-bits-to-append 1) 8) 0)))) (make-bytes (sub1 nbytes) 0))))
;; Step 2 - Append Length ;; Step 2 - Append Length
;; A 64 bit representation of the bit length b of the message before ;; A 64 bit representation of the bit length b of the message before
@ -274,7 +261,7 @@
;; Step 4 - Process Message in 16-Word Blocks ;; Step 4 - Process Message in 16-Word Blocks
;; 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 : input-port -> (list word word word word)
;; Step 3 :-) (magic constants) ;; Step 3 :-) (magic constants)
(define (step4 a-port) (define (step4 a-port)
@ -283,10 +270,10 @@
(vector (cons 0 0) (cons 0 0) (cons 0 0) (cons 0 0) (cons 0 0) (cons 0 0) (vector (cons 0 0) (cons 0 0) (cons 0 0) (cons 0 0) (cons 0 0) (cons 0 0)
(cons 0 0) (cons 0 0) (cons 0 0) (cons 0 0) (cons 0 0) (cons 0 0) (cons 0 0) (cons 0 0) (cons 0 0) (cons 0 0) (cons 0 0) (cons 0 0)
(cons 0 0) (cons 0 0) (cons 0 0) (cons 0 0))) (cons 0 0) (cons 0 0) (cons 0 0) (cons 0 0)))
(define A (word #:new #:safe #x67452301)) (define A (word #:new+safe #x67452301))
(define B (word #:new #:safe #xefcdab89)) (define B (word #:new+safe #xefcdab89))
(define C (word #:new #:safe #x98badcfe)) (define C (word #:new+safe #x98badcfe))
(define D (word #:new #:safe #x10325476)) (define D (word #:new+safe #x10325476))
(define AA (cons 0 0)) (define AA (cons 0 0))
(define BB (cons 0 0)) (define BB (cons 0 0))
(define CC (cons 0 0)) (define CC (cons 0 0))
@ -434,17 +421,19 @@
;; Step 5 - Output ;; Step 5 - Output
;; To finish up, we convert the word to hexadecimal string ;; To finish up, we convert the word to hexadecimal string
;; - and make sure they end up in order. ;; - and make sure they end up in order.
;; step5 : "(list word word word word)" -> string ;; step5 : (list word word word word) -> string
(define (step5 l) (define (step5 l)
(define hex #(48 49 50 51 52 53 54 55 56 57 97 98 99 100 101 102)) (define hex #(48 49 50 51 52 53 54 55 56 57 97 98 99 100 101 102))
;; word->bytesl : word -> (list byte),
(define (number->hex n) ;; returns a little endian result, but each byte is hi half and then lo half
(bytes (vector-ref hex (quotient n 16)) (define (word->bytesl w)
(vector-ref hex (modulo n 16)))) (let ([byte (lambda (n b) (bitwise-and (arithmetic-shift n (- b)) 15))]
[lo (cdr w)] [hi (car w)])
(apply bytes-append (map number->hex (apply append (map word->bytesl l))))) (list (byte lo 4) (byte lo 0) (byte lo 12) (byte lo 8)
(byte hi 4) (byte hi 0) (byte hi 12) (byte hi 8))))
(apply bytes (map (lambda (n) (vector-ref hex n))
(apply append (map word->bytesl l)))))
;(define (md5-test) ;(define (md5-test)
; (if (and (equal? (md5 "") ; (if (and (equal? (md5 "")