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
6 io.encodings.binary symbols math.bitwise checksums
7 checksums.common checksums.stream ;
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 s i k func a b c d -- )
33 #! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
35 b get c get d get func call w+
42 : ABCD a b c d (ABCD) ; inline
43 : BCDA b c d a (ABCD) ; inline
44 : CDAB c d a b (ABCD) ; inline
45 : DABC d a b c (ABCD) ; inline
48 #! F(X,Y,Z) = XY v not(X) Z
49 pick bitnot bitand [ bitand ] [ bitor ] bi* ;
52 #! G(X,Y,Z) = XZ v Y not(Z)
53 dup bitnot rot bitand [ bitand ] [ bitor ] bi* ;
56 #! H(X,Y,Z) = X xor Y xor Z
60 #! I(X,Y,Z) = Y xor (X v not(Z))
61 rot swap bitnot bitor bitxor ;
80 : (process-md5-block-F) ( block -- block )
81 dup S11 1 0 [ F ] ABCD
82 dup S12 2 1 [ F ] DABC
83 dup S13 3 2 [ F ] CDAB
84 dup S14 4 3 [ F ] BCDA
85 dup S11 5 4 [ F ] ABCD
86 dup S12 6 5 [ F ] DABC
87 dup S13 7 6 [ F ] CDAB
88 dup S14 8 7 [ F ] BCDA
89 dup S11 9 8 [ F ] ABCD
90 dup S12 10 9 [ F ] DABC
91 dup S13 11 10 [ F ] CDAB
92 dup S14 12 11 [ F ] BCDA
93 dup S11 13 12 [ F ] ABCD
94 dup S12 14 13 [ F ] DABC
95 dup S13 15 14 [ F ] CDAB
96 dup S14 16 15 [ F ] BCDA ;
98 : (process-md5-block-G) ( block -- block )
99 dup S21 17 1 [ G ] ABCD
100 dup S22 18 6 [ G ] DABC
101 dup S23 19 11 [ G ] CDAB
102 dup S24 20 0 [ G ] BCDA
103 dup S21 21 5 [ G ] ABCD
104 dup S22 22 10 [ G ] DABC
105 dup S23 23 15 [ G ] CDAB
106 dup S24 24 4 [ G ] BCDA
107 dup S21 25 9 [ G ] ABCD
108 dup S22 26 14 [ G ] DABC
109 dup S23 27 3 [ G ] CDAB
110 dup S24 28 8 [ G ] BCDA
111 dup S21 29 13 [ G ] ABCD
112 dup S22 30 2 [ G ] DABC
113 dup S23 31 7 [ G ] CDAB
114 dup S24 32 12 [ G ] BCDA ;
116 : (process-md5-block-H) ( block -- block )
117 dup S31 33 5 [ H ] ABCD
118 dup S32 34 8 [ H ] DABC
119 dup S33 35 11 [ H ] CDAB
120 dup S34 36 14 [ H ] BCDA
121 dup S31 37 1 [ H ] ABCD
122 dup S32 38 4 [ H ] DABC
123 dup S33 39 7 [ H ] CDAB
124 dup S34 40 10 [ H ] BCDA
125 dup S31 41 13 [ H ] ABCD
126 dup S32 42 0 [ H ] DABC
127 dup S33 43 3 [ H ] CDAB
128 dup S34 44 6 [ H ] BCDA
129 dup S31 45 9 [ H ] ABCD
130 dup S32 46 12 [ H ] DABC
131 dup S33 47 15 [ H ] CDAB
132 dup S34 48 2 [ H ] BCDA ;
134 : (process-md5-block-I) ( block -- block )
135 dup S41 49 0 [ I ] ABCD
136 dup S42 50 7 [ I ] DABC
137 dup S43 51 14 [ I ] CDAB
138 dup S44 52 5 [ I ] BCDA
139 dup S41 53 12 [ I ] ABCD
140 dup S42 54 3 [ I ] DABC
141 dup S43 55 10 [ I ] CDAB
142 dup S44 56 1 [ I ] BCDA
143 dup S41 57 8 [ I ] ABCD
144 dup S42 58 15 [ I ] DABC
145 dup S43 59 6 [ I ] CDAB
146 dup S44 60 13 [ I ] BCDA
147 dup S41 61 4 [ I ] ABCD
148 dup S42 62 11 [ I ] DABC
149 dup S43 63 2 [ I ] CDAB
150 dup S44 64 9 [ I ] BCDA ;
152 : (process-md5-block) ( block -- )
153 4 <groups> [ le> ] map
155 (process-md5-block-F)
156 (process-md5-block-G)
157 (process-md5-block-H)
158 (process-md5-block-I)
164 : process-md5-block ( str -- )
165 dup length [ bytes-read [ + ] change ] keep 64 = [
168 f bytes-read get pad-last-block
169 [ (process-md5-block) ] each
173 64 read [ process-md5-block ] keep
174 length 64 = [ stream>md5 ] when ;
177 [ a b c d ] [ get 4 >le ] map concat >byte-array ;
183 INSTANCE: md5 stream-checksum
185 M: md5 checksum-stream ( stream -- byte-array )
186 drop [ initialize-md5 stream>md5 get-md5 ] with-input-stream ;