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