diff --git a/src/conduit-lwt-unix/conduit_lwt_unix.ml b/src/conduit-lwt-unix/conduit_lwt_unix.ml index 9d4e5111..5cbf7e8a 100644 --- a/src/conduit-lwt-unix/conduit_lwt_unix.ml +++ b/src/conduit-lwt-unix/conduit_lwt_unix.ml @@ -108,6 +108,7 @@ type ctx = { src : Unix.sockaddr option; tls_own_key : tls_own_key; tls_authenticator : Conduit_lwt_tls.X509.authenticator; + ssl_client_verify : Conduit_lwt_unix_ssl.Client.verify; ssl_ctx : Ssl.context; } @@ -155,21 +156,25 @@ let default_ctx = src = None; tls_own_key = `None; tls_authenticator = Lazy.force Conduit_lwt_tls.X509.default_authenticator; + ssl_client_verify = Conduit_lwt_unix_ssl.Client.default_verify; ssl_ctx = Conduit_lwt_unix_ssl.Client.default_ctx; } let init ?src ?(tls_own_key = `None) ?(tls_authenticator = Lazy.force Conduit_lwt_tls.X509.default_authenticator) - ?(ssl_ctx = Conduit_lwt_unix_ssl.Client.default_ctx) () = + ?(ssl_ctx = Conduit_lwt_unix_ssl.Client.default_ctx) + ?(ssl_client_verify = Conduit_lwt_unix_ssl.Client.default_verify) () = + let no_source_ctx = + { src = None; tls_own_key; tls_authenticator; ssl_ctx; ssl_client_verify } + in match src with - | None -> Lwt.return { src = None; tls_own_key; tls_authenticator; ssl_ctx } + | None -> Lwt.return no_source_ctx | Some host -> ( let open Unix in Lwt_unix.getaddrinfo host "0" [ AI_PASSIVE; AI_SOCKTYPE SOCK_STREAM ] >>= function | { ai_addr; _ } :: _ -> - Lwt.return - { src = Some ai_addr; tls_own_key; tls_authenticator; ssl_ctx } + Lwt.return { no_source_ctx with src = Some ai_addr } | [] -> Lwt.fail_with "Invalid conduit source address specified") module Sockaddr_io = struct @@ -296,7 +301,8 @@ let connect_with_openssl ~ctx (`Hostname hostname, `IP ip, `Port port) = in ctx_ssl in - Conduit_lwt_unix_ssl.Client.connect ~ctx:ctx_ssl ?src:ctx.src ~hostname ~ip sa + Conduit_lwt_unix_ssl.Client.connect ~ctx:ctx_ssl ?src:ctx.src ~hostname ~ip + ~verify:ctx.ssl_client_verify sa >>= fun (fd, ic, oc) -> let flow = TCP { fd; ip; port } in Lwt.return (flow, ic, oc) diff --git a/src/conduit-lwt-unix/conduit_lwt_unix.mli b/src/conduit-lwt-unix/conduit_lwt_unix.mli index 93432f22..e95ac50c 100644 --- a/src/conduit-lwt-unix/conduit_lwt_unix.mli +++ b/src/conduit-lwt-unix/conduit_lwt_unix.mli @@ -162,6 +162,7 @@ val init : ?tls_own_key:tls_own_key -> ?tls_authenticator:Conduit_lwt_tls.X509.authenticator -> ?ssl_ctx:Ssl.context -> + ?ssl_client_verify:Conduit_lwt_unix_ssl.Client.verify -> unit -> ctx io (** [init ?src ?tls_own_key ?tls_authenticator ?ssl_ctx ()] will initialize a @@ -174,8 +175,8 @@ val init : anchors}. If SSL client connections are used, then [tls_own_key] may contain a valid - certificate to be used to advertise a TLS connection. If it's not - configured [ssl_ctx] will be used to configure OpenSSL. *) + certificate to be used to advertise a TLS connection. If it's not configured + [ssl_ctx] will be used to configure OpenSSL. *) val connect : ctx:ctx -> client -> (flow * ic * oc) io (** [connect ~ctx client] establishes an outgoing connection via the [ctx] diff --git a/src/conduit-lwt-unix/conduit_lwt_unix_ssl.dummy.ml b/src/conduit-lwt-unix/conduit_lwt_unix_ssl.dummy.ml index 89bebdf3..7448c485 100644 --- a/src/conduit-lwt-unix/conduit_lwt_unix_ssl.dummy.ml +++ b/src/conduit-lwt-unix/conduit_lwt_unix_ssl.dummy.ml @@ -18,6 +18,7 @@ module Client = struct type verify = { hostname : bool; ip : bool } + let default_verify = { hostname = true; ip = true } let default_ctx = `Ssl_not_available let create_ctx ?certfile:_ ?keyfile:_ ?password:_ () = default_ctx diff --git a/src/conduit-lwt-unix/conduit_lwt_unix_ssl.dummy.mli b/src/conduit-lwt-unix/conduit_lwt_unix_ssl.dummy.mli index 2a39be05..407e76a3 100644 --- a/src/conduit-lwt-unix/conduit_lwt_unix_ssl.dummy.mli +++ b/src/conduit-lwt-unix/conduit_lwt_unix_ssl.dummy.mli @@ -20,6 +20,7 @@ module Client : sig type verify = { hostname : bool; ip : bool } + val default_verify : verify val default_ctx : [ `Ssl_not_available ] val create_ctx : diff --git a/src/conduit-lwt-unix/conduit_lwt_unix_ssl.real.ml b/src/conduit-lwt-unix/conduit_lwt_unix_ssl.real.ml index 2de299f1..9903d366 100644 --- a/src/conduit-lwt-unix/conduit_lwt_unix_ssl.real.ml +++ b/src/conduit-lwt-unix/conduit_lwt_unix_ssl.real.ml @@ -54,6 +54,8 @@ module Client = struct type verify = { hostname : bool; ip : bool } + let default_verify = { hostname = true; ip = false } + let verification { hostname; ip } = function | None, _ when hostname -> invalid_arg "impossible to verify hostname" | _, None when ip -> invalid_arg "impossible to verify ip" @@ -80,9 +82,7 @@ module Client = struct | Some src_sa -> Lwt_unix.bind fd src_sa) >>= fun () -> Lwt_unix.connect fd sa >>= fun () -> - let verify = - Option.value ~default:{ hostname = true; ip = false } verify - in + let verify = Option.value ~default:default_verify verify in let with_socket f = let s = Lwt_ssl.embed_uninitialized_socket fd ctx in let socket = Lwt_ssl.ssl_socket_of_uninitialized_socket s in diff --git a/src/conduit-lwt-unix/conduit_lwt_unix_ssl.real.mli b/src/conduit-lwt-unix/conduit_lwt_unix_ssl.real.mli index 16cb920e..76498a75 100644 --- a/src/conduit-lwt-unix/conduit_lwt_unix_ssl.real.mli +++ b/src/conduit-lwt-unix/conduit_lwt_unix_ssl.real.mli @@ -20,6 +20,7 @@ module Client : sig type verify = { hostname : bool; ip : bool } + val default_verify : verify val default_ctx : Ssl.context val create_ctx :