conduit-lwt-unix: allow openssl clients to customize the ssl context …

…and the verification (#417)

* conduit-lwt-unix: create client ssl context on init

The ssl context may be used for connect_with_ssl.

When tls_own_key is not configured the configured ssl_ctx is used, by
default this is the default client ssl_ctx, just as before.

Signed-off-by: Pau Ruiz Safont <pau.safont@citrix.com>

* conduit-lwt-unix: fail when hostname verification cannot be done on SSL

When a valid hostname is not available it's better to fail early with
a useful error message rather than letting the connection go on and
letting OpenSSL fail with an undecipherable message.

Note that the "hostname" parameters are strings and don't have to be
hostnames, they can be IPs as well when using cohttp. Ideally these
should be a union type of domain names and ip addresses for better
clarity, but this would be a breaking change.

Signed-off-by: Pau Ruiz Safont <pau.safont@citrix.com>

* conduit-lwt-unix: Add flexibility for OpenSSL verification

This is not exposed currently to the user, so there is no change in
functionality.

This allows clients to turn on and off hostname and ip verification in
the remote cert independently in the unusual case where it's needed by
changing the default in the library.

Signed-off-by: Pau Ruiz Safont <pau.safont@citrix.com>

* conduit-lwt-unix: allow users to configure client ssl verification

The only options allowed are whether the hostname or the IP are used to
validate the remote host's certificate

Signed-off-by: Pau Ruiz Safont <pau.safont@citrix.com>

* conduit-lwt-unix: Change verification and SNI when using IP to connect

Now the SNIs is only sent when there's a domain name, as this is the
only type of server names allowed by the RFC

Additionally IP verification for the peer certificate can be enabled if
needed

Signed-off-by: Pau Ruiz Safont <pau.ruizsafont@cloud.com>

* changes: add entries regarding conduit-lwt-unix-ssl

Signed-off-by: Pau Ruiz Safont <pau.ruizsafont@cloud.com>

Signed-off-by: Pau Ruiz Safont <pau.safont@citrix.com>
Signed-off-by: Pau Ruiz Safont <pau.ruizsafont@cloud.com>

CHANGES.md

@@ -1,3 +1,15 @@
+## unreleased
+
+* conduit-lwt-unix-ssl: allow users to create a client ssl_context and use it for
+  any connections. This allows users to manage the lifecycle of the context.
+* conduit-lwt-unix-ssl: domain name verification can be disabled by users,
+  it's enabled by default. The library returns an error when the hostname
+  verification is turned on but it cannot be performed, this follows the TLS
+  implementation.
+* conduit-lwt-unix-ssl: IP verification can be enabled by users, it's disabled
+  by default.
+* conduit-lwt-unix-ssl: SNI is not sent when there isn't a domain name available
+
 ## v6.0.1 (2022-10-25)
 
 * conduit-mirage: adapt to dns 6.4.0 changes, Resolver_mirage.v is now in Lwt.t

src/conduit-lwt-unix/conduit_lwt_unix.ml

@@ -108,6 +108,8 @@ 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;
 }
 
 let string_of_unix_sockaddr sa =
@@ -154,19 +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_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 }
+  | 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 }
+          Lwt.return { no_source_ctx with src = Some ai_addr }
       | [] -> Lwt.fail_with "Invalid conduit source address specified")
 
 module Sockaddr_io = struct
@@ -279,21 +287,22 @@ let connect_with_tls_native ~ctx (`Hostname hostname, `IP ip, `Port port) =
   let flow = TCP { fd; ip; port } in
   (flow, ic, oc)
 
-let connect_with_openssl ~ctx (`Hostname hostname, `IP ip, `Port port) =
+let connect_with_openssl ~ctx (`Hostname host_addr, `IP ip, `Port port) =
   let sa = Unix.ADDR_INET (Ipaddr_unix.to_inet_addr ip, port) in
   let ctx_ssl =
     match ctx.tls_own_key with
-    | `None -> None
+    | `None -> ctx.ssl_ctx
     | `TLS (`Crt_file_path certfile, `Key_file_path keyfile, password) ->
         let password =
           match password with `No_password -> None | `Password fn -> Some fn
         in
         let ctx_ssl =
           Conduit_lwt_unix_ssl.Client.create_ctx ~certfile ~keyfile ?password ()
         in
-        Some ctx_ssl
+        ctx_ssl
   in
-  Conduit_lwt_unix_ssl.Client.connect ?ctx:ctx_ssl ?src:ctx.src ~hostname sa
+  Conduit_lwt_unix_ssl.Client.connect ~ctx:ctx_ssl ?src:ctx.src
+    ~hostname:host_addr ~ip ~verify:ctx.ssl_client_verify sa
   >>= fun (fd, ic, oc) ->
   let flow = TCP { fd; ip; port } in
   Lwt.return (flow, ic, oc)

src/conduit-lwt-unix/conduit_lwt_unix.mli

@@ -161,16 +161,22 @@ val init :
   ?src:string ->
   ?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 ()] will initialize a Unix conduit that binds to the
-    [src] interface if specified. If TLS server connections are used, then
-    [tls_server_key] must contain a valid certificate to be used to advertise a
-    TLS connection.
+(** [init ?src ?tls_own_key ?tls_authenticator ?ssl_ctx ()] will initialize a
+    Unix conduit that binds to the [src] interface if specified.
 
-    The certificate is validated using [tls_authenticator]. By default, the
+    If TLS server connections are used, then [tls_own_key] must contain a valid
+    certificate to be used to advertise a TLS connection. In TLS mode the
+    certificate is validated using [tls_authenticator]. By default, the
     validation is using the {{:https://github.com/mirage/ca-certs} OS trust
-    anchors}. *)
+    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. *)
 
 val connect : ctx:ctx -> client -> (flow * ic * oc) io
 (** [connect ~ctx client] establishes an outgoing connection via the [ctx]

src/conduit-lwt-unix/conduit_lwt_unix_ssl.dummy.ml

@@ -16,10 +16,13 @@
  *)
 
 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
 
