From c1f0433da4b6e553f1e19da350de9c3140ab275c Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Mon, 18 Sep 2023 14:41:00 +0100 Subject: [PATCH 1/3] cohttp-eio: factor out URI resolution This is to allow other resolution systems in future. --- cohttp-eio/src/client.ml | 59 +++++++++++++++++++++------------------- 1 file changed, 31 insertions(+), 28 deletions(-) diff --git a/cohttp-eio/src/client.ml b/cohttp-eio/src/client.ml index e9a8bc4f1..ab2c5dd22 100644 --- a/cohttp-eio/src/client.ml +++ b/cohttp-eio/src/client.ml @@ -2,38 +2,21 @@ open Eio.Std include Client_intf open Utils +type connection = [`Generic] Eio.Net.stream_socket_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 +62,26 @@ include end) (Io.IO) -type t = [ `Generic ] Eio.Net.ty r - -let make net = (net :> t) +let make net : t = + let net = (net :> [ `Generic ] Eio.Net.ty r) in + fun ~sw uri -> + Eio.Net.connect ~sw net @@ + 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") From 09d8f148b3d535dc9a990e4f197d04631ac543ca Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Mon, 18 Sep 2023 14:53:17 +0100 Subject: [PATCH 2/3] cohttp-eio: add Client.make_generic and HTTPS support The new `Client.make_generic` allows the user to provide their own function for resolving URIs to flows. The convenience wrapper `make` now taken an `https` argument, which is a function that can be used to wrap raw sockets with a TLS library. The `client_tls.ml` example shows how to use this with tls-eio. --- cohttp-eio.opam | 2 + cohttp-eio/examples/client1.ml | 2 +- cohttp-eio/examples/client_timeout.ml | 2 +- cohttp-eio/examples/client_tls.ml | 26 +++++++++++++ cohttp-eio/examples/docker_client.ml | 2 +- cohttp-eio/examples/dune | 4 +- cohttp-eio/src/client.ml | 56 ++++++++++++++++----------- cohttp-eio/src/client.mli | 20 +++++++++- dune-project | 2 + 9 files changed, 87 insertions(+), 29 deletions(-) create mode 100644 cohttp-eio/examples/client_tls.ml 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..3b54a07d5 --- /dev/null +++ b/cohttp-eio/examples/client_tls.ml @@ -0,0 +1,26 @@ +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..4f0a2dfb7 100644 --- a/cohttp-eio/examples/dune +++ b/cohttp-eio/examples/dune @@ -1,6 +1,6 @@ (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 ab2c5dd22..c01a978a1 100644 --- a/cohttp-eio/src/client.ml +++ b/cohttp-eio/src/client.ml @@ -2,7 +2,7 @@ open Eio.Std include Client_intf open Utils -type connection = [`Generic] Eio.Net.stream_socket_ty r +type connection = Eio.Flow.two_way_ty r type t = sw:Switch.t -> Uri.t -> connection @@ -62,26 +62,38 @@ include end) (Io.IO) -let make net : t = +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 ~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 -> - Eio.Net.connect ~sw net @@ - 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") + 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..f9f676ecc 100644 --- a/cohttp-eio/src/client.mli +++ b/cohttp-eio/src/client.mli @@ -1,9 +1,25 @@ +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 From 822285a959fa5360fb691490d8449bea6af375aa Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Wed, 25 Oct 2023 11:54:38 +0100 Subject: [PATCH 3/3] Make CI happy --- CHANGES.md | 1 + cohttp-eio/examples/client_tls.ml | 12 +++++++++--- cohttp-eio/examples/dune | 11 ++++++++++- cohttp-eio/src/client.ml | 28 +++++++++++++++++----------- cohttp-eio/src/client.mli | 22 +++++++++++++--------- 5 files changed, 50 insertions(+), 24 deletions(-) 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/examples/client_tls.ml b/cohttp-eio/examples/client_tls.ml index 3b54a07d5..3ccba76ba 100644 --- a/cohttp-eio/examples/client_tls.ml +++ b/cohttp-eio/examples/client_tls.ml @@ -5,18 +5,24 @@ let () = 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 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 + 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 + 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") diff --git a/cohttp-eio/examples/dune b/cohttp-eio/examples/dune index 4f0a2dfb7..7e5f48ac5 100644 --- a/cohttp-eio/examples/dune +++ b/cohttp-eio/examples/dune @@ -1,6 +1,15 @@ (executables (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)) + (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 c01a978a1..7525b074f 100644 --- a/cohttp-eio/src/client.ml +++ b/cohttp-eio/src/client.ml @@ -3,7 +3,6 @@ include Client_intf open Utils type connection = Eio.Flow.two_way_ty r - type t = sw:Switch.t -> Uri.t -> connection include @@ -15,7 +14,7 @@ include let map_context v f t ~sw = f (v t ~sw) - let call (t:t) ~sw ?headers ?body ?(chunked = false) meth uri = + let call (t : t) ~sw ?headers ?body ?(chunked = false) meth uri = let socket = t ~sw uri in let body_length = if chunked then None @@ -84,16 +83,23 @@ let tcp_address ~net uri = 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 + 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) + (* 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 + 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 f9f676ecc..e3276211f 100644 --- a/cohttp-eio/src/client.mli +++ b/cohttp-eio/src/client.mli @@ -9,16 +9,20 @@ include and type body = Body.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. + 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. -*) + - 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