Commit | Line | Data |
---|---|---|
3b267643 AC |
1 | (* HCoop Domtool (http://hcoop.sourceforge.net/) |
2 | * Copyright (c) 2006, Adam Chlipala | |
3 | * | |
4 | * This program is free software; you can redistribute it and/or | |
5 | * modify it under the terms of the GNU General Public License | |
6 | * as published by the Free Software Foundation; either version 2 | |
7 | * of the License, or (at your option) any later version. | |
8 | * | |
9 | * This program is distributed in the hope that it will be useful, | |
10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of | |
11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
12 | * GNU General Public License for more details. | |
13 | * | |
14 | * You should have received a copy of the GNU General Public License | |
15 | * along with this program; if not, write to the Free Software | |
16 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. | |
17 | *) | |
18 | ||
19 | (* OpenSSL *) | |
20 | ||
21 | structure OpenSSL :> OPENSSL = struct | |
22 | ||
23 | val () = (F_OpenSSL_SML_init.f' (); | |
24 | F_OpenSSL_SML_load_error_strings.f' (); | |
25 | F_OpenSSL_SML_load_BIO_strings.f' ()) | |
26 | ||
27 | exception OpenSSL of string | |
28 | ||
29 | type context = (ST_ssl_ctx_st.tag, C_Int.rw) C_Int.su_obj C_Int.ptr' | |
30 | type bio = (ST_bio_st.tag, C_Int.rw) C_Int.su_obj C_Int.ptr' | |
60534712 | 31 | type listener = bio |
3b267643 AC |
32 | |
33 | fun ssl_err s = | |
34 | let | |
35 | val err = F_OpenSSL_SML_get_error.f () | |
36 | ||
37 | val lib = F_OpenSSL_SML_lib_error_string.f err | |
38 | val func = F_OpenSSL_SML_func_error_string.f err | |
39 | val reason = F_OpenSSL_SML_reason_error_string.f err | |
40 | in | |
41 | print s; | |
42 | print "\nReason: "; | |
43 | if C.Ptr.isNull lib then | |
44 | () | |
45 | else | |
46 | (print (ZString.toML lib); | |
47 | print ":"); | |
64a44dc0 AC |
48 | if C.Ptr.isNull func then |
49 | () | |
50 | else | |
51 | (print (ZString.toML func); | |
52 | print ":"); | |
53 | if C.Ptr.isNull reason then | |
54 | () | |
55 | else | |
16465a9a AC |
56 | print (ZString.toML reason); |
57 | print "\n" | |
3b267643 AC |
58 | end |
59 | ||
60 | val readBuf : (C.uchar, C.rw) C.obj C.ptr' = C.alloc' C.S.uchar (Word.fromInt Config.bufSize) | |
61 | val bufSize = Int32.fromInt Config.bufSize | |
36e42cb8 AC |
62 | val one = Int32.fromInt 1 |
63 | val four = Int32.fromInt 4 | |
3b267643 | 64 | |
36e42cb8 AC |
65 | val eight = Word.fromInt 8 |
66 | val sixteen = Word.fromInt 16 | |
67 | val twentyfour = Word.fromInt 24 | |
68 | ||
69 | val mask1 = Word32.fromInt 255 | |
70 | ||
71 | fun readChar bio = | |
72 | let | |
73 | val r = F_OpenSSL_SML_read.f' (bio, C.Ptr.inject' readBuf, one) | |
74 | in | |
75 | if r = 0 then | |
76 | NONE | |
77 | else if r < 0 then | |
78 | (ssl_err "BIO_read"; | |
79 | raise OpenSSL "BIO_read failed") | |
80 | else | |
a49a9bfb AC |
81 | SOME (chr (Compat.Char.toInt (C.Get.uchar' |
82 | (C.Ptr.sub' C.S.uchar (readBuf, 0))))) | |
36e42cb8 AC |
83 | end |
84 | ||
a49a9bfb AC |
85 | val charToWord = Word32.fromLargeWord o Compat.Char.toLargeWord |
86 | ||
36e42cb8 AC |
87 | fun readInt bio = |
88 | let | |
89 | val r = F_OpenSSL_SML_read.f' (bio, C.Ptr.inject' readBuf, four) | |
90 | in | |
91 | if r = 0 then | |
92 | NONE | |
93 | else if r < 0 then | |
94 | (ssl_err "BIO_read"; | |
95 | raise OpenSSL "BIO_read failed") | |
96 | else | |
97 | SOME (Word32.toInt | |
98 | (Word32.+ | |
a49a9bfb | 99 | (charToWord (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 0))), |
36e42cb8 | 100 | Word32.+ |
a49a9bfb | 101 | (Word32.<< (charToWord (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 1))), |
36e42cb8 AC |
102 | eight), |
103 | Word32.+ | |
a49a9bfb | 104 | (Word32.<< (charToWord (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 2))), |
36e42cb8 | 105 | sixteen), |
a49a9bfb | 106 | Word32.<< (charToWord (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 3))), |
36e42cb8 AC |
107 | twentyfour)))))) |
108 | end | |
109 | ||
110 | fun readLen (bio, len) = | |
314ce7bd AC |
111 | if len = 0 then |
112 | SOME "" | |
113 | else | |
114 | let | |
115 | val buf = | |
116 | if len > Config.bufSize then | |
117 | C.alloc' C.S.uchar (Word.fromInt len) | |
118 | else | |
119 | readBuf | |
36e42cb8 | 120 | |
314ce7bd AC |
121 | fun cleanup () = |
122 | if len > Config.bufSize then | |
123 | C.free' buf | |
36e42cb8 | 124 | else |
314ce7bd AC |
125 | () |
126 | ||
127 | fun loop (buf', needed) = | |
128 | let | |
129 | val r = F_OpenSSL_SML_read.f' (bio, C.Ptr.inject' buf, Int32.fromInt len) | |
130 | in | |
131 | if r = 0 then | |
132 | (cleanup (); NONE) | |
133 | else if r < 0 then | |
134 | (cleanup (); | |
135 | ssl_err "BIO_read"; | |
136 | raise OpenSSL "BIO_read failed") | |
137 | else if r = needed then | |
138 | SOME (CharVector.tabulate (Int32.toInt needed, | |
139 | fn i => chr (Compat.Char.toInt (C.Get.uchar' | |
140 | (C.Ptr.sub' C.S.uchar (buf, i)))))) | |
141 | else | |
142 | loop (C.Ptr.|+! C.S.uchar (buf', Int32.toInt r), needed - r) | |
143 | end | |
144 | in | |
145 | loop (buf, Int32.fromInt len) | |
146 | before cleanup () | |
147 | end | |
36e42cb8 AC |
148 | |
149 | fun readChunk bio = | |
3b267643 AC |
150 | let |
151 | val r = F_OpenSSL_SML_read.f' (bio, C.Ptr.inject' readBuf, bufSize) | |
152 | in | |
153 | if r = 0 then | |
154 | NONE | |
155 | else if r < 0 then | |
36e42cb8 AC |
156 | (ssl_err "BIO_read"; |
157 | raise OpenSSL "BIO_read failed") | |
3b267643 AC |
158 | else |
159 | SOME (CharVector.tabulate (Int32.toInt r, | |
a49a9bfb AC |
160 | fn i => chr (Compat.Char.toInt (C.Get.uchar' |
161 | (C.Ptr.sub' C.S.uchar (readBuf, i)))))) | |
3b267643 AC |
162 | end |
163 | ||
36e42cb8 AC |
164 | fun readString bio = |
165 | case readInt bio of | |
166 | NONE => NONE | |
167 | | SOME len => readLen (bio, len) | |
168 | ||
169 | fun writeChar (bio, ch) = | |
3b267643 | 170 | let |
36e42cb8 | 171 | val _ = C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 0), |
a49a9bfb | 172 | Compat.Char.fromInt (ord ch)) |
3b267643 | 173 | |
36e42cb8 | 174 | fun trier () = |
3b267643 | 175 | let |
36e42cb8 | 176 | val r = F_OpenSSL_SML_write.f' (bio, C.Ptr.inject' readBuf, one) |
3b267643 | 177 | in |
36e42cb8 AC |
178 | if r = 0 then |
179 | trier () | |
180 | else if r < 0 then | |
181 | (ssl_err "BIO_write"; | |
182 | raise OpenSSL "BIO_write") | |
183 | else | |
184 | () | |
185 | end | |
186 | in | |
187 | trier () | |
188 | end | |
189 | ||
a49a9bfb AC |
190 | val wordToChar = Compat.Char.fromLargeWord o Word32.toLargeWord |
191 | ||
36e42cb8 AC |
192 | fun writeInt (bio, n) = |
193 | let | |
194 | val w = Word32.fromInt n | |
195 | ||
196 | val _ = (C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 0), | |
a49a9bfb | 197 | wordToChar (Word32.andb (w, mask1))); |
36e42cb8 | 198 | C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 1), |
a49a9bfb | 199 | wordToChar (Word32.andb (Word32.>> (w, eight), mask1))); |
36e42cb8 | 200 | C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 2), |
a49a9bfb | 201 | wordToChar (Word32.andb (Word32.>> (w, sixteen), mask1))); |
36e42cb8 | 202 | C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 3), |
a49a9bfb | 203 | wordToChar (Word32.andb (Word32.>> (w, twentyfour), mask1)))) |
36e42cb8 AC |
204 | |
205 | fun trier (buf, count) = | |
206 | let | |
207 | val r = F_OpenSSL_SML_write.f' (bio, C.Ptr.inject' buf, count) | |
208 | in | |
209 | if r < 0 then | |
210 | (ssl_err "BIO_write"; | |
211 | raise OpenSSL "BIO_write") | |
212 | else if r = count then | |
3b267643 | 213 | () |
3b267643 | 214 | else |
36e42cb8 | 215 | trier (C.Ptr.|+! C.S.uchar (buf, Int32.toInt r), count - r) |
3b267643 AC |
216 | end |
217 | in | |
36e42cb8 AC |
218 | trier (readBuf, 4) |
219 | end | |
220 | ||
221 | fun writeString' (bio, s) = | |
314ce7bd AC |
222 | if size s = 0 then |
223 | () | |
224 | else | |
225 | let | |
226 | val buf = ZString.dupML' s | |
227 | in | |
228 | if F_OpenSSL_SML_puts.f' (bio, buf) <= 0 then | |
229 | (C.free' buf; | |
230 | ssl_err "BIO_puts"; | |
231 | raise OpenSSL "BIO_puts") | |
232 | else | |
233 | C.free' buf | |
234 | end | |
3b267643 | 235 | |
36e42cb8 AC |
236 | fun writeString (bio, s) = |
237 | (writeInt (bio, size s); | |
238 | writeString' (bio, s)) | |
239 | ||
d22c1f00 | 240 | fun context printErr (chain, key, root) = |
3b267643 AC |
241 | let |
242 | val context = F_OpenSSL_SML_CTX_new.f' (F_OpenSSL_SML_SSLv23_method.f' ()) | |
243 | in | |
244 | if C.Ptr.isNull' context then | |
d22c1f00 | 245 | (if printErr then ssl_err "Error creating SSL context" else (); |
3b267643 AC |
246 | raise OpenSSL "Can't create SSL context") |
247 | else if F_OpenSSL_SML_use_certificate_chain_file.f' (context, | |
248 | ZString.dupML' chain) | |
249 | = 0 then | |
d22c1f00 | 250 | (if printErr then ssl_err "Error using certificate chain" else (); |
3b267643 AC |
251 | F_OpenSSL_SML_CTX_free.f' context; |
252 | raise OpenSSL "Can't load certificate chain") | |
253 | else if F_OpenSSL_SML_use_PrivateKey_file.f' (context, | |
254 | ZString.dupML' key) | |
255 | = 0 then | |
d22c1f00 | 256 | (if printErr then ssl_err "Error using private key" else (); |
3b267643 AC |
257 | F_OpenSSL_SML_CTX_free.f' context; |
258 | raise OpenSSL "Can't load private key") | |
259 | else if F_OpenSSL_SML_load_verify_locations.f' (context, | |
260 | ZString.dupML' root, | |
261 | C.Ptr.null') = 0 then | |
d22c1f00 | 262 | (if printErr then ssl_err "Error loading trust store" else (); |
3b267643 AC |
263 | F_OpenSSL_SML_CTX_free.f' context; |
264 | raise OpenSSL "Can't load trust store") | |
265 | else | |
266 | context | |
267 | end | |
268 | ||
8be753d9 | 269 | fun connect printErr (context, hostname) = |
3b267643 AC |
270 | let |
271 | val bio = F_OpenSSL_SML_new_ssl_connect.f' context | |
8be753d9 AC |
272 | |
273 | val ssl_err = | |
274 | if printErr then | |
275 | ssl_err | |
276 | else | |
277 | (fn _ => ()) | |
3b267643 AC |
278 | in |
279 | if C.Ptr.isNull' bio then | |
280 | (ssl_err ("Error initializating connection to " ^ hostname); | |
281 | F_OpenSSL_SML_free_all.f' bio; | |
282 | raise OpenSSL "Can't initialize connection") | |
283 | else if F_OpenSSL_SML_set_conn_hostname.f' (bio, ZString.dupML' hostname) = 0 then | |
284 | (ssl_err ("Error setting hostname: " ^ hostname); | |
285 | F_OpenSSL_SML_free_all.f' bio; | |
286 | raise OpenSSL "Can't set hostname") | |
287 | else if F_OpenSSL_SML_do_connect.f' bio <= 0 then | |
288 | (ssl_err ("Error connecting to " ^ hostname); | |
289 | F_OpenSSL_SML_free_all.f' bio; | |
290 | raise OpenSSL "Can't connect") | |
291 | else | |
292 | bio | |
293 | end | |
294 | ||
295 | fun close bio = F_OpenSSL_SML_free_all.f' bio | |
296 | ||
60534712 AC |
297 | fun listen (context, port) = |
298 | let | |
299 | val port = ZString.dupML' (Int.toString port) | |
300 | val listener = F_OpenSSL_SML_new_accept.f' (context, port) | |
301 | in | |
302 | C.free' port; | |
303 | if C.Ptr.isNull' listener then | |
304 | (ssl_err "Null listener"; | |
305 | raise OpenSSL "Null listener") | |
306 | else if F_OpenSSL_SML_do_accept.f' listener <= 0 then | |
307 | (ssl_err "Error initializing listener"; | |
308 | close listener; | |
309 | raise OpenSSL "Can't initialize listener") | |
310 | else | |
311 | listener | |
312 | end | |
313 | ||
314 | val shutdown = close | |
315 | ||
316 | fun accept listener = | |
317 | if F_OpenSSL_SML_do_accept.f' listener <= 0 then | |
318 | NONE | |
319 | else | |
7a150fe2 AC |
320 | let |
321 | val bio = F_OpenSSL_SML_pop.f' listener | |
322 | in | |
323 | if C.Ptr.isNull' bio then | |
324 | (ssl_err "Null accepted"; | |
325 | raise OpenSSL "Null accepted") | |
326 | else if F_OpenSSL_SML_do_handshake.f' bio <= 0 then | |
327 | (ssl_err "Handshake failed"; | |
328 | raise OpenSSL "Handshake failed") | |
329 | else | |
330 | SOME bio | |
331 | end | |
3b267643 AC |
332 | |
333 | fun peerCN bio = | |
334 | let | |
335 | val ssl = F_OpenSSL_SML_get_ssl.f' bio | |
336 | val _ = if C.Ptr.isNull' ssl then | |
337 | raise OpenSSL "Null SSL" | |
338 | else | |
339 | () | |
340 | val subj = F_OpenSSL_SML_get_peer_name.f' ssl | |
341 | in | |
342 | if C.Ptr.isNull' subj then | |
343 | raise OpenSSL "Null CN result" | |
344 | else | |
345 | ZString.toML' subj | |
346 | end | |
347 | ||
348 | end |