From 762d2913a1a9e9d11d6f51c4a683b96eae7c7e2c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 25 Aug 2005 10:07:50 +0000 Subject: [PATCH] Added sha1.factor Updated md5 to Factor .77 Added common.factor to contain common words to both md5 and sha1 Added load.factor --- contrib/crypto/common.factor | 57 ++++++++++++++ contrib/crypto/load.factor | 7 ++ contrib/crypto/md5.factor | 67 +++------------- contrib/crypto/sha1.factor | 143 +++++++++++++++++++++++++++++++++++ 4 files changed, 219 insertions(+), 55 deletions(-) create mode 100644 contrib/crypto/common.factor create mode 100644 contrib/crypto/load.factor create mode 100644 contrib/crypto/sha1.factor diff --git a/contrib/crypto/common.factor b/contrib/crypto/common.factor new file mode 100644 index 0000000000..163b8cb42d --- /dev/null +++ b/contrib/crypto/common.factor @@ -0,0 +1,57 @@ +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 ; + diff --git a/contrib/crypto/load.factor b/contrib/crypto/load.factor new file mode 100644 index 0000000000..2f76a42724 --- /dev/null +++ b/contrib/crypto/load.factor @@ -0,0 +1,7 @@ +IN: crypto +USING: parser sequences ; +[ + "contrib/crypto/common.factor" + "contrib/crypto/md5.factor" + "contrib/crypto/sha1.factor" +] [ run-file ] each diff --git a/contrib/crypto/md5.factor b/contrib/crypto/md5.factor index d089f88c0e..56765046fb 100644 --- a/contrib/crypto/md5.factor +++ b/contrib/crypto/md5.factor @@ -11,31 +11,12 @@ SYMBOL: old-b 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 [ 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 @@ -92,7 +73,7 @@ SYMBOL: old-d : 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 @@ -164,31 +145,6 @@ SYMBOL: old-d 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 @@ -196,19 +152,20 @@ SYMBOL: old-d : 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 ) - [ - stream>md5 - ] with-scope ; + [ + stream>md5 + ] with-scope ; : test-md5 ( -- ) [ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" string>md5 ] unit-test diff --git a/contrib/crypto/sha1.factor b/contrib/crypto/sha1.factor new file mode 100644 index 0000000000..00cef3dbfa --- /dev/null +++ b/contrib/crypto/sha1.factor @@ -0,0 +1,143 @@ +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 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 ) + [ + 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 ; +