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) = | |
111 | let | |
112 | val buf = | |
113 | if len > Config.bufSize then | |
114 | C.alloc' C.S.uchar (Word.fromInt len) | |
115 | else | |
116 | readBuf | |
117 | ||
118 | fun cleanup () = | |
119 | if len > Config.bufSize then | |
120 | C.free' buf | |
121 | else | |
122 | () | |
123 | ||
124 | fun loop (buf', needed) = | |
125 | let | |
126 | val r = F_OpenSSL_SML_read.f' (bio, C.Ptr.inject' buf, Int32.fromInt len) | |
127 | in | |
128 | if r = 0 then | |
129 | (cleanup (); NONE) | |
130 | else if r < 0 then | |
131 | (cleanup (); | |
132 | ssl_err "BIO_read"; | |
133 | raise OpenSSL "BIO_read failed") | |
134 | else if r = needed then | |
135 | SOME (CharVector.tabulate (Int32.toInt needed, | |
a49a9bfb AC |
136 | fn i => chr (Compat.Char.toInt (C.Get.uchar' |
137 | (C.Ptr.sub' C.S.uchar (buf, i)))))) | |
36e42cb8 AC |
138 | else |
139 | loop (C.Ptr.|+! C.S.uchar (buf', Int32.toInt r), needed - r) | |
140 | end | |
141 | in | |
142 | loop (buf, Int32.fromInt len) | |
143 | before cleanup () | |
144 | end | |
145 | ||
146 | fun readChunk bio = | |
3b267643 AC |
147 | let |
148 | val r = F_OpenSSL_SML_read.f' (bio, C.Ptr.inject' readBuf, bufSize) | |
149 | in | |
150 | if r = 0 then | |
151 | NONE | |
152 | else if r < 0 then | |
36e42cb8 AC |
153 | (ssl_err "BIO_read"; |
154 | raise OpenSSL "BIO_read failed") | |
3b267643 AC |
155 | else |
156 | SOME (CharVector.tabulate (Int32.toInt r, | |
a49a9bfb AC |
157 | fn i => chr (Compat.Char.toInt (C.Get.uchar' |
158 | (C.Ptr.sub' C.S.uchar (readBuf, i)))))) | |
3b267643 AC |
159 | end |
160 | ||
36e42cb8 AC |
161 | fun readString bio = |
162 | case readInt bio of | |
163 | NONE => NONE | |
164 | | SOME len => readLen (bio, len) | |
165 | ||
166 | fun writeChar (bio, ch) = | |
3b267643 | 167 | let |
36e42cb8 | 168 | val _ = C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 0), |
a49a9bfb | 169 | Compat.Char.fromInt (ord ch)) |
3b267643 | 170 | |
36e42cb8 | 171 | fun trier () = |
3b267643 | 172 | let |
36e42cb8 | 173 | val r = F_OpenSSL_SML_write.f' (bio, C.Ptr.inject' readBuf, one) |
3b267643 | 174 | in |
36e42cb8 AC |
175 | if r = 0 then |
176 | trier () | |
177 | else if r < 0 then | |
178 | (ssl_err "BIO_write"; | |
179 | raise OpenSSL "BIO_write") | |
180 | else | |
181 | () | |
182 | end | |
183 | in | |
184 | trier () | |
185 | end | |
186 | ||
a49a9bfb AC |
187 | val wordToChar = Compat.Char.fromLargeWord o Word32.toLargeWord |
188 | ||
36e42cb8 AC |
189 | fun writeInt (bio, n) = |
190 | let | |
191 | val w = Word32.fromInt n | |
192 | ||
193 | val _ = (C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 0), | |
a49a9bfb | 194 | wordToChar (Word32.andb (w, mask1))); |
36e42cb8 | 195 | C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 1), |
a49a9bfb | 196 | wordToChar (Word32.andb (Word32.>> (w, eight), mask1))); |
36e42cb8 | 197 | C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 2), |
a49a9bfb | 198 | wordToChar (Word32.andb (Word32.>> (w, sixteen), mask1))); |
36e42cb8 | 199 | C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 3), |
a49a9bfb | 200 | wordToChar (Word32.andb (Word32.>> (w, twentyfour), mask1)))) |
36e42cb8 AC |
201 | |
202 | fun trier (buf, count) = | |
203 | let | |
204 | val r = F_OpenSSL_SML_write.f' (bio, C.Ptr.inject' buf, count) | |
205 | in | |
206 | if r < 0 then | |
207 | (ssl_err "BIO_write"; | |
208 | raise OpenSSL "BIO_write") | |
209 | else if r = count then | |
3b267643 | 210 | () |
3b267643 | 211 | else |
36e42cb8 | 212 | trier (C.Ptr.|+! C.S.uchar (buf, Int32.toInt r), count - r) |
3b267643 AC |
213 | end |
214 | in | |
36e42cb8 AC |
215 | trier (readBuf, 4) |
216 | end | |
217 | ||
218 | fun writeString' (bio, s) = | |
219 | let | |
220 | val buf = ZString.dupML' s | |
221 | in | |
222 | if F_OpenSSL_SML_puts.f' (bio, buf) <= 0 then | |
223 | (C.free' buf; | |
224 | ssl_err "BIO_puts"; | |
225 | raise OpenSSL "BIO_puts") | |
226 | else | |
227 | C.free' buf | |
3b267643 AC |
228 | end |
229 | ||
36e42cb8 AC |
230 | fun writeString (bio, s) = |
231 | (writeInt (bio, size s); | |
232 | writeString' (bio, s)) | |
233 | ||
d22c1f00 | 234 | fun context printErr (chain, key, root) = |
3b267643 AC |
235 | let |
236 | val context = F_OpenSSL_SML_CTX_new.f' (F_OpenSSL_SML_SSLv23_method.f' ()) | |
237 | in | |
238 | if C.Ptr.isNull' context then | |
d22c1f00 | 239 | (if printErr then ssl_err "Error creating SSL context" else (); |
3b267643 AC |
240 | raise OpenSSL "Can't create SSL context") |
241 | else if F_OpenSSL_SML_use_certificate_chain_file.f' (context, | |
242 | ZString.dupML' chain) | |
243 | = 0 then | |
d22c1f00 | 244 | (if printErr then ssl_err "Error using certificate chain" else (); |
3b267643 AC |
245 | F_OpenSSL_SML_CTX_free.f' context; |
246 | raise OpenSSL "Can't load certificate chain") | |
247 | else if F_OpenSSL_SML_use_PrivateKey_file.f' (context, | |
248 | ZString.dupML' key) | |
249 | = 0 then | |
d22c1f00 | 250 | (if printErr then ssl_err "Error using private key" else (); |
3b267643 AC |
251 | F_OpenSSL_SML_CTX_free.f' context; |
252 | raise OpenSSL "Can't load private key") | |
253 | else if F_OpenSSL_SML_load_verify_locations.f' (context, | |
254 | ZString.dupML' root, | |
255 | C.Ptr.null') = 0 then | |
d22c1f00 | 256 | (if printErr then ssl_err "Error loading trust store" else (); |
3b267643 AC |
257 | F_OpenSSL_SML_CTX_free.f' context; |
258 | raise OpenSSL "Can't load trust store") | |
259 | else | |
260 | context | |
261 | end | |
262 | ||
263 | fun connect (context, hostname) = | |
264 | let | |
265 | val bio = F_OpenSSL_SML_new_ssl_connect.f' context | |
266 | in | |
267 | if C.Ptr.isNull' bio then | |
268 | (ssl_err ("Error initializating connection to " ^ hostname); | |
269 | F_OpenSSL_SML_free_all.f' bio; | |
270 | raise OpenSSL "Can't initialize connection") | |
271 | else if F_OpenSSL_SML_set_conn_hostname.f' (bio, ZString.dupML' hostname) = 0 then | |
272 | (ssl_err ("Error setting hostname: " ^ hostname); | |
273 | F_OpenSSL_SML_free_all.f' bio; | |
274 | raise OpenSSL "Can't set hostname") | |
275 | else if F_OpenSSL_SML_do_connect.f' bio <= 0 then | |
276 | (ssl_err ("Error connecting to " ^ hostname); | |
277 | F_OpenSSL_SML_free_all.f' bio; | |
278 | raise OpenSSL "Can't connect") | |
279 | else | |
280 | bio | |
281 | end | |
282 | ||
283 | fun close bio = F_OpenSSL_SML_free_all.f' bio | |
284 | ||
60534712 AC |
285 | fun listen (context, port) = |
286 | let | |
287 | val port = ZString.dupML' (Int.toString port) | |
288 | val listener = F_OpenSSL_SML_new_accept.f' (context, port) | |
289 | in | |
290 | C.free' port; | |
291 | if C.Ptr.isNull' listener then | |
292 | (ssl_err "Null listener"; | |
293 | raise OpenSSL "Null listener") | |
294 | else if F_OpenSSL_SML_do_accept.f' listener <= 0 then | |
295 | (ssl_err "Error initializing listener"; | |
296 | close listener; | |
297 | raise OpenSSL "Can't initialize listener") | |
298 | else | |
299 | listener | |
300 | end | |
301 | ||
302 | val shutdown = close | |
303 | ||
304 | fun accept listener = | |
305 | if F_OpenSSL_SML_do_accept.f' listener <= 0 then | |
306 | NONE | |
307 | else | |
7a150fe2 AC |
308 | let |
309 | val bio = F_OpenSSL_SML_pop.f' listener | |
310 | in | |
311 | if C.Ptr.isNull' bio then | |
312 | (ssl_err "Null accepted"; | |
313 | raise OpenSSL "Null accepted") | |
314 | else if F_OpenSSL_SML_do_handshake.f' bio <= 0 then | |
315 | (ssl_err "Handshake failed"; | |
316 | raise OpenSSL "Handshake failed") | |
317 | else | |
318 | SOME bio | |
319 | end | |
3b267643 AC |
320 | |
321 | fun peerCN bio = | |
322 | let | |
323 | val ssl = F_OpenSSL_SML_get_ssl.f' bio | |
324 | val _ = if C.Ptr.isNull' ssl then | |
325 | raise OpenSSL "Null SSL" | |
326 | else | |
327 | () | |
328 | val subj = F_OpenSSL_SML_get_peer_name.f' ssl | |
329 | in | |
330 | if C.Ptr.isNull' subj then | |
331 | raise OpenSSL "Null CN result" | |
332 | else | |
333 | ZString.toML' subj | |
334 | end | |
335 | ||
336 | end |