src/openssl.sml

   1 (* HCoop Domtool (http://hcoop.sourceforge.net/)
   2  * Copyright (c) 2006, Adam Chlipala
   3  *
   4  * This program is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU General Public License
   6  * as published by the Free Software Foundation; either version 2
   7  * of the License, or (at your option) any later version.
   8  *
   9  * This program is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12  * GNU General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU General Public License
  15  * along with this program; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
  17  *)
  18
  19 (* OpenSSL *)
  20
  21 structure OpenSSL :> OPENSSL = struct
  22
  23 val () = (F_OpenSSL_SML_init.f' ();
  24           F_OpenSSL_SML_load_error_strings.f' ();
  25           F_OpenSSL_SML_load_BIO_strings.f' ())
  26
  27 exception OpenSSL of string
  28
  29 type context = (ST_ssl_ctx_st.tag, C_Int.rw) C_Int.su_obj C_Int.ptr'
  30 type bio = (ST_bio_st.tag, C_Int.rw) C_Int.su_obj C_Int.ptr'
  31 type listener = MLRep.Signed.int
  32
  33 fun ssl_err s =
  34     let
  35         val err = F_OpenSSL_SML_get_error.f ()
  36
  37         val lib = F_OpenSSL_SML_lib_error_string.f err
  38         val func = F_OpenSSL_SML_func_error_string.f err
  39         val reason = F_OpenSSL_SML_reason_error_string.f err
  40     in
  41         print s;
  42         print "\nReason: ";
  43         if C.Ptr.isNull lib then
  44             ()
  45         else
  46             (print (ZString.toML lib);
  47              print ":");
  48         if C.Ptr.isNull func then
  49             ()
  50         else
  51             (print (ZString.toML func);
  52              print ":");
  53         if C.Ptr.isNull reason then
  54             ()
  55         else
  56             print (ZString.toML reason);
  57         print "\n"
  58     end
  59
  60 val readBuf : (C.uchar, C.rw) C.obj C.ptr' = C.alloc' C.S.uchar (Word.fromInt Config.bufSize)
  61 val bufSize = Int32.fromInt Config.bufSize
  62
  63 fun readOne bio =
  64     let
  65         val r = F_OpenSSL_SML_read.f' (bio, C.Ptr.inject' readBuf, bufSize)
  66     in
  67         if r = 0 then
  68             NONE
  69         else if r < 0 then
  70             raise OpenSSL "BIO_read failed"
  71         else
  72             SOME (CharVector.tabulate (Int32.toInt r,
  73                                     fn i => chr (Word32.toInt (C.Get.uchar'
  74                                                                    (C.Ptr.sub' C.S.uchar (readBuf, i))))))
  75     end
  76
  77 fun writeAll (bio, s) =
  78     let
  79         val buf = ZString.dupML' s
  80
  81         fun loop (buf, len) =
  82             let
  83                 val r = F_OpenSSL_SML_write.f' (bio, C.Ptr.inject' buf, len)
  84             in
  85                 if r = len then
  86                     ()
  87                 else if r <= 0 then
  88                     (C.free' buf;
  89                      raise OpenSSL "BIO_write failed")
  90                 else
  91                     loop (C.Ptr.|+! C.S.uchar (buf, Int32.toInt r), Int32.- (len, r))
  92             end
  93     in
  94         loop (buf, Int32.fromInt (size s));
  95         C.free' buf
  96     end
  97
  98 fun context (chain, key, root) =
  99     let
 100         val context = F_OpenSSL_SML_CTX_new.f' (F_OpenSSL_SML_SSLv23_method.f' ())
 101     in
 102         if C.Ptr.isNull' context then
 103             (ssl_err "Error creating SSL context";
 104              raise OpenSSL "Can't create SSL context")
 105         else if F_OpenSSL_SML_use_certificate_chain_file.f' (context,
 106                                                              ZString.dupML' chain)
 107                 = 0 then
 108             (ssl_err "Error using certificate chain";
 109              F_OpenSSL_SML_CTX_free.f' context;
 110              raise OpenSSL "Can't load certificate chain")
 111         else if F_OpenSSL_SML_use_PrivateKey_file.f' (context,
 112                                                       ZString.dupML' key)
 113                 = 0 then
 114             (ssl_err "Error using private key";
 115              F_OpenSSL_SML_CTX_free.f' context;
 116              raise OpenSSL "Can't load private key")
 117         else if F_OpenSSL_SML_load_verify_locations.f' (context,
 118                                                         ZString.dupML' root,
 119                                                         C.Ptr.null') = 0 then
 120             (ssl_err "Error loading trust store";
 121              F_OpenSSL_SML_CTX_free.f' context;
 122              raise OpenSSL "Can't load trust store")
 123         else
 124             context
 125     end
 126
 127 fun connect (context, hostname) =
 128     let
 129         val bio = F_OpenSSL_SML_new_ssl_connect.f' context
 130     in
 131         if C.Ptr.isNull' bio then
 132             (ssl_err ("Error initializating connection to " ^ hostname);
 133              F_OpenSSL_SML_free_all.f' bio;
 134              raise OpenSSL "Can't initialize connection")
 135         else if F_OpenSSL_SML_set_conn_hostname.f' (bio, ZString.dupML' hostname) = 0 then
 136             (ssl_err ("Error setting hostname: " ^ hostname);
 137              F_OpenSSL_SML_free_all.f' bio;
 138              raise OpenSSL "Can't set hostname")
 139         else if F_OpenSSL_SML_do_connect.f' bio <= 0 then
 140             (ssl_err ("Error connecting to " ^ hostname);
 141              F_OpenSSL_SML_free_all.f' bio;
 142              raise OpenSSL "Can't connect")
 143         else
 144             bio
 145     end
 146
 147 fun close bio = F_OpenSSL_SML_free_all.f' bio
 148
 149 fun listen (port, qsize) = F_OpenSSL_SML_tcp_listen.f' (Int32.fromInt port, Int32.fromInt qsize)
 150 fun shutdown sock = F_OpenSSL_SML_shutdown.f' sock
 151
 152 fun accept (context, sock) =
 153      let
 154          val sock' = F_OpenSSL_SML_accept.f' sock
 155      in
 156          if Int32.< (sock', Int32.fromInt 0) then
 157              NONE
 158          else let
 159                  val bio = F_OpenSSL_SML_new_socket.f' sock'
 160                  val ssl = F_OpenSSL_SML_SSL_new.f' context
 161              in
 162                  if C.Ptr.isNull' bio then
 163                      (ssl_err "Error initializating accepter";
 164                       F_OpenSSL_SML_free_all.f' bio;
 165                       raise OpenSSL "Can't initialize accepter")
 166                  else if (F_OpenSSL_SML_SSL_set_bio.f' (ssl, bio, bio);
 167                           F_OpenSSL_SML_SSL_accept.f' ssl) <= 0 then
 168                      (ssl_err "Error accepting connection";
 169                       F_OpenSSL_SML_free_all.f' bio;
 170                       raise OpenSSL "Can't accept connection")
 171                  else
 172                      SOME bio
 173              end
 174      end
 175
 176 fun peerCN bio =
 177     let
 178         val ssl = F_OpenSSL_SML_get_ssl.f' bio
 179         val _ = if C.Ptr.isNull' ssl then
 180                     raise OpenSSL "Null SSL"
 181                 else
 182                     ()
 183         val subj = F_OpenSSL_SML_get_peer_name.f' ssl
 184     in
 185         if C.Ptr.isNull' subj then
 186             raise OpenSSL "Null CN result"
 187         else
 188             ZString.toML' subj
 189     end
 190
 191 end