;;;; 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)