libmojave/util/lm_ssl.ml

   1 (*
   2  * Interface to Open SSL.
   3  *
   4  * ----------------------------------------------------------------
   5  *
   6  * @begin[license]
   7  * Copyright (C) 2004 Mojave Group, Caltech
   8  *
   9  * This library is free software; you can redistribute it and/or
  10  * modify it under the terms of the GNU Lesser General Public
  11  * License as published by the Free Software Foundation,
  12  * version 2.1 of the License.
  13  *
  14  * This library is distributed in the hope that it will be useful,
  15  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  16  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17  * Lesser General Public License for more details.
  18  *
  19  * You should have received a copy of the GNU Lesser General Public
  20  * License along with this library; if not, write to the Free Software
  21  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
  22  *
  23  * Additional permission is given to link this library with the
  24  * OpenSSL project's "OpenSSL" library, and with the OCaml runtime,
  25  * and you may distribute the linked executables.  See the file
  26  * LICENSE.libmojave for more details.
  27  *
  28  * Author: Jason Hickey
  29  * @email{jyh@cs.caltech.edu}
  30  * @end[license]
  31  *)
  32 let eprintf = Printf.eprintf
  33 let eflush out =
  34    output_char out '\n';
  35    flush out
  36
  37 open Lm_make_printf
  38
  39 (*
  40  * Define hooks to C code.
  41  *)
  42 type t
  43 type ssl = t
  44
  45 exception SSLSigPipe
  46
  47 external socket         : string -> t                        = "lm_ssl_socket"
  48 external bind           : t -> Unix.inet_addr -> int -> unit = "lm_ssl_bind"
  49 external getsockname    : t -> Unix.inet_addr * int          = "lm_ssl_get_addr"
  50 external listen         : t -> string -> int -> unit         = "lm_ssl_listen"
  51 external accept         : t -> t                             = "lm_ssl_accept"
  52 external connect        : t -> Unix.inet_addr -> int -> unit = "lm_ssl_connect"
  53 external shutdown       : t -> unit                          = "lm_ssl_shutdown"
  54 external close          : t -> unit                          = "lm_ssl_close"
  55
  56 (*
  57  * For restarting from an existing socket.
  58  *)
  59 external fd             : t -> int                           = "lm_ssl_fd"
  60 external serve          : int -> string -> string -> t       = "lm_ssl_serve"
  61
  62 (*
  63  * Private functions.
  64  *)
  65 external lm_ssl_enabled  : unit -> bool                       = "lm_ssl_enabled"
  66 external lm_ssl_init     : unit -> unit                       = "lm_ssl_init"
  67 external lm_ssl_read     : t -> string -> int -> int -> int   = "lm_ssl_read"
  68 external lm_ssl_write    : t -> string -> int -> int -> int   = "lm_ssl_write"
  69 external lm_ssl_flush    : t -> unit                          = "lm_ssl_flush"
  70
  71 (*
  72  * Initialize.
  73  *)
  74 let () = lm_ssl_init ()
  75 let enabled = lm_ssl_enabled ()
  76
  77 (*
  78  * Buffered output channel.
  79  *)
  80 module OutChannel =
  81 struct
  82    (* Some buffer type *)
  83    type t =
  84       { mutable windex : int;
  85         buffer : string;
  86         ssl    : ssl
  87       }
  88
  89    type result = unit
  90
  91    (* Buffer length is 1k *)
  92    let buf_length = 1 lsl 10
  93
  94    (* Create the output channel *)
  95    let create ssl =
  96       { windex = 0;
  97         buffer = String.create buf_length;
  98         ssl = ssl
  99       }
 100
 101    (* Flush the output *)
 102    let flush out =
 103       let { windex = windex;
 104             buffer = buf;
 105             ssl = ssl
 106           } = out
 107       in
 108       let rec flush off =
 109          if off < windex then
 110             let amount = lm_ssl_write ssl buf off (windex - off) in
 111                if amount <= 0 then
 112                   raise SSLSigPipe;
 113                flush (off + amount)
 114       in
 115          flush 0;
 116          out.windex <- 0
 117
 118    (* Close the output channel *)
 119    let close out =
 120       flush out;
 121       close out.ssl
 122
 123    (*
 124     * Add a single character.
 125     *)
 126    let print_char out c =
 127       let { windex = windex;
 128             buffer = buf
 129           } = out
 130       in
 131       let windex' = succ windex in
 132          buf.[windex] <- c;
 133          out.windex <- windex';
 134          if windex' = buf_length then
 135             flush out
 136
 137    (*
 138     * Add a string.
 139     *)
 140    let rec output out s off len =
 141       if len <> 0 then
 142          let { windex = windex;
 143                buffer = buf
 144              } = out
 145          in
 146          let amount = min len (buf_length - windex) in
 147          let windex' = windex + amount in
 148             String.blit s off buf windex amount;
 149             out.windex <- windex';
 150             if windex' = buf_length then
 151                flush out;
 152             output out s (off + amount) (len - amount)
 153
 154    let print_string out s =
 155       output out s 0 (String.length s)
 156
 157    (*
 158     * Formatting functions are ignored.
 159     *)
 160    let open_box _ _ = ()
 161    let open_hbox _ = ()
 162    let open_vbox _ _ = ()
 163    let open_hvbox _ _ = ()
 164    let open_hovbox _ _ = ()
 165    let close_box _ = ()
 166
 167    (*
 168     * These formatting actions are partially handled.
 169     *)
 170    let print_cut _ =
 171       ()
 172
 173    let print_space out =
 174       print_char out ' '
 175
 176    let force_newline out =
 177       print_char out '\n'
 178
 179    let print_break _ _ _ =
 180       ()
 181
 182    let print_flush out =
 183       flush out;
 184       lm_ssl_flush out.ssl
 185
 186    let print_newline =
 187       force_newline
 188
 189    let exit _out =
 190       ()
 191 end
 192
 193 module Printf = MakePrintf (OutChannel)
 194
 195 type ssl_out = OutChannel.t
 196
 197 let out_channel_of_ssl = OutChannel.create
 198 let output_char = OutChannel.print_char
 199 let output_string = OutChannel.print_string
 200 let output_buffer out buf =
 201    output_string out (Buffer.contents buf)
 202 let output = OutChannel.output
 203 let flush = OutChannel.flush
 204 let close_out = OutChannel.close
 205
 206 let fprintf = Printf.fprintf
 207
 208 (*
 209  * Input channel.
 210  *)
 211 module InChannel =
 212 struct
 213    type t =
 214       { mutable rindex : int;
 215         mutable length : int;
 216         buffer : string;
 217         ssl : ssl
 218       }
 219
 220    (*
 221     * Input buffer is 1k.
 222     *)
 223    let buf_length = 1 lsl 10
 224
 225    (*
 226     * Create the buffer.
 227     *)
 228    let create ssl =
 229       { rindex = 0;
 230         length = 0;
 231         buffer = String.create buf_length;
 232         ssl = ssl
 233       }
 234
 235    let close inx =
 236       close inx.ssl
 237
 238    (*
 239     * Fill input.
 240     *)
 241    let rec fill inx =
 242       let { rindex = rindex;
 243             length = length;
 244             buffer = buf;
 245             ssl = ssl
 246           } = inx
 247       in
 248          if length <> 0 && rindex = length then
 249             begin
 250                inx.rindex <- 0;
 251                inx.length <- 0;
 252                fill inx
 253             end
 254          else if length <> buf_length then
 255             begin
 256                let amount = lm_ssl_read ssl buf length (buf_length - length) in
 257                   if amount <= 0 then
 258                      raise End_of_file;
 259                   inx.length <- length + amount
 260             end
 261
 262    (*
 263     * Get a character.
 264     *)
 265    let rec input_char inx =
 266       let { rindex = rindex;
 267             length = length;
 268             buffer = buf
 269           } = inx
 270       in
 271          if rindex = length then
 272             begin
 273                fill inx;
 274                input_char inx
 275             end
 276          else
 277             let c = buf.[rindex] in
 278                inx.rindex <- succ rindex;
 279                c
 280
 281    (*
 282     * Get a line.
 283     *)
 284    let rec input_line_aux out inx =
 285       let { rindex = rindex;
 286             length = length;
 287             buffer = buf
 288           } = inx
 289       in
 290       let rec collect rindex =
 291          if rindex = length then
 292             let filled =
 293                inx.rindex <- rindex;
 294                try fill inx; true with
 295                   End_of_file ->
 296                      false
 297             in
 298                if filled then
 299                   input_line_aux out inx
 300                else
 301                   Buffer.contents out
 302          else
 303             let c = buf.[rindex] in
 304                if c = '\n' then
 305                   begin
 306                      inx.rindex <- succ rindex;
 307                      Buffer.contents out
 308                   end
 309                else
 310                   begin
 311                      Buffer.add_char out c;
 312                      collect (succ rindex)
 313                   end
 314       in
 315          collect rindex
 316
 317    let input_line inx =
 318       if inx.rindex = inx.length then
 319          fill inx;
 320       input_line_aux (Buffer.create 64) inx
 321
 322    (*
 323     * Get some input.
 324     * Try to optimize this case a little, and
 325     * copy directly into the buffer if possible.
 326     *)
 327    let rec really_input_start inx s off len =
 328       let { rindex = rindex;
 329             length = length;
 330             buffer = buf
 331           } = inx
 332       in
 333       let amount = min len (length - rindex) in
 334       let () =
 335          String.blit buf rindex s off amount;
 336          inx.rindex <- rindex + amount
 337       in
 338          let off = off + amount in
 339          let len = len - amount in
 340             if len <> 0 then
 341                really_input_middle inx s off len
 342
 343    and really_input_middle inx s off len =
 344       if len < buf_length then
 345          really_input_end inx s off len
 346       else
 347          let amount = lm_ssl_read inx.ssl s off len in
 348          let () =
 349             if amount <= 0 then
 350                raise End_of_file
 351          in
 352          let off = off + amount in
 353          let len = len - amount in
 354             really_input_middle inx s off len
 355
 356    and really_input_end inx s off len =
 357       let { rindex = rindex;
 358             length = length;
 359             buffer = buf
 360           } = inx
 361       in
 362          if length - rindex < len then
 363             begin
 364                fill inx;
 365                really_input_end inx s off len
 366             end
 367          else
 368             begin
 369                String.blit buf rindex s off len;
 370                inx.rindex <- rindex + len
 371             end
 372
 373    let really_input = really_input_start
 374 end
 375
 376 type ssl_in = InChannel.t
 377
 378 let in_channel_of_ssl = InChannel.create
 379 let input_char = InChannel.input_char
 380 let input_line = InChannel.input_line
 381 let really_input = InChannel.really_input
 382 let close_in = InChannel.close
 383
 384 (*!
 385  * @docoff
 386  *
 387  * -*-
 388  * Local Variables:
 389  * Caml-master: "compile"
 390  * End:
 391  * -*-
 392  *)