crypto -- add sha-256, cleanup md5/sha1

contrib/crypto/common.factor

@@ -1,7 +1,12 @@
 IN: crypto-internals
 USING: kernel io strings sequences namespaces math parser ;
 
-: w+ ( int -- int ) + HEX: ffffffff bitand ; inline
+IN: crypto
+: >32-bit ( n -- n ) HEX: ffffffff bitand ; inline
+: >64-bit ( n -- n ) HEX: ffffffffffffffff bitand ; inline
+
+IN: crypto-internals
+: w+ ( int -- int ) + >32-bit ; inline
 : nth-int ( string n -- int ) 2 shift dup 4 + rot <slice> le> ; inline
 : nth-int-be ( string n -- int ) 2 shift dup 4 + rot <slice> be> ; inline
 : update ( num var -- ) [ w+ ] change ; inline
@@ -25,7 +30,7 @@ USING: kernel io strings sequences namespaces math parser ;
 
 IN: crypto
 
-: bitroll ( n s w -- n )
+: bitroll ( n s w -- n' )
      #! Roll n by s bits to the left, wrapping around after
      #! w bits.
      [ 1 - bitand ] keep
@@ -33,5 +38,13 @@ IN: crypto
      [ shift-mod ] 3keep
      [ - ] keep shift-mod bitor ; inline
 
-: hex-string ( str -- str )
+: bitroll-32 ( n s -- n' ) 32 bitroll ;
-    [ [ >hex 2 48 pad-left % ] each ] "" make ;
+: bitroll-64 ( n s -- n' ) 64 bitroll ;
+: hex-string ( str -- str ) [ [ >hex 2 48 pad-left % ] each ] "" make ;
+: slice3 ( n seq -- a b c ) >r dup 3 + r> <slice> first3 ;
+
+: 4dup ( a b c d -- a b c d a b c d )
+    >r >r 2dup r> r> 2swap >r >r 2dup r> r> 2swap ;
+
+: 4keep ( w x y z quot -- w x y z )
+    >r 4dup r> swap >r swap >r swap >r swap >r call r> r> r> r> ; inline

contrib/crypto/load.factor

@@ -17,6 +17,7 @@ PROVIDE: contrib/crypto {
     "crc32.factor"
     "md5.factor"
     "sha1.factor"
+    "sha2.factor"
 
 ! Block ciphers
     "rc4.factor"
@@ -28,6 +29,7 @@ PROVIDE: contrib/crypto {
     "test/common.factor"
     "test/md5.factor"
     "test/sha1.factor"
+    "test/sha2.factor"
     "test/base64.factor"
     "test/miller-rabin.factor"
     "test/crc32.factor"

contrib/crypto/md5.factor

@@ -38,7 +38,7 @@ SYMBOL: md5-sin-table
 : (ABCD) ( s i x vars result -- )
     #! bits to shift, input to float-sin, x, func
     swap >r w+ swap md5-sin-table get nth w+ r> dup first >r swap r> update
-    dup first get rot 32 bitroll over second get w+ swap first set ;
+    dup first get rot bitroll-32 over second get w+ swap first set ;
 
 : ABCD { a b c d } swap (F) (ABCD) ; inline
 : BCDA { b c d a } swap (F) (ABCD) ; inline

contrib/crypto/sha1.factor

@@ -19,7 +19,7 @@ SYMBOL: K
 
 : reset-w ( -- ) 80 <vector> w set ; inline
 : get-wth ( n -- wth ) w get nth ; inline
-: shift-wth ( n -- x ) get-wth 1 32 bitroll ; inline
+: shift-wth ( n -- x ) get-wth 1 bitroll-32 ; inline
 
 : initialize-sha1 ( -- )
     HEX: 67452301 dup h0 set A set
@@ -39,7 +39,7 @@ SYMBOL: K
      dup 3 - get-wth
      over 8 - get-wth bitxor
      over 14 - get-wth bitxor
-     swap 16 - get-wth bitxor 1 32 bitroll ;
+     swap 16 - get-wth bitxor 1 bitroll-32 ;
 
 ! f(t;B,C,D) = (B AND C) OR ((NOT B) AND D)         ( 0 <= t <= 19)
 ! f(t;B,C,D) = B XOR C XOR D                        (20 <= t <= 39)
@@ -74,7 +74,7 @@ SYMBOL: K
         [ B get C get D get ] keep sha1-f ,
         dup get-wth ,
         K get nth ,
-        A get 5 32 bitroll ,
+        A get 5 bitroll-32 ,
         E get ,
     ] { } make sum 4294967295 bitand ; inline
 
@@ -82,7 +82,7 @@ SYMBOL: K
     ! E = D;  D = C;  C = S^30(B);  B = A; A = TEMP;
     D get E set
     C get D set
-    B get 30 32 bitroll C set
+    B get 30 bitroll-32 C set
     A get B set
     A set ;
 

contrib/crypto/sha2.factor

@@ -0,0 +1,138 @@
+USING: crypto crypto-internals io kernel math namespaces sequences words ;
+IN: sha2-internals
+
+SYMBOL: vars
+SYMBOL: M
+SYMBOL: K
+SYMBOL: H
+SYMBOL: S0
+SYMBOL: S1
+SYMBOL: process-M
+SYMBOL: word-size
+SYMBOL: block-size
+SYMBOL: >word
+
+: a 0 ;
+: b 1 ;
+: c 2 ;
+: d 3 ;
+: e 4 ;
+: f 5 ;
+: g 6 ;
+: h 7 ;
+
+: initial-H-256 ( -- seq )
+    {
+        HEX: 6a09e667 HEX: bb67ae85 HEX: 3c6ef372 HEX: a54ff53a
+        HEX: 510e527f HEX: 9b05688c HEX: 1f83d9ab HEX: 5be0cd19
+    } ;
+
+: K-256 ( -- seq )
+    {
+        HEX: 428a2f98 HEX: 71374491 HEX: b5c0fbcf HEX: e9b5dba5
+        HEX: 3956c25b HEX: 59f111f1 HEX: 923f82a4 HEX: ab1c5ed5
+        HEX: d807aa98 HEX: 12835b01 HEX: 243185be HEX: 550c7dc3
+        HEX: 72be5d74 HEX: 80deb1fe HEX: 9bdc06a7 HEX: c19bf174
+        HEX: e49b69c1 HEX: efbe4786 HEX: 0fc19dc6 HEX: 240ca1cc
+        HEX: 2de92c6f HEX: 4a7484aa HEX: 5cb0a9dc HEX: 76f988da
+        HEX: 983e5152 HEX: a831c66d HEX: b00327c8 HEX: bf597fc7
+        HEX: c6e00bf3 HEX: d5a79147 HEX: 06ca6351 HEX: 14292967
+        HEX: 27b70a85 HEX: 2e1b2138 HEX: 4d2c6dfc HEX: 53380d13
+        HEX: 650a7354 HEX: 766a0abb HEX: 81c2c92e HEX: 92722c85
+        HEX: a2bfe8a1 HEX: a81a664b HEX: c24b8b70 HEX: c76c51a3
+        HEX: d192e819 HEX: d6990624 HEX: f40e3585 HEX: 106aa070
+        HEX: 19a4c116 HEX: 1e376c08 HEX: 2748774c HEX: 34b0bcb5
+        HEX: 391c0cb3 HEX: 4ed8aa4a HEX: 5b9cca4f HEX: 682e6ff3
+        HEX: 748f82ee HEX: 78a5636f HEX: 84c87814 HEX: 8cc70208
+        HEX: 90befffa HEX: a4506ceb HEX: bef9a3f7 HEX: c67178f2
+    } ;
+
+: s0-256 ( x -- x' )
+    [ -7 bitroll-32 ] keep
+    [ -18 bitroll-32 ] keep
+    -3 shift bitxor bitxor ; inline
+
+: s1-256 ( x -- x' )
+    [ -17 bitroll-32 ] keep
+    [ -19 bitroll-32 ] keep
+    -10 shift bitxor bitxor ; inline
+
+: process-M-256 ( seq n -- )
+    [ 16 - swap nth ] 2keep
+    [ 15 - swap nth s0-256 ] 2keep
+    [ 7 - swap nth ] 2keep
+    [ 2 - swap nth s1-256 ] 2keep
+    >r >r + + w+ r> r> swap set-nth ; inline
+
+: prepare-message-schedule ( seq -- w-seq )
+    word-size get group [ be> ] map block-size get 0 pad-right
+    dup 16 64 dup <slice> [
+        process-M-256
+    ] each-with ;
+
+: ch ( x y z -- x' )
+    pick bitnot bitand >r bitand r> bitxor ;
+
+: maj ( x y z -- x' )
+    >r [ bitand ] 2keep r> [ rot bitand ] keep rot bitand bitxor bitxor ;
+
+: S0-256 ( x -- x' )
+    [ -2 bitroll-32 ] keep
+    [ -13 bitroll-32 ] keep
+    -22 bitroll-32 bitxor bitxor ; inline
+
+: S1-256 ( x -- x' )
+    [ -6 bitroll-32 ] keep
+    [ -11 bitroll-32 ] keep
+    -25 bitroll-32 bitxor bitxor ; inline
+
+: 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+ ;
+
+: T2 ( -- T2 )
+    a vars get nth S0-256
+    a vars get slice3 maj w+ ;
+
+: update-vars ( T1 T2 -- )
+    vars get
+    h g pick exchange
+    g f pick exchange
+    f e pick exchange
+    pick d pick nth w+ e pick set-nth
+    d c pick exchange
+    c b pick exchange
+    b a pick exchange
+    >r w+ a r> set-nth ;
+
+: process-chunk ( M -- )
+    H get clone vars set
+    prepare-message-schedule block-size get [
+        T1 T2 update-vars
+    ] each-with vars get H get [ w+ ] 2map H set ;
+
+: seq>string ( n seq -- string )
+    [ [ swap >be % ] each-with ] "" make ;
+
+: string>sha2 ( string -- string )
+    t preprocess-plaintext
+    block-size get group [ process-chunk ] each
+
+IN: sha2
+: string>sha-256 ( string -- string )
+    [
+        K-256 K set
+        initial-H-256 H set
+        4 word-size set
+        64 block-size set
+        \ >32-bit >word set
+        string>sha2
+        4 H get seq>string
+    ] with-scope ;
+
+: string>sha-256-string ( string -- hexstring )
+    string>sha-256 hex-string ;
+