Skip to content

Commit

Permalink
feat: add Ssl.Runtime_lock with compatible API that doesn't release…
Browse files Browse the repository at this point in the history 
… the OCaml runtime lock (#106)


Co-authored-by: Antonio Nuno Monteiro <anmonteiro@gmail.com>
Co-authored-by: Romain Beauxis <toots@rastageeks.org>
  • Loading branch information
@craff @anmonteiro @toots
3 people committed May 23, 2023
1 parent 37e44db commit 5420c29
Show file tree
Hide file tree
Showing 4 changed files with 333 additions and 92 deletions.
147 changes: 101 additions & 46 deletions src/ssl.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -248,8 +248,6 @@ external set_alpn_protos : socket -> string list -> unit = "ocaml_ssl_set_alpn_p

external get_negotiated_alpn_protocol : socket -> string option = "ocaml_ssl_get_negotiated_alpn_protocol"

external connect : socket -> unit = "ocaml_ssl_connect"

external verify : socket -> unit = "ocaml_ssl_verify"

type x509_check_flag =
Expand All @@ -265,91 +263,148 @@ external set_host : socket -> string -> unit = "ocaml_ssl_set1_host"

external set_ip : socket -> string -> unit = "ocaml_ssl_set1_ip"

external write : socket -> Bytes.t -> int -> int -> int = "ocaml_ssl_write"
(* Here is the signature of the base communication functions that are
implemented below in two versions *)
module type Ssl_base = sig
val connect : socket -> unit
val accept : socket -> unit
val ssl_shutdown : socket -> bool
val flush : socket -> unit
val read : socket -> Bytes.t -> int -> int -> int
val read_into_bigarray : socket -> bigarray -> int -> int -> int
val write : socket -> Bytes.t -> int -> int -> int
val write_substring : socket -> string -> int -> int -> int
val write_bigarray : socket -> bigarray -> int -> int -> int
end

(* Provide the base implementation communication functions that release
the OCaml runtime lock, allowing multiple systhreads to execute concurrently. *)
module Runtime_unlock_base = struct
external connect : socket -> unit = "ocaml_ssl_connect"

external accept : socket -> unit = "ocaml_ssl_accept"

external write : socket -> Bytes.t -> int -> int -> int = "ocaml_ssl_write"
external write_substring : socket -> string -> int -> int -> int
= "ocaml_ssl_write"
external write_bigarray : socket -> bigarray -> int -> int -> int
= "ocaml_ssl_write_bigarray"

external read : socket -> Bytes.t -> int -> int -> int = "ocaml_ssl_read"
external read_into_bigarray :
socket -> bigarray -> int -> int -> int = "ocaml_ssl_read_into_bigarray"

external flush : socket -> unit = "ocaml_ssl_flush"

external write_substring : socket -> string -> int -> int -> int = "ocaml_ssl_write"
external ssl_shutdown : socket -> bool = "ocaml_ssl_shutdown"
end

external write_bigarray : socket -> bigarray -> int -> int -> int = "ocaml_ssl_write_bigarray"
(* Same as above, but doesn't release the lock. *)
module Runtime_lock_base = struct
external connect : socket -> unit = "ocaml_ssl_connect"

external write_bigarray_blocking :
socket -> bigarray -> int -> int -> int = "ocaml_ssl_write_bigarray_blocking"
external accept : socket -> unit = "ocaml_ssl_accept_blocking"

external read : socket -> Bytes.t -> int -> int -> int = "ocaml_ssl_read"
external write : socket -> Bytes.t -> int -> int -> int
= "ocaml_ssl_write_blocking"
external write_substring : socket -> string -> int -> int -> int
= "ocaml_ssl_write_blocking"
external write_bigarray : socket -> bigarray -> int -> int -> int
= "ocaml_ssl_write_bigarray_blocking"

external read_into_bigarray :
socket -> bigarray -> int -> int -> int = "ocaml_ssl_read_into_bigarray"
external read : socket -> Bytes.t -> int -> int -> int
= "ocaml_ssl_read_blocking"

external read_into_bigarray_blocking :
socket -> bigarray -> int -> int -> int = "ocaml_ssl_read_into_bigarray_blocking"
external read_into_bigarray :
socket -> bigarray -> int -> int -> int = "ocaml_ssl_read_into_bigarray_blocking"

external accept : socket -> unit = "ocaml_ssl_accept"
external flush : socket -> unit = "ocaml_ssl_flush_blocking"

external flush : socket -> unit = "ocaml_ssl_flush"
external ssl_shutdown : socket -> bool = "ocaml_ssl_shutdown_blocking"

external ssl_shutdown : socket -> bool = "ocaml_ssl_shutdown"
end

let open_connection_with_context context sockaddr =
let domain = Unix.domain_of_sockaddr sockaddr in
let sock =
Unix.socket domain Unix.SOCK_STREAM 0 in
(* The functor implementing communication functions from a structure of type
Ssl_base *)
module Make(Ssl_base: Ssl_base) = struct
include Ssl_base

let open_connection_with_context context sockaddr =
let domain = Unix.domain_of_sockaddr sockaddr in
let sock =
Unix.socket domain Unix.SOCK_STREAM 0 in
try
Unix.connect sock sockaddr;
let ssl = embed_socket sock context in
connect ssl; ssl
connect ssl; ssl
with
| exn -> Unix.close sock; raise exn
| exn -> Unix.close sock; raise exn

let open_connection ssl_method sockaddr =
open_connection_with_context (create_context ssl_method Client_context) sockaddr

let open_connection ssl_method sockaddr =
open_connection_with_context (create_context ssl_method Client_context) sockaddr

let close_notify = ssl_shutdown
let close_notify = ssl_shutdown

let shutdown sock =
if not (close_notify sock)
then ignore (close_notify sock : bool)
let shutdown sock =
if not (close_notify sock)
then ignore (close_notify sock : bool)

let shutdown_connection = shutdown
let shutdown_connection = shutdown

let output_string ssl s =
ignore (write_substring ssl s 0 (String.length s))
let output_string ssl s =
ignore (write_substring ssl s 0 (String.length s))

let output_char ssl c =
let tmp = String.make 1 c in
let output_char ssl c =
let tmp = String.make 1 c in
ignore (write_substring ssl tmp 0 1)

let output_int ssl i =
let tmp = Bytes.create 4 in
let output_int ssl i =
let tmp = Bytes.create 4 in
Bytes.set tmp 0 (char_of_int (i lsr 24));
Bytes.set tmp 1 (char_of_int ((i lsr 16) land 0xff));
Bytes.set tmp 2 (char_of_int ((i lsr 8) land 0xff));
Bytes.set tmp 3 (char_of_int (i land 0xff));
if write ssl tmp 0 4 <> 4 then failwith "output_int error: all the byte were not sent"

let input_string ssl =
let bufsize = 1024 in
let buf = Bytes.create bufsize in
let ret = ref "" in
let r = ref 1 in
if write ssl tmp 0 4 <> 4 then
failwith "output_int error: all the byte were not sent"

let input_string ssl =
let bufsize = 1024 in
let buf = Bytes.create bufsize in
let ret = ref "" in
let r = ref 1 in
while !r <> 0
do
r := read ssl buf 0 bufsize;
ret := !ret ^ (Bytes.sub_string buf 0 !r)
done;
!ret

let input_char ssl =
let tmp = Bytes.create 1 in
let input_char ssl =
let tmp = Bytes.create 1 in
if read ssl tmp 0 1 <> 1 then
raise End_of_file
else
Bytes.get tmp 0

let input_int ssl =
let i = ref 0 in
let tmp = Bytes.create 4 in
let input_int ssl =
let i = ref 0 in
let tmp = Bytes.create 4 in
ignore (read ssl tmp 0 4);
i := int_of_char (Bytes.get tmp 0);
i := (!i lsl 8) + int_of_char (Bytes.get tmp 1);
i := (!i lsl 8) + int_of_char (Bytes.get tmp 2);
i := (!i lsl 8) + int_of_char (Bytes.get tmp 3);
!i

end

(* We apply the functor twice. The releasing functions are imported as default *)
include Make(Runtime_unlock_base)
module Runtime_lock = Make(Runtime_lock_base)

(** Deprecated functions for compatibility with older version *)
let read_into_bigarray_blocking : socket -> bigarray -> int -> int -> int
= Runtime_lock.read_into_bigarray
let write_bigarray_blocking : socket -> bigarray -> int -> int -> int
= Runtime_lock.write_bigarray
Loading

0 comments on commit 5420c29

Please sign in to comment.