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 = bio
  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 val one = Int32.fromInt 1
  63 val four = Int32.fromInt 4
  64
  65 val eight = Word.fromInt 8
  66 val sixteen = Word.fromInt 16
  67 val twentyfour = Word.fromInt 24
  68
  69 val mask1 = Word32.fromInt 255
  70
  71 fun readChar bio =
  72     let
  73         val r = F_OpenSSL_SML_read.f' (bio, C.Ptr.inject' readBuf, one)
  74     in
  75         if r = 0 then
  76             NONE
  77         else if r < 0 then
  78             (ssl_err "BIO_read";
  79              raise OpenSSL "BIO_read failed")
  80         else
  81             SOME (chr (Word32.toInt (C.Get.uchar'
  82                                          (C.Ptr.sub' C.S.uchar (readBuf, 0)))))
  83     end
  84
  85 fun readInt bio =
  86     let
  87         val r = F_OpenSSL_SML_read.f' (bio, C.Ptr.inject' readBuf, four)
  88     in
  89         if r = 0 then
  90             NONE
  91         else if r < 0 then
  92             (ssl_err "BIO_read";
  93              raise OpenSSL "BIO_read failed")
  94         else
  95             SOME (Word32.toInt
  96                       (Word32.+
  97                        (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 0)),
  98                         Word32.+
  99                         (Word32.<< (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 1)),
 100                                     eight),
 101                          Word32.+
 102                          (Word32.<< (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 2)),
 103                                      sixteen),
 104                           Word32.<< (C.Get.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 3)),
 105                                      twentyfour))))))
 106     end
 107
 108 fun readLen (bio, len) =
 109     let
 110         val buf =
 111             if len > Config.bufSize then
 112                 C.alloc' C.S.uchar (Word.fromInt len)
 113             else
 114                 readBuf
 115
 116         fun cleanup () =
 117             if len > Config.bufSize then
 118                 C.free' buf
 119             else
 120                 ()
 121
 122         fun loop (buf', needed) =
 123             let
 124                 val r = F_OpenSSL_SML_read.f' (bio, C.Ptr.inject' buf, Int32.fromInt len)
 125             in
 126                 if r = 0 then
 127                     (cleanup (); NONE)
 128                 else if r < 0 then
 129                     (cleanup ();
 130                      ssl_err "BIO_read";
 131                      raise OpenSSL "BIO_read failed")
 132                 else if r = needed then
 133                     SOME (CharVector.tabulate (Int32.toInt needed,
 134                                             fn i => chr (Word32.toInt (C.Get.uchar'
 135                                                                            (C.Ptr.sub' C.S.uchar (buf, i))))))
 136                 else
 137                     loop (C.Ptr.|+! C.S.uchar (buf', Int32.toInt r), needed - r)
 138             end
 139     in
 140         loop (buf, Int32.fromInt len)
 141         before cleanup ()
 142     end
 143
 144 fun readChunk bio =
 145     let
 146         val r = F_OpenSSL_SML_read.f' (bio, C.Ptr.inject' readBuf, bufSize)
 147     in
 148         if r = 0 then
 149             NONE
 150         else if r < 0 then
 151             (ssl_err "BIO_read";
 152              raise OpenSSL "BIO_read failed")
 153         else
 154             SOME (CharVector.tabulate (Int32.toInt r,
 155                                     fn i => chr (Word32.toInt (C.Get.uchar'
 156                                                                    (C.Ptr.sub' C.S.uchar (readBuf, i))))))
 157     end
 158
 159 fun readString bio =
 160     case readInt bio of
 161         NONE => NONE
 162       | SOME len => readLen (bio, len)
 163
 164 fun writeChar (bio, ch) =
 165     let
 166         val _ = C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 0),
 167                               Word32.fromInt (ord ch))
 168
 169         fun trier () =
 170             let
 171                 val r = F_OpenSSL_SML_write.f' (bio, C.Ptr.inject' readBuf, one)
 172             in
 173                 if r = 0 then
 174                     trier ()
 175                 else if r < 0 then
 176                     (ssl_err "BIO_write";
 177                      raise OpenSSL "BIO_write")
 178                 else
 179                     ()
 180             end
 181     in
 182         trier ()
 183     end
 184
 185 fun writeInt (bio, n) =
 186     let
 187         val w = Word32.fromInt n
 188
 189         val _ = (C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 0),
 190                                Word32.andb (w, mask1));
 191                  C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 1),
 192                                Word32.andb (Word32.>> (w, eight), mask1));
 193                  C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 2),
 194                                Word32.andb (Word32.>> (w, sixteen), mask1));
 195                  C.Set.uchar' (C.Ptr.sub' C.S.uchar (readBuf, 3),
 196                                Word32.andb (Word32.>> (w, twentyfour), mask1)))
 197
 198         fun trier (buf, count) =
 199             let
 200                 val r = F_OpenSSL_SML_write.f' (bio, C.Ptr.inject' buf, count)
 201             in
 202                 if r < 0 then
 203                     (ssl_err "BIO_write";
 204                      raise OpenSSL "BIO_write")
 205                 else if r = count then
 206                     ()
 207                 else
 208                     trier (C.Ptr.|+! C.S.uchar (buf, Int32.toInt r), count - r)
 209             end
 210     in
 211         trier (readBuf, 4)
 212     end
 213
 214 fun writeString' (bio, s) =
 215     let
 216         val buf = ZString.dupML' s
 217     in
 218         if F_OpenSSL_SML_puts.f' (bio, buf) <= 0 then
 219             (C.free' buf;
 220              ssl_err "BIO_puts";
 221              raise OpenSSL "BIO_puts")
 222         else
 223             C.free' buf
 224     end
 225
 226 fun writeString (bio, s) =
 227     (writeInt (bio, size s);
 228      writeString' (bio, s))
 229
 230 fun context (chain, key, root) =
 231     let
 232         val context = F_OpenSSL_SML_CTX_new.f' (F_OpenSSL_SML_SSLv23_method.f' ())
 233     in
 234         if C.Ptr.isNull' context then
 235             (ssl_err "Error creating SSL context";
 236              raise OpenSSL "Can't create SSL context")
 237         else if F_OpenSSL_SML_use_certificate_chain_file.f' (context,
 238                                                              ZString.dupML' chain)
 239                 = 0 then
 240             (ssl_err "Error using certificate chain";
 241              F_OpenSSL_SML_CTX_free.f' context;
 242              raise OpenSSL "Can't load certificate chain")
 243         else if F_OpenSSL_SML_use_PrivateKey_file.f' (context,
 244                                                       ZString.dupML' key)
 245                 = 0 then
 246             (ssl_err "Error using private key";
 247              F_OpenSSL_SML_CTX_free.f' context;
 248              raise OpenSSL "Can't load private key")
 249         else if F_OpenSSL_SML_load_verify_locations.f' (context,
 250                                                         ZString.dupML' root,
 251                                                         C.Ptr.null') = 0 then
 252             (ssl_err "Error loading trust store";
 253              F_OpenSSL_SML_CTX_free.f' context;
 254              raise OpenSSL "Can't load trust store")
 255         else
 256             context
 257     end
 258
 259 fun connect (context, hostname) =
 260     let
 261         val bio = F_OpenSSL_SML_new_ssl_connect.f' context
 262     in
 263         if C.Ptr.isNull' bio then
 264             (ssl_err ("Error initializating connection to " ^ hostname);
 265              F_OpenSSL_SML_free_all.f' bio;
 266              raise OpenSSL "Can't initialize connection")
 267         else if F_OpenSSL_SML_set_conn_hostname.f' (bio, ZString.dupML' hostname) = 0 then
 268             (ssl_err ("Error setting hostname: " ^ hostname);
 269              F_OpenSSL_SML_free_all.f' bio;
 270              raise OpenSSL "Can't set hostname")
 271         else if F_OpenSSL_SML_do_connect.f' bio <= 0 then
 272             (ssl_err ("Error connecting to " ^ hostname);
 273              F_OpenSSL_SML_free_all.f' bio;
 274              raise OpenSSL "Can't connect")
 275         else
 276             bio
 277     end
 278
 279 fun close bio = F_OpenSSL_SML_free_all.f' bio
 280
 281 fun listen (context, port) =
 282     let
 283         val port = ZString.dupML' (Int.toString port)
 284         val listener = F_OpenSSL_SML_new_accept.f' (context, port)
 285     in
 286         C.free' port;
 287         if C.Ptr.isNull' listener then
 288             (ssl_err "Null listener";
 289              raise OpenSSL "Null listener")
 290         else if F_OpenSSL_SML_do_accept.f' listener <= 0 then
 291             (ssl_err "Error initializing listener";
 292              close listener;
 293              raise OpenSSL "Can't initialize listener")
 294         else
 295             listener
 296     end
 297
 298 val shutdown = close
 299
 300 fun accept listener =
 301     if F_OpenSSL_SML_do_accept.f' listener <= 0 then
 302         NONE
 303     else
 304         let
 305             val bio = F_OpenSSL_SML_pop.f' listener
 306         in
 307             if C.Ptr.isNull' bio then
 308                 (ssl_err "Null accepted";
 309                  raise OpenSSL "Null accepted")
 310             else if F_OpenSSL_SML_do_handshake.f' bio <= 0 then
 311                 (ssl_err "Handshake failed";
 312                  raise OpenSSL "Handshake failed")
 313             else
 314                 SOME bio
 315         end
 316
 317 fun peerCN bio =
 318     let
 319         val ssl = F_OpenSSL_SML_get_ssl.f' bio
 320         val _ = if C.Ptr.isNull' ssl then
 321                     raise OpenSSL "Null SSL"
 322                 else
 323                     ()
 324         val subj = F_OpenSSL_SML_get_peer_name.f' ssl
 325     in
 326         if C.Ptr.isNull' subj then
 327             raise OpenSSL "Null CN result"
 328         else
 329             ZString.toML' subj
 330     end
 331
 332 end