extend Conduit_lwt_unix.endp with TLS tunnel

Author: art-w

src/conduit-lwt-unix/conduit_lwt_unix.ml

@@ -141,7 +141,7 @@ type vchan_flow = { domid : int; port : string } [@@deriving sexp]
 
 type flow =
   | TCP of tcp_flow
-  | Tunnel
+  | Tunnel of string * ic * oc
   | Domain_socket of domain_flow
   | Vchan of vchan_flow
 [@@deriving sexp]
@@ -294,10 +294,10 @@ let connect_with_tls_native ~ctx (`Hostname hostname, `IP ip, `Port port) =
 
 let connect_with_tls_tunnel ~ctx (`Hostname hostname, ic, oc) =
   certificates ~ctx >>= fun certificates ->
-  let hostname = domain_name hostname in
+  let host = domain_name hostname in
   Conduit_lwt_tls.Client.tunnel ?certificates
-    ~authenticator:ctx.tls_authenticator hostname (ic, oc)
-  >|= fun (ic, oc) -> (Tunnel, ic, oc)
+    ~authenticator:ctx.tls_authenticator host (ic, oc)
+  >|= fun (ic', oc') -> (Tunnel (hostname, ic, oc), ic', oc')
 
 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
@@ -427,15 +427,17 @@ let serve ?backlog ?timeout ?stop ~on_exn ~(ctx : ctx) ~(mode : server) callback
       let fn s = Sockaddr_server.init ~on:(`Socket s) ?timeout ?stop callback in
       Conduit_lwt_launchd.activate fn name
 
+type endp = [ Conduit.endp | `TLS_tunnel of string * ic * oc ] [@@deriving sexp]
+
 let endp_of_flow = function
   | TCP { ip; port; _ } -> `TCP (ip, port)
-  | Tunnel -> `Unknown "TLS tunnel"
+  | Tunnel (hostname, ic, oc) -> `TLS_tunnel (hostname, ic, oc)
   | Domain_socket { path; _ } -> `Unix_domain_socket path
   | Vchan { domid; port } -> `Vchan_direct (domid, port)
 
 (** Use the configuration of the server to interpret how to handle a particular
     endpoint from the resolver into a concrete implementation of type [client] *)
-let endp_to_client ~ctx:_ (endp : Conduit.endp) : client Lwt.t =
+let endp_to_client ~ctx:_ (endp : [< endp ]) : client Lwt.t =
   match endp with
   | `TCP (ip, port) -> Lwt.return (`TCP (`IP ip, `Port port))
   | `Unix_domain_socket file -> Lwt.return (`Unix_domain_socket (`File file))
@@ -449,6 +451,8 @@ let endp_to_client ~ctx:_ (endp : Conduit.endp) : client Lwt.t =
       Printf.ksprintf failwith
         "TLS to non-TCP currently unsupported: host=%s endp=%s" host
         (Sexplib0.Sexp.to_string_hum (Conduit.sexp_of_endp endp))
+  | `TLS_tunnel (host, ic, oc) ->
+      Lwt.return (`TLS_tunnel (`Hostname host, ic, oc))
   | `Unknown err -> failwith ("resolution failed: " ^ err)
 
 let endp_to_server ~ctx (endp : Conduit.endp) =

src/conduit-lwt-unix/conduit_lwt_unix.mli

@@ -26,10 +26,13 @@ type client_tls_config =
 [@@deriving sexp]
 (** Configuration fragment for a TLS client connecting to a remote endpoint *)
 
+type 'a io = 'a Lwt.t
+type ic = (Lwt_io.input_channel[@sexp.opaque]) [@@deriving sexp]
+type oc = (Lwt_io.output_channel[@sexp.opaque]) [@@deriving sexp]
+
 type client =
   [ `TLS of client_tls_config
-  | `TLS_tunnel of
-    [ `Hostname of string ] * Lwt_io.input_channel * Lwt_io.output_channel
+  | `TLS_tunnel of [ `Hostname of string ] * ic * oc
   | `TLS_native of client_tls_config
     (** Force use of native OCaml TLS stack to connect.*)
   | `OpenSSL of client_tls_config
@@ -105,10 +108,6 @@ type server =
       the {{:http://mirage.github.io/ocaml-launchd/launchd/} ocaml-launchd}
       documentation for more. *)
 
-type 'a io = 'a Lwt.t
-type ic = (Lwt_io.input_channel[@sexp.opaque]) [@@deriving sexp]
-type oc = (Lwt_io.output_channel[@sexp.opaque]) [@@deriving sexp]
-
 type tcp_flow = private {
   fd : Lwt_unix.file_descr; [@sexp.opaque]
   ip : Ipaddr.t;
@@ -131,7 +130,7 @@ type vchan_flow = private { domid : int; port : string } [@@deriving sexp_of]
     transport method. *)
 type flow = private
   | TCP of tcp_flow
-  | Tunnel
+  | Tunnel of string * ic * oc
   | Domain_socket of domain_flow
   | Vchan of vchan_flow
 [@@deriving sexp_of]
@@ -207,11 +206,18 @@ val set_max_active : int -> unit
     accepted. When the limit is hit accept blocks until another server
     connection is closed. *)
 
-val endp_of_flow : flow -> Conduit.endp
-(** [endp_of_flow flow] retrieves the original {!Conduit.endp} from the
-    established [flow] *)
+type endp =
+  [ Conduit.endp
+  | `TLS_tunnel of string * ic * oc
+    (** Wrap in a TLS channel over an existing [Lwt_io.channel] connection,
+        [hostname,input_channel,output_channel] *) ]
+[@@deriving sexp]
+
+val endp_of_flow : flow -> endp
+(** [endp_of_flow flow] retrieves the original {!endp} from the established
+    [flow] *)
 
-val endp_to_client : ctx:ctx -> Conduit.endp -> client io
+val endp_to_client : ctx:ctx -> [< endp ] -> client io
 (** [endp_to_client ~ctx endp] converts an [endp] into a a concrete connection
     mechanism of type [client] *)