fix sha1

basis/checksums/adler-32/adler-32.factor

@@ -10,6 +10,6 @@ CONSTANT: adler-32-modulus 65521
 
 M: adler-32 checksum-bytes ( bytes checksum -- value )
     drop
-    [ sum 1+ ]
+    [ sum 1 + ]
     [ [ dup length [1,b] <reversed> v. ] [ length ] bi + ] bi
     [ adler-32-modulus mod ] bi@ 16 shift bitor ;

basis/checksums/hmac/hmac-tests.factor

@@ -1,6 +1,6 @@
 USING: kernel io strings byte-arrays sequences namespaces math
-parser checksums.hmac tools.test checksums.md5 checksums.sha1
+parser checksums.hmac tools.test checksums.md5 checksums.sha2
-checksums.sha2 checksums ;
+checksums ;
 IN: checksums.hmac.tests
 
 [

basis/checksums/interleave/interleave-tests.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test checksums.interleave checksums.sha1 ;
+USING: tools.test checksums.interleave checksums.sha2 ;
 IN: checksums.interleave.tests
 
 [

basis/checksums/sha1/authors.txt

@@ -1 +0,0 @@
-Doug Coleman

basis/checksums/sha1/sha1-docs.factor

@@ -1,11 +0,0 @@
-USING: help.markup help.syntax ;
-IN: checksums.sha1
-
-HELP: sha1
-{ $class-description "SHA1 checksum algorithm." } ;
-
-ARTICLE: "checksums.sha1" "SHA1 checksum"
-"The SHA1 checksum algorithm implements a one-way hash function. It is generally considered to be stronger than MD5, however there is a known algorithm for finding collisions more effectively than a brute-force search (" { $url "http://www.schneier.com/blog/archives/2005/02/sha1_broken.html" } ")."
-{ $subsection sha1 } ;
-
-ABOUT: "checksums.sha1"

basis/checksums/sha1/sha1-tests.factor

@@ -1,14 +0,0 @@
-USING: arrays kernel math namespaces sequences tools.test checksums checksums.sha1 ;
-
-[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" sha1 checksum-bytes hex-string ] unit-test
-[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" sha1 checksum-bytes hex-string ] unit-test
-! [ "34aa973cd4c4daa4f61eeb2bdbad27316534016f" ] [ 1000000 CHAR: a fill string>sha1str ] unit-test ! takes a long time...
-[ "dea356a2cddd90c7a7ecedc5ebb563934f460452" ] [ "0123456701234567012345670123456701234567012345670123456701234567"
-10 swap <array> concat sha1 checksum-bytes hex-string ] unit-test
-
-[
-    ";\u00009b\u0000fd\u0000cdK\u0000a3^s\u0000d0*\u0000e3\\\u0000b5\u000013<\u0000e8wA\u0000b2\u000083\u0000d20\u0000f1\u0000e6\u0000cc\u0000d8\u00001e\u00009c\u000004\u0000d7PT]\u0000ce,\u000001\u000012\u000080\u000096\u000099"
-] [
-    "\u000066\u000053\u0000f1\u00000c\u00001a\u0000fa\u0000b5\u00004c\u000061\u0000c8\u000025\u000075\u0000a8\u00004a\u0000fe\u000030\u0000d8\u0000aa\u00001a\u00003a\u000096\u000096\u0000b3\u000018\u000099\u000092\u0000bf\u0000e1\u0000cb\u00007f\u0000a6\u0000a7"
-    sha1-interleave
-] unit-test

basis/checksums/sha1/sha1.factor

@@ -1,134 +0,0 @@
-! Copyright (C) 2006, 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators kernel io io.encodings.binary io.files
-io.streams.byte-array math.vectors strings namespaces
-make math parser sequences assocs grouping vectors io.binary
-hashtables math.bitwise checksums checksums.common
-checksums.stream ;
-IN: checksums.sha1
-
-! Implemented according to RFC 3174.
-
-SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
-
-: get-wth ( n -- wth ) w get nth ; inline
-: shift-wth ( n -- x ) get-wth 1 bitroll-32 ; inline
-
-: initialize-sha1 ( -- )
-    0 bytes-read set
-    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
-    [
-        20 HEX: 5a827999 <array> %
-        20 HEX: 6ed9eba1 <array> %
-        20 HEX: 8f1bbcdc <array> %
-        20 HEX: ca62c1d6 <array> %
-    ] { } make K set ;
-
-! 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 bitroll-32 ;
-
-! 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 )
-    20 /i
-    {   
-        { 0 [ [ over bitnot ] dip bitand [ bitand ] dip bitor ] }
-        { 1 [ bitxor bitxor ] }
-        { 2 [ 2dup bitand [ pick bitand [ bitand ] dip ] dip bitor bitor ] }
-        { 3 [ bitxor bitxor ] }
-    } case ;
-
-: nth-int-be ( string n -- int )
-    4 * dup 4 + rot <slice> be> ; inline
-
-: make-w ( str -- )
-    #! compute w, steps a-b of RFC 3174, section 6.1
-    16 [ nth-int-be w get push ] with each
-    16 80 dup <slice> [ sha1-W w get push ] each ;
-
-: init-letters ( -- )
-    ! 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 ;
-
-: inner-loop ( n -- temp )
-    ! TEMP = S^5(A) + f(t;B,C,D) + E + W(t) + K(t);
-    [
-        [ B get C get D get ] keep sha1-f ,
-        dup get-wth ,
-        K get nth ,
-        A get 5 bitroll-32 ,
-        E get ,
-    ] { } make sum 32 bits ; inline
-
-: set-vars ( temp -- )
-    ! E = D;  D = C;  C = S^30(B);  B = A; A = TEMP;
-    D get E set
-    C get D set
-    B get 30 bitroll-32 C set
-    A get B set
-    A set ;
-
-: calculate-letters ( -- )
-    ! step d of RFC 3174, section 6.1
-    80 [ inner-loop set-vars ] each ;
-
-: update-hs ( -- )
-    ! step e of RFC 3174, section 6.1
-    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 ;
-
-: (process-sha1-block) ( str -- )
-    80 <vector> w set make-w init-letters calculate-letters update-hs ;
-
-: process-sha1-block ( str -- )
-    dup length [ bytes-read [ + ] change ] keep 64 = [
-        (process-sha1-block)
-    ] [
-        t bytes-read get pad-last-block
-        [ (process-sha1-block) ] each
-    ] if ;
-
-: stream>sha1 ( -- )
-    64 read [ process-sha1-block ] keep
-    length 64 = [ stream>sha1 ] when ;
-
-: get-sha1 ( -- str )
-    [ [ h0 h1 h2 h3 h4 ] [ get 4 >be % ] each ] "" make ;
-
-SINGLETON: sha1
-
-INSTANCE: sha1 stream-checksum
-
-M: sha1 checksum-stream ( stream -- sha1 )
-    drop [ initialize-sha1 stream>sha1 get-sha1 ] with-input-stream ;
-
-: seq>2seq ( seq -- seq1 seq2 )
-    #! { abcdefgh } -> { aceg } { bdfh }
-    2 group flip [ { } { } ] [ first2 ] if-empty ;
-
-: 2seq>seq ( seq1 seq2 -- seq )
-    #! { aceg } { bdfh } -> { abcdefgh }
-    [ zip concat ] keep like ;
-
-: sha1-interleave ( string -- seq )
-    [ zero? ] trim-head
-    dup length odd? [ rest ] when
-    seq>2seq [ sha1 checksum-bytes ] bi@
-    2seq>seq ;

basis/checksums/sha1/summary.txt

@@ -1 +0,0 @@
-SHA1 checksum algorithm

basis/checksums/sha2/sha2-tests.factor

@@ -5,6 +5,13 @@ IN: checksums.sha2.tests
 : test-checksum ( text identifier -- checksum )
     checksum-bytes hex-string ;
 
+[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" sha1 checksum-bytes hex-string ] unit-test
+[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" sha1 checksum-bytes hex-string ] unit-test
+! [ "34aa973cd4c4daa4f61eeb2bdbad27316534016f" ] [ 1000000 CHAR: a fill string>sha1str ] unit-test ! takes a long time...
+[ "dea356a2cddd90c7a7ecedc5ebb563934f460452" ] [ "0123456701234567012345670123456701234567012345670123456701234567"
+10 swap <array> concat sha1 checksum-bytes hex-string ] unit-test
+
+
 [ "75388b16512776cc5dba5da1fd890150b0c6455cb4f58b1952522525" ]
 [
     "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"

basis/checksums/sha2/sha2.factor

@@ -3,15 +3,39 @@
 USING: kernel splitting grouping math sequences namespaces make
 io.binary math.bitwise checksums checksums.common
 sbufs strings combinators.smart math.ranges fry combinators
-accessors locals checksums.stream multiline ;
+accessors locals checksums.stream multiline literals
+generalizations ;
 IN: checksums.sha2
 
+SINGLETON: sha1
+INSTANCE: sha1 stream-checksum
+
 SINGLETON: sha-224
 SINGLETON: sha-256
 
 INSTANCE: sha-224 stream-checksum
 INSTANCE: sha-256 stream-checksum
 
+TUPLE: sha1-state < checksum-state K H W word-size ;
+
+CONSTANT: initial-H-sha1
+    { 
+        HEX: 67452301
+        HEX: efcdab89
+        HEX: 98badcfe
+        HEX: 10325476
+        HEX: c3d2e1f0
+    }
+
+CONSTANT: K-sha1
+    $[
+        20 HEX: 5a827999 <repetition>
+        20 HEX: 6ed9eba1 <repetition>
+        20 HEX: 8f1bbcdc <repetition>
+        20 HEX: ca62c1d6 <repetition> 
+        4 { } nappend-as
+    ]
+
 TUPLE: sha2-state < checksum-state K H word-size ;
 
 TUPLE: sha2-short < sha2-state ;
@@ -121,6 +145,13 @@ CONSTANT: K-384
 
 ALIAS: K-512 K-384
 
+: <sha1-state> ( -- sha1-state )
+    sha1-state new-checksum-state
+        64 >>block-size
+        K-sha1 >>K
+        initial-H-sha1 >>H
+        4 >>word-size ;
+
 : <sha-224-state> ( -- sha2-state )
     sha-224-state new-checksum-state
         64 >>block-size
@@ -135,6 +166,8 @@ ALIAS: K-512 K-384
         initial-H-256 >>H
         4 >>word-size ;
 
+M: sha1 initialize-checksum-state drop <sha1-state> ;
+
 M: sha-224 initialize-checksum-state drop <sha-224-state> ;
 
 M: sha-256 initialize-checksum-state drop <sha-256-state> ;
@@ -224,9 +257,6 @@ M: sha-256 initialize-checksum-state drop <sha-256-state> ;
 
 GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
 
-: seq>byte-array ( seq n -- string )
-    '[ _ >be ] map B{ } join ;
-
 :: T1-256 ( n M H sha2 -- T1 )
     n M nth
     n sha2 K>> nth +
@@ -272,12 +302,18 @@ GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
         cloned-H T2-256
         cloned-H update-H
     ] each
-    cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ; inline
+    sha2 [ cloned-H [ w+ ] 2map ] change-H drop ; inline
 
 M: sha2-short checksum-block
     [ prepare-message-schedule ]
     [ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi ;
 
+: seq>byte-array ( seq n -- string )
+    '[ _ >be ] map B{ } join ;
+
+: sha1>checksum ( sha2 -- bytes )
+    H>> 4 seq>byte-array ;
+
 : sha-224>checksum ( sha2 -- bytes )
     H>> 7 head 4 seq>byte-array ;
 
@@ -305,3 +341,71 @@ M: sha-224 checksum-stream ( stream checksum -- byte-array )
 M: sha-256 checksum-stream ( stream checksum -- byte-array )
     drop
     [ <sha-256-state> ] dip add-checksum-stream get-checksum ;
+
+
+
+: sha1-W ( t seq -- )
+    {
+        [ [ 3 - ] dip nth ]
+        [ [ 8 - ] dip nth bitxor ]
+        [ [ 14 - ] dip nth bitxor ]
+        [ [ 16 - ] dip nth bitxor 1 bitroll-32 ]
+        [ ]
+    } 2cleave set-nth ;
+
+: prepare-sha1-message-schedule ( seq -- w-seq )
+    4 <sliced-groups> [ be> ] map
+    80 0 pad-tail 16 80 [a,b) over
+    '[ _ sha1-W ] each ; inline
+
+: sha1-f ( B C D n -- f_nbcd )
+    20 /i
+    {
+        { 0 [ [ over bitnot ] dip bitand [ bitand ] dip bitor ] }
+        { 1 [ bitxor bitxor ] }
+        { 2 [ 2dup bitand [ pick bitand [ bitand ] dip ] dip bitor bitor ] }
+        { 3 [ bitxor bitxor ] }
+    } case ;
+
+:: inner-loop ( n H W K -- temp )
+    a H nth :> A
+    b H nth :> B
+    c H nth :> C
+    d H nth :> D
+    e H nth :> E
+    [
+        A 5 bitroll-32
+
+        B C D n sha1-f 
+
+        E
+
+        n K nth
+
+        n W nth
+    ] sum-outputs 32 bits ;
+
+:: process-sha1-chunk ( bytes H W K state -- )
+    80 [
+        H W K inner-loop
+        d H nth e H set-nth
+        c H nth d H set-nth
+        b H nth 30 bitroll-32 c H set-nth
+        a H nth b H set-nth
+        a H set-nth
+    ] each
+    state [ H [ w+ ] 2map ] change-H drop ; inline
+
+M:: sha1-state checksum-block ( bytes state -- )
+    bytes prepare-sha1-message-schedule state (>>W)
+
+    bytes
+    state [ H>> clone ] [ W>> ] [ K>> ] tri state process-sha1-chunk ;
+
+M: sha1-state get-checksum
+    clone
+    [ pad-last-short-block ] [ sha-256>checksum ] bi ;
+
+M: sha1 checksum-stream ( stream checksum -- byte-array )
+    drop
+    [ <sha1-state> ] dip add-checksum-stream get-checksum ;