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

@@ -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 ;
+

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

contrib/crypto/md5.factor

@@ -11,31 +11,12 @@ SYMBOL: old-b
 SYMBOL: old-c
 SYMBOL: old-d
 
-: w+ ( int -- int )
+: initialize-md5 ( -- )
-    + 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 ( -- )
     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
+        initialize-md5 pad-string-md5
-        dup length num-blocks [ 2dup get-block process-block ] repeat
+        dup length num-blocks [ 2dup get-block process-md5-block ] repeat
-        2drop get-md5
+        drop get-md5
     ] with-scope ;
 
 : stream>md5 ( stream -- md5 )
-	[
+    [
-		contents string>md5
+        contents string>md5
-	] with-scope ;
+    ] with-scope ;
+
 : file>md5 ( file -- md5 )
-	[
+    [
-		<file-reader> stream>md5
+        <file-reader> stream>md5
-	] with-scope ;
+    ] with-scope ;
 
 : test-md5 ( -- )
     [ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" string>md5 ] unit-test

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 <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 ;
+