diff --git a/CHANGES.md b/CHANGES.md index 3046dedb1..18e2e93d1 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,6 @@ ## Unreleased - 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) diff --git a/cohttp-eio.opam b/cohttp-eio.opam index 339f6e3c4..d897cc859 100644 --- a/cohttp-eio.opam +++ b/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} diff --git a/cohttp-eio/examples/client1.ml b/cohttp-eio/examples/client1.ml index 1dd26d39d..905f5294f 100644 --- a/cohttp-eio/examples/client1.ml +++ b/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 diff --git a/cohttp-eio/examples/client_timeout.ml b/cohttp-eio/examples/client_timeout.ml index 277139c4a..305a12efd 100644 --- a/cohttp-eio/examples/client_timeout.ml +++ b/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 () -> diff --git a/cohttp-eio/examples/client_tls.ml b/cohttp-eio/examples/client_tls.ml new file mode 100644 index 000000000..3ccba76ba --- /dev/null +++ b/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 diff --git a/cohttp-eio/examples/docker_client.ml b/cohttp-eio/examples/docker_client.ml index 66d93d7e2..e711e1025 100644 --- a/cohttp-eio/examples/docker_client.ml +++ b/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 diff --git a/cohttp-eio/examples/dune b/cohttp-eio/examples/dune index 778617c63..7e5f48ac5 100644 --- a/cohttp-eio/examples/dune +++ b/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) diff --git a/cohttp-eio/src/client.ml b/cohttp-eio/src/client.ml index e9a8bc4f1..7525b074f 100644 --- a/cohttp-eio/src/client.ml +++ b/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 diff --git a/cohttp-eio/src/client.mli b/cohttp-eio/src/client.mli index 8facd71e9..e3276211f 100644 --- a/cohttp-eio/src/client.mli +++ b/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. *) diff --git a/dune-project b/dune-project index ea0aac27f..fbbe3dd0d 100644 --- a/dune-project +++ b/dune-project @@ -371,6 +371,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