Jepri's changes so that md5 works on ports

svn: r2194

collects/mzlib/md5.ss

@@ -1,4 +1,5 @@
 (module md5 mzscheme
+  
   (provide md5)
   
   ;;; -*- mode: scheme; mode: font-lock -*-
@@ -54,6 +55,15 @@
   ;    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
+  ;  - Cleaned up a little
+  ;  - Despite comment above, it seems consistently faster
   
   
   ;;; Summary
@@ -97,7 +107,6 @@
       [(word c)
        (cons (quotient c 65536) (remainder c 65536))]))
   
-
   (let ()
     
     ;;; PORTING NOTES
@@ -226,39 +235,88 @@
     ;; 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)))))
+
+    (define empty-port (open-input-bytes #""))
     
     ;; List Helper
-  ;; block/list : list -> (values vector list)
+    ;; block/list : a-port done-n -> (values vector a-port done-n)
-  ;; return a vector of the first 16 elements of the list,
+    ;; reads 512 bytes from the port, turns them into a vector of 16 32-bit words
-  ;;         and the rest of the list
+    ;; when the port is exhausted it returns #f for the port and
-  (define (block/list l)
+    ;; the last few bytes padded 
-    (let* (( v0 (car  l))  ( l0 (cdr l))
+    
-	   ( v1 (car l0))  ( l1 (cdr l0))
+    (define (block/list a-port done)
-	   ( v2 (car l1))  ( l2 (cdr l1))
+      (let* ((l-raw (read-bytes (/ 512 8) a-port)))
-	   ( v3 (car l2))  ( l3 (cdr l2))
+        (cond 
-	   ( v4 (car l3))  ( l4 (cdr l3))
+          ;; File size was a multiple of 512 bits, or we're doing one more round to
-	   ( v5 (car l4))  ( l5 (cdr l4))
+          ;; add the correct padding from the short case
-	   ( v6 (car l5))  ( l6 (cdr l5))
+          ((eof-object? l-raw)
-	   ( v7 (car l6))  ( l7 (cdr l6))
+           (if (zero? (modulo done (/ 512 8)))
-	   ( v8 (car l7))  ( l8 (cdr l7))
+               ;; The file is a multiple of 512 or was 0, so there hasn't been a 
-	   ( v9 (car l8))  ( l9 (cdr l8))
+               ;; chance to add the 1-bit pad, so we need to do a full pad
-	   (v10 (car l9))  (l10 (cdr l9))
+               (values (vector-from-list (step2 (* 8 done)
-	   (v11 (car l10)) (l11 (cdr l10))
+                                                (step1 (string->bytes #""))))                        
-	   (v12 (car l11)) (l12 (cdr l11))
+                       #f
-	   (v13 (car l12)) (l13 (cdr l12))
+                       done)
-	   (v14 (car l13)) (l14 (cdr l13))
+               ;; We only enter this block when the previous block didn't have
-	   (v15 (car l14)) (l15 (cdr l14)))
+               ;; enough room to fit the 64-bit file length,
-      (values (vector v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 v10 v11 v12 v13 v14 v15)
+               ;; so we just add 448 bits of zeros and then the 64-bit file length (step2)
-	      l15)))
+               (values (vector-from-list (step2 (* 8 done)
+                                                (vector->list (make-vector (quotient 448 8) 0)))) 
+                       #f
+                       done)))
+          ;; We read exactly 512 bits, the algorythm proceeds as usual
+          ((= (bytes-length l-raw) (/ 512 8))
+           (values (vector-from-string l-raw) a-port (+ done (bytes-length l-raw))))
+          ;; We read less than 512 bits, so the file has ended.  
+          ;; However, we don't have enough room to add the correct trailer,
+          ;; so we add what we can, then go for one more round which will
+          ;; automatically fall into the (eof-object? case)
+          ((> (* 8 (bytes-length l-raw)) 446)
+           (let ([done (+ done (bytes-length l-raw))])
+             (values (vector-from-list (step2 (* 8 done)
+                                              (step1 (string->bytes l-raw))))
+                     empty-port
+                     done)))
+          
+          ;; Returning a longer vector than we should, luckily it doesn't matter.
+          ;; We read less than 512 bits and there is enough room for the correct trailer.
+          ;; Add trailer and bail
+          (else
+           (let ([done (+ done (bytes-length l-raw))])
+             (values (vector-from-list (step2 (* 8 done)
+                                              (step1 (string->bytes l-raw))))
+                     #f
+                     done))))))
+    
+    ;(step2 (* 8 (bytes-length  str)) 
+    ;			 (step1 (string->bytes str)))
+    
     
     ;; MD5
     ;; The algorithm consists of five steps.
     ;; All we need to do, is to call them in order.
     ;; md5 : string -> string
     
-  (define (md5-computation str)
+    (define (md5-computation a-thing)
-    (step5 (step4 (step2 (* 8 (bytes-length str)) 
+      (let ((a-port (cond
-			 (step1 (string->bytes str))))))
+                      [(bytes? a-thing)
+                       (open-input-bytes a-thing)]
+                      [(input-port? a-thing)
+			a-thing]
+                      [else
+                       (raise-type-error 'md5
+                                         "input-port or bytes"
+                                         a-thing)])))
+	(step5 (step4 a-port))))
     
     ;; Step 1  -  Append Padding Bits
     ;; The message is padded so the length (in bits) becomes 448 modulo 512.
@@ -304,14 +362,20 @@
     ;; For each 16 word block, go through a round one to four.
     ;; step4 : (list word) -> "(list word word word word)"
     
-  (define (step4 message)
+    (define (step4 a-port)
       
+      (define (loop A B C D a-port done)
 
-    (define (loop A B C D message)
+        (if (not a-port)
-      (if (null? message)
             (list A B C D)
-	  (let-values (((X rest) (block/list message)))
+            (let-values (((X b-port done) (block/list a-port done)))
-	    (let* ((AA A) (BB B) (CC C) (DD D)
+              (if (not X)
+                  (list A B C D)
+                  (begin
+                    (let* ((AA A) 
+                           (BB B) 
+                           (CC C)
+                           (DD D)
                            
                            (A (word+ B (word<<< (word.4+ A (F B C D) (vector-ref X 0) (word 3614090360)) 7)))
                            (D (word+ A (word<<< (word.4+ D (F A B C) (vector-ref X 1) (word 3905402710)) 12)))
@@ -385,10 +449,12 @@
                            (B (word+ B BB))
                            (C (word+ C CC)) 
                            (D (word+ D DD)))
-	      (loop A B C D rest)))))
+                      
+                      (loop A B C D b-port done)))))))
         
       ;; Step 3 :-) (magic constants)
-    (loop (word #x67452301) (word #xefcdab89) (word #x98badcfe) (word #x10325476) message))
+      ;;    (display (format "Message is: ~a~n~n" message))
+      (loop (word #x67452301) (word #xefcdab89) (word #x98badcfe) (word #x10325476) a-port 0))
     
     ;; Each round consists of the application of the following
     ;; basic functions. They functions on a word bitwise, as follows.
@@ -426,8 +492,8 @@
       (apply bytes-append
              (map number->hex
                   (apply append (map word->bytes l)))))
-
+    (set! md5 md5-computation)
-  (set! md5 md5-computation))
+    )
   
 ;(define (md5-test)
 ;  (if (and (equal? (md5 "")