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

(defstruct (sha1-regs
             (:type (vector (unsigned-byte 32)))
             (:constructor initial-sha1-regs ())
             (:copier %copy-sha1-regs))
  (a #x67452301)
  (b #xefcdab89)
  (c #x98badcfe)
  (d #x10325476)
  (e #xc3d2e1f0))
(deftype sha1-regs () '(simple-array (unsigned-byte 32) (5)))

(macrolet ((sha1-rounds (block func constant low high &rest initial-order)
             (let ((vars (apply #'make-circular-list initial-order)))
               (loop for i from low upto high
                     for vars on vars 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-or (kernel:32bit-logical-and x y)
                                      (kernel:32bit-logical-andc1 x z))
             #-cmu
             (ldb (byte 32 0) (logior (logand x y) (logandc1 x 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 fill-block fill-block-ub8 fill-block-char))
(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))))
    
(declaim (inline sha1regs-digest))
(defun sha1regs-digest (regs)
  "Create the final 20 byte message-digest from the SHA1 working state in
REGS.  Returns a (simple-array (unsigned-byte 8) (20))."
  (declare (type sha1-regs regs)
           #.(burn-baby-burn))
  (let ((result (make-array 20 :element-type '(unsigned-byte 8))))
    (declare (type (simple-array (unsigned-byte 8) (20)) result))
    (setf (ub32ref/be result 0) (sha1-regs-a regs)
          (ub32ref/be result 4) (sha1-regs-b regs)
          (ub32ref/be result 8) (sha1-regs-c regs)
          (ub32ref/be result 12) (sha1-regs-d regs)
          (ub32ref/be result 16) (sha1-regs-e regs))
    result))

;;; mid-level

(defstruct (sha1-state
             (:constructor make-sha1-state ())
             (:constructor %make-sha1-state (regs amount block buffer buffer-index finalized-p))
             (:copier nil))
  (regs (initial-sha1-regs) :type sha1-regs :read-only t)
  (amount 0 :type (unsigned-byte 64))   ; ugly bignums
  (block (make-array 80 :element-type '(unsigned-byte 32)) :read-only t
         :type (simple-array (unsigned-byte 32) (80)))
  (buffer (make-array 64 :element-type '(unsigned-byte 8)) :read-only t
          :type (simple-array (unsigned-byte 8) (64)))
  (buffer-index 0 :type (integer 0 63))
  (finalized-p nil))

(defun copy-sha1-state (state)
  (declare (type sha1-state state))
  (%make-sha1-state (%copy-sha1-regs (sha1-state-regs state))
                    (sha1-state-amount state)
                    (copy-seq (sha1-state-block state))
                    (copy-seq (sha1-state-buffer state))
                    (sha1-state-buffer-index state)
                    (when (sha1-state-finalized-p state)
                      (copy-seq (sha1-state-finalized-p state)))))

(define-digest-updater sha1
  (let ((regs (sha1-state-regs state))
        (block (sha1-state-block state))
        (buffer (sha1-state-buffer state))
        (buffer-index (sha1-state-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-state-buffer-index state) new-index)
            (incf (sha1-state-amount state) length)
            (return-from update-sha1-state state)))))
    (loop for offset of-type (unsigned-byte 29) 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-state-buffer-index state) amount)))
    (incf (sha1-state-amount state) length)
    state))

(define-digest-finalizer sha1
  (or (sha1-state-finalized-p state)
      (let ((regs (sha1-state-regs state))
	    (block (sha1-state-block state))
	    (buffer (sha1-state-buffer state))
	    (buffer-index (sha1-state-buffer-index state))
	    (total-length (* 8 (sha1-state-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 14)
                from 0 below 14
                do (setf (aref block index) #x00000000)))
        (when (<= buffer-index 55)
          (loop for index of-type (integer 0 56)
                from (1+ buffer-index) below 56
                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
        (setf (aref block 14) (ldb (byte 32 32) total-length)
              (aref block 15) (ldb (byte 32 0) total-length))
        (expand-block block)
	(update-sha1-block regs block)
	(setf (sha1-state-finalized-p state)
	      (sha1regs-digest regs)))))

(defdigest sha1
  (:digest-length 20)
  (:state-type sha1-state)
  (:creation-function make-sha1-state)
  (:copy-function copy-sha1-state)
  (:update-function update-sha1-state)
  (:finalize-function finalize-sha1-state))
