--- /dev/null
+IN: crypto
+USING: kernel io strings sequences namespaces math prettyprint
+unparser test parser lists ;
+
+: rot4 ( a b c d -- b c d a )
+ >r rot r> swap ;
+
+: w+ ( int -- int )
+ + HEX: ffffffff bitand ;
+
+: nth-int ( string n -- int )
+ 4 * dup 4 + rot subseq le> ;
+
+: nth-int-be ( string n -- int )
+ 4 * dup 4 + rot subseq be> ;
+
+: float-sin ( int -- int )
+ sin abs 4294967296 * >bignum ;
+
+: update ( num var -- )
+ [ w+ ] change ;
+
+: update-old-new ( old new -- )
+ [ get >r get r> ] 2keep >r >r w+ dup r> set r> set ;
+
+! calculate pad length. leave 8 bytes for length after padding
+: zero-pad-length ( length -- pad-length )
+ dup 64 mod 56 < 55 119 ? swap - ; ! one less for first byte of padding 0x80
+
+! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits
+: pad-string-md5 ( string -- padded-string )
+ [
+ dup % "\u0080" %
+ dup length 64 mod zero-pad-length 0 fill %
+ dup length 8 * 8 >le %
+ ] make-string nip ;
+
+: pad-string-sha1 ( string -- padded-string )
+ [
+ dup % "\u0080" %
+ dup length 64 mod zero-pad-length 0 fill %
+ dup length 8 * 8 >be %
+ ] make-string nip ;
+
+: num-blocks ( length -- num )
+ 64 /i ;
+
+: get-block ( string num -- string )
+ 64 * dup 64 + rot subseq ;
+
+: hex-string ( str -- str )
+ [
+ [
+ >hex 2 48 pad-left %
+ ] each
+ ] make-string ;
+
--- /dev/null
+IN: crypto
+USING: parser sequences ;
+[
+ "contrib/crypto/common.factor"
+ "contrib/crypto/md5.factor"
+ "contrib/crypto/sha1.factor"
+] [ run-file ] each
SYMBOL: old-c
SYMBOL: old-d
-: w+ ( int -- int )
- + HEX: ffffffff bitand ;
-
-: nth-int ( string n -- int )
- 4 * dup 4 + rot subseq le> ;
-
-: contents ( stream -- string )
- #! Read the entire stream into a string.
- 4096 <sbuf> [ stream-copy ] keep >string ;
-
-: initialize ( -- )
+: initialize-md5 ( -- )
HEX: 67452301 dup a set old-a set
HEX: efcdab89 dup b set old-b set
HEX: 98badcfe dup c set old-c set
HEX: 10325476 dup d set old-d set ;
-: float-sin ( int -- int )
- sin abs 4294967296 * >bignum ;
-
-: update ( num var -- )
- [ w+ ] change ;
-
-: update-old-new ( old new -- )
- [ get >r get r> ] 2keep >r >r w+ dup r> set r> set ;
-
: update-md ( -- )
old-a a update-old-new
old-b b update-old-new
: S43 15 ;
: S44 21 ;
-: process-block ( block -- )
+: process-md5-block ( block -- )
S11 1 pick 0 nth-int [ F ] ABCD
S12 2 pick 1 nth-int [ F ] DABC
S13 3 pick 2 nth-int [ F ] CDAB
drop
;
-! calculate pad length. leave 8 bytes for length after padding
-: md5-zero-pad-length ( length -- pad-length )
- dup 64 mod 56 < 55 119 ? swap - ; ! one less for first byte of padding 0x80
-
-! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits
-: pad-string ( string -- padded-string )
- [
- dup % "\u0080" %
- dup length 64 mod md5-zero-pad-length 0 fill %
- dup length 8 * 8 >le %
- ] make-string ;
-
-: num-blocks ( length -- num )
- 64 /i ;
-
-: get-block ( string num -- string )
- 64 * dup 64 + rot subseq ;
-
-: hex-string ( str -- str )
- [
- [
- >hex 2 48 pad-left %
- ] each
- ] make-string ;
-
: get-md5 ( -- str )
[
[ a b c d ] [ get 4 >le % ] each
: string>md5 ( string -- md5 )
[
- initialize pad-string
- dup length num-blocks [ 2dup get-block process-block ] repeat
- 2drop get-md5
+ initialize-md5 pad-string-md5
+ dup length num-blocks [ 2dup get-block process-md5-block ] repeat
+ drop get-md5
] with-scope ;
: stream>md5 ( stream -- md5 )
- [
- contents string>md5
- ] with-scope ;
+ [
+ contents string>md5
+ ] with-scope ;
+
: file>md5 ( file -- md5 )
- [
- <file-reader> stream>md5
- ] with-scope ;
+ [
+ <file-reader> stream>md5
+ ] with-scope ;
: test-md5 ( -- )
[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" string>md5 ] unit-test
--- /dev/null
+IN: crypto
+USING: kernel io strings sequences namespaces math prettyprint
+unparser test parser lists vectors ;
+
+! Implemented according to RFC 3174.
+
+SYMBOL: h0
+SYMBOL: h1
+SYMBOL: h2
+SYMBOL: h3
+SYMBOL: h4
+SYMBOL: A
+SYMBOL: B
+SYMBOL: C
+SYMBOL: D
+SYMBOL: E
+SYMBOL: temp
+SYMBOL: w
+SYMBOL: K
+
+: reset-w ( -- )
+ 80 <vector> w set ;
+
+: initialize-sha1 ( -- )
+ HEX: 67452301 dup h0 set A set
+ HEX: efcdab89 dup h1 set B set
+ HEX: 98badcfe dup h2 set C set
+ HEX: 10325476 dup h3 set D set
+ HEX: c3d2e1f0 dup h4 set E set
+ reset-w
+ [
+ 20 [ HEX: 5a827999 , ] times
+ 20 [ HEX: 6ed9eba1 , ] times
+ 20 [ HEX: 8f1bbcdc , ] times
+ 20 [ HEX: ca62c1d6 , ] times
+ ] make-vector K set ;
+
+: update-hs ( -- )
+ A h0 update-old-new
+ B h1 update-old-new
+ C h2 update-old-new
+ D h3 update-old-new
+ E h4 update-old-new ;
+
+: get-wth ( n -- wth )
+ w get nth ;
+
+: shift-wth ( n -- )
+ get-wth 1 32 bitroll ;
+
+! W(t) = S^1(W(t-3) XOR W(t-8) XOR W(t-14) XOR W(t-16))
+: sha1-W ( t -- W_t )
+ dup 3 - get-wth
+ over 8 - get-wth bitxor
+ over 14 - get-wth bitxor
+ swap 16 - get-wth bitxor 1 32 bitroll ;
+
+! 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)
+! f(t;B,C,D) = (B AND C) OR (B AND D) OR (C AND D) (40 <= t <= 59)
+! f(t;B,C,D) = B XOR C XOR D (60 <= t <= 79)
+: sha1-f ( B C D t -- f_tbcd )
+ dup 20 < [
+ drop >r over bitnot r> bitand >r bitand r> bitor
+ ] [ dup 40 < [
+ drop bitxor bitxor
+ ] [ dup 60 < [
+ drop 2dup bitand >r pick bitand >r bitand r> r> bitor bitor
+ ] [
+ drop bitxor bitxor
+ ] ifte
+ ] ifte
+ ] ifte ;
+
+: process-sha1-block ( block -- )
+ ! compute w, steps a-b of RFC 3174, section 6.1
+ 80 [ dup 16 < [
+ [ nth-int-be w get push ] 2keep
+ ] [
+ dup sha1-W w get push
+ ] ifte
+ ] repeat
+
+ ! step c of RFC 3174, section 6.1
+ h0 get A set
+ h1 get B set
+ h2 get C set
+ h3 get D set
+ h4 get E set
+
+ ! step d of RFC 3174, section 6.1
+ 80 [
+ ! TEMP = S^5(A) + f(t;B,C,D) + E + W(t) + K(t);
+ dup B get C get D get rot4 sha1-f
+ over get-wth
+ pick K get nth
+ A get 5 32 bitroll
+ E get
+ + + + +
+ 4294967296 mod
+ temp set
+
+ ! 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
+ A get B set
+ temp get A set
+ ] repeat
+
+ ! step e of RFC 3174, section 6.1
+ update-hs
+ drop ;
+
+: get-sha1 ( -- str )
+ [
+ [ h0 h1 h2 h3 h4 ] [ get 4 >be % ] each
+ ] make-string hex-string ;
+
+: string>sha1 ( string -- sha1 )
+ [
+ initialize-sha1 pad-string-sha1
+ dup length num-blocks [ reset-w 2dup get-block process-sha1-block ] repeat
+ drop get-sha1
+ ] with-scope ;
+
+: stream>sha1 ( stream -- sha1 )
+ [
+ contents string>sha1
+ ] with-scope ;
+
+: file>sha1 ( file -- sha1 )
+ [
+ <file-reader> stream>sha1
+ ] with-scope ;
+
+! unit test from the RFC
+: test-sha1 ( -- )
+ [ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" string>sha1 ] unit-test
+ [ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" string>sha1 ] unit-test
+ ! [ "34aa973cd4c4daa4f61eeb2bdbad27316534016f" ] [ 1000000 CHAR: a fill string>sha1 ] unit-test ! takes a long time...
+ [ "dea356a2cddd90c7a7ecedc5ebb563934f460452" ] [ "0123456701234567012345670123456701234567012345670123456701234567" [ 10 [ dup % ] times ] make-string nip string>sha1 ] unit-test ;
+
projects / factor.git / commitdiff