X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/7a150fe2efd23c4aeeb7262f614b2d31e4455287..d22c1f00ed619c221dc9891c86c5ced202a9ee77:/src/openssl.sml diff --git a/src/openssl.sml b/src/openssl.sml index ea91848..3f3b292 100644 --- a/src/openssl.sml +++ b/src/openssl.sml @@ -45,79 +45,215 @@ 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) 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 readOne bio = +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) = + 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 - raise OpenSSL "BIO_read failed" + (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)))))) + fn i => chr (Compat.Char.toInt (C.Get.uchar' + (C.Ptr.sub' C.S.uchar (readBuf, i)))))) end -fun writeAll (bio, s) = +fun readString bio = + case readInt bio of + NONE => NONE + | SOME len => readLen (bio, len) + +fun writeChar (bio, ch) = let - val buf = ZString.dupML' s + val _ = C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 0), + Compat.Char.fromInt (ord ch)) - fun loop (buf, len) = + fun trier () = let - val r = F_OpenSSL_SML_write.f' (bio, C.Ptr.inject' buf, len) + val r = F_OpenSSL_SML_write.f' (bio, C.Ptr.inject' readBuf, one) in - if r = len then + 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 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)) + trier (C.Ptr.|+! C.S.uchar (buf, Int32.toInt r), count - r) end in - loop (buf, Int32.fromInt (size s)); - C.free' buf + 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 context (chain, key, root) = +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 - (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 @@ -197,6 +333,4 @@ fun peerCN bio = ZString.toML' subj end -fun acceptPeerCN bio = peerCN (F_OpenSSL_SML_next.f' bio) - end