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