[hcoop/domtool2.git] / src / openssl.sml

(* 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 = bio

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
val one = Int32.fromInt 1
val four = Int32.fromInt 4

val eight = Word.fromInt 8
val sixteen = Word.fromInt 16
val twentyfour = Word.fromInt 24

val mask1 = Word32.fromInt 255

fun readChar bio =
    let
	val r = F_OpenSSL_SML_read.f' (bio, C.Ptr.inject' readBuf, one)
    in
	if r = 0 then
	    NONE
	else if r < 0 then
	    (ssl_err "BIO_read";
	     raise OpenSSL "BIO_read failed")
	else
	    SOME (chr (Word32.toInt (C.Get.uchar'
					 (C.Ptr.sub' C.S.uchar (readBuf, 0)))))
    end

fun readInt bio =
    let
	val r = F_OpenSSL_SML_read.f' (bio, C.Ptr.inject' readBuf, four)
    in
	if r = 0 then
	    NONE
	else if r < 0 then
	    (ssl_err "BIO_read";
	     raise OpenSSL "BIO_read failed")
	else
	    SOME (Word32.toInt
		      (Word32.+
		       (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 0)),
			Word32.+
			(Word32.<< (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 1)),
				    eight),
			 Word32.+
			 (Word32.<< (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 2)),
				     sixteen),
			  Word32.<< (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 3)),
				     twentyfour))))))
    end

fun readLen (bio, len) =
    let
	val buf =
	    if len > Config.bufSize then
		C.alloc' C.S.uchar (Word.fromInt len)
	    else
		readBuf

	fun cleanup () =
	    if len > Config.bufSize then
		C.free' buf
	    else
		()

	fun loop (buf', needed) =
	    let
		val r = F_OpenSSL_SML_read.f' (bio, C.Ptr.inject' buf, Int32.fromInt len)
	    in
		if r = 0 then
		    (cleanup (); NONE)
		else if r < 0 then
		    (cleanup ();
		     ssl_err "BIO_read";
		     raise OpenSSL "BIO_read failed")
		else if r = needed then
		    SOME (CharVector.tabulate (Int32.toInt needed,
					    fn i => chr (Word32.toInt (C.Get.uchar'
									   (C.Ptr.sub' C.S.uchar (buf, i))))))
		else
		    loop (C.Ptr.|+! C.S.uchar (buf', Int32.toInt r), needed - r)
	    end
    in
	loop (buf, Int32.fromInt len)
	before cleanup ()
    end	

fun readChunk 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
	    (ssl_err "BIO_read";
	     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 readString bio =
    case readInt bio of
	NONE => NONE
      | SOME len => readLen (bio, len)

fun writeChar (bio, ch) =
    let
	val _ = C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 0),
			      Word32.fromInt (ord ch))

	fun trier () =
	    let
		val r = F_OpenSSL_SML_write.f' (bio, C.Ptr.inject' readBuf, one)
	    in
		if r = 0 then
		    trier ()
		else if r < 0 then
		    (ssl_err "BIO_write";
		     raise OpenSSL "BIO_write")
		else
		    ()
	    end
    in
	trier ()
    end

fun writeInt (bio, n) =
    let
	val w = Word32.fromInt n

	val _ = (C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 0),
			       Word32.andb (w, mask1));
		 C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 1),
			       Word32.andb (Word32.>> (w, eight), mask1));
		 C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 2),
			       Word32.andb (Word32.>> (w, sixteen), mask1));
		 C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 3),
			       Word32.andb (Word32.>> (w, twentyfour), mask1)))

	fun trier (buf, count) =
	    let
		val r = F_OpenSSL_SML_write.f' (bio, C.Ptr.inject' buf, count)
	    in
		if r < 0 then
		    (ssl_err "BIO_write";
		     raise OpenSSL "BIO_write")
		else if r = count then
		    ()
		else
		    trier (C.Ptr.|+! C.S.uchar (buf, Int32.toInt r), count - r)
	    end
    in
	trier (readBuf, 4)
    end	

fun writeString' (bio, s) =
    let
	val buf = ZString.dupML' s
    in
	if F_OpenSSL_SML_puts.f' (bio, buf) <= 0 then
	    (C.free' buf;
	     ssl_err "BIO_puts";
	     raise OpenSSL "BIO_puts")
	else
	    C.free' buf
    end

