basis/checksums/sha1/sha1.factor

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