;;;; md4.lisp -- the MD4 digest algorithm as given in RFC1320

(in-package :crypto)

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

(defun update-md4-block (regs block)
  (declare (type md4-regs regs))
  (declare (type (simple-array (unsigned-byte 32) (16)) block)
           #.(burn-baby-burn))
  (let ((a (md4-regs-a regs))
        (b (md4-regs-b regs))
        (c (md4-regs-c regs))
        (d (md4-regs-d regs)))
    (declare (type (unsigned-byte 32) a b c d))
    (flet ((f (x y z)
             (declare (type (unsigned-byte 32) x y z))
             (logior (logand x y) (logandc1 x z)))
           (g (x y z)
             (declare (type (unsigned-byte 32) x y z))
             (logior (logand x y) (logand x z) (logand y z)))
           (h (x y z)
             (declare (type (unsigned-byte 32) x y z))
             (logxor x y z)))
      (declare (inline f g h))
      (macrolet ((with-md4-round ((op block constant) &rest clauses)
                   (loop for (a b c d k s) in clauses
                         collect `(setq ,a (rol32 (mod32+
                                                   (mod32+ ,a
                                                           (mod32+ (,op ,b ,c ,d)
                                                                   (aref ,block ,k)))
                                                   ,constant) ,s)) into result
                         finally (return `(progn ,@result)))))
        (with-md4-round (f block 0)
          (a b c d 0 3) (d a b c 1 7) (c d a b 2 11) (b c d a 3 19)
          (a b c d 4 3) (d a b c 5 7) (c d a b 6 11) (b c d a 7 19)
          (a b c d 8 3) (d a b c 9 7) (c d a b 10 11) (b c d a 11 19)
          (a b c d 12 3) (d a b c 13 7) (c d a b 14 11) (b c d a 15 19))
        (with-md4-round (g block #x5a827999)
          (a b c d 0 3) (d a b c 4 5) (c d a b 8 9) (b c d a 12 13)
          (a b c d 1 3) (d a b c 5 5) (c d a b 9 9) (b c d a 13 13)
          (a b c d 2 3) (d a b c 6 5) (c d a b 10 9) (b c d a 14 13)
          (a b c d 3 3) (d a b c 7 5) (c d a b 11 9) (b c d a 15 13))
        (with-md4-round (h block #x6ed9eba1)
          (a b c d 0 3) (d a b c 8 9) (c d a b 4 11) (b c d a 12 15)
          (a b c d 2 3) (d a b c 10 9) (c d a b 6 11) (b c d a 14 15)
          (a b c d 1 3) (d a b c 9 9) (c d a b 5 11) (b c d a 13 15)
          (a b c d 3 3) (d a b c 11 9) (c d a b 7 11) (b c d a 15 15))
        (setf (md4-regs-a regs) (mod32+ (md4-regs-a regs) a)
              (md4-regs-b regs) (mod32+ (md4-regs-b regs) b)
              (md4-regs-c regs) (mod32+ (md4-regs-c regs) c)
              (md4-regs-d regs) (mod32+ (md4-regs-d regs) d))
        regs))))

(declaim (inline md4regs-digest))
(defun md4regs-digest (regs)
  "Create the final 16 byte message-digest from the MD4 working state
in regs.  Returns a (simple-array (unsigned-byte 8) (16))."
  (declare (type md4-regs regs)
           #.(burn-baby-burn))
  (let ((result (make-array 16 :element-type '(unsigned-byte 8))))
    (declare (type (simple-array (unsigned-byte 8) (16)) result))
    (setf (ub32ref/le result 0) (md4-regs-a regs)
          (ub32ref/le result 4) (md4-regs-b regs)
          (ub32ref/le result 8) (md4-regs-c regs)
          (ub32ref/le result 12) (md4-regs-d regs))
    result))

(defstruct (md4-state
             (:constructor make-md4-state ())
             (:constructor %make-md4-state (regs amount block buffer buffer-index finalized-p))
             (:copier nil))
  (regs (initial-md4-regs) :type md4-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-md4-state (state)
  (declare (type md4-state state))
  (%make-md4-state (%copy-md4-regs (md4-state-regs state))
                   (md4-state-amount state)
                   (copy-seq (md4-state-block state))
                   (copy-seq (md4-state-buffer state))
                   (md4-state-buffer-index state)
                   (when (md4-state-finalized-p state)
                     (copy-seq (md4-state-finalized-p state)))))

(define-digest-updater md4
  "Update the given md4-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 (md4-state-regs state))
	(block (md4-state-block state))
	(buffer (md4-state-buffer state))
	(buffer-index (md4-state-buffer-index state))
	(length (- end start)))
    (declare (type md4-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-md4-block regs block))
          (when (>= start end)
            (setf (md4-state-buffer-index state) new-index)
            (incf (md4-state-amount state) length)
            (return-from update-md4-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-md4-block regs block)
          finally
          (let ((amount (- end offset)))
            (unless (zerop amount)
              (copy-to-buffer sequence offset amount buffer 0))
            (setf (md4-state-buffer-index state) amount)))
    (incf (md4-state-amount state) length)
    state))

(define-digest-finalizer md4
  "If the given md4-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 MD4 standard.

The resulting MD4 message-digest is returned as an array of sixteen
(unsigned-byte 8) values.  Calling UPDATE-MD4-STATE after a call to
FINALIZE-MD4-STATE results in unspecified behaviour."
  (or (md4-state-finalized-p state)
      (let ((regs (md4-state-regs state))
	    (block (md4-state-block state))
	    (buffer (md4-state-buffer state))
	    (buffer-index (md4-state-buffer-index state))
	    (total-length (* 8 (md4-state-amount state))))
	(declare (type md4-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-md4-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-md4-block regs block)
	;; Done, remember digest for later calls
	(setf (md4-state-finalized-p state)
	      (md4regs-digest regs)))))

(defdigest md4
  (:digest-length 16)
  (:state-type md4-state)
  (:creation-function make-md4-state)
  (:copy-function copy-md4-state)
  (:update-function update-md4-state)
  (:finalize-function finalize-md4-state))
