More helpful error message for failure to create an SSL context
[hcoop/domtool2.git] / src / openssl.sml
index ea91848..3f3b292 100644 (file)
@@ -45,79 +45,215 @@ fun ssl_err s =
        else
            (print (ZString.toML lib);
             print ":");
        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
     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
     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,
        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
 
     end
 
-fun writeAll (bio, s) =
+fun readString bio =
+    case readInt bio of
+       NONE => NONE
+      | SOME len => readLen (bio, len)
+
+fun writeChar (bio, ch) =
     let
     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
            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
            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
                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
            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
 
     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
     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
             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
             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
             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
             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
 
            ZString.toML' subj
     end
 
-fun acceptPeerCN bio = peerCN (F_OpenSSL_SML_next.f' bio)
-
 end
 end