1 ! Copyright (C) 2006, 2008 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: alien.c-types 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 specialized-arrays literals hints ;
9 SPECIALIZED-ARRAY: uint
14 INSTANCE: md5 stream-checksum
16 TUPLE: md5-state < checksum-state state old-state ;
18 : <md5-state> ( -- md5 )
19 md5-state new-checksum-state
21 uint-array{ HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 }
22 [ clone >>state ] [ >>old-state ] bi ;
24 M: md5 initialize-checksum-state drop <md5-state> ;
28 : v-w+ ( v1 v2 -- v3 ) [ w+ ] 2map ;
30 : update-md5 ( md5 -- )
31 [ state>> ] [ old-state>> v-w+ dup clone ] [ ] tri
32 [ (>>old-state) ] [ (>>state) ] bi ;
36 80 iota [ sin abs 32 2^ * >integer ] uint-array{ } map-as
39 :: F ( X Y Z -- FXYZ )
40 #! F(X,Y,Z) = XY v not(X) Z
41 X Y bitand X bitnot Z bitand bitor ; inline
43 :: G ( X Y Z -- GXYZ )
44 #! G(X,Y,Z) = XZ v Y not(Z)
45 X Z bitand Y Z bitnot bitand bitor ; inline
48 #! H(X,Y,Z) = X xor Y xor Z
49 bitxor bitxor ; inline
51 :: I ( X Y Z -- IXYZ )
52 #! I(X,Y,Z) = Y xor (X v not(Z))
53 Z bitnot X bitor Y bitxor ; inline
77 :: (ABCD) ( x state a b c d k s i quot -- )
78 #! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
82 d state nth-unsafe quot call w+
86 b state nth-unsafe w+ 32 bits
87 ] change-nth-unsafe ; inline
89 MACRO: with-md5-round ( ops quot -- )
90 '[ [ _ (ABCD) ] compose ] map '[ _ 2cleave ] ;
92 : (process-md5-block-F) ( block state -- )
104 [ c d a b 10 S13 11 ]
105 [ b c d a 11 S14 12 ]
106 [ a b c d 12 S11 13 ]
107 [ d a b c 13 S12 14 ]
108 [ c d a b 14 S13 15 ]
109 [ b c d a 15 S14 16 ]
110 } [ F ] with-md5-round ;
112 : (process-md5-block-G) ( block state -- )
116 [ c d a b 11 S23 19 ]
119 [ d a b c 10 S22 22 ]
120 [ c d a b 15 S23 23 ]
123 [ d a b c 14 S22 26 ]
126 [ a b c d 13 S21 29 ]
129 [ b c d a 12 S24 32 ]
130 } [ G ] with-md5-round ;
132 : (process-md5-block-H) ( block state -- )
136 [ c d a b 11 S33 35 ]
137 [ b c d a 14 S34 36 ]
141 [ b c d a 10 S34 40 ]
142 [ a b c d 13 S31 41 ]
147 [ d a b c 12 S32 46 ]
148 [ c d a b 15 S33 47 ]
150 } [ H ] with-md5-round ;
152 : (process-md5-block-I) ( block state -- )
156 [ c d a b 14 S43 51 ]
158 [ a b c d 12 S41 53 ]
160 [ c d a b 10 S43 55 ]
163 [ d a b c 15 S42 58 ]
165 [ b c d a 13 S44 60 ]
167 [ d a b c 11 S42 62 ]
170 } [ I ] with-md5-round ;
172 HINTS: (process-md5-block-F) { uint-array md5-state } ;
173 HINTS: (process-md5-block-G) { uint-array md5-state } ;
174 HINTS: (process-md5-block-H) { uint-array md5-state } ;
175 HINTS: (process-md5-block-I) { uint-array md5-state } ;
177 : byte-array>le ( byte-array -- byte-array )
179 dup 4 <sliced-groups> [
180 [ [ 1 2 ] dip exchange-unsafe ]
181 [ [ 0 3 ] dip exchange-unsafe ] bi
185 : byte-array>uint-array-le ( byte-array -- uint-array )
186 byte-array>le byte-array>uint-array ;
188 HINTS: byte-array>uint-array-le byte-array ;
190 : uint-array>byte-array-le ( uint-array -- byte-array )
191 underlying>> byte-array>le ;
193 HINTS: uint-array>byte-array-le uint-array ;
195 M: md5-state checksum-block ( block state -- )
197 [ byte-array>uint-array-le ] [ state>> ] bi* {
198 [ (process-md5-block-F) ]
199 [ (process-md5-block-G) ]
200 [ (process-md5-block-H) ]
201 [ (process-md5-block-I) ]
207 : md5>checksum ( md5 -- bytes ) state>> uint-array>byte-array-le ;
209 M: md5-state clone ( md5 -- new-md5 )
211 [ clone ] change-state
212 [ clone ] change-old-state ;
214 M: md5-state get-checksum ( md5 -- bytes )
215 clone [ bytes>> f ] [ bytes-read>> pad-last-block ] [ ] tri
216 [ [ checksum-block ] curry each ] [ md5>checksum ] bi ;
218 M: md5 checksum-stream ( stream checksum -- byte-array )
220 [ <md5-state> ] dip add-checksum-stream get-checksum ;