Permalink
Browse files

111.21.00

- Upgraded to use new ctypes and its new stub generation methods.
  • Loading branch information...
bmillwood committed Jun 24, 2014
1 parent 41a39d6 commit ab5ea6f55e4fee0075c0d6357c41fd43bae021f3
Showing with 225 additions and 117 deletions.
  1. +9 −0 .gitignore
  2. +26 −3 _oasis
  3. +1 −1 _tags
  4. +33 −113 lib/ffi.ml
  5. +108 −0 lib/ffi_bindings.ml
  6. +2 −0 lib/ffi_generated.mli
  7. +25 −0 lib/ffi_stubgen.ml
  8. +21 −0 myocamlbuild.ml
View
@@ -0,0 +1,9 @@
+_build/
+/setup.data
+/setup.log
+/*.exe
+/*.docdir
+/*.native
+/*.byte
+/lib/ffi_generated.ml
+/lib/ffi_generated_stubs.c
View
29 _oasis
@@ -2,7 +2,7 @@ OASISFormat: 0.3
OCamlVersion: >= 4.00.0
FindlibVersion: >= 1.3.2
Name: async_ssl
-Version: 111.08.00
+Version: 111.21.00
Synopsis: Async wrappers for ssl
Authors: Jane Street Capital LLC <opensource@janestreet.com>
Copyrights: (C) 2008-2013 Jane Street Capital LLC <opensource@janestreet.com>
@@ -25,14 +25,17 @@ Library async_ssl
FindlibName: async_ssl
Pack: true
Modules: Ffi,
+ Ffi_bindings,
+ Ffi_generated,
Import,
Ssl,
Std,
Version
+ CSources: ffi_generated_stubs.c
BuildDepends: core,
async,
ctypes,
- ctypes.foreign,
+ ctypes.stubs,
herelib,
herelib.syntax,
pa_bench,
@@ -45,11 +48,31 @@ Library async_ssl
XMETARequires: core,
async,
ctypes,
- ctypes.foreign,
+ ctypes.stubs,
herelib,
pa_bench,
pa_bench.syntax,
pa_ounit,
sexplib,
threads
CCLib: -lssl -lcrypto
+ CCOpt: -I$pkg_ctypes/..
+
+Executable ffi_stubgen
+ MainIs: ffi_stubgen.ml
+ Install: false
+ Build: false
+ Path: lib
+ BuildDepends: core,
+ async,
+ ctypes,
+ ctypes.stubs,
+ herelib,
+ herelib.syntax,
+ pa_bench,
+ pa_bench.syntax,
+ pa_ounit,
+ pa_ounit.syntax,
+ sexplib,
+ sexplib.syntax,
+ threads
View
2 _tags
@@ -1,3 +1,3 @@
-<**/*.ml{,i}> : syntax_camlp4o
+<**/*.ml{,i}>: syntax_camlp4o
# OASIS_START
# OASIS_STOP
View
@@ -2,7 +2,7 @@ open Core.Std
open Async.Std
open Import
-let foreign = Foreign.foreign
+module Bindings = Ffi_bindings.Bindings(Ffi_generated)
module Ssl_error = struct
type t =
@@ -27,26 +27,20 @@ let bigstring_strlen bigstr =
;;
let get_error_stack =
- let err_get_error =
- foreign "ERR_get_error" Ctypes.(void @-> returning ulong)
- in
- let err_error_string_n =
- foreign "ERR_error_string_n" Ctypes.(ulong @-> ptr char @-> int @-> returning void)
- in
let err_error_string =
(* We need to write error strings from C into bigstrings. To reduce allocation, reuse
scratch space for this. *)
let scratch_space = Bigstring.create 1024 in
fun err ->
- err_error_string_n
+ Bindings.err_error_string_n
err
(Ctypes.bigarray_start Ctypes.array1 scratch_space)
(Bigstring.length scratch_space);
Bigstring.to_string ~len:(bigstring_strlen scratch_space) scratch_space
in
fun () ->
iter_while_rev
- ~iter:err_get_error
+ ~iter:Bindings.err_get_error
~cond:(fun x -> x <> Unsigned.ULong.zero)
|> List.rev_map ~f:err_error_string
;;
@@ -55,84 +49,53 @@ let get_error_stack =
(* OpenSSL_add_all_algorithms is a macro, so we have to replicate it manually. :( *)
let add_all_algorithms =
- let add_all_digests =
- foreign "OpenSSL_add_all_digests" Ctypes.(void @-> returning void)
- in
- let add_all_ciphers =
- foreign "OpenSSL_add_all_ciphers" Ctypes.(void @-> returning void)
- in
fun () ->
- add_all_ciphers ();
- add_all_digests ();
+ Bindings.add_all_ciphers ();
+ Bindings.add_all_digests ();
;;
(* Call the openssl initialization method if it hasn't been already. *)
(* val possibly_init : unit -> unit *)
let possibly_init =
- let init = foreign "SSL_library_init" Ctypes.(void @-> returning ulong) in
- let ssl_load_error_strings =
- foreign "SSL_load_error_strings" Ctypes.(void @-> returning void)
- in
let initialized = ref false in
fun () ->
if not !initialized then begin
initialized := true;
(* SSL_library_init() always returns "1", so it is safe to discard the return
value. *)
- ignore (init () : Unsigned.ulong);
- ssl_load_error_strings ();
+ ignore (Bindings.init () : Unsigned.ulong);
+ Bindings.ssl_load_error_strings ();
add_all_algorithms ();
end
;;
-let ssl_method_t = Ctypes.(void @-> returning (ptr void))
-let sslv3_method = foreign "SSLv3_method" ssl_method_t
-let tlsv1_method = foreign "TLSv1_method" ssl_method_t
-let sslv23_method = foreign "SSLv23_method" ssl_method_t
-
module Ssl_ctx = struct
-
type t = unit Ctypes.ptr
let t = Ctypes.(ptr void) (* for use in ctypes type signatures *)
let sexp_of_t x = Ctypes.(ptr_diff x null) |> <:sexp_of<int>>
let create_exn =
- (* SSLv2 isn't secure, so we don't use it. If you really really really need it, use
- SSLv23 which will at least try to upgrade the security whenever possible.
-
- let sslv2_method = foreign "SSLv2_method" ssl_method_t
- *)
- let ssl_ctx_new =
- foreign "SSL_CTX_new" Ctypes.(ptr void @-> returning (ptr_opt void))
- in
- let ssl_ctx_free =
- foreign "SSL_CTX_free" Ctypes.(t @-> returning void)
- in
fun ver ->
possibly_init ();
let ver_method =
let module V = Version in
match ver with
- | V.Sslv3 -> sslv3_method ()
- | V.Tlsv1 -> tlsv1_method ()
- | V.Sslv23 -> sslv23_method ()
+ | V.Sslv3 -> Bindings.sslv3_method ()
+ | V.Tlsv1 -> Bindings.tlsv1_method ()
+ | V.Sslv23 -> Bindings.sslv23_method ()
in
- match ssl_ctx_new ver_method with
+ match Bindings.Ssl_ctx.ssl_ctx_new ver_method with
| None -> failwith "Could not allocate a new SSL context."
| Some p ->
- Gc.add_finalizer_exn p ssl_ctx_free;
+ Gc.add_finalizer_exn p Bindings.Ssl_ctx.ssl_ctx_free;
p
;;
let load_verify_locations =
- let ssl_ctx_load_verify_locations =
- foreign "SSL_CTX_load_verify_locations"
- Ctypes.(t @-> string_opt @-> string_opt @-> returning int)
- in
fun ?ca_file ?ca_path ctx ->
- In_thread.run (fun () -> ssl_ctx_load_verify_locations ctx ca_file ca_path)
+ In_thread.run (fun () -> Bindings.Ssl_ctx.ssl_ctx_load_verify_locations ctx ca_file ca_path)
>>= function
| 0 -> Deferred.return (Or_error.return ())
| _ -> Deferred.return begin
@@ -152,33 +115,21 @@ module Bio = struct
let sexp_of_t bio = Ctypes.(ptr_diff bio null) |> <:sexp_of<int>>
let create =
- let bio_new =
- foreign "BIO_new" Ctypes.(ptr void @-> returning t)
- in
- let bio_s_mem =
- foreign "BIO_s_mem" Ctypes.(void @-> returning (ptr void))
- in
fun () ->
- bio_s_mem ()
- |> bio_new
+ Bindings.Bio.bio_s_mem ()
+ |> Bindings.Bio.bio_new
;;
let read =
- let bio_read =
- foreign "BIO_read" Ctypes.(t @-> ptr char @-> int @-> returning int)
- in
fun bio ~buf ~len ->
- let retval = bio_read bio buf len in
+ let retval = Bindings.Bio.bio_read bio buf len in
if verbose then Debug.amf _here_ "BIO_read(%i) -> %i" len retval;
retval
;;
let write =
- let bio_write =
- foreign "BIO_write" Ctypes.(t @-> string @-> int @-> returning int)
- in
fun bio ~buf ~len ->
- let retval = bio_write bio buf len in
+ let retval = Bindings.Bio.bio_write bio buf len in
if verbose then Debug.amf _here_ "BIO_write(%i) -> %i" len retval;
retval
;;
@@ -193,42 +144,34 @@ module Ssl = struct
let sexp_of_t ssl = Ctypes.(ptr_diff ssl null) |> <:sexp_of<int>>
let create_exn =
- let ssl_new = foreign "SSL_new" Ctypes.(Ssl_ctx.t @-> returning t) in
- let ssl_free = foreign "SSL_free" Ctypes.( t @-> returning void) in
fun ctx ->
- let p = ssl_new ctx in
+ let p = Bindings.Ssl.ssl_new ctx in
if p = Ctypes.null
then failwith "Unable to allocate an SSL connection."
else begin
- Gc.add_finalizer_exn p ssl_free;
+ Gc.add_finalizer_exn p Bindings.Ssl.ssl_free;
p
end
;;
let set_method =
- let ssl_set_method =
- foreign "SSL_set_ssl_method" Ctypes.(t @-> ptr void @-> returning int)
- in
fun t version ->
let version_method =
let open Version in
match version with
- | Sslv3 -> sslv3_method ()
- | Tlsv1 -> tlsv1_method ()
- | Sslv23 -> sslv23_method ()
+ | Sslv3 -> Bindings.sslv3_method ()
+ | Tlsv1 -> Bindings.tlsv1_method ()
+ | Sslv23 -> Bindings.sslv23_method ()
in
- match ssl_set_method t version_method with
+ match Bindings.Ssl.ssl_set_method t version_method with
| 1 -> ()
| e -> failwithf "Failed to set SSL version: %i" e ()
;;
let get_error =
- let ssl_get_error =
- foreign "SSL_get_error" Ctypes.(ptr void @-> int @-> returning int)
- in
let module E = Ssl_error in
fun ssl ~retval ->
- ssl_get_error ssl retval
+ Bindings.Ssl.ssl_get_error ssl retval
|> function
| 1 -> Error E.Ssl_error
| 2 -> Error E.Want_read
@@ -242,60 +185,43 @@ module Ssl = struct
;;
let set_initial_state =
- let ssl_set_connect_state =
- foreign "SSL_set_connect_state" Ctypes.(t @-> returning void)
- in
- let ssl_set_accept_state =
- foreign "SSL_set_accept_state" Ctypes.(t @-> returning void)
- in
fun ssl -> function
- | `Connect -> ssl_set_connect_state ssl
- | `Accept -> ssl_set_accept_state ssl
+ | `Connect -> Bindings.Ssl.ssl_set_connect_state ssl
+ | `Accept -> Bindings.Ssl.ssl_set_accept_state ssl
;;
let connect =
- let ssl_connect = foreign "SSL_connect" Ctypes.(t @-> returning int) in
fun ssl ->
- let retval = ssl_connect ssl in
+ let retval = Bindings.Ssl.ssl_connect ssl in
Result.(get_error ssl ~retval
>>= fun _ ->
if verbose then Debug.amf _here_ "SSL_connect -> %i" retval;
return ())
;;
let accept =
- let ssl_accept = foreign "SSL_accept" Ctypes.(t @-> returning int) in
fun ssl ->
- let retval = ssl_accept ssl in
+ let retval = Bindings.Ssl.ssl_accept ssl in
Result.(get_error ssl ~retval
>>= fun _ ->
if verbose then Debug.amf _here_ "SSL_accept -> %i" retval;
return ())
let set_bio =
- let ssl_set_bio =
- foreign "SSL_set_bio" Ctypes.(t @-> Bio.t @-> Bio.t @-> returning void)
- in
fun ssl ~input ~output ->
- ssl_set_bio ssl input output
+ Bindings.Ssl.ssl_set_bio ssl input output
;;
let read =
- let ssl_read =
- foreign "SSL_read" Ctypes.(t @-> ptr char @-> int @-> returning int)
- in
fun ssl ~buf ~len ->
- let retval = ssl_read ssl buf len in
+ let retval = Bindings.Ssl.ssl_read ssl buf len in
if verbose then Debug.amf _here_ "SSL_read(%i) -> %i" len retval;
get_error ssl ~retval
;;
let write =
- let ssl_write =
- foreign "SSL_write" Ctypes.(t @-> string @-> int @-> returning int)
- in
fun ssl ~buf ~len ->
- let retval = ssl_write ssl buf len in
+ let retval = Bindings.Ssl.ssl_write ssl buf len in
if verbose then Debug.amf _here_ "SSL_write(%i) -> %i" len retval;
get_error ssl ~retval
;;
@@ -306,26 +232,20 @@ module Ssl = struct
;;
let use_certificate_file =
- let ssl_use_certificate_file =
- foreign "SSL_use_certificate_file" Ctypes.(t @-> string @-> int @-> returning int)
- in
fun ssl ~crt ~file_type ->
let c_enum = type_to_c_enum file_type in
In_thread.run (fun () ->
- let retval = ssl_use_certificate_file ssl crt c_enum in
+ let retval = Bindings.Ssl.ssl_use_certificate_file ssl crt c_enum in
if retval > 0
then Ok ()
else Error (get_error_stack ()))
;;
let use_private_key_file =
- let ssl_use_private_key_file =
- foreign "SSL_use_PrivateKey_file" Ctypes.(t @-> string @-> int @-> returning int)
- in
fun ssl ~key ~file_type ->
let c_enum = type_to_c_enum file_type in
In_thread.run (fun () ->
- let retval = ssl_use_private_key_file ssl key c_enum in
+ let retval = Bindings.Ssl.ssl_use_private_key_file ssl key c_enum in
if retval > 0
then Ok ()
else Error (get_error_stack ()))
Oops, something went wrong.

0 comments on commit ab5ea6f

Please sign in to comment.