basis/checksums/md5/md5.factor

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