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