Bug fixes for lcs.diff2html; xml.writer
[factor/jcg.git] / basis / checksums / sha2 / sha2.factor
blob898a695b34d5ce3308ec1fa19ba47db105ea9fd2
1 ! Copyright (C) 2008 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel splitting grouping math sequences namespaces make
4 io.binary math.bitwise checksums checksums.common
5 sbufs strings ;
6 IN: checksums.sha2
8 <PRIVATE
10 SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
12 : a 0 ; inline
13 : b 1 ; inline
14 : c 2 ; inline
15 : d 3 ; inline
16 : e 4 ; inline
17 : f 5 ; inline
18 : g 6 ; inline
19 : h 7 ; inline
21 : initial-H-256 ( -- seq )
22     {
23         HEX: 6a09e667 HEX: bb67ae85 HEX: 3c6ef372 HEX: a54ff53a
24         HEX: 510e527f HEX: 9b05688c HEX: 1f83d9ab HEX: 5be0cd19
25     } ;
27 : K-256 ( -- seq )
28     {
29         HEX: 428a2f98 HEX: 71374491 HEX: b5c0fbcf HEX: e9b5dba5
30         HEX: 3956c25b HEX: 59f111f1 HEX: 923f82a4 HEX: ab1c5ed5
31         HEX: d807aa98 HEX: 12835b01 HEX: 243185be HEX: 550c7dc3
32         HEX: 72be5d74 HEX: 80deb1fe HEX: 9bdc06a7 HEX: c19bf174
33         HEX: e49b69c1 HEX: efbe4786 HEX: 0fc19dc6 HEX: 240ca1cc
34         HEX: 2de92c6f HEX: 4a7484aa HEX: 5cb0a9dc HEX: 76f988da
35         HEX: 983e5152 HEX: a831c66d HEX: b00327c8 HEX: bf597fc7
36         HEX: c6e00bf3 HEX: d5a79147 HEX: 06ca6351 HEX: 14292967
37         HEX: 27b70a85 HEX: 2e1b2138 HEX: 4d2c6dfc HEX: 53380d13
38         HEX: 650a7354 HEX: 766a0abb HEX: 81c2c92e HEX: 92722c85
39         HEX: a2bfe8a1 HEX: a81a664b HEX: c24b8b70 HEX: c76c51a3
40         HEX: d192e819 HEX: d6990624 HEX: f40e3585 HEX: 106aa070
41         HEX: 19a4c116 HEX: 1e376c08 HEX: 2748774c HEX: 34b0bcb5
42         HEX: 391c0cb3 HEX: 4ed8aa4a HEX: 5b9cca4f HEX: 682e6ff3
43         HEX: 748f82ee HEX: 78a5636f HEX: 84c87814 HEX: 8cc70208
44         HEX: 90befffa HEX: a4506ceb HEX: bef9a3f7 HEX: c67178f2
45     } ;
47 : s0-256 ( x -- x' )
48     [ -7 bitroll-32 ] keep
49     [ -18 bitroll-32 ] keep
50     -3 shift bitxor bitxor ; inline
52 : s1-256 ( x -- x' )
53     [ -17 bitroll-32 ] keep
54     [ -19 bitroll-32 ] keep
55     -10 shift bitxor bitxor ; inline
57 : process-M-256 ( seq n -- )
58     [ 16 - swap nth ] 2keep
59     [ 15 - swap nth s0-256 ] 2keep
60     [ 7 - swap nth ] 2keep
61     [ 2 - swap nth s1-256 ] 2keep
62     [ + + w+ ] 2dip swap set-nth ; inline
64 : prepare-message-schedule ( seq -- w-seq )
65     word-size get group [ be> ] map block-size get 0 pad-right
66     dup 16 64 dup <slice> [
67         process-M-256
68     ] with each ;
70 : ch ( x y z -- x' )
71     [ bitxor bitand ] keep bitxor ;
73 : maj ( x y z -- x' )
74     [ [ bitand ] 2keep bitor ] dip bitand bitor ;
76 : S0-256 ( x -- x' )
77     [ -2 bitroll-32 ] keep
78     [ -13 bitroll-32 ] keep
79     -22 bitroll-32 bitxor bitxor ; inline
81 : S1-256 ( x -- x' )
82     [ -6 bitroll-32 ] keep
83     [ -11 bitroll-32 ] keep
84     -25 bitroll-32 bitxor bitxor ; inline
86 : slice3 ( n seq -- a b c ) [ dup 3 + ] dip <slice> first3 ; inline
88 : T1 ( W n -- T1 )
89     [ swap nth ] keep
90     K get nth +
91     e vars get slice3 ch +
92     e vars get nth S1-256 +
93     h vars get nth w+ ;
95 : T2 ( -- T2 )
96     a vars get nth S0-256
97     a vars get slice3 maj w+ ;
99 : update-vars ( T1 T2 -- )
100     vars get
101     h g pick exchange
102     g f pick exchange
103     f e pick exchange
104     pick d pick nth w+ e pick set-nth
105     d c pick exchange
106     c b pick exchange
107     b a pick exchange
108     [ w+ a ] dip set-nth ;
110 : process-chunk ( M -- )
111     H get clone vars set
112     prepare-message-schedule block-size get [
113         T1 T2 update-vars
114     ] with each vars get H get [ w+ ] 2map H set ;
116 : seq>byte-array ( n seq -- string )
117     [ swap [ >be % ] curry each ] B{ } make ;
119 : preprocess-plaintext ( string big-endian? -- padded-string )
120     #! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits
121     [ >sbuf ] dip over [
122         HEX: 80 ,
123         dup length HEX: 3f bitand
124         calculate-pad-length 0 <string> %
125         length 3 shift 8 rot [ >be ] [ >le ] if %
126     ] "" make over push-all ;
128 : byte-array>sha2 ( byte-array -- string )
129     t preprocess-plaintext
130     block-size get group [ process-chunk ] each
131     4 H get seq>byte-array ;
133 PRIVATE>
135 SINGLETON: sha-256
137 INSTANCE: sha-256 checksum
139 M: sha-256 checksum-bytes
140     drop [
141         K-256 K set
142         initial-H-256 H set
143         4 word-size set
144         64 block-size set
145         byte-array>sha2
146     ] with-scope ;