From 559e89e9adf62c5faeb0e78e6b9fb8fe107b8c72 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 2 Sep 2006 18:10:21 +0000 Subject: [PATCH] Simple OpenSSL stuff in SML/NJ --- Makefile | 17 +++++++-- configDefault/domtool.cfg | 2 ++ configDefault/domtool.cfs | 2 ++ openssl/openssl_sml.c | 47 ++++++++++++++++++++++++ openssl/openssl_sml.h | 15 ++++++++ openssl/smlnj/.cvsignore | 2 ++ openssl/smlnj/FFI/.cvsignore | 2 ++ openssl/smlnj/libssl-h.sml | 13 +++++++ src/domain.sml | 4 +-- src/domtool.cm | 3 ++ src/main.sig | 2 ++ src/main.sml | 70 ++++++++++++++++++++++++++++++++++++ 12 files changed, 175 insertions(+), 4 deletions(-) create mode 100644 openssl/openssl_sml.c create mode 100644 openssl/openssl_sml.h create mode 100644 openssl/smlnj/.cvsignore create mode 100644 openssl/smlnj/FFI/.cvsignore create mode 100644 openssl/smlnj/libssl-h.sml diff --git a/Makefile b/Makefile index 7964314..2d5c588 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,7 @@ -all: configDefault/config.sig configDefault/configDefault.sml +all: configDefault/config.sig configDefault/configDefault.sml \ + openssl/openssl_sml.so openssl/smlnj/FFI/libssl.h.cm -.PHONY: all +.PHONY: all openssl configDefault/config.sig: src/config.sig.header \ configDefault/*.csg configDefault/*.cfs \ @@ -18,3 +19,15 @@ configDefault/configDefault.sml: src/configDefault.sml.header \ src/configDefault.sml.footer \ >configDefault/configDefault.sml +openssl/openssl_sml.o: openssl/openssl_sml.c + gcc -fPIC -c openssl/openssl_sml.c -o openssl/openssl_sml.o + +openssl/openssl_sml.so: openssl/openssl_sml.o + gcc -shared -Wl,-soname,openssl_sml.so \ + -o openssl/openssl_sml.so \ + openssl/openssl_sml.o -lssl + +openssl/smlnj/FFI/libssl.h.cm: openssl/openssl_sml.h + cd openssl/smlnj ; ml-nlffigen -d FFI -lh LibsslH.libh -include ../libssl-h.sml \ + -cm libssl.h.cm -D__builtin_va_list="void*" \ + ../openssl_sml.h diff --git a/configDefault/domtool.cfg b/configDefault/domtool.cfg index 529ec7b..0246f2a 100644 --- a/configDefault/domtool.cfg +++ b/configDefault/domtool.cfg @@ -22,3 +22,5 @@ val aclFile = "/home/adamc/fake/acl" val testUser = "adamc" val defaultDomain = "hcoop.net" + +val dispatcher = "localhost:1234" diff --git a/configDefault/domtool.cfs b/configDefault/domtool.cfs index 1814dc4..db536e3 100644 --- a/configDefault/domtool.cfs +++ b/configDefault/domtool.cfs @@ -31,3 +31,5 @@ val aclFile : string val testUser : string val defaultDomain : string + +val dispatcher : string diff --git a/openssl/openssl_sml.c b/openssl/openssl_sml.c new file mode 100644 index 0000000..b35262b --- /dev/null +++ b/openssl/openssl_sml.c @@ -0,0 +1,47 @@ +#include "openssl/bio.h" +#include "openssl/ssl.h" +#include "openssl/err.h" + +void OpenSSL_SML_add_all_algorithms() { + OpenSSL_add_all_algorithms(); +} + +void OpenSSL_SML_load_error_strings() { + SSL_load_error_strings(); +} + +void OpenSSL_SML_load_BIO_strings() { + ERR_load_BIO_strings(); +} + +int OpenSSL_SML_get_error() { + return ERR_get_error(); +} + +const char *OpenSSL_SML_lib_error_string(int err) { + return ERR_lib_error_string(err); +} + +const char *OpenSSL_SML_func_error_string(int err) { + return ERR_func_error_string(err); +} + +const char *OpenSSL_SML_reason_error_string(int err) { + return ERR_reason_error_string(err); +} + +int OpenSSL_SML_write(BIO *b, const void *data, int len) { + return BIO_write(b, data, len); +} + +BIO *OpenSSL_SML_new_connect(char *addr) { + return BIO_new_connect(addr); +} + +void OpenSSL_SML_free_all(BIO *b) { + BIO_free_all(b); +} + +int OpenSSL_SML_do_connect(BIO *b) { + return BIO_do_connect(b); +} diff --git a/openssl/openssl_sml.h b/openssl/openssl_sml.h new file mode 100644 index 0000000..f461c43 --- /dev/null +++ b/openssl/openssl_sml.h @@ -0,0 +1,15 @@ +#include "openssl/bio.h" +#include "openssl/ssl.h" +#include "openssl/err.h" + +void OpenSSL_SML_add_all_algorithms(void); +void OpenSSL_SML_load_error_strings(void); +void OpenSSL_SML_load_BIO_strings(void); +int OpenSSL_SML_get_error(void); +const char *OpenSSL_SML_lib_error_string(int err); +const char *OpenSSL_SML_func_error_string(int err); +const char *OpenSSL_SML_reason_error_string(int err); +int OpenSSL_SML_write(BIO *b, const void *data, int len); +BIO *OpenSSL_SML_new_connect(char *addr); +void OpenSSL_SML_free_all(BIO *b); +int OpenSSL_SML_do_connect(BIO *b); diff --git a/openssl/smlnj/.cvsignore b/openssl/smlnj/.cvsignore new file mode 100644 index 0000000..a2a33e4 --- /dev/null +++ b/openssl/smlnj/.cvsignore @@ -0,0 +1,2 @@ +.cm +CM diff --git a/openssl/smlnj/FFI/.cvsignore b/openssl/smlnj/FFI/.cvsignore new file mode 100644 index 0000000..9c1ac52 --- /dev/null +++ b/openssl/smlnj/FFI/.cvsignore @@ -0,0 +1,2 @@ +*.sml +*.cm diff --git a/openssl/smlnj/libssl-h.sml b/openssl/smlnj/libssl-h.sml new file mode 100644 index 0000000..6e4b191 --- /dev/null +++ b/openssl/smlnj/libssl-h.sml @@ -0,0 +1,13 @@ +structure LibsslH = struct + local + val lh = DynLinkage.open_lib + { name = "openssl/openssl_sml.so", global = true, lazy = true } + handle DynLinkage.DynLinkError s => raise Fail s + in + fun libh s = let + val sh = DynLinkage.lib_symbol (lh, s) + in + fn () => DynLinkage.addr sh + end + end +end diff --git a/src/domain.sml b/src/domain.sml index da18f22..27bc806 100644 --- a/src/domain.sml +++ b/src/domain.sml @@ -547,9 +547,9 @@ val () = Env.registerPost (fn () => if !ErrorMsg.anyErrors then () else - Slave.handleChanges (map #2 diffs)(*; + Slave.handleChanges (map #2 diffs); ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""], - fn cl => "Temp file cleanup failed: " ^ cl))*) + fn cl => "Temp file cleanup failed: " ^ cl)) end) diff --git a/src/domtool.cm b/src/domtool.cm index ff07373..48cafe7 100644 --- a/src/domtool.cm +++ b/src/domtool.cm @@ -4,6 +4,9 @@ $/basis.cm $/smlnj-lib.cm $/ml-yacc-lib.cm $/pp-lib.cm +$c/internals/c-int.cm + +../openssl/smlnj/FFI/libssl.h.cm errormsg.sig errormsg.sml diff --git a/src/main.sig b/src/main.sig index 62a87ef..e1d5015 100644 --- a/src/main.sig +++ b/src/main.sig @@ -31,4 +31,6 @@ signature MAIN = sig val reduce : string -> Ast.exp option val eval : string -> unit + val request : string -> unit + end diff --git a/src/main.sml b/src/main.sml index 705b20a..14eaa4a 100644 --- a/src/main.sml +++ b/src/main.sml @@ -26,6 +26,12 @@ 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 @@ -133,4 +139,68 @@ fun eval fname = Eval.exec (SM.map (fn f => f ()) (!defaultV)) body' | NONE => () +val dispatcher : C.rw ZString.zstring' = ZString.dupML' Config.dispatcher + +fun ssl_err s = + let + val err = F_OpenSSL_SML_get_error.f () + 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)); + print "\n" + end + +exception OpenSSL of string + +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 request fname = + let + val bio = F_OpenSSL_SML_new_connect.f' dispatcher + 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 + end + end -- 2.20.1