basis/checksums/md5/md5.factor

   1 ! Copyright (C) 2006, 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: alien.c-types alien.data kernel io io.binary io.files
   4 io.streams.byte-array math math.functions math.parser namespaces
   5 splitting grouping strings sequences byte-arrays locals
   6 sequences.private macros fry io.encodings.binary math.bitwise
   7 checksums accessors checksums.common checksums.stream
   8 combinators combinators.smart specialized-arrays literals hints ;
   9 FROM: sequences.private => change-nth-unsafe ;
  10 SPECIALIZED-ARRAY: uint
  11 IN: checksums.md5
  12
  13 SINGLETON: md5
  14
  15 INSTANCE: md5 stream-checksum
  16
  17 TUPLE: md5-state < checksum-state state old-state ;
  18
  19 : <md5-state> ( -- md5 )
  20     md5-state new-checksum-state
  21         64 >>block-size
  22         uint-array{ 0x67452301 0xefcdab89 0x98badcfe 0x10325476 }
  23         [ clone >>state ] [ >>old-state ] bi ;
  24
  25 M: md5 initialize-checksum-state drop <md5-state> ;
  26
  27 <PRIVATE
  28
  29 : v-w+ ( v1 v2 -- v3 ) [ w+ ] 2map ;
  30
  31 : update-md5 ( md5 -- )
  32     [ state>> ] [ old-state>> v-w+ dup clone ] [ ] tri
  33     [ old-state<< ] [ state<< ] bi ;
  34
  35 CONSTANT: T
  36     $[
  37         80 iota [ sin abs 32 2^ * >integer ] uint-array{ } map-as
  38     ]
  39
  40 :: F ( X Y Z -- FXYZ )
  41     #! F(X,Y,Z) = XY v not(X) Z
  42     X Y bitand X bitnot Z bitand bitor ; inline
  43
  44 :: G ( X Y Z -- GXYZ )
  45     #! G(X,Y,Z) = XZ v Y not(Z)
  46     X Z bitand Y Z bitnot bitand bitor ; inline
  47
  48 : H ( X Y Z -- HXYZ )
  49     #! H(X,Y,Z) = X xor Y xor Z
  50     bitxor bitxor ; inline
  51
  52 :: I ( X Y Z -- IXYZ )
  53     #! I(X,Y,Z) = Y xor (X v not(Z))
  54     Z bitnot X bitor Y bitxor ; inline
  55
  56 CONSTANT: S11 7
  57 CONSTANT: S12 12
  58 CONSTANT: S13 17
  59 CONSTANT: S14 22
  60 CONSTANT: S21 5
  61 CONSTANT: S22 9
  62 CONSTANT: S23 14
  63 CONSTANT: S24 20
  64 CONSTANT: S31 4
  65 CONSTANT: S32 11
  66 CONSTANT: S33 16
  67 CONSTANT: S34 23
  68 CONSTANT: S41 6
  69 CONSTANT: S42 10
  70 CONSTANT: S43 15
  71 CONSTANT: S44 21
  72
  73 CONSTANT: a 0
  74 CONSTANT: b 1
  75 CONSTANT: c 2
  76 CONSTANT: d 3
  77
  78 :: (ABCD) ( x state a b c d k s i quot -- )
  79     #! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
  80     a state [
  81         b state nth-unsafe
  82         c state nth-unsafe
  83         d state nth-unsafe quot call w+
  84         k x nth-unsafe w+
  85         i T nth-unsafe w+
  86         s bitroll-32
  87         b state nth-unsafe w+ 32 bits
  88     ] change-nth-unsafe ; inline
  89
  90 MACRO: with-md5-round ( ops quot -- )
  91     '[ [ _ (ABCD) ] compose ] map '[ _ 2cleave ] ;
  92
  93 : (process-md5-block-F) ( block state -- )
  94     {
  95         [ a b c d 0  S11 1  ]
  96         [ d a b c 1  S12 2  ]
  97         [ c d a b 2  S13 3  ]
  98         [ b c d a 3  S14 4  ]
  99         [ a b c d 4  S11 5  ]
 100         [ d a b c 5  S12 6  ]
 101         [ c d a b 6  S13 7  ]
 102         [ b c d a 7  S14 8  ]
 103         [ a b c d 8  S11 9  ]
 104         [ d a b c 9  S12 10 ]
 105         [ c d a b 10 S13 11 ]
 106         [ b c d a 11 S14 12 ]
 107         [ a b c d 12 S11 13 ]
 108         [ d a b c 13 S12 14 ]
 109         [ c d a b 14 S13 15 ]
 110         [ b c d a 15 S14 16 ]
 111     } [ F ] with-md5-round ;
 112
 113 : (process-md5-block-G) ( block state -- )
 114     {
 115         [ a b c d 1  S21 17 ]
 116         [ d a b c 6  S22 18 ]
 117         [ c d a b 11 S23 19 ]
 118         [ b c d a 0  S24 20 ]
 119         [ a b c d 5  S21 21 ]
 120         [ d a b c 10 S22 22 ]
 121         [ c d a b 15 S23 23 ]
 122         [ b c d a 4  S24 24 ]
 123         [ a b c d 9  S21 25 ]
 124         [ d a b c 14 S22 26 ]
 125         [ c d a b 3  S23 27 ]
 126         [ b c d a 8  S24 28 ]
 127         [ a b c d 13 S21 29 ]
 128         [ d a b c 2  S22 30 ]
 129         [ c d a b 7  S23 31 ]
 130         [ b c d a 12 S24 32 ]
 131     } [ G ] with-md5-round ;
 132
 133 : (process-md5-block-H) ( block state -- )
 134     {
 135         [ a b c d 5  S31 33 ]
 136         [ d a b c 8  S32 34 ]
 137         [ c d a b 11 S33 35 ]
 138         [ b c d a 14 S34 36 ]
 139         [ a b c d 1  S31 37 ]
 140         [ d a b c 4  S32 38 ]
 141         [ c d a b 7  S33 39 ]
 142         [ b c d a 10 S34 40 ]
 143         [ a b c d 13 S31 41 ]
 144         [ d a b c 0  S32 42 ]
 145         [ c d a b 3  S33 43 ]
 146         [ b c d a 6  S34 44 ]
 147         [ a b c d 9  S31 45 ]
 148         [ d a b c 12 S32 46 ]
 149         [ c d a b 15 S33 47 ]
 150         [ b c d a 2  S34 48 ]
 151     } [ H ] with-md5-round ;
 152
 153 : (process-md5-block-I) ( block state -- )
 154     {
 155         [ a b c d 0  S41 49 ]
 156         [ d a b c 7  S42 50 ]
 157         [ c d a b 14 S43 51 ]
 158         [ b c d a 5  S44 52 ]
 159         [ a b c d 12 S41 53 ]
 160         [ d a b c 3  S42 54 ]
 161         [ c d a b 10 S43 55 ]
 162         [ b c d a 1  S44 56 ]
 163         [ a b c d 8  S41 57 ]
 164         [ d a b c 15 S42 58 ]
 165         [ c d a b 6  S43 59 ]
 166         [ b c d a 13 S44 60 ]
 167         [ a b c d 4  S41 61 ]
 168         [ d a b c 11 S42 62 ]
 169         [ c d a b 2  S43 63 ]
 170         [ b c d a 9  S44 64 ]
 171     } [ I ] with-md5-round ;
 172
 173 HINTS: (process-md5-block-F) { uint-array md5-state } ;
 174 HINTS: (process-md5-block-G) { uint-array md5-state } ;
 175 HINTS: (process-md5-block-H) { uint-array md5-state } ;
 176 HINTS: (process-md5-block-I) { uint-array md5-state } ;
 177
 178 : byte-array>le ( byte-array -- byte-array )
 179     little-endian? [
 180         dup 4 <sliced-groups> [
 181             [ [ 1 2 ] dip exchange-unsafe ]
 182             [ [ 0 3 ] dip exchange-unsafe ] bi
 183         ] each
 184     ] unless ;
 185
 186 : uint-array-cast-le ( byte-array -- uint-array )
 187     byte-array>le uint cast-array ;
 188
 189 HINTS: uint-array-cast-le byte-array ;
 190
 191 : uint-array>byte-array-le ( uint-array -- byte-array )
 192     underlying>> byte-array>le ;
 193
 194 HINTS: uint-array>byte-array-le uint-array ;
 195
 196 M: md5-state checksum-block ( block state -- )
 197     [
 198         [ uint-array-cast-le ] [ state>> ] bi* {
 199             [ (process-md5-block-F) ]
 200             [ (process-md5-block-G) ]
 201             [ (process-md5-block-H) ]
 202             [ (process-md5-block-I) ]
 203         } 2cleave
 204     ] [
 205         nip update-md5
 206     ] 2bi ;
 207
 208 : md5>checksum ( md5 -- bytes ) state>> uint-array>byte-array-le ;
 209
 210 M: md5-state clone ( md5 -- new-md5 )
 211     call-next-method
 212     [ clone ] change-state
 213     [ clone ] change-old-state ;
 214
 215 M: md5-state get-checksum ( md5 -- bytes )
 216     clone [ bytes>> f ] [ bytes-read>> pad-last-block ] [ ] tri
 217     [ [ checksum-block ] curry each ] [ md5>checksum ] bi ;
 218
 219 M: md5 checksum-stream ( stream checksum -- byte-array )
 220     drop
 221     [ <md5-state> ] dip add-checksum-stream get-checksum ;
 222
 223 PRIVATE>