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
7 checksums.common checksums.stream combinators ;
10 ! See http://www.faqs.org/rfcs/rfc1321.html
14 SYMBOLS: a b c d old-a old-b old-c old-d ;
17 sin abs 4294967296 * >integer ; foldable
19 : initialize-md5 ( -- )
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 ;
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 ;
32 :: (ABCD) ( x a b c d k s i func -- )
33 #! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
35 b get c get d get func call w+
43 #! F(X,Y,Z) = XY v not(X) Z
44 pick bitnot bitand [ bitand ] [ bitor ] bi* ;
47 #! G(X,Y,Z) = XZ v Y not(Z)
48 dup bitnot rot bitand [ bitand ] [ bitor ] bi* ;
51 #! H(X,Y,Z) = X xor Y xor Z
55 #! I(X,Y,Z) = Y xor (X v not(Z))
56 rot swap bitnot bitor bitxor ;
75 MACRO: with-md5-round ( ops func -- )
76 '[ [ _ (ABCD) ] compose ] map '[ _ cleave ] ;
78 : (process-md5-block-F) ( block -- )
96 } [ F ] with-md5-round ;
98 : (process-md5-block-G) ( block -- )
102 [ c d a b 11 S23 19 ]
105 [ d a b c 10 S22 22 ]
106 [ c d a b 15 S23 23 ]
109 [ d a b c 14 S22 26 ]
112 [ a b c d 13 S21 29 ]
115 [ b c d a 12 S24 32 ]
116 } [ G ] with-md5-round ;
118 : (process-md5-block-H) ( block -- )
122 [ c d a b 11 S33 35 ]
123 [ b c d a 14 S34 36 ]
127 [ b c d a 10 S34 40 ]
128 [ a b c d 13 S31 41 ]
133 [ d a b c 12 S32 46 ]
134 [ c d a b 15 S33 47 ]
136 } [ H ] with-md5-round ;
138 : (process-md5-block-I) ( block -- )
142 [ c d a b 14 S43 51 ]
144 [ a b c d 12 S41 53 ]
146 [ c d a b 10 S43 55 ]
149 [ d a b c 15 S42 58 ]
151 [ b c d a 13 S44 60 ]
153 [ d a b c 11 S42 62 ]
156 } [ I ] with-md5-round ;
158 : (process-md5-block) ( block -- )
159 4 <groups> [ le> ] map {
160 [ (process-md5-block-F) ]
161 [ (process-md5-block-G) ]
162 [ (process-md5-block-H) ]
163 [ (process-md5-block-I) ]
168 : process-md5-block ( str -- )
169 dup length [ bytes-read [ + ] change ] keep 64 = [
172 f bytes-read get pad-last-block
173 [ (process-md5-block) ] each
177 64 read [ process-md5-block ] keep
178 length 64 = [ stream>md5 ] when ;
181 [ a b c d ] [ get 4 >le ] map concat >byte-array ;
187 INSTANCE: md5 stream-checksum
189 M: md5 checksum-stream ( stream -- byte-array )
190 drop [ initialize-md5 stream>md5 get-md5 ] with-input-stream ;