X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/a49a9bfbe03214c68d029fe856a56006267bc8a3..314ce7bdcb5f54a7d1763e8b6d405dc66cb65d2b:/src/openssl.sml

diff --git a/src/openssl.sml b/src/openssl.sml
index 9ebb959..aad3925 100644
--- a/src/openssl.sml
+++ b/src/openssl.sml
@@ -45,16 +45,16 @@ fun ssl_err s =
 	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"
+	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)
@@ -108,40 +108,43 @@ fun readInt bio =
     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
-		()
+    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 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))))))
+	    fun cleanup () =
+		if len > Config.bufSize then
+		    C.free' buf
 		else
-		    loop (C.Ptr.|+! C.S.uchar (buf', Int32.toInt r), needed - r)
-	    end
-    in
-	loop (buf, Int32.fromInt len)
-	before cleanup ()
-    end	
+		    ()
+
+	    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
@@ -216,44 +219,47 @@ fun writeInt (bio, n) =
     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
+    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 (chain, key, root) =
+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
-	    (ssl_err "Error creating SSL context";
+	    (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
-	    (ssl_err "Error using certificate chain";
+	    (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
-	    (ssl_err "Error using private key";
+	    (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
-	    (ssl_err "Error loading trust store";
+	    (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