! See http://factorcode.org/license.txt for BSD license.
USING: kernel splitting grouping math sequences namespaces make
io.binary math.bitwise checksums checksums.common
-sbufs strings combinators.smart math.ranges fry combinators ;
+sbufs strings combinators.smart math.ranges fry combinators
+accessors ;
IN: checksums.sha2
<PRIVATE
-SYMBOLS: vars K H process-M word-size block-size ;
+SYMBOLS: H word-size block-size ;
CONSTANT: a 0
CONSTANT: b 1
[ -10 shift ] tri
] [ bitxor ] reduce-outputs ; inline
-: process-M-256 ( n seq -- )
- {
- [ [ 16 - ] dip nth ]
- [ [ 15 - ] dip nth s0-256 ]
- [ [ 7 - ] dip nth ]
- [ [ 2 - ] dip nth s1-256 w+ w+ w+ ]
- [ ]
- } 2cleave set-nth ; inline
-
-: prepare-message-schedule ( seq -- w-seq )
- word-size get group [ be> ] map block-size get 0 pad-tail
- 16 64 [a,b) over '[ _ process-M-256 ] each ;
-
-: ch ( x y z -- x' )
- [ bitxor bitand ] keep bitxor ;
-
-: maj ( x y z -- x' )
- [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ;
-
: S0-256 ( x -- x' )
[
[ -2 bitroll-32 ]
[ -25 bitroll-32 ] tri
] [ bitxor ] reduce-outputs ; inline
-: slice3 ( n seq -- a b c ) [ dup 3 + ] dip <slice> first3 ; inline
+: process-M-256 ( n seq -- )
+ {
+ [ [ 16 - ] dip nth ]
+ [ [ 15 - ] dip nth s0-256 ]
+ [ [ 7 - ] dip nth ]
+ [ [ 2 - ] dip nth s1-256 w+ w+ w+ ]
+ [ ]
+ } 2cleave set-nth ; inline
+
+: ch ( x y z -- x' )
+ [ bitxor bitand ] keep bitxor ;
+
+: maj ( x y z -- x' )
+ [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ;
-: T1 ( W n -- T1 )
- [ swap nth ] keep
- K get nth +
- e vars get slice3 ch +
- e vars get nth S1-256 +
- h vars get nth w+ ;
+: prepare-message-schedule ( seq -- w-seq )
+ word-size get <sliced-groups> [ be> ] map block-size get 0 pad-tail
+ 16 64 [a,b) over '[ _ process-M-256 ] each ;
-: T2 ( -- T2 )
- a vars get nth S0-256
- a vars get slice3 maj w+ ;
+: slice3 ( n seq -- a b c )
+ [ dup 3 + ] dip <slice> first3 ; inline
-: update-vars ( T1 T2 -- )
- vars get
+: T1 ( W n H -- T1 )
+ [
+ [ swap nth ] keep
+ K-256 nth +
+ ] dip
+ [ e swap slice3 ch w+ ]
+ [ e swap nth S1-256 w+ ]
+ [ h swap nth w+ ] tri ;
+
+: T2 ( H -- T2 )
+ [ a swap nth S0-256 ]
+ [ a swap slice3 maj w+ ] bi ;
+
+: update-H ( T1 T2 H -- )
h g pick exchange
g f pick exchange
f e pick exchange
b a pick exchange
[ w+ a ] dip set-nth ;
-: process-chunk ( M -- )
- H get clone vars set
- prepare-message-schedule block-size get [
- T1 T2 update-vars
- ] with each vars get H get [ w+ ] 2map H set ;
-
-: seq>byte-array ( n seq -- string )
- [ swap '[ _ >be % ] each ] B{ } make ;
-
-: preprocess-plaintext ( string big-endian? -- padded-string )
- #! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits
- [ >sbuf ] dip over [
+: process-chunk ( M block-size H-cloned -- )
+ [
+ '[
+ _
+ [ T1 ]
+ [ T2 ]
+ [ update-H ] tri
+ ] with each
+ ] keep H get [ w+ ] 2map H set ;
+
+: pad-initial-bytes ( string -- padded-string )
+ dup [
HEX: 80 ,
- dup length HEX: 3f bitand
- calculate-pad-length 0 <string> %
- length 3 shift 8 rot [ >be ] [ >le ] if %
- ] "" make over push-all ;
+ length
+ [ HEX: 3f bitand calculate-pad-length 0 <string> % ]
+ [ 3 shift 8 >be % ] bi
+ ] "" make append ;
+
+: seq>byte-array ( seq n -- string )
+ '[ _ >be ] map B{ } join ;
: byte-array>sha2 ( byte-array -- string )
- t preprocess-plaintext
- block-size get group [ process-chunk ] each
- 4 H get seq>byte-array ;
+ pad-initial-bytes
+ block-size get <sliced-groups>
+ [
+ prepare-message-schedule
+ block-size get H get clone process-chunk
+ ] each
+ H get 4 seq>byte-array ;
PRIVATE>
M: sha-256 checksum-bytes
drop [
- K-256 K set
initial-H-256 H set
4 word-size set
64 block-size set
byte-array>sha2
+
] with-scope ;