Merge pull request #1002 from talex5/eio-tls

cohttp-eio: add Client.make_generic and HTTPS support

CHANGES.md

@@ -1,5 +1,6 @@
 ## v6.0.0~beta1 (2023-10-24)
 - cohttp-eio: Complete rewrite to follow common interfaces and behaviors. (mefyl #984)
+- cohttp-eio: Add Client.make_generic and HTTPS support. (talex5 #1002)
 
 ## v6.0.0~alpha2 (2023-08-08)
 - cohttp-lwt: Do not leak exceptions to `Lwt.async_exception_hook`. (mefyl #992, #995)

cohttp-eio.opam

@@ -27,6 +27,8 @@ depends: [
   "eio_main" {with-test}
   "mdx" {with-test}
   "uri" {with-test}
+  "tls-eio" {with-test & >= "0.17.2"}
+  "mirage-crypto-rng-eio" {with-test & >= "0.11.2"}
   "fmt"
   "ptime"
   "http" {= version}

cohttp-eio/examples/client1.ml

@@ -10,7 +10,7 @@ and () = Logs.Src.set_level Cohttp_eio.src (Some Debug)
 
 let () =
   Eio_main.run @@ fun env ->
-  let client = Client.make env#net in
+  let client = Client.make ~https:None env#net in
   Eio.Switch.run @@ fun sw ->
   let resp, body = Client.get ~sw client (Uri.of_string "http://example.com") in
   if Http.Status.compare resp.status `OK = 0 then

cohttp-eio/examples/client_timeout.ml

@@ -2,7 +2,7 @@ open Cohttp_eio
 
 let () =
   Eio_main.run @@ fun env ->
-  let client = Client.make env#net in
+  let client = Client.make ~https:None env#net in
   (* Increment/decrement this value to see success/failure. *)
   let timeout_s = 0.01 in
   Eio.Time.with_timeout env#clock timeout_s (fun () ->

cohttp-eio/examples/client_tls.ml

@@ -0,0 +1,32 @@
+open Cohttp_eio
+
+let () =
+  Logs.set_reporter (Logs_fmt.reporter ());
+  Logs_threaded.enable ();
+  Logs.Src.set_level Cohttp_eio.src (Some Debug)
+
+let null_auth ?ip:_ ~host:_ _ =
+  Ok None (* Warning: use a real authenticator in your code! *)
+
+let https ~authenticator =
+  let tls_config = Tls.Config.client ~authenticator () in
+  fun uri raw ->
+    let host =
+      Uri.host uri
+      |> Option.map (fun x -> Domain_name.(host_exn (of_string_exn x)))
+    in
+    Tls_eio.client_of_flow ?host tls_config raw
+
+let () =
+  Eio_main.run @@ fun env ->
+  Mirage_crypto_rng_eio.run (module Mirage_crypto_rng.Fortuna) env @@ fun () ->
+  let client =
+    Client.make ~https:(Some (https ~authenticator:null_auth)) env#net
+  in
+  Eio.Switch.run @@ fun sw ->
+  let resp, body =
+    Client.get ~sw client (Uri.of_string "https://example.com")
+  in
+  if Http.Status.compare resp.status `OK = 0 then
+    print_string @@ Eio.Buf_read.(parse_exn take_all) body ~max_size:max_int
+  else Fmt.epr "Unexpected HTTP status: %a" Http.Status.pp resp.status

cohttp-eio/examples/docker_client.ml

@@ -10,7 +10,7 @@ and () = Logs.Src.set_level Cohttp_eio.src (Some Debug)
 
 let () =
   Eio_main.run @@ fun env ->
-  let client = Client.make env#net in
+  let client = Client.make ~https:None env#net in
   Eio.Switch.run @@ fun sw ->
   let response, body =
     Client.get client ~sw

cohttp-eio/examples/dune

@@ -1,6 +1,15 @@
 (executables
- (names server1 client1 docker_client client_timeout)
- (libraries cohttp-eio eio_main eio.unix fmt unix logs.fmt logs.threaded))
+ (names server1 client1 docker_client client_timeout client_tls)
+ (libraries
+  cohttp-eio
+  eio_main
+  eio.unix
+  fmt
+  unix
+  logs.fmt
+  logs.threaded
+  tls-eio
+  mirage-crypto-rng-eio))
 
 (alias
  (name runtest)

cohttp-eio/src/client.ml

@@ -2,38 +2,20 @@ open Eio.Std
 include Client_intf
 open Utils
 
+type connection = Eio.Flow.two_way_ty r
+type t = sw:Switch.t -> Uri.t -> connection
+
 include
   Cohttp.Client.Make
     (struct
       type 'a io = 'a
       type body = Body.t
-      type 'a with_context = [ `Generic ] Eio.Net.ty r -> sw:Eio.Switch.t -> 'a
+      type 'a with_context = t -> sw:Eio.Switch.t -> 'a
 
-      let map_context v f net ~sw = f (v net ~sw)
+      let map_context v f t ~sw = f (v t ~sw)
 
-      let call net ~sw ?headers ?body ?(chunked = false) meth uri =
-        let addr =
-          match Uri.scheme uri with
-          | Some "httpunix"
-          (* FIXME: while there is no standard, http+unix seems more widespread *)
-            -> (
-              match Uri.host uri with
-              | Some path -> `Unix path
-              | None -> failwith "no host specified with httpunix")
-          | _ -> (
-              let service =
-                match Uri.port uri with
-                | Some port -> Int.to_string port
-                | _ -> Uri.scheme uri |> Option.value ~default:"http"
-              in
-              match
-                Eio.Net.getaddrinfo_stream ~service net
-                  (Uri.host_with_default ~default:"localhost" uri)
-              with
-              | ip :: _ -> ip
-              | [] -> failwith "failed to resolve hostname")
-        in
-        let socket = Eio.Net.connect ~sw net addr in
+      let call (t : t) ~sw ?headers ?body ?(chunked = false) meth uri =
+        let socket = t ~sw uri in
         let body_length =
           if chunked then None
           else
@@ -79,6 +61,45 @@ include
     end)
     (Io.IO)
 
-type t = [ `Generic ] Eio.Net.ty r
+let make_generic fn = (fn :> t)
+
+let unix_address uri =
+  match Uri.host uri with
+  | Some path -> `Unix path
+  | None -> Fmt.failwith "no host specified (in %a)" Uri.pp uri
+
+let tcp_address ~net uri =
+  let service =
+    match Uri.port uri with
+    | Some port -> Int.to_string port
+    | _ -> Uri.scheme uri |> Option.value ~default:"http"
+  in
+  match
+    Eio.Net.getaddrinfo_stream ~service net
+      (Uri.host_with_default ~default:"localhost" uri)
+  with
+  | ip :: _ -> ip
+  | [] -> failwith "failed to resolve hostname"
 
-let make net = (net :> t)
+let make ~https net : t =
+  let net = (net :> [ `Generic ] Eio.Net.ty r) in
+  let https =
+    (https
+      :> (Uri.t -> [ `Generic ] Eio.Net.stream_socket_ty r -> connection) option)
+  in
+  fun ~sw uri ->
+    match Uri.scheme uri with
+    | Some "httpunix" ->
+        (* FIXME: while there is no standard, http+unix seems more widespread *)
+        (Eio.Net.connect ~sw net (unix_address uri) :> connection)
+    | Some "http" ->
+        (Eio.Net.connect ~sw net (tcp_address ~net uri) :> connection)
+    | Some "https" -> (
+        match https with
+        | Some wrap ->
+            wrap uri @@ Eio.Net.connect ~sw net (tcp_address ~net uri)
+        | None -> Fmt.failwith "HTTPS not enabled (for %a)" Uri.pp uri)
+    | x ->
+        Fmt.failwith "Unknown scheme %a"
+          Fmt.(option ~none:(any "None") Dump.string)
+          x

cohttp-eio/src/client.mli

@@ -1,9 +1,29 @@
+open Eio.Std
+
 type t
 
 include
   Cohttp.Client.S
-    with type 'a with_context = t -> sw:Eio.Switch.t -> 'a
+    with type 'a with_context = t -> sw:Switch.t -> 'a
      and type 'a io = 'a
      and type body = Body.t
 
-val make : _ Eio.Net.t -> t
+val make :
+  https:
+    (Uri.t -> [ `Generic ] Eio.Net.stream_socket_ty r -> _ Eio.Flow.two_way)
+    option ->
+  _ Eio.Net.t ->
+  t
+(** [make ~https net] is a convenience wrapper around {!make_generic} that uses
+    [net] to make connections.
+
+    - URIs of the form "http://host:port/..." connect to the given TCP host and
+      port.
+    - URIs of the form "https://host:port/..." connect to the given TCP host and
+      port, and are then wrapped by [https] (or rejected if that is [None]).
+    - URIs of the form "httpunix://unix-path/http-path" connect to the given
+      Unix path. *)
+
+val make_generic : (sw:Switch.t -> Uri.t -> _ Eio.Net.stream_socket) -> t
+(** [make_generic connect] is an HTTP client that uses [connect] to get the
+    connection to use for a given URI. *)

dune-project

@@ -372,6 +372,8 @@
   (eio_main :with-test)
   (mdx :with-test)
   (uri :with-test)
+  (tls-eio (and :with-test (>= 0.17.2)))
+  (mirage-crypto-rng-eio (and :with-test (>= 0.11.2)))
   fmt
   ptime
   (http