fun writeString (bio, s) =
    (writeInt (bio, size s);
     writeString' (bio, s))

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 (context, port) =
    let
	val port = ZString.dupML' (Int.toString port)
	val listener = F_OpenSSL_SML_new_accept.f' (context, port)
    in
	C.free' port;
	if C.Ptr.isNull' listener then
	    (ssl_err "Null listener";
	     raise OpenSSL "Null listener")
	else if F_OpenSSL_SML_do_accept.f' listener <= 0 then
	    (ssl_err "Error initializing listener";
	     close listener;
	     raise OpenSSL "Can't initialize listener")
	else
	    listener
    end

val shutdown = close

fun accept listener =
    if F_OpenSSL_SML_do_accept.f' listener <= 0 then
	NONE
    else
	let
	    val bio = F_OpenSSL_SML_pop.f' listener
	in
	    if C.Ptr.isNull' bio then
		(ssl_err "Null accepted";
		 raise OpenSSL "Null accepted")
	    else if F_OpenSSL_SML_do_handshake.f' bio <= 0 then
		(ssl_err "Handshake failed";
		 raise OpenSSL "Handshake failed")
	    else
		SOME bio
	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
Commit	Line	Data
3b267643 AC	1	(* HCoop Domtool (http://hcoop.sourceforge.net/)
	2	* Copyright (c) 2006, Adam Chlipala
	3	*
	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.
	8	*
	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.
	13	*
	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.
	17	*)
	18
	19	(* OpenSSL *)
	20
	21	structure OpenSSL :> OPENSSL = struct
	22
	23	val () = (F_OpenSSL_SML_init.f' ();
	24	F_OpenSSL_SML_load_error_strings.f' ();
	25	F_OpenSSL_SML_load_BIO_strings.f' ())
	26
	27	exception OpenSSL of string
	28
	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'
60534712	31	type listener = bio
3b267643 AC	32
	33	fun ssl_err s =
	34	let
	35	val err = F_OpenSSL_SML_get_error.f ()
	36
	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
	40	in
	41	print s;
	42	print "\nReason: ";
	43	if C.Ptr.isNull lib then
	44	()
	45	else
	46	(print (ZString.toML lib);
	47	print ":");
	48	if C.Ptr.isNull func then
	49	()
	50	else
	51	(print (ZString.toML func);
	52	print ":");
	53	if C.Ptr.isNull reason then
	54	()
	55	else
	56	print (ZString.toML reason);
	57	print "\n"
	58	end
	59
	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
36e42cb8 AC	62	val one = Int32.fromInt 1
36e42cb8 AC	63	val four = Int32.fromInt 4
3b267643	64
36e42cb8 AC	65	val eight = Word.fromInt 8
	66	val sixteen = Word.fromInt 16
	67	val twentyfour = Word.fromInt 24
	68
	69	val mask1 = Word32.fromInt 255
	70
	71	fun readChar bio =
	72	let
	73	val r = F_OpenSSL_SML_read.f' (bio, C.Ptr.inject' readBuf, one)
	74	in
	75	if r = 0 then
	76	NONE
	77	else if r < 0 then
	78	(ssl_err "BIO_read";
	79	raise OpenSSL "BIO_read failed")
	80	else
	81	SOME (chr (Word32.toInt (C.Get.uchar'
	82	(C.Ptr.sub' C.S.uchar (readBuf, 0)))))
	83	end
	84
	85	fun readInt bio =
	86	let
	87	val r = F_OpenSSL_SML_read.f' (bio, C.Ptr.inject' readBuf, four)
	88	in
	89	if r = 0 then
	90	NONE
	91	else if r < 0 then
	92	(ssl_err "BIO_read";
	93	raise OpenSSL "BIO_read failed")
	94	else
	95	SOME (Word32.toInt
	96	(Word32.+
	97	(C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 0)),
	98	Word32.+
	99	(Word32.<< (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 1)),
	100	eight),
	101	Word32.+
	102	(Word32.<< (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 2)),
	103	sixteen),
	104	Word32.<< (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 3)),
	105	twentyfour))))))
	106	end
	107
	108	fun readLen (bio, len) =
	109	let
	110	val buf =
	111	if len > Config.bufSize then
	112	C.alloc' C.S.uchar (Word.fromInt len)
	113	else
	114	readBuf
	115
	116	fun cleanup () =
	117	if len > Config.bufSize then
	118	C.free' buf
	119	else
	120	()
	121
	122	fun loop (buf', needed) =
	123	let
	124	val r = F_OpenSSL_SML_read.f' (bio, C.Ptr.inject' buf, Int32.fromInt len)
	125	in
	126	if r = 0 then
	127	(cleanup (); NONE)
	128	else if r < 0 then
