1 (* HCoop
Domtool (http
://hcoop
.sourceforge
.net
/)
2 * Copyright (c
) 2006, Adam Chlipala
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
.
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
.
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
.
21 structure OpenSSL
:> OPENSSL
= struct
23 val () = (F_OpenSSL_SML_init
.f
' ();
24 F_OpenSSL_SML_load_error_strings
.f
' ();
25 F_OpenSSL_SML_load_BIO_strings
.f
' ())
27 exception OpenSSL
of string
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
'
35 val err
= F_OpenSSL_SML_get_error
.f ()
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
43 if C
.Ptr
.isNull lib
then
46 (print (ZString
.toML lib
);
48 if C
.Ptr
.isNull func
then
51 (print (ZString
.toML func
);
53 if C
.Ptr
.isNull reason
then
56 print (ZString
.toML reason
);
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
65 val eight
= Word.fromInt
8
66 val sixteen
= Word.fromInt
16
67 val twentyfour
= Word.fromInt
24
69 val mask1
= Word32
.fromInt
255
73 val r
= F_OpenSSL_SML_read
.f
' (bio
, C
.Ptr
.inject
' readBuf
, one
)
79 raise OpenSSL
"BIO_read failed")
81 SOME (chr (Compat
.Char.toInt (C
.Get
.uchar
'
82 (C
.Ptr
.sub
' C
.S
.uchar (readBuf
, 0)))))
85 val charToWord
= Word32
.fromLargeWord
o Compat
.Char.toLargeWord
89 val r
= F_OpenSSL_SML_read
.f
' (bio
, C
.Ptr
.inject
' readBuf
, four
)
95 raise OpenSSL
"BIO_read failed")
99 (charToWord (C
.Get
.uchar
' (C
.Ptr
.sub
' C
.S
.uchar (readBuf
, 0))),
101 (Word32
.<< (charToWord (C
.Get
.uchar
' (C
.Ptr
.sub
' C
.S
.uchar (readBuf
, 1))),
104 (Word32
.<< (charToWord (C
.Get
.uchar
' (C
.Ptr
.sub
' C
.S
.uchar (readBuf
, 2))),
106 Word32
.<< (charToWord (C
.Get
.uchar
' (C
.Ptr
.sub
' C
.S
.uchar (readBuf
, 3))),
110 fun readLen (bio
, len
) =
116 if len
> Config
.bufSize
then
117 C
.alloc
' C
.S
.uchar (Word.fromInt len
)
122 if len
> Config
.bufSize
then
127 fun loop (buf
', needed
) =
129 val r
= F_OpenSSL_SML_read
.f
' (bio
, C
.Ptr
.inject
' buf
, Int32
.fromInt len
)
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
))))))
142 loop (C
.Ptr
.|
+! C
.S
.uchar (buf
', Int32
.toInt r
), needed
- r
)
145 loop (buf
, Int32
.fromInt len
)
151 val r
= F_OpenSSL_SML_read
.f
' (bio
, C
.Ptr
.inject
' readBuf
, bufSize
)
157 raise OpenSSL
"BIO_read failed")
159 SOME (CharVector
.tabulate (Int32
.toInt r
,
160 fn i
=> chr (Compat
.Char.toInt (C
.Get
.uchar
'
161 (C
.Ptr
.sub
' C
.S
.uchar (readBuf
, i
))))))
167 | SOME len
=> readLen (bio
, len
)
169 fun writeChar (bio
, ch
) =
171 val _
= C
.Set
.uchar
' (C
.Ptr
.sub
' C
.S
.uchar (readBuf
, 0),
172 Compat
.Char.fromInt (ord ch
))
176 val r
= F_OpenSSL_SML_write
.f
' (bio
, C
.Ptr
.inject
' readBuf
, one
)
181 (ssl_err
"BIO_write";
182 raise OpenSSL
"BIO_write")
190 val wordToChar
= Compat
.Char.fromLargeWord
o Word32
.toLargeWord
192 fun writeInt (bio
, n
) =
194 val w
= Word32
.fromInt n
196 val _
= (C
.Set
.uchar
' (C
.Ptr
.sub
' C
.S
.uchar (readBuf
, 0),
197 wordToChar (Word32
.andb (w
, mask1
)));
198 C
.Set
.uchar
' (C
.Ptr
.sub
' C
.S
.uchar (readBuf
, 1),
199 wordToChar (Word32
.andb (Word32
.>> (w
, eight
), mask1
)));
200 C
.Set
.uchar
' (C
.Ptr
.sub
' C
.S
.uchar (readBuf
, 2),
201 wordToChar (Word32
.andb (Word32
.>> (w
, sixteen
), mask1
)));
202 C
.Set
.uchar
' (C
.Ptr
.sub
' C
.S
.uchar (readBuf
, 3),
203 wordToChar (Word32
.andb (Word32
.>> (w
, twentyfour
), mask1
))))
205 fun trier (buf
, count
) =
207 val r
= F_OpenSSL_SML_write
.f
' (bio
, C
.Ptr
.inject
' buf
, count
)
210 (ssl_err
"BIO_write";
211 raise OpenSSL
"BIO_write")
212 else if r
= count
then
215 trier (C
.Ptr
.|
+! C
.S
.uchar (buf
, Int32
.toInt r
), count
- r
)
221 fun writeString
' (bio
, s
) =
226 val buf
= ZString
.dupML
' s
228 if F_OpenSSL_SML_puts
.f
' (bio
, buf
) <= 0 then
231 raise OpenSSL
"BIO_puts")
236 fun writeString (bio
, s
) =
237 (writeInt (bio
, size s
);
238 writeString
' (bio
, s
))
240 fun context
printErr (chain
, key
, root
) =
242 val context
= F_OpenSSL_SML_CTX_new
.f
' (F_OpenSSL_SML_SSLv23_method
.f
' ())
244 if C
.Ptr
.isNull
' context
then
245 (if printErr
then ssl_err
"Error creating SSL context" else ();
246 raise OpenSSL
"Can't create SSL context")
247 else if F_OpenSSL_SML_use_certificate_chain_file
.f
' (context
,
248 ZString
.dupML
' chain
)
250 (if printErr
then ssl_err
"Error using certificate chain" else ();
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
,
256 (if printErr
then ssl_err
"Error using private key" else ();
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
,
261 C
.Ptr
.null
') = 0 then
262 (if printErr
then ssl_err
"Error loading trust store" else ();
263 F_OpenSSL_SML_CTX_free
.f
' context
;
264 raise OpenSSL
"Can't load trust store")
269 fun connect (context
, hostname
) =
271 val bio
= F_OpenSSL_SML_new_ssl_connect
.f
' context
273 if C
.Ptr
.isNull
' bio
then
274 (ssl_err ("Error initializating connection to " ^ hostname
);
275 F_OpenSSL_SML_free_all
.f
' bio
;
276 raise OpenSSL
"Can't initialize connection")
277 else if F_OpenSSL_SML_set_conn_hostname
.f
' (bio
, ZString
.dupML
' hostname
) = 0 then
278 (ssl_err ("Error setting hostname: " ^ hostname
);
279 F_OpenSSL_SML_free_all
.f
' bio
;
280 raise OpenSSL
"Can't set hostname")
281 else if F_OpenSSL_SML_do_connect
.f
' bio
<= 0 then
282 (ssl_err ("Error connecting to " ^ hostname
);
283 F_OpenSSL_SML_free_all
.f
' bio
;
284 raise OpenSSL
"Can't connect")
289 fun close bio
= F_OpenSSL_SML_free_all
.f
' bio
291 fun listen (context
, port
) =
293 val port
= ZString
.dupML
' (Int.toString port
)
294 val listener
= F_OpenSSL_SML_new_accept
.f
' (context
, port
)
297 if C
.Ptr
.isNull
' listener
then
298 (ssl_err
"Null listener";
299 raise OpenSSL
"Null listener")
300 else if F_OpenSSL_SML_do_accept
.f
' listener
<= 0 then
301 (ssl_err
"Error initializing listener";
303 raise OpenSSL
"Can't initialize listener")
310 fun accept listener
=
311 if F_OpenSSL_SML_do_accept
.f
' listener
<= 0 then
315 val bio
= F_OpenSSL_SML_pop
.f
' listener
317 if C
.Ptr
.isNull
' bio
then
318 (ssl_err
"Null accepted";
319 raise OpenSSL
"Null accepted")
320 else if F_OpenSSL_SML_do_handshake
.f
' bio
<= 0 then
321 (ssl_err
"Handshake failed";
322 raise OpenSSL
"Handshake failed")
329 val ssl
= F_OpenSSL_SML_get_ssl
.f
' bio
330 val _
= if C
.Ptr
.isNull
' ssl
then
331 raise OpenSSL
"Null SSL"
334 val subj
= F_OpenSSL_SML_get_peer_name
.f
' ssl
336 if C
.Ptr
.isNull
' subj
then
337 raise OpenSSL
"Null CN result"