[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 (Compat.Char.toInt (C.Get.uchar'
					      (C.Ptr.sub' C.S.uchar (readBuf, 0)))))
    end

val charToWord = Word32.fromLargeWord o Compat.Char.toLargeWord

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.+
		       (charToWord (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 0))),
			Word32.+
			(Word32.<< (charToWord (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 1))),
				    eight),
			 Word32.+
			 (Word32.<< (charToWord (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 2))),
				     sixteen),
			  Word32.<< (charToWord (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 3))),
				     twentyfour))))))
    end

fun readLen (bio, len) =
    if len = 0 then
	SOME ""
    else
	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 (Compat.Char.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 (Compat.Char.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),
			      Compat.Char.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

val wordToChar = Compat.Char.fromLargeWord o Word32.toLargeWord

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

	val _ = (C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 0),
			       wordToChar (Word32.andb (w, mask1)));
		 C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 1),
			       wordToChar (Word32.andb (Word32.>> (w, eight), mask1)));
		 C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 2),
			       wordToChar (Word32.andb (Word32.>> (w, sixteen), mask1)));
		 C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 3),
			       wordToChar (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) =
    if size s = 0 then
	()
    else
	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 printErr (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
	    (if printErr then ssl_err "Error creating SSL context" else ();
	     raise OpenSSL "Can't create SSL context")
	else if F_OpenSSL_SML_use_certificate_chain_file.f' (context,
							     ZString.dupML' chain)
		= 0 then
	    (if printErr then ssl_err "Error using certificate chain" else ();
	     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
	    (if printErr then ssl_err "Error using private key" else ();
	     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
	    (if printErr then ssl_err "Error loading trust store" else ();
	     F_OpenSSL_SML_CTX_free.f' context;
	     raise OpenSSL "Can't load trust store")
	else
	    context
    end

fun connect printErr (context, hostname) =
    let
	val bio = F_OpenSSL_SML_new_ssl_connect.f' context

	val ssl_err =
	    if printErr then
		ssl_err
	    else
		(fn _ => ())
    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 ":");
64a44dc0 AC	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
16465a9a AC	56	print (ZString.toML reason);
16465a9a AC	57	print "\n"
3b267643 AC	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
a49a9bfb AC	81	SOME (chr (Compat.Char.toInt (C.Get.uchar'
a49a9bfb AC	82	(C.Ptr.sub' C.S.uchar (readBuf, 0)))))
36e42cb8 AC	83	end
36e42cb8 AC	84
a49a9bfb AC	85	val charToWord = Word32.fromLargeWord o Compat.Char.toLargeWord
a49a9bfb AC	86
36e42cb8 AC	87	fun readInt bio =
	88	let
	89	val r = F_OpenSSL_SML_read.f' (bio, C.Ptr.inject' readBuf, four)
	90	in
	91	if r = 0 then
	92	NONE
	93	else if r < 0 then
	94	(ssl_err "BIO_read";
	95	raise OpenSSL "BIO_read failed")
	96	else
	97	SOME (Word32.toInt
	98	(Word32.+
a49a9bfb	99	(charToWord (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 0))),
36e42cb8	100	Word32.+
a49a9bfb	101	(Word32.<< (charToWord (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 1))),
36e42cb8 AC	102	eight),
36e42cb8 AC	103	Word32.+
a49a9bfb	104	(Word32.<< (charToWord (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 2))),
36e42cb8	105	sixteen),
a49a9bfb	106	Word32.<< (charToWord (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 3))),
36e42cb8 AC	107	twentyfour))))))
	108	end
	109
	110	fun readLen (bio, len) =
314ce7bd AC	111	if len = 0 then
	112	SOME ""
	113	else
	114	let
	115	val buf =
	116	if len > Config.bufSize then
	117	C.alloc' C.S.uchar (Word.fromInt len)
	118	else
	119	readBuf
36e42cb8	120
314ce7bd AC	121	fun cleanup () =
	122	if len > Config.bufSize then
	123	C.free' buf
