Fix file paths for recursive rmdom
[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 print "\n"
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
62 val one = Int32.fromInt 1
63 val four = Int32.fromInt 4
64
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
81 SOME (chr (Compat.Char.toInt (C.Get.uchar'
82 (C.Ptr.sub' C.S.uchar (readBuf, 0)))))
83 end
84
85 val charToWord = Word32.fromLargeWord o Compat.Char.toLargeWord
86
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.+
99 (charToWord (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 0))),
100 Word32.+
101 (Word32.<< (charToWord (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 1))),
102 eight),
103 Word32.+
104 (Word32.<< (charToWord (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 2))),
105 sixteen),
106 Word32.<< (charToWord (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 3))),
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,
136 fn i => chr (Compat.Char.toInt (C.Get.uchar'
137 (C.Ptr.sub' C.S.uchar (buf, i))))))
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 =
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
153 (ssl_err "BIO_read";
154 raise OpenSSL "BIO_read failed")
155 else
156 SOME (CharVector.tabulate (Int32.toInt r,
157 fn i => chr (Compat.Char.toInt (C.Get.uchar'
158 (C.Ptr.sub' C.S.uchar (readBuf, i))))))
159 end
160
161 fun readString bio =
162 case readInt bio of
163 NONE => NONE
164 | SOME len => readLen (bio, len)
165
166 fun writeChar (bio, ch) =
167 let
168 val _ = C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 0),
169 Compat.Char.fromInt (ord ch))
170
171 fun trier () =
172 let
173 val r = F_OpenSSL_SML_write.f' (bio, C.Ptr.inject' readBuf, one)
174 in
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
187 val wordToChar = Compat.Char.fromLargeWord o Word32.toLargeWord
188
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),
194 wordToChar (Word32.andb (w, mask1)));
195 C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 1),
196 wordToChar (Word32.andb (Word32.>> (w, eight), mask1)));
197 C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 2),
198 wordToChar (Word32.andb (Word32.>> (w, sixteen), mask1)));
199 C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 3),
200 wordToChar (Word32.andb (Word32.>> (w, twentyfour), mask1))))
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
210 ()
211 else
212 trier (C.Ptr.|+! C.S.uchar (buf, Int32.toInt r), count - r)
213 end
214 in
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
228 end
229
230 fun writeString (bio, s) =
231 (writeInt (bio, size s);
232 writeString' (bio, s))
233
234 fun context (chain, key, root) =
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
239 (ssl_err "Error creating SSL context";
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
244 (ssl_err "Error using certificate chain";
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
250 (ssl_err "Error using private key";
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
256 (ssl_err "Error loading trust store";
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
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
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
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