conduit: allow turning TLS hostname verification off by setting hostn…

[edwintorok]

…ame to None

In some cases doing hostname verification can be too strict,
and there is no way to turn that off currently without also turning TLS
chain verification off.

Add a change here to allow 'hostname=None' to mean no hostname
verification.
Once we properly pass all the hostname in xapi-clusterd we can undo
this.

Reviewing this here is a bit awkward because it shows the diff-of-a-diff

[edwintorok]

The upstream PR for the original patch is here and didn't get merged yet mirage/ocaml-conduit#390

[edwintorok]

Recommend reviewing this with the 'side-by-side/split' diff setting, not the default unified diff setting (click the gear icon)

[lindig]

Below is the resulting diff in context against Conduit 2.2.2 - which we are using. This patch makes it possible to use overrrides; the current PR enhances the capabilities of these overrides.

commit 7652459fc1dc3bafaba854a2f84d490d4d76beff
Author: Christian Lindig <christian.lindig@citrix.com>
Date:   Mon Jan 24 09:36:30 2022 +0000

    Citrix patch v2
    
    Signed-off-by: Christian Lindig <christian.lindig@citrix.com>

diff --git a/lwt-unix/conduit_lwt_unix.ml b/lwt-unix/conduit_lwt_unix.ml
index 8dade88d..9c515648 100644
--- a/lwt-unix/conduit_lwt_unix.ml
+++ b/lwt-unix/conduit_lwt_unix.ml
@@ -110,6 +110,7 @@ type tls_server_key = tls_own_key [@@deriving sexp]
 type ctx = {
   src: Unix.sockaddr option;
   tls_own_key: tls_own_key;
+  openssl_overrides : Conduit_lwt_unix_ssl.Overrides.t option;
 }
 
 let string_of_unix_sockaddr sa =
@@ -155,19 +156,19 @@ let flow_of_fd fd sa =
   | Unix.ADDR_INET (ip,port) -> TCP { fd; ip=Ipaddr_unix.of_inet_addr ip; port }
 
 let default_ctx =
-  { src=None; tls_own_key=`None }
+  { src=None; tls_own_key=`None; openssl_overrides=None; }
 
-let init ?src ?(tls_own_key=`None) ?(tls_server_key=`None) () =
+let init ?src ?(tls_own_key=`None) ?(tls_server_key=`None) ?openssl_overrides () =
   let tls_own_key =
     match tls_own_key with `None -> tls_server_key | _ -> tls_own_key in
   match src with
   | None ->
-    Lwt.return { src=None; tls_own_key }
+    Lwt.return { src=None; tls_own_key; openssl_overrides; }
   | 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 }
+    | {ai_addr;_}::_ -> Lwt.return { src=Some ai_addr; tls_own_key; openssl_overrides; }
     | [] -> Lwt.fail_with "Invalid conduit source address specified"
 
 module Sockaddr_io = struct
@@ -270,7 +271,16 @@ let connect_with_openssl ~ctx (`Hostname hostname, `IP ip, `Port port) =
         in
         Some ctx_ssl
   in
-  Conduit_lwt_unix_ssl.Client.connect ?ctx:ctx_ssl ?src:ctx.src ~hostname sa
+  let hostname, ctx_ssl =
+    match ctx.openssl_overrides with
+    | None | Some { client = None } -> (Some hostname, ctx_ssl)
+    | Some { client = Some overrides } ->
+        let ctx_ssl =
+          match overrides.ctx with Some x -> Some x | None -> ctx_ssl
+        in
+        (overrides.hostname, ctx_ssl)
+  in
+  Conduit_lwt_unix_ssl.Client.connect ?ctx:ctx_ssl ?src:ctx.src ?hostname sa
   >>= fun (fd, ic, oc) ->
   let flow = TCP {fd;ip;port} in
   Lwt.return (flow, ic, oc)
