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