36e42cb8	124	else
314ce7bd AC	125	()
	126
	127	fun loop (buf', needed) =
	128	let
	129	val r = F_OpenSSL_SML_read.f' (bio, C.Ptr.inject' buf, Int32.fromInt len)
	130	in
	131	if r = 0 then
	132	(cleanup (); NONE)
	133	else if r < 0 then
	134	(cleanup ();
	135	ssl_err "BIO_read";
	136	raise OpenSSL "BIO_read failed")
	137	else if r = needed then
	138	SOME (CharVector.tabulate (Int32.toInt needed,
	139	fn i => chr (Compat.Char.toInt (C.Get.uchar'
	140	(C.Ptr.sub' C.S.uchar (buf, i))))))
	141	else
	142	loop (C.Ptr.\|+! C.S.uchar (buf', Int32.toInt r), needed - r)
	143	end
	144	in
	145	loop (buf, Int32.fromInt len)
	146	before cleanup ()
	147	end
36e42cb8 AC	148
36e42cb8 AC	149	fun readChunk bio =
3b267643 AC	150	let
	151	val r = F_OpenSSL_SML_read.f' (bio, C.Ptr.inject' readBuf, bufSize)
	152	in
	153	if r = 0 then
	154	NONE
	155	else if r < 0 then
36e42cb8 AC	156	(ssl_err "BIO_read";
36e42cb8 AC	157	raise OpenSSL "BIO_read failed")
3b267643 AC	158	else
3b267643 AC	159	SOME (CharVector.tabulate (Int32.toInt r,
a49a9bfb AC	160	fn i => chr (Compat.Char.toInt (C.Get.uchar'
a49a9bfb AC	161	(C.Ptr.sub' C.S.uchar (readBuf, i))))))
3b267643 AC	162	end
3b267643 AC	163
36e42cb8 AC	164	fun readString bio =
	165	case readInt bio of
	166	NONE => NONE
	167	\| SOME len => readLen (bio, len)
	168
	169	fun writeChar (bio, ch) =
3b267643	170	let
36e42cb8	171	val _ = C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 0),
a49a9bfb	172	Compat.Char.fromInt (ord ch))
3b267643	173
36e42cb8	174	fun trier () =
3b267643	175	let
36e42cb8	176	val r = F_OpenSSL_SML_write.f' (bio, C.Ptr.inject' readBuf, one)
3b267643	177	in
36e42cb8 AC	178	if r = 0 then
	179	trier ()
	180	else if r < 0 then
	181	(ssl_err "BIO_write";
	182	raise OpenSSL "BIO_write")
	183	else
	184	()
	185	end
	186	in
	187	trier ()
	188	end
	189
a49a9bfb AC	190	val wordToChar = Compat.Char.fromLargeWord o Word32.toLargeWord
a49a9bfb AC	191
36e42cb8 AC	192	fun writeInt (bio, n) =
	193	let
	194	val w = Word32.fromInt n
	195
	196	val _ = (C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 0),
a49a9bfb	197	wordToChar (Word32.andb (w, mask1)));
36e42cb8	198	C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 1),
a49a9bfb	199	wordToChar (Word32.andb (Word32.>> (w, eight), mask1)));
36e42cb8	200	C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 2),
a49a9bfb	201	wordToChar (Word32.andb (Word32.>> (w, sixteen), mask1)));
36e42cb8	202	C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 3),
a49a9bfb	203	wordToChar (Word32.andb (Word32.>> (w, twentyfour), mask1))))
36e42cb8 AC	204
	205	fun trier (buf, count) =
	206	let
	207	val r = F_OpenSSL_SML_write.f' (bio, C.Ptr.inject' buf, count)
	208	in
	209	if r < 0 then
	210	(ssl_err "BIO_write";
	211	raise OpenSSL "BIO_write")
	212	else if r = count then
3b267643	213	()
3b267643	214	else
36e42cb8	215	trier (C.Ptr.\|+! C.S.uchar (buf, Int32.toInt r), count - r)
3b267643 AC	216	end
3b267643 AC	217	in
36e42cb8 AC	218	trier (readBuf, 4)
	219	end
	220
	221	fun writeString' (bio, s) =
314ce7bd AC	222	if size s = 0 then
	223	()
	224	else
	225	let
	226	val buf = ZString.dupML' s
	227	in
	228	if F_OpenSSL_SML_puts.f' (bio, buf) <= 0 then
	229	(C.free' buf;
	230	ssl_err "BIO_puts";
	231	raise OpenSSL "BIO_puts")
	232	else
	233	C.free' buf
	234	end
3b267643	235
36e42cb8 AC	236	fun writeString (bio, s) =
	237	(writeInt (bio, size s);
	238	writeString' (bio, s))
	239
d22c1f00	240	fun context printErr (chain, key, root) =
3b267643 AC	241	let
	242	val context = F_OpenSSL_SML_CTX_new.f' (F_OpenSSL_SML_SSLv23_method.f' ())
	243	in
	244	if C.Ptr.isNull' context then
