Some OpenSSL frobbing
[hcoop/domtool2.git] / src / openssl.sml
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'
31 type listener = bio
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 ":");
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 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
61 val one = Int32.fromInt 1
62 val four = Int32.fromInt 4
63
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
80 SOME (chr (Compat.Char.toInt (C.Get.uchar'
81 (C.Ptr.sub' C.S.uchar (readBuf, 0)))))
82 end
83
84 val charToWord = Word32.fromLargeWord o Compat.Char.toLargeWord
85
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.+
98 (charToWord (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 0))),
99 Word32.+
100 (Word32.<< (charToWord (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 1))),
101 eight),
102 Word32.+
103 (Word32.<< (charToWord (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 2))),
104 sixteen),
105 Word32.<< (charToWord (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 3))),
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,
135 fn i => chr (Compat.Char.toInt (C.Get.uchar'
136 (C.Ptr.sub' C.S.uchar (buf, i))))))
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 =
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
152 (ssl_err "BIO_read";
153 raise OpenSSL "BIO_read failed")
154 else
155 SOME (CharVector.tabulate (Int32.toInt r,
156 fn i => chr (Compat.Char.toInt (C.Get.uchar'
157 (C.Ptr.sub' C.S.uchar (readBuf, i))))))
158 end
159
160 fun readString bio =
161 case readInt bio of
162 NONE => NONE
163 | SOME len => readLen (bio, len)
164
165 fun writeChar (bio, ch) =
166 let
167 val _ = C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 0),
168 Compat.Char.fromInt (ord ch))
169
170 fun trier () =
171 let
172 val r = F_OpenSSL_SML_write.f' (bio, C.Ptr.inject' readBuf, one)
173 in
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
186 val wordToChar = Compat.Char.fromLargeWord o Word32.toLargeWord
187
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),
193 wordToChar (Word32.andb (w, mask1)));
194 C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 1),
195 wordToChar (Word32.andb (Word32.>> (w, eight), mask1)));
196 C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 2),
197 wordToChar (Word32.andb (Word32.>> (w, sixteen), mask1)));
198 C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 3),
199 wordToChar (Word32.andb (Word32.>> (w, twentyfour), mask1))))
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
209 ()
210 else
211 trier (C.Ptr.|+! C.S.uchar (buf, Int32.toInt r), count - r)
212 end
213 in
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
227 end
228
229 fun writeString (bio, s) =
230 (writeInt (bio, size s);
231 writeString' (bio, s))
232
233 fun context printErr (chain, key, root) =
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
238 (if printErr then ssl_err "Error creating SSL context" else ();
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
243 (if printErr then ssl_err "Error using certificate chain" else ();
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
249 (if printErr then ssl_err "Error using private key" else ();
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
255 (if printErr then ssl_err "Error loading trust store" else ();
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
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
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
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