From 24a5d76473ba6eb07bc4225ae84c4249cf562b04 Mon Sep 17 00:00:00 2001 From: Jesse Off Date: Mon, 22 Jun 2020 14:20:15 -0700 Subject: [PATCH 1/4] Integrate a small (130 line) implementation of MD5 Creates a ql-md5 package with exported function "md5-file" that returns a hex string that can be compared with "string-equal" to verify against. New condition "corrupt-local-archive", potentially signaled from "check-local-archive-file" --- quicklisp/md5.lisp | 130 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 130 insertions(+) create mode 100644 quicklisp/md5.lisp diff --git a/quicklisp/md5.lisp b/quicklisp/md5.lisp new file mode 100644 index 0000000..05b6855 --- /dev/null +++ b/quicklisp/md5.lisp @@ -0,0 +1,130 @@ +;;;; md5.lisp + +(cl:in-package #:ql-md5) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *md5-t* + (make-array 64 :element-type '(unsigned-byte 32) + :initial-contents + (loop for i from 1 to 64 + collect (truncate (* 4294967296 (abs (sin (float i 0.0d0))))))))) + +(defun update-md5-block (regs block) + (declare (type (simple-array (unsigned-byte 32) (4)) regs) + (type (simple-array (unsigned-byte 32) (16)) block)) + (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)) + (logxor z (logand x (logxor y z)))) + (g (x y z) + (declare (type (unsigned-byte 32) x y z)) + (logxor y (logand z (logxor x y)))) + (h (x y z) + (declare (type (unsigned-byte 32) x y z)) + (logxor x y z)) + (i (x y z) + (declare (type (unsigned-byte 32) x y z)) + (ldb (byte 32 0) (logxor y (logorc2 x z)))) + (mod32+ (a b) + (declare (type (unsigned-byte 32) a b)) + (ldb (byte 32 0) (+ a b))) + (rol32 (a s) + (declare (type (unsigned-byte 32) a) + (type (integer 0 32) s)) + (logior (ldb (byte 32 0) (ash a s)) (ash a (- s 32))))) + (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) + ,(aref *md5-t* (1- 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)) + (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 (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 (* 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) + (let ((ret (make-array 16 :element-type '(unsigned-byte 8)))) + (dotimes (i 16) + (setf (aref ret i) + (ldb (byte 8 (* 8 (logand 3 i))) (aref regs (ash i -2))))) + (format nil "~(~{~2,'0x~}~)" (loop for x across ret collect x))))) + (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)) + (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))) From 6d9d2fd275b7579ca19e4143732b2719c17bd2e2 Mon Sep 17 00:00:00 2001 From: Jesse Off Date: Mon, 22 Jun 2020 14:31:45 -0700 Subject: [PATCH 2/4] Add MD5 checking --- quicklisp/dist.lisp | 18 +++++++++++++++++- quicklisp/package.lisp | 6 ++++++ quicklisp/quicklisp.asd | 1 + 3 files changed, 24 insertions(+), 1 deletion(-) 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/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") From 59c67cd18ddeb6d42e2abe45b08c917094ae21ac Mon Sep 17 00:00:00 2001 From: Jesse Off Date: Mon, 22 Jun 2020 22:04:49 -0700 Subject: [PATCH 3/4] Add decl's for speed optimization --- quicklisp/md5.lisp | 32 ++++++++++++++++++++++---------- 1 file changed, 22 insertions(+), 10 deletions(-) diff --git a/quicklisp/md5.lisp b/quicklisp/md5.lisp index 05b6855..2d3dfb4 100644 --- a/quicklisp/md5.lisp +++ b/quicklisp/md5.lisp @@ -9,31 +9,39 @@ (loop for i from 1 to 64 collect (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)) + (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)) - (logxor z (logand x (logxor 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)) - (logxor y (logand z (logxor x y)))) + (the (unsigned-byte 32) (logxor y (logand z (logxor x y))))) (h (x y z) (declare (type (unsigned-byte 32) x y z)) - (logxor x y z)) + (the (unsigned-byte 32) (logxor x y z))) (i (x y z) (declare (type (unsigned-byte 32) x y z)) - (ldb (byte 32 0) (logxor y (logorc2 x z)))) + (the (unsigned-byte 32) (ldb (byte 32 0) (logxor y (logorc2 x z))))) (mod32+ (a b) (declare (type (unsigned-byte 32) a b)) - (ldb (byte 32 0) (+ 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)) - (logior (ldb (byte 32 0) (ash a s)) (ash a (- s 32))))) + (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 @@ -78,7 +86,8 @@ (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)) + (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))) @@ -90,13 +99,13 @@ a lexical closure with the same arg signature to be called for continuation." (labels ((inp (x) (declare (type (unsigned-byte 8) x)) - (setf wip (logior (ash x 24) (ash wip -8))) + (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 (* 8 len))) + (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) @@ -120,6 +129,9 @@ a lexical closure with the same arg signature to be called for continuation." (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))) From 0b8e64e2c0595b513a8335115e6991c428215b82 Mon Sep 17 00:00:00 2001 From: Jesse Off Date: Tue, 23 Jun 2020 13:34:40 -0700 Subject: [PATCH 4/4] Dont use a defparameter for MD5 table Avoid needless loadtime (re)calculation and storage of MD5 T table. Keeps the fasl load time minimal. T table is only needed for macroexpansion. --- quicklisp/md5.lisp | 32 ++++++++++---------------------- 1 file changed, 10 insertions(+), 22 deletions(-) diff --git a/quicklisp/md5.lisp b/quicklisp/md5.lisp index 2d3dfb4..f6380c4 100644 --- a/quicklisp/md5.lisp +++ b/quicklisp/md5.lisp @@ -3,11 +3,7 @@ (cl:in-package #:ql-md5) (eval-when (:compile-toplevel :load-toplevel :execute) - (defparameter *md5-t* - (make-array 64 :element-type '(unsigned-byte 32) - :initial-contents - (loop for i from 1 to 64 - collect (truncate (* 4294967296 (abs (sin (float i 0.0d0))))))))) + (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)) @@ -15,8 +11,7 @@ (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))) + (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)) @@ -34,8 +29,7 @@ (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)) + (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) @@ -47,8 +41,7 @@ collect `(setf ,a (mod32+ ,b (rol32 (mod32+ (mod32+ ,a (,op ,b ,c ,d)) - (mod32+ (aref ,block ,k) - ,(aref *md5-t* (1- i)))) + (mod32+ (aref ,block ,k) ,(md5-t i))) ,s))) into result finally (return `(progn ,@result))))) @@ -91,8 +84,7 @@ a lexical closure with the same arg signature to be called for continuation." (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)) + (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)) @@ -111,11 +103,9 @@ a lexical closure with the same arg signature to be called for continuation." (setf (aref tmpblk 14) (ldb (byte 32 0) nbits) (aref tmpblk 15) (ldb (byte 32 32) nbits)) (update-md5-block regs tmpblk) - (let ((ret (make-array 16 :element-type '(unsigned-byte 8)))) - (dotimes (i 16) - (setf (aref ret i) - (ldb (byte 8 (* 8 (logand 3 i))) (aref regs (ash i -2))))) - (format nil "~(~{~2,'0x~}~)" (loop for x across ret collect x))))) + (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)) @@ -127,11 +117,9 @@ a lexical closure with the same arg signature to be called for continuation." (defun md5-stream (stream) (let* ((buf (make-array #x10000 :element-type '(unsigned-byte 8))) - (idx (read-sequence buf stream)) - (process #'md5-seq)) + (idx (read-sequence buf stream)) (process #'md5-seq)) (declare (type (simple-array (unsigned-byte 8) (#x10000)) buf) - (type fixnum idx) - (type function process)) + (type fixnum idx) (type function process)) (loop until (< idx #x10000) do (setf process (funcall process buf) idx (read-sequence buf stream)))