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