diff options
Diffstat (limited to 'ironclad')
| -rw-r--r-- | ironclad/LICENSE | 31 | ||||
| -rw-r--r-- | ironclad/common.lisp | 372 | ||||
| -rw-r--r-- | ironclad/digest.lisp | 420 | ||||
| -rw-r--r-- | ironclad/package.lisp | 61 | ||||
| -rw-r--r-- | ironclad/sha1.lisp | 237 |
5 files changed, 1121 insertions, 0 deletions
diff --git a/ironclad/LICENSE b/ironclad/LICENSE new file mode 100644 index 0000000..13203f8 --- /dev/null +++ b/ironclad/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2004-2008, Nathan Froyd + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +* Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +* Neither the name of the copyright holders nor the names of + contributors to this software may be used to endorse or promote + products derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS +IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/ironclad/common.lisp b/ironclad/common.lisp new file mode 100644 index 0000000..4753ad7 --- /dev/null +++ b/ironclad/common.lisp @@ -0,0 +1,372 @@ +;;;; common.lisp -- efficient implementations of mod32 arithmetic and macros + +;;; Functions in this file are intended to be fast +(in-package :crypto) + +(defmacro defconst (name value) + `(defconstant ,name + (if (boundp ',name) + (symbol-value ',name) + ,value))) + +;;; CMUCL and SBCL both have an internal type for this, but we'd like to +;;; be portable, so we define our own. + +(deftype index () '(mod #.array-dimension-limit)) +(deftype index+1 () `(mod ,(1+ array-dimension-limit))) + +;;; We write something like this all over the place. + +(deftype simple-octet-vector (&optional length) + (let ((length (or length '*))) + `(simple-array (unsigned-byte 8) (,length)))) + + +;;; a global specification of optimization settings + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defun burn-baby-burn () + '(optimize (speed 3) (safety 0) (space 0) + (debug 0) (compilation-speed 0))) + +(defun hold-me-back () + '(declare (optimize (speed 3) (space 0) (compilation-speed 0) + #-cmu (safety 1) #-cmu (debug 1) + #+cmu (safety 0) #+cmu (debug 0)) + #+cmu (ext:optimize-interface (safety 1) (debug 1)))) +) ; EVAL-WHEN + + +;;; extracting individual bytes from integers + +;;; We used to declare these functions with much stricter types (e.g. +;;; (UNSIGNED-BYTE 32) as the lone argument), but we need to access +;;; bytes of both 32-bit and 64-bit words and the types would just get +;;; in our way. We declare these functions as inline; a good Common +;;; Lisp compiler should be able to generate efficient code from the +;;; declarations at the point of the call. + +;;; These functions are named according to big-endian conventions. The +;;; comment is here because I always forget and need to be reminded. +#.(loop for i from 1 to 8 + collect (let ((name (intern (format nil "~:@(~:R~)-BYTE" i)))) + `(progn + (declaim (inline ,name)) + (declaim (ftype (function (unsigned-byte) (unsigned-byte 8)) ,name)) + (defun ,name (ub) + (declare (type unsigned-byte ub)) + (ldb (byte 8 ,(* 8 (1- i))) ub)))) into forms + finally (return `(progn ,@forms))) + + +;;; fetching/storing appropriately-sized integers from octet vectors + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defun ubref-fun-name (bitsize big-endian-p) + (intern (format nil "UB~DREF/~:[LE~;BE~]" bitsize big-endian-p))) +) ; EVAL-WHEN + +(macrolet ((define-fetcher (bitsize &optional big-endian) + (let ((name (ubref-fun-name bitsize big-endian)) + (bytes (truncate bitsize 8))) + `(progn + (declaim (inline ,name)) + (defun ,name (buffer index) + (declare (type simple-octet-vector buffer)) + (declare (type (integer 0 ,(- array-dimension-limit bytes)) index)) + (logand ,(1- (ash 1 bitsize)) + ,(loop for i from 0 below bytes + collect (let* ((offset (if big-endian + i + (- bytes i 1))) + (shift (if big-endian + (* (- bytes i 1) 8) + (* offset 8)))) + `(ash (aref buffer (+ index ,offset)) ,shift)) into forms + finally (return `(logior ,@forms)))))))) + (define-storer (bitsize &optional big-endian) + (let ((name (ubref-fun-name bitsize big-endian)) + (bytes (truncate bitsize 8))) + `(progn + (declaim (inline (setf ,name))) + (defun (setf ,name) (value buffer index) + (declare (type simple-octet-vector buffer)) + (declare (type (integer 0 ,(- array-dimension-limit bytes)) index)) + (declare (type (unsigned-byte ,bitsize) value)) + ,@(loop for i from 1 to bytes + collect (let ((offset (if big-endian + (- bytes i) + (1- i)))) + `(setf (aref buffer (+ index ,offset)) + (,(intern (format nil "~:@(~:R~)-BYTE" i)) value)))) + (values))))) + (define-fetchers-and-storers (bitsize) + `(progn + (define-fetcher ,bitsize) (define-fetcher ,bitsize t) + (define-storer ,bitsize) (define-storer ,bitsize t)))) + (define-fetchers-and-storers 16) + (define-fetchers-and-storers 32) + (define-fetchers-and-storers 64)) + + +;;; efficient 32-bit arithmetic, which a lot of algorithms require + +(declaim (inline mod32+) + (ftype (function ((unsigned-byte 32) (unsigned-byte 32)) (unsigned-byte 32)) mod32+)) +(defun mod32+ (a b) + (declare (type (unsigned-byte 32) a b)) + (ldb (byte 32 0) (+ a b))) + +#+cmu +(define-compiler-macro mod32+ (a b) + `(ext:truly-the (unsigned-byte 32) (+ ,a ,b))) + +#+sbcl +(define-compiler-macro mod32+ (a b) + `(ldb (byte 32 0) (+ ,a ,b))) + +;;; mostly needed for CAST* +(declaim (inline mod32-) + (ftype (function ((unsigned-byte 32) (unsigned-byte 32)) (unsigned-byte 32)) mod32-)) + +(defun mod32- (a b) + (declare (type (unsigned-byte 32) a b)) + (ldb (byte 32 0) (- a b))) + +#+cmu +(define-compiler-macro mod32- (a b) + `(ext:truly-the (unsigned-byte 32) (- ,a ,b))) + +#+sbcl +(define-compiler-macro mod32- (a b) + `(ldb (byte 32 0) (- ,a ,b))) + +;;; mostly needed for RC6 +(declaim (inline mod32*) + (ftype (function ((unsigned-byte 32) (unsigned-byte 32)) (unsigned-byte 32)) mod32*)) + +(defun mod32* (a b) + (declare (type (unsigned-byte 32) a b)) + (ldb (byte 32 0) (* a b))) + +#+cmu +(define-compiler-macro mod32* (a b) + `(ext:truly-the (unsigned-byte 32) (* ,a ,b))) + +#+sbcl +(define-compiler-macro mod32* (a b) + `(ldb (byte 32 0) (* ,a ,b))) + +(declaim (inline mod32ash) + (ftype (function ((unsigned-byte 32) (integer -31 31)) (unsigned-byte 32)) mod32ash)) + +(defun mod32ash (num count) + (declare (type (unsigned-byte 32) num)) + (declare (type (integer -31 31) count)) + (ldb (byte 32 0) (ash num count))) + +#+sbcl +(define-compiler-macro mod32ash (num count) + ;; work around SBCL optimizing bug as described by APD: + ;; http://www.caddr.com/macho/archives/sbcl-devel/2004-8/3877.html + `(logand #xffffffff (ash ,num ,count))) + +(declaim (inline mod32lognot) + (ftype (function ((unsigned-byte 32)) (unsigned-byte 32)) mod32lognot)) + +(defun mod32lognot (num) + (ldb (byte 32 0) (lognot num))) + +#+sbcl +(define-compiler-macro mod32lognot (num) + `(ldb (byte 32 0) (lognot ,num))) + +(declaim (inline rol32 ror32) + (ftype (function ((unsigned-byte 32) (unsigned-byte 5)) (unsigned-byte 32)) rol32 ror32)) + +(defun rol32 (a s) + (declare (type (unsigned-byte 32) a) (type (integer 0 32) s)) + #+cmu + (kernel:32bit-logical-or #+little-endian (kernel:shift-towards-end a s) + #+big-endian (kernel:shift-towards-start a s) + (ash a (- s 32))) + #+sbcl + (sb-rotate-byte:rotate-byte s (byte 32 0) a) + #-(or sbcl cmu) + (logior (ldb (byte 32 0) (ash a s)) (ash a (- s 32)))) + +(defun ror32 (a s) + (declare (type (unsigned-byte 32) a) (type (integer 0 32) s)) + #+sbcl + (sb-rotate-byte:rotate-byte (- s) (byte 32 0) a) + #-sbcl + (rol32 a (- 32 s))) + +(declaim (inline mod64+) + (ftype (function ((unsigned-byte 64) (unsigned-byte 64)) (unsigned-byte 64)) mod64+)) +(defun mod64+ (a b) + (declare (type (unsigned-byte 64) a b)) + (ldb (byte 64 0) (+ a b))) + +#+sbcl +(define-compiler-macro mod64+ (a b) + `(ldb (byte 64 0) (+ ,a ,b))) + +(defun rol64 (a s) + (declare (type (unsigned-byte 64) a) (type (integer 0 64) s)) + (logior (ldb (byte 64 0) (ash a s)) (ash a (- s 64)))) + +(defun ror64 (a s) + (declare (type (unsigned-byte 64) a) (type (integer 0 64) s)) + (rol64 a (- 64 s))) + + +;;; 64-bit utilities + +(declaim (inline %add-with-carry %subtract-with-borrow)) + +;;; The names are taken from sbcl and cmucl's bignum routines. +;;; Naturally, they work the same way (which means %SUBTRACT-WITH-BORROW +;;; is a little weird). +(defun %add-with-carry (x y carry) + (declare (type (unsigned-byte 32) x y) + (type (mod 2) carry)) + #+(and sbcl 32-bit) + (sb-bignum:%add-with-carry x y carry) + #+(and cmucl 32-bit) + (bignum:%add-with-carry x y carry) + #-(or (and sbcl 32-bit) + (and cmucl 32-bit)) + (let* ((temp (mod32+ x y)) + (temp-carry (if (< temp x) 1 0)) + (result (mod32+ temp carry))) + (values result (logior temp-carry (if (< result temp) 1 0))))) + +(defun %subtract-with-borrow (x y borrow) + (declare (type (unsigned-byte 32) x y) + (type (mod 2) borrow)) + #+(and sbcl 32-bit) + (sb-bignum:%subtract-with-borrow x y borrow) + #+(and cmucl 32-bit) + (bignum:%subtract-with-borrow x y borrow) + #-(or (and sbcl 32-bit) + (and cmucl 32-bit)) + (let ((temp (mod32- x y))) + (cond + ((zerop borrow) + (values (mod32- temp 1) (if (< y x) 1 0))) + (t + (values temp (logxor (if (< x y) 1 0) 1)))))) + +;;; efficient 8-byte -> 32-byte buffer copy routines, mostly used by +;;; the hash functions. we provide big-endian and little-endian +;;; versions. + +(declaim (inline fill-block-le-ub8 fill-block-be-ub8)) + +(declaim (inline copy-to-buffer)) +(defun copy-to-buffer (from from-offset count buffer buffer-offset) + "Copy a partial segment from input vector from starting at +from-offset and copying count elements into the 64 byte buffer +starting at buffer-offset." + (declare (type index from-offset) + (type (integer 0 127) count buffer-offset) + (type simple-octet-vector from) + (type simple-octet-vector buffer) + #.(burn-baby-burn)) + #+cmu + (kernel:bit-bash-copy + from (+ (* vm:vector-data-offset vm:word-bits) (* from-offset vm:byte-bits)) + buffer (+ (* vm:vector-data-offset vm:word-bits) + (* buffer-offset vm:byte-bits)) + (* count vm:byte-bits)) + #+sbcl + (sb-kernel:ub8-bash-copy from from-offset buffer buffer-offset count) + #-(or cmu sbcl) + (loop for buffer-index of-type (integer 0 64) from buffer-offset + for from-index of-type fixnum from from-offset + below (+ from-offset count) + do + (setf (aref buffer buffer-index) (aref from from-index)))) + +(defun fill-block-ub8-le (block buffer offset) + "Convert a complete 64 (UNSIGNED-BYTE 8) input BUFFER starting from +OFFSET into the given (UNSIGNED-BYTE 32) BLOCK." + (declare (type (integer 0 #.(- array-dimension-limit 64)) offset) + (type (simple-array (unsigned-byte 32) (16)) block) + (type simple-octet-vector buffer)) + #+(and :cmu :little-endian) + (kernel:bit-bash-copy + buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits)) + block (* vm:vector-data-offset vm:word-bits) + (* 64 vm:byte-bits)) + #+(and :sbcl :little-endian) + (sb-kernel:ub8-bash-copy buffer offset block 0 64) + #-(or (and :sbcl :little-endian) (and :cmu :little-endian)) + (loop for i of-type (integer 0 16) from 0 + for j of-type (integer 0 #.array-dimension-limit) + from offset to (+ offset 63) by 4 + do + (setf (aref block i) (ub32ref/le buffer j)))) + +(defun fill-block-ub8-be (block buffer offset) + "Convert a complete 64 (unsigned-byte 8) input vector segment +starting from offset into the given 16 word SHA1 block. Calling this function +without subsequently calling EXPAND-BLOCK results in undefined behavior." + (declare (type (integer 0 #.(- array-dimension-limit 64)) offset) + (type (simple-array (unsigned-byte 32) (*)) block) + (type simple-octet-vector buffer)) + ;; convert to 32-bit words + #+(and :cmu :big-endian) + (kernel:bit-bash-copy + buffer (+ (* vm:vector-data-offset vm:word-bits) + (* offset vm:byte-bits)) + block (* vm:vector-data-offset vm:word-bits) + (* 64 vm:byte-bits)) + #+(and :sbcl :big-endian) + (sb-kernel:ub8-bash-copy buffer offset block 0 64) + #-(or (and :sbcl :big-endian) (and :cmu :big-endian)) + (loop for i of-type (integer 0 16) from 0 + for j of-type (integer 0 #.array-dimension-limit) + from offset to (+ offset 63) by 4 + do (setf (aref block i) (ub32ref/be buffer j)))) + +(defun fill-block-ub8-be/64 (block buffer offset) + "Convert a complete 128 (unsigned-byte 8) input vector segment +starting from offset into the given 16 qword SHA1 block. Calling this +function without subsequently calling EXPAND-BLOCK results in undefined +behavior." + (declare (type (integer 0 #.(- array-dimension-limit 128)) offset) + (type (simple-array (unsigned-byte 64) (*)) block) + (type simple-octet-vector buffer) + #.(burn-baby-burn)) + ;; convert to 32-bit words + #+(and :cmu :big-endian) + (kernel:bit-bash-copy + buffer (+ (* vm:vector-data-offset vm:word-bits) + (* offset vm:byte-bits)) + block (* vm:vector-data-offset vm:word-bits) + (* 128 vm:byte-bits)) + #+(and :sbcl :big-endian) + (sb-kernel:ub8-bash-copy buffer offset block 0 128) + #-(or (and :sbcl :big-endian) (and :cmu :big-endian)) + (loop for i of-type (integer 0 16) from 0 + for j of-type (integer 0 #.array-dimension-limit) + from offset to (+ offset 127) by 8 + do (setf (aref block i) (ub64ref/be buffer j)))) + +;;; a few functions that are useful during compilation + +(defun make-circular-list (&rest elements) + (let ((list (copy-seq elements))) + (setf (cdr (last list)) list))) + +;;; SUBSEQ is defined to error on circular lists, so we define our own +(defun circular-list-subseq (list start end) + (let* ((length (- end start)) + (subseq (make-list length))) + (do ((i 0 (1+ i)) + (list (nthcdr start list) (cdr list)) + (xsubseq subseq (cdr xsubseq))) + ((>= i length) subseq) + (setf (first xsubseq) (first list)))))
\ No newline at end of file diff --git a/ironclad/digest.lisp b/ironclad/digest.lisp new file mode 100644 index 0000000..acf4e95 --- /dev/null +++ b/ironclad/digest.lisp @@ -0,0 +1,420 @@ +;;;; digest.lisp -- common functions for hashing + +(in-package :crypto) + + +;;; defining digest (hash) functions + +(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 &key buffer (start 0) end) + (cond + ((let ((element-type (stream-element-type stream))) + (or (equal element-type '(unsigned-byte 8)) + (equal element-type '(integer 0 255)))) + (flet ((frob (read-buffer start end) + (loop for last-updated = (read-sequence read-buffer stream + :start start :end end) + do (update-digest digest read-buffer + :start start :end last-updated) + until (< last-updated end) + finally (return digest)))) + (if buffer + (frob buffer start (or end (length buffer))) + (let ((buffer (make-array +buffer-size+ + :element-type '(unsigned-byte 8)))) + (declare (dynamic-extent buffer)) + (frob buffer 0 +buffer-size+))))) + (t + (error "Unsupported stream element-type ~S for stream ~S." + (stream-element-type stream) stream)))) + +;;; Storing a length at the end of the hashed data is very common and +;;; can be a small bottleneck when generating lots of hashes over small +;;; quantities of data. We assume that the appropriate locations have +;;; already been zeroed if necessary. LENGTH is also assumed to be an +;;; (effectively) 64-bit quantity. +(declaim (inline store-data-length)) +(defun store-data-length (block length offset &optional big-endian-p) + (let ((lo (if big-endian-p (1+ offset) offset)) + (hi (if big-endian-p offset (1+ offset)))) + #+(and sbcl 32-bit) + (cond + ((sb-int:fixnump length) + (setf (aref block lo) length)) + ;; Otherwise, we have a bignum. + (t + (locally (declare (optimize (safety 0)) + (type sb-bignum:bignum-type length)) + (cond + ((= (sb-bignum:%bignum-length length) 1) + (setf (aref block lo) (sb-bignum:%bignum-ref length 0))) + (t + (setf (aref block lo) (sb-bignum:%bignum-ref length 0) + (aref block hi) (sb-bignum:%bignum-ref length 1))))))) + #+(and cmu 32-bit) + (cond + ((ext:fixnump length) + (setf (aref block lo) length)) + ;; Otherwise, we have a bignum. + (t + (locally (declare (optimize (safety 0)) + (type bignum:bignum-type length)) + (cond + ((= (bignum:%bignum-length length) 1) + (setf (aref block lo) (bignum:%bignum-ref length 0))) + (t + (setf (aref block lo) (bignum:%bignum-ref length 0) + (aref block hi) (bignum:%bignum-ref length 1))))))) + #-(or (and sbcl 32-bit) + (and cmu 32-bit)) + (setf (aref block lo) (ldb (byte 32 0) length) + (aref block hi) (ldb (byte 32 32) length)))) + +;;; macros for "mid-level" functions + +(defmacro define-digest-registers ((digest-name &key (endian :big) (size 4) (digest-registers nil)) &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 (or digest-registers + (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) + ;; Some versions of LispWorks incorrectly define STRUCT-NAME as + ;; a type with DEFSTRUCT, so avoid gratuitous warnings. + #-(and lispworks lispworks5.0) + (deftype ,struct-name () + '(simple-array (unsigned-byte ,register-bit-size) (,(length registers))))) + (defun ,digest-fun (regs buffer start) + (declare (type ,struct-name regs) + (type (simple-array (unsigned-byte 8) (*)) buffer) + (type (integer 0 ,(- array-dimension-limit digest-size)) start) + ,(burn-baby-burn)) + ,(let ((inlined-unpacking + `(setf ,@(loop for (reg value) in registers + for index from 0 below digest-size by size + nconc `((,ref-fun buffer (+ start ,index)) + (,(intern (format nil "~A-REGS-~A" digest-name reg)) regs)))))) + (cond + #+(and sbcl :little-endian) + ((eq endian :little) + `(if (= start 0) + (sb-kernel:ub8-bash-copy regs 0 buffer 0 ,digest-size) + ,inlined-unpacking)) + #+(and sbcl :big-endian) + ((eq endian :big) + `(if (= start 0) + (sb-kernel:ub8-bash-copy regs 0 buffer 0 ,digest-size) + ,inlined-unpacking)) + (t inlined-unpacking))) + buffer)))) + +(defmacro define-digest-updater (digest-name &body body) + (destructuring-bind (maybe-doc-string &rest rest) body + `(defmethod update-digest ((state ,digest-name) (sequence vector) &key (start 0) (end (length sequence))) + ,@(when (stringp maybe-doc-string) + `(,maybe-doc-string)) + (declare (type (simple-array (unsigned-byte 8) (*)) sequence)) + (declare (type index start end)) + ,(hold-me-back) + ,@(if (stringp maybe-doc-string) + rest + body)))) + +;;; SPECS is either (DIGEST-NAME DIGEST-BYTES) or a list of the same. +;;; The latter spelling is for digests that are related, but have +;;; different output sizes (e.g. SHA2-512 and SHA2-384). In that case, +;;; the first list is expected to be for the "major" variant of the +;;; pair; its digest type is expected to be the supertype of the +;;; variants. +(defmacro define-digest-finalizer (specs &body body) + (let* ((single-digest-p (not (consp (car specs)))) + (specs (if single-digest-p (list specs) specs)) + (inner-fun-name (intern (format nil "%FINALIZE-~A-STATE" (caar specs))))) + (destructuring-bind (maybe-doc-string &rest rest) body + (loop for (digest-name digest-size) in specs + for regs-digest-fun = (intern (format nil "~AREGS-DIGEST" digest-name)) + collect `(defmethod finalize-digest ((state ,digest-name) + &optional buffer buffer-start) + ,@(when (stringp maybe-doc-string) + `(,maybe-doc-string)) + (declare (type (or (simple-array (unsigned-byte 8) (*)) cl:null) buffer)) + (cond + (buffer + ;; verify that the buffer is large enough + (let ((buffer-start (or buffer-start 0))) + (if (<= ,digest-size (- (length buffer) buffer-start)) + (,inner-fun-name state buffer buffer-start + ,@(unless single-digest-p + `(#',regs-digest-fun))) + (error 'insufficient-buffer-space + :buffer buffer :start buffer-start + :length ,digest-size)))) + (t + (,inner-fun-name state + (make-array ,digest-size + :element-type '(unsigned-byte 8)) + 0 + ,@(unless single-digest-p + `(#',regs-digest-fun)))))) into finalizers + finally + (return + `(progn + ,@finalizers + (defun ,inner-fun-name (state %buffer buffer-start ,@(unless single-digest-p + '(reg-digest-fun))) + ,(hold-me-back) + (macrolet ((finalize-registers (state regs) + (declare (ignore state)) + ,(if single-digest-p + ``(,',(intern (format nil "~AREGS-DIGEST" (caar specs))) ,regs %buffer buffer-start) + ``(funcall 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-spec pathname &rest args + &key buffer start end + 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. + +If BUFFER is provided, the portion of BUFFER between START and END will +be used to hold data read from the stream.")) + +(defmethod digest-file ((digest-name symbol) pathname &rest kwargs) + (apply #'digest-file (make-digest digest-name) pathname kwargs)) + +(defmethod digest-file (state pathname &key buffer (start 0) end + digest (digest-start 0)) + (with-open-file (stream pathname :element-type '(unsigned-byte 8) + :direction :input + :if-does-not-exist :error) + (update-digest-from-stream state stream + :buffer buffer :start start :end end) + (produce-digest state :digest digest :digest-start digest-start))) + +(defgeneric digest-stream (digest-spec stream &rest args + &key buffer start end + 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. + +If BUFFER is provided, the portion of BUFFER between START and END will +be used to hold data read from the stream.")) + +(defmethod digest-stream ((digest-name symbol) stream &rest kwargs) + (apply #'digest-stream (make-digest digest-name) stream kwargs)) + +(defmethod digest-stream (state stream &key buffer (start 0) end + digest (digest-start 0)) + (update-digest-from-stream state stream + :buffer buffer :start start :end end) + (produce-digest state :digest digest :digest-start digest-start)) + +(defgeneric digest-sequence (digest-spec sequence &rest args + &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 (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.")) + +(defmethod digest-sequence ((digest-name symbol) sequence &rest kwargs) + (apply #'digest-sequence (make-digest digest-name) sequence kwargs)) + +(defmethod digest-sequence (state sequence &key (start 0) end + digest (digest-start 0)) + (declare (type (vector (unsigned-byte 8)) sequence) (type index start)) + #+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)) + (update-digest 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)) + (update-digest 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)) + (update-digest state sequence + :start start :end (or real-end (length sequence)))) + (produce-digest state :digest digest :digest-start digest-start)) + +;;; 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. +(defun make-digest (digest-name) + "Return a digest object which uses the algorithm DIGEST-NAME." + (typecase digest-name + (symbol + (let ((name (massage-symbol digest-name))) + (if (digestp name) + (funcall (the function (get name '%make-digest))) + (error 'unsupported-digest :name digest-name)))) + (t + (error 'type-error :datum digest-name :expected-type 'symbol)))) + +(defgeneric copy-digest (digester &optional copy) + (:documentation "Return a copy of DIGESTER. If COPY is not NIL, it +should be of the same type as DIGESTER and will receive the copied data, +rather than creating a new object. 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 modifies 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.")) + +(defmethod produce-digest (digester &key digest (digest-start 0)) + (finalize-digest digester digest digest-start)) + + +;;; the digest-defining macro + +(defclass digest () + ((amount :accessor amount-processed :type (unsigned-byte 64) + :initform 0) + (buffer-index :accessor buffer-index :initform 0) + (finalized-p :accessor finalized-p :initform nil))) + +(defun digestp (sym) + (get sym '%digest-length)) + +(defun list-all-digests () + (loop for symbol being each external-symbol of (find-package :ironclad) + if (digestp symbol) + collect symbol)) + +(defun digest-supported-p (name) + "Return T if the digest NAME is a valid digest name." + (and (symbolp name) + (not (cl:null (digestp name))))) + +(defgeneric digest-length (digest) + (:documentation "Return the number of bytes in a digest generated by DIGEST.")) + +(defun massage-symbol (symbol) + (let ((package (symbol-package symbol)) + (ironclad (load-time-value (find-package :ironclad)))) + (cond + ((eq package ironclad) symbol) + ((eq package (load-time-value (find-package :keyword))) + (find-symbol (symbol-name symbol) ironclad)) + (t nil)))) + +(defmethod digest-length ((digest-name symbol)) + (or (digestp (massage-symbol digest-name)) + (error 'unsupported-digest :name digest-name))) + +(defmethod digest-length (digest-name) + (error 'unsupported-digest :name digest-name)) + +(defmethod update-digest (digester (stream stream) &key buffer (start 0) end + &allow-other-keys) + (update-digest-from-stream digester stream + :buffer buffer :start start :end end)) + +(defun optimized-maker-name (name) + (let ((*package* (find-package :ironclad))) + (intern (format nil "%MAKE-~A-DIGEST" name)))) + +(defmacro defdigest (name &key digest-length block-length) + (let ((optimized-maker-name (optimized-maker-name name))) + `(progn + (eval-when (:compile-toplevel :load-toplevel) + (export ',name :ironclad)) + (setf (get ',name '%digest-length) ,digest-length) + (setf (get ',name '%make-digest) (symbol-function ',optimized-maker-name)) + (defmethod digest-length ((digest ,name)) + ,digest-length) + (defmethod block-length ((digest ,name)) + ,block-length)))) + +;;; If we pass a constant argument to MAKE-DIGEST, convert the +;;; MAKE-DIGEST call to a direct call to the state creation function. +(define-compiler-macro make-digest (&whole form &environment env + name) + (declare (ignore env)) + (cond + ((or (keywordp name) + (and (quotationp name) (symbolp name))) + (let ((name (massage-symbol (unquote name)))) + (if (digestp name) + `(,(optimized-maker-name name)) + form))) + (t form))) + +;;; And do the same for various one-shot digest functions. +(defun maybe-expand-one-shot-call (form funname name 2nd-arg keys) + (cond + ((or (keywordp name) + (and (quotationp name) (symbolp name))) + (let ((name (massage-symbol (unquote name)))) + (if (digestp name) + `(,funname (,(optimized-maker-name name)) ,2nd-arg ,@keys) + form))) + (t form))) + +(define-compiler-macro digest-sequence (&whole form &environment env + name sequence &rest keys) + (declare (ignore env)) + (maybe-expand-one-shot-call form 'digest-sequence name sequence keys)) + +(define-compiler-macro digest-stream (&whole form &environment env + name stream &rest keys) + (declare (ignore env)) + (maybe-expand-one-shot-call form 'digest-stream name stream keys)) + +(define-compiler-macro digest-file (&whole form &environment env + name file &rest keys) + (declare (ignore env)) + (maybe-expand-one-shot-call form 'digest-file name file keys)) diff --git a/ironclad/package.lisp b/ironclad/package.lisp new file mode 100644 index 0000000..d2f8814 --- /dev/null +++ b/ironclad/package.lisp @@ -0,0 +1,61 @@ +(cl:defpackage :ironclad + (:use :cl) + (:nicknames :crypto) + (:shadow null) + (:export + ;; referencing multiple-octet values in an octet vector (SETF-able) + #:ub16ref/be #:ub16ref/le #:ub32ref/be #:ub32ref/le #:ub64ref/le #:ub64ref/be + + ;; hash functions + #:digest-sequence #:digest-stream #:digest-file + #:make-digest #:copy-digest #:update-digest #:produce-digest + + ;; HMACs + #:make-hmac #:update-hmac #:hmac-digest + ;; CMACs + #:make-cmac #:update-cmac #:cmac-digest + + ;; introspection + #:cipher-supported-p #:list-all-ciphers + #:digest-supported-p #:list-all-digests + #:mode-supported-p #:list-all-modes + #:block-length #:digest-length #:key-lengths + + ;; high-level block cipher operators + #:make-cipher #:encrypt #:decrypt #:encrypt-in-place #:decrypt-in-place + + ;; arguments to (MAKE-CIPHER ... :MODE X) + #:ecb #:cbc #:ctr #:ofb #:cfb #:stream + + ;; KDFs + #:pbkdf1 #:pbkdf2 + #:make-kdf #:derive-key + + ;; public-key encryption operations + #:make-public-key #:make-private-key + #:sign-message #:verify-signature + #:encrypt-message #:decrypt-message + + ;; signatures + #:make-dsa-signature + + ;; public-key slot readers + #:dsa-key-p #:dsa-key-q #:dsa-key-g #:dsa-key-y #:dsa-key-x + #:dsa-signature-r #:dsa-signature-s + + ;; conditions + #:ironclad-error #:initialization-vector-not-supplied + #:invalid-initialization-vector #:invalid-key-length + #:unsupported-cipher #:unsupported-mode #:unsupported-digest + #:insufficient-buffer-space #:invalid-padding + #:key-not-supplied + + ;; utilities + #:ascii-string-to-byte-array #:byte-array-to-hex-string + #:octets-to-integer #:integer-to-octets #:expt-mod + + ;; streams + #:make-octet-input-stream #:make-octet-output-stream + #:get-output-stream-octets + + #:make-digesting-stream)) diff --git a/ironclad/sha1.lisp b/ironclad/sha1.lisp new file mode 100644 index 0000000..712cce8 --- /dev/null +++ b/ironclad/sha1.lisp @@ -0,0 +1,237 @@ +;;;; This is an implementation of the US Secure Hash Algorithm 1 (SHA1), +;;;; defined in RFC 3174, written by D. Eastlake and P. Jones, September +;;;; 2001. The RFC was based on the document "Secure Hash Standard", +;;;; United States of America, National Institute of Science and Technology, +;;;; Federal Information Processing Standard (FIPS) 180-1, April 1993. +;;;; +;;;; It was written by Nathan J. Froyd, with many of the main ideas and +;;;; functions grabbed from Pierre R. Mai's CL implementation of MD5, +;;;; available at http://www.pmsf.de/pmai/MD5.html. +;;;; +;;;; This implementation should work on any conforming Common Lisp +;;;; implementation, but it has been optimized for CMU CL and SBCL. +;;;; +;;;; The implementation makes heavy use of (UNSIGNED-BYTE 32) arithmetic; +;;;; if your CL implementation does not implement unboxed arithmetic on +;;;; such numbers, performance will likely be greater in a 16-bit +;;;; implementation. +;;;; +;;;; This software is "as is", and has no warranty of any kind. The +;;;; authors assume no responsibility for the consequences of any use +;;;; of this software. + +(in-package :crypto) + +;;; nonlinear functions + +(defconstant +k1+ #x5a827999) +(defconstant +k2+ #x6ed9eba1) +(defconstant +k3+ #x8f1bbcdc) +(defconstant +k4+ #xca62c1d6) + +;;; working set + +(define-digest-registers (sha1 :endian :big) + (a #x67452301) + (b #xefcdab89) + (c #x98badcfe) + (d #x10325476) + (e #xc3d2e1f0)) + +(defconst +pristine-sha1-registers+ (initial-sha1-regs)) + +(macrolet ((sha1-rounds (block func constant low high &rest initial-order) + ;; Yay for "implementation-dependent" behavior (6.1.1.4). + (let ((xvars (apply #'make-circular-list initial-order))) + (loop for i from low upto high + for vars on xvars by #'cddddr + collect (let ((a-var (first vars)) + (b-var (second vars)) + (c-var (third vars)) + (d-var (fourth vars)) + (e-var (fifth vars))) + `(setf ,e-var + (mod32+ (rol32 ,a-var 5) + (mod32+ (mod32+ (,func ,b-var ,c-var ,d-var) ,e-var) + (mod32+ (aref ,block ,i) ,constant))) + ,b-var (rol32 ,b-var 30))) into forms + finally (return `(progn ,@forms)))))) +(defun update-sha1-block (regs block) + (declare (type sha1-regs regs) + (type (simple-array (unsigned-byte 32) (80)) block) + #.(burn-baby-burn)) + (let ((a (sha1-regs-a regs)) (b (sha1-regs-b regs)) + (c (sha1-regs-c regs)) (d (sha1-regs-d regs)) + (e (sha1-regs-e regs))) + (flet ((f1 (x y z) + (declare (type (unsigned-byte 32) x y z)) + #+cmu + (kernel:32bit-logical-xor z + (kernel:32bit-logical-and x + (kernel:32bit-logical-xor y z))) + #-cmu + (logxor z (logand x (logxor y z)))) + (f2 (x y z) + (declare (type (unsigned-byte 32) x y z)) + #+cmu + (kernel:32bit-logical-xor x (kernel:32bit-logical-xor y z)) + #-cmu + (ldb (byte 32 0) (logxor x y z))) + (f3 (x y z) + (declare (type (unsigned-byte 32) x y z)) + #+cmu + (kernel:32bit-logical-or (kernel:32bit-logical-or + (kernel:32bit-logical-and x y) + (kernel:32bit-logical-and x z)) + (kernel:32bit-logical-and y z)) + #-cmu + (ldb (byte 32 0) + (logior (logand x y) (logand x z) (logand y z))))) + (declare (inline f1 f2 f3)) + ;; core of the algorithm + (sha1-rounds block f1 +k1+ 0 19 a b c d e) + (sha1-rounds block f2 +k2+ 20 39 a b c d e) + (sha1-rounds block f3 +k3+ 40 59 a b c d e) + (sha1-rounds block f2 +k4+ 60 79 a b c d e) + ;; update and return + (setf (sha1-regs-a regs) (mod32+ (sha1-regs-a regs) a) + (sha1-regs-b regs) (mod32+ (sha1-regs-b regs) b) + (sha1-regs-c regs) (mod32+ (sha1-regs-c regs) c) + (sha1-regs-d regs) (mod32+ (sha1-regs-d regs) d) + (sha1-regs-e regs) (mod32+ (sha1-regs-e regs) e)) + regs))) +) ; MACROLET + +(declaim (inline expand-block)) +(defun expand-block (block) + "Expand the first 16 words in BLOCK to fill the entire 80 word space +available." + (declare (type (simple-array (unsigned-byte 32) (80)) block) + #.(burn-baby-burn)) + (loop for i of-type (integer 16 80) from 16 below 80 + do (setf (aref block i) + (rol32 #+cmu + (kernel:32bit-logical-xor + (kernel:32bit-logical-xor (aref block (- i 3)) + (aref block (- i 8))) + (kernel:32bit-logical-xor (aref block (- i 14)) + (aref block (- i 16)))) + #-cmu + (ldb (byte 32 0) + (logxor (aref block (- i 3)) + (aref block (- i 8)) + (aref block (- i 14)) + (aref block (- i 16)))) + 1)))) + +;;; mid-level + +(defstruct (sha1 + (:constructor %make-sha1-digest) + (:constructor %make-sha1-state (regs amount block buffer buffer-index)) + (:copier nil)) + (regs (initial-sha1-regs) :type sha1-regs :read-only t) + (amount 0 :type (unsigned-byte 64)) + (block (make-array 80 :element-type '(unsigned-byte 32)) + :type (simple-array (unsigned-byte 32) (80)) :read-only t) + (buffer (make-array 64 :element-type '(unsigned-byte 8)) + :type (simple-array (unsigned-byte 8) (64)) :read-only t) + (buffer-index 0 :type (integer 0 63))) + +(defmethod reinitialize-instance ((state sha1) &rest initargs) + (declare (ignore initargs)) + (replace (sha1-regs state) +pristine-sha1-registers+) + (setf (sha1-amount state) 0 + (sha1-buffer-index state) 0) + state) + +(defmethod copy-digest ((state sha1) &optional copy) + (declare (type (or cl:null sha1) copy)) + (cond + (copy + (replace (sha1-regs copy) (sha1-regs state)) + (replace (sha1-buffer copy) (sha1-buffer state)) + (setf (sha1-amount copy) (sha1-amount state) + (sha1-buffer-index copy) (sha1-buffer-index state)) + copy) + (t + (%make-sha1-state (copy-seq (sha1-regs state)) + (sha1-amount state) + (copy-seq (sha1-block state)) + (copy-seq (sha1-buffer state)) + (sha1-buffer-index state))))) + +(define-digest-updater sha1 + (let ((regs (sha1-regs state)) + (block (sha1-block state)) + (buffer (sha1-buffer state)) + (buffer-index (sha1-buffer-index state)) + (length (- end start))) + (declare (type sha1-regs regs) (type fixnum length) + (type (integer 0 63) buffer-index) + (type (simple-array (unsigned-byte 32) (80)) block) + (type (simple-array (unsigned-byte 8) (64)) buffer)) + ;; Handle old rest + (unless (zerop buffer-index) + (let ((amount (min (- 64 buffer-index) length))) + (declare (type (integer 0 63) amount)) + (copy-to-buffer sequence start amount buffer buffer-index) + (setq start (the fixnum (+ start amount))) + (let ((new-index (mod (+ buffer-index amount) 64))) + (when (zerop new-index) + (fill-block-ub8-be block buffer 0) + (expand-block block) + (update-sha1-block regs block)) + (when (>= start end) + (setf (sha1-buffer-index state) new-index) + (incf (sha1-amount state) length) + (return-from update-digest state))))) + (loop for offset of-type index from start below end by 64 + until (< (- end offset) 64) + do + (fill-block-ub8-be block sequence offset) + (expand-block block) + (update-sha1-block regs block) + finally + (let ((amount (- end offset))) + (unless (zerop amount) + (copy-to-buffer sequence offset amount buffer 0)) + (setf (sha1-buffer-index state) amount))) + (incf (sha1-amount state) length) + state)) + +(define-digest-finalizer (sha1 20) + (let ((regs (sha1-regs state)) + (block (sha1-block state)) + (buffer (sha1-buffer state)) + (buffer-index (sha1-buffer-index state)) + (total-length (* 8 (sha1-amount state)))) + (declare (type sha1-regs regs) + (type (integer 0 63) buffer-index) + (type (simple-array (unsigned-byte 32) (80)) block) + (type (simple-array (unsigned-byte 8) (64)) buffer)) + (setf (aref buffer buffer-index) #x80) + (when (> buffer-index 55) + (loop for index of-type (integer 0 64) + from (1+ buffer-index) below 64 + do (setf (aref buffer index) #x00)) + (fill-block-ub8-be block buffer 0) + (expand-block block) + (update-sha1-block regs block) + (loop for index of-type (integer 0 16) + from 0 below 16 + do (setf (aref block index) #x00000000))) + (when (<= buffer-index 55) + (loop for index of-type (integer 0 64) + from (1+ buffer-index) below 64 + do (setf (aref buffer index) #x00)) + ;; copy the data to BLOCK prematurely + (fill-block-ub8-be block buffer 0)) + ;; fill in the remaining block data + (store-data-length block total-length 14 t) + (expand-block block) + (update-sha1-block regs block) + (finalize-registers state regs))) + +(defdigest sha1 :digest-length 20 :block-length 64) + |