;;;; ripemd-160.lisp -- the RIPEMD-160 digest function

(in-package :crypto)

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

(defun update-ripemd-160-block (regs block)
  (declare (type ripemd-160-regs regs)
           (type (simple-array (unsigned-byte 32) (16)) block)
           #.(burn-baby-burn))
  (let* ((a1 (ripemd-160-regs-a regs)) (a2 a1)
         (b1 (ripemd-160-regs-b regs)) (b2 b1)
         (c1 (ripemd-160-regs-c regs)) (c2 c1)
         (d1 (ripemd-160-regs-d regs)) (d2 d1)
         (e1 (ripemd-160-regs-e regs)) (e2 e1))
    (declare (type (unsigned-byte 32) a1 a2 b1 b2 c1 c2 d1 d2 e1 e2))
    (flet ((f (x y z)
             (declare (type (unsigned-byte 32) x y z))
             (ldb (byte 32 0) (logxor x y z)))
           (g (x y z)
             (declare (type (unsigned-byte 32) x y z))
             (ldb (byte 32 0) (logxor z (logand x (logxor y z)))))
           (h (x y z)
             (declare (type (unsigned-byte 32) x y z))
             (ldb (byte 32 0) (logxor z (logior x (lognot y)))))
           (i (x y z)
             (declare (type (unsigned-byte 32) x y z))
             (ldb (byte 32 0) (logxor y (logand z (logxor x y)))))
           (j (x y z)
             (declare (type (unsigned-byte 32) x y z))
             (ldb (byte 32 0) (logxor x (logior y (lognot z))))))
      (declare (inline f g h i j))
      (macrolet ((subround (func a b c d e x s k)
                   `(progn
                     (setf ,a (mod32+ ,a
                               (mod32+ (funcall (function ,func) ,b ,c ,d)
                                       (mod32+ ,x ,k))))
                     (setf ,a (mod32+ (rol32 ,a ,s) ,e))
                     (setf ,c (rol32 ,c 10))))
                 (with-ripemd-round ((block func constant) &rest clauses)
                   (loop for (a b c d e i s) in clauses
                         collect `(subround ,func ,a ,b ,c ,d ,e (aref ,block ,i)
                                   ,s ,constant)
                         into result
                         finally (return `(progn ,@result)))))
        (with-ripemd-round (block f 0)
          (a1 b1 c1 d1 e1  0 11) (e1 a1 b1 c1 d1  1 14)
          (d1 e1 a1 b1 c1  2 15) (c1 d1 e1 a1 b1  3 12)
          (b1 c1 d1 e1 a1  4  5) (a1 b1 c1 d1 e1  5  8)
          (e1 a1 b1 c1 d1  6  7) (d1 e1 a1 b1 c1  7  9)
          (c1 d1 e1 a1 b1  8 11) (b1 c1 d1 e1 a1  9 13)
          (a1 b1 c1 d1 e1 10 14) (e1 a1 b1 c1 d1 11 15)
          (d1 e1 a1 b1 c1 12  6) (c1 d1 e1 a1 b1 13  7)
          (b1 c1 d1 e1 a1 14  9) (a1 b1 c1 d1 e1 15  8))
        (with-ripemd-round (block g #x5a827999)
          (e1 a1 b1 c1 d1  7  7) (d1 e1 a1 b1 c1  4  6)
          (c1 d1 e1 a1 b1 13  8) (b1 c1 d1 e1 a1  1 13)
          (a1 b1 c1 d1 e1 10 11) (e1 a1 b1 c1 d1  6  9)
          (d1 e1 a1 b1 c1 15  7) (c1 d1 e1 a1 b1  3 15)
          (b1 c1 d1 e1 a1 12  7) (a1 b1 c1 d1 e1  0 12)
          (e1 a1 b1 c1 d1  9 15) (d1 e1 a1 b1 c1  5  9)
          (c1 d1 e1 a1 b1  2 11) (b1 c1 d1 e1 a1 14  7)
          (a1 b1 c1 d1 e1 11 13) (e1 a1 b1 c1 d1  8 12))
        (with-ripemd-round (block h #x6ed9eba1)
          (d1 e1 a1 b1 c1  3 11) (c1 d1 e1 a1 b1 10 13)
          (b1 c1 d1 e1 a1 14  6) (a1 b1 c1 d1 e1  4  7)
          (e1 a1 b1 c1 d1  9 14) (d1 e1 a1 b1 c1 15  9)
          (c1 d1 e1 a1 b1  8 13) (b1 c1 d1 e1 a1  1 15)
          (a1 b1 c1 d1 e1  2 14) (e1 a1 b1 c1 d1  7  8)
          (d1 e1 a1 b1 c1  0 13) (c1 d1 e1 a1 b1  6  6)
          (b1 c1 d1 e1 a1 13  5) (a1 b1 c1 d1 e1 11 12)
          (e1 a1 b1 c1 d1  5  7) (d1 e1 a1 b1 c1 12  5))
        (with-ripemd-round (block i #x8f1bbcdc)
          (c1 d1 e1 a1 b1  1 11) (b1 c1 d1 e1 a1  9 12)
          (a1 b1 c1 d1 e1 11 14) (e1 a1 b1 c1 d1 10 15)
          (d1 e1 a1 b1 c1  0 14) (c1 d1 e1 a1 b1  8 15)
          (b1 c1 d1 e1 a1 12  9) (a1 b1 c1 d1 e1  4  8)
          (e1 a1 b1 c1 d1 13  9) (d1 e1 a1 b1 c1  3 14)
          (c1 d1 e1 a1 b1  7  5) (b1 c1 d1 e1 a1 15  6)
          (a1 b1 c1 d1 e1 14  8) (e1 a1 b1 c1 d1  5  6)
          (d1 e1 a1 b1 c1  6  5) (c1 d1 e1 a1 b1  2 12))
        (with-ripemd-round (block j #xa953fd4e)
          (b1 c1 d1 e1 a1  4  9) (a1 b1 c1 d1 e1  0 15)
          (e1 a1 b1 c1 d1  5  5) (d1 e1 a1 b1 c1  9 11)
          (c1 d1 e1 a1 b1  7  6) (b1 c1 d1 e1 a1 12  8)
          (a1 b1 c1 d1 e1  2 13) (e1 a1 b1 c1 d1 10 12)
          (d1 e1 a1 b1 c1 14  5) (c1 d1 e1 a1 b1  1 12)
          (b1 c1 d1 e1 a1  3 13) (a1 b1 c1 d1 e1  8 14)
          (e1 a1 b1 c1 d1 11 11) (d1 e1 a1 b1 c1  6  8)
          (c1 d1 e1 a1 b1 15  5) (b1 c1 d1 e1 a1 13  6))
        (with-ripemd-round (block j #x50a28be6)
          (a2 b2 c2 d2 e2  5  8) (e2 a2 b2 c2 d2 14  9)
          (d2 e2 a2 b2 c2  7  9) (c2 d2 e2 a2 b2  0 11)
          (b2 c2 d2 e2 a2  9 13) (a2 b2 c2 d2 e2  2 15)
          (e2 a2 b2 c2 d2 11 15) (d2 e2 a2 b2 c2  4  5)
          (c2 d2 e2 a2 b2 13  7) (b2 c2 d2 e2 a2  6  7)
          (a2 b2 c2 d2 e2 15  8) (e2 a2 b2 c2 d2  8 11)
          (d2 e2 a2 b2 c2  1 14) (c2 d2 e2 a2 b2 10 14)
          (b2 c2 d2 e2 a2  3 12) (a2 b2 c2 d2 e2 12  6))
        (with-ripemd-round (block i #x5c4dd124)
          (e2 a2 b2 c2 d2  6  9) (d2 e2 a2 b2 c2 11 13)
          (c2 d2 e2 a2 b2  3 15) (b2 c2 d2 e2 a2  7  7)
          (a2 b2 c2 d2 e2  0 12) (e2 a2 b2 c2 d2 13  8)
          (d2 e2 a2 b2 c2  5  9) (c2 d2 e2 a2 b2 10 11)
          (b2 c2 d2 e2 a2 14  7) (a2 b2 c2 d2 e2 15  7)
          (e2 a2 b2 c2 d2  8 12) (d2 e2 a2 b2 c2 12  7)
          (c2 d2 e2 a2 b2  4  6) (b2 c2 d2 e2 a2  9 15)
          (a2 b2 c2 d2 e2  1 13) (e2 a2 b2 c2 d2  2 11))
        (with-ripemd-round (block h #x6d703ef3)
          (d2 e2 a2 b2 c2 15  9) (c2 d2 e2 a2 b2  5  7)
          (b2 c2 d2 e2 a2  1 15) (a2 b2 c2 d2 e2  3 11)
          (e2 a2 b2 c2 d2  7  8) (d2 e2 a2 b2 c2 14  6)
          (c2 d2 e2 a2 b2  6  6) (b2 c2 d2 e2 a2  9 14)
          (a2 b2 c2 d2 e2 11 12) (e2 a2 b2 c2 d2  8 13)
          (d2 e2 a2 b2 c2 12  5) (c2 d2 e2 a2 b2  2 14)
          (b2 c2 d2 e2 a2 10 13) (a2 b2 c2 d2 e2  0 13)
          (e2 a2 b2 c2 d2  4  7) (d2 e2 a2 b2 c2 13  5))
        (with-ripemd-round (block g #x7a6d76e9)
          (c2 d2 e2 a2 b2  8 15) (b2 c2 d2 e2 a2  6  5)
          (a2 b2 c2 d2 e2  4  8) (e2 a2 b2 c2 d2  1 11)
          (d2 e2 a2 b2 c2  3 14) (c2 d2 e2 a2 b2 11 14)
          (b2 c2 d2 e2 a2 15  6) (a2 b2 c2 d2 e2  0 14)
          (e2 a2 b2 c2 d2  5  6) (d2 e2 a2 b2 c2 12  9)
          (c2 d2 e2 a2 b2  2 12) (b2 c2 d2 e2 a2 13  9)
          (a2 b2 c2 d2 e2  9 12) (e2 a2 b2 c2 d2  7  5)
          (d2 e2 a2 b2 c2 10 15) (c2 d2 e2 a2 b2 14  8))
        (with-ripemd-round (block f 0)
          (b2 c2 d2 e2 a2 12  8) (a2 b2 c2 d2 e2 15  5)
          (e2 a2 b2 c2 d2 10 12) (d2 e2 a2 b2 c2  4  9)
          (c2 d2 e2 a2 b2  1 12) (b2 c2 d2 e2 a2  5  5)
          (a2 b2 c2 d2 e2  8 14) (e2 a2 b2 c2 d2  7  6)
          (d2 e2 a2 b2 c2  6  8) (c2 d2 e2 a2 b2  2 13)
          (b2 c2 d2 e2 a2 13  6) (a2 b2 c2 d2 e2 14  5)
          (e2 a2 b2 c2 d2  0 15) (d2 e2 a2 b2 c2  3 13)
          (c2 d2 e2 a2 b2  9 11) (b2 c2 d2 e2 a2 11 11))
        (setf c1 (mod32+ (ripemd-160-regs-b regs) (mod32+ c1 d2))
              (ripemd-160-regs-b regs) (mod32+ (ripemd-160-regs-c regs) (mod32+ d1 e2))
              (ripemd-160-regs-c regs) (mod32+ (ripemd-160-regs-d regs) (mod32+ e1 a2))
              (ripemd-160-regs-d regs) (mod32+ (ripemd-160-regs-e regs) (mod32+ a1 b2))
              (ripemd-160-regs-e regs) (mod32+ (ripemd-160-regs-a regs) (mod32+ b1 c2))
              (ripemd-160-regs-a regs) c1)
        regs))))

(declaim (inline ripemd-160-regs-digest))
(defun ripemd-160-regs-digest (regs)
  "Create the final 16 byte message-digest from the RIPEMD-160 working state
in regs.  Returns a (simple-array (unsigned-byte 8) (16))."
  (declare (type ripemd-160-regs regs)
           #.(burn-baby-burn))
  (let ((result (make-array 20 :element-type '(unsigned-byte 8))))
    (declare (type (simple-array (unsigned-byte 8) (20)) result))
    (macrolet ((frob (reg offset)
		 (let ((var (gensym)))
		   `(let ((,var ,reg))
		      (declare (type (unsigned-byte 32) ,var))
		      (setf
		       (aref result ,offset) (first-byte ,var)
		       (aref result ,(+ offset 1)) (second-byte ,var)
		       (aref result ,(+ offset 2)) (third-byte ,var)
		       (aref result ,(+ offset 3)) (fourth-byte ,var))))))
      (frob (ripemd-160-regs-a regs) 0)
      (frob (ripemd-160-regs-b regs) 4)
      (frob (ripemd-160-regs-c regs) 8)
      (frob (ripemd-160-regs-d regs) 12)
      (frob (ripemd-160-regs-e regs) 16))
    result))

(defstruct (ripemd-160-state
             (:constructor make-ripemd-160-state ())
             (:constructor %make-ripemd-160-state (regs amount block buffer buffer-index finalized-p))
             (:copier nil))
  (regs (initial-ripemd-160-regs) :type ripemd-160-regs :read-only t)
  (amount 0 :type (integer 0 *))
  (block (make-array 16 :element-type '(unsigned-byte 32)) :read-only t
         :type (simple-array (unsigned-byte 32) (16)))
  (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-ripemd-160-state (state)
  (declare (type ripemd-160-state state))
  (%make-ripemd-160-state (%copy-ripemd-160-regs (ripemd-160-state-regs state))
                          (ripemd-160-state-amount state)
                          (copy-seq (ripemd-160-state-block state))
                          (copy-seq (ripemd-160-state-buffer state))
                          (ripemd-160-state-buffer-index state)
                          (when (ripemd-160-state-finalized-p state)
                            (copy-seq (ripemd-160-state-finalized-p state)))))

(define-digest-updater ripemd-160
  "Update the given ripemd-160-state from sequence, which is either a
simple-string or a simple-array with element-type (unsigned-byte 8),
bounded by start and end, which must be numeric bounding-indices."
  (let ((regs (ripemd-160-state-regs state))
	(block (ripemd-160-state-block state))
	(buffer (ripemd-160-state-buffer state))
	(buffer-index (ripemd-160-state-buffer-index state))
	(length (- end start)))
    (declare (type ripemd-160-regs regs) (type fixnum length)
	     (type (integer 0 63) buffer-index)
	     (type (simple-array (unsigned-byte 32) (16)) 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-le block buffer 0)
            (update-ripemd-160-block regs block))
          (when (>= start end)
            (setf (ripemd-160-state-buffer-index state) new-index)
            (incf (ripemd-160-state-amount state) length)
            (return-from update-ripemd-160-state state)))))
    (loop for offset of-type (unsigned-byte 29) from start below end by 64
          until (< (- end offset) 64)
          do
          (fill-block-ub8-le block sequence offset)
          (update-ripemd-160-block regs block)
          finally
          (let ((amount (- end offset)))
            (unless (zerop amount)
              (copy-to-buffer sequence offset amount buffer 0))
            (setf (ripemd-160-state-buffer-index state) amount)))
    (incf (ripemd-160-state-amount state) length)
    state))

(define-digest-finalizer ripemd-160
  "If the given ripemd-160-state has not already been finalized, finalize it,
by processing any remaining input in its buffer, with suitable padding
and appended bit-length, as specified by the RIPEMD-160 standard.

The resulting RIPEMD-160 message-digest is returned as an array of twenty
(unsigned-byte 8) values.  Calling `update-ripemd-160-state' after a call to
`finalize-ripemd-160-state' results in unspecified behaviour."
  (or (ripemd-160-state-finalized-p state)
      (let ((regs (ripemd-160-state-regs state))
	    (block (ripemd-160-state-block state))
	    (buffer (ripemd-160-state-buffer state))
	    (buffer-index (ripemd-160-state-buffer-index state))
	    (total-length (* 8 (ripemd-160-state-amount state))))
	(declare (type ripemd-160-regs regs)
		 (type (integer 0 63) buffer-index)
		 (type (simple-array (unsigned-byte 32) (16)) block)
		 (type (simple-array (unsigned-byte 8) (*)) buffer))
	;; Add mandatory bit 1 padding
	(setf (aref buffer buffer-index) #x80)
	;; Fill with 0 bit padding
	(loop for index of-type (integer 0 64)
	      from (1+ buffer-index) below 64
	      do (setf (aref buffer index) #x00))
	(fill-block-ub8-le block buffer 0)
	;; Flush block first if length wouldn't fit
	(when (>= buffer-index 56)
	  (update-ripemd-160-block regs block)
	  ;; Create new fully 0 padded block
	  (loop for index of-type (integer 0 16) from 0 below 16
		do (setf (aref block index) #x00000000)))
	;; Add 64bit message bit length
	(setf (aref block 14) (ldb (byte 32 0) total-length))
	(setf (aref block 15) (ldb (byte 32 32) total-length))
	;; Flush last block
	(update-ripemd-160-block regs block)
	;; Done, remember digest for later calls
	(setf (ripemd-160-state-finalized-p state)
	      (ripemd-160-regs-digest regs)))))

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