From 6ebc7b5f6731793e0ab120ae3ae14651d76d49fa Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 15 Jan 2005 01:05:52 +0000 Subject: [PATCH] . original commit: 4954dabecb507014ab824728303bdc28b6c86fac --- collects/mzlib/md5.ss | 753 +++++++++++++++++++++--------------------- 1 file changed, 368 insertions(+), 385 deletions(-) diff --git a/collects/mzlib/md5.ss b/collects/mzlib/md5.ss index a3d0eb5..64cd26c 100644 --- a/collects/mzlib/md5.ss +++ b/collects/mzlib/md5.ss @@ -1,405 +1,412 @@ -;;; md5.scm -- Jens Axel Søgaard, 16 oct 2002 +(module md5 mzscheme + (provide md5) + +;;; -*- mode: scheme; mode: font-lock -*- +;;; +;;; 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 ;;; History - -; 14-10-2002 +; 14-10-2002 /jas ; - Bored. Initial attempt. Done. Well, except for faulty output. -; 15-10-2002 +; 15-10-2002 /jas ; - It works at last -; 16-10-2002 +; 16-10-2002 /jas ; - 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 +; or later required due to bignum bug) +; - 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 +; - Some cleanup of repeated computations +; - Moved test code to separate file +; 17-02-2003 / lth +; - Removed some of the indirection, for a 30% speedup in Larceny's +; interpreter. Running in the interpreter on my Dell Inspiron 4000 +; I get a fingerprint of "Lib/Common/bignums-be.sch" in about 63ms, +; which is slow but adequate. (The compiled version is not much +; faster -- most time is spent in bignum manipulation, which is +; compiled in either case. To do this well we must either operate +; on the bignum representation or redo the algorithm to use +; fixnums only.) +; 01-12-2003 / lth +; - Reimplemented word arithmetic to use two 16-bit fixnums boxed in +; a cons cell. In Petit Larceny's interpreter this gives a speedup +; of a factor of almost eight, and in addition this change translates +; well to other Scheme systems that support bit operations on fixnums. +; Only 17-bit (signed) fixnums are required. +; 23-12-2003 / jas +; - Trivial port to PLT. Rewrote the word macro to syntax-rules. +; Larceny primitives written as syntax-rules macros exanding +; to their PLT name. ;;; 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, ;;; Contact - ; Email jensaxel@soegaard.net if you have problems, ; suggestions, code for 32 bit arithmetic for your ; favorite implementation. - ; Check 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. ;;; Word aritmetic (32 bit) - ; Terminology - ; word: 32 bit unsigned integer ; byte: 8 bit unsigned integer -(module md5 mzscheme - (provide md5) +(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. + +;(define-syntax word +; (transformer +; (lambda (expr rename compare) +; (list 'quote (cons (quotient (cadr expr) 65536) (remainder (cadr expr) 65536)))))) + +(define-syntax word + (syntax-rules () + [(word c) + (cons (quotient c 65536) (remainder c 65536))])) + + +(let () + + ;;; PORTING NOTES - ;; mod32 : integer -> word - (define-syntax mod32 - (syntax-rules () - ((mod32 n) (modulo n 4294967296)))) - - ; word+ : word word -> word - (define (word+ w1 w2) - (mod32 (+ w1 w2))) - - ; word->bits : word -> (list (union 0 1)) + ; 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) - (define (bit i) - (modulo (quotient w (expt 2 i)) 2)) - (map bit (iota 0 31))) - - ; bits->integer : (list (union 0 1)) -> integer + (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) (expt 2 i)) - (iota 0 31))))) + (apply + (map * bs (map (lambda (i) (vector-ref powers i)) bitpos)))) - ; map-bitwise (bit -> bit) word word -> word - (define (map-bitwise f w1 w2) - (bits->integer (map f (word->bits w1) (word->bits w2)))) - - ;;; PLT-Versions (DrScheme, MzScheme) - - ; Remove the comments to use the PLT primitives. - - (define word-or bitwise-ior) - (define word-not bitwise-not) - (define word-xor bitwise-xor) - (define word-and bitwise-and) - (define (word<<< n s) - (bitwise-ior (arithmetic-shift n s) - (arithmetic-shift n (- s 32)))) - - ;;; Bytes and words - - ; The least significant byte of a word is the first - - ; bytes->word : (list byte*) -> word + ;; 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) - (cond - ((empty? bs) akk) - (else (bs->w (+ akk (* (first bs) mul)) (* 256 mul) (rest bs))))) + (if (null? bs) + (integer->word akk) + (bs->w (+ akk (* (car bs) mul)) (* 256 mul) (cdr bs)))) (bs->w 0 1 bs)) - - ; word->bytes : word -> "(list byte byte byte byte)" - (define (word->bytes word) - (define (extract w i) - (remainder (quotient w (expt 256 i)) 256)) - (list (extract word 0) (extract word 1) (extract word 2) (extract word 3))) - - ; bytes->words : (list byte) -> (list word) + + ;; bytes->words : (list byte) -> (list word) (define (bytes->words bytes) (define (loop bs l) - (cond - ((empty? l) (list (bytes->word (reverse bs)))) - ((< (length bs) 4) (loop (cons (first l) bs) (rest l))) - (else (cons (bytes->word (reverse bs)) (loop '() l))))) - (if (empty? bytes) - '() - (loop '() bytes))) - - ; string->bytes : string -> (list byte) + (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) - (map char->integer (string->list s))) - - - ;;; Personal idiosyncrasies - - ; These are all part of PLT Scheme. - ; Thus comment them out, if you use PLT. - - (define empty? null?) - (define rest cdr) - (define first car) - (define second cadr) - (define third caddr) - (define fourth cadddr) - - (define (iota m n) - (if (> m n) - '() - (cons m (iota (+ m 1) n)))) - - - ;;; List Helper - - ; block/list : list -> (values vector list) - ; return a vector of the first 16 elements of the list, - ; and the rest of the list + (bytes->list s)) + + ;; List Helper + ;; block/list : list -> (values vector list) + ;; return a vector of the first 16 elements of the list, + ;; and the rest of the list (define (block/list l) - (let* (( v0 (first l)) ( l0 (rest l)) - ( v1 (first l0)) ( l1 (rest l0)) - ( v2 (first l1)) ( l2 (rest l1)) - ( v3 (first l2)) ( l3 (rest l2)) - ( v4 (first l3)) ( l4 (rest l3)) - ( v5 (first l4)) ( l5 (rest l4)) - ( v6 (first l5)) ( l6 (rest l5)) - ( v7 (first l6)) ( l7 (rest l6)) - ( v8 (first l7)) ( l8 (rest l7)) - ( v9 (first l8)) ( l9 (rest l8)) - (v10 (first l9)) (l10 (rest l9)) - (v11 (first l10)) (l11 (rest l10)) - (v12 (first l11)) (l12 (rest l11)) - (v13 (first l12)) (l13 (rest l12)) - (v14 (first l13)) (l14 (rest l13)) - (v15 (first l14)) (l15 (rest l14))) + (let* (( v0 (car l)) ( l0 (cdr l)) + ( v1 (car l0)) ( l1 (cdr l0)) + ( v2 (car l1)) ( l2 (cdr l1)) + ( v3 (car l2)) ( l3 (cdr l2)) + ( v4 (car l3)) ( l4 (cdr l3)) + ( v5 (car l4)) ( l5 (cdr l4)) + ( v6 (car l5)) ( l6 (cdr l5)) + ( v7 (car l6)) ( l7 (cdr l6)) + ( v8 (car l7)) ( l8 (cdr l7)) + ( v9 (car l8)) ( l9 (cdr l8)) + (v10 (car l9)) (l10 (cdr l9)) + (v11 (car l10)) (l11 (cdr l10)) + (v12 (car l11)) (l12 (cdr l11)) + (v13 (car l12)) (l13 (cdr l12)) + (v14 (car l13)) (l14 (cdr l13)) + (v15 (car l14)) (l15 (cdr l14))) (values (vector v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 v13 v14 v15) - l15))) - - - ;;;;; MD5 - - ; The algorithm consists of five steps. - ; All we need to do, is to call them in order. - - ; md5 : byte-string -> byte-string - (define (md5 bstr) - (unless (bytes? bstr) - (raise-type-error 'md5 "byte string" bstr)) - (step5 (step4 (step2 (* 8 (bytes-length bstr)) - (step1 (bytes->list bstr)))))) - - - ;;; 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) + l15))) + + ;; MD5 + ;; The algorithm consists of five steps. + ;; All we need to do, is to call them in order. + ;; md5 : string -> string + + (define (md5-computation str) + (step5 (step4 (step2 (* 8 (bytes-length str)) + (step1 (string->bytes str)))))) + + ;; 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 ((zero-bits-to-append (modulo (- 448 (* 8 (length message))) 512))) (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 1is appended. Lower word first. - - ; step2 : number (list byte) -> (list word) - ; org-len is the length of the original message in number of bits + (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 1is 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 org-len padded-message) (let* ((b org-len) - (lo (mod32 b)) - (hi (mod32 (quotient b (expt 2 32))))) + (lo (remainder b #x100000000)) + (hi (remainder (quotient b #x100000000) #x100000000))) (bytes->words (append padded-message - (append (word->bytes lo) - (word->bytes 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)" + (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 message) (define (loop A B C D message) - (if (empty? message) - (list A B C D) - (let-values (((X rest) (block/list message))) - (let* ((result (apply round4 - (apply round3 - (apply round2 - (round1 A B C D X))))) - (A (word+ (list-ref result 0) A)) - (B (word+ (list-ref result 1) B)) - (C (word+ (list-ref result 2) C)) - (D (word+ (list-ref result 3) D))) - (loop A B C D rest))))) - - ; Step 3 :-) (magic constants) - (loop #x67452301 #xefcdab89 #x98badcfe #x10325476 message)) - - ; 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)) + (if (null? message) + (list A B C D) + (let-values (((X rest) (block/list message))) + (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 rest))))) + ;; Step 3 :-) (magic constants) + (loop (word #x67452301) (word #xefcdab89) (word #x98badcfe) (word #x10325476) message)) + + ;; 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)))) - - ; The rounds furthermore use values from this sine table, - ; which we precompute. - - (define T - (let* ((precompute (lambda (i) (inexact->exact (floor (* 4294967296 (abs (sin i))))))) - (v (list->vector (map precompute (iota 1 64))))) - (lambda (i) - (vector-ref v (- i 1))))) - - ; The rounds are specified using the notation (abcd k s i). - ; This is a shorthand for respectively: - - ; Round 1: a = b + ((a + F(b,c,d) + X(k) + T(i)) <<< s) - ; Round 2: a = b + ((a + G(b,c,d) + X(k) + T(i)) <<< s) - ; Round 3: a = b + ((a + H(b,c,d) + X(k) + T(i)) <<< s) - ; Round 4: a = b + ((a + I(b,c,d) + X(k) + T(i)) <<< s) - - ; Example: (DABC 1 12 2) in round 1 is shothand for this operation - ; D = A + ((D + F(A,B,C) + X(1) + T(2)) <<< 12) - - ; To use the specifications, we need to replace the symbols - ; with permutation vectors. - - ; prepare : operations -> operations' - ; symbols are substituted with indices, e.g. 'DABC |-> (list 3 0 1 2) - (define (prepare ops) - (define (symbol->indices s) - (list->vector (map (lambda (n) (- n (char->integer #\a))) - (map char->integer (string->list (symbol->string s)))))) - (map (lambda (l) - (cons (symbol->indices (first l)) (rest l))) - ops)) - - (define round1-operations - (prepare - '((abcd 0 7 1) (dabc 1 12 2) (cdab 2 17 3) (bcda 3 22 4) - (abcd 4 7 5) (dabc 5 12 6) (cdab 6 17 7) (bcda 7 22 8) - (abcd 8 7 9) (dabc 9 12 10) (cdab 10 17 11) (bcda 11 22 12) - (abcd 12 7 13) (dabc 13 12 14) (cdab 14 17 15) (bcda 15 22 16)))) - - (define round2-operations - (prepare - '((abcd 1 5 17) (dabc 6 9 18) (cdab 11 14 19) (bcda 0 20 20) - (abcd 5 5 21) (dabc 10 9 22) (cdab 15 14 23) (bcda 4 20 24) - (abcd 9 5 25) (dabc 14 9 26) (cdab 3 14 27) (bcda 8 20 28) - (abcd 13 5 29) (dabc 2 9 30) (cdab 7 14 31) (bcda 12 20 32)))) - - (define round3-operations - (prepare - '((abcd 5 4 33) (dabc 8 11 34) (cdab 11 16 35) (bcda 14 23 36) - (abcd 1 4 37) (dabc 4 11 38) (cdab 7 16 39) (bcda 10 23 40) - (abcd 13 4 41) (dabc 0 11 42) (cdab 3 16 43) (bcda 6 23 44) - (abcd 9 4 45) (dabc 12 11 46) (cdab 15 16 47) (bcda 2 23 48)))) - - (define round4-operations - (prepare - '((abcd 0 6 49) (dabc 7 10 50) (cdab 14 15 51) (bcda 5 21 52) - (abcd 12 6 53) (dabc 3 10 54) (cdab 10 15 55) (bcda 1 21 56) - (abcd 8 6 57) (dabc 15 10 58) (cdab 6 15 59) (bcda 13 21 60) - (abcd 4 6 61) (dabc 11 10 62) (cdab 2 15 63) (bcda 9 21 64)))) - - ; The operation without permutation is given by (respectively). - - (define (rf1 a b c d X k i s) - (word+ b (word<<< (word+ a (word+ (F b c d) (word+ (vector-ref X k) (T i)))) s))) - (define (rf2 a b c d X k i s) - (word+ b (word<<< (word+ a (word+ (G b c d) (word+ (vector-ref X k) (T i)))) s))) - (define (rf3 a b c d X k i s) - (word+ b (word<<< (word+ a (word+ (H b c d) (word+ (vector-ref X k) (T i)))) s))) - (define (rf4 a b c d X k i s) - (word+ b (word<<< (word+ a (word+ (II b c d) (word+ (vector-ref X k) (T i)))) s))) - - ; Uncomment these to see what happens in the rounds - ; (define (trace func name) - ; (lambda (a b c d X k i s) - ; (display (list name (hex a) (hex b) (hex c) (hex d) - ; (hex (vector-ref X k)) (hex (T i)) (hex s))) - ; (let ((r (func a b c d X k i s))) - ; (display " -> ") (display (hex r)) (newline) - ; r))) - ; - ; (define rf1 (trace rf1 'f)) - ; (define rf2 (trace rf2 'g)) - ; (define rf3 (trace rf3 'h)) - ; (define rf4 (trace rf4 'i)) - - ; To execute a round, one goes through the list of - ; operations. The above functions rf1,...,rf4 are called - ; after the permutation is done. - - (define (xround j a b c d X) - - (define (loop a b c d X rf ops) - (define (indirect v w i) - (vector-ref v (vector-ref w i))) - (if (empty? ops) - (list a b c d X) - (let* ((op (first ops)) - (indices (first op)) - (k (second op)) - (s (third op)) - (i (fourth op)) - ; permute - (v (vector a b c d)) - (a (indirect v indices 0)) - (b (indirect v indices 1)) - (c (indirect v indices 2)) - (d (indirect v indices 3)) - (a (rf a b c d X k i s))) - ; make the assignment - (vector-set! v (vector-ref indices 0) a) - (let ((a (vector-ref v 0)) - (b (vector-ref v 1)) - (c (vector-ref v 2)) - (d (vector-ref v 3))) - (apply loop (list a b c d X rf (rest ops))))))) - - (cond - ((= j 1) (loop a b c d X rf1 round1-operations)) - ((= j 2) (loop a b c d X rf2 round2-operations)) - ((= j 3) (loop a b c d X rf3 round3-operations)) - ((= j 4) (loop a b c d X rf4 round4-operations)))) - - ; For convenience in step 4: - - (define (round1 a b c d X) - (xround 1 a b c d X)) - (define (round2 a b c d X) - (xround 2 a b c d X)) - (define (round3 a b c d X) - (xround 3 a b c d X)) - (define (round4 a b c d X) - (xround 4 a b c d X)) - - - ;;; Step 5 - Output - - ; To finish up, we convert the word to hexadecimal string - ; - and make sure they end up in order. - - (define hex #(48 49 50 51 52 53 54 55 56 57 97 98 99 100 101 102)) - ; step5 : "(list word word word word)" -> string + ;; 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)))) @@ -407,50 +414,26 @@ (apply bytes-append (map number->hex (apply append (map word->bytes l))))) - - - ;;; Test - - ; Generic arithmetic - - ;'bytes->word - ;(and (= (bytes->word '(1 0 0 0)) 1) - ; (= (bytes->word '(0 0 0 128)) (expt 2 31))) - ; - ;'word->bytes - ;(and (equal? '(1 2 3 4) (word->bytes (bytes->word '(1 2 3 4))))) - ; - ;'word<<< - ;(and (= 123 (word<<< (word<<< 123 7) 25)) - ; (= 123 (word<<< (word<<< 123 0) 32)) - ; (= 123 (word<<< (word<<< 123 8) 24))) - ; - ;'word-not - ;(and (= (+ 0 (word-not 0)) - ; (+ 1 (word-not 1)))) - ; - ;(define (hex n) - ; (number->string n 16)) - - #; - (define (md5-test) - (if (and (equal? (md5 "") - "d41d8cd98f00b204e9800998ecf8427e") - (equal? (md5 "a") - "0cc175b9c0f1b6a831c399e269772661") - (equal? (md5 "abc") - "900150983cd24fb0d6963f7d28e17f72") - (equal? (md5 "message digest") - "f96b697d7cb7938d525a2f31aaf161d0") - (equal? (md5 "abcdefghijklmnopqrstuvwxyz") - "c3fcd3d76192e4007dfb496cca67e13b") - (equal? (md5 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789") - "d174ab98d277d9f5a5611c2c9f419d9f") - (equal? (md5 "12345678901234567890123456789012345678901234567890123456789012345678901234567890") - "57edf4a22be3c955ac49da2e2107b67a")) - 'passed - 'failed)) - - #; - (md5-test) - ) \ No newline at end of file + + (set! md5 md5-computation)) + +;(define (md5-test) +; (if (and (equal? (md5 "") +; "d41d8cd98f00b204e9800998ecf8427e") +; (equal? (md5 "a") +; "0cc175b9c0f1b6a831c399e269772661") +; (equal? (md5 "abc") +; "900150983cd24fb0d6963f7d28e17f72") +; (equal? (md5 "message digest") +; "f96b697d7cb7938d525a2f31aaf161d0") +; (equal? (md5 "abcdefghijklmnopqrstuvwxyz") +; "c3fcd3d76192e4007dfb496cca67e13b") +; (equal? (md5 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789") +; "d174ab98d277d9f5a5611c2c9f419d9f") +; (equal? (md5 "12345678901234567890123456789012345678901234567890123456789012345678901234567890") +; "57edf4a22be3c955ac49da2e2107b67a")) +; 'passed +; 'failed)) +; +;(md5-test) +)