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
'
31 type listener
= MLRep
.Signed
.int
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
65 val r
= F_OpenSSL_SML_read
.f
' (bio
, C
.Ptr
.inject
' readBuf
, bufSize
)
70 raise OpenSSL
"BIO_read failed"
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
))))))
77 fun writeAll (bio
, s
) =
79 val buf
= ZString
.dupML
' s
83 val r
= F_OpenSSL_SML_write
.f
' (bio
, C
.Ptr
.inject
' buf
, len
)
89 raise OpenSSL
"BIO_write failed")
91 loop (C
.Ptr
.|
+! C
.S
.uchar (buf
, Int32
.toInt r
), Int32
.- (len
, r
))
94 loop (buf
, Int32
.fromInt (size s
));
98 fun context (chain
, key
, root
) =
100 val context
= F_OpenSSL_SML_CTX_new
.f
' (F_OpenSSL_SML_SSLv23_method
.f
' ())
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
)
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
,
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
,
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")
127 fun connect (context
, hostname
) =
129 val bio
= F_OpenSSL_SML_new_ssl_connect
.f
' context
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")
147 fun close bio
= F_OpenSSL_SML_free_all
.f
' bio
149 fun listen (port
, qsize
) = F_OpenSSL_SML_tcp_listen
.f
' (Int32
.fromInt port
, Int32
.fromInt qsize
)
150 fun shutdown sock
= F_OpenSSL_SML_shutdown
.f
' sock
152 fun accept (context
, sock
) =
154 val sock
' = F_OpenSSL_SML_accept
.f
' sock
156 if Int32
.< (sock
', Int32
.fromInt
0) then
159 val bio
= F_OpenSSL_SML_new_socket
.f
' sock
'
160 val ssl
= F_OpenSSL_SML_SSL_new
.f
' context
162 if C
.Ptr
.isNull
' bio
then
163 (ssl_err
"Error initializating accepter";
164 F_OpenSSL_SML_free_all
.f
' bio
;
165 raise OpenSSL
"Can't initialize accepter")
166 else if (F_OpenSSL_SML_SSL_set_bio
.f
' (ssl
, bio
, bio
);
167 F_OpenSSL_SML_SSL_accept
.f
' ssl
) <= 0 then
168 (ssl_err
"Error accepting connection";
169 F_OpenSSL_SML_free_all
.f
' bio
;
170 raise OpenSSL
"Can't accept connection")
178 val ssl
= F_OpenSSL_SML_get_ssl
.f
' bio
179 val _
= if C
.Ptr
.isNull
' ssl
then
180 raise OpenSSL
"Null SSL"
183 val subj
= F_OpenSSL_SML_get_peer_name
.f
' ssl
185 if C
.Ptr
.isNull
' subj
then
186 raise OpenSSL
"Null CN result"