extra/checksums/md5/md5.factor

   1 ! See http://www.faqs.org/rfcs/rfc1321.html
   2
   3 USING: kernel io io.binary io.files io.streams.byte-array math
   4 math.functions math.parser namespaces splitting strings
   5 sequences crypto.common byte-arrays locals sequences.private
   6 io.encodings.binary symbols math.bitfields.lib checksums ;
   7 IN: checksums.md5
   8
   9 <PRIVATE
  10
  11 SYMBOLS: a b c d old-a old-b old-c old-d ;
  12
  13 : T ( N -- Y )
  14     sin abs 4294967296 * >bignum ; foldable
  15
  16 : initialize-md5 ( -- )
  17     0 bytes-read set
  18     HEX: 67452301 dup a set old-a set
  19     HEX: efcdab89 dup b set old-b set
  20     HEX: 98badcfe dup c set old-c set
  21     HEX: 10325476 dup d set old-d set ;
  22
  23 : update-md ( -- )
  24     old-a a update-old-new
  25     old-b b update-old-new
  26     old-c c update-old-new
  27     old-d d update-old-new ;
  28
  29 :: (ABCD) ( x s i k func a b c d -- )
  30     #! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
  31     a [
  32         b get c get d get func call w+
  33         k x nth-unsafe w+
  34         i T w+
  35         s bitroll-32
  36         b get w+
  37     ] change ; inline
  38
  39 : ABCD a b c d (ABCD) ; inline
  40 : BCDA b c d a (ABCD) ; inline
  41 : CDAB c d a b (ABCD) ; inline
  42 : DABC d a b c (ABCD) ; inline
  43
  44 : F ( X Y Z -- FXYZ )
  45     #! F(X,Y,Z) = XY v not(X) Z
  46     pick bitnot bitand [ bitand ] [ bitor ] bi* ;
  47
  48 : G ( X Y Z -- GXYZ )
  49     #! G(X,Y,Z) = XZ v Y not(Z)
  50     dup bitnot rot bitand [ bitand ] [ bitor ] bi* ;
  51
  52 : H ( X Y Z -- HXYZ )
  53     #! H(X,Y,Z) = X xor Y xor Z
  54     bitxor bitxor ;
  55
  56 : I ( X Y Z -- IXYZ )
  57     #! I(X,Y,Z) = Y xor (X v not(Z))
  58     rot swap bitnot bitor bitxor ;
  59
  60 : S11 7  ; inline
  61 : S12 12 ; inline
  62 : S13 17 ; inline
  63 : S14 22 ; inline
  64 : S21 5  ; inline
  65 : S22 9  ; inline
  66 : S23 14 ; inline
  67 : S24 20 ; inline
  68 : S31 4 ;  inline
  69 : S32 11 ; inline
  70 : S33 16 ; inline
  71 : S34 23 ; inline
  72 : S41 6  ; inline
  73 : S42 10 ; inline
  74 : S43 15 ; inline
  75 : S44 21 ; inline
  76
  77 : (process-md5-block-F) ( block -- block )
  78     dup S11 1  0  [ F ] ABCD
  79     dup S12 2  1  [ F ] DABC
  80     dup S13 3  2  [ F ] CDAB
  81     dup S14 4  3  [ F ] BCDA
  82     dup S11 5  4  [ F ] ABCD
  83     dup S12 6  5  [ F ] DABC
  84     dup S13 7  6  [ F ] CDAB
  85     dup S14 8  7  [ F ] BCDA
  86     dup S11 9  8  [ F ] ABCD
  87     dup S12 10 9  [ F ] DABC
  88     dup S13 11 10 [ F ] CDAB
  89     dup S14 12 11 [ F ] BCDA
  90     dup S11 13 12 [ F ] ABCD
  91     dup S12 14 13 [ F ] DABC
  92     dup S13 15 14 [ F ] CDAB
  93     dup S14 16 15 [ F ] BCDA ;
  94
  95 : (process-md5-block-G) ( block -- block )
  96     dup S21 17 1  [ G ] ABCD
  97     dup S22 18 6  [ G ] DABC
  98     dup S23 19 11 [ G ] CDAB
  99     dup S24 20 0  [ G ] BCDA
 100     dup S21 21 5  [ G ] ABCD
 101     dup S22 22 10 [ G ] DABC
 102     dup S23 23 15 [ G ] CDAB
 103     dup S24 24 4  [ G ] BCDA
 104     dup S21 25 9  [ G ] ABCD
 105     dup S22 26 14 [ G ] DABC
 106     dup S23 27 3  [ G ] CDAB
 107     dup S24 28 8  [ G ] BCDA
 108     dup S21 29 13 [ G ] ABCD
 109     dup S22 30 2  [ G ] DABC
 110     dup S23 31 7  [ G ] CDAB
 111     dup S24 32 12 [ G ] BCDA ;
 112
 113 : (process-md5-block-H) ( block -- block )
 114     dup S31 33 5  [ H ] ABCD
 115     dup S32 34 8  [ H ] DABC
 116     dup S33 35 11 [ H ] CDAB
 117     dup S34 36 14 [ H ] BCDA
 118     dup S31 37 1  [ H ] ABCD
 119     dup S32 38 4  [ H ] DABC
 120     dup S33 39 7  [ H ] CDAB
 121     dup S34 40 10 [ H ] BCDA
 122     dup S31 41 13 [ H ] ABCD
 123     dup S32 42 0  [ H ] DABC
 124     dup S33 43 3  [ H ] CDAB
 125     dup S34 44 6  [ H ] BCDA
 126     dup S31 45 9  [ H ] ABCD
 127     dup S32 46 12 [ H ] DABC
 128     dup S33 47 15 [ H ] CDAB
 129     dup S34 48 2  [ H ] BCDA ;
 130
 131 : (process-md5-block-I) ( block -- block )
 132     dup S41 49 0  [ I ] ABCD
 133     dup S42 50 7  [ I ] DABC
 134     dup S43 51 14 [ I ] CDAB
 135     dup S44 52 5  [ I ] BCDA
 136     dup S41 53 12 [ I ] ABCD
 137     dup S42 54 3  [ I ] DABC
 138     dup S43 55 10 [ I ] CDAB
 139     dup S44 56 1  [ I ] BCDA
 140     dup S41 57 8  [ I ] ABCD
 141     dup S42 58 15 [ I ] DABC
 142     dup S43 59 6  [ I ] CDAB
 143     dup S44 60 13 [ I ] BCDA
 144     dup S41 61 4  [ I ] ABCD
 145     dup S42 62 11 [ I ] DABC
 146     dup S43 63 2  [ I ] CDAB
 147     dup S44 64 9  [ I ] BCDA ;
 148
 149 : (process-md5-block) ( block -- )
 150     4 <groups> [ le> ] map
 151
 152     (process-md5-block-F)
 153     (process-md5-block-G)
 154     (process-md5-block-H)
 155     (process-md5-block-I)
 156
 157     drop
 158
 159     update-md ;
 160
 161 : process-md5-block ( str -- )
 162     dup length [ bytes-read [ + ] change ] keep 64 = [
 163         (process-md5-block)
 164     ] [
 165         f bytes-read get pad-last-block
 166         [ (process-md5-block) ] each
 167     ] if ;
 168
 169 : stream>md5 ( -- )
 170     64 read [ process-md5-block ] keep
 171     length 64 = [ stream>md5 ] when ;
 172
 173 : get-md5 ( -- str )
 174     [ a b c d ] [ get 4 >le ] map concat >byte-array ;
 175
 176 PRIVATE>
 177
 178 SINGLETON: md5
 179
 180 INSTANCE: md5 checksum
 181
 182 M: md5 checksum-stream ( stream -- byte-array )
 183     drop [ initialize-md5 stream>md5 get-md5 ] with-input-stream ;