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