Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Norelease+flush #106

Merged
merged 30 commits into from
May 23, 2023
Merged

Norelease+flush #106

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
30 commits
Select commit Hold shift + click to select a range
debd27d
raise an exception when flush encounter an error
craff Jan 10, 2023
c67854b
remove a warning building test
craff Jan 10, 2023
6fd98c1
forgot new exception in .mli
craff Jan 10, 2023
8c5e205
forgot acquire lock
craff Jan 10, 2023
365ee6f
Thread.Exit does not exist in not so old version of OCAml
craff Jan 10, 2023
7473e7b
Allow compilation on ocaml 5.0 by tolerating Thread.exit () deprecate…
craff Jan 10, 2023
847d053
Better doc for Fix_flush exception
craff May 10, 2023
30d86f6
Update src/ssl.mli
craff May 10, 2023
4690761
use [@warning -3] for the compilation of test une 5.0.0
craff May 10, 2023
fff621d
add function read_blocking/write_blocking and alike (fixes also a dep…
craff Dec 19, 2022
151b3ff
handle exception in flush so that the user can retry in case of non b…
craff Dec 20, 2022
60077e0
Update src/ssl.mli
craff May 4, 2023
9f4b9c0
Update src/ssl.mli
craff May 4, 2023
26a11b7
improvment in function names for ssl.ml
craff May 10, 2023
fff5a14
Update src/ssl.mli
craff May 10, 2023
111fed7
Merge branch 'master' into NOrelease+flush
craff May 10, 2023
0468519
Added back read_into_big_array_blocking and write_bigarray_blocking but
craff May 10, 2023
550098f
Remove SslCom
craff May 10, 2023
28ad4b5
SslCom -> SslMake
craff May 11, 2023
54d0373
Merge branch 'master' into NOrelease+flush
craff May 11, 2023
458810f
Update src/ssl.mli
craff May 12, 2023
856a5c5
new pb with Thread.exit in tests/util.ml ???
craff May 12, 2023
8d611e8
Module name: RuntimeLock
craff May 12, 2023
358177a
Retintroduce the doc un RuntimeLock to allow for editor help
craff May 12, 2023
b5c6966
lower case ident
craff May 12, 2023
2f9810a
Apply suggestions from code review
anmonteiro May 13, 2023
57b3132
Apply suggestions from code review
anmonteiro May 13, 2023
b9c4f84
Update src/ssl_stubs.c
anmonteiro May 13, 2023
62e5b84
ambiguous documentation in ssl.mli
craff May 17, 2023
606c1e5
revert embed_socket
craff May 17, 2023
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
147 changes: 101 additions & 46 deletions src/ssl.ml
View file
Open in desktop
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