Less noisy pinging and shutting down
[hcoop/domtool2.git] / src / openssl.sml
CommitLineData
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
21structure OpenSSL :> OPENSSL = struct
22
23val () = (F_OpenSSL_SML_init.f' ();
24 F_OpenSSL_SML_load_error_strings.f' ();
25 F_OpenSSL_SML_load_BIO_strings.f' ())
26
27exception OpenSSL of string
28
29type context = (ST_ssl_ctx_st.tag, C_Int.rw) C_Int.su_obj C_Int.ptr'
30type bio = (ST_bio_st.tag, C_Int.rw) C_Int.su_obj C_Int.ptr'
60534712 31type listener = bio
3b267643
AC
32
33fun 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
60val readBuf : (C.uchar, C.rw) C.obj C.ptr' = C.alloc' C.S.uchar (Word.fromInt Config.bufSize)
61val bufSize = Int32.fromInt Config.bufSize
36e42cb8
AC
62val one = Int32.fromInt 1
63val four = Int32.fromInt 4
3b267643 64
36e42cb8
AC
65val eight = Word.fromInt 8
66val sixteen = Word.fromInt 16
67val twentyfour = Word.fromInt 24
68
69val mask1 = Word32.fromInt 255
70
71fun 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
85val charToWord = Word32.fromLargeWord o Compat.Char.toLargeWord
86
36e42cb8
AC
87fun 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
110fun 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
149fun 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
164fun readString bio =
165 case readInt bio of
166 NONE => NONE
167 | SOME len => readLen (bio, len)
168
169fun 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
190val wordToChar = Compat.Char.fromLargeWord o Word32.toLargeWord
191
36e42cb8
AC
192fun 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
221fun 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
236fun writeString (bio, s) =
237 (writeInt (bio, size s);
238 writeString' (bio, s))
239
d22c1f00 240fun 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 269fun 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
295fun close bio = F_OpenSSL_SML_free_all.f' bio
296
60534712
AC
297fun 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
314val shutdown = close
315
316fun 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
333fun 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
348end