diff --git a/quicklisp/dist.lisp b/quicklisp/dist.lisp index 72e21a7..ed48987 100644 --- a/quicklisp/dist.lisp +++ b/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) diff --git a/quicklisp/md5.lisp b/quicklisp/md5.lisp new file mode 100644 index 0000000..f6380c4 --- /dev/null +++ b/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))) diff --git a/quicklisp/package.lisp b/quicklisp/package.lisp index f0346e6..379e33c 100644 --- a/quicklisp/package.lisp +++ b/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.") diff --git a/quicklisp/quicklisp.asd b/quicklisp/quicklisp.asd index 158a1b4..b642921 100644 --- a/quicklisp/quicklisp.asd +++ b/quicklisp/quicklisp.asd @@ -22,6 +22,7 @@ (:file "progress") (:file "http") (:file "deflate") + (:file "md5") (:file "minitar") (:file "cdb") (:file "dist")