From 618df43b2d0fb7e59671ae3d40b18a941e51e997 Mon Sep 17 00:00:00 2001 From: "Pierre R. Mai" Date: Fri, 2 Nov 2012 20:47:39 +0100 Subject: [PATCH] Add initial version of project. --- .gitattributes | 2 + .gitignore | 12 ++ COPYING | 25 +++ README | 96 +++++++++ common.lisp | 196 ++++++++++++++++++ keccak-16bit.lisp | 510 ++++++++++++++++++++++++++++++++++++++++++++++ keccak-32bit.lisp | 431 +++++++++++++++++++++++++++++++++++++++ keccak-64bit.lisp | 266 ++++++++++++++++++++++++ pkgdef.lisp | 46 +++++ sha3.asd | 67 ++++++ sha3.lisp | 248 ++++++++++++++++++++++ 11 files changed, 1899 insertions(+) create mode 100644 .gitattributes create mode 100644 .gitignore create mode 100644 COPYING create mode 100644 README create mode 100644 common.lisp create mode 100644 keccak-16bit.lisp create mode 100644 keccak-32bit.lisp create mode 100644 keccak-64bit.lisp create mode 100644 pkgdef.lisp create mode 100644 sha3.asd create mode 100644 sha3.lisp diff --git a/.gitattributes b/.gitattributes new file mode 100644 index 0000000..1a1f266 --- /dev/null +++ b/.gitattributes @@ -0,0 +1,2 @@ +/*.lisp ident +/*.asd ident diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..a6d5a49 --- /dev/null +++ b/.gitignore @@ -0,0 +1,12 @@ +# FASLs +*.fas +*.fasl +*.ofasl +*.nfasl +*.xfasl +*.dx32fsl +*.dx64fsl +*.abcl +*.sse2f +# Backup files +*~ diff --git a/COPYING b/COPYING new file mode 100644 index 0000000..13d39e7 --- /dev/null +++ b/COPYING @@ -0,0 +1,25 @@ + Copyright (C) 2012 PMSF IT Consulting Pierre R. Mai + + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the + "Software"), to deal in the Software without restriction, including + without limitation the rights to use, copy, modify, merge, publish, + distribute, sublicense, and/or sell copies of the Software, and to + permit persons to whom the Software is furnished to do so, subject to + the following conditions: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. + IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY CLAIM, DAMAGES OR + OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, + ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR + OTHER DEALINGS IN THE SOFTWARE. + + Except as contained in this notice, the name of the author shall + not be used in advertising or otherwise to promote the sale, use or + other dealings in this Software without prior written authorization + from the author. diff --git a/README b/README new file mode 100644 index 0000000..bc285bb --- /dev/null +++ b/README @@ -0,0 +1,96 @@ +This library is an implementation of the Secure Hash Algorithm 3 +(SHA-3), also known as Keccak. The implementation is constrained to +messages with an integral number of octets, i.e. sub-byte length +messages are not supported. + +The implementation should be portable across nearly all ANSI compliant +CL with specialized implementations tuned for implementations that +offer unboxed 64bit arithmetic, unboxed 32bit arithmetic and for +implementations with efficient fixnum arithmetic (requiring fixnums +that can represent (unsigned-byte 16)). Especially the 64 and 32bit +implementations have been mostly optimized for SBCL and CMU CL. For +those implementations, digests with a 1024 bit-rate (and 288 bit +digest output) can be generated in between 30 (64bit SBCL) to around +100 (32bit CMU CL) cycles/byte on an i7-640M; whereas optimized +C/assembler implementations reach around 12 to 50 cycles/byte on 64/32 +bit Intel hardware. The reason for the discrepancy probably lies in +missing peephole and dependency optimizations in the SBCL/CMU CL +compiler backend. + +The mid-level interfaces to the digest routines are the functions + +- sha3:sha3-init &key output-bit-length bit-rate + + Create and return a new SHA-3 state. If `output-bit-length' is + specified then the state will run at the bit rate specified for the + given output bit length. If `output-bit-length' is unspecified, + `bit-rate' can be specified to select a suitable bit rate. If both + are left unspecified then a default bit rate of 1024 bits is + selected, which is suitable for arbitrary output bit lengths of up + to 288 bits. + +- sha3:sha3-copy state + + Return an independent copy of the SHA-3 state `state'. + +- sha3:sha3-state-p state + + Test whether a given object is a SHA-3 state, i.e. is an instance of + the class sha3:sha3-state. + +- sha3:sha3-update state vector &key (start 0) (end (length vector)) + + Update the given SHA-3 state `state' from `vector', which must be a + simple-array with element-type (unsigned-byte 8), bounded by `start' + and `end', which must be numeric bounding-indices. + +- sha3:sha3-final state &key output-bit-length + + If the given SHA-3 state `state' has not already been finalized, + finalize it by processing any remaining input in its buffer, with + suitable padding as specified by the SHA-3 standard. Returns the + message digest as a simple-array of (unsigned-byte 8). The length + of the returned digest is determined either by the output bit length + or bit rate specified on state creation, or for the special case of + default parameters being used, by the optional keyword argument + `output-bit-length'. If the state has previously been finalized, + the function will return the digest again. + +For convenience the following high-level functions produce digests in +one step from 1d simple-arrays and streams with element-type +(unsigned-byte 8), as well as files: + +- sha3:sha3-digest-vector vector &key (start 0) end (output-bit-length 512) + + Calculate an SHA-3 message-digest of data in `vector', which should + be a 1d simple-array with element type (unsigned-byte 8), bounded by + `start' and `end'. The bit length of the message digest produced is + controlled by `output-bit-length', which can take on the values 224, + 256, 288, 384 and 512, which is the default value. + +- sha3:sha3-digest-stream stream &key (output-bit-length 512) + + Calculate an SHA-3 message-digest of data read from `stream', which + should be a stream with element type (unsigned-byte 8). The bit + length of the message digest produced is controlled by + `output-bit-length', which can take on the values 224, 256, 288, 384 + and 512, which is the default value. + +- sha3:sha3-digest-file pathname &key (output-bit-length 512) + + Calculate an SHA-3 message-digest of the file specified by + `pathname'. The bit length of the message digest produced is + controlled by `output-bit-length', which can take on the values 224, + 256, 288, 384 and 512, which is the default value. + +Note that in order to generate a message digest of a string it will +have to be converted to a simple-array with element-type +(unsigned-byte 8) in the proper output-encoding. This will have to +rely on implementation-specific functions and is not part of the SHA3 +library. + +The implementation is licensed under the MIT-style license contained +in the file COPYING and the header of each source file. + +Please direct any feedback to pmai@pmsf.de. A git repository of this +library is available under git://github.com/pmai/sha3.git diff --git a/common.lisp b/common.lisp new file mode 100644 index 0000000..6140eec --- /dev/null +++ b/common.lisp @@ -0,0 +1,196 @@ +;;;; SHA3 --- Secure Hash Algorithm 3 (Keccak) Implementation +;;;; +;;;; Copyright (C) 2012 PMSF IT Consulting Pierre R. Mai. +;;;; +;;;; Permission is hereby granted, free of charge, to any person obtaining +;;;; a copy of this software and associated documentation files (the +;;;; "Software"), to deal in the Software without restriction, including +;;;; without limitation the rights to use, copy, modify, merge, publish, +;;;; distribute, sublicense, and/or sell copies of the Software, and to +;;;; permit persons to whom the Software is furnished to do so, subject to +;;;; the following conditions: +;;;; +;;;; The above copyright notice and this permission notice shall be +;;;; included in all copies or substantial portions of the Software. +;;;; +;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +;;;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY CLAIM, DAMAGES OR +;;;; OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, +;;;; ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +;;;; OTHER DEALINGS IN THE SOFTWARE. +;;;; +;;;; Except as contained in this notice, the name of the author shall +;;;; not be used in advertising or otherwise to promote the sale, use or +;;;; other dealings in this Software without prior written authorization +;;;; from the author. +;;;; +;;;; $Id$ + +(cl:in-package #:sha3) + +;;;; %File Description: +;;;; +;;;; This file contains common definitions and utility macros/functions +;;;; used in the specifically optimized implementations of keccak. +;;;; + +;;; +;;; Optimization +;;; + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *optimize-declaration* + '(optimize (speed 3) (space 0) (safety 0) (debug 0)) + "Global optimize declaration used for performance critical functions. +This can be changed prior to compiling the package for debugging/testing +purposes.")) + +;;; +;;; LOGXOR Reduction Hack for certain lisps +;;; + +#+(or lispworks ccl) +(defun logxor (&rest args) + (apply #'cl:logxor args)) + +#+(or lispworks ccl) +(define-compiler-macro logxor (&whole form &rest args) + (labels ((binarify (list) + (if (rest list) + `(cl:logxor ,(car list) ,(binarify (rest list))) + (first list)))) + (if (null args) + form + (binarify args)))) + +;;; +;;; Partial Evaluation Helpers +;;; + +(defun trivial-macroexpand-all (form env) + "Trivial and very restricted code-walker used in partial evaluation macros. +Only supports atoms and function forms, no special forms." + (let ((real-form (macroexpand form env))) + (cond + ((atom real-form) + real-form) + (t + (list* (car real-form) + (mapcar #'(lambda (x) (trivial-macroexpand-all x env)) + (cdr real-form))))))) + +(defmacro dotimes-unrolled ((var limit) &body body &environment env) + "Unroll the loop body at compile-time." + (loop for x from 0 below (eval (trivial-macroexpand-all limit env)) + collect + `(symbol-macrolet ((,var ,x)) ,@body) + into forms + finally + (return `(progn ,@forms)))) + +;;; +;;; Keccak-f-1600 definitions +;;; + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +keccak-state-columns+ 5 + "Width of Keccak state in the x axis") + (defconstant +keccak-state-rows+ 5 + "Width of Keccak state in the y axis") + + (defconstant +keccak-state-lanes+ (* +keccak-state-columns+ +keccak-state-rows+) + "Total number of lanes in Keccak state") + + (defconstant +keccak-1600-lane-width+ 64 + "Lane width for Keccak-1600.") + + (defconstant +keccak-1600-lane-byte-width+ (truncate +keccak-1600-lane-width+ 8) + "Lane width in bytes for Keccak-1600.")) + +(deftype keccak-1600-lane () + "Type of a keccak lane for Keccak-1600." + `(unsigned-byte ,+keccak-1600-lane-width+)) + +;;; +;;; Keccak Constants +;;; + +(defparameter *keccak-f-round-constants* + (make-array '(24) :element-type 'keccak-1600-lane + :initial-contents + #-sha3-fixed-constants + (loop with lfrstate = #x01 + for i from 0 below 24 + collect + (loop with const = 0 + for j from 0 below 7 + for bit-position = (1- (ash 1 j)) + when (logbitp 0 lfrstate) + do (setq const (logxor const (ash 1 bit-position))) + do (setq lfrstate (if (logbitp 7 lfrstate) + (logxor (ldb (byte 8 0) (ash lfrstate 1)) + #x71) + (ash lfrstate 1))) + finally (return const))) + #+sha3-fixed-constants + '(#x0000000000000001 + #x0000000000008082 + #x800000000000808a + #x8000000080008000 + #x000000000000808b + #x0000000080000001 + #x8000000080008081 + #x8000000000008009 + #x000000000000008a + #x0000000000000088 + #x0000000080008009 + #x000000008000000a + #x000000008000808b + #x800000000000008b + #x8000000000008089 + #x8000000000008003 + #x8000000000008002 + #x8000000000000080 + #x000000000000800a + #x800000008000000a + #x8000000080008081 + #x8000000000008080 + #x0000000080000001 + #x8000000080008008)) + "Keccak Round Constants") + +(defparameter *keccak-f-rotate-offsets* + (make-array (list +keccak-state-columns+ +keccak-state-rows+) + :element-type '(unsigned-byte 8) + :initial-contents + '(( 0 36 3 41 18) + ( 1 44 10 45 2) + (62 6 43 15 61) + (28 55 25 21 56) + (27 20 39 8 14))) + "Keccak Rotate Offsets") + +(defmacro get-rotate-offset (x y &environment env) + (aref *keccak-f-rotate-offsets* + (eval (trivial-macroexpand-all x env)) + (eval (trivial-macroexpand-all y env)))) + +;;; +;;; Message Padding for last block +;;; + +(defun pad-message-to-width (message bit-width) + "Destructively pad the given message to the given bit-width according to +Keccak padding rules and return the padded message." + (let ((message-byte-length (length message)) + (width-bytes (truncate bit-width 8))) + (setq message (adjust-array message (list width-bytes))) + (setf (aref message message-byte-length) #x01) + (loop for index from (1+ message-byte-length) below width-bytes + do (setf (aref message index) #x00) + finally + (setf (aref message (1- width-bytes)) + (logior #x80 (aref message (1- width-bytes)))))) + message) diff --git a/keccak-16bit.lisp b/keccak-16bit.lisp new file mode 100644 index 0000000..e7e6e6e --- /dev/null +++ b/keccak-16bit.lisp @@ -0,0 +1,510 @@ +;;;; SHA3 --- Secure Hash Algorithm 3 (Keccak) Implementation +;;;; +;;;; Copyright (C) 2012 PMSF IT Consulting Pierre R. Mai. +;;;; +;;;; Permission is hereby granted, free of charge, to any person obtaining +;;;; a copy of this software and associated documentation files (the +;;;; "Software"), to deal in the Software without restriction, including +;;;; without limitation the rights to use, copy, modify, merge, publish, +;;;; distribute, sublicense, and/or sell copies of the Software, and to +;;;; permit persons to whom the Software is furnished to do so, subject to +;;;; the following conditions: +;;;; +;;;; The above copyright notice and this permission notice shall be +;;;; included in all copies or substantial portions of the Software. +;;;; +;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +;;;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY CLAIM, DAMAGES OR +;;;; OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, +;;;; ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +;;;; OTHER DEALINGS IN THE SOFTWARE. +;;;; +;;;; Except as contained in this notice, the name of the author shall +;;;; not be used in advertising or otherwise to promote the sale, use or +;;;; other dealings in this Software without prior written authorization +;;;; from the author. +;;;; +;;;; $Id$ + +(cl:in-package #:sha3) + +;;;; %File Description: +;;;; +;;;; This file contains an implementation of Keccak 1600 tuned to +;;;; implementations that support efficient arithmetic on fixnums +;;;; which are assumed to be able to represent (unsigned-byte 16) +;;;; numbers. NOTE that the ANSI CL standard only guarantees +;;;; (signed-byte 16), which would also be sufficient but would +;;;; complicate the code somewhat. Since none of the currently useful +;;;; implementations have quite so limited fixnums, the assumption +;;;; should hold sufficiently well. +;;;; +;;;; Implementation Choices: +;;;; +;;;; This is a fairly straightforward implementation of Keccak 1600. +;;;; It employs a bit of loop unrolling at compile-time, and splits +;;;; the 64bit Keccak 1600 lanes into four 16 bit words with bit +;;;; interleaving. It might make sense to test if not using bit +;;;; interleaving makes much of a difference, since we do not use +;;;; hardware rotate instructions in any case. +;;;; + +#+cmu +(eval-when (:compile-toplevel) + (defparameter *old-expansion-limit* ext:*inline-expansion-limit*) + (setq ext:*inline-expansion-limit* (max ext:*inline-expansion-limit* 1000))) + +#+sbcl +(eval-when (:compile-toplevel) + (defparameter *old-expansion-limit* sb-ext:*inline-expansion-limit*) + (setq sb-ext:*inline-expansion-limit* (max sb-ext:*inline-expansion-limit* 1000))) + +;;; +;;; Additional Keccak-f-1600 definitions +;;; + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +keccak-state-splits+ 4 + "Number of lane splits") + + (defconstant +keccak-state-parts+ (* +keccak-state-lanes+ +keccak-state-splits+) + "Total number of partial lanes in Keccak state") + + (defconstant +keccak-1600-part-width+ 16 + "Partial lane width for Keccak-1600.") + + (defconstant +keccak-1600-part-byte-width+ (truncate +keccak-1600-part-width+ 8) + "Partial lane width in bytes for Keccak-1600.")) + +(deftype keccak-1600-part () + "Type of a partial keccak lane for Keccak-1600." + 'fixnum) + +(deftype keccak-1600-state () + "Type of a keccak working state object for Keccak-1600." + `(simple-array keccak-1600-part + (,+keccak-state-parts+))) + +(declaim (inline make-keccak-1600-state) + (ftype (function () keccak-1600-state) make-keccak-1600-state)) +(defun make-keccak-1600-state () + (declare #.*optimize-declaration*) + (make-array '(#.+keccak-state-parts+) + :element-type 'keccak-1600-part + :initial-element 0)) + +;;; +;;; De/Interleaving of bytes +;;; + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun make-interleave-table () + (loop with result = (make-array 256 :element-type '(unsigned-byte 8)) + for value from 0 to 255 + for entry = 0 + do + (loop for bit-index from 0 to 7 + do + (setf (ldb (byte 1 (+ (truncate bit-index 4) (* 2 (mod bit-index 4)))) + entry) + (ldb (byte 1 bit-index) value))) + (setf (aref result value) entry) + finally + (return result))) + + (defun make-deinterleave-table () + (loop with result = (make-array 256 :element-type '(unsigned-byte 8)) + for value from 0 to 255 + for entry = 0 + do + (loop for bit-index from 0 to 7 + do + (setf (ldb (byte 1 (+ (truncate bit-index 4) (* 2 (mod bit-index 4)))) + entry) + (ldb (byte 1 bit-index) value))) + (setf (aref result entry) value) + finally + (return result)))) + +;;; +;;; Transforming linear input/output to state array +;;; + +(defun keccak-state-merge-input (state bit-rate input start) + (declare (type keccak-1600-state state) (type (integer 0 1600) bit-rate) + (type (simple-array (unsigned-byte 8) (*)) input) + (type fixnum start) + #.*optimize-declaration*) + (let ((rate-bytes (truncate bit-rate 8)) + (interleave-lookup (load-time-value (make-interleave-table) t))) + (declare (type (integer 0 200) rate-bytes) + (type (simple-array (unsigned-byte 8) (256)) interleave-lookup)) + (dotimes (y #.+keccak-state-rows+) + (declare (fixnum y)) + (dotimes (x #.+keccak-state-columns+) + (declare (fixnum x)) + (let* ((element (+ (* y +keccak-state-columns+) x)) + (part (* element +keccak-state-splits+)) + (offset (* element +keccak-1600-lane-byte-width+)) + (index (the fixnum (+ start offset)))) + (declare (fixnum element part offset index)) + (when (>= offset rate-bytes) + (return-from keccak-state-merge-input)) + (setf (aref state part) + (logxor + (aref state part) + . + #.(loop for byte-index from 0 + below +keccak-1600-lane-byte-width+ + collect + `(the keccak-1600-part + (ash (ldb (byte 2 0) + (aref interleave-lookup + (aref input (+ index ,byte-index)))) + ,(* byte-index 2))))) + (aref state (1+ part)) + (logxor + (aref state (1+ part)) + . + #.(loop for byte-index from 0 + below +keccak-1600-lane-byte-width+ + collect + `(the keccak-1600-part + (ash (ldb (byte 2 2) + (aref interleave-lookup + (aref input (+ index ,byte-index)))) + ,(* byte-index 2))))) + (aref state (+ part 2)) + (logxor + (aref state (+ part 2)) + . + #.(loop for byte-index from 0 + below +keccak-1600-lane-byte-width+ + collect + `(the keccak-1600-part + (ash (ldb (byte 2 4) + (aref interleave-lookup + (aref input (+ index ,byte-index)))) + ,(* byte-index 2))))) + (aref state (+ part 3)) + (logxor + (aref state (+ part 3)) + . + #.(loop for byte-index from 0 + below +keccak-1600-lane-byte-width+ + collect + `(the keccak-1600-part + (ash (ldb (byte 2 6) + (aref interleave-lookup + (aref input (+ index ,byte-index)))) + ,(* byte-index 2))))))))))) + +(defun keccak-state-extract-output (state output-bits) + (let* ((output-bytes (truncate output-bits 8)) + (digest (make-array (list output-bytes) :element-type '(unsigned-byte 8))) + (deinterleave-lookup (load-time-value (make-deinterleave-table) t))) + (dotimes (x +keccak-state-columns+) + (dotimes (y +keccak-state-rows+) + (let* ((element (+ (* y +keccak-state-columns+) x)) + (part (* element +keccak-state-splits+)) + (offset (* element +keccak-1600-lane-byte-width+))) + (unless (>= offset output-bytes) + (loop with value-even = (aref state part) + with value-odd1 = (aref state (1+ part)) + with value-odd2 = (aref state (+ part 2)) + with value-odd3 = (aref state (+ part 3)) + for index from offset + below (min (+ offset +keccak-1600-lane-byte-width+) output-bytes) + do + (setf (aref digest index) + (aref deinterleave-lookup + (dpb (ldb (byte 2 0) value-odd3) (byte 2 6) + (dpb (ldb (byte 2 0) value-odd2) (byte 2 4) + (dpb (ldb (byte 2 0) value-odd1) (byte 2 2) + (ldb (byte 2 0) value-even))))) + value-even (ash value-even -2) + value-odd1 (ash value-odd1 -2) + value-odd2 (ash value-odd2 -2) + value-odd3 (ash value-odd3 -2))))))) + digest)) + +;;; +;;; Keccak Constants +;;; + +(declaim (inline keccak-f-round-constant) + (ftype (function ((integer 0 23) (integer 0 3)) keccak-1600-part) + keccak-f-round-constant)) +(defun keccak-f-round-constant (i p) + (declare (type (integer 0 23) i) (type (integer 0 3) p) + #.*optimize-declaration*) + (let ((constants + (load-time-value + (make-array #.(* 24 +keccak-state-splits+) + :element-type 'keccak-1600-part + :initial-contents + (loop with itable = (make-interleave-table) + for rc across *keccak-f-round-constants* + nconc + (loop with even = 0 + with odd1 = 0 + with odd2 = 0 + with odd3 = 0 + for bit-offset from 0 below 64 by 8 + for value = (aref itable + (ldb (byte 8 bit-offset) rc)) + do + (setf (ldb (byte 2 (truncate bit-offset 4)) even) + (ldb (byte 2 0) value) + (ldb (byte 2 (truncate bit-offset 4)) odd1) + (ldb (byte 2 2) value) + (ldb (byte 2 (truncate bit-offset 4)) odd2) + (ldb (byte 2 4) value) + (ldb (byte 2 (truncate bit-offset 4)) odd3) + (ldb (byte 2 6) value)) + finally + (return (list even odd1 odd2 odd3))))) + t))) + (declare (type (simple-array keccak-1600-part (#.(* 24 +keccak-state-splits+))) + constants)) + (aref constants (+ (* i +keccak-state-splits+) p)))) + +;;; +;;; Helper: Rotation +;;; + +(declaim (inline keccak-f-rot-part) + (ftype (function (keccak-1600-part (integer 0 16)) keccak-1600-part) + keccak-f-rot-part)) +(defun keccak-f-rot-part (value offset) + (declare (type (integer 0 16) offset) + (type keccak-1600-part value) + #.*optimize-declaration* + #+sbcl + (sb-ext:muffle-conditions sb-ext:code-deletion-note)) + #+(and xxx sbcl) + (if (or (zerop offset) (= offset 16)) + value + (sb-rotate-byte:rotate-byte offset (byte 16 0) value)) + #-(and xxx sbcl) + (if (or (zerop offset) (= offset 16)) + value + (logior (the keccak-1600-part (ash (ldb (byte (- 16 offset) 0) value) offset)) + (ash value (- offset 16))))) + +(declaim (inline keccak-f-rot) + (ftype (function (keccak-1600-part keccak-1600-part + keccak-1600-part keccak-1600-part (integer 0 63)) + (values keccak-1600-part keccak-1600-part + keccak-1600-part keccak-1600-part)) + keccak-f-rot)) +(defun keccak-f-rot (value-even value-odd1 value-odd2 value-odd3 offset) + (declare (type (integer 0 63) offset) + (type keccak-1600-part value-even value-odd1 value-odd2 value-odd3) + #.*optimize-declaration* + #+sbcl + (sb-ext:muffle-conditions sb-ext:code-deletion-note)) + (case (mod offset 4) + (0 + (values + (keccak-f-rot-part value-even (truncate offset 4)) + (keccak-f-rot-part value-odd1 (truncate offset 4)) + (keccak-f-rot-part value-odd2 (truncate offset 4)) + (keccak-f-rot-part value-odd3 (truncate offset 4)))) + (1 + (values + (keccak-f-rot-part value-odd3 (1+ (truncate offset 4))) + (keccak-f-rot-part value-even (truncate offset 4)) + (keccak-f-rot-part value-odd1 (truncate offset 4)) + (keccak-f-rot-part value-odd2 (truncate offset 4)))) + (2 + (values + (keccak-f-rot-part value-odd2 (1+ (truncate offset 4))) + (keccak-f-rot-part value-odd3 (1+ (truncate offset 4))) + (keccak-f-rot-part value-even (truncate offset 4)) + (keccak-f-rot-part value-odd1 (truncate offset 4)))) + (3 + (values + (keccak-f-rot-part value-odd1 (1+ (truncate offset 4))) + (keccak-f-rot-part value-odd2 (1+ (truncate offset 4))) + (keccak-f-rot-part value-odd3 (1+ (truncate offset 4))) + (keccak-f-rot-part value-even (truncate offset 4)))))) + +;;; +;;; State and Temporary Variable Accessors +;;; + +(defmacro with-state-accessors ((&rest states) &body body) + "Bind the contents of the state(s) array(s) to local variables, and save +the content on normal form exit." + (let ((bindings nil) (mappings nil) (save-forms nil)) + (loop for state in states + for map = (make-array '(#.+keccak-state-columns+ #.+keccak-state-rows+ + #.+keccak-state-splits+)) + do + (dotimes (y +keccak-state-rows+) + (dotimes (x +keccak-state-columns+) + (dotimes (p +keccak-state-splits+) + (let ((sym (make-symbol (format nil "~A-~D-~D-~D" state x y p)))) + (setf (aref map x y p) sym) + (push `(,sym (aref ,state ,(+ p (* (+ x (* y +keccak-state-columns+)) + +keccak-state-splits+)))) + bindings) + (push `(setf (aref ,state ,(+ p (* (+ x (* y +keccak-state-columns+)) + +keccak-state-splits+))) + ,sym) + save-forms))))) + (push (cons state map) mappings)) + `(let (,@bindings) + (declare (ignorable ,@(mapcar #'car bindings)) + (type keccak-1600-part ,@(mapcar #'car bindings))) + (macrolet ((state-aref (state x y p &environment env) + (let ((entry (assoc state ',mappings))) + (unless entry (error "Strange: ~S!" state)) + (aref (cdr entry) + (eval (trivial-macroexpand-all x env)) + (eval (trivial-macroexpand-all y env)) + (eval (trivial-macroexpand-all p env)))))) + (multiple-value-prog1 (progn ,@body) + ,@save-forms))))) + +(defmacro with-temp-state ((&rest temps) &body body) + "Bind local variables for each temporary state." + (let ((bindings nil) (mappings nil)) + (loop for temp in temps + for map = (make-array '(#.+keccak-state-columns+ #.+keccak-state-rows+ + #.+keccak-state-splits+)) + do + (dotimes (y +keccak-state-rows+) + (dotimes (x +keccak-state-columns+) + (dotimes (p +keccak-state-splits+) + (let ((sym (make-symbol (format nil "~A-~D-~D-~D" temp x y p)))) + (setf (aref map x y p) sym) + (push `(,sym 0) bindings))))) + (push (cons temp map) mappings)) + `(let (,@bindings) + (declare (ignorable ,@(mapcar #'car bindings)) + (type keccak-1600-part ,@(mapcar #'car bindings))) + (macrolet ((temp-state-aref (temp x y p &environment env) + (let ((entry (assoc temp ',mappings))) + (unless entry (error "Strange: ~S!" temp)) + (aref (cdr entry) + (eval (trivial-macroexpand-all x env)) + (eval (trivial-macroexpand-all y env)) + (eval (trivial-macroexpand-all p env)))))) + ,@body)))) + +(defmacro with-temp-rows ((&rest rows) &body body) + "Bind local variables for each temporary row." + (let ((bindings nil) (mappings nil)) + (loop for row in rows + for map = (make-array '(#.+keccak-state-columns+ #.+keccak-state-splits+)) + do + (dotimes (x +keccak-state-columns+) + (dotimes (p +keccak-state-splits+) + (let ((sym (make-symbol (format nil "~A-~D-~D" row x p)))) + (setf (aref map x p) sym) + (push `(,sym 0) bindings)))) + (push (cons row map) mappings)) + `(let (,@bindings) + (declare (ignorable ,@(mapcar #'car bindings)) + (type keccak-1600-part ,@(mapcar #'car bindings))) + (macrolet ((temp-row-aref (row x p &environment env) + (let ((entry (assoc row ',mappings))) + (unless entry (error "Strange: ~S!" row)) + (aref (cdr entry) + (eval (trivial-macroexpand-all x env)) + (eval (trivial-macroexpand-all p env)))))) + ,@body)))) + +;;; +;;; Keccak-f permutation +;;; + +(declaim (ftype (function (keccak-1600-state) keccak-1600-state) keccak-f)) +(defun keccak-f (a) + (declare (type keccak-1600-state a) + #.*optimize-declaration*) + (with-state-accessors (a) + (with-temp-state (b) + (with-temp-rows (c d) + (dotimes (i #.(+ 12 (* 2 (truncate (log +keccak-1600-lane-width+ 2))))) + (dotimes-unrolled (x +keccak-state-columns+) + (dotimes-unrolled (p +keccak-state-splits+) + (setf (temp-row-aref c x p) + (logxor (state-aref a x 0 p) + (state-aref a x 1 p) + (state-aref a x 2 p) + (state-aref a x 3 p) + (state-aref a x 4 p))))) + (dotimes-unrolled (x +keccak-state-columns+) + (setf (temp-row-aref d x 0) + (logxor (temp-row-aref c (mod (+ +keccak-state-columns+ (1- x)) + +keccak-state-columns+) + 0) + (keccak-f-rot-part + (temp-row-aref c (mod (1+ x) +keccak-state-columns+) 3) + 1)) + (temp-row-aref d x 1) + (logxor (temp-row-aref c (mod (+ +keccak-state-columns+ (1- x)) + +keccak-state-columns+) + 1) + (temp-row-aref c (mod (1+ x) +keccak-state-columns+) 0)) + (temp-row-aref d x 2) + (logxor (temp-row-aref c (mod (+ +keccak-state-columns+ (1- x)) + +keccak-state-columns+) + 2) + (temp-row-aref c (mod (1+ x) +keccak-state-columns+) 1)) + (temp-row-aref d x 3) + (logxor (temp-row-aref c (mod (+ +keccak-state-columns+ (1- x)) + +keccak-state-columns+) + 3) + (temp-row-aref c (mod (1+ x) +keccak-state-columns+) 2)))) + (dotimes-unrolled (x +keccak-state-columns+) + (dotimes-unrolled (y +keccak-state-rows+) + (dotimes-unrolled (p +keccak-state-splits+) + (setf (state-aref a x y p) + (logxor (state-aref a x y p) (temp-row-aref d x p)))))) + (dotimes-unrolled (x +keccak-state-columns+) + (dotimes-unrolled (y +keccak-state-rows+) + (setf (values + (temp-state-aref b y + (mod (+ (* 2 x) (* 3 y)) +keccak-state-rows+) + 0) + (temp-state-aref b y + (mod (+ (* 2 x) (* 3 y)) +keccak-state-rows+) + 1) + (temp-state-aref b y + (mod (+ (* 2 x) (* 3 y)) +keccak-state-rows+) + 2) + (temp-state-aref b y + (mod (+ (* 2 x) (* 3 y)) +keccak-state-rows+) + 3)) + (keccak-f-rot (state-aref a x y 0) (state-aref a x y 1) + (state-aref a x y 2) (state-aref a x y 3) + (get-rotate-offset x y))))) + (dotimes-unrolled (x +keccak-state-columns+) + (dotimes-unrolled (y +keccak-state-rows+) + (dotimes-unrolled (p +keccak-state-splits+) + (setf (state-aref a x y p) + (logxor (temp-state-aref b x y p) + (logandc1 + (temp-state-aref b (mod (1+ x) +keccak-state-columns+) + y p) + (temp-state-aref b (mod (+ x 2) +keccak-state-columns+) + y p))))))) + (dotimes-unrolled (p +keccak-state-splits+) + (setf (state-aref a 0 0 p) + (logxor (state-aref a 0 0 p) + (keccak-f-round-constant i p))))))) + a)) + +#+cmu +(eval-when (:compile-toplevel) + (setq ext:*inline-expansion-limit* *old-expansion-limit*)) + +#+sbcl +(eval-when (:compile-toplevel) + (setq sb-ext:*inline-expansion-limit* *old-expansion-limit*)) diff --git a/keccak-32bit.lisp b/keccak-32bit.lisp new file mode 100644 index 0000000..a63c4f6 --- /dev/null +++ b/keccak-32bit.lisp @@ -0,0 +1,431 @@ +;;;; SHA3 --- Secure Hash Algorithm 3 (Keccak) Implementation +;;;; +;;;; Copyright (C) 2012 PMSF IT Consulting Pierre R. Mai. +;;;; +;;;; Permission is hereby granted, free of charge, to any person obtaining +;;;; a copy of this software and associated documentation files (the +;;;; "Software"), to deal in the Software without restriction, including +;;;; without limitation the rights to use, copy, modify, merge, publish, +;;;; distribute, sublicense, and/or sell copies of the Software, and to +;;;; permit persons to whom the Software is furnished to do so, subject to +;;;; the following conditions: +;;;; +;;;; The above copyright notice and this permission notice shall be +;;;; included in all copies or substantial portions of the Software. +;;;; +;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +;;;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY CLAIM, DAMAGES OR +;;;; OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, +;;;; ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +;;;; OTHER DEALINGS IN THE SOFTWARE. +;;;; +;;;; Except as contained in this notice, the name of the author shall +;;;; not be used in advertising or otherwise to promote the sale, use or +;;;; other dealings in this Software without prior written authorization +;;;; from the author. +;;;; +;;;; $Id$ + +(cl:in-package #:sha3) + +;;;; %File Description: +;;;; +;;;; This file contains an implementation of Keccak 1600 tuned to +;;;; implementations that support unboxed arithmetic on (unsigned-byte +;;;; 32). +;;;; +;;;; Implementation Choices: +;;;; +;;;; This is a fairly straightforward implementation of Keccak 1600, +;;;; mostly tuned to sbcl for x86, and to some degree to cmucl for +;;;; x86. It employs a bit of loop unrolling at compile-time, and +;;;; splits the 64bit Keccak 1600 lanes into two 32 bit words with bit +;;;; interleaving, thereby being able to still use hardware rotate +;;;; support where possible. More advanced implementation techniques +;;;; like plane-per-plane processing, lane complementing and early +;;;; parity (c.f. the Keccak implementation overview) did not seem to +;;;; work well with SBCL's compiler, resulting in slower, less +;;;; readable code. +;;;; + +#+cmu +(eval-when (:compile-toplevel) + (defparameter *old-expansion-limit* ext:*inline-expansion-limit*) + (setq ext:*inline-expansion-limit* (max ext:*inline-expansion-limit* 1000))) + +;;; +;;; Additional Keccak-f-1600 definitions +;;; + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +keccak-state-splits+ 2 + "Number of lane splits") + + (defconstant +keccak-state-parts+ (* +keccak-state-lanes+ +keccak-state-splits+) + "Total number of partial lanes in Keccak state") + + (defconstant +keccak-1600-part-width+ 32 + "Partial lane width for Keccak-1600.") + + (defconstant +keccak-1600-part-byte-width+ (truncate +keccak-1600-part-width+ 8) + "Partial lane width in bytes for Keccak-1600.")) + +(deftype keccak-1600-part () + "Type of a partial keccak lane for Keccak-1600." + `(unsigned-byte ,+keccak-1600-part-width+)) + +(deftype keccak-1600-state () + "Type of a keccak working state object for Keccak-1600." + `(simple-array keccak-1600-part + (,+keccak-state-parts+))) + +(declaim (inline make-keccak-1600-state) + (ftype (function () keccak-1600-state) make-keccak-1600-state)) +(defun make-keccak-1600-state () + (declare #.*optimize-declaration*) + (make-array '(#.+keccak-state-parts+) + :element-type 'keccak-1600-part + :initial-element 0)) + +;;; +;;; De/Interleaving of bytes +;;; + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun make-interleave-table () + (loop with result = (make-array 256 :element-type '(unsigned-byte 8)) + for value from 0 to 255 + for entry = 0 + do + (loop for bit-index from 0 to 7 + do + (setf (ldb (byte 1 (+ (truncate bit-index 2) (* 4 (mod bit-index 2)))) + entry) + (ldb (byte 1 bit-index) value))) + (setf (aref result value) entry) + finally + (return result))) + + (defun make-deinterleave-table () + (loop with result = (make-array 256 :element-type '(unsigned-byte 8)) + for value from 0 to 255 + for entry = 0 + do + (loop for bit-index from 0 to 7 + do + (setf (ldb (byte 1 (+ (truncate bit-index 2) (* 4 (mod bit-index 2)))) + entry) + (ldb (byte 1 bit-index) value))) + (setf (aref result entry) value) + finally + (return result)))) + +;;; +;;; Transforming linear input/output to state array +;;; + +(defun keccak-state-merge-input (state bit-rate input start) + (declare (type keccak-1600-state state) (type (integer 0 1600) bit-rate) + (type (simple-array (unsigned-byte 8) (*)) input) + (type fixnum start) + #.*optimize-declaration*) + (let ((rate-bytes (truncate bit-rate 8)) + (interleave-lookup (load-time-value (make-interleave-table) t))) + (declare (type (integer 0 200) rate-bytes) + (type (simple-array (unsigned-byte 8) (256)) interleave-lookup)) + (dotimes (y #.+keccak-state-rows+) + (declare (fixnum y)) + (dotimes (x #.+keccak-state-columns+) + (declare (fixnum x)) + (let* ((element (+ (* y +keccak-state-columns+) x)) + (part (* element +keccak-state-splits+)) + (offset (* element +keccak-1600-lane-byte-width+)) + (index (the fixnum (+ start offset)))) + (declare (fixnum element part offset index)) + (when (>= offset rate-bytes) + (return-from keccak-state-merge-input)) + (setf (aref state part) + (logxor + (aref state part) + . + #.(loop for byte-index from 0 + below +keccak-1600-lane-byte-width+ + collect + `(the keccak-1600-part + (ash (ldb (byte 4 0) + (aref interleave-lookup + (aref input (+ index ,byte-index)))) + ,(* byte-index 4))))) + (aref state (1+ part)) + (logxor + (aref state (1+ part)) + . + #.(loop for byte-index from 0 + below +keccak-1600-lane-byte-width+ + collect + `(the keccak-1600-part + (ash (ldb (byte 4 4) + (aref interleave-lookup + (aref input (+ index ,byte-index)))) + ,(* byte-index 4))))))))))) + +(defun keccak-state-extract-output (state output-bits) + (let* ((output-bytes (truncate output-bits 8)) + (digest (make-array (list output-bytes) :element-type '(unsigned-byte 8))) + (deinterleave-lookup (load-time-value (make-deinterleave-table) t))) + (dotimes (x +keccak-state-columns+) + (dotimes (y +keccak-state-rows+) + (let* ((element (+ (* y +keccak-state-columns+) x)) + (part (* element +keccak-state-splits+)) + (offset (* element +keccak-1600-lane-byte-width+))) + (unless (>= offset output-bytes) + (loop with value-even = (aref state part) + with value-odd = (aref state (1+ part)) + for index from offset + below (min (+ offset +keccak-1600-lane-byte-width+) output-bytes) + do + (setf (aref digest index) + (aref deinterleave-lookup (dpb (ldb (byte 4 0) value-odd) + (byte 4 4) + (ldb (byte 4 0) value-even))) + value-even (ash value-even -4) + value-odd (ash value-odd -4))))))) + digest)) + +;;; +;;; Keccak Constants +;;; + +(declaim (inline keccak-f-round-constant) + (ftype (function ((integer 0 23) (integer 0 1)) keccak-1600-part) + keccak-f-round-constant)) +(defun keccak-f-round-constant (i p) + (declare (type (integer 0 23) i) (type (integer 0 1) p) + #.*optimize-declaration*) + (let ((constants + (load-time-value + (make-array #.(* 24 +keccak-state-splits+) + :element-type 'keccak-1600-part + :initial-contents + (loop with itable = (make-interleave-table) + for rc across *keccak-f-round-constants* + nconc + (loop with even = 0 + with odd = 0 + for bit-offset from 0 below 64 by 8 + for value = (aref itable + (ldb (byte 8 bit-offset) rc)) + do + (setf (ldb (byte 4 (truncate bit-offset 2)) even) + (ldb (byte 4 0) value) + (ldb (byte 4 (truncate bit-offset 2)) odd) + (ldb (byte 4 4) value)) + finally + (return (list even odd))))) + t))) + (declare (type (simple-array keccak-1600-part (#.(* 24 +keccak-state-splits+))) + constants)) + (aref constants (+ (* i +keccak-state-splits+) p)))) + +;;; +;;; Helper: Rotation +;;; + +(declaim (inline keccak-f-rot-part) + (ftype (function (keccak-1600-part (integer 0 32)) keccak-1600-part) + keccak-f-rot-part)) +(defun keccak-f-rot-part (value offset) + (declare (type (integer 0 32) offset) + (type keccak-1600-part value) + #.*optimize-declaration* + #+sbcl + (sb-ext:muffle-conditions sb-ext:code-deletion-note)) + #+sbcl + (if (or (zerop offset) (= offset 32)) + value + (sb-rotate-byte:rotate-byte offset (byte 32 0) value)) + #-sbcl + (if (or (zerop offset) (= offset 32)) + value + #+ccl + (logior (the keccak-1600-part (ash (ldb (byte (- 32 offset) 0) value) offset)) + (ash value (- offset 32))) + #-ccl + (logior (ldb (byte 32 0) (ash value offset)) + (ash value (- offset 32))))) + +(declaim (inline keccak-f-rot) + (ftype (function (keccak-1600-part keccak-1600-part (integer 0 63)) + (values keccak-1600-part keccak-1600-part)) + keccak-f-rot)) +(defun keccak-f-rot (value-even value-odd offset) + (declare (type (integer 0 63) offset) + (type keccak-1600-part value-even value-odd) + #.*optimize-declaration* + #+sbcl + (sb-ext:muffle-conditions sb-ext:code-deletion-note)) + (if (evenp offset) + (values + (keccak-f-rot-part value-even (truncate offset 2)) + (keccak-f-rot-part value-odd (truncate offset 2))) + (values + (keccak-f-rot-part value-odd (1+ (truncate offset 2))) + (keccak-f-rot-part value-even (truncate offset 2))))) + +;;; +;;; State and Temporary Variable Accessors +;;; + +(defmacro with-state-accessors ((&rest states) &body body) + "Bind the contents of the state(s) array(s) to local variables, and save +the content on normal form exit." + (let ((bindings nil) (mappings nil) (save-forms nil)) + (loop for state in states + for map = (make-array '(#.+keccak-state-columns+ #.+keccak-state-rows+ + #.+keccak-state-splits+)) + do + (dotimes (y +keccak-state-rows+) + (dotimes (x +keccak-state-columns+) + (dotimes (p +keccak-state-splits+) + (let ((sym (make-symbol (format nil "~A-~D-~D-~D" state x y p)))) + (setf (aref map x y p) sym) + (push `(,sym (aref ,state ,(+ p (* (+ x (* y +keccak-state-columns+)) + +keccak-state-splits+)))) + bindings) + (push `(setf (aref ,state ,(+ p (* (+ x (* y +keccak-state-columns+)) + +keccak-state-splits+))) + ,sym) + save-forms))))) + (push (cons state map) mappings)) + `(let (,@bindings) + (declare (ignorable ,@(mapcar #'car bindings)) + (type keccak-1600-part ,@(mapcar #'car bindings))) + (macrolet ((state-aref (state x y p &environment env) + (let ((entry (assoc state ',mappings))) + (unless entry (error "Strange: ~S!" state)) + (aref (cdr entry) + (eval (trivial-macroexpand-all x env)) + (eval (trivial-macroexpand-all y env)) + (eval (trivial-macroexpand-all p env)))))) + (multiple-value-prog1 (progn ,@body) + ,@save-forms))))) + +(defmacro with-temp-state ((&rest temps) &body body) + "Bind local variables for each temporary state." + (let ((bindings nil) (mappings nil)) + (loop for temp in temps + for map = (make-array '(#.+keccak-state-columns+ #.+keccak-state-rows+ + #.+keccak-state-splits+)) + do + (dotimes (y +keccak-state-rows+) + (dotimes (x +keccak-state-columns+) + (dotimes (p +keccak-state-splits+) + (let ((sym (make-symbol (format nil "~A-~D-~D-~D" temp x y p)))) + (setf (aref map x y p) sym) + (push `(,sym 0) bindings))))) + (push (cons temp map) mappings)) + `(let (,@bindings) + (declare (ignorable ,@(mapcar #'car bindings)) + (type keccak-1600-part ,@(mapcar #'car bindings))) + (macrolet ((temp-state-aref (temp x y p &environment env) + (let ((entry (assoc temp ',mappings))) + (unless entry (error "Strange: ~S!" temp)) + (aref (cdr entry) + (eval (trivial-macroexpand-all x env)) + (eval (trivial-macroexpand-all y env)) + (eval (trivial-macroexpand-all p env)))))) + ,@body)))) + +(defmacro with-temp-rows ((&rest rows) &body body) + "Bind local variables for each temporary row." + (let ((bindings nil) (mappings nil)) + (loop for row in rows + for map = (make-array '(#.+keccak-state-columns+ #.+keccak-state-splits+)) + do + (dotimes (x +keccak-state-columns+) + (dotimes (p +keccak-state-splits+) + (let ((sym (make-symbol (format nil "~A-~D-~D" row x p)))) + (setf (aref map x p) sym) + (push `(,sym 0) bindings)))) + (push (cons row map) mappings)) + `(let (,@bindings) + (declare (ignorable ,@(mapcar #'car bindings)) + (type keccak-1600-part ,@(mapcar #'car bindings))) + (macrolet ((temp-row-aref (row x p &environment env) + (let ((entry (assoc row ',mappings))) + (unless entry (error "Strange: ~S!" row)) + (aref (cdr entry) + (eval (trivial-macroexpand-all x env)) + (eval (trivial-macroexpand-all p env)))))) + ,@body)))) + +;;; +;;; Keccak-f permutation +;;; + +(declaim (ftype (function (keccak-1600-state) keccak-1600-state) keccak-f)) +(defun keccak-f (a) + (declare (type keccak-1600-state a) + #.*optimize-declaration*) + (with-state-accessors (a) + (with-temp-state (b) + (with-temp-rows (c d) + (dotimes (i #.(+ 12 (* 2 (truncate (log +keccak-1600-lane-width+ 2))))) + (dotimes-unrolled (x +keccak-state-columns+) + (dotimes-unrolled (p +keccak-state-splits+) + (setf (temp-row-aref c x p) + (logxor (state-aref a x 0 p) + (state-aref a x 1 p) + (state-aref a x 2 p) + (state-aref a x 3 p) + (state-aref a x 4 p))))) + (dotimes-unrolled (x +keccak-state-columns+) + (setf (temp-row-aref d x 0) + (logxor (temp-row-aref c (mod (+ +keccak-state-columns+ (1- x)) + +keccak-state-columns+) + 0) + (keccak-f-rot-part + (temp-row-aref c (mod (1+ x) +keccak-state-columns+) 1) + 1)) + (temp-row-aref d x 1) + (logxor (temp-row-aref c (mod (+ +keccak-state-columns+ (1- x)) + +keccak-state-columns+) + 1) + (temp-row-aref c (mod (1+ x) +keccak-state-columns+) 0)))) + (dotimes-unrolled (x +keccak-state-columns+) + (dotimes-unrolled (y +keccak-state-rows+) + (dotimes-unrolled (p +keccak-state-splits+) + (setf (state-aref a x y p) + (logxor (state-aref a x y p) (temp-row-aref d x p)))))) + (dotimes-unrolled (x +keccak-state-columns+) + (dotimes-unrolled (y +keccak-state-rows+) + (setf (values + (temp-state-aref b y + (mod (+ (* 2 x) (* 3 y)) +keccak-state-rows+) + 0) + (temp-state-aref b y + (mod (+ (* 2 x) (* 3 y)) +keccak-state-rows+) + 1)) + (keccak-f-rot (state-aref a x y 0) (state-aref a x y 1) + (get-rotate-offset x y))))) + (dotimes-unrolled (x +keccak-state-columns+) + (dotimes-unrolled (y +keccak-state-rows+) + (dotimes-unrolled (p +keccak-state-splits+) + (setf (state-aref a x y p) + (logxor (temp-state-aref b x y p) + (logandc1 + (temp-state-aref b (mod (1+ x) +keccak-state-columns+) + y p) + (temp-state-aref b (mod (+ x 2) +keccak-state-columns+) + y p))))))) + (dotimes-unrolled (p +keccak-state-splits+) + (setf (state-aref a 0 0 p) + (logxor (state-aref a 0 0 p) + (keccak-f-round-constant i p))))))) + a)) + +#+cmu +(eval-when (:compile-toplevel) + (setq ext:*inline-expansion-limit* *old-expansion-limit*)) diff --git a/keccak-64bit.lisp b/keccak-64bit.lisp new file mode 100644 index 0000000..924bb64 --- /dev/null +++ b/keccak-64bit.lisp @@ -0,0 +1,266 @@ +;;;; SHA3 --- Secure Hash Algorithm 3 (Keccak) Implementation +;;;; +;;;; Copyright (C) 2012 PMSF IT Consulting Pierre R. Mai. +;;;; +;;;; Permission is hereby granted, free of charge, to any person obtaining +;;;; a copy of this software and associated documentation files (the +;;;; "Software"), to deal in the Software without restriction, including +;;;; without limitation the rights to use, copy, modify, merge, publish, +;;;; distribute, sublicense, and/or sell copies of the Software, and to +;;;; permit persons to whom the Software is furnished to do so, subject to +;;;; the following conditions: +;;;; +;;;; The above copyright notice and this permission notice shall be +;;;; included in all copies or substantial portions of the Software. +;;;; +;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +;;;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY CLAIM, DAMAGES OR +;;;; OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, +;;;; ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +;;;; OTHER DEALINGS IN THE SOFTWARE. +;;;; +;;;; Except as contained in this notice, the name of the author shall +;;;; not be used in advertising or otherwise to promote the sale, use or +;;;; other dealings in this Software without prior written authorization +;;;; from the author. +;;;; +;;;; $Id$ + +(cl:in-package #:sha3) + +;;;; %File Description: +;;;; +;;;; This file contains an implementation of Keccak 1600 tuned to +;;;; implementations that support unboxed arithmetic on (unsigned-byte +;;;; 64). +;;;; +;;;; Implementation Choices: +;;;; +;;;; This is a fairly straightforward implementation of Keccak 1600, +;;;; mostly tuned to sbcl for x86-64. It employs a bit of loop +;;;; unrolling at compile-time. More advanced implementation +;;;; techniques like plane-per-plane processing, lane complementing +;;;; and early parity (c.f. the Keccak implementation overview) did +;;;; not seem to work well with SBCL's compiler, resulting in slower, +;;;; less readable code. +;;;; + +;;; +;;; Additional Keccak-f-1600 definitions +;;; + +(deftype keccak-1600-state () + "Type of a keccak working state object for Keccak-1600." + `(simple-array keccak-1600-lane + (,+keccak-state-lanes+))) + +(declaim (inline make-keccak-1600-state) + (ftype (function () keccak-1600-state) make-keccak-1600-state)) +(defun make-keccak-1600-state () + (declare #.*optimize-declaration*) + (make-array '(#.+keccak-state-lanes+) + :element-type 'keccak-1600-lane + :initial-element 0)) + +;;; +;;; Transforming linear input/output to state array +;;; + +(defun keccak-state-merge-input (state bit-rate input start) + (declare (type keccak-1600-state state) (type (integer 0 1600) bit-rate) + (type (simple-array (unsigned-byte 8) (*)) input) + (type fixnum start) + #.*optimize-declaration*) + (let ((rate-bytes (truncate bit-rate 8))) + (declare (type (integer 0 200) rate-bytes)) + (dotimes (y +keccak-state-rows+) + (dotimes (x +keccak-state-columns+) + (let* ((element (+ (* y +keccak-state-columns+) x)) + (offset (* element +keccak-1600-lane-byte-width+)) + (index (the fixnum (+ start offset)))) + (when (>= offset rate-bytes) + (return-from keccak-state-merge-input)) + (setf (aref state element) + (logxor + (aref state element) + . + #.(loop for byte-index from 0 + below +keccak-1600-lane-byte-width+ + collect + `(the keccak-1600-lane + (ash (aref input (+ index ,byte-index)) + ,(* byte-index 8))))))))))) + +(defun keccak-state-extract-output (state output-bits) + (let* ((output-bytes (truncate output-bits 8)) + (digest (make-array (list output-bytes) :element-type '(unsigned-byte 8)))) + (dotimes (x +keccak-state-columns+) + (dotimes (y +keccak-state-rows+) + (let* ((element (+ (* y +keccak-state-columns+) x)) + (offset (* element +keccak-1600-lane-byte-width+))) + (unless (>= offset output-bytes) + (loop with value = (aref state element) + for index from offset + below (min (+ offset +keccak-1600-lane-byte-width+) output-bytes) + do + (setf (aref digest index) (ldb (byte 8 0) value) + value (ash value -8))))))) + digest)) + +;;; +;;; Keccak Constants +;;; + +(declaim (inline keccak-f-round-constant) + (ftype (function ((integer 0 23)) keccak-1600-lane) keccak-f-round-constant)) +(defun keccak-f-round-constant (i) + (declare (type (integer 0 23) i) + #.*optimize-declaration*) + (let ((constants (load-time-value *keccak-f-round-constants* t))) + (declare (type (simple-array keccak-1600-lane (24)) constants)) + (aref constants i))) + +;;; +;;; Helper: Rotation +;;; + +(declaim (inline keccak-f-rot) + (ftype (function (keccak-1600-lane (integer 0 63)) keccak-1600-lane) + keccak-f-rot)) +(defun keccak-f-rot (value offset) + (declare (type (integer 0 63) offset) + (type keccak-1600-lane value) + #.*optimize-declaration*) + #+sbcl + (sb-rotate-byte:rotate-byte offset (byte 64 0) value) + #-sbcl + (if (zerop offset) + value + (logior (ldb (byte 64 0) (ash value offset)) + (ash value (- offset 64))))) + +;;; +;;; State and Temporary Variable Accessors +;;; + +(defmacro with-state-accessors ((&rest states) &body body) + "Bind the contents of the state(s) array(s) to local variables, and save +the content on normal form exit." + (let ((bindings nil) (mappings nil) (save-forms nil)) + (loop for state in states + for map = (make-array '(#.+keccak-state-columns+ #.+keccak-state-rows+)) + do + (dotimes (y +keccak-state-rows+) + (dotimes (x +keccak-state-columns+) + (let ((sym (make-symbol (format nil "~A-~D-~D" state x y)))) + (setf (aref map x y) sym) + (push `(,sym (aref ,state ,(+ x (* y +keccak-state-columns+)))) + bindings) + (push `(setf (aref ,state ,(+ x (* y +keccak-state-columns+))) ,sym) + save-forms)))) + (push (cons state map) mappings)) + `(let (,@bindings) + (declare (ignorable ,@(mapcar #'car bindings)) + (type keccak-1600-lane ,@(mapcar #'car bindings))) + (macrolet ((state-aref (state x y &environment env) + (let ((entry (assoc state ',mappings))) + (unless entry (error "Strange: ~S!" state)) + (aref (cdr entry) + (eval (trivial-macroexpand-all x env)) + (eval (trivial-macroexpand-all y env)))))) + (multiple-value-prog1 (progn ,@body) + ,@save-forms))))) + +(defmacro with-temp-state ((&rest temps) &body body) + "Bind local variables for each temporary state." + (let ((bindings nil) (mappings nil)) + (loop for temp in temps + for map = (make-array '(#.+keccak-state-columns+ #.+keccak-state-rows+)) + do + (dotimes (y +keccak-state-rows+) + (dotimes (x +keccak-state-columns+) + (let ((sym (make-symbol (format nil "~A-~D-~D" temp x y)))) + (setf (aref map x y) sym) + (push `(,sym 0) bindings)))) + (push (cons temp map) mappings)) + `(let (,@bindings) + (declare (ignorable ,@(mapcar #'car bindings)) + (type keccak-1600-lane ,@(mapcar #'car bindings))) + (macrolet ((temp-state-aref (temp x y &environment env) + (let ((entry (assoc temp ',mappings))) + (unless entry (error "Strange: ~S!" temp)) + (aref (cdr entry) + (eval (trivial-macroexpand-all x env)) + (eval (trivial-macroexpand-all y env)))))) + ,@body)))) + +(defmacro with-temp-rows ((&rest rows) &body body) + "Bind local variables for each temporary row." + (let ((bindings nil) (mappings nil)) + (loop for row in rows + for map = (make-array '(#.+keccak-state-columns+)) + do + (dotimes (x +keccak-state-columns+) + (let ((sym (make-symbol (format nil "~A-~D" row x)))) + (setf (aref map x) sym) + (push `(,sym 0) bindings))) + (push (cons row map) mappings)) + `(let (,@bindings) + (declare (ignorable ,@(mapcar #'car bindings)) + (type keccak-1600-lane ,@(mapcar #'car bindings))) + (macrolet ((temp-row-aref (row x &environment env) + (let ((entry (assoc row ',mappings))) + (unless entry (error "Strange: ~S!" row)) + (aref (cdr entry) + (eval (trivial-macroexpand-all x env)))))) + ,@body)))) + +;;; +;;; Keccak-f permutation +;;; + +(declaim (ftype (function (keccak-1600-state) keccak-1600-state) keccak-f)) +(defun keccak-f (a) + (declare (type keccak-1600-state a) + #.*optimize-declaration*) + (with-state-accessors (a) + (with-temp-state (b) + (with-temp-rows (c d) + (dotimes (i #.(+ 12 (* 2 (truncate (log +keccak-1600-lane-width+ 2))))) + (dotimes-unrolled (x +keccak-state-columns+) + (setf (temp-row-aref c x) + (logxor (state-aref a x 0) + (state-aref a x 1) + (state-aref a x 2) + (state-aref a x 3) + (state-aref a x 4)))) + (dotimes-unrolled (x +keccak-state-columns+) + (setf (temp-row-aref d x) + (logxor (temp-row-aref c (mod (+ +keccak-state-columns+ (1- x)) + +keccak-state-columns+)) + (keccak-f-rot + (temp-row-aref c (mod (1+ x) +keccak-state-columns+)) + 1)))) + (dotimes-unrolled (x +keccak-state-columns+) + (dotimes-unrolled (y +keccak-state-rows+) + (setf (state-aref a x y) + (logxor (state-aref a x y) (temp-row-aref d x))))) + (dotimes-unrolled (x +keccak-state-columns+) + (dotimes-unrolled (y +keccak-state-rows+) + (setf (temp-state-aref b y + (mod (+ (* 2 x) (* 3 y)) +keccak-state-rows+)) + (keccak-f-rot (state-aref a x y) + (get-rotate-offset x y))))) + (dotimes-unrolled (x +keccak-state-columns+) + (dotimes-unrolled (y +keccak-state-rows+) + (setf (state-aref a x y) + (logxor (temp-state-aref b x y) + (logandc1 + (temp-state-aref b (mod (1+ x) +keccak-state-columns+) y) + (temp-state-aref b (mod (+ x 2) +keccak-state-columns+) + y)))))) + (setf (state-aref a 0 0) (logxor (state-aref a 0 0) + (keccak-f-round-constant i)))))) + a)) diff --git a/pkgdef.lisp b/pkgdef.lisp new file mode 100644 index 0000000..3449bca --- /dev/null +++ b/pkgdef.lisp @@ -0,0 +1,46 @@ +;;;; SHA3 --- Secure Hash Algorithm 3 (Keccak) Implementation +;;;; +;;;; Copyright (C) 2012 PMSF IT Consulting Pierre R. Mai. +;;;; +;;;; Permission is hereby granted, free of charge, to any person obtaining +;;;; a copy of this software and associated documentation files (the +;;;; "Software"), to deal in the Software without restriction, including +;;;; without limitation the rights to use, copy, modify, merge, publish, +;;;; distribute, sublicense, and/or sell copies of the Software, and to +;;;; permit persons to whom the Software is furnished to do so, subject to +;;;; the following conditions: +;;;; +;;;; The above copyright notice and this permission notice shall be +;;;; included in all copies or substantial portions of the Software. +;;;; +;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +;;;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY CLAIM, DAMAGES OR +;;;; OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, +;;;; ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +;;;; OTHER DEALINGS IN THE SOFTWARE. +;;;; +;;;; Except as contained in this notice, the name of the author shall +;;;; not be used in advertising or otherwise to promote the sale, use or +;;;; other dealings in this Software without prior written authorization +;;;; from the author. +;;;; +;;;; $Id$ + +;;;; %File Description: +;;;; +;;;; This file contains the package definition +;;;; + +(cl:defpackage #:sha3 + (:use #:common-lisp) + #+(or lispworks ccl) + (:shadow #:logxor) + (:export + ;; Mid-Level + #:sha3-state #:sha3-state-p + #:sha3-init #:sha3-copy #:sha3-update #:sha3-final + ;; High-Level + #:sha3-digest-vector #:sha3-digest-stream #:sha3-digest-file + )) diff --git a/sha3.asd b/sha3.asd new file mode 100644 index 0000000..2cbc585 --- /dev/null +++ b/sha3.asd @@ -0,0 +1,67 @@ +;;;; SHA3 --- Secure Hash Algorithm 3 (Keccak) Implementation +;;;; +;;;; Copyright (C) 2012 PMSF IT Consulting Pierre R. Mai. +;;;; +;;;; Permission is hereby granted, free of charge, to any person obtaining +;;;; a copy of this software and associated documentation files (the +;;;; "Software"), to deal in the Software without restriction, including +;;;; without limitation the rights to use, copy, modify, merge, publish, +;;;; distribute, sublicense, and/or sell copies of the Software, and to +;;;; permit persons to whom the Software is furnished to do so, subject to +;;;; the following conditions: +;;;; +;;;; The above copyright notice and this permission notice shall be +;;;; included in all copies or substantial portions of the Software. +;;;; +;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +;;;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY CLAIM, DAMAGES OR +;;;; OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, +;;;; ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +;;;; OTHER DEALINGS IN THE SOFTWARE. +;;;; +;;;; Except as contained in this notice, the name of the author shall +;;;; not be used in advertising or otherwise to promote the sale, use or +;;;; other dealings in this Software without prior written authorization +;;;; from the author. +;;;; +;;;; $Id$ + +(cl:in-package #:cl-user) + +;;;; %File Description: +;;;; +;;;; This file contains the system definition form for the SHA3 +;;;; Library. System definitions use the ASDF system definition +;;;; facility. +;;;; + +(asdf:defsystem "sha3" + :description "Secure Hash Algorithm 3 (Keccak) Implementation" + :author "Pierre R. Mai " + :maintainer "Pierre R. Mai " + :licence "MIT/X11" + :version "1.0.0" + #+sbcl :depends-on #+sbcl ("sb-rotate-byte") + :components ((:file "pkgdef") + (:file "common" :depends-on ("pkgdef")) + #+(and :sbcl (or :x86-64 :alpha)) + (:file "keccak-64bit" :depends-on ("pkgdef" "common")) + #+(or (and :sbcl (not (or :x86-64 :alpha))) + :cmucl + (and :ccl :64-bit-target)) + (:file "keccak-32bit" :depends-on ("pkgdef" "common")) + #-(or :sbcl :cmucl (and :ccl :64-bit-target)) + (:file "keccak-16bit" :depends-on ("pkgdef" "common")) + (:file "sha3" + :depends-on ("pkgdef" + "common" + #+(and :sbcl (or :x86-64 :alpha)) + "keccak-64bit" + #+(or (and :sbcl (not (or :x86-64 :alpha))) + :cmucl + (and :ccl :64-bit-target)) + "keccak-32bit" + #-(or :sbcl :cmucl (and :ccl :64-bit-target)) + "keccak-16bit")))) diff --git a/sha3.lisp b/sha3.lisp new file mode 100644 index 0000000..74edf05 --- /dev/null +++ b/sha3.lisp @@ -0,0 +1,248 @@ +;;;; SHA3 --- Secure Hash Algorithm 3 (Keccak) Implementation +;;;; +;;;; Copyright (C) 2012 PMSF IT Consulting Pierre R. Mai. +;;;; +;;;; Permission is hereby granted, free of charge, to any person obtaining +;;;; a copy of this software and associated documentation files (the +;;;; "Software"), to deal in the Software without restriction, including +;;;; without limitation the rights to use, copy, modify, merge, publish, +;;;; distribute, sublicense, and/or sell copies of the Software, and to +;;;; permit persons to whom the Software is furnished to do so, subject to +;;;; the following conditions: +;;;; +;;;; The above copyright notice and this permission notice shall be +;;;; included in all copies or substantial portions of the Software. +;;;; +;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +;;;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY CLAIM, DAMAGES OR +;;;; OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, +;;;; ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +;;;; OTHER DEALINGS IN THE SOFTWARE. +;;;; +;;;; Except as contained in this notice, the name of the author shall +;;;; not be used in advertising or otherwise to promote the sale, use or +;;;; other dealings in this Software without prior written authorization +;;;; from the author. +;;;; +;;;; $Id$ + +(cl:in-package #:sha3) + +;;;; %File Description: +;;;; +;;;; This file contains the implementation of mid- and high-level +;;;; SHA-3 functions based on the optimized Keccak implementations. +;;;; +;;;; The main entry points are the mid-level functions sha3-init, +;;;; sha3-update and sha3-final to initialize, update and finalize an +;;;; sha3 hash, and sha3-copy in order to copy a sha3 state. +;;;; +;;;; For convenience high-level functions to hash a given vector, +;;;; stream or file are provided as sha3-digest-vector, +;;;; sha3-digest-stream and sha3-digest-vector. +;;;; + +;;; +;;; Mid-Level Routines +;;; + +(defstruct (sha3-state + (:constructor make-sha3-state (bit-rate)) + (:copier)) + (state (make-keccak-1600-state) :type keccak-1600-state :read-only t) + (bit-rate 1024 :type (integer 0 1600) :read-only t) + (buffer (make-array 200 :element-type '(unsigned-byte 8)) :read-only t + :type (simple-array (unsigned-byte 8) (200))) + (buffer-index 0 :type (integer 0 199)) + (finalized-p nil)) + +(defun sha3-init (&key (output-bit-length nil output-bit-length-p) + (bit-rate (if (and output-bit-length-p + output-bit-length) + (- 1600 (* 2 output-bit-length)) + 1024))) + "Create and return a new SHA-3 state. If `output-bit-length' is specified +then the state will run at the bit rate specified for the given output bit +length. If `output-bit-length' is unspecified, `bit-rate' can be specified +to select a suitable bit rate. If both are left unspecified then a default +bit rate of 1024 bits is selected, which is suitable for arbitrary output +bit lengths of up to 288 bits." + (check-type output-bit-length (member nil 224 256 288 384 512) + "Legal output-bit-length specifier for SHA-3/Keccak-1600") + (check-type bit-rate (member 576 832 1024 1088 1152) + "Legal bit-rate for SHA-3/Keccak-1600") + (if (or (null output-bit-length) + (= bit-rate (- 1600 (* 2 output-bit-length))) + (= bit-rate 1024)) + (make-sha3-state bit-rate) + (error "Illegal combination of output-bit-length ~D and bit-rate ~D." + output-bit-length bit-rate))) + +(defun sha3-copy (state) + "Return an independent copy of the SHA-3 state `state'." + (let ((result (make-sha3-state (sha3-state-bit-rate state)))) + (setf (sha3-state-buffer-index result) (sha3-state-buffer-index state) + (sha3-state-finalized-p result) (sha3-state-finalized-p state)) + (replace (sha3-state-buffer result) (sha3-state-buffer state)) + (replace (sha3-state-state result) (sha3-state-state state)) + result)) + +(defun sha3-update (state vector &key (start 0) (end (length vector))) + "Update the given SHA-3 state `state' from `vector', which must be +a simple-array with element-type (unsigned-byte 8), bounded by `start' +and `end', which must be numeric bounding-indices." + (declare (type sha3-state state) + (type (simple-array (unsigned-byte 8) (*)) vector) + (type fixnum start end) + (optimize (speed 3) (safety 1) (space 0) (debug 1))) + (let* ((keccak-state (sha3-state-state state)) + (buffer (sha3-state-buffer state)) + (buffer-index (sha3-state-buffer-index state)) + (bit-rate (sha3-state-bit-rate state)) + (rate-bytes (truncate bit-rate 8))) + (declare (type keccak-1600-state keccak-state) + (type (simple-array (unsigned-byte 8) (200)) buffer) + (type (integer 0 199) buffer-index) + (type (integer 0 1600) bit-rate) + (type (integer 0 200) rate-bytes) + #.*optimize-declaration*) + ;; Handle potential remaining bytes + (unless (zerop buffer-index) + (let ((remainder (- (length buffer) buffer-index))) + (declare (type fixnum remainder)) + (replace buffer vector :start1 buffer-index :start2 start :end2 end) + (when (>= (- end start) remainder) + (keccak-state-merge-input keccak-state bit-rate buffer 0) + (keccak-f keccak-state)) + (setf (sha3-state-buffer-index state) 0 + start (min (+ start remainder) end)))) + ;; Now handle full blocks, stuff any remainder into buffer + (loop for block-offset of-type fixnum from start to end by rate-bytes + do + (cond + ((<= (+ block-offset rate-bytes) end) + (keccak-state-merge-input keccak-state bit-rate vector block-offset) + (keccak-f keccak-state)) + (t + (replace buffer vector :start1 0 :start2 block-offset) + (setf (sha3-state-buffer-index state) (- end block-offset))))))) + +(defun sha3-final (state &key (output-bit-length nil output-bit-length-p)) + "If the given SHA-3 state `state' has not already been finalized, +finalize it by processing any remaining input in its buffer, with +suitable padding as specified by the SHA-3 standard. Returns the +message digest as a simple-array of (unsigned-byte 8). The length +of the returned digest is determined either by the output bit length +or bit rate specified on state creation, or for the special case of +default parameters being used, by the optional keyword argument +`output-bit-length'. If the state has previously been finalized, +the function will return the digest again." + (declare (type sha3-state state) + (type (or null (integer 0 1600)) output-bit-length) + (optimize (speed 3) (safety 1) (space 0) (debug 1))) + (let ((keccak-state (sha3-state-state state)) + (buffer (sha3-state-buffer state)) + (buffer-index (sha3-state-buffer-index state)) + (bit-rate (sha3-state-bit-rate state)) + (finalized-p (sha3-state-finalized-p state))) + (declare (type keccak-1600-state keccak-state) + (type (simple-array (unsigned-byte 8) (200)) buffer) + (type (integer 0 199) buffer-index) + (type (integer 0 1600) bit-rate) + (type (or null (simple-array (unsigned-byte 8) (*))) finalized-p) + #.*optimize-declaration*) + ;; Determine output-bit-length + (if output-bit-length-p + (unless (or (= bit-rate 1024) + (= (* 2 output-bit-length) (- 1600 bit-rate))) + (error "Illegal output-bit-length ~D specified!" output-bit-length)) + (setq output-bit-length (truncate (- 1600 bit-rate) 2))) + (cond + ;; Check if already finalized + (finalized-p + (unless (= (* (length finalized-p) 8) output-bit-length) + (error "Mismatch in output-bit-length ~D in repeated call to sha3-final! ~ + Should be: ~D!" + output-bit-length (* (length finalized-p) 8))) + finalized-p) + ;; Finalize + (t + (keccak-state-merge-input keccak-state bit-rate + (pad-message-to-width + (subseq buffer 0 buffer-index) + bit-rate) + 0) + (keccak-f keccak-state) + (setf (sha3-state-buffer-index state) 0 + (sha3-state-finalized-p state) + (keccak-state-extract-output keccak-state output-bit-length)))))) + +;;; +;;; High-Level Routines +;;; + +(defun sha3-digest-vector (vector &key (start 0) end + (output-bit-length 512)) + "Calculate an SHA-3 message-digest of data in `vector', which should +be a 1d simple-array with element type (unsigned-byte 8), bounded by +`start' and `end'. The bit length of the message digest produced is +controlled by `output-bit-length', which can take on the values 224, +256, 288, 384 and 512, which is the default value." + (declare (optimize (speed 3) (safety 3) (space 0) (debug 1)) + (type (simple-array (unsigned-byte 8) (*)) vector) + (type fixnum start) + (type (or null fixnum) end) + (type (integer 0 1600) output-bit-length)) + (locally + (declare (optimize (safety 1) (debug 0))) + (let ((state (sha3-init :output-bit-length output-bit-length))) + (declare (type sha3-state state)) + (let ((real-end (or end (length vector)))) + (declare (type fixnum real-end)) + (sha3-update state vector :start start :end real-end)) + (sha3-final state)))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +buffer-size+ (* 128 1024) + "Size of internal buffer to use for `sha3-digest-stream' and +`sha3-digest-file' operations.")) + +(deftype buffer-index () `(integer 0 ,+buffer-size+)) + +(defun sha3-digest-stream (stream &key (output-bit-length 512)) + "Calculate an SHA-3 message-digest of data read from `stream', which +should be a stream with element type (unsigned-byte 8). The bit +length of the message digest produced is controlled by +`output-bit-length', which can take on the values 224, 256, 288, 384 +and 512, which is the default value." + (declare (optimize (speed 3) (safety 3) (space 0) (debug 1)) + (type stream stream) + (type (integer 0 1600) output-bit-length)) + (locally + (declare (optimize (safety 1) (debug 0))) + (unless (equal (stream-element-type stream) '(unsigned-byte 8)) + (error "Illegal stream-element-type ~S, must be ~S." + (stream-element-type stream) '(unsigned-byte 8))) + (let ((buffer (make-array '(#.+buffer-size+) :element-type '(unsigned-byte 8))) + (state (sha3-init :output-bit-length output-bit-length))) + (declare (type sha3-state state) + (type (simple-array (unsigned-byte 8) (#.+buffer-size+)) buffer)) + (loop for bytes of-type buffer-index = (read-sequence buffer stream) + do (sha3-update state buffer :end bytes) + until (< bytes +buffer-size+) + finally + (return (sha3-final state)))))) + +(defun sha3-digest-file (pathname &key (output-bit-length 512)) + "Calculate an SHA-3 message-digest of the file specified by +`pathname'. The bit length of the message digest produced is +controlled by `output-bit-length', which can take on the values 224, +256, 288, 384 and 512, which is the default value." + (declare (optimize (speed 3) (safety 3) (space 0) (debug 1)) + (type (integer 0 1600) output-bit-length)) + (locally + (declare (optimize (safety 1) (debug 0))) + (with-open-file (stream pathname :element-type '(unsigned-byte 8)) + (sha3-digest-stream stream :output-bit-length output-bit-length))))