;;;; 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-file-body)) (defun digest-sequence-body (sequence state-creation-fn                              state-update-fn state-finalize-fn                              &key (start 0) end buffer (buffer-start 0))   (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 buffer buffer-start))) (eval-when (:compile-toplevel :load-toplevel) (defconstant +buffer-size+ (* 128 1024)) ) ; EVAL-WHEN (deftype buffer-index () `(integer 0 (,+buffer-size+))) (defun update-digest-from-stream (digest stream)   (cond     ((let ((element-type (stream-element-type stream)))        (or (equal element-type '(unsigned-byte 8))            (equal element-type '(integer 0 255))))      (let ((read-buffer (make-array +buffer-size+                                     :element-type '(unsigned-byte 8))))        (declare (type (simple-array (unsigned-byte 8) (#.+buffer-size+))                       read-buffer))        (declare (dynamic-extent read-buffer))        (loop for n-bytes = (read-sequence read-buffer stream)           do (update-digest digest read-buffer :end n-bytes)           until (< n-bytes +buffer-size+)           finally (return digest))))     (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                          &key buffer (buffer-start 0))   (with-open-file (stream pathname :element-type '(unsigned-byte 8)                           :direction :input                           :if-does-not-exist :error)     (let ((state (funcall state-creation-fn)))       (update-digest-from-stream state stream)       (funcall state-finalize-fn state buffer buffer-start))))  ;;; macros for "mid-level" functions (defmacro define-digest-registers ((digest-name &key (endian :big) (size 4)) &rest registers)   (let* ((struct-name (intern (format nil "~A-REGS" digest-name)))          (constructor (intern (format nil "INITIAL-~A" struct-name)))          (copier (intern (format nil "%COPY-~A" struct-name)))          (digest-fun (intern (format nil "~AREGS-DIGEST" digest-name)))          (register-bit-size (* size 8))          (digest-size (* size (length registers)))          (ref-fun (ubref-fun-name register-bit-size (eq endian :big))))     `(progn        (eval-when (:compile-toplevel :load-toplevel :execute)          (defstruct (,struct-name                       (:type (vector (unsigned-byte ,register-bit-size)))                       (:constructor ,constructor ())                       (:copier ,copier))            ,@registers)          ;; LispWorks properly defines STRUCT-NAME as a type with DEFSTRUCT,         ;; so just avoid gratuitous warnings here.         #-lispworks          (deftype ,struct-name ()            '(simple-array (unsigned-byte ,register-bit-size) (,(length registers)))))        (defun ,digest-fun (regs buffer start)          (declare (type ,struct-name regs)                   (type (integer 0 ,(- array-dimension-limit digest-size)) start)                   ,(burn-baby-burn))          (flet ((stuff-registers (buffer start)                   (declare (type (simple-array (unsigned-byte 8) (*))))                   (setf ,@(loop for (reg value) in registers                                for index from 0 by size                                nconc `((,ref-fun buffer (+ start ,index))                                        (,(intern (format nil "~A-REGS-~A" digest-name reg)) regs))))                   buffer))            (declare (inline stuff-registers))            (cond              (buffer               (stuff-registers buffer start))              (t (stuff-registers (make-array ,digest-size :element-type '(unsigned-byte 8)) 0)))))))) (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 digest-size &body body)   (let ((fun-name (intern (format nil "FINALIZE-~A-STATE" digest-name)))         (inner-fun-name (intern (format nil "%FINALIZE-~A-STATE" digest-name)))         (finalized-p (intern (format nil "~A-STATE-FINALIZED-P" digest-name)))         (reg-digest-fun (intern (format nil "~AREGS-DIGEST" digest-name)))         (state-name (intern (format nil "~A-STATE" digest-name))))     (destructuring-bind (maybe-doc-string &rest rest) body       `(progn          (defun ,fun-name (state &optional buffer buffer-start)            ,@(when (stringp maybe-doc-string)                    `(,maybe-doc-string))            (declare (type ,state-name state))            (declare (type (or (simple-array (unsigned-byte 8) (*)) null) buffer))            (cond              (buffer               ;; verify that the buffer is large enough              (if (<= ,digest-size (- (length buffer) buffer-start))                   (,inner-fun-name state buffer buffer-start)                   (error 'insufficient-buffer-space                          :buffer buffer :start buffer-start                          :length ,digest-size)))              (t               (,inner-fun-name state nil 0))))          (defun ,inner-fun-name (state %buffer buffer-start)            ,(hold-me-back)            (macrolet ((finalize-registers (state regs)                         `(setf (,',finalized-p ,state)                                (,',reg-digest-fun ,regs %buffer buffer-start))))              ,@(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 &key digest digest-start)   (:documentation "Return the digest of the contents of the file named by PATHNAME using the algorithm DIGEST-NAME. If DIGEST is provided, the digest will be placed into DIGEST starting at DIGEST-START.  DIGEST must be a (SIMPLE-ARRAY (UNSIGNED-BYTE 8) (*)). An error will be signaled if there is insufficient room in DIGEST.")) (defgeneric digest-stream (digest-name stream &key digest digest-start)   (:documentation "Return the digest of the contents of STREAM using the algorithm DIGEST-NAME.  STREAM-ELEMENT-TYPE of STREAM should be  (UNSIGNED-BYTE 8). If DIGEST is provided, the digest will be placed into DIGEST starting at DIGEST-START.  DIGEST must be a (SIMPLE-ARRAY (UNSIGNED-BYTE 8) (*)). An error will be signaled if there is insufficient room in DIGEST.")) (defgeneric digest-sequence (digest-name sequence                                          &key start end                                          digest digest-start)   (: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. If DIGEST is provided, the digest will be placed into DIGEST starting at DIGEST-START.  DIGEST must be a (SIMPLE-ARRAY (UNSIGNED-BYTE 8) (*)). An error will be signaled if there is insufficient room in DIGEST.")) ;;; 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.")) (defmethod make-digest (digest-name)   (error 'unsupported-digest :name digest-name)) (defgeneric copy-digest (digester)   (:documentation "Return a copy of DIGESTER.  The copy is a deep copy, not a shallow copy as might be returned by COPY-STRUCTURE.")) (defgeneric update-digest (digester thing &key &allow-other-keys)   (:documentation "Update the internal state of DIGESTER with THING. The exact method is determined by the type of THING.")) (defgeneric produce-digest (digester &key digest digest-start)   (:documentation "Return the hash of the data processed by DIGESTER so far. This function does not modify the internal state of DIGESTER. If DIGEST is provided, the hash will be placed into DIGEST starting at DIGEST-START.  DIGEST must be a (SIMPLE-ARRAY (UNSIGNED-BYTE 8) (*)). An error will be signaled if there is insufficient room in 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.")) (defmethod digest-length (digest-name)   (error 'unsupported-digest :name digest-name)) (defmethod update-digest (digester (stream stream) &key &allow-other-keys)   (update-digest-from-stream digester stream)) (defmethod digest-stream (digest-name stream &key digest (digest-start 0))   (let ((digester (make-digest digest-name)))     (update-digest-from-stream digester stream)     (produce-digest digester :digest digest :digest-start digest-start))) (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 ((digester ,state-type))       (,copy-function digester))     (defmethod update-digest ((digester ,state-type) (sequence vector) &key (start 0) end &allow-other-keys)       (,update-function digester sequence                         :start start :end (or end (length sequence))))     (defmethod produce-digest ((digester ,state-type) &key digest (digest-start 0))       (,finalize-function (,copy-function digester) digest digest-start))     (defmethod digest-file ((digest-name (eql ,digest-name)) pathname                             &key digest (digest-start 0))       (digest-file-body pathname #',creation-function #',update-function                         #',finalize-function                         :buffer digest :buffer-start digest-start))     (defmethod digest-sequence ((digest-name (eql ,digest-name))                                 sequence &key (start 0) end                                 digest (digest-start 0))       (digest-sequence-body sequence #',creation-function                             #',update-function #',finalize-function                             :start start :end end                             :buffer digest :buffer-start digest-start))))