1 ! Copyright (C) 2006, 2008 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays combinators kernel io io.encodings.binary io.files
4 io.streams.byte-array math.vectors strings sequences namespaces
5 make math parser sequences assocs grouping vectors io.binary
6 hashtables symbols math.bitwise checksums checksums.common ;
9 ! Implemented according to RFC 3174.
11 SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
13 : get-wth ( n -- wth ) w get nth ; inline
14 : shift-wth ( n -- x ) get-wth 1 bitroll-32 ; inline
16 : initialize-sha1 ( -- )
18 HEX: 67452301 dup h0 set A set
19 HEX: efcdab89 dup h1 set B set
20 HEX: 98badcfe dup h2 set C set
21 HEX: 10325476 dup h3 set D set
22 HEX: c3d2e1f0 dup h4 set E set
24 20 HEX: 5a827999 <array> %
25 20 HEX: 6ed9eba1 <array> %
26 20 HEX: 8f1bbcdc <array> %
27 20 HEX: ca62c1d6 <array> %
30 ! W(t) = S^1(W(t-3) XOR W(t-8) XOR W(t-14) XOR W(t-16))
33 over 8 - get-wth bitxor
34 over 14 - get-wth bitxor
35 swap 16 - get-wth bitxor 1 bitroll-32 ;
37 ! f(t;B,C,D) = (B AND C) OR ((NOT B) AND D) ( 0 <= t <= 19)
38 ! f(t;B,C,D) = B XOR C XOR D (20 <= t <= 39)
39 ! f(t;B,C,D) = (B AND C) OR (B AND D) OR (C AND D) (40 <= t <= 59)
40 ! f(t;B,C,D) = B XOR C XOR D (60 <= t <= 79)
41 : sha1-f ( B C D t -- f_tbcd )
44 { 0 [ >r over bitnot r> bitand >r bitand r> bitor ] }
45 { 1 [ bitxor bitxor ] }
46 { 2 [ 2dup bitand >r pick bitand >r bitand r> r> bitor bitor ] }
47 { 3 [ bitxor bitxor ] }
50 : nth-int-be ( string n -- int )
51 4 * dup 4 + rot <slice> be> ; inline
54 #! compute w, steps a-b of RFC 3174, section 6.1
55 16 [ nth-int-be w get push ] with each
56 16 80 dup <slice> [ sha1-W w get push ] each ;
59 ! step c of RFC 3174, section 6.1
66 : inner-loop ( n -- temp )
67 ! TEMP = S^5(A) + f(t;B,C,D) + E + W(t) + K(t);
69 [ B get C get D get ] keep sha1-f ,
74 ] { } make sum 32 bits ; inline
76 : set-vars ( temp -- )
77 ! E = D; D = C; C = S^30(B); B = A; A = TEMP;
80 B get 30 bitroll-32 C set
84 : calculate-letters ( -- )
85 ! step d of RFC 3174, section 6.1
86 80 [ inner-loop set-vars ] each ;
89 ! step e of RFC 3174, section 6.1
96 : (process-sha1-block) ( str -- )
97 80 <vector> w set make-w init-letters calculate-letters update-hs ;
99 : process-sha1-block ( str -- )
100 dup length [ bytes-read [ + ] change ] keep 64 = [
103 t bytes-read get pad-last-block
104 [ (process-sha1-block) ] each
108 64 read [ process-sha1-block ] keep
109 length 64 = [ stream>sha1 ] when ;
111 : get-sha1 ( -- str )
112 [ [ h0 h1 h2 h3 h4 ] [ get 4 >be % ] each ] "" make ;
116 INSTANCE: sha1 checksum
118 M: sha1 checksum-stream ( stream -- sha1 )
119 drop [ initialize-sha1 stream>sha1 get-sha1 ] with-input-stream ;
121 : seq>2seq ( seq -- seq1 seq2 )
122 #! { abcdefgh } -> { aceg } { bdfh }
123 2 group flip [ { } { } ] [ first2 ] if-empty ;
125 : 2seq>seq ( seq1 seq2 -- seq )
126 #! { aceg } { bdfh } -> { abcdefgh }
127 [ zip concat ] keep like ;
129 : sha1-interleave ( string -- seq )
131 dup length odd? [ rest ] when
132 seq>2seq [ sha1 checksum-bytes ] bi@