suzanne.soy/racket
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
This commit is contained in:
Matthew Flatt 2006-02-11 05:35:35 +00:00
parent 17e10b396e
commit a59d668f6d
1 changed files with 485 additions and 419 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

922
collects/mzlib/md5.ss
View File

@ -1,433 +1,499 @@
(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
;;; Summary ; - Now it accepts a port or a string as input
; This is an implementation of the md5 message-digest algorithm ; - Doesn't explode when handed large strings anymore
; in R5RS Scheme. The algorithm takes an arbitrary string and ; - Now much slower
; returns a 128-bit "fingerprint".
; The algorithm was invented by Ron Rivest, RSA Security, INC. ; 2-10-2006 / Matthew
; Reference: RFC 1321, <http://www.faqs.org/rfcs/rfc1321.html> ; - Cleaned up a little
; - Despite comment above, it seems consistently faster
;;; Contact
; Email jensaxel@soegaard.net if you have problems,
; suggestions, code for 32 bit arithmetic for your ;;; Summary
; favorite implementation. ; This is an implementation of the md5 message-digest algorithm
; Check <http://www.scheme.dk/md5/> for new versions. ; in R5RS Scheme. The algorithm takes an arbitrary string and
; returns a 128-bit "fingerprint".
;;; Technicalities ; The algorithm was invented by Ron Rivest, RSA Security, INC.
; The algorithm is designed to be efficiently implemented ; Reference: RFC 1321, <http://www.faqs.org/rfcs/rfc1321.html>
; using 32 bit arithmetic. If your implementation supports
; 32 bit arithmetic directly, you should substitute the ;;; Contact
; portable 32 operations with primitives of your implementation. ; Email jensaxel@soegaard.net if you have problems,
; See the PLT version below for an example. ; suggestions, code for 32 bit arithmetic for your
; favorite implementation.
;;; Word aritmetic (32 bit) ; Check <http://www.scheme.dk/md5/> for new versions.
; Terminology
; word: 32 bit unsigned integer ;;; Technicalities
; byte: 8 bit unsigned integer ; The algorithm is designed to be efficiently implemented
; using 32 bit arithmetic. If your implementation supports
(define md5 'undefined) ; 32 bit arithmetic directly, you should substitute the
; portable 32 operations with primitives of your implementation.
; (word c) turns into a quoted pair '(hi . lo). I would have this local to the ; See the PLT version below for an example.
; let below except Twobit does not allow transformer to be used with let-syntax,
; only with define-syntax. ;;; Word aritmetic (32 bit)
; Terminology
;(define-syntax word ; word: 32 bit unsigned integer
; (transformer ; byte: 8 bit unsigned integer
; (lambda (expr rename compare)
; (list 'quote (cons (quotient (cadr expr) 65536) (remainder (cadr expr) 65536)))))) (define md5 'undefined)
(define-syntax word ; (word c) turns into a quoted pair '(hi . lo). I would have this local to the
(syntax-rules () ; let below except Twobit does not allow transformer to be used with let-syntax,
[(word c) ; only with define-syntax.
(cons (quotient c 65536) (remainder c 65536))]))
;(define-syntax word
; (transformer
(let () ; (lambda (expr rename compare)
; (list 'quote (cons (quotient (cadr expr) 65536) (remainder (cadr expr) 65536))))))
;;; PORTING NOTES
(define-syntax word
; logand is bitwise "and" on fixnums (syntax-rules ()
; logior is bitwise "inclusive or" on fixnums [(word c)
; logxor is bitwise "exclusive or" on fixnums (cons (quotient c 65536) (remainder c 65536))]))
; lognot is bitwise "not" on fixnums
; lsh is bitwise left-shift without overflow detection on fixnums (let ()
; rshl is bitwise logical right-shift on fixnums. Arithmetic
; right shift (rsha in Larceny) can be used instead of rshl ;;; PORTING NOTES
; in this code
; logand is bitwise "and" on fixnums
; PLT versions of the Larceny primitives ; logior is bitwise "inclusive or" on fixnums
(define-syntax fixnum? (syntax-rules () [(_ n) #t])) ; logxor is bitwise "exclusive or" on fixnums
(define-syntax logand (syntax-rules () [(_ . more) (bitwise-and . more)])) ; lognot is bitwise "not" on fixnums
(define-syntax logior (syntax-rules () [(_ . more) (bitwise-ior . more)])) ; lsh is bitwise left-shift without overflow detection on fixnums
(define-syntax logxor (syntax-rules () [(_ . more) (bitwise-xor . more)])) ; rshl is bitwise logical right-shift on fixnums. Arithmetic
(define-syntax lognot (syntax-rules () [(_ . more) (bitwise-not . more)])) ; right shift (rsha in Larceny) can be used instead of rshl
(define-syntax lsh (syntax-rules () [(_ n s) (arithmetic-shift n s)])) ; in this code
(define-syntax rshl (syntax-rules () [(_ n s) (arithmetic-shift n (- s))]))
; PLT versions of the Larceny primitives
; Words are represented as a cons where the car holds the high 16 (define-syntax fixnum? (syntax-rules () [(_ n) #t]))
; bits and the cdr holds the low 16 bits. Most good Scheme systems (define-syntax logand (syntax-rules () [(_ . more) (bitwise-and . more)]))
; will have fixnums that hold at least 16 bits as well as fast (define-syntax logior (syntax-rules () [(_ . more) (bitwise-ior . more)]))
; allocation, so this has a fair chance at beating bignums for (define-syntax logxor (syntax-rules () [(_ . more) (bitwise-xor . more)]))
; performance. (define-syntax lognot (syntax-rules () [(_ . more) (bitwise-not . more)]))
(define-syntax lsh (syntax-rules () [(_ n s) (arithmetic-shift n s)]))
(define (integer->word i) (define-syntax rshl (syntax-rules () [(_ n s) (arithmetic-shift n (- s))]))
(if (or (and (fixnum? i) (>= i 0))
(<= 0 i 4294967296)) ; Words are represented as a cons where the car holds the high 16
(cons (quotient i 65536) (remainder i 65536)) ; bits and the cdr holds the low 16 bits. Most good Scheme systems
(error "integer->word: out of range: " i))) ; will have fixnums that hold at least 16 bits as well as fast
; allocation, so this has a fair chance at beating bignums for
(define (word->integer w) ; performance.
(+ (* (car w) 65536) (cdr w)))
(define (integer->word i)
(define (word+ a b) (if (or (and (fixnum? i) (>= i 0))
(let ((t1 (+ (car a) (car b))) (<= 0 i 4294967296))
(t2 (+ (cdr a) (cdr b)))) (cons (quotient i 65536) (remainder i 65536))
(cons (logand (+ t1 (rshl t2 16)) 65535) (error "integer->word: out of range: " i)))
(logand t2 65535))))
(define (word->integer w)
(define (word-or a b) (+ (* (car w) 65536) (cdr w)))
(cons (logior (car a) (car b))
(logior (cdr a) (cdr b)))) (define (word+ a b)
(let ((t1 (+ (car a) (car b)))
(define (word-not a) (t2 (+ (cdr a) (cdr b))))
(cons (logand (lognot (car a)) 65535) (logand (lognot (cdr a)) 65535))) (cons (logand (+ t1 (rshl t2 16)) 65535)
(logand t2 65535))))
(define (word-xor a b)
(cons (logxor (car a) (car b)) (logxor (cdr a) (cdr b)))) (define (word-or a b)
(cons (logior (car a) (car b))
(define (word-and a b) (logior (cdr a) (cdr b))))
(cons (logand (car a) (car b)) (logand (cdr a) (cdr b))))
(define (word-not a)
(define (word<<< a s) (cons (logand (lognot (car a)) 65535) (logand (lognot (cdr a)) 65535)))
(define masks
'#(#x0 #x1 #x3 #x7 #xF #x1F #x3F #x7F #xFF (define (word-xor a b)
#x1FF #x3FF #x7FF #xFFF #x1FFF #x3FFF #x7FFF #xFFFF)) (cons (logxor (car a) (car b)) (logxor (cdr a) (cdr b))))
(define (rot hi lo s)
(cons (logior (lsh (logand hi (vector-ref masks (- 16 s))) s) (define (word-and a b)
(logand (rshl lo (- 16 s)) (vector-ref masks s))) (cons (logand (car a) (car b)) (logand (cdr a) (cdr b))))
(logior (lsh (logand lo (vector-ref masks (- 16 s))) s)
(logand (rshl hi (- 16 s)) (vector-ref masks s))))) (define (word<<< a s)
(cond ((< 0 s 16) (define masks
(rot (car a) (cdr a) s)) '#(#x0 #x1 #x3 #x7 #xF #x1F #x3F #x7F #xFF
((< s 32) #x1FF #x3FF #x7FF #xFFF #x1FFF #x3FFF #x7FFF #xFFFF))
(rot (cdr a) (car a) (- s 16))) (define (rot hi lo s)
(else (cons (logior (lsh (logand hi (vector-ref masks (- 16 s))) s)
(error "word<<<: shift out of range: " s)))) (logand (rshl lo (- 16 s)) (vector-ref masks s)))
(logior (lsh (logand lo (vector-ref masks (- 16 s))) s)
;; word->bytes : word -> "(list byte byte byte byte)", little endian! (logand (rshl hi (- 16 s)) (vector-ref masks s)))))
(define (word->bytes w) (cond ((< 0 s 16)
(list (logand (cdr w) 255) (rot (car a) (cdr a) s))
(logand (rshl (cdr w) 8) 255) ((< s 32)
(logand (car w) 255) (rot (cdr a) (car a) (- s 16)))
(logand (rshl (car w) 8) 255))) (else
(error "word<<<: shift out of range: " s))))
(define (word.4+ a b c d)
(word+ (word+ (word+ a b) c) d)) ;; word->bytes : word -> "(list byte byte byte byte)", little endian!
(define (word->bytes w)
(define bitpos (list (logand (cdr w) 255)
'(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 (logand (rshl (cdr w) 8) 255)
26 27 28 29 30 31)) (logand (car w) 255)
(logand (rshl (car w) 8) 255)))
(define powers
'#(1 2 4 8 16 32 64 128 256 512 1024 2048 4096 8192 16384 32768 65536 (define (word.4+ a b c d)
131072 262144 524288 1048576 2097152 4194304 8388608 16777216 33554432 (word+ (word+ (word+ a b) c) d))
67108864 134217728 268435456 536870912 1073741824 2147483648
4294967296)) (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
;; word->bits : word -> (list (union 0 1)) 26 27 28 29 30 31))
(define (word->bits w)
(let ((w (word->integer w))) (define powers
(define (bit i) '#(1 2 4 8 16 32 64 128 256 512 1024 2048 4096 8192 16384 32768 65536
(remainder (quotient w (vector-ref powers i)) 2)) 131072 262144 524288 1048576 2097152 4194304 8388608 16777216 33554432
(map bit bitpos))) 67108864 134217728 268435456 536870912 1073741824 2147483648
4294967296))
;; bits->integer : (list (union 0 1)) -> integer
(define (bits->integer bs) ;; word->bits : word -> (list (union 0 1))
(apply + (map * bs (map (lambda (i) (vector-ref powers i)) bitpos)))) (define (word->bits w)
(let ((w (word->integer w)))
;; Bytes and words (define (bit i)
;; The least significant byte of a word is the first (remainder (quotient w (vector-ref powers i)) 2))
(map bit bitpos)))
;; bytes->word : (list byte*) -> word
(define (bytes->word bs) ;; bits->integer : (list (union 0 1)) -> integer
(define (bs->w akk mul bs) (define (bits->integer bs)
(if (null? bs) (apply + (map * bs (map (lambda (i) (vector-ref powers i)) bitpos))))
(integer->word akk)
(bs->w (+ akk (* (car bs) mul)) (* 256 mul) (cdr bs)))) ;; Bytes and words
(bs->w 0 1 bs)) ;; The least significant byte of a word is the first
;; bytes->words : (list byte) -> (list word) ;; bytes->word : (list byte*) -> word
(define (bytes->words bytes) (define (bytes->word bs)
(define (loop bs l) (define (bs->w akk mul bs)
(cond ((null? l) (list (bytes->word (reverse bs)))) (if (null? bs)
((< (length bs) 4) (loop (cons (car l) bs) (cdr l))) (integer->word akk)
(else (cons (bytes->word (reverse bs)) (bs->w (+ akk (* (car bs) mul)) (* 256 mul) (cdr bs))))
(loop '() l))))) (bs->w 0 1 bs))
(if (null? bytes)
'() ;; bytes->words : (list byte) -> (list word)
(loop '() bytes))) (define (bytes->words bytes)
(define (loop bs l)
;; string->bytes : string -> (list byte) (cond ((null? l) (list (bytes->word (reverse bs))))
(define (string->bytes s) ((< (length bs) 4) (loop (cons (car l) bs) (cdr l)))
(bytes->list s)) (else (cons (bytes->word (reverse bs))
(loop '() l)))))
;; List Helper (if (null? bytes)
;; block/list : list -> (values vector list) '()
;; return a vector of the first 16 elements of the list, (loop '() bytes)))
;; and the rest of the list
(define (block/list l) ;; string->bytes : string -> (list byte)
(let* (( v0 (car l)) ( l0 (cdr l)) (define (string->bytes s)
( v1 (car l0)) ( l1 (cdr l0)) (bytes->list s))
( v2 (car l1)) ( l2 (cdr l1)) ;; Converts a list of words to a vector, just like vector-from-string
( v3 (car l2)) ( l3 (cdr l2)) ;; vector-from-list: byte-string -> (vector ...)
( v4 (car l3)) ( l4 (cdr l3)) (define vector-from-list list->vector)
( v5 (car l4)) ( l5 (cdr l4))
( v6 (car l5)) ( l6 (cdr l5)) ;; Converts a byte string to a more useful vector
( v7 (car l6)) ( l7 (cdr l6)) ;; vector-from-string: byte string -> (vector ...)
( v8 (car l7)) ( l8 (cdr l7)) (define vector-from-string
( v9 (car l8)) ( l9 (cdr l8)) (lambda (l-raw)
(v10 (car l9)) (l10 (cdr l9)) (list->vector (bytes->words (string->bytes l-raw)))))
(v11 (car l10)) (l11 (cdr l10))
(v12 (car l11)) (l12 (cdr l11)) (define empty-port (open-input-bytes #""))
(v13 (car l12)) (l13 (cdr l12))
(v14 (car l13)) (l14 (cdr l13)) ;; List Helper
(v15 (car l14)) (l15 (cdr l14))) ;; block/list : a-port done-n -> (values vector a-port done-n)
(values (vector v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 v13 v14 v15) ;; reads 512 bytes from the port, turns them into a vector of 16 32-bit words
l15))) ;; when the port is exhausted it returns #f for the port and
;; the last few bytes padded
;; MD5
;; The algorithm consists of five steps. (define (block/list a-port done)
;; All we need to do, is to call them in order. (let* ((l-raw (read-bytes (/ 512 8) a-port)))
;; md5 : string -> string (cond
;; File size was a multiple of 512 bits, or we're doing one more round to
(define (md5-computation str) ;; add the correct padding from the short case
(step5 (step4 (step2 (* 8 (bytes-length str)) ((eof-object? l-raw)
(step1 (string->bytes str)))))) (if (zero? (modulo done (/ 512 8)))
;; The file is a multiple of 512 or was 0, so there hasn't been a
;; Step 1 - Append Padding Bits ;; chance to add the 1-bit pad, so we need to do a full pad
;; The message is padded so the length (in bits) becomes 448 modulo 512. (values (vector-from-list (step2 (* 8 done)
;; We allways append a 1 bit and then append the proper numbber of 0's. (step1 (string->bytes #""))))
;; NB: 448 bits is 14 words and 512 bits is 16 words #f
;; step1 : (list byte) -> (list byte) done)
;; We only enter this block when the previous block didn't have
(define (step1 message) ;; enough room to fit the 64-bit file length,
(let* ([z-b-t-a (modulo (- 448 (* 8 (length message))) 512)] ;; so we just add 448 bits of zeros and then the 64-bit file length (step2)
[zero-bits-to-append (if (zero? z-b-t-a) 512 z-b-t-a)]) (values (vector-from-list (step2 (* 8 done)
(append message (vector->list (make-vector (quotient 448 8) 0))))
(cons #x80 ; The byte containing the 1 bit => one less #f
; 0 byte to append done)))
(vector->list ;; We read exactly 512 bits, the algorythm proceeds as usual
(make-vector ((= (bytes-length l-raw) (/ 512 8))
(quotient (- zero-bits-to-append 1) 8) 0)))))) (values (vector-from-string l-raw) a-port (+ done (bytes-length l-raw))))
;; We read less than 512 bits, so the file has ended.
;; Step 2 - Append Length ;; However, we don't have enough room to add the correct trailer,
;; A 64 bit representation of the bit length b of the message before ;; so we add what we can, then go for one more round which will
;; the padding of step 1 is appended. Lower word first. ;; automatically fall into the (eof-object? case)
;; step2 : number (list byte) -> (list word) ((> (* 8 (bytes-length l-raw)) 446)
;; org-len is the length of the original message in number of bits (let ([done (+ done (bytes-length l-raw))])
(values (vector-from-list (step2 (* 8 done)
(define (step2 original-length padded-message) (step1 (string->bytes l-raw))))
(let* ((b original-length) empty-port
(lo (remainder b #x100000000)) done)))
(hi (remainder (quotient b #x100000000) #x100000000)))
(bytes->words ;; Returning a longer vector than we should, luckily it doesn't matter.
(append padded-message ;; We read less than 512 bits and there is enough room for the correct trailer.
(append (word->bytes (integer->word lo)) ;; Add trailer and bail
(word->bytes (integer->word hi))))))) (else
(let ([done (+ done (bytes-length l-raw))])
;; Step 3 - Initialize MD Buffer (values (vector-from-list (step2 (* 8 done)
;; These magic constants are used to initialize the loop (step1 (string->bytes l-raw))))
;; in step 4. #f
;; done))))))
;; word A: 01 23 45 67
;; word B: 89 ab cd ef ;(step2 (* 8 (bytes-length str))
;; word C: fe dc ba 98 ; (step1 (string->bytes str)))
;; word D: 76 54 32 10
;; Step 4 - Process Message in 16-Word Blocks ;; MD5
;; For each 16 word block, go through a round one to four. ;; The algorithm consists of five steps.
;; step4 : (list word) -> "(list word word word word)" ;; All we need to do, is to call them in order.
;; md5 : string -> string
(define (step4 message)
(define (md5-computation a-thing)
(let ((a-port (cond
(define (loop A B C D message) [(bytes? a-thing)
(if (null? message) (open-input-bytes a-thing)]
(list A B C D) [(input-port? a-thing)
(let-values (((X rest) (block/list message))) a-thing]
(let* ((AA A) (BB B) (CC C) (DD D) [else
(raise-type-error 'md5
(A (word+ B (word<<< (word.4+ A (F B C D) (vector-ref X 0) (word 3614090360)) 7))) "input-port or bytes"
(D (word+ A (word<<< (word.4+ D (F A B C) (vector-ref X 1) (word 3905402710)) 12))) a-thing)])))
(C (word+ D (word<<< (word.4+ C (F D A B) (vector-ref X 2) (word 606105819)) 17))) (step5 (step4 a-port))))
(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))) ;; Step 1 - Append Padding Bits
(D (word+ A (word<<< (word.4+ D (F A B C) (vector-ref X 5) (word 1200080426)) 12))) ;; The message is padded so the length (in bits) becomes 448 modulo 512.
(C (word+ D (word<<< (word.4+ C (F D A B) (vector-ref X 6) (word 2821735955)) 17))) ;; We allways append a 1 bit and then append the proper numbber of 0's.
(B (word+ C (word<<< (word.4+ B (F C D A) (vector-ref X 7) (word 4249261313)) 22))) ;; NB: 448 bits is 14 words and 512 bits is 16 words
(A (word+ B (word<<< (word.4+ A (F B C D) (vector-ref X 8) (word 1770035416)) 7))) ;; step1 : (list byte) -> (list byte)
(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))) (define (step1 message)
(B (word+ C (word<<< (word.4+ B (F C D A) (vector-ref X 11) (word 2304563134)) 22))) (let* ([z-b-t-a (modulo (- 448 (* 8 (length message))) 512)]
(A (word+ B (word<<< (word.4+ A (F B C D) (vector-ref X 12) (word 1804603682)) 7))) [zero-bits-to-append (if (zero? z-b-t-a) 512 z-b-t-a)])
(D (word+ A (word<<< (word.4+ D (F A B C) (vector-ref X 13) (word 4254626195)) 12))) (append message
(C (word+ D (word<<< (word.4+ C (F D A B) (vector-ref X 14) (word 2792965006)) 17))) (cons #x80 ; The byte containing the 1 bit => one less
(B (word+ C (word<<< (word.4+ B (F C D A) (vector-ref X 15) (word 1236535329)) 22))) ; 0 byte to append
(vector->list
(A (word+ B (word<<< (word.4+ A (G B C D) (vector-ref X 1) (word 4129170786)) 5))) (make-vector
(D (word+ A (word<<< (word.4+ D (G A B C) (vector-ref X 6) (word 3225465664)) 9))) (quotient (- zero-bits-to-append 1) 8) 0))))))
(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))) ;; Step 2 - Append Length
(A (word+ B (word<<< (word.4+ A (G B C D) (vector-ref X 5) (word 3593408605)) 5))) ;; A 64 bit representation of the bit length b of the message before
(D (word+ A (word<<< (word.4+ D (G A B C) (vector-ref X 10) (word 38016083)) 9))) ;; the padding of step 1 is appended. Lower word first.
(C (word+ D (word<<< (word.4+ C (G D A B) (vector-ref X 15) (word 3634488961)) 14))) ;; step2 : number (list byte) -> (list word)
(B (word+ C (word<<< (word.4+ B (G C D A) (vector-ref X 4) (word 3889429448)) 20))) ;; org-len is the length of the original message in number of bits
(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))) (define (step2 original-length padded-message)
(C (word+ D (word<<< (word.4+ C (G D A B) (vector-ref X 3) (word 4107603335)) 14))) (let* ((b original-length)
(B (word+ C (word<<< (word.4+ B (G C D A) (vector-ref X 8) (word 1163531501)) 20))) (lo (remainder b #x100000000))
(A (word+ B (word<<< (word.4+ A (G B C D) (vector-ref X 13) (word 2850285829)) 5))) (hi (remainder (quotient b #x100000000) #x100000000)))
(D (word+ A (word<<< (word.4+ D (G A B C) (vector-ref X 2) (word 4243563512)) 9))) (bytes->words
(C (word+ D (word<<< (word.4+ C (G D A B) (vector-ref X 7) (word 1735328473)) 14))) (append padded-message
(B (word+ C (word<<< (word.4+ B (G C D A) (vector-ref X 12) (word 2368359562)) 20))) (append (word->bytes (integer->word lo))
(word->bytes (integer->word hi)))))))
(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))) ;; Step 3 - Initialize MD Buffer
(C (word+ D (word<<< (word.4+ C (H D A B) (vector-ref X 11) (word 1839030562)) 16))) ;; These magic constants are used to initialize the loop
(B (word+ C (word<<< (word.4+ B (H C D A) (vector-ref X 14) (word 4259657740)) 23))) ;; in step 4.
(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))) ;; word A: 01 23 45 67
(C (word+ D (word<<< (word.4+ C (H D A B) (vector-ref X 7) (word 4139469664)) 16))) ;; word B: 89 ab cd ef
(B (word+ C (word<<< (word.4+ B (H C D A) (vector-ref X 10) (word 3200236656)) 23))) ;; word C: fe dc ba 98
(A (word+ B (word<<< (word.4+ A (H B C D) (vector-ref X 13) (word 681279174)) 4))) ;; word D: 76 54 32 10
(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))) ;; Step 4 - Process Message in 16-Word Blocks
(B (word+ C (word<<< (word.4+ B (H C D A) (vector-ref X 6) (word 76029189)) 23))) ;; For each 16 word block, go through a round one to four.
(A (word+ B (word<<< (word.4+ A (H B C D) (vector-ref X 9) (word 3654602809)) 4))) ;; step4 : (list word) -> "(list word word word word)"
(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))) (define (step4 a-port)
(B (word+ C (word<<< (word.4+ B (H C D A) (vector-ref X 2) (word 3299628645)) 23)))
(define (loop A B C D a-port done)
(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))) (if (not a-port)
(C (word+ D (word<<< (word.4+ C (II D A B) (vector-ref X 14) (word 2878612391)) 15))) (list A B C D)
(B (word+ C (word<<< (word.4+ B (II C D A) (vector-ref X 5) (word 4237533241)) 21))) (let-values (((X b-port done) (block/list a-port done)))
(A (word+ B (word<<< (word.4+ A (II B C D) (vector-ref X 12) (word 1700485571)) 6))) (if (not X)
(D (word+ A (word<<< (word.4+ D (II A B C) (vector-ref X 3) (word 2399980690)) 10))) (list A B C D)
(C (word+ D (word<<< (word.4+ C (II D A B) (vector-ref X 10) (word 4293915773)) 15))) (begin
(B (word+ C (word<<< (word.4+ B (II C D A) (vector-ref X 1) (word 2240044497)) 21))) (let* ((AA A)
(A (word+ B (word<<< (word.4+ A (II B C D) (vector-ref X 8) (word 1873313359)) 6))) (BB B)
(D (word+ A (word<<< (word.4+ D (II A B C) (vector-ref X 15) (word 4264355552)) 10))) (CC C)
(C (word+ D (word<<< (word.4+ C (II D A B) (vector-ref X 6) (word 2734768916)) 15))) (DD D)
(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))) (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 (II A B C) (vector-ref X 11) (word 3174756917)) 10))) (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 (II D A B) (vector-ref X 2) (word 718787259)) 15))) (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 (II C D A) (vector-ref X 9) (word 3951481745)) 21))) (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)))
(A (word+ A AA)) (D (word+ A (word<<< (word.4+ D (F A B C) (vector-ref X 5) (word 1200080426)) 12)))
(B (word+ B BB)) (C (word+ D (word<<< (word.4+ C (F D A B) (vector-ref X 6) (word 2821735955)) 17)))
(C (word+ C CC)) (B (word+ C (word<<< (word.4+ B (F C D A) (vector-ref X 7) (word 4249261313)) 22)))
(D (word+ D DD))) (A (word+ B (word<<< (word.4+ A (F B C D) (vector-ref X 8) (word 1770035416)) 7)))
(loop A B C D rest))))) (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)))
;; Step 3 :-) (magic constants) (B (word+ C (word<<< (word.4+ B (F C D A) (vector-ref X 11) (word 2304563134)) 22)))
(loop (word #x67452301) (word #xefcdab89) (word #x98badcfe) (word #x10325476) message)) (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)))
;; Each round consists of the application of the following (C (word+ D (word<<< (word.4+ C (F D A B) (vector-ref X 14) (word 2792965006)) 17)))
;; basic functions. They functions on a word bitwise, as follows. (B (word+ C (word<<< (word.4+ B (F C D A) (vector-ref X 15) (word 1236535329)) 22)))
;; 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) (A (word+ B (word<<< (word.4+ A (G B C D) (vector-ref X 1) (word 4129170786)) 5)))
;; H(X,Y,Z) = X xor Y xor Z (D (word+ A (word<<< (word.4+ D (G A B C) (vector-ref X 6) (word 3225465664)) 9)))
;; I(X,Y,Z) = Y xor (X v not(Z)) (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)))
(define (F x y z) (A (word+ B (word<<< (word.4+ A (G B C D) (vector-ref X 5) (word 3593408605)) 5)))
(word-or (word-and x y) (word-and (word-not x) z))) (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)))
(define (G x y z) (B (word+ C (word<<< (word.4+ B (G C D A) (vector-ref X 4) (word 3889429448)) 20)))
(word-or (word-and x z) (word-and y (word-not z)))) (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)))
(define (H x y z) (C (word+ D (word<<< (word.4+ C (G D A B) (vector-ref X 3) (word 4107603335)) 14)))
(word-xor x (word-xor y z))) (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)))
(define (II x y z) (D (word+ A (word<<< (word.4+ D (G A B C) (vector-ref X 2) (word 4243563512)) 9)))
(word-xor y (word-or x (word-not z)))) (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)))
;; Step 5 - Output
;; To finish up, we convert the word to hexadecimal string (A (word+ B (word<<< (word.4+ A (H B C D) (vector-ref X 5) (word 4294588738)) 4)))
;; - and make sure they end up in order. (D (word+ A (word<<< (word.4+ D (H A B C) (vector-ref X 8) (word 2272392833)) 11)))
;; step5 : "(list word word word word)" -> string (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)))
(define (step5 l) (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)))
(define hex #(48 49 50 51 52 53 54 55 56 57 97 98 99 100 101 102)) (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)))
(define (number->hex n) (D (word+ A (word<<< (word.4+ D (H A B C) (vector-ref X 0) (word 3936430074)) 11)))
(bytes (vector-ref hex (quotient n 16)) (C (word+ D (word<<< (word.4+ C (H D A B) (vector-ref X 3) (word 3572445317)) 16)))
(vector-ref hex (modulo n 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)))
(apply bytes-append (D (word+ A (word<<< (word.4+ D (H A B C) (vector-ref X 12) (word 3873151461)) 11)))
(map number->hex (C (word+ D (word<<< (word.4+ C (H D A B) (vector-ref X 15) (word 530742520)) 16)))
(apply append (map word->bytes l))))) (B (word+ C (word<<< (word.4+ B (H C D A) (vector-ref X 2) (word 3299628645)) 23)))
(set! md5 md5-computation)) (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)
)
;(define (md5-test) ;(define (md5-test)
; (if (and (equal? (md5 "") ; (if (and (equal? (md5 "")
@ -448,4 +514,4 @@
; 'failed)) ; 'failed))
; ;
;(md5-test) ;(md5-test)
) )