From 3b2676435dc4af39acd77e7fe232902e6651e42d Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 3 Sep 2006 02:03:55 +0000 Subject: [PATCH] Basic SSL connection going --- configDefault/domtool.cfg | 5 + configDefault/domtool.cfs | 4 + openssl/openssl_sml.c | 158 ++++++++++++++++++++++++++++++- openssl/openssl_sml.h | 31 ++++++- src/domtool.cm | 3 + src/main.sig | 2 +- src/main.sml | 153 +++++++++++++----------------- src/openssl.sig | 46 +++++++++ src/openssl.sml | 191 ++++++++++++++++++++++++++++++++++++++ 9 files changed, 498 insertions(+), 95 deletions(-) create mode 100644 src/openssl.sig create mode 100644 src/openssl.sml diff --git a/configDefault/domtool.cfg b/configDefault/domtool.cfg index 55e6afd..35296fd 100644 --- a/configDefault/domtool.cfg +++ b/configDefault/domtool.cfg @@ -25,5 +25,10 @@ val defaultDomain = "hcoop.net" val dispatcher = "localhost" val dispatcherPort = 1234 +val queueSize = 5 val bufSize = 1024 + +val trustStore = "/home/adamc/fake/TrustKey.pem" +val serverCert = "/home/adamc/fake/servercert.pem" +val serverKey = "/home/adamc/fake/serverkey.pem" diff --git a/configDefault/domtool.cfs b/configDefault/domtool.cfs index 43f9f06..109f09f 100644 --- a/configDefault/domtool.cfs +++ b/configDefault/domtool.cfs @@ -34,6 +34,10 @@ val defaultDomain : string val dispatcher : string val dispatcherPort : int +val queueSize : int val bufSize : int +val trustStore : string +val serverCert : string +val serverKey : string diff --git a/openssl/openssl_sml.c b/openssl/openssl_sml.c index b2fbb89..201d816 100644 --- a/openssl/openssl_sml.c +++ b/openssl/openssl_sml.c @@ -2,12 +2,18 @@ #include "openssl/ssl.h" #include "openssl/err.h" -void OpenSSL_SML_add_all_algorithms() { - OpenSSL_add_all_algorithms(); +#include +#include +#include +#include + +void OpenSSL_SML_init() { + SSL_library_init(); } void OpenSSL_SML_load_error_strings() { SSL_load_error_strings(); + ERR_load_X509_strings(); } void OpenSSL_SML_load_BIO_strings() { @@ -57,3 +63,151 @@ int OpenSSL_SML_do_connect(BIO *b) { int OpenSSL_SML_do_accept(BIO *b) { return BIO_do_accept(b); } + +SSL_CTX *OpenSSL_SML_CTX_new(SSL_METHOD *meth) { + SSL_CTX *ctx = SSL_CTX_new(meth); + SSL_CTX_set_verify(ctx, + SSL_VERIFY_PEER | SSL_VERIFY_FAIL_IF_NO_PEER_CERT, + 0); + return ctx; +} + +void OpenSSL_SML_CTX_free(SSL_CTX *ctx) { + return SSL_CTX_free(ctx); +} + +SSL_METHOD *OpenSSL_SML_SSLv23_method() { + return SSLv23_method(); +} + +int OpenSSL_SML_load_verify_locations(SSL_CTX *ctx, const char *trust, const char *certs) { + return SSL_CTX_load_verify_locations(ctx, trust, certs); +} + +BIO *OpenSSL_SML_new_ssl_connect(SSL_CTX *ctx) { + BIO *bio = BIO_new_ssl_connect(ctx); + SSL *ssl; + + BIO_get_ssl(bio, &ssl); + SSL_set_mode(ssl, SSL_MODE_AUTO_RETRY); + + return bio; +} + + +SSL *OpenSSL_SML_get_ssl(BIO *bio) { + SSL *ssl; + + if (BIO_get_ssl(bio, &ssl) <= 0) + return NULL; + else + return ssl; +} + +int OpenSSL_SML_set_conn_hostname(BIO *bio, char *hostname) { + BIO_set_conn_hostname(bio, hostname); +} + +int OpenSSL_SML_set_accept_port(BIO *bio, char *port) { + BIO_set_accept_port(bio, port); +} + +int OpenSSL_SML_tcp_listen(int port, int qsize) { + int sock; + struct sockaddr_in sin; + int val=1; + + if((sock=socket(AF_INET,SOCK_STREAM,0))<0) + return -1; + + memset(&sin,0,sizeof(sin)); + sin.sin_addr.s_addr=INADDR_ANY; + sin.sin_family=AF_INET; + sin.sin_port=htons(port); + setsockopt(sock,SOL_SOCKET,SO_REUSEADDR, + &val,sizeof(val)); + + if(bind(sock,(struct sockaddr *)&sin, + sizeof(sin))<0) + return -1; + listen(sock, qsize); + + return sock; +} + +int OpenSSL_SML_accept(int sock) { + return accept(sock, 0, 0); +} + +BIO *OpenSSL_SML_new_socket(int sock) { + return BIO_new_socket(sock, BIO_NOCLOSE); +} + +SSL *OpenSSL_SML_SSL_new(SSL_CTX *ctx) { + SSL *ssl = SSL_new(ctx); + + return ssl; +} + +int OpenSSL_SML_SSL_shutdown(SSL *ssl) { + return SSL_shutdown(ssl); +} + +void OpenSSL_SML_shutdown(int sock) { + shutdown(sock, 1); +} + +void OpenSSL_SML_SSL_set_bio(SSL *ssl, BIO *b1, BIO *b2) { + SSL_set_mode(ssl, SSL_MODE_AUTO_RETRY); + SSL_set_bio(ssl, b1, b2); +} + +int OpenSSL_SML_use_PrivateKey_file(SSL_CTX *ctx, char *keyfile) { + return SSL_CTX_use_PrivateKey_file(ctx, + keyfile, + SSL_FILETYPE_PEM); +} + +int OpenSSL_SML_SSL_accept(SSL *ssl) { + return SSL_accept(ssl); +} + +int OpenSSL_SML_use_certificate_chain_file(SSL_CTX *ctx, char *keyfile) { + return SSL_CTX_use_certificate_chain_file(ctx, + keyfile); +} + +static unsigned char subject[] = "Subject"; + +const char *OpenSSL_SML_get_peer_name(SSL *ssl) { + X509 *x = SSL_get_peer_certificate(ssl); + unsigned char *name = subject; + X509_NAME *nm; + + if (x) { + X509_NAME *name = X509_get_subject_name(x); + + if (name) { + unsigned char *out; + X509_NAME_ENTRY *ne; + + ne = X509_NAME_get_entry(name, 3); + + if (ne) { + ASN1_STRING *s = X509_NAME_ENTRY_get_data(ne); + static char ret[1024]; + + if (M_ASN1_STRING_length(s) >= sizeof ret) + return NULL; + else { + memcpy(ret, M_ASN1_STRING_data(s), M_ASN1_STRING_length(s)); + ret[M_ASN1_STRING_length(s)] = 0; + return ret; + } + } else + return NULL; + } else + return NULL; + } else + return NULL; +} diff --git a/openssl/openssl_sml.h b/openssl/openssl_sml.h index 5317021..3eced90 100644 --- a/openssl/openssl_sml.h +++ b/openssl/openssl_sml.h @@ -2,7 +2,7 @@ #include "openssl/ssl.h" #include "openssl/err.h" -void OpenSSL_SML_add_all_algorithms(void); +void OpenSSL_SML_init(void); void OpenSSL_SML_load_error_strings(void); void OpenSSL_SML_load_BIO_strings(void); @@ -22,3 +22,32 @@ int OpenSSL_SML_do_accept(BIO *b); void OpenSSL_SML_free_all(BIO *b); +SSL_METHOD *OpenSSL_SML_SSLv23_method(void); + +SSL_CTX *OpenSSL_SML_CTX_new(SSL_METHOD *meth); +void OpenSSL_SML_CTX_free(SSL_CTX *ctx); + +int OpenSSL_SML_load_verify_locations(SSL_CTX *ctx, const char *trust, const char *certs); + +BIO *OpenSSL_SML_new_ssl_connect(SSL_CTX *ctx); +SSL *OpenSSL_SML_get_ssl(BIO *bio); +int OpenSSL_SML_set_conn_hostname(BIO *bio, char *hostname); +int OpenSSL_SML_set_accept_port(BIO *bio, char *port); + +int OpenSSL_SML_tcp_listen(int port, int qsize); +int OpenSSL_SML_accept(int sock); +BIO *OpenSSL_SML_new_socket(int sock); + +SSL *OpenSSL_SML_SSL_new(SSL_CTX *ctx); + +int OpenSSL_SML_SSL_shutdown(SSL *ssl); +void OpenSSL_SML_shutdown(int sock); +void OpenSSL_SML_SSL_set_bio(SSL *ssl, BIO *b1, BIO *b2); + +int OpenSSL_SML_use_PrivateKey_file(SSL_CTX *ctx, char *keyfile); + +int OpenSSL_SML_SSL_accept(SSL *ssl); + +int OpenSSL_SML_use_certificate_chain_file(SSL_CTX *ctx, char *keyfile); + +const char *OpenSSL_SML_get_peer_name(SSL *ssl); diff --git a/src/domtool.cm b/src/domtool.cm index 48cafe7..ab147b7 100644 --- a/src/domtool.cm +++ b/src/domtool.cm @@ -74,5 +74,8 @@ plugins/mailman.sml order.sig order.sml +openssl.sig +openssl.sml + main.sig main.sml diff --git a/src/main.sig b/src/main.sig index 1d084b8..90c7cc9 100644 --- a/src/main.sig +++ b/src/main.sig @@ -32,6 +32,6 @@ signature MAIN = sig val eval : string -> unit val request : string -> unit - val serviceOne : unit -> unit + val service : unit -> unit end diff --git a/src/main.sml b/src/main.sml index bcadb63..cc5b5b5 100644 --- a/src/main.sml +++ b/src/main.sml @@ -26,12 +26,6 @@ structure SM = StringMap val dmy = ErrorMsg.dummyLoc -fun init () = (F_OpenSSL_SML_add_all_algorithms.f' (); - F_OpenSSL_SML_load_error_strings.f' (); - F_OpenSSL_SML_load_BIO_strings.f' ()) - -val () = init () - val defaultT : record ref = ref SM.empty val defaultV : (unit -> exp) SM.map ref = ref SM.empty @@ -139,111 +133,88 @@ fun eval fname = Eval.exec (SM.map (fn f => f ()) (!defaultV)) body' | NONE => () -val dispatcher : C.rw ZString.zstring' = - ZString.dupML' (Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort) - -val listenOn : C.rw ZString.zstring' = - ZString.dupML' ("localhost:" ^ Int.toString Config.dispatcherPort) +val dispatcher = + Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort fun ssl_err s = let val err = F_OpenSSL_SML_get_error.f () + + val lib = F_OpenSSL_SML_lib_error_string.f err + val func = F_OpenSSL_SML_func_error_string.f err + val reason = F_OpenSSL_SML_reason_error_string.f err in print s; print "\nReason: "; - print (ZString.toML (F_OpenSSL_SML_lib_error_string.f err)); - print ":"; - print (ZString.toML (F_OpenSSL_SML_func_error_string.f err)); - print ":"; - print (ZString.toML (F_OpenSSL_SML_reason_error_string.f err)); + if C.Ptr.isNull lib then + () + else + (print (ZString.toML lib); + print ":"); + if C.Ptr.isNull func then + () + else + (print (ZString.toML func); + print ":"); + if C.Ptr.isNull reason then + () + else + print (ZString.toML reason); print "\n" end -exception OpenSSL of string - -val readBuf : (C.uchar, C.rw) C.obj C.ptr' = C.alloc' C.S.uchar (Word.fromInt Config.bufSize) -val bufSize = Int32.fromInt Config.bufSize -fun readOne bio = +fun request fname = let - val r = F_OpenSSL_SML_read.f' (bio, C.Ptr.inject' readBuf, bufSize) - in - if r = 0 then - NONE - else if r < 0 then - raise OpenSSL "BIO_read failed" - else - SOME (CharVector.tabulate (Int32.toInt r, - fn i => chr (Word32.toInt (C.Get.uchar' - (C.Ptr.sub' C.S.uchar (readBuf, i)))))) - end + val context = OpenSSL.context ("/home/adamc/fake/clientcert.pem", + "/home/adamc/fake/clientkey.pem", + Config.trustStore) -fun writeAll (bio, s) = - let - val buf = ZString.dupML' s + val bio = OpenSSL.connect (context, dispatcher) - fun loop (buf, len) = - let - val r = F_OpenSSL_SML_write.f' (bio, C.Ptr.inject' buf, len) - in - if r = len then - () - else if r <= 0 then - (C.free' buf; - raise OpenSSL "BIO_write failed") - else - loop (C.Ptr.|+! C.S.uchar (buf, Int32.toInt r), Int32.- (len, r)) - end - in - loop (buf, Int32.fromInt (size s)); - C.free' buf - end + val _ = print ("Subject: " ^ OpenSSL.peerCN bio ^ "\n") -fun request fname = - let - val bio = F_OpenSSL_SML_new_connect.f' dispatcher + val inf = TextIO.openIn fname + + fun loop () = + case TextIO.inputLine inf of + NONE => () + | SOME line => (OpenSSL.writeAll (bio, line); + loop ()) in - if C.Ptr.isNull' bio then - (ssl_err ("Error initializating connection to dispatcher at " ^ Config.dispatcher); - F_OpenSSL_SML_free_all.f' bio) - else if F_OpenSSL_SML_do_connect.f' bio <= 0 then - (ssl_err ("Error connecting to dispatcher at " ^ Config.dispatcher); - F_OpenSSL_SML_free_all.f' bio) - else let - val inf = TextIO.openIn fname - - fun loop () = - case TextIO.inputLine inf of - NONE => () - | SOME line => (writeAll (bio, line); - loop ()) - in - loop (); - TextIO.closeIn inf; - F_OpenSSL_SML_free_all.f' bio - end + loop (); + TextIO.closeIn inf; + OpenSSL.close bio end -fun serviceOne () = +fun service () = let - val bio = F_OpenSSL_SML_new_accept.f' listenOn + val context = OpenSSL.context (Config.serverCert, + Config.serverKey, + Config.trustStore) + + val sock = OpenSSL.listen (Config.dispatcherPort, Config.queueSize) + + fun loop () = + case OpenSSL.accept (context, sock) of + NONE => () + | SOME bio => + let + val _ = print ("Subject: " ^ OpenSSL.peerCN bio ^ "\n") + + fun loop' () = + case OpenSSL.readOne bio of + NONE => () + | SOME line => (print line; + loop' ()) + in + loop' (); + OpenSSL.close bio; + loop () + end in - if C.Ptr.isNull' bio then - (ssl_err "Error initializating listener"; - F_OpenSSL_SML_free_all.f' bio) - else if F_OpenSSL_SML_do_accept.f' bio <= 0 then - (ssl_err "Error accepting connection"; - F_OpenSSL_SML_free_all.f' bio) - else let - fun loop () = - case readOne bio of - NONE => () - | SOME line => (print line; - loop ()) - in - loop (); - F_OpenSSL_SML_free_all.f' bio - end + loop (); + OpenSSL.shutdown sock end end diff --git a/src/openssl.sig b/src/openssl.sig new file mode 100644 index 0000000..750a4fa --- /dev/null +++ b/src/openssl.sig @@ -0,0 +1,46 @@ +(* HCoop Domtool (http://hcoop.sourceforge.net/) + * Copyright (c) 2006, Adam Chlipala + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + *) + +(* OpenSSL *) + +signature OPENSSL = sig + +exception OpenSSL of string + +val ssl_err : string -> unit + +type context +type bio +type listener + +val readOne : bio -> string option +val writeAll : bio * string -> unit + +val context : string * string * string -> context + +val connect : context * string -> bio +val close : bio -> unit + +val listen : int * int -> listener +val shutdown : listener -> unit + +val accept : context * listener -> bio option + +val peerCN : bio -> string + +end diff --git a/src/openssl.sml b/src/openssl.sml new file mode 100644 index 0000000..c0a24d4 --- /dev/null +++ b/src/openssl.sml @@ -0,0 +1,191 @@ +(* HCoop Domtool (http://hcoop.sourceforge.net/) + * Copyright (c) 2006, Adam Chlipala + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + *) + +(* OpenSSL *) + +structure OpenSSL :> OPENSSL = struct + +val () = (F_OpenSSL_SML_init.f' (); + F_OpenSSL_SML_load_error_strings.f' (); + F_OpenSSL_SML_load_BIO_strings.f' ()) + +exception OpenSSL of string + +type context = (ST_ssl_ctx_st.tag, C_Int.rw) C_Int.su_obj C_Int.ptr' +type bio = (ST_bio_st.tag, C_Int.rw) C_Int.su_obj C_Int.ptr' +type listener = MLRep.Signed.int + +fun ssl_err s = + let + val err = F_OpenSSL_SML_get_error.f () + + val lib = F_OpenSSL_SML_lib_error_string.f err + val func = F_OpenSSL_SML_func_error_string.f err + val reason = F_OpenSSL_SML_reason_error_string.f err + in + print s; + print "\nReason: "; + if C.Ptr.isNull lib then + () + else + (print (ZString.toML lib); + print ":"); + if C.Ptr.isNull func then + () + else + (print (ZString.toML func); + print ":"); + if C.Ptr.isNull reason then + () + else + print (ZString.toML reason); + print "\n" + end + +val readBuf : (C.uchar, C.rw) C.obj C.ptr' = C.alloc' C.S.uchar (Word.fromInt Config.bufSize) +val bufSize = Int32.fromInt Config.bufSize + +fun readOne bio = + let + val r = F_OpenSSL_SML_read.f' (bio, C.Ptr.inject' readBuf, bufSize) + in + if r = 0 then + NONE + else if r < 0 then + raise OpenSSL "BIO_read failed" + else + SOME (CharVector.tabulate (Int32.toInt r, + fn i => chr (Word32.toInt (C.Get.uchar' + (C.Ptr.sub' C.S.uchar (readBuf, i)))))) + end + +fun writeAll (bio, s) = + let + val buf = ZString.dupML' s + + fun loop (buf, len) = + let + val r = F_OpenSSL_SML_write.f' (bio, C.Ptr.inject' buf, len) + in + if r = len then + () + else if r <= 0 then + (C.free' buf; + raise OpenSSL "BIO_write failed") + else + loop (C.Ptr.|+! C.S.uchar (buf, Int32.toInt r), Int32.- (len, r)) + end + in + loop (buf, Int32.fromInt (size s)); + C.free' buf + end + +fun context (chain, key, root) = + let + val context = F_OpenSSL_SML_CTX_new.f' (F_OpenSSL_SML_SSLv23_method.f' ()) + in + if C.Ptr.isNull' context then + (ssl_err "Error creating SSL context"; + raise OpenSSL "Can't create SSL context") + else if F_OpenSSL_SML_use_certificate_chain_file.f' (context, + ZString.dupML' chain) + = 0 then + (ssl_err "Error using certificate chain"; + F_OpenSSL_SML_CTX_free.f' context; + raise OpenSSL "Can't load certificate chain") + else if F_OpenSSL_SML_use_PrivateKey_file.f' (context, + ZString.dupML' key) + = 0 then + (ssl_err "Error using private key"; + F_OpenSSL_SML_CTX_free.f' context; + raise OpenSSL "Can't load private key") + else if F_OpenSSL_SML_load_verify_locations.f' (context, + ZString.dupML' root, + C.Ptr.null') = 0 then + (ssl_err "Error loading trust store"; + F_OpenSSL_SML_CTX_free.f' context; + raise OpenSSL "Can't load trust store") + else + context + end + +fun connect (context, hostname) = + let + val bio = F_OpenSSL_SML_new_ssl_connect.f' context + in + if C.Ptr.isNull' bio then + (ssl_err ("Error initializating connection to " ^ hostname); + F_OpenSSL_SML_free_all.f' bio; + raise OpenSSL "Can't initialize connection") + else if F_OpenSSL_SML_set_conn_hostname.f' (bio, ZString.dupML' hostname) = 0 then + (ssl_err ("Error setting hostname: " ^ hostname); + F_OpenSSL_SML_free_all.f' bio; + raise OpenSSL "Can't set hostname") + else if F_OpenSSL_SML_do_connect.f' bio <= 0 then + (ssl_err ("Error connecting to " ^ hostname); + F_OpenSSL_SML_free_all.f' bio; + raise OpenSSL "Can't connect") + else + bio + end + +fun close bio = F_OpenSSL_SML_free_all.f' bio + +fun listen (port, qsize) = F_OpenSSL_SML_tcp_listen.f' (Int32.fromInt port, Int32.fromInt qsize) +fun shutdown sock = F_OpenSSL_SML_shutdown.f' sock + +fun accept (context, sock) = + let + val sock' = F_OpenSSL_SML_accept.f' sock + in + if Int32.< (sock', Int32.fromInt 0) then + NONE + else let + val bio = F_OpenSSL_SML_new_socket.f' sock' + val ssl = F_OpenSSL_SML_SSL_new.f' context + in + if C.Ptr.isNull' bio then + (ssl_err "Error initializating accepter"; + F_OpenSSL_SML_free_all.f' bio; + raise OpenSSL "Can't initialize accepter") + else if (F_OpenSSL_SML_SSL_set_bio.f' (ssl, bio, bio); + F_OpenSSL_SML_SSL_accept.f' ssl) <= 0 then + (ssl_err "Error accepting connection"; + F_OpenSSL_SML_free_all.f' bio; + raise OpenSSL "Can't accept connection") + else + SOME bio + end + end + +fun peerCN bio = + let + val ssl = F_OpenSSL_SML_get_ssl.f' bio + val _ = if C.Ptr.isNull' ssl then + raise OpenSSL "Null SSL" + else + () + val subj = F_OpenSSL_SML_get_peer_name.f' ssl + in + if C.Ptr.isNull' subj then + raise OpenSSL "Null CN result" + else + ZString.toML' subj + end + +end -- 2.20.1