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 macros fry
   6 io.encodings.binary math.bitwise checksums accessors
   7 checksums.common checksums.stream combinators combinators.smart ;
   8 IN: checksums.md5
   9
  10 TUPLE: md5-state bytes-read state old-state ;
  11
  12 : <md5-state> ( -- md5-state )
  13     md5-state new
  14         0 >>bytes-read
  15         { HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 }
  16         [ clone >>state ] [ >>old-state ] bi ;
  17
  18 <PRIVATE
  19
  20 : v-w+ ( v1 v2 -- v3 ) [ w+ ] 2map ;
  21
  22 : update-md5-state ( md5-state -- )
  23     [ state>> ] [ old-state>> v-w+ dup clone ] [ ] tri
  24     [ (>>old-state) ] [ (>>state) ] bi ; inline
  25
  26 : T ( N -- Y )
  27     sin abs 32 2^ * >integer ; inline
  28
  29 :: F ( X Y Z -- FXYZ )
  30     #! F(X,Y,Z) = XY v not(X) Z
  31     X Y bitand X bitnot Z bitand bitor ; inline
  32
  33 :: G ( X Y Z -- GXYZ )
  34     #! G(X,Y,Z) = XZ v Y not(Z)
  35     X Z bitand Y Z bitnot bitand bitor ; inline
  36
  37 : H ( X Y Z -- HXYZ )
  38     #! H(X,Y,Z) = X xor Y xor Z
  39     bitxor bitxor ; inline
  40
  41 :: I ( X Y Z -- IXYZ )
  42     #! I(X,Y,Z) = Y xor (X v not(Z))
  43     Z bitnot X bitor Y bitxor ; inline
  44
  45 CONSTANT: S11 7
  46 CONSTANT: S12 12
  47 CONSTANT: S13 17
  48 CONSTANT: S14 22
  49 CONSTANT: S21 5
  50 CONSTANT: S22 9
  51 CONSTANT: S23 14
  52 CONSTANT: S24 20
  53 CONSTANT: S31 4
  54 CONSTANT: S32 11
  55 CONSTANT: S33 16
  56 CONSTANT: S34 23
  57 CONSTANT: S41 6
  58 CONSTANT: S42 10
  59 CONSTANT: S43 15
  60 CONSTANT: S44 21
  61
  62 CONSTANT: a 0
  63 CONSTANT: b 1
  64 CONSTANT: c 2
  65 CONSTANT: d 3
  66
  67 :: (ABCD) ( x V a b c d k s i quot -- )
  68     #! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
  69     a V [
  70         b V nth-unsafe
  71         c V nth-unsafe
  72         d V nth-unsafe quot call w+
  73         k x nth-unsafe w+
  74         i T w+
  75         s bitroll-32
  76         b V nth-unsafe w+
  77     ] change-nth ; inline
  78
  79 MACRO: with-md5-round ( ops quot -- )
  80     '[ [ _ (ABCD) ] compose ] map '[ _ 2cleave ] ;
  81
  82 : (process-md5-block-F) ( block v -- )
  83     {
  84         [ a b c d 0  S11 1  ]
  85         [ d a b c 1  S12 2  ]
  86         [ c d a b 2  S13 3  ]
  87         [ b c d a 3  S14 4  ]
  88         [ a b c d 4  S11 5  ]
  89         [ d a b c 5  S12 6  ]
  90         [ c d a b 6  S13 7  ]
  91         [ b c d a 7  S14 8  ]
  92         [ a b c d 8  S11 9  ]
  93         [ d a b c 9  S12 10 ]
  94         [ c d a b 10 S13 11 ]
  95         [ b c d a 11 S14 12 ]
  96         [ a b c d 12 S11 13 ]
  97         [ d a b c 13 S12 14 ]
  98         [ c d a b 14 S13 15 ]
  99         [ b c d a 15 S14 16 ]
 100     } [ F ] with-md5-round ; inline
 101
 102 : (process-md5-block-G) ( block v -- )
 103     {
 104         [ a b c d 1  S21 17 ]
 105         [ d a b c 6  S22 18 ]
 106         [ c d a b 11 S23 19 ]
 107         [ b c d a 0  S24 20 ]
 108         [ a b c d 5  S21 21 ]
 109         [ d a b c 10 S22 22 ]
 110         [ c d a b 15 S23 23 ]
 111         [ b c d a 4  S24 24 ]
 112         [ a b c d 9  S21 25 ]
 113         [ d a b c 14 S22 26 ]
 114         [ c d a b 3  S23 27 ]
 115         [ b c d a 8  S24 28 ]
 116         [ a b c d 13 S21 29 ]
 117         [ d a b c 2  S22 30 ]
 118         [ c d a b 7  S23 31 ]
 119         [ b c d a 12 S24 32 ]
 120     } [ G ] with-md5-round ; inline
 121
 122 : (process-md5-block-H) ( block v -- )
 123     {
 124         [ a b c d 5  S31 33 ]
 125         [ d a b c 8  S32 34 ]
 126         [ c d a b 11 S33 35 ]
 127         [ b c d a 14 S34 36 ]
 128         [ a b c d 1  S31 37 ]
 129         [ d a b c 4  S32 38 ]
 130         [ c d a b 7  S33 39 ]
 131         [ b c d a 10 S34 40 ]
 132         [ a b c d 13 S31 41 ]
 133         [ d a b c 0  S32 42 ]
 134         [ c d a b 3  S33 43 ]
 135         [ b c d a 6  S34 44 ]
 136         [ a b c d 9  S31 45 ]
 137         [ d a b c 12 S32 46 ]
 138         [ c d a b 15 S33 47 ]
 139         [ b c d a 2  S34 48 ]
 140     } [ H ] with-md5-round ; inline
 141
 142 : (process-md5-block-I) ( block v -- )
 143     {
 144         [ a b c d 0  S41 49 ]
 145         [ d a b c 7  S42 50 ]
 146         [ c d a b 14 S43 51 ]
 147         [ b c d a 5  S44 52 ]
 148         [ a b c d 12 S41 53 ]
 149         [ d a b c 3  S42 54 ]
 150         [ c d a b 10 S43 55 ]
 151         [ b c d a 1  S44 56 ]
 152         [ a b c d 8  S41 57 ]
 153         [ d a b c 15 S42 58 ]
 154         [ c d a b 6  S43 59 ]
 155         [ b c d a 13 S44 60 ]
 156         [ a b c d 4  S41 61 ]
 157         [ d a b c 11 S42 62 ]
 158         [ c d a b 2  S43 63 ]
 159         [ b c d a 9  S44 64 ]
 160     } [ I ] with-md5-round ; inline
 161
 162 : (process-md5-block) ( block state -- )
 163     [
 164         [ 4 <groups> [ le> ] map ] [ state>> ] bi* {
 165             [ (process-md5-block-F) ]
 166             [ (process-md5-block-G) ]
 167             [ (process-md5-block-H) ]
 168             [ (process-md5-block-I) ]
 169         } 2cleave
 170     ] [
 171         nip update-md5-state
 172     ] 2bi ;
 173
 174 :: process-md5-block ( block state -- )
 175     block length
 176     [ state [ + ] change-bytes-read drop ] [ 64 = ] bi [
 177         block state (process-md5-block)
 178     ] [
 179         block f state bytes-read>> pad-last-block
 180         [ state (process-md5-block) ] each
 181     ] if ;
 182
 183 : get-md5 ( md5-state -- bytes )
 184     state>> [ 4 >le ] map B{ } concat-as ;
 185
 186 :: stream>md5 ( state stream -- )
 187     64 stream stream-read
 188     [ state process-md5-block ] [ length 64 = ] bi
 189     [ state stream stream>md5 ] when ;
 190
 191 PRIVATE>
 192
 193 SINGLETON: md5
 194
 195 INSTANCE: md5 stream-checksum
 196
 197 M: md5 checksum-stream
 198     drop [ <md5-state> ] dip [ stream>md5 ] [ drop get-md5 ] 2bi ;
 199
 200 GENERIC: initialize-checksum ( checksum -- state )
 201 GENERIC# add-bytes 1 ( state bytes -- state )
 202 GENERIC# add-stream 1 ( state stream -- state )
 203 GENERIC: finish-checksum ( state -- bytes )
 204
 205 M: md5 initialize-checksum drop <md5-state> ;
 206
 207 M: md5-state finish-checksum get-md5 ;
 208
 209 M: md5-state add-bytes over [ binary <byte-reader> stream>md5 ] dip ;
 210
 211 M: md5-state add-stream over [ stream>md5 ] dip ;