major cleanup
svn: r2910
This commit is contained in:
Eli Barzilay
parent
727ac66143
commit
6264ad30db
|
|
@ -1,17 +1,29 @@
|
|||
(module md5 mzscheme
|
||||
|
||||
|
||||
(provide md5)
|
||||
|
||||
;;; -*- mode: scheme; mode: font-lock -*-
|
||||
|
||||
;;; Copyright (c) 2002, Jens Axel Soegaard
|
||||
;;;
|
||||
;;; Copyright (c) 2002, Jens Axel Søgaard
|
||||
;;;
|
||||
;;; Permission to copy this software, in whole or in part, to use this
|
||||
;;; software for any lawful purpose, and to redistribute this software
|
||||
;;; is hereby granted.
|
||||
;;;
|
||||
;;; md5.scm -- Jens Axel Søgaard, 16 oct 2002
|
||||
|
||||
;;; md5.scm -- Jens Axel Soegaard, 16 oct 2002
|
||||
|
||||
;;; Summary
|
||||
;; This is an implementation of the md5 message-digest algorithm
|
||||
;; in R5RS Scheme. The algorithm takes an arbitrary byte-string or
|
||||
;; an input port, and returns a 128-bit "fingerprint" byte string.
|
||||
;; The algorithm was invented by Ron Rivest, RSA Security, INC.
|
||||
;; 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
|
||||
; 14-10-2002 /jas
|
||||
; - Bored. Initial attempt. Done. Well, except for faulty output.
|
||||
|
|
@ -21,9 +33,9 @@
|
|||
; - Added R5RS support
|
||||
; 16-02-2003 / lth
|
||||
; - 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)
|
||||
; - 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.
|
||||
; Performance in the interpreter is still really quite awful.
|
||||
; - Wrapped entire procedure in a big LET to protect the namespace
|
||||
|
|
@ -48,453 +60,357 @@
|
|||
; - Trivial port to PLT. Rewrote the word macro to syntax-rules.
|
||||
; Larceny primitives written as syntax-rules macros exanding
|
||||
; to their PLT name.
|
||||
|
||||
|
||||
; 5-5-2005 / Greg Pettyjohn
|
||||
; - 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.
|
||||
; According to RFC 1321, the message should still be padded in this
|
||||
; 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
|
||||
; 10-2-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>
|
||||
|
||||
;;; Contact
|
||||
; Email jensaxel@soegaard.net if you have problems,
|
||||
; suggestions, code for 32 bit arithmetic for your
|
||||
; favorite implementation.
|
||||
; Check <http://www.scheme.dk/md5/> for new versions.
|
||||
|
||||
;;; 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.
|
||||
|
||||
|
||||
; 11-5-2006 / Eli
|
||||
; - Cleaned up a lot, removed Larceny-isms
|
||||
|
||||
|
||||
;;; Word aritmetic (32 bit)
|
||||
; Terminology
|
||||
; word: 32 bit unsigned integer
|
||||
; byte: 8 bit unsigned integer
|
||||
|
||||
(define md5 'undefined)
|
||||
;; Terminology
|
||||
;; word: 32 bit unsigned integer
|
||||
;; byte: 8 bit unsigned integer
|
||||
|
||||
; (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.
|
||||
|
||||
;(define-syntax word
|
||||
; (transformer
|
||||
; (lambda (expr rename compare)
|
||||
; (list 'quote (cons (quotient (cadr expr) 65536) (remainder (cadr expr) 65536))))))
|
||||
|
||||
(define-syntax word
|
||||
(syntax-rules ()
|
||||
;; Words are represented as a cons where the car holds the high 16
|
||||
;; bits and the cdr holds the low 16 bits. Most good Scheme systems
|
||||
;; will have fixnums that hold at least 16 bits as well as fast
|
||||
;; allocation, so this has a fair chance at beating bignums for
|
||||
;; performance.
|
||||
|
||||
;; (word c) turns into a quoted pair '(hi . lo) if c is a literal number.
|
||||
(define-syntax (word stx)
|
||||
(syntax-case stx ()
|
||||
[(word c)
|
||||
(cons (quotient c 65536) (remainder c 65536))]))
|
||||
|
||||
(let ()
|
||||
|
||||
;;; PORTING NOTES
|
||||
|
||||
; logand is bitwise "and" on fixnums
|
||||
; logior is bitwise "inclusive or" on fixnums
|
||||
; logxor is bitwise "exclusive or" on fixnums
|
||||
; lognot is bitwise "not" on fixnums
|
||||
; lsh is bitwise left-shift without overflow detection on fixnums
|
||||
; rshl is bitwise logical right-shift on fixnums. Arithmetic
|
||||
; right shift (rsha in Larceny) can be used instead of rshl
|
||||
; in this code
|
||||
|
||||
; PLT versions of the Larceny primitives
|
||||
(define-syntax fixnum? (syntax-rules () [(_ n) #t]))
|
||||
(define-syntax logand (syntax-rules () [(_ . more) (bitwise-and . more)]))
|
||||
(define-syntax logior (syntax-rules () [(_ . more) (bitwise-ior . more)]))
|
||||
(define-syntax logxor (syntax-rules () [(_ . more) (bitwise-xor . more)]))
|
||||
(define-syntax lognot (syntax-rules () [(_ . more) (bitwise-not . more)]))
|
||||
(define-syntax lsh (syntax-rules () [(_ n s) (arithmetic-shift n s)]))
|
||||
(define-syntax rshl (syntax-rules () [(_ n s) (arithmetic-shift n (- s))]))
|
||||
|
||||
; Words are represented as a cons where the car holds the high 16
|
||||
; bits and the cdr holds the low 16 bits. Most good Scheme systems
|
||||
; will have fixnums that hold at least 16 bits as well as fast
|
||||
; allocation, so this has a fair chance at beating bignums for
|
||||
; performance.
|
||||
|
||||
(define (integer->word i)
|
||||
(if (or (and (fixnum? i) (>= i 0))
|
||||
(<= 0 i 4294967296))
|
||||
(cons (quotient i 65536) (remainder i 65536))
|
||||
(error "integer->word: out of range: " i)))
|
||||
|
||||
(define (word->integer w)
|
||||
(+ (* (car w) 65536) (cdr w)))
|
||||
|
||||
(define (word+ a b)
|
||||
(let ((t1 (+ (car a) (car b)))
|
||||
(t2 (+ (cdr a) (cdr b))))
|
||||
(cons (logand (+ t1 (rshl t2 16)) 65535)
|
||||
(logand t2 65535))))
|
||||
|
||||
(define (word-or a b)
|
||||
(cons (logior (car a) (car b))
|
||||
(logior (cdr a) (cdr b))))
|
||||
|
||||
(define (word-not a)
|
||||
(cons (logand (lognot (car a)) 65535) (logand (lognot (cdr a)) 65535)))
|
||||
|
||||
(define (word-xor a b)
|
||||
(cons (logxor (car a) (car b)) (logxor (cdr a) (cdr b))))
|
||||
|
||||
(define (word-and a b)
|
||||
(cons (logand (car a) (car b)) (logand (cdr a) (cdr b))))
|
||||
|
||||
(define (word<<< a s)
|
||||
(define masks
|
||||
'#(#x0 #x1 #x3 #x7 #xF #x1F #x3F #x7F #xFF
|
||||
#x1FF #x3FF #x7FF #xFFF #x1FFF #x3FFF #x7FFF #xFFFF))
|
||||
(define (rot hi lo s)
|
||||
(cons (logior (lsh (logand hi (vector-ref masks (- 16 s))) s)
|
||||
(logand (rshl lo (- 16 s)) (vector-ref masks s)))
|
||||
(logior (lsh (logand lo (vector-ref masks (- 16 s))) s)
|
||||
(logand (rshl hi (- 16 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: " s))))
|
||||
|
||||
;; word->bytes : word -> "(list byte byte byte byte)", little endian!
|
||||
(define (word->bytes w)
|
||||
(list (logand (cdr w) 255)
|
||||
(logand (rshl (cdr w) 8) 255)
|
||||
(logand (car w) 255)
|
||||
(logand (rshl (car w) 8) 255)))
|
||||
|
||||
(define (word.4+ a b c d)
|
||||
(word+ (word+ (word+ a b) c) d))
|
||||
|
||||
(define bitpos
|
||||
'(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25
|
||||
26 27 28 29 30 31))
|
||||
|
||||
(define powers
|
||||
'#(1 2 4 8 16 32 64 128 256 512 1024 2048 4096 8192 16384 32768 65536
|
||||
131072 262144 524288 1048576 2097152 4194304 8388608 16777216 33554432
|
||||
67108864 134217728 268435456 536870912 1073741824 2147483648
|
||||
4294967296))
|
||||
|
||||
;; word->bits : word -> (list (union 0 1))
|
||||
(define (word->bits w)
|
||||
(let ((w (word->integer w)))
|
||||
(define (bit i)
|
||||
(remainder (quotient w (vector-ref powers i)) 2))
|
||||
(map bit bitpos)))
|
||||
|
||||
;; bits->integer : (list (union 0 1)) -> integer
|
||||
(define (bits->integer bs)
|
||||
(apply + (map * bs (map (lambda (i) (vector-ref powers i)) bitpos))))
|
||||
|
||||
;; Bytes and words
|
||||
;; The least significant byte of a word is the first
|
||||
|
||||
;; bytes->word : (list byte*) -> word
|
||||
(define (bytes->word bs)
|
||||
(define (bs->w akk mul bs)
|
||||
(if (null? bs)
|
||||
(integer->word akk)
|
||||
(bs->w (+ akk (* (car bs) mul)) (* 256 mul) (cdr bs))))
|
||||
(bs->w 0 1 bs))
|
||||
|
||||
;; bytes->words : (list byte) -> (list word)
|
||||
(define (bytes->words bytes)
|
||||
(define (loop bs l)
|
||||
(cond ((null? l) (list (bytes->word (reverse bs))))
|
||||
((< (length bs) 4) (loop (cons (car l) bs) (cdr l)))
|
||||
(else (cons (bytes->word (reverse bs))
|
||||
(loop '() l)))))
|
||||
(if (null? bytes)
|
||||
'()
|
||||
(loop '() bytes)))
|
||||
|
||||
;; string->bytes : string -> (list byte)
|
||||
(define (string->bytes 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)))))
|
||||
(let ([n (syntax-e #'c)])
|
||||
(if (integer? n)
|
||||
(datum->syntax-object
|
||||
#'c `(quote ,(cons (quotient n 65536) (remainder n 65536))) #'c)
|
||||
#'(let ([n c])
|
||||
(if (<= 0 n 4294967296)
|
||||
(cons (quotient n 65536) (remainder n 65536))
|
||||
(error 'word "out of range: ~e" n)))))]))
|
||||
|
||||
(define empty-port (open-input-bytes #""))
|
||||
|
||||
;; List Helper
|
||||
;; block/list : a-port done-n -> (values vector a-port done-n)
|
||||
;; reads 512 bytes from the port, turns them into a vector of 16 32-bit words
|
||||
;; when the port is exhausted it returns #f for the port and
|
||||
;; the last few bytes padded
|
||||
|
||||
(define (block/list a-port done)
|
||||
(let* ((l-raw (read-bytes (/ 512 8) a-port)))
|
||||
(cond
|
||||
;; File size was a multiple of 512 bits, or we're doing one more round to
|
||||
;; add the correct padding from the short case
|
||||
((eof-object? l-raw)
|
||||
(if (zero? (modulo done (/ 512 8)))
|
||||
;; The file is a multiple of 512 or was 0, so there hasn't been a
|
||||
;; chance to add the 1-bit pad, so we need to do a full pad
|
||||
(values (vector-from-list (step2 (* 8 done)
|
||||
(step1 (string->bytes #""))))
|
||||
#f
|
||||
done)
|
||||
;; We only enter this block when the previous block didn't have
|
||||
;; enough room to fit the 64-bit file length,
|
||||
;; so we just add 448 bits of zeros and then the 64-bit file length (step2)
|
||||
(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
|
||||
;; The algorithm consists of five steps.
|
||||
;; All we need to do, is to call them in order.
|
||||
;; md5 : string -> string
|
||||
|
||||
(define (md5-computation a-thing)
|
||||
(let ((a-port (cond
|
||||
[(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
|
||||
;; The message is padded so the length (in bits) becomes 448 modulo 512.
|
||||
;; We allways append a 1 bit and then append the proper numbber of 0's.
|
||||
;; NB: 448 bits is 14 words and 512 bits is 16 words
|
||||
;; step1 : (list byte) -> (list byte)
|
||||
|
||||
(define (step1 message)
|
||||
(let* ([z-b-t-a (modulo (- 448 (* 8 (length message))) 512)]
|
||||
[zero-bits-to-append (if (zero? z-b-t-a) 512 z-b-t-a)])
|
||||
(append message
|
||||
(cons #x80 ; The byte containing the 1 bit => one less
|
||||
; 0 byte to append
|
||||
(vector->list
|
||||
(make-vector
|
||||
(quotient (- zero-bits-to-append 1) 8) 0))))))
|
||||
|
||||
;; Step 2 - Append Length
|
||||
;; A 64 bit representation of the bit length b of the message before
|
||||
;; the padding of step 1 is appended. Lower word first.
|
||||
;; step2 : number (list byte) -> (list word)
|
||||
;; org-len is the length of the original message in number of bits
|
||||
|
||||
(define (step2 original-length padded-message)
|
||||
(let* ((b original-length)
|
||||
(lo (remainder b #x100000000))
|
||||
(hi (remainder (quotient b #x100000000) #x100000000)))
|
||||
(bytes->words
|
||||
(append padded-message
|
||||
(append (word->bytes (integer->word lo))
|
||||
(word->bytes (integer->word hi)))))))
|
||||
|
||||
;; Step 3 - Initialize MD Buffer
|
||||
;; These magic constants are used to initialize the loop
|
||||
;; in step 4.
|
||||
;;
|
||||
;; word A: 01 23 45 67
|
||||
;; word B: 89 ab cd ef
|
||||
;; word C: fe dc ba 98
|
||||
;; word D: 76 54 32 10
|
||||
|
||||
;; Step 4 - Process Message in 16-Word Blocks
|
||||
;; For each 16 word block, go through a round one to four.
|
||||
;; step4 : (list word) -> "(list word word word word)"
|
||||
|
||||
(define (step4 a-port)
|
||||
|
||||
(define (loop A B C D a-port done)
|
||||
(define (word+ a b)
|
||||
(let ([t1 (+ (car a) (car b))]
|
||||
[t2 (+ (cdr a) (cdr b))])
|
||||
(cons (bitwise-and (+ t1 (arithmetic-shift t2 -16)) 65535)
|
||||
(bitwise-and t2 65535))))
|
||||
|
||||
(if (not a-port)
|
||||
(define (word-or a b)
|
||||
(cons (bitwise-ior (car a) (car b))
|
||||
(bitwise-ior (cdr a) (cdr b))))
|
||||
|
||||
(define (word-not a)
|
||||
(cons (bitwise-and (bitwise-not (car a)) 65535)
|
||||
(bitwise-and (bitwise-not (cdr a)) 65535)))
|
||||
|
||||
(define (word-xor a b)
|
||||
(cons (bitwise-xor (car a) (car b))
|
||||
(bitwise-xor (cdr a) (cdr b))))
|
||||
(define (word-xor3 a b c)
|
||||
(cons (bitwise-xor (car a) (car b) (car c))
|
||||
(bitwise-xor (cdr a) (cdr b) (cdr c))))
|
||||
|
||||
(define (word-and a b)
|
||||
(cons (bitwise-and (car a) (car b))
|
||||
(bitwise-and (cdr a) (cdr b))))
|
||||
|
||||
(define word<<<
|
||||
(let* ([masks '#(#x0 #x1 #x3 #x7 #xF #x1F #x3F #x7F #xFF #x1FF #x3FF #x7FF
|
||||
#xFFF #x1FFF #x3FFF #x7FFF #xFFFF)]
|
||||
[rot (lambda (hi lo s)
|
||||
(cons (bitwise-ior (arithmetic-shift (bitwise-and hi (vector-ref masks (- 16 s))) s)
|
||||
(bitwise-and (arithmetic-shift lo (- s 16)) (vector-ref masks s)))
|
||||
(bitwise-ior (arithmetic-shift (bitwise-and lo (vector-ref masks (- 16 s))) s)
|
||||
(bitwise-and (arithmetic-shift hi (- s 16)) (vector-ref masks s)))))])
|
||||
(lambda (a 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: " s)]))))
|
||||
|
||||
;; word->bytes : word -> (list byte byte byte byte), little endian!
|
||||
(define (word->bytes 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)))
|
||||
|
||||
(define (word.4+ a b c d)
|
||||
(word+ (word+ (word+ a b) c) d))
|
||||
|
||||
;; Bytes and words
|
||||
;; The least significant byte of a word is the first
|
||||
|
||||
;; bytes->word : (list byte*) -> word
|
||||
(define (bytes->word bs)
|
||||
(define (bs->w akk mul bs)
|
||||
(if (null? bs)
|
||||
(word akk)
|
||||
(bs->w (+ akk (* (car bs) mul)) (* 256 mul) (cdr bs))))
|
||||
(bs->w 0 1 bs))
|
||||
|
||||
;; bytes->words : (list byte) -> (list word)
|
||||
(define (bytes->words bytes)
|
||||
(define (loop bs l)
|
||||
(cond [(null? l) (list (bytes->word (reverse bs)))]
|
||||
[(< (length bs) 4) (loop (cons (car l) bs) (cdr l))]
|
||||
[else (cons (bytes->word (reverse bs)) (loop '() l))]))
|
||||
(if (null? bytes) '() (loop '() bytes)))
|
||||
|
||||
;; string->bytes : string -> (list byte)
|
||||
(define (string->bytes s)
|
||||
(bytes->list s))
|
||||
|
||||
;; Converts a byte string to a more useful vector
|
||||
;; vector-from-string: byte string -> (vector ...)
|
||||
(define (vector-from-string l-raw)
|
||||
(list->vector (bytes->words (string->bytes l-raw))))
|
||||
|
||||
(define empty-port (open-input-bytes #""))
|
||||
|
||||
;; List Helper
|
||||
;; block/list : a-port done-n -> (values vector a-port done-n)
|
||||
;; reads 512 bytes from the port, turns them into a vector of 16 32-bit words
|
||||
;; when the port is exhausted it returns #f for the port and
|
||||
;; the last few bytes padded
|
||||
|
||||
(define (block/list a-port done)
|
||||
(let ([l-raw (read-bytes (/ 512 8) a-port)])
|
||||
(cond
|
||||
;; File size was a multiple of 512 bits, or we're doing one more round to
|
||||
;; add the correct padding from the short case
|
||||
[(eof-object? l-raw)
|
||||
(if (zero? (modulo done (/ 512 8)))
|
||||
;; The file is a multiple of 512 or was 0, so there hasn't been a
|
||||
;; chance to add the 1-bit pad, so we need to do a full pad
|
||||
(values (list->vector (step2 (* 8 done) (step1 (string->bytes #""))))
|
||||
#f
|
||||
done)
|
||||
;; We only enter this block when the previous block didn't have
|
||||
;; enough room to fit the 64-bit file length,
|
||||
;; so we just add 448 bits of zeros and then the 64-bit file length (step2)
|
||||
(values (list->vector (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 (list->vector (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 (list->vector (step2 (* 8 done) (step1 (string->bytes l-raw))))
|
||||
#f
|
||||
done))])))
|
||||
|
||||
;; (step2 (* 8 (bytes-length str))
|
||||
;; (step1 (string->bytes str)))
|
||||
|
||||
|
||||
;; MD5
|
||||
;; The algorithm consists of five steps.
|
||||
;; All we need to do, is to call them in order.
|
||||
;; md5 : string -> string
|
||||
|
||||
(define (md5 a-thing)
|
||||
(let ([a-port
|
||||
(cond [(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
|
||||
;; The message is padded so the length (in bits) becomes 448 modulo 512.
|
||||
;; We allways append a 1 bit and then append the proper numbber of 0's.
|
||||
;; NB: 448 bits is 14 words and 512 bits is 16 words
|
||||
;; step1 : (list byte) -> (list byte)
|
||||
|
||||
(define (step1 message)
|
||||
(let* ([z-b-t-a (modulo (- 448 (* 8 (length message))) 512)]
|
||||
[zero-bits-to-append (if (zero? z-b-t-a) 512 z-b-t-a)])
|
||||
(append message
|
||||
(cons #x80 ; The byte containing the 1 bit => one less
|
||||
; 0 byte to append
|
||||
(vector->list
|
||||
(make-vector
|
||||
(quotient (- zero-bits-to-append 1) 8)
|
||||
0))))))
|
||||
|
||||
;; Step 2 - Append Length
|
||||
;; A 64 bit representation of the bit length b of the message before
|
||||
;; the padding of step 1 is appended. Lower word first.
|
||||
;; step2 : number (list byte) -> (list word)
|
||||
;; org-len is the length of the original message in number of bits
|
||||
|
||||
(define (step2 original-length padded-message)
|
||||
(let* ([b original-length]
|
||||
[lo (remainder b #x100000000)]
|
||||
[hi (remainder (quotient b #x100000000) #x100000000)])
|
||||
(bytes->words
|
||||
(append padded-message
|
||||
(append (word->bytes (word lo))
|
||||
(word->bytes (word hi)))))))
|
||||
|
||||
;; Step 3 - Initialize MD Buffer
|
||||
;; These magic constants are used to initialize the loop
|
||||
;; in step 4.
|
||||
;;
|
||||
;; word A: 01 23 45 67
|
||||
;; word B: 89 ab cd ef
|
||||
;; word C: fe dc ba 98
|
||||
;; word D: 76 54 32 10
|
||||
|
||||
;; Step 4 - Process Message in 16-Word Blocks
|
||||
;; For each 16 word block, go through a round one to four.
|
||||
;; step4 : (list word) -> "(list word word word word)"
|
||||
|
||||
;; Step 3 :-) (magic constants)
|
||||
(define (step4 a-port)
|
||||
(let loop ([A (word #x67452301)]
|
||||
[B (word #xefcdab89)]
|
||||
[C (word #x98badcfe)]
|
||||
[D (word #x10325476)]
|
||||
[a-port a-port]
|
||||
[done 0])
|
||||
(if (not a-port)
|
||||
(list A B C D)
|
||||
(let-values ([(X b-port done) (block/list a-port done)])
|
||||
(if (not X)
|
||||
(list A B C D)
|
||||
(let-values (((X b-port done) (block/list a-port done)))
|
||||
(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)))
|
||||
(D (word+ A (word<<< (word.4+ D (F A B C) (vector-ref X 1) (word 3905402710)) 12)))
|
||||
(C (word+ D (word<<< (word.4+ C (F D A B) (vector-ref X 2) (word 606105819)) 17)))
|
||||
(B (word+ C (word<<< (word.4+ B (F C D A) (vector-ref X 3) (word 3250441966)) 22)))
|
||||
(A (word+ B (word<<< (word.4+ A (F B C D) (vector-ref X 4) (word 4118548399)) 7)))
|
||||
(D (word+ A (word<<< (word.4+ D (F A B C) (vector-ref X 5) (word 1200080426)) 12)))
|
||||
(C (word+ D (word<<< (word.4+ C (F D A B) (vector-ref X 6) (word 2821735955)) 17)))
|
||||
(B (word+ C (word<<< (word.4+ B (F C D A) (vector-ref X 7) (word 4249261313)) 22)))
|
||||
(A (word+ B (word<<< (word.4+ A (F B C D) (vector-ref X 8) (word 1770035416)) 7)))
|
||||
(D (word+ A (word<<< (word.4+ D (F A B C) (vector-ref X 9) (word 2336552879)) 12)))
|
||||
(C (word+ D (word<<< (word.4+ C (F D A B) (vector-ref X 10) (word 4294925233)) 17)))
|
||||
(B (word+ C (word<<< (word.4+ B (F C D A) (vector-ref X 11) (word 2304563134)) 22)))
|
||||
(A (word+ B (word<<< (word.4+ A (F B C D) (vector-ref X 12) (word 1804603682)) 7)))
|
||||
(D (word+ A (word<<< (word.4+ D (F A B C) (vector-ref X 13) (word 4254626195)) 12)))
|
||||
(C (word+ D (word<<< (word.4+ C (F D A B) (vector-ref X 14) (word 2792965006)) 17)))
|
||||
(B (word+ C (word<<< (word.4+ B (F C D A) (vector-ref X 15) (word 1236535329)) 22)))
|
||||
|
||||
(A (word+ B (word<<< (word.4+ A (G B C D) (vector-ref X 1) (word 4129170786)) 5)))
|
||||
(D (word+ A (word<<< (word.4+ D (G A B C) (vector-ref X 6) (word 3225465664)) 9)))
|
||||
(C (word+ D (word<<< (word.4+ C (G D A B) (vector-ref X 11) (word 643717713)) 14)))
|
||||
(B (word+ C (word<<< (word.4+ B (G C D A) (vector-ref X 0) (word 3921069994)) 20)))
|
||||
(A (word+ B (word<<< (word.4+ A (G B C D) (vector-ref X 5) (word 3593408605)) 5)))
|
||||
(D (word+ A (word<<< (word.4+ D (G A B C) (vector-ref X 10) (word 38016083)) 9)))
|
||||
(C (word+ D (word<<< (word.4+ C (G D A B) (vector-ref X 15) (word 3634488961)) 14)))
|
||||
(B (word+ C (word<<< (word.4+ B (G C D A) (vector-ref X 4) (word 3889429448)) 20)))
|
||||
(A (word+ B (word<<< (word.4+ A (G B C D) (vector-ref X 9) (word 568446438)) 5)))
|
||||
(D (word+ A (word<<< (word.4+ D (G A B C) (vector-ref X 14) (word 3275163606)) 9)))
|
||||
(C (word+ D (word<<< (word.4+ C (G D A B) (vector-ref X 3) (word 4107603335)) 14)))
|
||||
(B (word+ C (word<<< (word.4+ B (G C D A) (vector-ref X 8) (word 1163531501)) 20)))
|
||||
(A (word+ B (word<<< (word.4+ A (G B C D) (vector-ref X 13) (word 2850285829)) 5)))
|
||||
(D (word+ A (word<<< (word.4+ D (G A B C) (vector-ref X 2) (word 4243563512)) 9)))
|
||||
(C (word+ D (word<<< (word.4+ C (G D A B) (vector-ref X 7) (word 1735328473)) 14)))
|
||||
(B (word+ C (word<<< (word.4+ B (G C D A) (vector-ref X 12) (word 2368359562)) 20)))
|
||||
|
||||
(A (word+ B (word<<< (word.4+ A (H B C D) (vector-ref X 5) (word 4294588738)) 4)))
|
||||
(D (word+ A (word<<< (word.4+ D (H A B C) (vector-ref X 8) (word 2272392833)) 11)))
|
||||
(C (word+ D (word<<< (word.4+ C (H D A B) (vector-ref X 11) (word 1839030562)) 16)))
|
||||
(B (word+ C (word<<< (word.4+ B (H C D A) (vector-ref X 14) (word 4259657740)) 23)))
|
||||
(A (word+ B (word<<< (word.4+ A (H B C D) (vector-ref X 1) (word 2763975236)) 4)))
|
||||
(D (word+ A (word<<< (word.4+ D (H A B C) (vector-ref X 4) (word 1272893353)) 11)))
|
||||
(C (word+ D (word<<< (word.4+ C (H D A B) (vector-ref X 7) (word 4139469664)) 16)))
|
||||
(B (word+ C (word<<< (word.4+ B (H C D A) (vector-ref X 10) (word 3200236656)) 23)))
|
||||
(A (word+ B (word<<< (word.4+ A (H B C D) (vector-ref X 13) (word 681279174)) 4)))
|
||||
(D (word+ A (word<<< (word.4+ D (H A B C) (vector-ref X 0) (word 3936430074)) 11)))
|
||||
(C (word+ D (word<<< (word.4+ C (H D A B) (vector-ref X 3) (word 3572445317)) 16)))
|
||||
(B (word+ C (word<<< (word.4+ B (H C D A) (vector-ref X 6) (word 76029189)) 23)))
|
||||
(A (word+ B (word<<< (word.4+ A (H B C D) (vector-ref X 9) (word 3654602809)) 4)))
|
||||
(D (word+ A (word<<< (word.4+ D (H A B C) (vector-ref X 12) (word 3873151461)) 11)))
|
||||
(C (word+ D (word<<< (word.4+ C (H D A B) (vector-ref X 15) (word 530742520)) 16)))
|
||||
(B (word+ C (word<<< (word.4+ B (H C D A) (vector-ref X 2) (word 3299628645)) 23)))
|
||||
|
||||
(A (word+ B (word<<< (word.4+ A (II B C D) (vector-ref X 0) (word 4096336452)) 6)))
|
||||
(D (word+ A (word<<< (word.4+ D (II A B C) (vector-ref X 7) (word 1126891415)) 10)))
|
||||
(C (word+ D (word<<< (word.4+ C (II D A B) (vector-ref X 14) (word 2878612391)) 15)))
|
||||
(B (word+ C (word<<< (word.4+ B (II C D A) (vector-ref X 5) (word 4237533241)) 21)))
|
||||
(A (word+ B (word<<< (word.4+ A (II B C D) (vector-ref X 12) (word 1700485571)) 6)))
|
||||
(D (word+ A (word<<< (word.4+ D (II A B C) (vector-ref X 3) (word 2399980690)) 10)))
|
||||
(C (word+ D (word<<< (word.4+ C (II D A B) (vector-ref X 10) (word 4293915773)) 15)))
|
||||
(B (word+ C (word<<< (word.4+ B (II C D A) (vector-ref X 1) (word 2240044497)) 21)))
|
||||
(A (word+ B (word<<< (word.4+ A (II B C D) (vector-ref X 8) (word 1873313359)) 6)))
|
||||
(D (word+ A (word<<< (word.4+ D (II A B C) (vector-ref X 15) (word 4264355552)) 10)))
|
||||
(C (word+ D (word<<< (word.4+ C (II D A B) (vector-ref X 6) (word 2734768916)) 15)))
|
||||
(B (word+ C (word<<< (word.4+ B (II C D A) (vector-ref X 13) (word 1309151649)) 21)))
|
||||
(A (word+ B (word<<< (word.4+ A (II B C D) (vector-ref X 4) (word 4149444226)) 6)))
|
||||
(D (word+ A (word<<< (word.4+ D (II A B C) (vector-ref X 11) (word 3174756917)) 10)))
|
||||
(C (word+ D (word<<< (word.4+ C (II D A B) (vector-ref X 2) (word 718787259)) 15)))
|
||||
(B (word+ C (word<<< (word.4+ B (II C D A) (vector-ref X 9) (word 3951481745)) 21)))
|
||||
|
||||
(A (word+ A AA))
|
||||
(B (word+ B BB))
|
||||
(C (word+ C CC))
|
||||
(D (word+ D DD)))
|
||||
|
||||
(loop A B C D b-port done)))))))
|
||||
|
||||
;; Step 3 :-) (magic constants)
|
||||
;; (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
|
||||
;; basic functions. They functions on a word bitwise, as follows.
|
||||
;; F(X,Y,Z) = XY v not(X) Z (NB: or can be replaced with + in F)
|
||||
;; G(X,Y,Z) = XZ v Y not(Z)
|
||||
;; H(X,Y,Z) = X xor Y xor Z
|
||||
;; I(X,Y,Z) = Y xor (X v not(Z))
|
||||
|
||||
(define (F x y z)
|
||||
(word-or (word-and x y) (word-and (word-not x) z)))
|
||||
|
||||
(define (G x y z)
|
||||
(word-or (word-and x z) (word-and y (word-not z))))
|
||||
|
||||
(define (H x y z)
|
||||
(word-xor x (word-xor y z)))
|
||||
|
||||
(define (II x y z)
|
||||
(word-xor y (word-or x (word-not z))))
|
||||
|
||||
;; Step 5 - Output
|
||||
;; To finish up, we convert the word to hexadecimal string
|
||||
;; - and make sure they end up in order.
|
||||
;; step5 : "(list word word word word)" -> string
|
||||
|
||||
(define (step5 l)
|
||||
|
||||
|
||||
(define hex #(48 49 50 51 52 53 54 55 56 57 97 98 99 100 101 102))
|
||||
|
||||
(define (number->hex n)
|
||||
(bytes (vector-ref hex (quotient n 16))
|
||||
(vector-ref hex (modulo n 16))))
|
||||
|
||||
(apply bytes-append
|
||||
(map number->hex
|
||||
(apply append (map word->bytes l)))))
|
||||
(set! md5 md5-computation)
|
||||
)
|
||||
|
||||
(let ([AA A] [BB B] [CC C] [DD D])
|
||||
(define-syntax step
|
||||
(syntax-rules ()
|
||||
[(_ a b c d e f g h)
|
||||
(set! a (word+ b (word<<< (word.4+ a
|
||||
(e b c d)
|
||||
(vector-ref X f)
|
||||
(word g))
|
||||
h)))]))
|
||||
;;---
|
||||
(step A B C D F 0 3614090360 7)
|
||||
(step D A B C F 1 3905402710 12)
|
||||
(step C D A B F 2 606105819 17)
|
||||
(step B C D A F 3 3250441966 22)
|
||||
(step A B C D F 4 4118548399 7)
|
||||
(step D A B C F 5 1200080426 12)
|
||||
(step C D A B F 6 2821735955 17)
|
||||
(step B C D A F 7 4249261313 22)
|
||||
(step A B C D F 8 1770035416 7)
|
||||
(step D A B C F 9 2336552879 12)
|
||||
(step C D A B F 10 4294925233 17)
|
||||
(step B C D A F 11 2304563134 22)
|
||||
(step A B C D F 12 1804603682 7)
|
||||
(step D A B C F 13 4254626195 12)
|
||||
(step C D A B F 14 2792965006 17)
|
||||
(step B C D A F 15 1236535329 22)
|
||||
;;---
|
||||
(step A B C D G 1 4129170786 5)
|
||||
(step D A B C G 6 3225465664 9)
|
||||
(step C D A B G 11 643717713 14)
|
||||
(step B C D A G 0 3921069994 20)
|
||||
(step A B C D G 5 3593408605 5)
|
||||
(step D A B C G 10 38016083 9)
|
||||
(step C D A B G 15 3634488961 14)
|
||||
(step B C D A G 4 3889429448 20)
|
||||
(step A B C D G 9 568446438 5)
|
||||
(step D A B C G 14 3275163606 9)
|
||||
(step C D A B G 3 4107603335 14)
|
||||
(step B C D A G 8 1163531501 20)
|
||||
(step A B C D G 13 2850285829 5)
|
||||
(step D A B C G 2 4243563512 9)
|
||||
(step C D A B G 7 1735328473 14)
|
||||
(step B C D A G 12 2368359562 20)
|
||||
;;---
|
||||
(step A B C D H 5 4294588738 4)
|
||||
(step D A B C H 8 2272392833 11)
|
||||
(step C D A B H 11 1839030562 16)
|
||||
(step B C D A H 14 4259657740 23)
|
||||
(step A B C D H 1 2763975236 4)
|
||||
(step D A B C H 4 1272893353 11)
|
||||
(step C D A B H 7 4139469664 16)
|
||||
(step B C D A H 10 3200236656 23)
|
||||
(step A B C D H 13 681279174 4)
|
||||
(step D A B C H 0 3936430074 11)
|
||||
(step C D A B H 3 3572445317 16)
|
||||
(step B C D A H 6 76029189 23)
|
||||
(step A B C D H 9 3654602809 4)
|
||||
(step D A B C H 12 3873151461 11)
|
||||
(step C D A B H 15 530742520 16)
|
||||
(step B C D A H 2 3299628645 23)
|
||||
;;---
|
||||
(step A B C D II 0 4096336452 6)
|
||||
(step D A B C II 7 1126891415 10)
|
||||
(step C D A B II 14 2878612391 15)
|
||||
(step B C D A II 5 4237533241 21)
|
||||
(step A B C D II 12 1700485571 6)
|
||||
(step D A B C II 3 2399980690 10)
|
||||
(step C D A B II 10 4293915773 15)
|
||||
(step B C D A II 1 2240044497 21)
|
||||
(step A B C D II 8 1873313359 6)
|
||||
(step D A B C II 15 4264355552 10)
|
||||
(step C D A B II 6 2734768916 15)
|
||||
(step B C D A II 13 1309151649 21)
|
||||
(step A B C D II 4 4149444226 6)
|
||||
(step D A B C II 11 3174756917 10)
|
||||
(step C D A B II 2 718787259 15)
|
||||
(step B C D A II 9 3951481745 21)
|
||||
;;---
|
||||
(loop (word+ A AA) (word+ B BB) (word+ C CC) (word+ D DD)
|
||||
b-port done)))))))
|
||||
|
||||
;; Each round consists of the application of the following
|
||||
;; basic functions. They functions on a word bitwise, as follows.
|
||||
;; F(X,Y,Z) = XY v not(X) Z (NB: or can be replaced with + in F)
|
||||
;; G(X,Y,Z) = XZ v Y not(Z)
|
||||
;; H(X,Y,Z) = X xor Y xor Z
|
||||
;; I(X,Y,Z) = Y xor (X v not(Z))
|
||||
|
||||
(define (F x y z) (word-or (word-and x y) (word-and (word-not x) z)))
|
||||
(define (G x y z) (word-or (word-and x z) (word-and y (word-not z))))
|
||||
(define (H x y z) (word-xor3 x y z))
|
||||
(define (II x y z) (word-xor y (word-or x (word-not z))))
|
||||
|
||||
;; Step 5 - Output
|
||||
;; To finish up, we convert the word to hexadecimal string
|
||||
;; - and make sure they end up in order.
|
||||
;; step5 : "(list word word word word)" -> string
|
||||
|
||||
(define (step5 l)
|
||||
|
||||
(define hex #(48 49 50 51 52 53 54 55 56 57 97 98 99 100 101 102))
|
||||
|
||||
(define (number->hex n)
|
||||
(bytes (vector-ref hex (quotient n 16))
|
||||
(vector-ref hex (modulo n 16))))
|
||||
|
||||
(apply bytes-append (map number->hex (apply append (map word->bytes l)))))
|
||||
|
||||
;(define (md5-test)
|
||||
; (if (and (equal? (md5 "")
|
||||
; "d41d8cd98f00b204e9800998ecf8427e")
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user