basis/checksums/sha1/sha1.factor

   1 ! Copyright (C) 2006, 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays combinators kernel io io.encodings.binary io.files
   4 io.streams.byte-array math.vectors strings sequences namespaces
   5 math parser sequences assocs grouping vectors io.binary hashtables
   6 symbols math.bitwise checksums checksums.common ;
   7 IN: checksums.sha1
   8
   9 ! Implemented according to RFC 3174.
  10
  11 SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
  12
  13 : get-wth ( n -- wth ) w get nth ; inline
  14 : shift-wth ( n -- x ) get-wth 1 bitroll-32 ; inline
  15
  16 : initialize-sha1 ( -- )
  17     0 bytes-read set
  18     HEX: 67452301 dup h0 set A set
  19     HEX: efcdab89 dup h1 set B set
  20     HEX: 98badcfe dup h2 set C set
  21     HEX: 10325476 dup h3 set D set
  22     HEX: c3d2e1f0 dup h4 set E set
  23     [
  24         20 HEX: 5a827999 <array> %
  25         20 HEX: 6ed9eba1 <array> %
  26         20 HEX: 8f1bbcdc <array> %
  27         20 HEX: ca62c1d6 <array> %
  28     ] { } make K set ;
  29
  30 ! W(t) = S^1(W(t-3) XOR W(t-8) XOR W(t-14) XOR W(t-16))
  31 : sha1-W ( t -- W_t )
  32      dup 3 - get-wth
  33      over 8 - get-wth bitxor
  34      over 14 - get-wth bitxor
  35      swap 16 - get-wth bitxor 1 bitroll-32 ;
  36
  37 ! f(t;B,C,D) = (B AND C) OR ((NOT B) AND D)         ( 0 <= t <= 19)
  38 ! f(t;B,C,D) = B XOR C XOR D                        (20 <= t <= 39)
  39 ! f(t;B,C,D) = (B AND C) OR (B AND D) OR (C AND D)  (40 <= t <= 59)
  40 ! f(t;B,C,D) = B XOR C XOR D                        (60 <= t <= 79)
  41 : sha1-f ( B C D t -- f_tbcd )
  42     20 /i
  43     {
  44         { 0 [ >r over bitnot r> bitand >r bitand r> bitor ] }
  45         { 1 [ bitxor bitxor ] }
  46         { 2 [ 2dup bitand >r pick bitand >r bitand r> r> bitor bitor ] }
  47         { 3 [ bitxor bitxor ] }
  48     } case ;
  49
  50 : nth-int-be ( string n -- int )
  51     4 * dup 4 + rot <slice> be> ; inline
  52
  53 : make-w ( str -- )
  54     #! compute w, steps a-b of RFC 3174, section 6.1
  55     16 [ nth-int-be w get push ] with each
  56     16 80 dup <slice> [ sha1-W w get push ] each ;
  57
  58 : init-letters ( -- )
  59     ! step c of RFC 3174, section 6.1
  60     h0 get A set
  61     h1 get B set
  62     h2 get C set
  63     h3 get D set
  64     h4 get E set ;
  65
  66 : inner-loop ( n -- temp )
  67     ! TEMP = S^5(A) + f(t;B,C,D) + E + W(t) + K(t);
  68     [
  69         [ B get C get D get ] keep sha1-f ,
  70         dup get-wth ,
  71         K get nth ,
  72         A get 5 bitroll-32 ,
  73         E get ,
  74     ] { } make sum 32 bits ; inline
  75
  76 : set-vars ( temp -- )
  77     ! E = D;  D = C;  C = S^30(B);  B = A; A = TEMP;
  78     D get E set
  79     C get D set
  80     B get 30 bitroll-32 C set
  81     A get B set
  82     A set ;
  83
  84 : calculate-letters ( -- )
  85     ! step d of RFC 3174, section 6.1
  86     80 [ inner-loop set-vars ] each ;
  87
  88 : update-hs ( -- )
  89     ! step e of RFC 3174, section 6.1
  90     A h0 update-old-new
  91     B h1 update-old-new
  92     C h2 update-old-new
  93     D h3 update-old-new
  94     E h4 update-old-new ;
  95
  96 : (process-sha1-block) ( str -- )
  97     80 <vector> w set make-w init-letters calculate-letters update-hs ;
  98
  99 : process-sha1-block ( str -- )
 100     dup length [ bytes-read [ + ] change ] keep 64 = [
 101         (process-sha1-block)
 102     ] [
 103         t bytes-read get pad-last-block
 104         [ (process-sha1-block) ] each
 105     ] if ;
 106
 107 : stream>sha1 ( -- )
 108     64 read [ process-sha1-block ] keep
 109     length 64 = [ stream>sha1 ] when ;
 110
 111 : get-sha1 ( -- str )
 112     [ [ h0 h1 h2 h3 h4 ] [ get 4 >be % ] each ] "" make ;
 113
 114 SINGLETON: sha1
 115
 116 INSTANCE: sha1 checksum
 117
 118 M: sha1 checksum-stream ( stream -- sha1 )
 119     drop [ initialize-sha1 stream>sha1 get-sha1 ] with-input-stream ;
 120
 121 : seq>2seq ( seq -- seq1 seq2 )
 122     #! { abcdefgh } -> { aceg } { bdfh }
 123     2 group flip dup empty? [ drop { } { } ] [ first2 ] if ;
 124
 125 : 2seq>seq ( seq1 seq2 -- seq )
 126     #! { aceg } { bdfh } -> { abcdefgh }
 127     [ zip concat ] keep like ;
 128
 129 : sha1-interleave ( string -- seq )
 130     [ zero? ] trim-left
 131     dup length odd? [ rest ] when
 132     seq>2seq [ sha1 checksum-bytes ] bi@
 133     2seq>seq ;