libs/crypto/sha1.factor

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