;;;; digest.lisp -- common functions for hashing

(in-package :crypto)


;;; defining digest (hash) functions

;;; general inlinable functions for implementing the higher-level functions

(declaim (inline digest-sequence-body digest-stream-body digest-file-body))

(defun digest-sequence-body (sequence state-creation-fn
                                      state-update-fn
                                      state-finalize-fn
                                      &key (start 0) end)
  (declare (type (vector (unsigned-byte 8)) sequence) (type index start))
  (let ((state (funcall state-creation-fn)))
    #+cmu
    ;; respect the fill-pointer
    (let ((end (or end (length sequence))))
      (declare (type index end))
      (lisp::with-array-data ((data sequence) (real-start start) (real-end end))
        (declare (ignore real-end))
        (funcall state-update-fn state data
                 :start real-start :end (+ real-start (- end start)))))
    #+sbcl
    ;; respect the fill-pointer
    (let ((end (or end (length sequence))))
      (sb-kernel:with-array-data ((data sequence) (real-start start) (real-end end))
        (declare (ignore real-end))
        (funcall state-update-fn state data
                 :start real-start :end (+ real-start (- end start)))))
    #-(or cmu sbcl)
    (let ((real-end (or end (length sequence))))
      (declare (type index real-end))
      (funcall state-update-fn state sequence
               :start start :end (or real-end (length sequence))))
    (funcall state-finalize-fn state)))

(eval-when (:compile-toplevel :load-toplevel)
(defconstant +buffer-size+ (* 128 1024))
) ; EVAL-WHEN

