libs/crypto/sha2.factor

   1 USING: crypto crypto-internals io kernel math namespaces sequences words ;
   2 IN: sha2-internals
   3
   4 SYMBOL: vars
   5 SYMBOL: M
   6 SYMBOL: K
   7 SYMBOL: H
   8 SYMBOL: S0
   9 SYMBOL: S1
  10 SYMBOL: process-M
  11 SYMBOL: word-size
  12 SYMBOL: block-size
  13 SYMBOL: >word
  14
  15 : a 0 ;
  16 : b 1 ;
  17 : c 2 ;
  18 : d 3 ;
  19 : e 4 ;
  20 : f 5 ;
  21 : g 6 ;
  22 : h 7 ;
  23
  24 : initial-H-256 ( -- seq )
  25     {
  26         HEX: 6a09e667 HEX: bb67ae85 HEX: 3c6ef372 HEX: a54ff53a
  27         HEX: 510e527f HEX: 9b05688c HEX: 1f83d9ab HEX: 5be0cd19
  28     } ;
  29
  30 : K-256 ( -- seq )
  31     {
  32         HEX: 428a2f98 HEX: 71374491 HEX: b5c0fbcf HEX: e9b5dba5
  33         HEX: 3956c25b HEX: 59f111f1 HEX: 923f82a4 HEX: ab1c5ed5
  34         HEX: d807aa98 HEX: 12835b01 HEX: 243185be HEX: 550c7dc3
  35         HEX: 72be5d74 HEX: 80deb1fe HEX: 9bdc06a7 HEX: c19bf174
  36         HEX: e49b69c1 HEX: efbe4786 HEX: 0fc19dc6 HEX: 240ca1cc
  37         HEX: 2de92c6f HEX: 4a7484aa HEX: 5cb0a9dc HEX: 76f988da
  38         HEX: 983e5152 HEX: a831c66d HEX: b00327c8 HEX: bf597fc7
  39         HEX: c6e00bf3 HEX: d5a79147 HEX: 06ca6351 HEX: 14292967
  40         HEX: 27b70a85 HEX: 2e1b2138 HEX: 4d2c6dfc HEX: 53380d13
  41         HEX: 650a7354 HEX: 766a0abb HEX: 81c2c92e HEX: 92722c85
  42         HEX: a2bfe8a1 HEX: a81a664b HEX: c24b8b70 HEX: c76c51a3
  43         HEX: d192e819 HEX: d6990624 HEX: f40e3585 HEX: 106aa070
  44         HEX: 19a4c116 HEX: 1e376c08 HEX: 2748774c HEX: 34b0bcb5
  45         HEX: 391c0cb3 HEX: 4ed8aa4a HEX: 5b9cca4f HEX: 682e6ff3
  46         HEX: 748f82ee HEX: 78a5636f HEX: 84c87814 HEX: 8cc70208
  47         HEX: 90befffa HEX: a4506ceb HEX: bef9a3f7 HEX: c67178f2
  48     } ;
  49
  50 : s0-256 ( x -- x' )
  51     [ -7 bitroll-32 ] keep
  52     [ -18 bitroll-32 ] keep
  53     -3 shift bitxor bitxor ; inline
  54
  55 : s1-256 ( x -- x' )
  56     [ -17 bitroll-32 ] keep
  57     [ -19 bitroll-32 ] keep
  58     -10 shift bitxor bitxor ; inline
  59
  60 : process-M-256 ( seq n -- )
  61     [ 16 - swap nth ] 2keep
  62     [ 15 - swap nth s0-256 ] 2keep
  63     [ 7 - swap nth ] 2keep
  64     [ 2 - swap nth s1-256 ] 2keep
  65     >r >r + + w+ r> r> swap set-nth ; inline
  66
  67 : prepare-message-schedule ( seq -- w-seq )
  68     word-size get group [ be> ] map block-size get 0 pad-right
  69     dup 16 64 dup <slice> [
  70         process-M-256
  71     ] each-with ;
  72
  73 : ch ( x y z -- x' )
  74     [ bitxor bitand ] keep bitxor ;
  75
  76 : maj ( x y z -- x' )
  77     >r [ bitand ] 2keep bitor r> bitand bitor ;
  78
  79 : S0-256 ( x -- x' )
  80     [ -2 bitroll-32 ] keep
  81     [ -13 bitroll-32 ] keep
  82     -22 bitroll-32 bitxor bitxor ; inline
  83
  84 : S1-256 ( x -- x' )
  85     [ -6 bitroll-32 ] keep
  86     [ -11 bitroll-32 ] keep
  87     -25 bitroll-32 bitxor bitxor ; inline
  88
  89 : T1 ( W n -- T1 )
  90     [ swap nth ] keep
  91     K get nth +
  92     e vars get slice3 ch +
  93     e vars get nth S1-256 +
  94     h vars get nth w+ ;
  95
  96 : T2 ( -- T2 )
  97     a vars get nth S0-256
  98     a vars get slice3 maj w+ ;
  99
 100 : update-vars ( T1 T2 -- )
 101     vars get
 102     h g pick exchange
 103     g f pick exchange
 104     f e pick exchange
 105     pick d pick nth w+ e pick set-nth
 106     d c pick exchange
 107     c b pick exchange
 108     b a pick exchange
 109     >r w+ a r> set-nth ;
 110
 111 : process-chunk ( M -- )
 112     H get clone vars set
 113     prepare-message-schedule block-size get [
 114         T1 T2 update-vars
 115     ] each-with vars get H get [ w+ ] 2map H set ;
 116
 117 : seq>string ( n seq -- string )
 118     [ [ swap >be % ] each-with ] "" make ;
 119
 120 : string>sha2 ( string -- string )
 121     t preprocess-plaintext
 122     block-size get group [ process-chunk ] each
 123     4 H get seq>string ;
 124
 125 IN: sha2
 126 : string>sha-256 ( string -- string )
 127     [
 128         K-256 K set
 129         initial-H-256 H set
 130         4 word-size set
 131         64 block-size set
 132         \ >32-bit >word set
 133         string>sha2
 134     ] with-scope ;
 135
 136 : string>sha-256-string ( string -- hexstring )
 137     string>sha-256 hex-string ;
 138