diff options
Diffstat (limited to 'ironclad/sha1.lisp')
| -rw-r--r-- | ironclad/sha1.lisp | 237 |
1 files changed, 237 insertions, 0 deletions
diff --git a/ironclad/sha1.lisp b/ironclad/sha1.lisp new file mode 100644 index 0000000..712cce8 --- /dev/null +++ b/ironclad/sha1.lisp @@ -0,0 +1,237 @@ +;;;; This is an implementation of the US Secure Hash Algorithm 1 (SHA1), +;;;; defined in RFC 3174, written by D. Eastlake and P. Jones, September +;;;; 2001. The RFC was based on the document "Secure Hash Standard", +;;;; United States of America, National Institute of Science and Technology, +;;;; Federal Information Processing Standard (FIPS) 180-1, April 1993. +;;;; +;;;; It was written by Nathan J. Froyd, with many of the main ideas and +;;;; functions grabbed from Pierre R. Mai's CL implementation of MD5, +;;;; available at http://www.pmsf.de/pmai/MD5.html. +;;;; +;;;; This implementation should work on any conforming Common Lisp +;;;; implementation, but it has been optimized for CMU CL and SBCL. +;;;; +;;;; The implementation makes heavy use of (UNSIGNED-BYTE 32) arithmetic; +;;;; if your CL implementation does not implement unboxed arithmetic on +;;;; such numbers, performance will likely be greater in a 16-bit +;;;; implementation. +;;;; +;;;; This software is "as is", and has no warranty of any kind. The +;;;; authors assume no responsibility for the consequences of any use +;;;; of this software. + +(in-package :crypto) + +;;; nonlinear functions + +(defconstant +k1+ #x5a827999) +(defconstant +k2+ #x6ed9eba1) +(defconstant +k3+ #x8f1bbcdc) +(defconstant +k4+ #xca62c1d6) + +;;; working set + +(define-digest-registers (sha1 :endian :big) + (a #x67452301) + (b #xefcdab89) + (c #x98badcfe) + (d #x10325476) + (e #xc3d2e1f0)) + +(defconst +pristine-sha1-registers+ (initial-sha1-regs)) + +(macrolet ((sha1-rounds (block func constant low high &rest initial-order) + ;; Yay for "implementation-dependent" behavior (6.1.1.4). + (let ((xvars (apply #'make-circular-list initial-order))) + (loop for i from low upto high + for vars on xvars by #'cddddr + collect (let ((a-var (first vars)) + (b-var (second vars)) + (c-var (third vars)) + (d-var (fourth vars)) + (e-var (fifth vars))) + `(setf ,e-var + (mod32+ (rol32 ,a-var 5) + (mod32+ (mod32+ (,func ,b-var ,c-var ,d-var) ,e-var) + (mod32+ (aref ,block ,i) ,constant))) + ,b-var (rol32 ,b-var 30))) into forms + finally (return `(progn ,@forms)))))) +(defun update-sha1-block (regs block) + (declare (type sha1-regs regs) + (type (simple-array (unsigned-byte 32) (80)) block) + #.(burn-baby-burn)) + (let ((a (sha1-regs-a regs)) (b (sha1-regs-b regs)) + (c (sha1-regs-c regs)) (d (sha1-regs-d regs)) + (e (sha1-regs-e regs))) + (flet ((f1 (x y z) + (declare (type (unsigned-byte 32) x y z)) + #+cmu + (kernel:32bit-logical-xor z + (kernel:32bit-logical-and x + (kernel:32bit-logical-xor y z))) + #-cmu + (logxor z (logand x (logxor y z)))) + (f2 (x y z) + (declare (type (unsigned-byte 32) x y z)) + #+cmu + (kernel:32bit-logical-xor x (kernel:32bit-logical-xor y z)) + #-cmu + (ldb (byte 32 0) (logxor x y z))) + (f3 (x y z) + (declare (type (unsigned-byte 32) x y z)) + #+cmu + (kernel:32bit-logical-or (kernel:32bit-logical-or + (kernel:32bit-logical-and x y) + (kernel:32bit-logical-and x z)) + (kernel:32bit-logical-and y z)) + #-cmu + (ldb (byte 32 0) + (logior (logand x y) (logand x z) (logand y z))))) + (declare (inline f1 f2 f3)) + ;; core of the algorithm + (sha1-rounds block f1 +k1+ 0 19 a b c d e) + (sha1-rounds block f2 +k2+ 20 39 a b c d e) + (sha1-rounds block f3 +k3+ 40 59 a b c d e) + (sha1-rounds block f2 +k4+ 60 79 a b c d e) + ;; update and return + (setf (sha1-regs-a regs) (mod32+ (sha1-regs-a regs) a) + (sha1-regs-b regs) (mod32+ (sha1-regs-b regs) b) + (sha1-regs-c regs) (mod32+ (sha1-regs-c regs) c) + (sha1-regs-d regs) (mod32+ (sha1-regs-d regs) d) + (sha1-regs-e regs) (mod32+ (sha1-regs-e regs) e)) + regs))) +) ; MACROLET + +(declaim (inline expand-block)) +(defun expand-block (block) + "Expand the first 16 words in BLOCK to fill the entire 80 word space +available." + (declare (type (simple-array (unsigned-byte 32) (80)) block) + #.(burn-baby-burn)) + (loop for i of-type (integer 16 80) from 16 below 80 + do (setf (aref block i) + (rol32 #+cmu + (kernel:32bit-logical-xor + (kernel:32bit-logical-xor (aref block (- i 3)) + (aref block (- i 8))) + (kernel:32bit-logical-xor (aref block (- i 14)) + (aref block (- i 16)))) + #-cmu + (ldb (byte 32 0) + (logxor (aref block (- i 3)) + (aref block (- i 8)) + (aref block (- i 14)) + (aref block (- i 16)))) + 1)))) + +;;; mid-level + +(defstruct (sha1 + (:constructor %make-sha1-digest) + (:constructor %make-sha1-state (regs amount block buffer buffer-index)) + (:copier nil)) + (regs (initial-sha1-regs) :type sha1-regs :read-only t) + (amount 0 :type (unsigned-byte 64)) + (block (make-array 80 :element-type '(unsigned-byte 32)) + :type (simple-array (unsigned-byte 32) (80)) :read-only t) + (buffer (make-array 64 :element-type '(unsigned-byte 8)) + :type (simple-array (unsigned-byte 8) (64)) :read-only t) + (buffer-index 0 :type (integer 0 63))) + +(defmethod reinitialize-instance ((state sha1) &rest initargs) + (declare (ignore initargs)) + (replace (sha1-regs state) +pristine-sha1-registers+) + (setf (sha1-amount state) 0 + (sha1-buffer-index state) 0) + state) + +(defmethod copy-digest ((state sha1) &optional copy) + (declare (type (or cl:null sha1) copy)) + (cond + (copy + (replace (sha1-regs copy) (sha1-regs state)) + (replace (sha1-buffer copy) (sha1-buffer state)) + (setf (sha1-amount copy) (sha1-amount state) + (sha1-buffer-index copy) (sha1-buffer-index state)) + copy) + (t + (%make-sha1-state (copy-seq (sha1-regs state)) + (sha1-amount state) + (copy-seq (sha1-block state)) + (copy-seq (sha1-buffer state)) + (sha1-buffer-index state))))) + +(define-digest-updater sha1 + (let ((regs (sha1-regs state)) + (block (sha1-block state)) + (buffer (sha1-buffer state)) + (buffer-index (sha1-buffer-index state)) + (length (- end start))) + (declare (type sha1-regs regs) (type fixnum length) + (type (integer 0 63) buffer-index) + (type (simple-array (unsigned-byte 32) (80)) block) + (type (simple-array (unsigned-byte 8) (64)) buffer)) + ;; Handle old rest + (unless (zerop buffer-index) + (let ((amount (min (- 64 buffer-index) length))) + (declare (type (integer 0 63) amount)) + (copy-to-buffer sequence start amount buffer buffer-index) + (setq start (the fixnum (+ start amount))) + (let ((new-index (mod (+ buffer-index amount) 64))) + (when (zerop new-index) + (fill-block-ub8-be block buffer 0) + (expand-block block) + (update-sha1-block regs block)) + (when (>= start end) + (setf (sha1-buffer-index state) new-index) + (incf (sha1-amount state) length) + (return-from update-digest state))))) + (loop for offset of-type index from start below end by 64 + until (< (- end offset) 64) + do + (fill-block-ub8-be block sequence offset) + (expand-block block) + (update-sha1-block regs block) + finally + (let ((amount (- end offset))) + (unless (zerop amount) + (copy-to-buffer sequence offset amount buffer 0)) + (setf (sha1-buffer-index state) amount))) + (incf (sha1-amount state) length) + state)) + +(define-digest-finalizer (sha1 20) + (let ((regs (sha1-regs state)) + (block (sha1-block state)) + (buffer (sha1-buffer state)) + (buffer-index (sha1-buffer-index state)) + (total-length (* 8 (sha1-amount state)))) + (declare (type sha1-regs regs) + (type (integer 0 63) buffer-index) + (type (simple-array (unsigned-byte 32) (80)) block) + (type (simple-array (unsigned-byte 8) (64)) buffer)) + (setf (aref buffer buffer-index) #x80) + (when (> buffer-index 55) + (loop for index of-type (integer 0 64) + from (1+ buffer-index) below 64 + do (setf (aref buffer index) #x00)) + (fill-block-ub8-be block buffer 0) + (expand-block block) + (update-sha1-block regs block) + (loop for index of-type (integer 0 16) + from 0 below 16 + do (setf (aref block index) #x00000000))) + (when (<= buffer-index 55) + (loop for index of-type (integer 0 64) + from (1+ buffer-index) below 64 + do (setf (aref buffer index) #x00)) + ;; copy the data to BLOCK prematurely + (fill-block-ub8-be block buffer 0)) + ;; fill in the remaining block data + (store-data-length block total-length 14 t) + (expand-block block) + (update-sha1-block regs block) + (finalize-registers state regs))) + +(defdigest sha1 :digest-length 20 :block-length 64) + |