(deftype buffer-index () `(integer 0 (,+buffer-size+)))

(defun digest-stream-body (stream state-creation-fn
                                  state-update-fn
                                  state-finalize-fn)
  (let ((state (funcall state-creation-fn)))
    (cond
      ((let ((element-type (stream-element-type stream)))
         (or (equal element-type '(unsigned-byte 8))
             (equal element-type '(integer 0 255))))
       (let ((buffer (make-array +buffer-size+
                                 :element-type '(unsigned-byte 8))))
         (declare (type (simple-array (unsigned-byte 8) (#.+buffer-size+))
                        buffer))
         (declare (dynamic-extent buffer))
         (loop for n-bytes = (read-sequence buffer stream)
               do (funcall state-update-fn state buffer :end n-bytes)
               until (< n-bytes +buffer-size+)
               finally (return (funcall state-finalize-fn state)))))
      (t
       (error "Unsupported stream element-type ~S for stream ~S."
              (stream-element-type stream) stream)))))

(defun digest-file-body (pathname state-creation-fn
                                  state-update-fn
                                  state-finalize-fn)
  (with-open-file (stream pathname :element-type '(unsigned-byte 8)
                          :direction :input
                          :if-does-not-exist :error)
    (digest-stream-body stream state-creation-fn state-update-fn
                        state-finalize-fn)))

;;; macros for "mid-level" functions

(defmacro define-digest-updater (digest-name &body body)
  (let ((fun-name (intern (format nil "UPDATE-~A-STATE" digest-name)))
        (state-name (intern (format nil "~A-STATE" digest-name))))
    (destructuring-bind (maybe-doc-string &rest rest) body
      `(defun ,fun-name (state sequence &key (start 0) (end (length sequence)))
         ,@(when (stringp maybe-doc-string)
             `(,maybe-doc-string))
         (declare (type ,state-name state))
         (declare (type (simple-array (unsigned-byte 8) (*)) sequence))
         (declare (type index start end))
         ,(hold-me-back)
         ,@(if (stringp maybe-doc-string)
               rest
               body)))))

(defmacro define-digest-finalizer (digest-name &body body)
  (let ((fun-name (intern (format nil "FINALIZE-~A-STATE" digest-name)))
        (state-name (intern (format nil "~A-STATE" digest-name))))
    (destructuring-bind (maybe-doc-string &rest rest) body
      `(defun ,fun-name (state)
         ,@(when (stringp maybe-doc-string)
             `(,maybe-doc-string))
         (declare (type ,state-name state))
         ,(hold-me-back)
         ,@(if (stringp maybe-doc-string)
               rest
               body)))))

;;; high-level generic function drivers

;;; These three functions are intended to be one-shot ways to digest
;;; an object of some kind.  You could write these in terms of the more
;;; familiar digest interface below, but these are likely to be slightly
;;; more efficient, as well as more obvious about what you're trying to
;;; do.
(defgeneric digest-file (digest-name pathname)
  (:documentation "Return the digest of PATHNAME using the algorithm DIGEST-NAME."))

(defgeneric digest-stream (digest-name stream)
  (:documentation "Return the digest of STREAM using the algorithm DIGEST-NAME.
STREAM-ELEMENT-TYPE of STREAM should be (UNSIGNED-BYTE 8)."))

(defgeneric digest-sequence (digest-name sequence &key start end)
  (:documentation "Return the digest of the subsequence of SEQUENCE
specified by START and END using the algorithm DIGEST-NAME.  For CMUCL
and SBCL, SEQUENCE can be any vector with an element-type of
(UNSIGNED-BYTE 8); for other implementations, SEQUENCE must be a
SIMPLE-ARRAY."))

;;; These four functions represent the common interface for digests in
;;; other crypto toolkits (OpenSSL, Botan, Python, etc.).  You obtain
;;; some state object for a particular digest, you update it with some
;;; data, and then you get the actual digest.  Flexibility is the name
;;; of the game with these functions.
(defgeneric make-digest (digest-name)
  (:documentation "Return a digest object which uses the algorithm DIGEST-NAME."))

(defgeneric copy-digest (digest)
  (:documentation "Return a copy of DIGEST.  The copy is a deep copy, not a
shallow copy as might be returned by COPY-STRUCTURE."))

(defgeneric update-digest (digest sequence &key start end)
  (:documentation "Update the internal state of DIGEST with the subsequence
of SEQUENCE specified by START and END.  For CMUCL and SBCL, SEQUENCE
can be any vector with an element-type of (UNSIGNED-BYTE 8); for other
implementations, SEQUENCE must be a SIMPLE-ARRAY."))

(defgeneric produce-digest (digest)
  (:documentation "Return the hash of the data processed by DIGEST so far.
This function does not modify the internal state of DIGEST."))
 

;;; the digest-defining macro

(defvar *supported-digests* nil)

(defun list-all-digests ()
  (copy-seq *supported-digests*))

(defun digest-supported-p (name)
  "Return T if the digest NAME is a valid digest name."
  (member name *supported-digests*))

(defgeneric digest-length (digest)
  (:documentation "Return the number of bytes in a digest generated by DIGEST."))

(defmacro defdigest (name &rest initargs)
  (%defdigest name initargs))

(defun %defdigest (name initargs)
  (let ((creation-function nil)
        (copy-function nil)
        (update-function nil)
        (finalize-function nil)
        (state-type nil)
        (digest-length nil)
        (digest-name (intern (string name) (find-package :keyword))))
    (loop for (arg value) in initargs
          do
          (case arg
            (:creation-function 
             (if (not creation-function)
                 (setf creation-function value)
                 (error "Specified :CREATION-FUNCTION multiple times.")))
            (:copy-function
             (if (not copy-function)
                 (setf copy-function value)
                 (error "Specified :COPY-FUNCTION multiple times.")))
            (:update-function
             (if (not update-function)
                 (setf update-function value)
                 (error "Specified :UPDATE-FUNCTION multiple times.")))
            (:finalize-function
             (if (not finalize-function)
                 (setf finalize-function value)
                 (error "Specified :FINALIZE-FUNCTION multiple times.")))
            (:state-type
             (if (not state-type)
                 (setf state-type value)
                 (error "Specified :STATE-TYPE multiple times.")))
            (:digest-length
             (if (not digest-length)
                 (setf digest-length value)
                 (error "Specified :DIGEST-LENGTH multiple times."))))
          finally (if (and creation-function copy-function update-function
                           finalize-function state-type digest-length)
                      (return (generate-digest-forms digest-name state-type
                                                     digest-length
                                                     creation-function
                                                     copy-function update-function
                                                     finalize-function))
                      (error "Didn't specify all required options for DEFDIGEST")))))

(defun generate-digest-forms (digest-name state-type digest-length
                                          creation-function copy-function
                                          update-function finalize-function)
  `(progn
    (pushnew ,digest-name *supported-digests*)
    (defmethod digest-length ((digest (eql ,digest-name)))
      ,digest-length)
    (defmethod digest-length ((digest ,state-type))
      ,digest-length)
    (defmethod make-digest ((digest-name (eql ,digest-name)))
      (,creation-function))
    (defmethod copy-digest ((digest ,state-type))
      (,copy-function digest))
    (defmethod update-digest ((digest ,state-type) sequence &key (start 0) end)
      (,update-function digest sequence
                        :start start :end (or end (length sequence))))
    (defmethod produce-digest ((digest ,state-type))
      (,finalize-function (,copy-function digest)))
    (defmethod digest-file ((digest-name (eql ,digest-name)) pathname)
      (digest-file-body pathname #',creation-function #',update-function #',finalize-function))
    (defmethod digest-stream ((digest-name (eql ,digest-name)) stream)
      (digest-stream-body stream #',creation-function #',update-function #',finalize-function))
    (defmethod digest-sequence ((digest-name (eql ,digest-name)) sequence &key (start 0) end)
      (digest-sequence-body sequence #',creation-function #',update-function #',finalize-function :start start :end end))))
