From 582003997e6d1cb5c8fd74f58d6fdc35574e6230 Mon Sep 17 00:00:00 2001 From: Christophe Raffalli Date: Fri, 2 Jun 2023 01:02:40 -1000 Subject: [PATCH 01/12] Add a way to set context mode when creating context + distinct default mode for blocking and Runtime_lock. Also test Runtime_lock --- src/ssl.ml | 31 ++++++++++- src/ssl.mli | 51 ++++++++++++++++- src/ssl_stubs.c | 6 +- tests/dune | 11 ++++ tests/ssl_rlock_io.ml | 126 ++++++++++++++++++++++++++++++++++++++++++ tests/util_rlock.ml | 98 ++++++++++++++++++++++++++++++++ 6 files changed, 317 insertions(+), 6 deletions(-) create mode 100644 tests/ssl_rlock_io.ml create mode 100644 tests/util_rlock.ml diff --git a/src/ssl.ml b/src/ssl.ml index 24267ae..1f15c6e 100644 --- a/src/ssl.ml +++ b/src/ssl.ml @@ -77,6 +77,26 @@ type verify_error = | Error_v_keyusage_no_certsign | Error_v_application_verification +module Modes = struct + type t = int + + let no_mode = 0x000 + let enable_partial_write = 0x001 + (*let accept_moving_write_buffer = 0x002: is always set because of GC*) + let auto_retry = 0x004 + let no_auto_chain = 0x008 + let release_buffers = 0x010 + let send_clienthello_time = 0x020 + let send_serverhello_time = 0x040 + let send_fallback_scsv = 0x080 + let async = 0x100 + + let (lor) = (lor) +end + + (** Allow SSL_write(..., n) to return r with 0 < r < n (i.e. report success + when just a single record has been written *) + type bigarray = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t @@ -197,9 +217,10 @@ type context_type = | Server_context | Both_context -external create_context : +external raw_create_context : protocol -> context_type + -> Modes.t -> context = "ocaml_ssl_create_context" @@ -421,6 +442,7 @@ external set_ip : socket -> string -> unit = "ocaml_ssl_set1_ip" (* Here is the signature of the base communication functions that are implemented below in two versions *) module type Ssl_base = sig + val create_context : ?modes:Modes.t -> protocol -> context_type -> context val connect : socket -> unit val accept : socket -> unit val ssl_shutdown : socket -> bool @@ -435,6 +457,9 @@ end (* Provide the base implementation communication functions that release the OCaml runtime lock, allowing multiple systhreads to execute concurrently. *) module Runtime_unlock_base = struct + let create_context ?(modes = Modes.auto_retry) protocol ctype = + raw_create_context protocol ctype modes + 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" @@ -471,6 +496,10 @@ end (* Same as above, but doesn't release the lock. *) module Runtime_lock_base = struct + let create_context ?(modes = Modes.(async lor enable_partial_write)) + protocol ctype = + raw_create_context protocol ctype modes + external get_error : socket -> int -> ssl_error = "ocaml_ssl_get_error_code" [@@noalloc] diff --git a/src/ssl.mli b/src/ssl.mli index cf9860c..d9e8e92 100644 --- a/src/ssl.mli +++ b/src/ssl.mli @@ -78,6 +78,49 @@ type ssl_error = (** See https://www.openssl.org/docs/manmaster/man3/SSL_CTX_set_verify.html *) +module Modes : sig + (** set of mode *) + type t = int + + val no_mode : t + + (** Allow SSL_write(..., n) to return r with 0 < r < n (i.e. report success + when just a single record has been written *) + val enable_partial_write : t + + (** Never bother the application with retries if the transport is blocking *) + val auto_retry : t + + (** Don't attempt to automatically build certificate chain *) + val no_auto_chain : t + + (** Save RAM by releasing read and write buffers when they're empty. (SSL3 and + TLS only.) Released buffers are freed. *) + val release_buffers : t + + (** Send the current time in the Random fields of the ClientHello and + ServerHello records for compatibility with hypothetical implementations + that require it. *) + val send_clienthello_time : t + val send_serverhello_time : t + + (** Send TLS_FALLBACK_SCSV in the ClientHello. To be set only by + applications that reconnect with a downgraded protocol version; see + draft-ietf-tls-downgrade-scsv-00 for details. DO NOT ENABLE THIS if your + application attempts a normal handshake. Only use this in explicit + fallback retries, following the guidance in + draft-ietf-tls-downgrade-scsv-00. *) + val send_fallback_scsv : t + + (** Support Asynchronous operation *) + val async : t + + (** put togther two sets of options *) + val ( lor ) : t -> t -> t +end + + + type bigarray = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t @@ -288,8 +331,8 @@ type context_type = | Server_context (** Server connections. *) | Both_context (** Client and server connections. *) -val create_context : protocol -> context_type -> context -(** Create a context. *) +val create_context : ?modes:Modes.t -> protocol -> context_type -> context +(** Create a context. Default modes is Modes.(auto_retry) *) val add_extra_chain_cert : context -> string -> unit (** Add an additional certificate to the extra chain certificates associated @@ -575,6 +618,10 @@ val output_int : socket -> int -> unit i.e. handling of `EWOULDBLOCK`, `EGAIN`, etc. Additionally, the functions in this module don't perform a copy of application data buffers. *) module Runtime_lock : sig + val create_context : ?modes:Modes.t -> protocol -> context_type -> context + (** same as create_context above, but the default modes are + [Modes.(async lor enable_partial_write] *) + val connect : socket -> unit (** Connect an SSL socket. *) diff --git a/src/ssl_stubs.c b/src/ssl_stubs.c index 8a63633..119c6de 100644 --- a/src/ssl_stubs.c +++ b/src/ssl_stubs.c @@ -401,8 +401,8 @@ static void set_protocol(SSL_CTX *ssl_context, int protocol) { } } -CAMLprim value ocaml_ssl_create_context(value protocol, value type) { - CAMLparam2(protocol, type); +CAMLprim value ocaml_ssl_create_context(value protocol, value type, value modes) { + CAMLparam3(protocol, type, modes); CAMLlocal1(block); SSL_CTX *ctx; const SSL_METHOD *method = get_method(Int_val(type)); @@ -419,7 +419,7 @@ CAMLprim value ocaml_ssl_create_context(value protocol, value type) { a write retry (since the GC may need to move it). In blocking mode, hide SSL_ERROR_WANT_(READ|WRITE) from us. */ SSL_CTX_set_mode(ctx, - SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER | SSL_MODE_AUTO_RETRY); + SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER | Int_val(modes)); caml_acquire_runtime_system(); block = caml_alloc_custom(&ctx_ops, sizeof(SSL_CTX *), 0, 1); diff --git a/tests/dune b/tests/dune index 26d43f5..d8b3890 100644 --- a/tests/dune +++ b/tests/dune @@ -3,6 +3,11 @@ (modules util) (libraries ssl threads str alcotest)) +(library + (name util_rlock) + (modules util_rlock) + (libraries ssl threads str alcotest)) + (test (name ssl_test) (modules ssl_test) @@ -43,3 +48,9 @@ (modules ssl_io) (libraries ssl alcotest util) (deps ca.pem ca.key server.key server.pem)) + +(test + (name ssl_rlock_io) + (modules ssl_rlock_io) + (libraries ssl alcotest util_rlock) + (deps ca.pem ca.key server.key server.pem)) diff --git a/tests/ssl_rlock_io.ml b/tests/ssl_rlock_io.ml new file mode 100644 index 0000000..51b4c2e --- /dev/null +++ b/tests/ssl_rlock_io.ml @@ -0,0 +1,126 @@ +open Alcotest + +module Ssl = struct + include Ssl + include Ssl.Runtime_lock +end + +module Util = Util_rlock + +let test_verify () = + let addr = Unix.ADDR_INET (Unix.inet_addr_of_string "127.0.0.1", 2342) in + Util.server_thread addr None |> ignore; + + let context = Ssl.create_context TLSv1_3 Client_context in + let ssl = Ssl.open_connection_with_context context addr in + let verify_result = + try + Ssl.verify ssl; + "" + with + | e -> Printexc.to_string e + in + let rec fn () = + try + Ssl.shutdown_connection ssl; + with + Ssl.(Connection_error(Error_want_write|Error_want_read| + Error_want_accept|Error_want_connect|Error_zero_return)) -> + fn () + in + fn (); + check + bool + "no verify errors" + true + (Str.search_forward + (Str.regexp_string "error:00000000:lib(0)") + verify_result + 0 + > 0) + +let test_set_host () = + let addr = Unix.ADDR_INET (Unix.inet_addr_of_string "127.0.0.1", 2343) in + let pid = Util.server_thread addr None in + + let context = Ssl.create_context TLSv1_3 Client_context in + let domain = Unix.domain_of_sockaddr addr in + let sock = Unix.socket domain Unix.SOCK_STREAM 0 in + let ssl = Ssl.embed_socket sock context in + Ssl.set_host ssl "localhost"; + Unix.connect sock addr; + Unix.set_nonblock sock; + let rec fn () = + try + Ssl.connect ssl; + with + Ssl.(Connection_error(Error_want_write|Error_want_read| + Error_want_accept|Error_want_connect|Error_zero_return)) -> + fn () + in fn (); + + let verify_result = + try + Ssl.verify ssl; + "" + with + | e -> Printexc.to_string e + in + let rec fn () = + try + Ssl.shutdown_connection ssl; + with + Ssl.(Connection_error(Error_want_write|Error_want_read| + Error_want_accept|Error_want_connect|Error_zero_return)) -> + fn () + in + fn (); + check + bool + "no verify errors" + true + (Str.search_forward + (Str.regexp_string "error:00000000:lib(0)") + verify_result + 0 + > 0); + Unix.kill pid Sys.sigint; + Unix.waitpid [] pid |> ignore + + +let test_read_write () = + let addr = Unix.ADDR_INET (Unix.inet_addr_of_string "127.0.0.1", 2344) in + let pid = Util.server_thread addr (Some (fun _ -> "received")) in + + let context = Ssl.create_context TLSv1_3 Client_context in + let ssl = Ssl.open_connection_with_context context addr in + Unix.set_nonblock (Ssl.file_descr_of_socket ssl); + let send_msg = "send" in + let write_buf = Bytes.create (String.length send_msg) in + let rec fn () = + try Ssl.write ssl write_buf 0 4 |> ignore; + with Ssl.(Write_error(Error_want_write|Error_want_read| + Error_want_accept|Error_want_connect|Error_zero_return)) -> + fn () + in fn (); + let read_buf = Bytes.create 8 in + let rec fn () = + try Ssl.read ssl read_buf 0 8 |> ignore; + with Ssl.(Read_error(Error_want_write|Error_want_read| + Error_want_accept|Error_want_connect|Error_zero_return)) -> + fn () + in fn (); + Ssl.shutdown_connection ssl; + check string "received message" "received" (Bytes.to_string read_buf); + Unix.kill pid Sys.sigint; + Unix.waitpid [] pid |> ignore + +let () = + run + "Ssl io functions with Ssl.Runtime_lock and non blocking socket" + [ ( "IO" + , [ test_case "Verify" `Quick test_verify + ; test_case "Set host" `Quick test_set_host + ; test_case "Read write" `Quick test_read_write + ] ) + ] diff --git a/tests/util_rlock.ml b/tests/util_rlock.ml new file mode 100644 index 0000000..e524bea --- /dev/null +++ b/tests/util_rlock.ml @@ -0,0 +1,98 @@ +module Ssl = struct + include Ssl + + let[@ocaml.alert "-deprecated"] get_error_string = get_error_string +end + +open Ssl +open Ssl.Runtime_lock + +type server_args = + { address : Unix.sockaddr + ; parser : (string -> string) option + } + +let server_rw_loop ssl parser_func = + let rw_loop = ref true in + while !rw_loop do + try + let read_buf = Bytes.create 256 in + let read_bytes = read ssl read_buf 0 256 in + if read_bytes > 0 + then ( + let input = Bytes.to_string read_buf in + let response = parser_func input in + Ssl.write_substring ssl response 0 (String.length response) |> ignore; + Ssl.close_notify ssl |> ignore; + rw_loop := false) + with + | Read_error(Error_want_read|Error_want_accept| + Error_want_connect|Error_want_write|Error_zero_return) -> + () + | Read_error _ -> rw_loop := false + done + +let server_init args = + try + (* Server initialization *) + let socket = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in + Unix.setsockopt socket Unix.SO_REUSEADDR true; + Unix.bind socket args.address; + let context = create_context TLSv1_3 Server_context in + use_certificate context "server.pem" "server.key"; + Ssl.set_context_alpn_select_callback context (fun client_protos -> + List.find_opt (fun opt -> opt = "http/1.1") client_protos); + (* Signal ready and listen for connection *) + Unix.listen socket 1; + Some (socket, context) + with + | exn -> + Printexc.to_string exn |> print_endline; + None + +let server_listen args = + match server_init args with + | None -> + Thread.exit () [@warning "-3"] + | Some (socket, context) -> + let _ = Unix.select [socket] [] [] (-1.0) in + let listen = Unix.accept socket in + Unix.set_nonblock (fst listen); + let ssl = embed_socket (fst listen) context in + let rec fn () = + try + accept ssl; + (* Exit right away unless we need to rw *) + (match args.parser with + | Some parser_func -> server_rw_loop ssl parser_func + | None -> + (); + shutdown ssl; + exit 0) + with + Accept_error(Error_want_read|Error_want_write + |Error_want_connect|Error_want_accept|Error_zero_return) -> + fn () + in + fn () + +let server_thread addr parser = + let args = { address = addr; parser } in + let pid = Unix.fork () in + if pid = 0 then + server_listen args + else + Unix.sleep 1; pid + +let check_ssl_no_error err = + Str.string_partial_match (Str.regexp_string "error:00000000:lib(0)") err 0 + +let[@ocaml.alert "-deprecated"] pp_protocol ppf = function + | SSLv23 -> Format.fprintf ppf "SSLv23" + | SSLv3 -> Format.fprintf ppf "SSLv3" + | TLSv1 -> Format.fprintf ppf "TLSv1" + | TLSv1_1 -> Format.fprintf ppf "TLSv1_1" + | TLSv1_2 -> Format.fprintf ppf "TLSv1_2" + | TLSv1_3 -> Format.fprintf ppf "TLSv1_3" + +let protocol_testable = Alcotest.testable pp_protocol (fun r1 r2 -> r1 == r2) From 18277ab5849c74a57f05a5ad16906db851f9be41 Mon Sep 17 00:00:00 2001 From: Christophe Raffalli Date: Sun, 4 Jun 2023 13:34:31 -1000 Subject: [PATCH 02/12] remove Runtime_lock tests --- tests/dune | 11 ---- tests/ssl_rlock_io.ml | 126 ------------------------------------------ tests/util_rlock.ml | 98 -------------------------------- 3 files changed, 235 deletions(-) delete mode 100644 tests/ssl_rlock_io.ml delete mode 100644 tests/util_rlock.ml diff --git a/tests/dune b/tests/dune index d8b3890..26d43f5 100644 --- a/tests/dune +++ b/tests/dune @@ -3,11 +3,6 @@ (modules util) (libraries ssl threads str alcotest)) -(library - (name util_rlock) - (modules util_rlock) - (libraries ssl threads str alcotest)) - (test (name ssl_test) (modules ssl_test) @@ -48,9 +43,3 @@ (modules ssl_io) (libraries ssl alcotest util) (deps ca.pem ca.key server.key server.pem)) - -(test - (name ssl_rlock_io) - (modules ssl_rlock_io) - (libraries ssl alcotest util_rlock) - (deps ca.pem ca.key server.key server.pem)) diff --git a/tests/ssl_rlock_io.ml b/tests/ssl_rlock_io.ml deleted file mode 100644 index 51b4c2e..0000000 --- a/tests/ssl_rlock_io.ml +++ /dev/null @@ -1,126 +0,0 @@ -open Alcotest - -module Ssl = struct - include Ssl - include Ssl.Runtime_lock -end - -module Util = Util_rlock - -let test_verify () = - let addr = Unix.ADDR_INET (Unix.inet_addr_of_string "127.0.0.1", 2342) in - Util.server_thread addr None |> ignore; - - let context = Ssl.create_context TLSv1_3 Client_context in - let ssl = Ssl.open_connection_with_context context addr in - let verify_result = - try - Ssl.verify ssl; - "" - with - | e -> Printexc.to_string e - in - let rec fn () = - try - Ssl.shutdown_connection ssl; - with - Ssl.(Connection_error(Error_want_write|Error_want_read| - Error_want_accept|Error_want_connect|Error_zero_return)) -> - fn () - in - fn (); - check - bool - "no verify errors" - true - (Str.search_forward - (Str.regexp_string "error:00000000:lib(0)") - verify_result - 0 - > 0) - -let test_set_host () = - let addr = Unix.ADDR_INET (Unix.inet_addr_of_string "127.0.0.1", 2343) in - let pid = Util.server_thread addr None in - - let context = Ssl.create_context TLSv1_3 Client_context in - let domain = Unix.domain_of_sockaddr addr in - let sock = Unix.socket domain Unix.SOCK_STREAM 0 in - let ssl = Ssl.embed_socket sock context in - Ssl.set_host ssl "localhost"; - Unix.connect sock addr; - Unix.set_nonblock sock; - let rec fn () = - try - Ssl.connect ssl; - with - Ssl.(Connection_error(Error_want_write|Error_want_read| - Error_want_accept|Error_want_connect|Error_zero_return)) -> - fn () - in fn (); - - let verify_result = - try - Ssl.verify ssl; - "" - with - | e -> Printexc.to_string e - in - let rec fn () = - try - Ssl.shutdown_connection ssl; - with - Ssl.(Connection_error(Error_want_write|Error_want_read| - Error_want_accept|Error_want_connect|Error_zero_return)) -> - fn () - in - fn (); - check - bool - "no verify errors" - true - (Str.search_forward - (Str.regexp_string "error:00000000:lib(0)") - verify_result - 0 - > 0); - Unix.kill pid Sys.sigint; - Unix.waitpid [] pid |> ignore - - -let test_read_write () = - let addr = Unix.ADDR_INET (Unix.inet_addr_of_string "127.0.0.1", 2344) in - let pid = Util.server_thread addr (Some (fun _ -> "received")) in - - let context = Ssl.create_context TLSv1_3 Client_context in - let ssl = Ssl.open_connection_with_context context addr in - Unix.set_nonblock (Ssl.file_descr_of_socket ssl); - let send_msg = "send" in - let write_buf = Bytes.create (String.length send_msg) in - let rec fn () = - try Ssl.write ssl write_buf 0 4 |> ignore; - with Ssl.(Write_error(Error_want_write|Error_want_read| - Error_want_accept|Error_want_connect|Error_zero_return)) -> - fn () - in fn (); - let read_buf = Bytes.create 8 in - let rec fn () = - try Ssl.read ssl read_buf 0 8 |> ignore; - with Ssl.(Read_error(Error_want_write|Error_want_read| - Error_want_accept|Error_want_connect|Error_zero_return)) -> - fn () - in fn (); - Ssl.shutdown_connection ssl; - check string "received message" "received" (Bytes.to_string read_buf); - Unix.kill pid Sys.sigint; - Unix.waitpid [] pid |> ignore - -let () = - run - "Ssl io functions with Ssl.Runtime_lock and non blocking socket" - [ ( "IO" - , [ test_case "Verify" `Quick test_verify - ; test_case "Set host" `Quick test_set_host - ; test_case "Read write" `Quick test_read_write - ] ) - ] diff --git a/tests/util_rlock.ml b/tests/util_rlock.ml deleted file mode 100644 index e524bea..0000000 --- a/tests/util_rlock.ml +++ /dev/null @@ -1,98 +0,0 @@ -module Ssl = struct - include Ssl - - let[@ocaml.alert "-deprecated"] get_error_string = get_error_string -end - -open Ssl -open Ssl.Runtime_lock - -type server_args = - { address : Unix.sockaddr - ; parser : (string -> string) option - } - -let server_rw_loop ssl parser_func = - let rw_loop = ref true in - while !rw_loop do - try - let read_buf = Bytes.create 256 in - let read_bytes = read ssl read_buf 0 256 in - if read_bytes > 0 - then ( - let input = Bytes.to_string read_buf in - let response = parser_func input in - Ssl.write_substring ssl response 0 (String.length response) |> ignore; - Ssl.close_notify ssl |> ignore; - rw_loop := false) - with - | Read_error(Error_want_read|Error_want_accept| - Error_want_connect|Error_want_write|Error_zero_return) -> - () - | Read_error _ -> rw_loop := false - done - -let server_init args = - try - (* Server initialization *) - let socket = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in - Unix.setsockopt socket Unix.SO_REUSEADDR true; - Unix.bind socket args.address; - let context = create_context TLSv1_3 Server_context in - use_certificate context "server.pem" "server.key"; - Ssl.set_context_alpn_select_callback context (fun client_protos -> - List.find_opt (fun opt -> opt = "http/1.1") client_protos); - (* Signal ready and listen for connection *) - Unix.listen socket 1; - Some (socket, context) - with - | exn -> - Printexc.to_string exn |> print_endline; - None - -let server_listen args = - match server_init args with - | None -> - Thread.exit () [@warning "-3"] - | Some (socket, context) -> - let _ = Unix.select [socket] [] [] (-1.0) in - let listen = Unix.accept socket in - Unix.set_nonblock (fst listen); - let ssl = embed_socket (fst listen) context in - let rec fn () = - try - accept ssl; - (* Exit right away unless we need to rw *) - (match args.parser with - | Some parser_func -> server_rw_loop ssl parser_func - | None -> - (); - shutdown ssl; - exit 0) - with - Accept_error(Error_want_read|Error_want_write - |Error_want_connect|Error_want_accept|Error_zero_return) -> - fn () - in - fn () - -let server_thread addr parser = - let args = { address = addr; parser } in - let pid = Unix.fork () in - if pid = 0 then - server_listen args - else - Unix.sleep 1; pid - -let check_ssl_no_error err = - Str.string_partial_match (Str.regexp_string "error:00000000:lib(0)") err 0 - -let[@ocaml.alert "-deprecated"] pp_protocol ppf = function - | SSLv23 -> Format.fprintf ppf "SSLv23" - | SSLv3 -> Format.fprintf ppf "SSLv3" - | TLSv1 -> Format.fprintf ppf "TLSv1" - | TLSv1_1 -> Format.fprintf ppf "TLSv1_1" - | TLSv1_2 -> Format.fprintf ppf "TLSv1_2" - | TLSv1_3 -> Format.fprintf ppf "TLSv1_3" - -let protocol_testable = Alcotest.testable pp_protocol (fun r1 r2 -> r1 == r2) From 5fa6f37660d65bdb4d7f08d32f9ca69367be2f56 Mon Sep 17 00:00:00 2001 From: Christophe Raffalli Date: Sun, 4 Jun 2023 13:38:43 -1000 Subject: [PATCH 03/12] Mode logical operator on modes --- src/ssl.ml | 3 +++ src/ssl.mli | 11 ++++++++++- 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/src/ssl.ml b/src/ssl.ml index 1f15c6e..b2eecb4 100644 --- a/src/ssl.ml +++ b/src/ssl.ml @@ -92,6 +92,9 @@ module Modes = struct let async = 0x100 let (lor) = (lor) + let (land) = (land) + let lnot = lnot + let subset a b = a land (lnot b) = no_mode end (** Allow SSL_write(..., n) to return r with 0 < r < n (i.e. report success diff --git a/src/ssl.mli b/src/ssl.mli index d9e8e92..dd15eaf 100644 --- a/src/ssl.mli +++ b/src/ssl.mli @@ -115,8 +115,17 @@ module Modes : sig (** Support Asynchronous operation *) val async : t - (** put togther two sets of options *) + (** put togther two sets of modes *) val ( lor ) : t -> t -> t + + (** conjunction of modes *) + val ( land ) : t -> t -> t + + (** negation of modes *) + val lnot : t -> t + + (** subset on modes*) + val subset : t -> t -> bool end From 42a7681920c6a25d302e6a54be7404fdc57ad8cb Mon Sep 17 00:00:00 2001 From: Christophe Raffalli Date: Sun, 4 Jun 2023 13:48:21 -1000 Subject: [PATCH 04/12] interface to SSL_CTX_get|set|clear_mode + move/clean the code --- src/ssl.ml | 47 +++++++++---------- src/ssl.mli | 117 +++++++++++++++++++++++++----------------------- src/ssl_stubs.c | 20 +++++++++ 3 files changed, 106 insertions(+), 78 deletions(-) diff --git a/src/ssl.ml b/src/ssl.ml index b2eecb4..b034534 100644 --- a/src/ssl.ml +++ b/src/ssl.ml @@ -77,29 +77,6 @@ type verify_error = | Error_v_keyusage_no_certsign | Error_v_application_verification -module Modes = struct - type t = int - - let no_mode = 0x000 - let enable_partial_write = 0x001 - (*let accept_moving_write_buffer = 0x002: is always set because of GC*) - let auto_retry = 0x004 - let no_auto_chain = 0x008 - let release_buffers = 0x010 - let send_clienthello_time = 0x020 - let send_serverhello_time = 0x040 - let send_fallback_scsv = 0x080 - let async = 0x100 - - let (lor) = (lor) - let (land) = (land) - let lnot = lnot - let subset a b = a land (lnot b) = no_mode -end - - (** Allow SSL_write(..., n) to return r with 0 < r < n (i.e. report success - when just a single record has been written *) - type bigarray = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t @@ -220,6 +197,30 @@ type context_type = | Server_context | Both_context +module Modes = struct + type t = int + + let no_mode = 0x000 + let enable_partial_write = 0x001 + (*let accept_moving_write_buffer = 0x002: is always set because of GC*) + let auto_retry = 0x004 + let no_auto_chain = 0x008 + let release_buffers = 0x010 + let send_clienthello_time = 0x020 + let send_serverhello_time = 0x040 + let send_fallback_scsv = 0x080 + let async = 0x100 + + let (lor) = (lor) + let (land) = (land) + let lnot = lnot + let subset a b = a land (lnot b) = no_mode +end + +external set_mode : context -> Modes.t -> unit = "ocaml_ssl_set_mode" +external clear_mode : context -> Modes.t -> unit = "ocaml_ssl_clear_mode" +external get_mode : context -> Modes.t = "ocaml_ssl_get_mode" + external raw_create_context : protocol -> context_type diff --git a/src/ssl.mli b/src/ssl.mli index dd15eaf..21b8968 100644 --- a/src/ssl.mli +++ b/src/ssl.mli @@ -78,61 +78,6 @@ type ssl_error = (** See https://www.openssl.org/docs/manmaster/man3/SSL_CTX_set_verify.html *) -module Modes : sig - (** set of mode *) - type t = int - - val no_mode : t - - (** Allow SSL_write(..., n) to return r with 0 < r < n (i.e. report success - when just a single record has been written *) - val enable_partial_write : t - - (** Never bother the application with retries if the transport is blocking *) - val auto_retry : t - - (** Don't attempt to automatically build certificate chain *) - val no_auto_chain : t - - (** Save RAM by releasing read and write buffers when they're empty. (SSL3 and - TLS only.) Released buffers are freed. *) - val release_buffers : t - - (** Send the current time in the Random fields of the ClientHello and - ServerHello records for compatibility with hypothetical implementations - that require it. *) - val send_clienthello_time : t - val send_serverhello_time : t - - (** Send TLS_FALLBACK_SCSV in the ClientHello. To be set only by - applications that reconnect with a downgraded protocol version; see - draft-ietf-tls-downgrade-scsv-00 for details. DO NOT ENABLE THIS if your - application attempts a normal handshake. Only use this in explicit - fallback retries, following the guidance in - draft-ietf-tls-downgrade-scsv-00. *) - val send_fallback_scsv : t - - (** Support Asynchronous operation *) - val async : t - - (** put togther two sets of modes *) - val ( lor ) : t -> t -> t - - (** conjunction of modes *) - val ( land ) : t -> t -> t - - (** negation of modes *) - val lnot : t -> t - - (** subset on modes*) - val subset : t -> t -> bool -end - - - -type bigarray = - (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t - exception Method_error (** The SSL method could not be initialized. *) @@ -340,9 +285,71 @@ type context_type = | Server_context (** Server connections. *) | Both_context (** Client and server connections. *) +module Modes : sig + (** set of mode *) + type t = int + + val no_mode : t + + (** Allow SSL_write(..., n) to return r with 0 < r < n (i.e. report success + when just a single record has been written *) + val enable_partial_write : t + + (** Never bother the application with retries if the transport is blocking *) + val auto_retry : t + + (** Don't attempt to automatically build certificate chain *) + val no_auto_chain : t + + (** Save RAM by releasing read and write buffers when they're empty. (SSL3 and + TLS only.) Released buffers are freed. *) + val release_buffers : t + + (** Send the current time in the Random fields of the ClientHello and + ServerHello records for compatibility with hypothetical implementations + that require it. *) + val send_clienthello_time : t + val send_serverhello_time : t + + (** Send TLS_FALLBACK_SCSV in the ClientHello. To be set only by + applications that reconnect with a downgraded protocol version; see + draft-ietf-tls-downgrade-scsv-00 for details. DO NOT ENABLE THIS if your + application attempts a normal handshake. Only use this in explicit + fallback retries, following the guidance in + draft-ietf-tls-downgrade-scsv-00. *) + val send_fallback_scsv : t + + (** Support Asynchronous operation *) + val async : t + + (** put togther two sets of modes *) + val ( lor ) : t -> t -> t + + (** conjunction of modes *) + val ( land ) : t -> t -> t + + (** negation of modes *) + val lnot : t -> t + + (** subset on modes*) + val subset : t -> t -> bool +end + val create_context : ?modes:Modes.t -> protocol -> context_type -> context (** Create a context. Default modes is Modes.(auto_retry) *) +(** Set the given modes in a context (does not clear preset modes) *) +val set_mode : context -> Modes.t -> unit + +(** Clear the given modes in a context *) +val clear_mode : context -> Modes.t -> unit + +(** Get the current mode of a context *) +val get_mode : context -> Modes.t + +type bigarray = + (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t + val add_extra_chain_cert : context -> string -> unit (** Add an additional certificate to the extra chain certificates associated with the [ctx]. Extra chain certificates will be sent to the peer for diff --git a/src/ssl_stubs.c b/src/ssl_stubs.c index 119c6de..df1457b 100644 --- a/src/ssl_stubs.c +++ b/src/ssl_stubs.c @@ -401,6 +401,26 @@ static void set_protocol(SSL_CTX *ssl_context, int protocol) { } } +CAMLprim void ocaml_ssl_set_mode(value ctx, value modes) { + CAMLparam1(ctx); + SSL_CTX_set_mode(Ctx_val(ctx), + SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER | Int_val(modes)); + CAMLreturn0; +} + +CAMLprim void ocaml_ssl_clear_mode(value ctx, value modes) { + CAMLparam1(ctx); + SSL_CTX_clear_mode(Ctx_val(ctx), + !SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER & Int_val(modes)); + CAMLreturn0; +} + +CAMLprim value ocaml_ssl_get_mode(value ctx, value modes) { + CAMLparam1(ctx); + long r = SSL_CTX_get_mode(Ctx_val(ctx)); + CAMLreturn(Val_int(!SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER & r)); +} + CAMLprim value ocaml_ssl_create_context(value protocol, value type, value modes) { CAMLparam3(protocol, type, modes); CAMLlocal1(block); From 2a3ab46c20082083604283dc416709f2019375a5 Mon Sep 17 00:00:00 2001 From: Christophe Raffalli Date: Sun, 4 Jun 2023 14:14:58 -1000 Subject: [PATCH 05/12] added a link to the definition of the mode constants --- src/ssl.ml | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/src/ssl.ml b/src/ssl.ml index b034534..1d80b31 100644 --- a/src/ssl.ml +++ b/src/ssl.ml @@ -200,16 +200,17 @@ type context_type = module Modes = struct type t = int + (* value taken from openssl/ssl.h *) let no_mode = 0x000 - let enable_partial_write = 0x001 + let enable_partial_write = 0x001 (* SSL_MODE_ENABLE_PARTIAL_WRITE *) (*let accept_moving_write_buffer = 0x002: is always set because of GC*) - let auto_retry = 0x004 - let no_auto_chain = 0x008 - let release_buffers = 0x010 - let send_clienthello_time = 0x020 - let send_serverhello_time = 0x040 - let send_fallback_scsv = 0x080 - let async = 0x100 + let auto_retry = 0x004 (* SSL_MODE_AUTO_RETRY *) + let no_auto_chain = 0x008 (* SSL_MODE_RELEASE_BUFFERS *) + let release_buffers = 0x010 (* SSL_MODE_RELEASE_BUFFERS *) + let send_clienthello_time = 0x020 (* SSL_MODE_SEND_CLIENTHELLO_TIME *) + let send_serverhello_time = 0x040 (* SSL_MODE_SEND_SERVERHELLO_TIME *) + let send_fallback_scsv = 0x080 (* SSL_MODE_SEND_FALLBACK_SCSV *) + let async = 0x100 (* SSL_MODE_ASYNC *) let (lor) = (lor) let (land) = (land) From 8bfa083d003b4cd83de7c2463fd4416383581941 Mon Sep 17 00:00:00 2001 From: Christophe Raffalli Date: Sun, 4 Jun 2023 22:01:34 -1000 Subject: [PATCH 06/12] wrong negation in c stubs --- src/ssl_stubs.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/ssl_stubs.c b/src/ssl_stubs.c index df1457b..9bf60b7 100644 --- a/src/ssl_stubs.c +++ b/src/ssl_stubs.c @@ -411,14 +411,14 @@ CAMLprim void ocaml_ssl_set_mode(value ctx, value modes) { CAMLprim void ocaml_ssl_clear_mode(value ctx, value modes) { CAMLparam1(ctx); SSL_CTX_clear_mode(Ctx_val(ctx), - !SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER & Int_val(modes)); + ~SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER & Int_val(modes)); CAMLreturn0; } CAMLprim value ocaml_ssl_get_mode(value ctx, value modes) { CAMLparam1(ctx); long r = SSL_CTX_get_mode(Ctx_val(ctx)); - CAMLreturn(Val_int(!SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER & r)); + CAMLreturn(Val_int(~SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER & r)); } CAMLprim value ocaml_ssl_create_context(value protocol, value type, value modes) { From 7e06846a638a53d9c415d91690418e86d1fb0d4a Mon Sep 17 00:00:00 2001 From: Christophe Raffalli Date: Sun, 4 Jun 2023 14:28:28 -1000 Subject: [PATCH 07/12] try to add dune runtest in workflow --- .github/workflows/build.yml | 1 - 1 file changed, 1 deletion(-) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 73752ca..19e995c 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -56,4 +56,3 @@ jobs: extra-trusted-public-keys = ocaml.nix-cache.com-1:/xI2h2+56rwFfKyyFVbkJSeGqSIYMC/Je+7XXqGKDIY= - name: "Run nix-build" run: nix-build ./nix/ci/test.nix --argstr ocamlVersion ${{ matrix.setup.ocamlVersion }} - From fafa8139b3540efb08c88b1e90a623374f6c8fa1 Mon Sep 17 00:00:00 2001 From: Christophe Raffalli Date: Sun, 4 Jun 2023 14:28:28 -1000 Subject: [PATCH 08/12] try to add dune runtest in workflow --- .github/workflows/build.yml | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 19e995c..8324258 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -30,11 +30,9 @@ jobs: run: opam pin add -n . - name: Install dependencies run: opam depext -yt mad - - name: Build - if: ${{ ! matrix.setup.runtest }} - run: opam install . - - name: Build and test - if: ${{ matrix.setup.runtest }} + - name: build and test + run: dune runtest + - name: Build, test and install run: opam install -t . nix-build: From 8eb6f8db5b832d30eccf11c6e5aac233dd359e3a Mon Sep 17 00:00:00 2001 From: Christophe Raffalli Date: Tue, 20 Jun 2023 13:35:03 -1000 Subject: [PATCH 09/12] revert build.yml (mistake...) --- .github/workflows/build.yml | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 8324258..19e995c 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -30,9 +30,11 @@ jobs: run: opam pin add -n . - name: Install dependencies run: opam depext -yt mad - - name: build and test - run: dune runtest - - name: Build, test and install + - name: Build + if: ${{ ! matrix.setup.runtest }} + run: opam install . + - name: Build and test + if: ${{ matrix.setup.runtest }} run: opam install -t . nix-build: From a065122f89b015e60f96f64ea8450dcbfe01c59c Mon Sep 17 00:00:00 2001 From: Christophe Raffalli Date: Fri, 2 Jun 2023 01:02:40 -1000 Subject: [PATCH 10/12] Add a way to set context mode when creating context + distinct default mode for blocking and Runtime_lock. Also test Runtime_lock --- src/ssl.ml | 3 + src/ssl.mli | 6 +- tests/dune | 11 ++++ tests/ssl_rlock_io.ml | 126 ++++++++++++++++++++++++++++++++++++++++++ tests/util_rlock.ml | 98 ++++++++++++++++++++++++++++++++ 5 files changed, 241 insertions(+), 3 deletions(-) create mode 100644 tests/ssl_rlock_io.ml create mode 100644 tests/util_rlock.ml diff --git a/src/ssl.ml b/src/ssl.ml index 8b88b5a..9d401fb 100644 --- a/src/ssl.ml +++ b/src/ssl.ml @@ -87,6 +87,9 @@ type verify_error = | Error_v_keyusage_no_certsign | Error_v_application_verification +(** Allow SSL_write(..., n) to return r with 0 < r < n (i.e. report success + when just a single record has been written *) + type bigarray = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t diff --git a/src/ssl.mli b/src/ssl.mli index 1421962..539df5c 100644 --- a/src/ssl.mli +++ b/src/ssl.mli @@ -358,9 +358,6 @@ module Modes : sig val subset : t -> t -> bool end -val create_context : ?modes:Modes.t -> protocol -> context_type -> context -(** Create a context. Default modes is Modes.(auto_retry) *) - (** Set the given modes in a context (does not clear preset modes) *) val set_mode : context -> Modes.t -> unit @@ -373,6 +370,9 @@ val get_mode : context -> Modes.t type bigarray = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t +val create_context : ?modes:Modes.t -> protocol -> context_type -> context +(** Create a context. Default modes is Modes.(auto_retry) *) + val set_min_protocol_version : context -> protocol -> unit (** [set_min_protocol_version ctx proto] sets the minimum supported protocol version for [ctx] to [proto]. *) diff --git a/tests/dune b/tests/dune index 26d43f5..d8b3890 100644 --- a/tests/dune +++ b/tests/dune @@ -3,6 +3,11 @@ (modules util) (libraries ssl threads str alcotest)) +(library + (name util_rlock) + (modules util_rlock) + (libraries ssl threads str alcotest)) + (test (name ssl_test) (modules ssl_test) @@ -43,3 +48,9 @@ (modules ssl_io) (libraries ssl alcotest util) (deps ca.pem ca.key server.key server.pem)) + +(test + (name ssl_rlock_io) + (modules ssl_rlock_io) + (libraries ssl alcotest util_rlock) + (deps ca.pem ca.key server.key server.pem)) diff --git a/tests/ssl_rlock_io.ml b/tests/ssl_rlock_io.ml new file mode 100644 index 0000000..51b4c2e --- /dev/null +++ b/tests/ssl_rlock_io.ml @@ -0,0 +1,126 @@ +open Alcotest + +module Ssl = struct + include Ssl + include Ssl.Runtime_lock +end + +module Util = Util_rlock + +let test_verify () = + let addr = Unix.ADDR_INET (Unix.inet_addr_of_string "127.0.0.1", 2342) in + Util.server_thread addr None |> ignore; + + let context = Ssl.create_context TLSv1_3 Client_context in + let ssl = Ssl.open_connection_with_context context addr in + let verify_result = + try + Ssl.verify ssl; + "" + with + | e -> Printexc.to_string e + in + let rec fn () = + try + Ssl.shutdown_connection ssl; + with + Ssl.(Connection_error(Error_want_write|Error_want_read| + Error_want_accept|Error_want_connect|Error_zero_return)) -> + fn () + in + fn (); + check + bool + "no verify errors" + true + (Str.search_forward + (Str.regexp_string "error:00000000:lib(0)") + verify_result + 0 + > 0) + +let test_set_host () = + let addr = Unix.ADDR_INET (Unix.inet_addr_of_string "127.0.0.1", 2343) in + let pid = Util.server_thread addr None in + + let context = Ssl.create_context TLSv1_3 Client_context in + let domain = Unix.domain_of_sockaddr addr in + let sock = Unix.socket domain Unix.SOCK_STREAM 0 in + let ssl = Ssl.embed_socket sock context in + Ssl.set_host ssl "localhost"; + Unix.connect sock addr; + Unix.set_nonblock sock; + let rec fn () = + try + Ssl.connect ssl; + with + Ssl.(Connection_error(Error_want_write|Error_want_read| + Error_want_accept|Error_want_connect|Error_zero_return)) -> + fn () + in fn (); + + let verify_result = + try + Ssl.verify ssl; + "" + with + | e -> Printexc.to_string e + in + let rec fn () = + try + Ssl.shutdown_connection ssl; + with + Ssl.(Connection_error(Error_want_write|Error_want_read| + Error_want_accept|Error_want_connect|Error_zero_return)) -> + fn () + in + fn (); + check + bool + "no verify errors" + true + (Str.search_forward + (Str.regexp_string "error:00000000:lib(0)") + verify_result + 0 + > 0); + Unix.kill pid Sys.sigint; + Unix.waitpid [] pid |> ignore + + +let test_read_write () = + let addr = Unix.ADDR_INET (Unix.inet_addr_of_string "127.0.0.1", 2344) in + let pid = Util.server_thread addr (Some (fun _ -> "received")) in + + let context = Ssl.create_context TLSv1_3 Client_context in + let ssl = Ssl.open_connection_with_context context addr in + Unix.set_nonblock (Ssl.file_descr_of_socket ssl); + let send_msg = "send" in + let write_buf = Bytes.create (String.length send_msg) in + let rec fn () = + try Ssl.write ssl write_buf 0 4 |> ignore; + with Ssl.(Write_error(Error_want_write|Error_want_read| + Error_want_accept|Error_want_connect|Error_zero_return)) -> + fn () + in fn (); + let read_buf = Bytes.create 8 in + let rec fn () = + try Ssl.read ssl read_buf 0 8 |> ignore; + with Ssl.(Read_error(Error_want_write|Error_want_read| + Error_want_accept|Error_want_connect|Error_zero_return)) -> + fn () + in fn (); + Ssl.shutdown_connection ssl; + check string "received message" "received" (Bytes.to_string read_buf); + Unix.kill pid Sys.sigint; + Unix.waitpid [] pid |> ignore + +let () = + run + "Ssl io functions with Ssl.Runtime_lock and non blocking socket" + [ ( "IO" + , [ test_case "Verify" `Quick test_verify + ; test_case "Set host" `Quick test_set_host + ; test_case "Read write" `Quick test_read_write + ] ) + ] diff --git a/tests/util_rlock.ml b/tests/util_rlock.ml new file mode 100644 index 0000000..e524bea --- /dev/null +++ b/tests/util_rlock.ml @@ -0,0 +1,98 @@ +module Ssl = struct + include Ssl + + let[@ocaml.alert "-deprecated"] get_error_string = get_error_string +end + +open Ssl +open Ssl.Runtime_lock + +type server_args = + { address : Unix.sockaddr + ; parser : (string -> string) option + } + +let server_rw_loop ssl parser_func = + let rw_loop = ref true in + while !rw_loop do + try + let read_buf = Bytes.create 256 in + let read_bytes = read ssl read_buf 0 256 in + if read_bytes > 0 + then ( + let input = Bytes.to_string read_buf in + let response = parser_func input in + Ssl.write_substring ssl response 0 (String.length response) |> ignore; + Ssl.close_notify ssl |> ignore; + rw_loop := false) + with + | Read_error(Error_want_read|Error_want_accept| + Error_want_connect|Error_want_write|Error_zero_return) -> + () + | Read_error _ -> rw_loop := false + done + +let server_init args = + try + (* Server initialization *) + let socket = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in + Unix.setsockopt socket Unix.SO_REUSEADDR true; + Unix.bind socket args.address; + let context = create_context TLSv1_3 Server_context in + use_certificate context "server.pem" "server.key"; + Ssl.set_context_alpn_select_callback context (fun client_protos -> + List.find_opt (fun opt -> opt = "http/1.1") client_protos); + (* Signal ready and listen for connection *) + Unix.listen socket 1; + Some (socket, context) + with + | exn -> + Printexc.to_string exn |> print_endline; + None + +let server_listen args = + match server_init args with + | None -> + Thread.exit () [@warning "-3"] + | Some (socket, context) -> + let _ = Unix.select [socket] [] [] (-1.0) in + let listen = Unix.accept socket in + Unix.set_nonblock (fst listen); + let ssl = embed_socket (fst listen) context in + let rec fn () = + try + accept ssl; + (* Exit right away unless we need to rw *) + (match args.parser with + | Some parser_func -> server_rw_loop ssl parser_func + | None -> + (); + shutdown ssl; + exit 0) + with + Accept_error(Error_want_read|Error_want_write + |Error_want_connect|Error_want_accept|Error_zero_return) -> + fn () + in + fn () + +let server_thread addr parser = + let args = { address = addr; parser } in + let pid = Unix.fork () in + if pid = 0 then + server_listen args + else + Unix.sleep 1; pid + +let check_ssl_no_error err = + Str.string_partial_match (Str.regexp_string "error:00000000:lib(0)") err 0 + +let[@ocaml.alert "-deprecated"] pp_protocol ppf = function + | SSLv23 -> Format.fprintf ppf "SSLv23" + | SSLv3 -> Format.fprintf ppf "SSLv3" + | TLSv1 -> Format.fprintf ppf "TLSv1" + | TLSv1_1 -> Format.fprintf ppf "TLSv1_1" + | TLSv1_2 -> Format.fprintf ppf "TLSv1_2" + | TLSv1_3 -> Format.fprintf ppf "TLSv1_3" + +let protocol_testable = Alcotest.testable pp_protocol (fun r1 r2 -> r1 == r2) From 21e5a97159bc75049e57a8b69be62cdfefc9289e Mon Sep 17 00:00:00 2001 From: Christophe Raffalli Date: Sun, 4 Jun 2023 13:48:21 -1000 Subject: [PATCH 11/12] interface to SSL_CTX_get|set|clear_mode + move/clean the code --- src/ssl.ml | 6 +++--- src/ssl.mli | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/ssl.ml b/src/ssl.ml index 9d401fb..81ec3ae 100644 --- a/src/ssl.ml +++ b/src/ssl.ml @@ -87,9 +87,6 @@ type verify_error = | Error_v_keyusage_no_certsign | Error_v_application_verification -(** Allow SSL_write(..., n) to return r with 0 < r < n (i.e. report success - when just a single record has been written *) - type bigarray = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t @@ -596,6 +593,9 @@ module Runtime_lock_base = struct = "ocaml_ssl_write_blocking" [@@noalloc] + (** Allow SSL_write(..., n) to return r with 0 < r < n (i.e. report success + when just a single record has been written *) + let write socket buffer start length = if start < 0 then invalid_arg "Ssl.write: start negative"; if length < 0 then invalid_arg "Ssl.write: length negative"; diff --git a/src/ssl.mli b/src/ssl.mli index 539df5c..8588b5c 100644 --- a/src/ssl.mli +++ b/src/ssl.mli @@ -367,9 +367,6 @@ val clear_mode : context -> Modes.t -> unit (** Get the current mode of a context *) val get_mode : context -> Modes.t -type bigarray = - (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t - val create_context : ?modes:Modes.t -> protocol -> context_type -> context (** Create a context. Default modes is Modes.(auto_retry) *) @@ -389,6 +386,9 @@ val get_max_protocol_version : context -> protocol (** [get_max_protocol_version ctx proto] sets the maximum supported protocol version for [ctx] to [proto]. *) +type bigarray = + (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t + val add_extra_chain_cert : context -> string -> unit (** Add an additional certificate to the extra chain certificates associated with the [ctx]. Extra chain certificates will be sent to the peer for From d451f31a33097f56e0f8e484261afe59eb1a7c2c Mon Sep 17 00:00:00 2001 From: Christophe Raffalli Date: Sat, 8 Jul 2023 13:55:22 -1000 Subject: [PATCH 12/12] fix test + move definition of bigarray before its first use --- src/ssl.ml | 6 +++--- src/ssl.mli | 6 +++--- tests/ssl_rlock_io.ml | 4 ++-- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/ssl.ml b/src/ssl.ml index 81ec3ae..53ac299 100644 --- a/src/ssl.ml +++ b/src/ssl.ml @@ -87,9 +87,6 @@ type verify_error = | Error_v_keyusage_no_certsign | Error_v_application_verification -type bigarray = - (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t - external get_error_string : unit -> string = "ocaml_ssl_get_error_string" (** Kept for backwards compatibility *) @@ -480,6 +477,9 @@ external set_hostflags : external set_host : socket -> string -> unit = "ocaml_ssl_set1_host" external set_ip : socket -> string -> unit = "ocaml_ssl_set1_ip" +type bigarray = + (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t + (* Here is the signature of the base communication functions that are implemented below in two versions *) module type Ssl_base = sig diff --git a/src/ssl.mli b/src/ssl.mli index 8588b5c..5df3b36 100644 --- a/src/ssl.mli +++ b/src/ssl.mli @@ -386,9 +386,6 @@ val get_max_protocol_version : context -> protocol (** [get_max_protocol_version ctx proto] sets the maximum supported protocol version for [ctx] to [proto]. *) -type bigarray = - (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t - val add_extra_chain_cert : context -> string -> unit (** Add an additional certificate to the extra chain certificates associated with the [ctx]. Extra chain certificates will be sent to the peer for @@ -630,6 +627,9 @@ val flush : socket -> unit val read : socket -> Bytes.t -> int -> int -> int (** [read sock buf off len] receives data from a connected SSL socket. *) +type bigarray = + (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t + val read_into_bigarray : socket -> bigarray -> int -> int -> int (** [read_into_bigarray sock ba off len] receives data from a connected SSL socket. This function releases the runtime while the read takes place. *) diff --git a/tests/ssl_rlock_io.ml b/tests/ssl_rlock_io.ml index 51b4c2e..0b1b07e 100644 --- a/tests/ssl_rlock_io.ml +++ b/tests/ssl_rlock_io.ml @@ -34,7 +34,7 @@ let test_verify () = "no verify errors" true (Str.search_forward - (Str.regexp_string "error:00000000:lib(0)") + (Str.regexp_string "error:00:000000:lib(0)") verify_result 0 > 0) @@ -80,7 +80,7 @@ let test_set_host () = "no verify errors" true (Str.search_forward - (Str.regexp_string "error:00000000:lib(0)") + (Str.regexp_string "error:00:000000:lib(0)") verify_result 0 > 0);