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