129	(cleanup ();
130	ssl_err "BIO_read";
131	raise OpenSSL "BIO_read failed")
132	else if r = needed then
133	SOME (CharVector.tabulate (Int32.toInt needed,
134	fn i => chr (Word32.toInt (C.Get.uchar'
135	(C.Ptr.sub' C.S.uchar (buf, i))))))
136	else
137	loop (C.Ptr.\|+! C.S.uchar (buf', Int32.toInt r), needed - r)
138	end
139	in
140	loop (buf, Int32.fromInt len)
141	before cleanup ()
142	end
143
144	fun readChunk bio =
3b267643 AC	145	let
	146	val r = F_OpenSSL_SML_read.f' (bio, C.Ptr.inject' readBuf, bufSize)
	147	in
	148	if r = 0 then
	149	NONE
	150	else if r < 0 then
36e42cb8 AC	151	(ssl_err "BIO_read";
36e42cb8 AC	152	raise OpenSSL "BIO_read failed")
3b267643 AC	153	else
	154	SOME (CharVector.tabulate (Int32.toInt r,
	155	fn i => chr (Word32.toInt (C.Get.uchar'
	156	(C.Ptr.sub' C.S.uchar (readBuf, i))))))
	157	end
	158
36e42cb8 AC	159	fun readString bio =
	160	case readInt bio of
	161	NONE => NONE
	162	\| SOME len => readLen (bio, len)
	163
	164	fun writeChar (bio, ch) =
3b267643	165	let
36e42cb8 AC	166	val _ = C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 0),
36e42cb8 AC	167	Word32.fromInt (ord ch))
3b267643	168
36e42cb8	169	fun trier () =
3b267643	170	let
36e42cb8	171	val r = F_OpenSSL_SML_write.f' (bio, C.Ptr.inject' readBuf, one)
3b267643	172	in
36e42cb8 AC	173	if r = 0 then
	174	trier ()
	175	else if r < 0 then
	176	(ssl_err "BIO_write";
	177	raise OpenSSL "BIO_write")
	178	else
	179	()
	180	end
	181	in
	182	trier ()
	183	end
	184
	185	fun writeInt (bio, n) =
	186	let
	187	val w = Word32.fromInt n
	188
	189	val _ = (C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 0),
	190	Word32.andb (w, mask1));
	191	C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 1),
	192	Word32.andb (Word32.>> (w, eight), mask1));
	193	C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 2),
	194	Word32.andb (Word32.>> (w, sixteen), mask1));
	195	C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 3),
	196	Word32.andb (Word32.>> (w, twentyfour), mask1)))
	197
	198	fun trier (buf, count) =
	199	let
	200	val r = F_OpenSSL_SML_write.f' (bio, C.Ptr.inject' buf, count)
	201	in
	202	if r < 0 then
	203	(ssl_err "BIO_write";
	204	raise OpenSSL "BIO_write")
	205	else if r = count then
3b267643	206	()
3b267643	207	else
36e42cb8	208	trier (C.Ptr.\|+! C.S.uchar (buf, Int32.toInt r), count - r)
3b267643 AC	209	end
3b267643 AC	210	in
36e42cb8 AC	211	trier (readBuf, 4)
	212	end
	213
	214	fun writeString' (bio, s) =
	215	let
	216	val buf = ZString.dupML' s
	217	in
	218	if F_OpenSSL_SML_puts.f' (bio, buf) <= 0 then
	219	(C.free' buf;
	220	ssl_err "BIO_puts";
	221	raise OpenSSL "BIO_puts")
	222	else
	223	C.free' buf
