From: Taylor R Campbell Date: Fri, 3 Nov 2017 21:15:11 +0000 (+0000) Subject: First draft of SHA3-256 with minimal tests. X-Git-Tag: mit-scheme-pucked-9.2.12~14^2~12 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1cc14a8343d4995ae2987d0605d728a8ecc43a79;p=mit-scheme.git First draft of SHA3-256 with minimal tests. Probably full of fenceposts but this is all I have energy for at the moment. --- diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 36973f43a..ce5cac9be 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -589,6 +589,15 @@ USA. quick-sort quick-sort!)) +(define-package (runtime sha3) + (files "sha3") + (parent (runtime)) + (export () + sha3256 + sha3256-final + sha3256-init + sha3256-update)) + (define-package (runtime simple-queue) (files "queue") (parent (runtime)) diff --git a/src/runtime/sha3.scm b/src/runtime/sha3.scm new file mode 100644 index 000000000..7427e0278 --- /dev/null +++ b/src/runtime/sha3.scm @@ -0,0 +1,130 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; SHA-3: FIPS-202, Permutation-Based Hash and Extendable-Output Functions +;;; package: (runtime sha3) + +(declare (usual-integrations)) + +(define-primitives + (bytevector-keccak-f1600 1)) + +(define-structure sha3 + (state #f read-only #t) + nb) + +(define-integrable (sha3-rate-bytes db) + (- 200 (* 2 db))) + +(define-integrable (sha3-init rb) + (make-sha3 (make-bytevector 200 0) rb)) + +(declare (integrate-operator sha3-update)) +(define (sha3-update sha3 bv start end rb) + (assert (< 0 (sha3-nb sha3))) + (let ((i (- rb (sha3-nb sha3))) + (ni (min (- end start) (sha3-nb sha3)))) + ;; If there's a partial buffer, try to fill it. + (assert (<= 0 i)) + (assert (< i rb)) + (assert (<= 0 ni)) + (assert (< ni rb)) + (bytevector-xor! (sha3-state sha3) i bv start ni) + ;; If we couldn't fill the buffer, we're done. + (if (< ni (sha3-nb sha3)) + (set-sha3-nb! sha3 (- (sha3-nb sha3) ni)) + ;; Otherwise, permute and go on. + (begin + (bytevector-keccak-f1600 (sha3-state sha3)) + ;; If we filled a buffer, permute now. + (let loop ((start (+ start ni))) + (if (<= start (- end rb)) + ;; Xor a buffer's worth of input and permute. + (begin + (bytevector-xor! (sha3-state sha3) 0 bv start rb) + (bytevector-keccak-f1600 (sha3-state sha3)) + (loop (+ start rb))) + ;; Partially fill the buffer with as many bytes as we can. + (let ((nf (- end start))) + (assert (< nf rb)) + (bytevector-xor! (sha3-state sha3) 0 bv start nf) + (set-sha3-nb! sha3 (- rb nf))))))))) + +(define-integrable (sha3-final sha3 h hstart db rb) + (assert (<= db (* 8 25))) + (assert (< 0 (sha3-nb sha3))) + ;; Append 01, pad with 10*1 up to buffer boundary, LSB first. + (bytevector-u8-xor! (sha3-state sha3) (- rb (sha3-nb sha3)) #x06) + (bytevector-u8-xor! (sha3-state sha3) (- rb 1) #x80) + (bytevector-keccak-f1600 (sha3-state sha3)) + ;; Reveal the first db bytes of states. + (bytevector-copy! h hstart (sha3-state sha3) 0 db) + ;; Forget the rest. XXX Prevent optimizing away. + (bytevector-fill! (sha3-state sha3) 0) + (set-sha3-nb! sha3 0)) + +(define-integrable (sha3256-rate-bytes) (sha3-rate-bytes 32)) + +(define (sha3256 bv) + (let ((s (sha3256-init)) + (h (make-bytevector 32))) + (sha3256-update s bv 0 (bytevector-length bv)) + (sha3256-final s h 0 32) + h)) + +(define (sha3256-init) + (sha3-init (sha3256-rate-bytes))) + +(define (sha3256-update sha3256 bv start end) + (sha3-update sha3256 bv start end (sha3256-rate-bytes))) + +(define (sha3256-final sha3256 bv start end) + (sha3-final sha3256 bv start (- end start) (sha3256-rate-bytes))) + +(define (bytevector-u8-xor! bv i x) + ;;(declare (no-type-checks) (no-range-checks)) + (guarantee bytevector? bv 'BYTEVECTOR-U8-XOR!) + (guarantee index-fixnum? i 'BYTEVECTOR-U8-XOR!) + (if (not (fix:< i (bytevector-length bv))) + (error:bad-range-argument i 'BYTEVECTOR-U8-XOR!)) + (guarantee u8? x 'BYTEVECTOR-U8-XOR) + (bytevector-u8-set! bv i (fix:xor x (bytevector-u8-ref bv i)))) + +(define (bytevector-xor! t ts f fs n) + ;;(declare (no-type-checks) (no-range-checks)) + (guarantee bytevector? f 'BYTEVECTOR-XOR!) + (guarantee bytevector? t 'BYTEVECTOR-XOR!) + (guarantee index-fixnum? ts 'BYTEVECTOR-XOR!) + (guarantee index-fixnum? fs 'BYTEVECTOR-XOR!) + (if (not (fix:<= n (fix:- (bytevector-length t) ts))) + (error:bad-range-argument ts 'BYTEVECTOR-XOR!)) + (if (not (fix:<= n (fix:- (bytevector-length f) fs))) + (error:bad-range-argument fs 'BYTEVECTOR-XOR!)) + (do ((i 0 (fix:+ i 1))) ((fix:>= i n)) + (let ((ti (bytevector-u8-ref t (fix:+ ts i))) + (fi (bytevector-u8-ref f (fix:+ fs i)))) + (declare (integrate ti fi)) + (bytevector-u8-set! t (fix:+ ts i) (fix:xor ti fi))))) diff --git a/tests/check.scm b/tests/check.scm index 224eb0440..23976a39f 100644 --- a/tests/check.scm +++ b/tests/check.scm @@ -70,6 +70,7 @@ USA. "runtime/test-readwrite" "runtime/test-regsexp" "runtime/test-rgxcmp" + "runtime/test-sha3" "runtime/test-string" "runtime/test-string-normalization" "runtime/test-string-search" diff --git a/tests/runtime/test-sha3.scm b/tests/runtime/test-sha3.scm new file mode 100644 index 000000000..bd4553fb1 --- /dev/null +++ b/tests/runtime/test-sha3.scm @@ -0,0 +1,47 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, + 2017 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +USA. + +|# + +;;;; Tests of SHA-3 functions + +(define-test 'SHA3-256-EMPTY + (lambda () + (assert-equal (sha3256 #u8()) + #u8( + #xa7 #xff #xc6 #xf8 #xbf #x1e #xd7 #x66 + #x51 #xc1 #x47 #x56 #xa0 #x61 #xd6 #x62 + #xf5 #x80 #xff #x4d #xe4 #x3b #x49 #xfa + #x82 #xd8 #x0a #x4b #x80 #xf8 #x43 #x4a + )))) + +(define-test 'SHA3-256-HELLOWORLD + (lambda () + (assert-equal (sha3256 (string->utf8 "hello world")) + #u8( + #x64 #x4b #xcc #x7e #x56 #x43 #x73 #x04 + #x09 #x99 #xaa #xc8 #x9e #x76 #x22 #xf3 + #xca #x71 #xfb #xa1 #xd9 #x72 #xfd #x94 + #xa3 #x1c #x3b #xfb #xf2 #x4e #x39 #x38 + )))) \ No newline at end of file