Integrate a small (130 line) implementation of MD5

quicklisp/dist.lisp

@@ -717,6 +717,14 @@ the given NAME."
              (badly-sized-local-archive-expected-size condition)
              (badly-sized-local-archive-actual-size condition)))))
 
+(define-condition corrupt-local-archive (invalid-local-archive)
+  ()
+  (:report
+   (lambda (condition stream)
+     (format stream "The archive file ~S for release ~S is corrupt"
+             (file-namestring (invalid-local-archive-file condition))
+             (name (invalid-local-archive-release condition))))))
+
 (defmethod check-local-archive-file ((release release))
   (let ((file (local-archive-file release)))
     (unless (probe-file file)
@@ -730,7 +738,15 @@ the given NAME."
                :file file
                :release release
                :actual-size actual-size
-               :expected-size expected-size)))))
+               :expected-size expected-size)))
+    (let ((actual-md5 (ql-md5:md5-file file))
+          (expected-md5 (archive-md5 release)))
+      (unless (string-equal actual-md5 expected-md5)
+        (error 'corrupt-local-archive
+               :file file
+               :release release
+               :actual-md5 actual-md5
+               :expected-md5 expected-md5)))))
 
 (defmethod local-archive-file ((release release))
   (relative-to (dist release)

quicklisp/md5.lisp

@@ -0,0 +1,130 @@
+;;;; md5.lisp
+
+(cl:in-package #:ql-md5)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun md5-t (i) (truncate (* 4294967296 (abs (sin (float i 0.0d0)))))))
+
+(declaim (ftype (function ((simple-array (unsigned-byte 32) (4)) (simple-array (unsigned-byte 32) (16)))
+                          (simple-array (unsigned-byte 32) (4))) update-md5-block))
+(defun update-md5-block (regs block)
+  (declare (type (simple-array (unsigned-byte 32) (4)) regs)
+           (type (simple-array (unsigned-byte 32) (16)) block)
+           (optimize (speed 3) (safety 0)))
+  (let ((a (aref regs 0)) (b (aref regs 1)) (c (aref regs 2)) (d (aref regs 3)))
+    (declare (type (unsigned-byte 32) a b c d))
+    (flet ((f (x y z)
+             (declare (type (unsigned-byte 32) x y z))
+             (the (unsigned-byte 32) (logxor z (logand x (logxor y z)))))
+           (g (x y z)
+             (declare (type (unsigned-byte 32) x y z))
+             (the (unsigned-byte 32) (logxor y (logand z (logxor x y)))))
+           (h (x y z)
+             (declare (type (unsigned-byte 32) x y z))
+             (the (unsigned-byte 32) (logxor x y z)))
+           (i (x y z)
+             (declare (type (unsigned-byte 32) x y z))
+             (the (unsigned-byte 32) (ldb (byte 32 0) (logxor y (logorc2 x z)))))
+           (mod32+ (a b)
+             (declare (type (unsigned-byte 32) a b))
+             (the (unsigned-byte 32) (ldb (byte 32 0) (+ a b))))
+           (rol32 (a s)
+             (declare (type (unsigned-byte 32) a) (type (integer 0 32) s))
+             (the (unsigned-byte 32) (logior (ldb (byte 32 0) (ash a s)) (ash a (- s 32))))))
+      (declare (ftype (function ((unsigned-byte 32) (unsigned-byte 32) (unsigned-byte 32))
+                                (unsigned-byte 32)) f g h i)
+               (ftype (function ((unsigned-byte 32) (unsigned-byte 32)) (unsigned-byte 32)) mod32+)
+               (ftype (function ((unsigned-byte 32) (integer 0 32)) (unsigned-byte 32)) rol32)
+               #-abcl(inline f g h i mod32+ rol32)) ;abcl has some problem with this inline decl
+      (macrolet ((with-md5-round ((op block) &rest clauses)
+                   (loop for (a b c d k s i) in clauses
+                         collect
+                         `(setf ,a (mod32+ ,b
+                                           (rol32 (mod32+ (mod32+ ,a (,op ,b ,c ,d))
+                                                          (mod32+ (aref ,block ,k) ,(md5-t i)))
+                                                  ,s)))
+                         into result
+                         finally (return `(progn ,@result)))))
+        ;; Round 1
+        (with-md5-round (f block)
+                        (a b c d  0  7  1)(d a b c  1 12  2)(c d a b  2 17  3)(b c d a  3 22  4)
+                        (a b c d  4  7  5)(d a b c  5 12  6)(c d a b  6 17  7)(b c d a  7 22  8)
+                        (a b c d  8  7  9)(d a b c  9 12 10)(c d a b 10 17 11)(b c d a 11 22 12)
+                        (a b c d 12  7 13)(d a b c 13 12 14)(c d a b 14 17 15)(b c d a 15 22 16))
+        ;; round 2
+        (with-md5-round (g block)
+                        (a b c d  1  5 17)(d a b c  6  9 18)(c d a b 11 14 19)(b c d a  0 20 20)
+                        (a b c d  5  5 21)(d a b c 10  9 22)(c d a b 15 14 23)(b c d a  4 20 24)
+                        (a b c d  9  5 25)(d a b c 14  9 26)(c d a b  3 14 27)(b c d a  8 20 28)
+                        (a b c d 13  5 29)(d a b c  2  9 30)(c d a b  7 14 31)(b c d a 12 20 32))
+        ;; round 3
+        (with-md5-round (h block)
+                        (a b c d  5  4 33)(d a b c  8 11 34)(c d a b 11 16 35)(b c d a 14 23 36)
+                        (a b c d  1  4 37)(d a b c  4 11 38)(c d a b  7 16 39)(b c d a 10 23 40)
+                        (a b c d 13  4 41)(d a b c  0 11 42)(c d a b  3 16 43)(b c d a  6 23 44)
+                        (a b c d  9  4 45)(d a b c 12 11 46)(c d a b 15 16 47)(b c d a  2 23 48))
+        ;; round 4
+        (with-md5-round (i block)
+                        (a b c d  0  6 49)(d a b c  7 10 50)(c d a b 14 15 51)(b c d a  5 21 52)
+                        (a b c d 12  6 53)(d a b c  3 10 54)(c d a b 10 15 55)(b c d a  1 21 56)
+                        (a b c d  8  6 57)(d a b c 15 10 58)(c d a b  6 15 59)(b c d a 13 21 60)
+                        (a b c d  4  6 61)(d a b c 11 10 62)(c d a b  2 15 63)(b c d a  9 21 64))
+        ;; Update and return
+        (setf (aref regs 0) (mod32+ (aref regs 0) a)
+              (aref regs 1) (mod32+ (aref regs 1) b)
+              (aref regs 2) (mod32+ (aref regs 2) c)
+              (aref regs 3) (mod32+ (aref regs 3) d))
+        regs))))
+
+(defun md5-seq (seq &key (start 0) end finalize)
+  "Takes in a octet vector and computes MD5.  When :finalize t, returns 16-byte array else returns
+a lexical closure with the same arg signature to be called for continuation."
+  (declare (type (simple-array (unsigned-byte 8) (*)) seq)
+           (optimize (speed 3) (safety 0)))
+  (let ((tmpblk (make-array 16 :element-type '(unsigned-byte 32)))
+        (regs (make-array 4 :element-type '(unsigned-byte 32)
+                            :initial-contents '(#x67452301 #xefcdab89 #x98badcfe #x10325476)))
+        (wip 0) (len 0))
+    (declare (type (unsigned-byte 32) wip) (type fixnum len)
+             (type (simple-array (unsigned-byte 32) (16)) tmpblk)
+             (type (simple-array (unsigned-byte 32) (4)) regs))
+    (labels
+        ((inp (x)
+           (declare (type (unsigned-byte 8) x))
+           (setf wip (the (unsigned-byte 32) (logior (ash x 24) (ash wip -8))))
+           (when (= 3 (logand 3 len))
+             (setf (aref tmpblk (logand #xf (ash len -2))) wip)
+             (when (= 63 (logand #x3f len)) (update-md5-block regs tmpblk)))
+           (setf len (1+ len)))
+         (fini ()
+           (let ((nbits (the (unsigned-byte 64) (* 8 len))))
+             (inp #x80)
+             (loop until (= (logand #x3f len) 56) do (inp 0))
+             (setf (aref tmpblk 14) (ldb (byte 32 0) nbits)
+                   (aref tmpblk 15) (ldb (byte 32 32) nbits))
+             (update-md5-block regs tmpblk)
+             (format nil "~(~{~2,'0x~}~)" (loop for i below 16
+                                                collect (ldb (byte 8 (* 8 (logand 3 i)))
+                                                             (aref regs (ash i -2)))))))
+         (process (seq &key (start 0) end finalize)
+           (declare (type (simple-array (unsigned-byte 8) (*)) seq))
+           (map nil #'inp (subseq seq start end))
+           (if finalize
+               (fini)
+               (lambda (seq &key (start 0) end finalize)
+                 (process seq :start start :end end :finalize finalize)))))
+      (process seq :start start :end end :finalize finalize))))
+
+(defun md5-stream (stream)
+  (let* ((buf (make-array #x10000 :element-type '(unsigned-byte 8)))
+         (idx (read-sequence buf stream)) (process #'md5-seq))
+    (declare (type (simple-array (unsigned-byte 8) (#x10000)) buf)
+             (type fixnum idx) (type function process))
+    (loop until (< idx #x10000) do
+      (setf process (funcall process buf)
+            idx (read-sequence buf stream)))
+    (funcall process buf :end idx :finalize t)))
+
+(defun md5-file (pathname)
+  (with-open-file (stream pathname :element-type '(unsigned-byte 8))
+    (md5-stream stream)))

quicklisp/package.lisp

@@ -128,6 +128,12 @@
   (:use #:cl)
   (:export #:gunzip))
 
+(defpackage #:ql-md5
+  (:documentation
+   "A simple implementation of md5.")
+  (:use #:cl)
+  (:export #:md5-file))
+
 (defpackage #:ql-cdb
   (:documentation
    "Read and write CDB files; code adapted from ZCDB.")

quicklisp/quicklisp.asd

@@ -22,6 +22,7 @@
                (:file "progress")
                (:file "http")
                (:file "deflate")
+               (:file "md5")
                (:file "minitar")
                (:file "cdb")
                (:file "dist")