;SHA1 - Provide an idealized interface to the US Secure Hash Algorithm 1 function.
;Copyright (C) 2019 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 <http://www.gnu.org/licenses/>.
(cl:defpackage #:SHA1
(:documentation "This provides the Secure Hash Algorithm 1 function. Do not USE-PACKAGE it.")
(:use #:common-lisp)
(:shadow #:print #:string)
(:export #:hash #:partial-hash #:pad #:initial-status #:print #:string))
(cl:in-package #:SHA1)
(defconstant initial-status #x67452301EFCDAB8998BADCFE10325476C3D2E1F0
"This is the starting value of the running digest.")
(defun partial-hash (hash block &aux (w (make-array 80 :element-type '(unsigned-byte 32))))
"This implements the half-kibibyte block hash core of the SHA1 algorithm.
The BLOCK isn't modified and must be a (VECTOR (UNSIGNED-BYTE 8) 64).
Only use this function if HASH is insufficient for some reason."
(declare (dynamic-extent w) (ftype (function (t t) (unsigned-byte 160)) partial-hash))
(check-type hash (unsigned-byte 160))
(or (typep block '(vector (unsigned-byte 8) 64)) ;I should make this continuable, later.
(and (vectorp block)
(= 64 (length block))
(every (lambda (integer) (typep integer '(unsigned-byte 8))) block))
(error 'type-error :expected-type '(vector (unsigned-byte 8) 64) :datum block))
(loop :for count :from 0 :below 16
:doing (setf (aref w count)
(dpb (aref block (* 4 count)) (byte 8 24)
(dpb (aref block (1+ (* 4 count))) (byte 8 16)
(dpb (aref block (+ 2 (* 4 count))) (byte 8 8)
(aref block (+ 3 (* 4 count))))))))
(loop :for count :from 16 :below 80
:for logxor := (logxor (aref w (- count 3)) (aref w (- count 8))
(aref w (- count 14)) (aref w (- count 16)))
:doing (setf (aref w count)
(dpb (ldb (byte 31 0) logxor) (byte 31 1) (ldb (byte 1 31) logxor))))
(let ((a (ldb (byte 32 128) hash))
(b (ldb (byte 32 96) hash))
(c (ldb (byte 32 64) hash))
(d (ldb (byte 32 32) hash))
(e (ldb (byte 32 0) hash)))
(let ((h0 a) (h1 b) (h2 c) (h3 d) (h4 e))
(declare (type (unsigned-byte 32) a b c d e h0 h1 h2 h3 h4)
(dynamic-extent a b c d e h0 h1 h2 h3 h4))
(flet ((f (count b c d)
(cond ((<= 0 count 19) (logior (logand b c) (logand d (lognot b))))
((<= 40 count 59) (logior (logand b c) (logand b d) (logand c d)))
(t (logxor b c d))))
(k (count) (svref #(#x5A827999 #x6ED9EBA1 #x8F1BBCDC #xCA62C1D6) (floor count 20))))
(dotimes (count 80)
(psetq a (ldb (byte 32 0) (+ e (aref w count) (k count) (f count b c d)
(dpb (ldb (byte 27 0) a) (byte 27 5) (ldb (byte 5 27) a))))
b a
c (dpb (ldb (byte 2 0) b) (byte 2 30) (ldb (byte 30 2) b))
d c
e d)))
(setq h0 (ldb (byte 32 0) (+ a h0))
h1 (ldb (byte 32 0) (+ b h1))
h2 (ldb (byte 32 0) (+ c h2))
h3 (ldb (byte 32 0) (+ d h3))
h4 (ldb (byte 32 0) (+ e h4)))
(dpb h0 (byte 32 128) (dpb h1 (byte 32 96) (dpb h2 (byte 32 64) (dpb h3 (byte 32 32) h4)))))))
(defun pad (length block &optional second
&aux (mod (mod length 512)) (byte (ldb (byte 6 3) length)))
"This implements the half-kibibyte block padding functionality of the SHA1 algorithm.
The BLOCK is modified and must be a (VECTOR (UNSIGNED-BYTE 8) 64); the length is a bit-length.
If SECOND is provided, it is the same type of VECTOR as BLOCK, but must not be EQ to BLOCK.
If SECOND is provided, an allocation is avoided and SECOND will modified, in some cases.
Only use this function if using PARTIAL-HASH and also read its documentation string."
(check-type length (unsigned-byte 64))
(or (typep block '(vector (unsigned-byte 8) 64)) ;I should make this continuable, later.
(and (vectorp block)
(= 64 (length block))
(every (lambda (integer) (typep integer '(unsigned-byte 8))) block))
(error 'type-error :expected-type '(vector (unsigned-byte 8) 64) :datum block))
(assert (not (eq block second)) (block second))
(or (not second)
(or (typep second '(vector (unsigned-byte 8) 64))
(and (vectorp second)
(= 64 (length second))
(every (lambda (integer) (typep integer '(unsigned-byte 8))) second)))
(error 'type-error :expected-type '(vector (unsigned-byte 8) 64) :datum second))
(if (zerop length)
(progn #0=(setf (aref block 0) #.(expt 2 7))
(fill block 0 :start 1)
block)
(flet ((terminate (block) (setf (aref block byte)
(dpb 1 (byte 1 (- 7 #1=(ldb (byte 3 0) length)))
(mask-field (byte #1# (- 8 #1#))
(aref block byte))))
(fill block 0 :start (1+ byte)))
(pad (block)
(prog1 block (dotimes (count 8) (setf (aref block (- 63 count))
(ldb (byte 8 (* 8 count)) length))))))
(cond ((zerop mod)
(values block (let ((block #2=(or second (make-array 64
:element-type '(unsigned-byte 8)
:initial-element 0))))
#0# (pad block))))
((<= 448 mod 511) (terminate block) (values block (pad #2#)))
((<= 1 mod 447) (terminate block) (pad block))))))
(defgeneric hash (set &key &allow-other-keys)
(:documentation "Hash the contents of the required parameter, returning the final digest.
The message bit-length will always be a multiple of eight with this."))
(defmethod hash ((set vector) &key ((:start first) 0) ((:end last) nil))
"Return the SHA1 checksum digest of the VECTOR, bound by :START and :END.
The desired subsequence of VECTOR must only contain elements of type (UNSIGNED-BYTE 8)."
(check-type first integer) ;I'll not be caring if it's a valid array index, for these purposes.
(check-type last (or null integer))
(if last (assert (< first last) (first last)))
(or (typep set '(vector (unsigned-byte 8))) ;I should make this continuable, later.
(and (vectorp set)
(every (lambda (integer) (typep integer '(unsigned-byte 8)))
(make-array #0=(- #1=(or last (length set)) first)
:element-type (array-element-type set)
:displaced-to set :displaced-index-offset first)))
(error 'type-error :expected-type '(vector (unsigned-byte 8)) :datum set))
(let (* (block #2=(make-array 64 :element-type '(unsigned-byte 8))) ;This could just be a SUBSEQ.
(rest #2#))
(let ((count first) (hash initial-status))
(loop (cond ((< #1# (+ 64 count))
(replace block set :start2 count)
(setf * hash) (return)))
(let ((subseq (make-array 64 :displaced-to set :displaced-index-offset count
:element-type (array-element-type set))))
(setq hash (partial-hash hash subseq)))
(incf count 64)))
(multiple-value-bind (first second) (pad (* 8 #0#) block rest)
(setf * (partial-hash * first))
(if second (partial-hash * second) *))))
(defmethod hash ((set stream) &key &aux (* initial-status) (count 0) (integer 0)
(block #0=(make-array 64 :element-type '(unsigned-byte 8))) (rest #0#))
"Return the SHA1 checksum digest of the contents of the STREAM.
The STREAM-ELEMENT-TYPE must be (UNSIGNED-BYTE 8)."
(declare (dynamic-extent block rest))
;I really should check the stream-element-type nicely, as with the others.
(unwind-protect (progn (loop (setq integer (read-sequence block set)
count (+ integer count)
* (partial-hash * (if (= 64 integer) block (return)))))
(if (and (not (zerop count)) (zerop integer)) ;This is a hack.
(partial-hash * (nth-value 1 (pad (* 8 count) block rest)))
(multiple-value-bind (first second) (pad (* 8 count) block rest)
(setf * (partial-hash * first))
(if second (partial-hash * second) *))))
(close set)))
(defmethod hash ((set pathname) &key)
"Return the SHA1 checksum digest of the contents of the file.
This file will be opened with element-type (UNSIGNED-BYTE 8)."
(with-open-file (stream set :element-type '(unsigned-byte 8)) (hash stream)))
;I would've used FORMMATER if only it had different resulting arguments.
(setf (symbol-function 'print) (lambda (hash &optional (stream *standard-output*))
(format stream "~40,'0X" hash))
(symbol-function 'string) (lambda (hash) (with-output-to-string (*standard-output*)
(print hash))))