-  let connect ?(ctx = default_ctx) ?src:_ ?hostname:_ _sa =
+  let connect ?(ctx = default_ctx) ?src:_ ?hostname:_ ?ip:_ ?verify:_ _sa =
     ignore ctx;
     Lwt.fail_with "Ssl not available"
 end

src/conduit-lwt-unix/conduit_lwt_unix_ssl.dummy.mli

@@ -18,6 +18,9 @@
 (** TLS/SSL connections via {{:http://www.openssl.org} OpenSSL} C bindings *)
 
 module Client : sig
+  type verify = { hostname : bool; ip : bool }
+
+  val default_verify : verify
   val default_ctx : [ `Ssl_not_available ]
 
   val create_ctx :
@@ -31,6 +34,8 @@ module Client : sig
     ?ctx:[ `Ssl_not_available ] ->
     ?src:Lwt_unix.sockaddr ->
     ?hostname:string ->
+    ?ip:Ipaddr.t ->
+    ?verify:verify ->
     Lwt_unix.sockaddr ->
     (Lwt_unix.file_descr * Lwt_io.input_channel * Lwt_io.output_channel) Lwt.t
 end

src/conduit-lwt-unix/conduit_lwt_unix_ssl.real.ml

@@ -52,24 +52,61 @@ module Client = struct
 
   let default_ctx = create_ctx ()
 
-  let connect ?(ctx = default_ctx) ?src ?hostname sa =
+  type verify = { hostname : bool; ip : bool }
+
+  let default_verify = { hostname = true; ip = false }
+
+  let validate_hostname host_addr =
+    try
+      let _ = Domain_name.(host_exn (of_string_exn host_addr)) in
+      host_addr
+    with Invalid_argument msg ->
+      let s =
+        Printf.sprintf "couldn't convert %s to a [`host] Domain_name.t: %s"
+          host_addr msg
+      in
+      invalid_arg s
+
+  let verification { hostname; ip } = function
+    | None, _ when hostname -> invalid_arg "impossible to verify hostname"
+    | _, None when ip -> invalid_arg "impossible to verify ip"
+    | h, i ->
+        let hostname =
+          if hostname && h <> None then Option.map validate_hostname h else None
+        in
+        let ip = if ip && i <> None then i else None in
+        (hostname, ip)
+
+  let connect ?(ctx = default_ctx) ?src ?hostname ?ip ?verify sa =
+    let verify = Option.value ~default:default_verify verify in
+    let to_verify = verification verify (hostname, ip) in
     Conduit_lwt_server.with_socket sa (fun fd ->
         (match src with
         | None -> Lwt.return_unit
         | Some src_sa -> Lwt_unix.bind fd src_sa)
         >>= fun () ->
         Lwt_unix.connect fd sa >>= fun () ->
-        (match hostname with
-        | Some host ->
-            let s = Lwt_ssl.embed_uninitialized_socket fd ctx in
-            let ssl = Lwt_ssl.ssl_socket_of_uninitialized_socket s in
-            Ssl.set_client_SNI_hostname ssl host;
-            (* Enable hostname verification *)
-            Ssl.set_hostflags ssl [ Ssl.No_partial_wildcards ];
-            Ssl.set_host ssl host;
-            Lwt_ssl.ssl_perform_handshake s
-        | None -> Lwt_ssl.ssl_connect fd ctx)
-        >>= fun sock -> Lwt.return (chans_of_fd sock))
+        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
+          f socket;
+          Lwt_ssl.ssl_perform_handshake s
+        in
+        let maybe_verify ssl = function
+          | Some hostname, Some ip ->
+              Ssl.set_hostflags ssl [ Ssl.No_partial_wildcards ];
+              Ssl.set_client_SNI_hostname ssl hostname;
+              Ssl.set_host ssl hostname;
+              Ssl.set_ip ssl (Ipaddr.to_string ip)
+          | Some hostname, None ->
+              Ssl.set_hostflags ssl [ Ssl.No_partial_wildcards ];
+              Ssl.set_client_SNI_hostname ssl hostname;
+              Ssl.set_host ssl hostname
+          | None, Some ip -> Ssl.set_ip ssl (Ipaddr.to_string ip)
+          | None, None -> ()
+        in
+        with_socket (fun ssl -> maybe_verify ssl to_verify) >>= fun sock ->
+        Lwt.return (chans_of_fd sock))
 end
 
 module Server = struct

src/conduit-lwt-unix/conduit_lwt_unix_ssl.real.mli

@@ -18,6 +18,9 @@
 (** TLS/SSL connections via {{:http://www.openssl.org} OpenSSL} C bindings *)
 
 module Client : sig
+  type verify = { hostname : bool; ip : bool }
+
+  val default_verify : verify
   val default_ctx : Ssl.context
 
   val create_ctx :
@@ -31,6 +34,8 @@ module Client : sig
     ?ctx:Ssl.context ->
     ?src:Lwt_unix.sockaddr ->
     ?hostname:string ->
+    ?ip:Ipaddr.t ->
+    ?verify:verify ->
     Lwt_unix.sockaddr ->
     (Lwt_unix.file_descr * Lwt_io.input_channel * Lwt_io.output_channel) Lwt.t
 end