3b267643 AC	224	end
3b267643 AC	225
36e42cb8 AC	226	fun writeString (bio, s) =
	227	(writeInt (bio, size s);
	228	writeString' (bio, s))
	229
3b267643 AC	230	fun context (chain, key, root) =
	231	let
	232	val context = F_OpenSSL_SML_CTX_new.f' (F_OpenSSL_SML_SSLv23_method.f' ())
	233	in
	234	if C.Ptr.isNull' context then
	235	(ssl_err "Error creating SSL context";
	236	raise OpenSSL "Can't create SSL context")
	237	else if F_OpenSSL_SML_use_certificate_chain_file.f' (context,
	238	ZString.dupML' chain)
	239	= 0 then
	240	(ssl_err "Error using certificate chain";
	241	F_OpenSSL_SML_CTX_free.f' context;
	242	raise OpenSSL "Can't load certificate chain")
	243	else if F_OpenSSL_SML_use_PrivateKey_file.f' (context,
	244	ZString.dupML' key)
	245	= 0 then
	246	(ssl_err "Error using private key";
	247	F_OpenSSL_SML_CTX_free.f' context;
	248	raise OpenSSL "Can't load private key")
	249	else if F_OpenSSL_SML_load_verify_locations.f' (context,
	250	ZString.dupML' root,
	251	C.Ptr.null') = 0 then
	252	(ssl_err "Error loading trust store";
	253	F_OpenSSL_SML_CTX_free.f' context;
	254	raise OpenSSL "Can't load trust store")
	255	else
	256	context
	257	end
	258
	259	fun connect (context, hostname) =
	260	let
	261	val bio = F_OpenSSL_SML_new_ssl_connect.f' context
	262	in
	263	if C.Ptr.isNull' bio then
	264	(ssl_err ("Error initializating connection to " ^ hostname);
	265	F_OpenSSL_SML_free_all.f' bio;
	266	raise OpenSSL "Can't initialize connection")
	267	else if F_OpenSSL_SML_set_conn_hostname.f' (bio, ZString.dupML' hostname) = 0 then
	268	(ssl_err ("Error setting hostname: " ^ hostname);
	269	F_OpenSSL_SML_free_all.f' bio;
	270	raise OpenSSL "Can't set hostname")
	271	else if F_OpenSSL_SML_do_connect.f' bio <= 0 then
	272	(ssl_err ("Error connecting to " ^ hostname);
	273	F_OpenSSL_SML_free_all.f' bio;
	274	raise OpenSSL "Can't connect")
	275	else
	276	bio
	277	end
	278
	279	fun close bio = F_OpenSSL_SML_free_all.f' bio
	280
60534712 AC	281	fun listen (context, port) =
	282	let
	283	val port = ZString.dupML' (Int.toString port)
	284	val listener = F_OpenSSL_SML_new_accept.f' (context, port)
	285	in
	286	C.free' port;
	287	if C.Ptr.isNull' listener then
	288	(ssl_err "Null listener";
	289	raise OpenSSL "Null listener")
	290	else if F_OpenSSL_SML_do_accept.f' listener <= 0 then
	291	(ssl_err "Error initializing listener";
	292	close listener;
	293	raise OpenSSL "Can't initialize listener")
	294	else
	295	listener
	296	end
	297
	298	val shutdown = close
	299
	300	fun accept listener =
	301	if F_OpenSSL_SML_do_accept.f' listener <= 0 then
	302	NONE
	303	else
7a150fe2 AC	304	let
	305	val bio = F_OpenSSL_SML_pop.f' listener
	306	in
	307	if C.Ptr.isNull' bio then
	308	(ssl_err "Null accepted";
	309	raise OpenSSL "Null accepted")
	310	else if F_OpenSSL_SML_do_handshake.f' bio <= 0 then
	311	(ssl_err "Handshake failed";
	312	raise OpenSSL "Handshake failed")
	313	else
	314	SOME bio
	315	end
3b267643 AC	316
	317	fun peerCN bio =
	318	let
	319	val ssl = F_OpenSSL_SML_get_ssl.f' bio
	320	val _ = if C.Ptr.isNull' ssl then
	321	raise OpenSSL "Null SSL"
	322	else
	323	()
	324	val subj = F_OpenSSL_SML_get_peer_name.f' ssl
	325	in
	326	if C.Ptr.isNull' subj then
	327	raise OpenSSL "Null CN result"
	328	else
	329	ZString.toML' subj
	330	end
	331
	332	end