1(* ========================================================================= *) 2(* MD5 cryptographic hashing in SML *) 3(* Copyright (C) 2001 Daniel Wang. All rights reserved. *) 4(* Derived from the RSA Data Security, Inc. MD5 Message-Digest Algorithm. *) 5(* ========================================================================= *) 6 7structure MD5 :> MD5 = 8struct 9 10structure W32 = Word32 11structure W8V = 12struct 13 open Word8Vector 14 fun extract (vec, s, l) = 15 let 16 val n = 17 case l of 18 NONE => length vec - s 19 | SOME i => i 20 in 21 tabulate (n, fn i => sub (vec, s + i)) 22 end 23 end 24 type word64 = {hi:W32.word,lo:W32.word} 25 type word128 = {A:W32.word, B:W32.word, C:W32.word, D:W32.word} 26 type md5state = {digest:word128, 27 mlen:word64, 28 buf:Word8Vector.vector} 29 30 31 32 val w64_zero = ({hi=0w0,lo=0w0}:word64) 33 fun mul8add ({hi,lo},n) = let 34 val mul8lo = W32.<< (W32.fromInt (n),0w3) 35 val mul8hi = W32.>> (W32.fromInt (n),0w29) 36 val lo = W32.+ (lo,mul8lo) 37 val cout = if W32.< (lo,mul8lo) then 0w1 else 0w0 38 val hi = W32.+ (mul8hi,W32.+ (hi,cout)) 39 in {hi=hi,lo=lo} 40 end 41 42 fun packLittle wrds = let 43 fun loop [] = [] 44 | loop (w::ws) = let 45 val b0 = Word8.fromLargeWord (W32.toLargeWord w) 46 val b1 = Word8.fromLargeWord (W32.toLargeWord (W32.>> (w,0w8))) 47 val b2 = Word8.fromLargeWord (W32.toLargeWord (W32.>> (w,0w16))) 48 val b3 = Word8.fromLargeWord (W32.toLargeWord (W32.>> (w,0w24))) 49 in b0::b1::b2::b3:: (loop ws) 50 end 51 in W8V.fromList (loop wrds) 52 end 53 54 val S11 = 0w7 55 val S12 = 0w12 56 val S13 = 0w17 57 val S14 = 0w22 58 val S21 = 0w5 59 val S22 = 0w9 60 val S23 = 0w14 61 val S24 = 0w20 62 val S31 = 0w4 63 val S32 = 0w11 64 val S33 = 0w16 65 val S34 = 0w23 66 val S41 = 0w6 67 val S42 = 0w10 68 val S43 = 0w15 69 val S44 = 0w21 70 71 fun PADDING i = W8V.tabulate (i,(fn 0 => 0wx80 | _ => 0wx0)) 72 73 fun F (x,y,z) = W32.orb (W32.andb (x,y), 74 W32.andb (W32.notb x,z)) 75 fun G (x,y,z) = W32.orb (W32.andb (x,z), 76 W32.andb (y,W32.notb z)) 77 fun H (x,y,z) = W32.xorb (x,W32.xorb (y,z)) 78 fun I (x,y,z) = W32.xorb (y,W32.orb (x,W32.notb z)) 79 fun ROTATE_LEFT (x,n) = 80 W32.orb (W32.<< (x,n), W32.>> (x,0w32 - n)) 81 82 fun XX f (a,b,c,d,x,s,ac) = let 83 val a = W32.+ (a,W32.+ (W32.+ (f (b,c,d),x),ac)) 84 val a = ROTATE_LEFT (a,s) 85 in W32.+ (a,b) 86 end 87 88 val FF = XX F 89 val GG = XX G 90 val HH = XX H 91 val II = XX I 92 93 val empty_buf = W8V.tabulate (0,(fn x => raise (Fail "buf"))) 94 val init = {digest= {A=0wx67452301, 95 B=0wxefcdab89, 96 C=0wx98badcfe, 97 D=0wx10325476}, 98 mlen=w64_zero, 99 buf=empty_buf} : md5state 100 101 fun update ({buf,digest,mlen}:md5state,input) = let 102 val inputLen = W8V.length input 103 val needBytes = 64 - W8V.length buf 104 fun loop (i,digest) = 105 if i + 63 < inputLen then 106 loop (i + 64,transform (digest,i,input)) 107 else (i,digest) 108 val (buf,(i,digest)) = 109 if inputLen >= needBytes then let 110 val buf = W8V.concat [buf,W8V.extract (input,0,SOME needBytes)] 111 val digest = transform (digest,0,buf) 112 in (empty_buf,loop (needBytes,digest)) 113 end 114 else (buf,(0,digest)) 115 val buf = W8V.concat [buf, W8V.extract (input,i,SOME (inputLen-i))] 116 val mlen = mul8add (mlen,inputLen) 117 in {buf=buf,digest=digest,mlen=mlen} 118 end 119 and final (state:md5state) = let 120 val {mlen= {lo,hi},buf,...} = state 121 val bits = packLittle [lo,hi] 122 val index = W8V.length buf 123 val padLen = if index < 56 then 56 - index else 120 - index 124 val state = update (state,PADDING padLen) 125 val {digest= {A,B,C,D},...} = update (state,bits) 126 in packLittle [A,B,C,D] 127 end 128 and transform ({A,B,C,D},i,buf) = let 129 val off = i div PackWord32Little.bytesPerElem 130 fun x (n) = Word32.fromLargeWord (PackWord32Little.subVec (buf,n + off)) 131 val (a,b,c,d) = (A,B,C,D) 132 (* fetch to avoid range checks *) 133 val x_00 = x (0) val x_01 = x (1) val x_02 = x (2) val x_03 = x (3) 134 val x_04 = x (4) val x_05 = x (5) val x_06 = x (6) val x_07 = x (7) 135 val x_08 = x (8) val x_09 = x (9) val x_10 = x (10) val x_11 = x (11) 136 val x_12 = x (12) val x_13 = x (13) val x_14 = x (14) val x_15 = x (15) 137 138 val a = FF (a, b, c, d, x_00, S11, 0wxd76aa478) (* 1 *) 139 val d = FF (d, a, b, c, x_01, S12, 0wxe8c7b756) (* 2 *) 140 val c = FF (c, d, a, b, x_02, S13, 0wx242070db) (* 3 *) 141 val b = FF (b, c, d, a, x_03, S14, 0wxc1bdceee) (* 4 *) 142 val a = FF (a, b, c, d, x_04, S11, 0wxf57c0faf) (* 5 *) 143 val d = FF (d, a, b, c, x_05, S12, 0wx4787c62a) (* 6 *) 144 val c = FF (c, d, a, b, x_06, S13, 0wxa8304613) (* 7 *) 145 val b = FF (b, c, d, a, x_07, S14, 0wxfd469501) (* 8 *) 146 val a = FF (a, b, c, d, x_08, S11, 0wx698098d8) (* 9 *) 147 val d = FF (d, a, b, c, x_09, S12, 0wx8b44f7af) (* 10 *) 148 val c = FF (c, d, a, b, x_10, S13, 0wxffff5bb1) (* 11 *) 149 val b = FF (b, c, d, a, x_11, S14, 0wx895cd7be) (* 12 *) 150 val a = FF (a, b, c, d, x_12, S11, 0wx6b901122) (* 13 *) 151 val d = FF (d, a, b, c, x_13, S12, 0wxfd987193) (* 14 *) 152 val c = FF (c, d, a, b, x_14, S13, 0wxa679438e) (* 15 *) 153 val b = FF (b, c, d, a, x_15, S14, 0wx49b40821) (* 16 *) 154 155 (* Round 2 *) 156 val a = GG (a, b, c, d, x_01, S21, 0wxf61e2562) (* 17 *) 157 val d = GG (d, a, b, c, x_06, S22, 0wxc040b340) (* 18 *) 158 val c = GG (c, d, a, b, x_11, S23, 0wx265e5a51) (* 19 *) 159 val b = GG (b, c, d, a, x_00, S24, 0wxe9b6c7aa) (* 20 *) 160 val a = GG (a, b, c, d, x_05, S21, 0wxd62f105d) (* 21 *) 161 val d = GG (d, a, b, c, x_10, S22, 0wx2441453) (* 22 *) 162 val c = GG (c, d, a, b, x_15, S23, 0wxd8a1e681) (* 23 *) 163 val b = GG (b, c, d, a, x_04, S24, 0wxe7d3fbc8) (* 24 *) 164 val a = GG (a, b, c, d, x_09, S21, 0wx21e1cde6) (* 25 *) 165 val d = GG (d, a, b, c, x_14, S22, 0wxc33707d6) (* 26 *) 166 val c = GG (c, d, a, b, x_03, S23, 0wxf4d50d87) (* 27 *) 167 val b = GG (b, c, d, a, x_08, S24, 0wx455a14ed) (* 28 *) 168 val a = GG (a, b, c, d, x_13, S21, 0wxa9e3e905) (* 29 *) 169 val d = GG (d, a, b, c, x_02, S22, 0wxfcefa3f8) (* 30 *) 170 val c = GG (c, d, a, b, x_07, S23, 0wx676f02d9) (* 31 *) 171 val b = GG (b, c, d, a, x_12, S24, 0wx8d2a4c8a) (* 32 *) 172 173 (* Round 3 *) 174 val a = HH (a, b, c, d, x_05, S31, 0wxfffa3942) (* 33 *) 175 val d = HH (d, a, b, c, x_08, S32, 0wx8771f681) (* 34 *) 176 val c = HH (c, d, a, b, x_11, S33, 0wx6d9d6122) (* 35 *) 177 val b = HH (b, c, d, a, x_14, S34, 0wxfde5380c) (* 36 *) 178 val a = HH (a, b, c, d, x_01, S31, 0wxa4beea44) (* 37 *) 179 val d = HH (d, a, b, c, x_04, S32, 0wx4bdecfa9) (* 38 *) 180 val c = HH (c, d, a, b, x_07, S33, 0wxf6bb4b60) (* 39 *) 181 val b = HH (b, c, d, a, x_10, S34, 0wxbebfbc70) (* 40 *) 182 val a = HH (a, b, c, d, x_13, S31, 0wx289b7ec6) (* 41 *) 183 val d = HH (d, a, b, c, x_00, S32, 0wxeaa127fa) (* 42 *) 184 val c = HH (c, d, a, b, x_03, S33, 0wxd4ef3085) (* 43 *) 185 val b = HH (b, c, d, a, x_06, S34, 0wx4881d05) (* 44 *) 186 val a = HH (a, b, c, d, x_09, S31, 0wxd9d4d039) (* 45 *) 187 val d = HH (d, a, b, c, x_12, S32, 0wxe6db99e5) (* 46 *) 188 val c = HH (c, d, a, b, x_15, S33, 0wx1fa27cf8) (* 47 *) 189 val b = HH (b, c, d, a, x_02, S34, 0wxc4ac5665) (* 48 *) 190 191 (* Round 4 *) 192 val a = II (a, b, c, d, x_00, S41, 0wxf4292244) (* 49 *) 193 val d = II (d, a, b, c, x_07, S42, 0wx432aff97) (* 50 *) 194 val c = II (c, d, a, b, x_14, S43, 0wxab9423a7) (* 51 *) 195 val b = II (b, c, d, a, x_05, S44, 0wxfc93a039) (* 52 *) 196 val a = II (a, b, c, d, x_12, S41, 0wx655b59c3) (* 53 *) 197 val d = II (d, a, b, c, x_03, S42, 0wx8f0ccc92) (* 54 *) 198 val c = II (c, d, a, b, x_10, S43, 0wxffeff47d) (* 55 *) 199 val b = II (b, c, d, a, x_01, S44, 0wx85845dd1) (* 56 *) 200 val a = II (a, b, c, d, x_08, S41, 0wx6fa87e4f) (* 57 *) 201 val d = II (d, a, b, c, x_15, S42, 0wxfe2ce6e0) (* 58 *) 202 val c = II (c, d, a, b, x_06, S43, 0wxa3014314) (* 59 *) 203 val b = II (b, c, d, a, x_13, S44, 0wx4e0811a1) (* 60 *) 204 val a = II (a, b, c, d, x_04, S41, 0wxf7537e82) (* 61 *) 205 val d = II (d, a, b, c, x_11, S42, 0wxbd3af235) (* 62 *) 206 val c = II (c, d, a, b, x_02, S43, 0wx2ad7d2bb) (* 63 *) 207 val b = II (b, c, d, a, x_09, S44, 0wxeb86d391) (* 64 *) 208 209 val A = Word32.+ (A,a) 210 val B = Word32.+ (B,b) 211 val C = Word32.+ (C,c) 212 val D = Word32.+ (D,d) 213 in {A=A,B=B,C=C,D=D} 214 end 215 216 val hxd = "0123456789abcdef" 217 fun toHexString v = let 218 fun byte2hex (b,acc) = 219 (String.sub (hxd,(Word8.toInt b) div 16)):: 220 (String.sub (hxd,(Word8.toInt b) mod 16))::acc 221 val digits = Word8Vector.foldr byte2hex [] v 222 in String.implode digits 223 end 224 225 val b64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"; 226 fun b64i n = String.sub (b64, Word8.toInt n); 227 datatype bstate = B0 | B2 of Word8.word | B4 of Word8.word; 228 fun toBase64String v = 229 let 230 fun bytes2b64 (b,(B0,acc)) = 231 let 232 val bm = Word8.>> (b,0w2) 233 val bl = Word8.<< (Word8.andb (b,0wx03), 0w4) 234 in 235 (B2 bl, bm :: acc) 236 end 237 | bytes2b64 (b, (B2 x, acc)) = 238 let 239 val bm = Word8.orb (x, Word8.>> (b,0w4)) 240 val bl = Word8.<< (Word8.andb (b,0wx0f), 0w2) 241 in 242 (B4 bl, bm :: acc) 243 end 244 | bytes2b64 (b, (B4 x, acc)) = 245 let 246 val bm = Word8.orb (x, Word8.>> (b,0w6)) 247 val bl = Word8.andb (b,0wx3f) 248 in 249 (B0, bl :: bm :: acc) 250 end 251 fun final (B0, acc) = acc 252 | final (B2 x, acc) = x :: acc 253 | final (B4 x, acc) = x :: acc 254 val chrs = final (Word8Vector.foldl bytes2b64 (B0,[]) v) 255 in 256 String.implode (foldl (fn (h,t) => b64i h :: t) [] chrs) 257 end; 258 259end 260