2569e66d |
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' |
cbb8f260 |
31 | type listener = bio |
2569e66d |
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 | |
63 | fun readOne bio = |
64 | let |
65 | val r = F_OpenSSL_SML_read.f' (bio, C.Ptr.inject' readBuf, bufSize) |
66 | in |
67 | if r = 0 then |
68 | NONE |
69 | else if r < 0 then |
70 | raise OpenSSL "BIO_read failed" |
71 | else |
72 | SOME (CharVector.tabulate (Int32.toInt r, |
73 | fn i => chr (Word32.toInt (C.Get.uchar' |
74 | (C.Ptr.sub' C.S.uchar (readBuf, i)))))) |
75 | end |
76 | |
77 | fun writeAll (bio, s) = |
78 | let |
79 | val buf = ZString.dupML' s |
80 | |
81 | fun loop (buf, len) = |
82 | let |
83 | val r = F_OpenSSL_SML_write.f' (bio, C.Ptr.inject' buf, len) |
84 | in |
85 | if r = len then |
86 | () |
87 | else if r <= 0 then |
88 | (C.free' buf; |
89 | raise OpenSSL "BIO_write failed") |
90 | else |
91 | loop (C.Ptr.|+! C.S.uchar (buf, Int32.toInt r), Int32.- (len, r)) |
92 | end |
93 | in |
94 | loop (buf, Int32.fromInt (size s)); |
95 | C.free' buf |
96 | end |
97 | |
98 | fun context (chain, key, root) = |
99 | let |
100 | val context = F_OpenSSL_SML_CTX_new.f' (F_OpenSSL_SML_SSLv23_method.f' ()) |
101 | in |
102 | if C.Ptr.isNull' context then |
103 | (ssl_err "Error creating SSL context"; |
104 | raise OpenSSL "Can't create SSL context") |
105 | else if F_OpenSSL_SML_use_certificate_chain_file.f' (context, |
106 | ZString.dupML' chain) |
107 | = 0 then |
108 | (ssl_err "Error using certificate chain"; |
109 | F_OpenSSL_SML_CTX_free.f' context; |
110 | raise OpenSSL "Can't load certificate chain") |
111 | else if F_OpenSSL_SML_use_PrivateKey_file.f' (context, |
112 | ZString.dupML' key) |
113 | = 0 then |
114 | (ssl_err "Error using private key"; |
115 | F_OpenSSL_SML_CTX_free.f' context; |
116 | raise OpenSSL "Can't load private key") |
117 | else if F_OpenSSL_SML_load_verify_locations.f' (context, |
118 | ZString.dupML' root, |
119 | C.Ptr.null') = 0 then |
120 | (ssl_err "Error loading trust store"; |
121 | F_OpenSSL_SML_CTX_free.f' context; |
122 | raise OpenSSL "Can't load trust store") |
123 | else |
124 | context |
125 | end |
126 | |
127 | fun connect (context, hostname) = |
128 | let |
129 | val bio = F_OpenSSL_SML_new_ssl_connect.f' context |
130 | in |
131 | if C.Ptr.isNull' bio then |
132 | (ssl_err ("Error initializating connection to " ^ hostname); |
133 | F_OpenSSL_SML_free_all.f' bio; |
134 | raise OpenSSL "Can't initialize connection") |
135 | else if F_OpenSSL_SML_set_conn_hostname.f' (bio, ZString.dupML' hostname) = 0 then |
136 | (ssl_err ("Error setting hostname: " ^ hostname); |
137 | F_OpenSSL_SML_free_all.f' bio; |
138 | raise OpenSSL "Can't set hostname") |
139 | else if F_OpenSSL_SML_do_connect.f' bio <= 0 then |
140 | (ssl_err ("Error connecting to " ^ hostname); |
141 | F_OpenSSL_SML_free_all.f' bio; |
142 | raise OpenSSL "Can't connect") |
143 | else |
144 | bio |
145 | end |
146 | |
147 | fun close bio = F_OpenSSL_SML_free_all.f' bio |
148 | |
cbb8f260 |
149 | fun listen (context, port) = |
150 | let |
151 | val port = ZString.dupML' (Int.toString port) |
152 | val listener = F_OpenSSL_SML_new_accept.f' (context, port) |
153 | in |
154 | C.free' port; |
155 | if C.Ptr.isNull' listener then |
156 | (ssl_err "Null listener"; |
157 | raise OpenSSL "Null listener") |
158 | else if F_OpenSSL_SML_do_accept.f' listener <= 0 then |
159 | (ssl_err "Error initializing listener"; |
160 | close listener; |
161 | raise OpenSSL "Can't initialize listener") |
162 | else |
163 | listener |
164 | end |
165 | |
166 | val shutdown = close |
167 | |
168 | fun accept listener = |
169 | if F_OpenSSL_SML_do_accept.f' listener <= 0 then |
170 | NONE |
171 | else |
172 | SOME (F_OpenSSL_SML_pop.f' listener) |
2569e66d |
173 | |
174 | fun peerCN bio = |
175 | let |
176 | val ssl = F_OpenSSL_SML_get_ssl.f' bio |
177 | val _ = if C.Ptr.isNull' ssl then |
178 | raise OpenSSL "Null SSL" |
179 | else |
180 | () |
181 | val subj = F_OpenSSL_SML_get_peer_name.f' ssl |
182 | in |
183 | if C.Ptr.isNull' subj then |
184 | raise OpenSSL "Null CN result" |
185 | else |
186 | ZString.toML' subj |
187 | end |
188 | |
189 | end |