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

(in-package :crypto)

(define-digest-registers (ripemd-160 :endian :little)
  (a #x67452301)
  (b #xefcdab89)
  (c #x98badcfe)
  (d #x10325476)
  (e #xc3d2e1f0))

(defconst +pristine-ripemd-160-registers+ (initial-ripemd-160-regs))

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

(defstruct (ripemd-160
             (:constructor %make-ripemd-160-digest)
             (:constructor %make-ripemd-160-state (regs amount block buffer buffer-index))
             (:copier nil))
  (regs (initial-ripemd-160-regs) :type ripemd-160-regs :read-only t)
  (amount 0 :type (unsigned-byte 64))
  (block (make-array 16 :element-type '(unsigned-byte 32))
    :type (simple-array (unsigned-byte 32) (16)) :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 ripemd-160) &rest initargs)
  (declare (ignore initargs))
  (replace (ripemd-160-regs state) +pristine-ripemd-160-registers+)
  (setf (ripemd-160-amount state) 0
        (ripemd-160-buffer-index state) 0)
  state)

(defmethod copy-digest ((state ripemd-160) &optional copy)
  (declare (type (or cl:null ripemd-160) copy))
  (cond
    (copy
     (replace (ripemd-160-regs copy) (ripemd-160-regs state))
     (replace (ripemd-160-buffer copy) (ripemd-160-buffer state))
     (setf (ripemd-160-amount copy) (ripemd-160-amount state)
           (ripemd-160-buffer-index copy) (ripemd-160-buffer-index state))
     copy)
    (t
     (%make-ripemd-160-state (copy-seq (ripemd-160-regs state))
                             (ripemd-160-amount state)
                             (copy-seq (ripemd-160-block state))
                             (copy-seq (ripemd-160-buffer state))
                             (ripemd-160-buffer-index 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-regs state))
	(block (ripemd-160-block state))
	(buffer (ripemd-160-buffer state))
	(buffer-index (ripemd-160-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-buffer-index state) new-index)
            (incf (ripemd-160-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-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-buffer-index state) amount)))
    (incf (ripemd-160-amount state) length)
    state))

(define-digest-finalizer (ripemd-160 20)
  "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."
  (let ((regs (ripemd-160-regs state))
        (block (ripemd-160-block state))
        (buffer (ripemd-160-buffer state))
        (buffer-index (ripemd-160-buffer-index state))
        (total-length (* 8 (ripemd-160-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
    (store-data-length block total-length 14)
    ;; Flush last block
    (update-ripemd-160-block regs block)
    ;; Done, remember digest for later calls
    (finalize-registers state regs)))

(defdigest ripemd-160 :digest-length 20 :block-length 64)