diff --git a/lwt-unix/conduit_lwt_unix.mli b/lwt-unix/conduit_lwt_unix.mli
index e5db5d08..37ad7519 100644
--- a/lwt-unix/conduit_lwt_unix.mli
+++ b/lwt-unix/conduit_lwt_unix.mli
@@ -166,6 +166,7 @@ val init :
   ?src:string ->
   ?tls_own_key:tls_own_key ->
   ?tls_server_key:tls_own_key (* Deprecated, use tls_own_key. *) ->
+  ?openssl_overrides:Conduit_lwt_unix_ssl.Overrides.t ->
   unit -> ctx io
 
 (** [connect ~ctx client] establishes an outgoing connection
diff --git a/lwt-unix/conduit_lwt_unix_ssl_dummy.ml b/lwt-unix/conduit_lwt_unix_ssl_dummy.ml
index b11f8d2e..6e7d57dd 100644
--- a/lwt-unix/conduit_lwt_unix_ssl_dummy.ml
+++ b/lwt-unix/conduit_lwt_unix_ssl_dummy.ml
@@ -15,6 +15,14 @@
  *
  *)
 
+module Overrides = struct
+  module Client = struct
+    type t = { ctx : [ `Ssl_not_available ] option ; hostname : string option }
+  end
+
+  type t = { client : Client.t option }
+end
+
 module Client = struct
   let default_ctx = `Ssl_not_available
 
diff --git a/lwt-unix/conduit_lwt_unix_ssl_dummy.mli b/lwt-unix/conduit_lwt_unix_ssl_dummy.mli
index 24b73b07..cf25544c 100644
--- a/lwt-unix/conduit_lwt_unix_ssl_dummy.mli
+++ b/lwt-unix/conduit_lwt_unix_ssl_dummy.mli
@@ -17,6 +17,14 @@
 
 (** TLS/SSL connections via {{:http://www.openssl.org}OpenSSL} C bindings *)
 
+module Overrides : sig
+  module Client : sig
+    type t = { ctx : [ `Ssl_not_available ] option ; hostname : string option }
+  end
+
+  type t = { client : Client.t option }
+end
+
 module Client : sig
   val default_ctx : [`Ssl_not_available]
 
diff --git a/lwt-unix/conduit_lwt_unix_ssl_real.ml b/lwt-unix/conduit_lwt_unix_ssl_real.ml
index 9aca9bb8..330bd03a 100644
--- a/lwt-unix/conduit_lwt_unix_ssl_real.ml
+++ b/lwt-unix/conduit_lwt_unix_ssl_real.ml
@@ -27,6 +27,14 @@ let chans_of_fd sock =
   let ic = Lwt_io.make ~mode:Lwt_io.input ~close (Lwt_ssl.read_bytes sock) in
   ((Lwt_ssl.get_fd sock), ic, oc)
 
+module Overrides = struct
+  module Client = struct
+    type t = { ctx : Ssl.context option; hostname : string option }
+  end
+
+  type t = { client : Client.t option }
+end
+
 module Client = struct
   let create_ctx ?certfile ?keyfile ?password () =
     let ctx = Ssl.create_context Ssl.SSLv23 Ssl.Client_context in
diff --git a/lwt-unix/conduit_lwt_unix_ssl_real.mli b/lwt-unix/conduit_lwt_unix_ssl_real.mli
index 018bc655..64356eab 100644
--- a/lwt-unix/conduit_lwt_unix_ssl_real.mli
+++ b/lwt-unix/conduit_lwt_unix_ssl_real.mli
@@ -17,6 +17,14 @@
 
 (** TLS/SSL connections via {{:http://www.openssl.org}OpenSSL} C bindings *)
 
+module Overrides : sig
+  module Client : sig
+    type t = { ctx : Ssl.context option; hostname : string option }
+  end
+
+  type t = { client : Client.t option }
+end
+
 module Client : sig
   val default_ctx : Ssl.context