d22c1f00	245	(if printErr then ssl_err "Error creating SSL context" else ();
3b267643 AC	246	raise OpenSSL "Can't create SSL context")
	247	else if F_OpenSSL_SML_use_certificate_chain_file.f' (context,
	248	ZString.dupML' chain)
	249	= 0 then
d22c1f00	250	(if printErr then ssl_err "Error using certificate chain" else ();
3b267643 AC	251	F_OpenSSL_SML_CTX_free.f' context;
	252	raise OpenSSL "Can't load certificate chain")
	253	else if F_OpenSSL_SML_use_PrivateKey_file.f' (context,
	254	ZString.dupML' key)
	255	= 0 then
d22c1f00	256	(if printErr then ssl_err "Error using private key" else ();
3b267643 AC	257	F_OpenSSL_SML_CTX_free.f' context;
	258	raise OpenSSL "Can't load private key")
	259	else if F_OpenSSL_SML_load_verify_locations.f' (context,
	260	ZString.dupML' root,
	261	C.Ptr.null') = 0 then
d22c1f00	262	(if printErr then ssl_err "Error loading trust store" else ();
3b267643 AC	263	F_OpenSSL_SML_CTX_free.f' context;
	264	raise OpenSSL "Can't load trust store")
	265	else
	266	context
	267	end
	268
8be753d9	269	fun connect printErr (context, hostname) =
3b267643 AC	270	let
3b267643 AC	271	val bio = F_OpenSSL_SML_new_ssl_connect.f' context
8be753d9 AC	272
	273	val ssl_err =
	274	if printErr then
	275	ssl_err
	276	else
	277	(fn _ => ())
3b267643 AC	278	in
	279	if C.Ptr.isNull' bio then
	280	(ssl_err ("Error initializating connection to " ^ hostname);
	281	F_OpenSSL_SML_free_all.f' bio;
	282	raise OpenSSL "Can't initialize connection")
	283	else if F_OpenSSL_SML_set_conn_hostname.f' (bio, ZString.dupML' hostname) = 0 then
	284	(ssl_err ("Error setting hostname: " ^ hostname);
	285	F_OpenSSL_SML_free_all.f' bio;
	286	raise OpenSSL "Can't set hostname")
	287	else if F_OpenSSL_SML_do_connect.f' bio <= 0 then
	288	(ssl_err ("Error connecting to " ^ hostname);
	289	F_OpenSSL_SML_free_all.f' bio;
	290	raise OpenSSL "Can't connect")
	291	else
	292	bio
	293	end
	294
	295	fun close bio = F_OpenSSL_SML_free_all.f' bio
	296
60534712 AC	297	fun listen (context, port) =
	298	let
	299	val port = ZString.dupML' (Int.toString port)
	300	val listener = F_OpenSSL_SML_new_accept.f' (context, port)
	301	in
	302	C.free' port;
	303	if C.Ptr.isNull' listener then
	304	(ssl_err "Null listener";
	305	raise OpenSSL "Null listener")
	306	else if F_OpenSSL_SML_do_accept.f' listener <= 0 then
	307	(ssl_err "Error initializing listener";
	308	close listener;
	309	raise OpenSSL "Can't initialize listener")
	310	else
	311	listener
	312	end
	313
	314	val shutdown = close
	315
	316	fun accept listener =
	317	if F_OpenSSL_SML_do_accept.f' listener <= 0 then
	318	NONE
	319	else
7a150fe2 AC	320	let
	321	val bio = F_OpenSSL_SML_pop.f' listener
	322	in
	323	if C.Ptr.isNull' bio then
	324	(ssl_err "Null accepted";
	325	raise OpenSSL "Null accepted")
	326	else if F_OpenSSL_SML_do_handshake.f' bio <= 0 then
	327	(ssl_err "Handshake failed";
	328	raise OpenSSL "Handshake failed")
	329	else
	330	SOME bio
	331	end
3b267643 AC	332
	333	fun peerCN bio =
	334	let
	335	val ssl = F_OpenSSL_SML_get_ssl.f' bio
	336	val _ = if C.Ptr.isNull' ssl then
	337	raise OpenSSL "Null SSL"
	338	else
	339	()
	340	val subj = F_OpenSSL_SML_get_peer_name.f' ssl
	341	in
	342	if C.Ptr.isNull' subj then
	343	raise OpenSSL "Null CN result"
	344	else
	345	ZString.toML' subj
	346	end
	347
	348	end