X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/36e42cb86393a7b9e333ecd7edfbdd16c7d9a1ac..314ce7bdcb5f54a7d1763e8b6d405dc66cb65d2b:/src/openssl.sml diff --git a/src/openssl.sml b/src/openssl.sml index 7a062f1..aad3925 100644 --- a/src/openssl.sml +++ b/src/openssl.sml @@ -78,10 +78,12 @@ fun readChar bio = (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))))) + 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) @@ -94,52 +96,55 @@ fun readInt bio = else SOME (Word32.toInt (Word32.+ - (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 0)), + (charToWord (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 0))), Word32.+ - (Word32.<< (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 1)), + (Word32.<< (charToWord (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)), + (Word32.<< (charToWord (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 2))), sixteen), - Word32.<< (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 3)), + Word32.<< (charToWord (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 - () + 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 (Word32.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 @@ -152,8 +157,8 @@ fun readChunk bio = 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)))))) + fn i => chr (Compat.Char.toInt (C.Get.uchar' + (C.Ptr.sub' C.S.uchar (readBuf, i)))))) end fun readString bio = @@ -164,7 +169,7 @@ fun readString bio = fun writeChar (bio, ch) = let val _ = C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 0), - Word32.fromInt (ord ch)) + Compat.Char.fromInt (ord ch)) fun trier () = let @@ -182,18 +187,20 @@ fun writeChar (bio, ch) = 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), - Word32.andb (w, mask1)); + wordToChar (Word32.andb (w, mask1))); C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 1), - Word32.andb (Word32.>> (w, eight), mask1)); + wordToChar (Word32.andb (Word32.>> (w, eight), mask1))); C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 2), - Word32.andb (Word32.>> (w, sixteen), mask1)); + wordToChar (Word32.andb (Word32.>> (w, sixteen), mask1))); C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 3), - Word32.andb (Word32.>> (w, twentyfour), mask1))) + wordToChar (Word32.andb (Word32.>> (w, twentyfour), mask1)))) fun trier (buf, count) = let @@ -212,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