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"
val dispatcher : string
val dispatcherPort : int
+val queueSize : int
val bufSize : int
+val trustStore : string
+val serverCert : string
+val serverKey : string
#include "openssl/ssl.h"
#include "openssl/err.h"
-void OpenSSL_SML_add_all_algorithms() {
- OpenSSL_add_all_algorithms();
+#include <sys/types.h>
+#include <sys/socket.h>
+#include <unistd.h>
+#include <netinet/in.h>
+
+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() {
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;
+}
#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);
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);
order.sig
order.sml
+openssl.sig
+openssl.sml
+
main.sig
main.sml
val eval : string -> unit
val request : string -> unit
- val serviceOne : unit -> unit
+ val service : unit -> unit
end
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
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
--- /dev/null
+(* 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
--- /dev/null
+(* 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
HCoop / hcoop / domtool2.git / commitdiff