Added sha1.factor
Updated md5 to Factor .77 Added common.factor to contain common words to both md5 and sha1 Added load.factorcvs
Doug Coleman
parent
01a1f8cede
commit
762d2913a1
|
|
@ -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 ;
|
||||
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
IN: crypto
|
||||
USING: parser sequences ;
|
||||
[
|
||||
"contrib/crypto/common.factor"
|
||||
"contrib/crypto/md5.factor"
|
||||
"contrib/crypto/sha1.factor"
|
||||
] [ run-file ] each
|
||||
|
|
@ -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 <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
|
||||
|
|
@ -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,15 +152,16 @@ 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 ;
|
||||
|
||||
: file>md5 ( file -- md5 )
|
||||
[
|
||||
<file-reader> stream>md5
|
||||
|
|
|
|||
|
|
@ -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 <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 ;
|
||||
|
||||
Loading…
Reference in New Issue