;SHA - Provide an idealized interface to the US Secure Hash Algorithm 1 and 2 family 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 . (cl:defpackage #:SHA (:documentation "This provides interface to the Secure Hash Algorithm 1 and 2 family of functions. The intent is symbols herein will always be used with the SHA prefix, not by USE.") (:use #:common-lisp) (:shadow #:string) (:export #:status #:\1 #:|224| #:|256| #:|384| #:|512| ;#:|512/224| #:|512/256| #:|512/| #:hash #:string #:octets #:digest #:pad #:blockhash #:blocklength)) (cl:in-package #:SHA) (deftype octet () '(unsigned-byte 8)) (eval-when (:compile-toplevel :load-toplevel :execute) (defclass status () ((unit :type unsigned-byte :initarg :unit :documentation "This is the bit-length of the elements, used primarily with DIGEST.") (status :type vector :initarg :status ;Unfortunately, (VECTOR UNSIGNED-BYTE) is incorrect here. :documentation "This is the vector holding however many UNIT integers as the state.")) (:documentation "This class is that overarching class for intermediate hashing status."))) (defun copy-status-status (status &aux (* (slot-value status 'status))) (let* ((length (array-dimension * 0)) ;It seems only ARRAY-DIMENSION or ARRAY-DIMENSIONS suffices. (+ (make-array length :element-type `(unsigned-byte ,(slot-value status 'unit)) :fill-pointer (if (array-has-fill-pointer-p *) (fill-pointer *))))) (loop :for count :below length :do (setf (aref + count) (aref * count)) :finally (return +)))) (eval-when (:compile-toplevel :load-toplevel :execute) (defclass \1 (status) () (:default-initargs :unit 32 :status (copy-status-status \1)) (:documentation "This class is solely for SHA1, with naught special and no descendents.")) (defclass |256| (status) () (:default-initargs :unit 32 :status (copy-status-status |256|)) (:documentation "This class is primarily for SHA256 and acts as a superclass to SHA224.")) (defclass |224| (|256|) () (:default-initargs :status (copy-status-status |224|)) (:documentation "This class is for SHA224 from SHA256 with FILL-POINTERs to hide state.")) (defclass |512| (status) () (:default-initargs :unit 64 :status (copy-status-status |512|)) (:documentation "This class is primarily for SHA512 and acts as a superclass to SHA384.")) (defclass |384| (|512|) () (:default-initargs :status (copy-status-status |384|)) (:documentation "This class is for SHA384 from SHA512 with FILL-POINTERs to hide state."))) (defmacro safe-defconstant (symbol symbol-value &optional documentation) "Define a constant which always adheres to the equality rules." `(defconstant ,symbol (if (constantp ',symbol) (symbol-value ',symbol) ,symbol-value) ,documentation)) (defmacro defshaconstant (symbol length byte-size fill-pointer list &optional documentation) "" `(safe-defconstant ,symbol (make-instance ',symbol :status (make-array ,length :element-type '(unsigned-byte ,byte-size) :initial-contents ',list :fill-pointer ,fill-pointer)) ,documentation)) ;I could change *READ-BASE* to make these constants slightly easier, but my editor is fine for such. (defshaconstant \1 5 32 nil (#x67452301 #xEFCDAB89 #x98BADCFE #x10325476 #xC3D2E1F0) "This is that starting value of the SHA1; it's five thirty-two bit units with all state visible.") (defshaconstant |256| 8 32 nil (#x6A09E667 #xBB67AE85 #x3C6EF372 #xA54FF53A #x510E527F #x9B05688C #x1F83D9AB #x5BE0CD19) "This is that starting value of SHA256. It's eight thirty-two bit units with all state visible.") (defshaconstant |224| 8 32 7 (#xC1059ED8 #x367CD507 #x3070DD17 #xF70E5939 #xFFC00B31 #x68581511 #x64F98FA7 #xBEFA4FA4) "This is that starting value of SHA224, as with SHA256. A FILL-POINTER hides state, for DIGEST.") (defshaconstant |512| 8 64 nil (#x6A09E667F3BCC908 #xBB67AE8584CAA73B #x3C6EF372FE94F82B #xA54FF53A5F1D36F1 #x510E527FADE682D1 #x9B05688C2B3E6C1F #x1F83D9ABFB41BD6B #x5BE0CD19137E2179) "This is that starting value of SHA512. It's eight sixty-four bit units with all state visible.") (defshaconstant |384| 8 64 6 (#xCBBB9D5DC1059ED8 #x629A292A367CD507 #x9159015A3070DD17 #x152FECD8F70E5939 #x67332667FFC00B31 #x8EB44A8768581511 #xDB0C2E0D64F98FA7 #x47B5481DBEFA4FA4) "This is that starting value of SHA384, as with SHA512. A FILL-POINTER hides state, for DIGEST.") (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 octet ,(/ length 8))) ;This is the most efficient path in checking. (and (vectorp block) (= (length block) (/ length 8)) (every (lambda (elt) (typep elt 'octet)) block))))) (defun copy-status (status) ;This was once method yet I found it superfluous, and now it's internal. "Return a STATUS object which is equivalent but not EQ to the argument. The function only copies the STATUS and uses the UNIT without copying." (make-instance (class-of status) :unit (slot-value status 'unit) :status (copy-status-status status))) (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.")) (defgeneric pad (status length block &optional second) (:documentation "Pad a block as the appropriate SHA dictates, decided by STATUS. The second return value is the second block to hash, if needed. The block arguments are modified, and mustn't be EQ to another. If the optional SECOND block is provided it won't be allocated. This exists for use with BLOCKHASH; the LENGTH is a bit-length.")) (defgeneric blockhash (status block) (:documentation "")) (defgeneric blocklength (status) (:documentation "Return the block size of the SHA, in bits.")) (defgeneric digest (status) (:documentation "Convert a STATUS, one-way, into a form suitable for those other functions.")) (declaim (inline ch maj f sb0 sb1 ss0 ss1 bb0 bb1 bs0 bs1)) ;Using INLINE, for internals, isn't bad. (safe-defconstant k (make-array 80 :element-type '(unsigned-byte 32) :initial-contents (mapcan (lambda (elt) (make-list 20 :initial-element elt)) '(#x5A827999 #x6ED9EBA1 #x8F1BBCDC #xCA62C1D6))) "") (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 f (position first second third) (cond ((or (<= 20 position 39) (<= 60 position 79)) (logxor first second third)) ((<= 0 position 19) (ch first second third)) ;I've ordered these from most common to least. ((<= 40 position 59) (maj first second third)))) (defmacro rotr (symbol unit count) "This inlines a ROTation Right about UNIT, for COUNT; this is separate for the purposes of SHA-1." `(dpb (ldb (byte ,count 0) ,symbol) (byte ,count ,(- unit count)) (ldb (byte ,(- unit count) ,count) ,symbol))) (defmacro defxrotr (symbol unit first second third &optional shiftf) "This DEFine logXor ROTate Right macro defines variations on the B0, B1, S0, and S1 algorithms. The rotation counts are given and if SHIFTF is true than the final is instead made a shifting." `(defun ,symbol (integer) "This function was created by DEFXROTR." (logxor ,.(maplist (lambda (rest &aux (count (car rest))) (if (or (cdr rest) (not shiftf)) `(rotr integer ,unit ,count) ;(SYMBOL UNIT SHIFTF &REST SEQUENCE) `(ldb (byte ,(- unit count) ,count) integer))) (list first second third))))) ;I dislike needing to use a LIST in this. (defxrotr sb0 32 2 13 22) (defxrotr sb1 32 6 11 25) (defxrotr ss0 32 7 18 3 t) (defxrotr ss1 32 17 19 10 t) (defxrotr bb0 64 28 34 39) (defxrotr bb1 64 14 18 41) (defxrotr bs0 64 1 8 7 t) (defxrotr bs1 64 19 61 6 t) (safe-defconstant kk (make-array 80 :element-type '(unsigned-byte 64) :initial-contents '(#x428A2F98D728AE22 #x7137449123EF65CD #xB5C0FBCFEC4D3B2F #xE9B5DBA58189DBBC #x3956C25BF348B538 #x59F111F1B605D019 #x923F82A4AF194F9B #xAB1C5ED5DA6D8118 #xD807AA98A3030242 #x12835B0145706FBE #x243185BE4EE4B28C #x550C7DC3D5FFB4E2 #x72BE5D74F27B896F #x80DEB1FE3B1696B1 #x9BDC06A725C71235 #xC19BF174CF692694 #xE49B69C19EF14AD2 #xEFBE4786384F25E3 #x0FC19DC68B8CD5B5 #x240CA1CC77AC9C65 #x2DE92C6F592B0275 #x4A7484AA6EA6E483 #x5CB0A9DCBD41FBD4 #x76F988DA831153B5 #x983E5152EE66DFAB #xA831C66D2DB43210 #xB00327C898FB213F #xBF597FC7BEEF0EE4 #xC6E00BF33DA88FC2 #xD5A79147930AA725 #x06CA6351E003826F #x142929670A0E6E70 #x27B70A8546D22FFC #x2E1B21385C26C926 #x4D2C6DFC5AC42AED #x53380D139D95B3DF #x650A73548BAF63DE #x766A0ABB3C77B2A8 #x81C2C92E47EDAEE6 #x92722C851482353B #xA2BFE8A14CF10364 #xA81A664BBC423001 #xC24B8B70D0F89791 #xC76C51A30654BE30 #xD192E819D6EF5218 #xD69906245565A910 #xF40E35855771202A #x106AA07032BBD1B8 #x19A4C116B8D2D0C8 #x1E376C085141AB53 #x2748774CDF8EEB99 #x34B0BCB5E19B48A8 #x391C0CB3C5C95A63 #x4ED8AA4AE3418ACB #x5B9CCA4F7763E373 #x682E6FF3D6B2B8A3 #x748F82EE5DEFB2FC #x78A5636F43172F60 #x84C87814A1F0AB72 #x8CC702081A6439EC #x90BEFFFA23631E28 #xA4506CEBDE82BDE9 #xBEF9A3F7B2C67915 #xC67178F2E372532B #xCA273ECEEA26619C #xD186B8C721C0C207 #xEADA7DD6CDE0EB1E #xF57D4F7FEE6ED178 #x06F067AA72176FBA #x0A637DC5A2C898A6 #x113F9804BEF90DAE #x1B710B35131C471B #x28DB77F523047D84 #x32CAAB7B40C72493 #x3C9EBE0A15C9BEBC #x431D67C49C100D4C #x4CC5D4BECB3E42B6 #x597F299CFC657E2A #x5FCB6FAB3AD6FAEC #x6C44198C4A475817)) "This array gives a source of pseudo-entropy for the hashing algorithms, collected from primes. SHA512 and descendents use it directly whereas SHA224 and SHA256 use the high thirty-two bits.") (defmacro octets-to-words (unit) "This macro generates good code for translating UNIT octets to words. It violates hygiene." `(let ((byte 0)) (declare (type (unsigned-byte ,unit) byte)) (dotimes (count 16) (let ((aref (* count ,(/ unit 8)))) (setf byte (aref block (+ ,(1- (/ unit 8)) aref)) ;Unfortunate how I don't emit 1+ in this. ,@(loop :for count :from (- (/ unit 8) 2) :downto 1 :for position :from 8 :by 8 :nconc `(byte (dpb (aref block (+ ,count aref)) (byte 8 ,position) byte))) byte (dpb (aref block aref) (byte 8 ,(- unit 8)) byte) ;The loop is unrolled by-hand. (aref set count) byte))))) (defmacro defblockhash (status unit count + - * = get &optional documentation) "This macro is a generic implementation of the SHA256 and SHA512 block hasher. The STATUS is the class used for dispatching and the UNIT is the class' unit. The COUNT is that schedule length and GET is the expression for accessing KK. The +, -, *, and = are to be those functions implementing S0, S1, B0, and B1. Those four names are poor, but I won't be wasting symbols; I may change them." `(defmethod blockhash ((status ,status) block &aux (vector (slot-value status 'status)) (set (make-array ,count :element-type '(unsigned-byte ,unit))) ,@#0='(first second third fourth fifth sixth seventh eighth)) ,@(if documentation `(,documentation)) (declare (dynamic-extent set ,@#0#)) (octets-to-words ,unit) (do ((count 16 (1+ count))) ((= ,count count)) (setf (aref set count) (ldb (byte ,unit 0) (+ (aref set (- count 7)) (aref set (- count 16)) (,- (aref set (- count 2))) (,+ (aref set (- count 15))))))) (setq ,@(loop :for count :from 0 :to 7 :for symbol :in #0# :nconcing `(,symbol (aref vector ,count)))) ;I reuse these names but that's fine. ;This is quite a nice trick, so that I may continue to use pleasant names, but modify directly. ;This little trick merely makes FIRST a symbol macro for (AREF VECTOR 0), so and on, to eighth. (symbol-macrolet ,(pairlis #0# (loop :for count :below 8 :collecting `((aref vector ,count)))) (dotimes (count ,count) (let ((gentemp (ldb (byte ,unit 0) ;This caches T1 as it's used twice, but T2 is used once. (+ eighth ,get (,= fifth) (ch fifth sixth seventh) (aref set count))))) (psetq first (ldb (byte ,unit 0) (+ gentemp (,* first) (maj first second third))) second first third second fourth third fifth (ldb (byte ,unit 0) (+ gentemp fourth)) sixth fifth seventh sixth eighth seventh)))) (setf ,@(loop :for count :from 0 :to 7 :for symbol :in #0# ;A MAP-INTO using + wasn't feasible. :nconcing `(#1=(aref vector ,count) (ldb (byte ,unit 0) (+ ,symbol #1#))))) status)) (defblockhash |256| 32 64 ss0 ss1 sb0 sb1 (ldb (byte 32 32) (aref kk count)) "Hash for the thirty-two bit SHA-256 functions; the KK array is only partially used.") (defblockhash |512| 64 80 bs0 bs1 bb0 bb1 (aref kk count) "Hash for the sixty-four bit SHA-512 functions; the KK array is completely used now.") (defmethod blockhash ((status \1) block &aux (vector (slot-value status 'status)) (set (make-array 80 :element-type '(unsigned-byte 32))) . #0=(first second third fourth fifth)) "Hash for the thirty-two bit SHA-1 function, making use of F and K." (declare (dynamic-extent set . #0#)) (octets-to-words 32) ;Unfortunately, this is repetitive moreso than a nicer DEFBLOCKHASH would be. (do ((count 16 (1+ count))) ((= 80 count)) (let ((integer (logxor (aref set (- count 3)) (aref set (- count 14)) ;A better ROTR would help. (aref set (- count 8)) (aref set (- count 16))))) (setf (aref set count) (rotr integer 32 31)))) #.`(setq ,@(loop :for count :from 0 :to 4 :for symbol :in '#0# ;Using #. is such a help with this. :nconcing `(,symbol (aref vector ,count)))) (symbol-macrolet #.(pairlis '#0# (loop :for count :below 5 :collecting `((aref vector ,count)))) (dotimes (count 80) (psetq first (ldb (byte 32 0) (+ fifth (aref k count) (f count second third fourth) (aref set count) (rotr first 32 27))) second first third (rotr second 32 2) fourth third fifth fourth))) #.`(setf ,@(loop :for count :from 0 :to 7 :for symbol :in '#0# :nconcing `(#1=(aref vector ,count) (ldb (byte 32 0) (+ ,symbol #1#))))) status) (defmethod blocklength ((status \1)) "Return the block size for the SHA-1 function." 512) (defmethod blocklength ((status |256|)) "Return the block size for the SHA-256 family." 512) (defmethod blocklength ((status |512|)) "Return the block size for the SHA-512 family." 1024) (defmacro defpad (status blocklength &optional documentation) "This macro is a generic implementation of the SHA 1 and 2 family block padder. The STATUS is the class used for dispatching and BLOCKLENGTH is the variation. This macro makes an assumption the message length size is (/ BLOCKLENGTH 8 8)." `(defmethod pad ((status ,status) length block &optional second &aux mod bit rem pad last) ,@(if documentation `(,documentation)) ;It no longer makes good sense to restrict the integers. (check-type length unsigned-byte) ;This PAD is more accomodating, so I'll ignore too large now. (assert (and (not (eq block second)) ;I dislike the checking but it happens only once per hash. (blockcheck ,blocklength block) ;Maybe it's poor to inline my BLOCKLENGTH message. (or (not second) (blockcheck ,blocklength second))) (block second) ,(format nil "The two blocks mustn't be EQ and must allow ~A bits, ~A octets." blocklength (/ blocklength 8))) (or second (setq second (make-array ,(/ blocklength 8) :element-type 'octet))) ;How unpleasant. (setq mod (mod length ,blocklength) ;Now the padding begins; this is nicer here than with &AUX. bit (ldb (byte 3 0) mod) ;This implementation of PAD isn't rules-based as previously 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 inefficient. (setf last (cond ((zerop length) block) ;Instead of using FLET I set LAST for parameterization. ((or (zerop mod) (>= mod ,(- blocklength (/ blocklength 8)))) second) (t block)) ;I should note this: (SECOND NIL IF) MAKE-ARRAY :INITIAL-ELEMENT 0. pad (cond ((zerop length) block) ;That last block isn't necessarily where all padding is. ((zerop mod) second) (t block)) #0=(aref pad rem) (dpb 1 (byte 1 (- 7 bit)) ;This places that one for that block padding. (mask-field (byte bit (- 8 bit)) #0#))) (dotimes (count ,(/ blocklength 8 8)) (setf (aref last (- ,(1- (/ blocklength 8)) count)) (ldb (byte 8 (ash count 3)) length))) (values block (if (not (eq block last)) last)))) (defpad \1 512 "Pad a block with a terminating one, zeroes, and a sixty-four bit length.") (defpad |256| 512 "Pad a block with a terminating one, zeroes, and a sixty-four bit length.") (defpad |512| 1024 "Pad with a terminal one, zeroes, and one hundred and twenty-eight bit length.") (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))))) (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 'octet))) (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)) ;(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 vector) &key ((:start first) 0) ((:end last) nil) ; &aux (block #0=(make-array (/ (blocklength status) 8) :element-type 'octet)) ; (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). ;The :START and :END keyword arguments work as expected to restrict the vector sequence used." ; (declare (dynamic-extent block rest)) ; (setq status (copy-status status)) ; ) (defmethod hash (status (set stream) &key &aux (block #0=(make-array (/ (blocklength status) 8) :element-type 'octet)) (rest #0#) (count 0) (length 0)) "Return the appropriate SHA checksum digest of the contents of a STREAM of (UNSIGNED-BYTE 8). The STREAM will be closed afterwards, so use a CONCATENATED or BROADCAST stream if you need." (declare (dynamic-extent block rest count length) (type fixnum count) (type unsigned-byte length)) (setq status (copy-status status)) (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)). (blockhash status block) ;I save a line by relying on this one test against zero, however. (rotatef block rest))) (multiple-value-bind (first second) (pad status (* 8 length) block rest) (blockhash status first) (if second (blockhash status second))) (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 'octet) (hash status stream))) .