;SHA224/256 - Provide an idealized interface to the US Secure Hash Algorithm 224 and 256 functions. ;Copyright (C) 2020 Prince Trippy programmer@verisimilitudes.net. ;This program is free software: you can redistribute it and/or modify it under the terms of the ;GNU Affero General Public License version 3 as published by the Free Software Foundation. ;This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without ;even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. ;See the GNU Affero General Public License for more details. ;You should have received a copy of the GNU Affero General Public License along with this program. ;If not, see . ;This is clearly an incomplete, intermediate SHA package, only implementing those SHA224 and SHA256. (cl:defpackage #:SHA (:documentation "This provides the Secure Hash Algorithm 224 and 256 functions. Do not USE it.") (:use #:common-lisp) (:shadow #:string) (:export #:status #:|224| #:|256| #:hash #:string #:octets #:digest #:pad #:blockhash #:blocklength)) (cl:in-package #:SHA) (defclass status () ((unit :type unsigned-byte :initarg :unit :documentation "This is the bit-length of elements, used primarily for DIGEST.") (status :type (vector (unsigned-byte 32) 8) :initarg :status :documentation "This is the vector holding however many UNIT integers as the state.")) (:documentation "This class is that overarching class for intermediate hashing status.")) (defclass |256| (status) () (:default-initargs :unit 32 :status (slot-value |256| 'status)) (:documentation "This class is for SHA256 purposes.")) (defclass |224| (status) () (:default-initargs :unit 32 :status (slot-value |224| 'status)) (:documentation "This class is for SHA224 purposes.")) (defconstant |256| (make-instance '|256| :status (make-array 8 :element-type '(unsigned-byte 32) :initial-contents '(#x6A09E667 #xBB67AE85 #x3C6EF372 #xA54FF53A #x510E527F #x9B05688C #x1F83D9AB #x5BE0CD19))) "This is the initial value of SHA256 expressed as a STATUS.") (defconstant |224| (make-instance '|224| :status (make-array 8 :element-type '(unsigned-byte 32) :fill-pointer t :initial-contents '(#xC1059ED8 #x367CD507 #x3070DD17 #xF70E5939 #xFFC00B31 #x68581511 #x64F98FA7 #xBEFA4FA4))) "This is the initial value of SHA224 expressed as a STATUS.") (defun blockcheck (length block) ;This predicate isn't normal, but I don't care as it's not for you. "This predicate returns T if BLOCK is a (VECTOR (UNSIGNED-BYTE 8)) with size congruent to LENGTH." (and (typep length 'fixnum) (zerop (mod length 8)) (or (typep block `(vector (unsigned-byte 8) ,(/ length 8))) ;This is the most efficient path. (and (vectorp block) (= (length block) (/ length 8)) (every (lambda (elt) (typep elt '(unsigned-byte 8))) block))))) (declaim (inline ch maj b0 b1 s0 s1)) ;I usually find using INLINE to be poor yet not for internals. (defun ch (first second third) (logxor (logand first second) (logand third (lognot first)))) (defun maj (first second third) (logxor (logand first second) (logand first third) (logand second third))) (defun b0 (integer) ;While I should consider writing a macro, none of these functions need to exist. (logxor (dpb (ldb (byte 2 0) integer) (byte 2 30) (ldb (byte 30 2) integer)) (dpb (ldb (byte 13 0) integer) (byte 13 19) (ldb (byte 19 13) integer)) (dpb (ldb (byte 22 0) integer) (byte 22 10) (ldb (byte 10 22) integer)))) (defun b1 (integer) ;Unlike other languages I can't conveniently make these generic on varying size. (logxor (dpb (ldb (byte 6 0) integer) (byte 6 26) (ldb (byte 26 6) integer)) (dpb (ldb (byte 11 0) integer) (byte 11 21) (ldb (byte 21 11) integer)) (dpb (ldb (byte 25 0) integer) (byte 25 7) (ldb (byte 7 25) integer)))) (defun s0 (integer) ;Different forms for thirty-two and sixty-four bit variants are required anyway. (logxor (dpb (ldb (byte 7 0) integer) (byte 7 25) (ldb (byte 25 7) integer)) (dpb (ldb (byte 18 0) integer) (byte 18 14) (ldb (byte 14 18) integer)) (ldb (byte 29 3) integer))) (defun s1 (integer) ;These latter two would either require a better macro or one entirely different. (logxor (dpb (ldb (byte 17 0) integer) (byte 17 15) (ldb (byte 15 17) integer)) (dpb (ldb (byte 19 0) integer) (byte 19 13) (ldb (byte 13 19) integer)) (ldb (byte 22 10) integer))) (defvar k (make-array 64 :element-type '(unsigned-byte 32) :initial-contents '(#x428A2F98 #x71374491 #xB5C0FBCF #xE9B5DBA5 #x3956C25B #x59F111F1 #x923F82A4 #xAB1C5ED5 #xD807AA98 #x12835B01 #x243185BE #x550C7DC3 #x72BE5D74 #x80DEB1FE #x9BDC06A7 #xC19BF174 #xE49B69C1 #xEFBE4786 #x0FC19DC6 #x240CA1CC #x2DE92C6F #x4A7484AA #x5CB0A9DC #x76F988DA #x983E5152 #xA831C66D #xB00327C8 #xBF597FC7 #xC6E00BF3 #xD5A79147 #x06CA6351 #x14292967 #x27B70A85 #x2E1B2138 #x4D2C6DFC #x53380D13 #x650A7354 #x766A0ABB #x81C2C92E #x92722C85 #xA2BFE8A1 #xA81A664B #xC24B8B70 #xC76C51A3 #xD192E819 #xD6990624 #xF40E3585 #x106AA070 #x19A4C116 #x1E376C08 #x2748774C #x34B0BCB5 #x391C0CB3 #x4ED8AA4A #x5B9CCA4F #x682E6FF3 #x748F82EE #x78A5636F #x84C87814 #x8CC70208 #x90BEFFFA #xA4506CEB #xBEF9A3F7 #xC67178F2)) "This array is a source of pseudo-entropy for the hashing algorithm. It will likely be best to use the sixty-four bit variant and LDB, once SHA384 and SHA512 are done.") (defmethod blockhash ((status status) block &aux vector (set (make-array 64 :element-type '(unsigned-byte 32)))) "This is the prime hashing algorithm of SHA224 and SHA256. Neither argument is modified. This is intended only for use where HASH is insufficient or to define a new method thereof. Perhaps the STATUS should be changed; I'm usually unwilling to make efficiency concessions. It would complicate using either constant with this function, however, which would be poor." (declare (dynamic-extent set)) ;As with the CH, MAJ, et al. I'll need two versions of my function. (assert (blockcheck 512 block) (block) "The block wasn't a (VECTOR (UNSIGNED-BYTE 8) 64).") (setq vector (slot-value status 'status)) (dotimes (count 16) (let ((- (aref block (+ 3 (* 4 count))))) (setf - (dpb (aref block (+ 2 (* 4 count))) (byte 8 8) -) - (dpb (aref block (1+ (* 4 count))) (byte 8 16) -) - (dpb (aref block (* 4 count)) (byte 8 24) -) (aref set count) -))) (do ((count 16 (1+ count))) ((= 64 count)) (setf (aref set count) (ldb (byte 32 0) (+ (aref set (- count 7)) (aref set (- count 16)) (s1 (aref set (- count 2))) (s0 (aref set (- count 15))))))) ;This lets me make declarations more easily, by keeping the list separate; merely EVAL it to view. (let #.(pairlis '#0=(first second third fourth fifth sixth seventh eighth) ;Thus: A B C D E F G H. (loop :for count :from 0 :to 7 :collecting `((aref vector ,count)))) (declare (type (unsigned-byte 32) . #0#) (dynamic-extent . #0#)) (dotimes (count 64) ;I don't bother saving that T1 of the algorithm here, but it would optimize. (psetq first (ldb (byte 32 0) (+ eighth (aref set count) (aref k count) (b0 first) (maj first second third) (b1 fifth) (ch fifth sixth seventh))) second first third second fourth third fifth (ldb (byte 32 0) (+ fourth eighth (aref set count) (aref k count) (b1 fifth) (ch fifth sixth seventh))) sixth fifth seventh sixth eighth seventh)) (make-instance (class-of status) :unit (slot-value status 'unit) :status (make-array 8 :element-type '(unsigned-byte 32) :fill-pointer (array-has-fill-pointer-p vector) ;This is a poor hack. :initial-contents #.`(list ,@(loop :for symbol :in '#0# :for nth :from 0 :collect `(ldb (byte 32 0) (+ ,symbol (aref vector ,nth))))))))) (defun pad (blocklength length block &optional second &aux mod bit rem pad last) "Pad a block as the SHA family of functions dictate; a second block is a second value, if needed. The block arguments are modified and their length must be BLOCKLENGTH, yet ELEMENT-TYPE of octets. All blocks are VECTORs of (UNSIGNED-BYTE 8). The optional block may be provided to optimize. If a second block is needed, the optional block will be used. The two blocks must not be EQ. The LENGTH is a bit-length. This function is intended for manual use only when using BLOCKHASH. Currently, an assumption is made that the space needed for the length is (/ BLOCKLENGTH 8) bits." (check-type blocklength unsigned-byte) ;It no longer makes good sense, to restrict these integers. (check-type length unsigned-byte) ;This PAD is more accomodating, so I'll merely ignore too large. (assert (blockcheck blocklength block) (block) "The mandatory PAD block must accomodate ~A bits, only containing octets." blocklength) (assert (and (not (eq block second)) (or (not second) (blockcheck blocklength second))) (block second) "The optional PAD block must be distinct and not EQ with the mandatory block and~ must also accomodate ~A bits, only containing octets; it can also be left NIL." blocklength) (or second (setq second (make-array (/ blocklength 8) :element-type '(unsigned-byte 8)))) (setq mod (mod length blocklength) ;Now the padding can begin; this is nicer here, than with &AUX. bit (ldb (byte 3 0) mod) ;This implementation of PAD isn't rules-based as that previous was. rem (ash mod -3)) (or (and (not (zerop length)) (zerop mod)) (fill block 0 :start (1+ rem))) (fill second 0) ;It's far easier to fill each block unconditionally albeit this is less efficient. (setf last (cond ((zerop length) block) ;Instead of using FLET I set LAST to get parameterization. ((or (zerop mod) (>= mod (- blocklength (/ blocklength 8)))) second) (t block)) pad (cond ((zerop length) block) ;That last block isn't necessarily where all padding stays. ((zerop mod) second) (t block)) #0=(aref pad rem) (dpb 1 (byte 1 (- 7 bit)) ;This places that final one bit of that message. (mask-field (byte bit (- 8 bit)) #0#))) (dotimes (count (/ blocklength 8 8)) (setf (aref last (- (length last) 1 count)) (ldb (byte 8 (ash count 3)) length))) (values block (if (not (eq block last)) last))) (defgeneric blocklength (status) (:documentation "Return the block size of the SHA, in bits.")) (defmethod blocklength ((status |256|)) "Return the appropriate block size for SHA-256." 512) (defmethod blocklength ((status |224|)) "Return the appropriate block size for SHA-224." 512) (defgeneric digest (status) (:documentation "Convert a STATUS, one-way, into a form suitable for those other functions.")) (defmethod digest ((status status)) "This default method should be used for all instances of STATUS not needing foreprocessing." (with-slots (unit status) status ;This could be written better, but it's going to allocate anyway. (make-array (1+ (length status)) :element-type `(unsigned-byte ,unit) :initial-contents (list* unit (coerce status 'list))))) (defmethod digest :before ((status |224|)) (decf (fill-pointer (slot-value status 'status)))) (defun octets (digest &aux (unit (aref digest 0))) "Convert the parameter, which should come from a call to DIGEST, to an octet vector. Currently, the UNIT must be larger than the octet, but this will be relaxed, later. The UNIT must also be a power of two, but this is clearly not the final form, here." (let ((vector (make-array (* (1- (length digest)) (/ unit 8)) :element-type '(unsigned-byte 8)))) (prog1 vector (loop :for count :from 1 :to (1- (length digest)) :doing (loop :for elt :from 0 :for byte :from 0 :below unit :by 8 :doing (setf (aref vector (+ elt (* (1- count) (/ unit 8)))) (ldb (byte 8 (- unit 8 byte)) (aref digest count)))))))) (defun string (digest &aux (octets (octets digest))) "Convert the parameter, which should come from a call to DIGEST, to a string representation." (let ((string (make-array (* 2 (length octets)) :element-type 'base-char))) (loop :for * :from 0 :below (length octets) ;Perhaps, I'll translate this into a call to FORMAT. :do (setf (char string (* * 2)) (digit-char (ldb (byte 4 4) (aref octets *)) 16) (char string (1+ (* * 2))) (digit-char (ldb (byte 4 0) (aref octets *)) 16))) string)) (defgeneric hash (status set &key &allow-other-keys) (:documentation "Return the appropriate SHA checksum digest of the contents of the set. The status is what will be used for initialization and should ideally be a starting constant. The status is what controls which SHA will be employed in deriving the checksum digest.")) ;(defmethod hash (status (set vector) &key ((:start first) 0) ((:end last) nil) ; &aux (block #0=(make-array (/ (blocklength status) 8) ; :element-type '(unsigned-byte 8))) ; (rest #0#)) ;This BLOCK and REST are only necessary here, for use by that PAD. ; "Return the appropriate SHA checksum digest of the contents of a VECTOR of (UNSIGNED-BYTE 8)." ; (declare (dynamic-extent block rest)) ; ) ; ;(defmethod hash (status (set list) &key ((:start first) 0) ((:end last) nil) ; &aux (block #0=(make-array (/ (blocklength status) 8) ; :element-type '(unsigned-byte 8))) ; (rest #0#)) ; "" ; ) (defmethod hash (status (set stream) &key &aux (block #0=(make-array (/ (blocklength status) 8) :element-type '(unsigned-byte 8))) (rest #0#) (count 0) (length 0)) "Return the appropriate SHA checksum digest of the contents of a STREAM of (UNSIGNED-BYTE 8)." (declare (dynamic-extent block rest count length) (type fixnum count) (type unsigned-byte length)) (with-open-stream (stream set) ;How should I nicely check the STREAM-ELEMENT-TYPE is correct here? (incf length (read-sequence block stream)) ;Such checking can truly stay with PAD and BLOCKHASH. (loop (setq count (read-sequence rest stream) length (+ length count)) (if (zerop count) (return)) ;I could return early, checking for (/= COUNT (LENGTH BLOCK)). (setq status (blockhash status block)) ;I save a line by relying on this one test, though. (rotatef block rest))) (multiple-value-bind (first second) (pad (blocklength status) (* 8 length) block rest) (setq status (blockhash status first) status (if second (blockhash status second) status))) (digest status)) (defmethod hash (status (set pathname) &key) ;I could set some &KEY arguments, yet lack good reason. "Return the appropriate SHA checksum digest of the contents of pathname by (UNSIGNED-BYTE 8)." (with-open-file (stream set :element-type '(unsigned-byte 8)) (hash status stream))) .