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