diff options
| -rw-r--r-- | hmac.rkt | 5 | ||||
| -rw-r--r-- | salsa-chacha.rkt | 186 | ||||
| -rw-r--r-- | typed-stream.rkt | 12 | ||||
| -rw-r--r-- | util.rkt | 28 | ||||
| -rw-r--r-- | whirlpool.rkt | 2 |
5 files changed, 225 insertions, 8 deletions
@@ -36,7 +36,7 @@ [ipad (make-bytes blocksize #x36)] [padded-key (pad-bytes (if (> (bytes-length key) blocksize) - (integer->bytes (hashfn key)) + (integer->bytes (hashfn key) 'big-endian) key) blocksize #x0 @@ -44,6 +44,7 @@ (hashfn (bytes-append (integer->bytes/size (bitwise-xor (bytes->integer opad) (bytes->integer padded-key)) + 'big-endian blocksize) (integer->bytes/size (hashfn @@ -51,8 +52,10 @@ (integer->bytes/size (bitwise-xor (bytes->integer ipad) (bytes->integer padded-key)) + 'big-endian blocksize) msg)) + 'big-endian hashsize))))) ;; According to Ironclad: diff --git a/salsa-chacha.rkt b/salsa-chacha.rkt new file mode 100644 index 0000000..17af9c8 --- /dev/null +++ b/salsa-chacha.rkt @@ -0,0 +1,186 @@ +#lang typed/racket +;;; Copyright 2011, Matthias Andreas Benkard. +;;; +;;;----------------------------------------------------------------------------- +;;; This program is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU Affero General Public License as published by +;;; the Free Software Foundation, either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU Affero General Public License for more details. +;;; +;;; You should have received a copy of the GNU Affero General Public License +;;; along with this program. If not, see <http://www.gnu.org/licenses/>. +;;;----------------------------------------------------------------------------- +;;; + +(require "util.rkt") + +(provide salsa20) + +(require/typed racket/stream + [empty-stream #;(All (a) (Sequenceof a)) + (Sequenceof Byte)]) + +(require/typed racket + [sequence-generate (All (a) + (Sequenceof a) + -> (values (-> Boolean) + (-> a)))]) + +(require/typed "typed-stream.rkt" + [lazy-functional-stream-append (All (a) + ((Sequenceof a) + (-> (Sequenceof a)) + -> (Sequenceof a)))]) + +(define-type Word Exact-Nonnegative-Integer) +(define-type 4words (Vector Word Word Word Word)) +(define-type 16words (Vector Word Word Word Word + Word Word Word Word + Word Word Word Word + Word Word Word Word)) + +(: w+ (Word Word -> Word)) +(define (w+ a b) + (bitwise-and (+ a b) #xffffffff)) + +(: wxor (Word Word -> Word)) +(define wxor bitwise-xor) + +(: wrot (Word Exact-Positive-Integer -> Word)) +(define (wrot a e) + (let ([ash (arithmetic-shift a e)]) + (bitwise-ior (bitwise-and ash #xffffffff) + (arithmetic-shift ash -32)))) + + +(: quarterround (4words -> 4words)) +(define (quarterround y) + (match y + [(vector y0 y1 y2 y3) + (let* ([z1 (wxor y1 (wrot (w+ y0 y3) 7))] + [z2 (wxor y2 (wrot (w+ z1 y0) 9))] + [z3 (wxor y3 (wrot (w+ z2 z1) 13))] + [z0 (wxor y0 (wrot (w+ z3 z2) 18))]) + (vector z0 z1 z2 z3))])) + +(: chacha-quarterround (4words -> 4words)) +(define (chacha-quarterround y) + (match y + [(vector a b c d) + (let* ([a2 (w+ a b)] [d2 (wrot (wxor a2 d) 16)] + [c2 (w+ c d2)] [b2 (wrot (wxor b c2) 12)] + [a3 (w+ a2 b2)] [d3 (wrot (wxor d2 a3) 8)] + [c3 (w+ c2 d3)] [b3 (wrot (wxor b2 c2) 7)]) + (vector a3 b3 c3 d3))])) + +(: rowround (16words -> 16words)) +(define (rowround y) + (match y + [(vector y0 y1 y2 y3 y4 y5 y6 y7 y8 y9 y10 y11 y12 y13 y14 y15) + (match (vector (quarterround (vector y0 y1 y2 y3)) + (quarterround (vector y5 y6 y7 y4)) + (quarterround (vector y10 y11 y8 y9)) + (quarterround (vector y15 y12 y13 y14))) + [(vector (vector z0 z1 z2 z3) (vector z5 z6 z7 z4) + (vector z10 z11 z8 z9) (vector z15 z12 z13 z14)) + (vector z0 z1 z2 z3 z4 z5 z6 z7 z8 z9 z10 z11 z12 z13 z14 z15)])])) + +(: columnround (16words -> 16words)) +(define (columnround y) + (match y + [(vector y0 y1 y2 y3 y4 y5 y6 y7 y8 y9 y10 y11 y12 y13 y14 y15) + (match (vector (quarterround (vector y0 y4 y8 y12)) + (quarterround (vector y5 y9 y13 y1)) + (quarterround (vector y10 y14 y2 y6)) + (quarterround (vector y15 y3 y7 y11))) + [(vector (vector z0 z4 z8 z12) (vector z5 z9 z13 z1) + (vector z10 z14 z2 z6) (vector z15 z3 z7 z11)) + (vector z0 z1 z2 z3 z4 z5 z6 z7 z8 z9 z10 z11 z12 z13 z14 z15)])])) + +(: doubleround (16words -> 16words)) +(define doubleround (compose rowround columnround)) + +#; +(: 16words? (Any -> Boolean : 16words)) +#; +(define (16words? x) + (match x + [(vector y0 y1 y2 y3 y4 y5 y6 y7 y8 y9 y10 y11 y12 y13 y14 y15) + #t] + [_ + #f])) + +(: little-endian (Bytes -> Word)) +(define (little-endian b) + (match (bytes->list b) + [(list b0 b1 b2 b3) + (+ (arithmetic-shift b3 24) + (arithmetic-shift b2 16) + (arithmetic-shift b1 8) + b0)])) + +(: anti-little-endian (Word -> Bytes)) +(define (anti-little-endian w) + (integer->bytes/size w 'little-endian 4)) + +(: times (All (a) ((a -> a) Integer -> (a -> a)))) +(define (times fn n) + (for/fold ([acc (inst identity a)]) + ([i (in-range 0 n)]) + (compose fn acc))) + +(: salsa20h (Bytes -> Bytes)) +(define (salsa20h x) + (let*: ([xwords : 16words (vector 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)]) + (for ([i (in-range 0 16)]) + (vector-set! (ann xwords (Vectorof Word)) + i + (little-endian (subbytes x (* i 4) (* (add1 i) 4))))) + (let ([zwords ((times doubleround 10) xwords)]) + (bytes-append* (vector->list + (vector-map (λ: ([a : Word] [b : Word]) + (anti-little-endian (w+ a b))) + (ann xwords (Vectorof Word)) + (ann zwords (Vectorof Word)))))))) + +(: salsa20k (Bytes Bytes -> Bytes)) +(define (salsa20k k n) + (let* ([s0 (list->bytes '(101 120 112 97))] + [s1 (list->bytes '(110 100 32 51))] + [s2 (list->bytes '( 50 45 98 121))] + [s3 (list->bytes '(116 101 32 107))] + [t0 s0] + [t1 (list->bytes '(110 100 32 49))] + [t2 s2] + [t3 s3]) + (if (= (bytes-length k) 32) + (let ([k0 (subbytes k 0 16)] + [k1 (subbytes k 16)]) + (salsa20h (bytes-append s0 k0 s1 n s2 k1 s3))) + (salsa20h (bytes-append t0 k t1 n t2 k t3))))) + +(: salsa20 (Bytes Bytes (Sequenceof Byte) -> (Sequenceof Byte))) +(define (salsa20 k v m) + (let-values ([(next? next) (sequence-generate m)]) + (let: loop : (Sequenceof Byte) + ([i : Word 0]) + (if (next?) + (let ([64bytes + (let: inner-loop : Bytes + ([k : Integer 0] + [bytes : (Listof Byte) (list)]) + (if (and (next?) (< k 64)) + (inner-loop (add1 k) (cons (next) bytes)) + (list->bytes bytes)))] + [i-code + (integer->bytes/size i 'little-endian 8)]) + (lazy-functional-stream-append (ann (bytes-xor 64bytes + (salsa20k k (bytes-append v i-code))) + (Sequenceof Byte)) + (λ () (loop (add1 i))))) + empty-stream)))) diff --git a/typed-stream.rkt b/typed-stream.rkt new file mode 100644 index 0000000..b674750 --- /dev/null +++ b/typed-stream.rkt @@ -0,0 +1,12 @@ +#lang racket +(require racket/stream) + +(provide lazy-functional-stream-append) + +(define (lazy-functional-stream-append seq thunk) + (let-values ([(next? next) (sequence-generate seq)]) + (let loop () + (if (next?) + (let ([x (next)]) + (stream-cons x (loop))) + (thunk))))) @@ -21,23 +21,31 @@ integer->bytes/size bytes->integer pad-bytes - Justification) + Justification + Endianness + bytes-xor) (define-type Justification (U 'left 'right)) +(define-type Endianness (U 'little-endian 'big-endian)) -(define: (integer->bytes [x : Exact-Nonnegative-Integer]) : Bytes +(define: (integer->bytes [x : Exact-Nonnegative-Integer] + [endianness : Endianness]) + : Bytes (let: loop : Bytes ([acc : (Listof Byte) (list)] [x : Exact-Nonnegative-Integer x]) (if (zero? x) - (list->bytes acc) + (list->bytes (if (eq? endianness 'big-endian) + acc + (reverse acc))) (loop (cons (bitwise-and #xff x) acc) (arithmetic-shift x -8))))) -(define: (integer->bytes/size [x : Exact-Nonnegative-Integer] - [size : Exact-Nonnegative-Integer]) +(define: (integer->bytes/size [x : Exact-Nonnegative-Integer] + [endianness : Endianness] + [size : Exact-Nonnegative-Integer]) : Bytes - (pad-bytes (integer->bytes x) size #x0 'right)) + (pad-bytes (integer->bytes x endianness) size #x0 'right)) (define: (bytes->integer [b : Bytes]) : Exact-Nonnegative-Integer (for/fold: ([n : Exact-Nonnegative-Integer 0]) @@ -58,3 +66,11 @@ (bytes-append b padding) (bytes-append padding b))))) +(define: (bytes-xor [a : Bytes] [b : Bytes]) : Bytes + (list->bytes + (reverse + (for/fold: ([acc : (Listof Byte) (list)]) + ([x : Byte (in-bytes a)] + [y : Byte (in-bytes b)]) + (cons (bitwise-xor x y) acc))))) + diff --git a/whirlpool.rkt b/whirlpool.rkt index 5d436aa..222f9df 100644 --- a/whirlpool.rkt +++ b/whirlpool.rkt @@ -204,7 +204,7 @@ (+ (arithmetic-shift acc 8) byte))) (define: (length->bytes [n : Exact-Nonnegative-Integer]) : Bytes - (let ([b (integer->bytes n)]) + (let ([b (integer->bytes n 'big-endian)]) (bytes-append (make-bytes (- 32 (bytes-length b)) 0) b))) (define: (pad-whirlpool-bytes [b : Bytes]) : Bytes |