(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)
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
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 =
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
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
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
context
end
-fun connect (context, hostname) =
+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);
HCoop / hcoop / domtool2.git / blobdiff