From 809fa5cd33920b48857d4b73149f529a804ac4ac Mon Sep 17 00:00:00 2001 From: Romain Calascibetta Date: Mon, 17 Oct 2022 14:36:15 +0200 Subject: [PATCH 1/6] Improve the API to be more user-friendly (@pitag-ha) --- src/http_mirage_client.ml | 52 +++++++++++++++++++++----------------- src/http_mirage_client.mli | 12 ++++----- 2 files changed, 35 insertions(+), 29 deletions(-) diff --git a/src/http_mirage_client.ml b/src/http_mirage_client.ml index c1713ff..1c14f73 100644 --- a/src/http_mirage_client.ml +++ b/src/http_mirage_client.ml @@ -5,16 +5,23 @@ let tls_config = Mimic.make ~name:"tls-config" open Lwt.Infix +type t = + { ctx : Mimic.ctx + ; alpn_protocol : Mimic.flow -> string option + ; authenticator : (X509.Authenticator.t, [ `Msg of string ]) result } + module type S = sig - val connect : Mimic.ctx -> Mimic.ctx Lwt.t - val alpn_protocol : Mimic.flow -> string option - val authenticator : (X509.Authenticator.t, [> `Msg of string ]) result + type nonrec t = t + + val connect : Mimic.ctx -> t Lwt.t end module Make (Pclock : Mirage_clock.PCLOCK) (TCP : Tcpip.Tcp.S) (Happy_eyeballs : Mimic_happy_eyeballs.S with type flow = TCP.flow) : S = struct + type nonrec t = t + module TCP = struct include TCP type endpoint = Happy_eyeballs.t * string * int @@ -60,23 +67,6 @@ module Make let tls_edn, tls_protocol = Mimic.register ~name:"tls" (module TLS) - let connect ctx = - let k0 happy_eyeballs http_scheme http_hostname http_port = match http_scheme with - | "http" -> Lwt.return_some (happy_eyeballs, http_hostname, http_port) - | _ -> Lwt.return_none in - let k1 happy_eyeballs http_scheme http_hostname http_port tls_config = match http_scheme with - | "https" -> Lwt.return_some (happy_eyeballs, tls_config, http_hostname, http_port) - | _ -> Lwt.return_none in - let ctx = Mimic.fold tcp_edn - Mimic.Fun.[ req Happy_eyeballs.happy_eyeballs - ; req http_scheme; req http_hostname; dft http_port 80 ] - ~k:k0 ctx in - Lwt.return (Mimic.fold tls_edn - Mimic.Fun.[ req Happy_eyeballs.happy_eyeballs - ; req http_scheme; req http_hostname; dft http_port 443 - ; req tls_config ] - ~k:k1 ctx) - let alpn_protocol flow = let module M = (val (Mimic.repr tls_protocol)) in match flow with @@ -89,6 +79,24 @@ module Make let authenticator = let module V = Ca_certs_nss.Make (Pclock) in V.authenticator () + + let connect ctx = + let k0 happy_eyeballs http_scheme http_hostname http_port = match http_scheme with + | "http" -> Lwt.return_some (happy_eyeballs, http_hostname, http_port) + | _ -> Lwt.return_none in + let k1 happy_eyeballs http_scheme http_hostname http_port tls_config = match http_scheme with + | "https" -> Lwt.return_some (happy_eyeballs, tls_config, http_hostname, http_port) + | _ -> Lwt.return_none in + let ctx = Mimic.fold tcp_edn + Mimic.Fun.[ req Happy_eyeballs.happy_eyeballs + ; req http_scheme; req http_hostname; dft http_port 80 ] + ~k:k0 ctx in + let ctx = Mimic.fold tls_edn + Mimic.Fun.[ req Happy_eyeballs.happy_eyeballs + ; req http_scheme; req http_hostname; dft http_port 443 + ; req tls_config ] + ~k:k1 ctx in + Lwt.return { ctx; alpn_protocol; authenticator; } end module Version = Httpaf.Version @@ -310,9 +318,7 @@ let resolve_location ~uri ~location = let one_request ?config ?tls_config:cfg - ~ctx - ~alpn_protocol - ~authenticator + { ctx; alpn_protocol; authenticator; } ?(meth= `GET) ?(headers= []) ?body diff --git a/src/http_mirage_client.mli b/src/http_mirage_client.mli index 55c5574..12303c0 100644 --- a/src/http_mirage_client.mli +++ b/src/http_mirage_client.mli @@ -1,7 +1,9 @@ +type t + module type S = sig - val connect : Mimic.ctx -> Mimic.ctx Lwt.t - val alpn_protocol : Mimic.flow -> string option - val authenticator : (X509.Authenticator.t, [> `Msg of string ]) result + type nonrec t = t + + val connect : Mimic.ctx -> t Lwt.t end module Make @@ -22,9 +24,7 @@ type response = val one_request : ?config:[ `H2 of H2.Config.t | `HTTP_1_1 of Httpaf.Config.t ] -> ?tls_config:Tls.Config.client -> - ctx:Mimic.ctx -> - alpn_protocol:(Mimic.flow -> string option) -> - authenticator:(X509.Authenticator.t, [> `Msg of string ]) result -> + t -> ?meth:Httpaf.Method.t -> ?headers:(string * string) list -> ?body:string -> From e0c58e9b704f97a05d44b163a6cddec9a1fa177b Mon Sep 17 00:00:00 2001 From: Romain Calascibetta Date: Mon, 17 Oct 2022 14:36:24 +0200 Subject: [PATCH 2/6] Add a LICENSE.md (MIT) --- LICENSE.md | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/LICENSE.md b/LICENSE.md index e69de29..52a1d15 100644 --- a/LICENSE.md +++ b/LICENSE.md @@ -0,0 +1,20 @@ +The MIT License (MIT) + +Copyright (c) 2022 Romain Calascibetta + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of +the Software, and to permit persons to whom the Software is furnished to do so, +subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS +FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR +COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER +IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. From 8b7a8fb5280da677389fafa12a77452db1e94f57 Mon Sep 17 00:00:00 2001 From: Romain Calascibetta Date: Mon, 17 Oct 2022 14:36:34 +0200 Subject: [PATCH 3/6] Improve the README.md --- README.md | 61 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 61 insertions(+) diff --git a/README.md b/README.md index e69de29..52bd9ec 100644 --- a/README.md +++ b/README.md @@ -0,0 +1,61 @@ +# An HTTP (http/1.1 or h2) client for MirageOS + +This little library provides an HTTP client which can be usable inside a +unikernel/[MirageOS][mirage]. It follows the same API as +[http-lwt-client][http-lwt-client] which is pretty simple and uses: +- [happy-eyeballs][happy-eyeballs] to resolve domain-name +- [ocaml-tls][ocaml-tls] for the TLS layer +- [paf][paf] for the HTTP protocol + +This library wants to be easy to use and it is associated to a MirageOS +_device_ in order to facilite `functoria` to compose everything (mainly the +TCP/IP stack) according to the user's target and give a _witness_ so as to +be able to allocate a new connection to a peer and process the HTTP flow. + +## How to use it? + +First, you need to describe a new `http_client` device: +```ocaml +open Mirage + +type http_client = HTTP_client +let http_client = typ HTTP_client + +let http_client = + let connect _ modname = function + | [ _pclock; _tcpv4v6; ctx ] -> + Fmt.str {ocaml|%s.connect %s|ocaml} modname ctx + | _ -> assert false in + impl ~connect "Http_mirage_client.Make" + (pclock @-> tcpv4v6 @-> git_client @-> http_client) +``` + +Then, you can decide how to construct such device: +```ocaml +let stack = generic_stackv4v6 default_network +let dns = generic_dns_client stack +let tcp = tcpv4v6_of_stackv4v6 stack + +let http_client = + let happy_eyeballs = git_happy_eyeballs stack dns + (generic_happy_eyeballs stack dns) in + http_client $ default_posix_clock $ tcp $ happy_eyeballs +``` + +Finally, you can use the _witness_ into your `unikernel.ml`: +```ocaml +open Lwt.Infix + +module Make (HTTP_client : Http_mirage_client.S) = struct + let start http_client = + Http_mirage_client.one_request http_client "https://google.com/" + >>= function + | Ok (resp, body) -> ... + | Error _ -> ... +end + +[mirage]: https://mirage.io/ +[happy-eyeballs]: https://github.com/roburio/happy-eyeballs +[ocaml-tls]: https://github.com/mirleft/ocaml-tls +[paf]: https://github.com/dinosaure/paf-le-chien +[http-lwt-client]: https://github.com/roburio/http-lwt-client From ab520b4c3e253149404235e774a77dac0d320842 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Mon, 17 Oct 2022 15:03:24 +0200 Subject: [PATCH 4/6] Update the example with https://mirage.io/ MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Reynir Björnsson --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 52bd9ec..0087908 100644 --- a/README.md +++ b/README.md @@ -48,7 +48,7 @@ open Lwt.Infix module Make (HTTP_client : Http_mirage_client.S) = struct let start http_client = - Http_mirage_client.one_request http_client "https://google.com/" + Http_mirage_client.one_request http_client "https://mirage.io/" >>= function | Ok (resp, body) -> ... | Error _ -> ... From 546a06441c648d10ff1f420f43a46cbab38aa044 Mon Sep 17 00:00:00 2001 From: Romain Calascibetta Date: Mon, 17 Oct 2022 15:10:54 +0200 Subject: [PATCH 5/6] Be able to specify our own authenticator --- src/http_mirage_client.ml | 10 +++++++--- src/http_mirage_client.mli | 1 + 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/src/http_mirage_client.ml b/src/http_mirage_client.ml index 1c14f73..2b0f81d 100644 --- a/src/http_mirage_client.ml +++ b/src/http_mirage_client.ml @@ -291,7 +291,7 @@ let single_request ~ctx ~alpn_protocol ?config cfg ~meth ~headers ?body uri = Mimic.close flow >|= fun () -> r -let tls_config ?tls_config ?config authenticator = +let tls_config ?tls_config ?config authenticator user's_authenticator = lazy ( match tls_config with | Some cfg -> Ok (`Custom cfg) | None -> @@ -299,7 +299,10 @@ let tls_config ?tls_config ?config authenticator = | None -> [ "h2"; "http/1.1" ] | Some (`H2 _) -> [ "h2" ] | Some (`HTTP_1_1 _) -> [ "http/1.1" ] in - Result.map (fun authenticator -> `Default (Tls.Config.client ~alpn_protocols ~authenticator ())) authenticator ) + match authenticator, user's_authenticator with + | Ok authenticator, None -> Ok (`Default (Tls.Config.client ~alpn_protocols ~authenticator ())) + | _, Some authenticator -> Ok (`Default (Tls.Config.client ~alpn_protocols ~authenticator ())) + | (Error _ as err), None -> err ) let resolve_location ~uri ~location = match String.split_on_char '/' location with @@ -319,12 +322,13 @@ let one_request ?config ?tls_config:cfg { ctx; alpn_protocol; authenticator; } + ?authenticator:user's_authenticator ?(meth= `GET) ?(headers= []) ?body ?(max_redirect= 5) ?(follow_redirect= true) uri = - let tls_config = tls_config ?tls_config:cfg ?config authenticator in + let tls_config = tls_config ?tls_config:cfg ?config authenticator user's_authenticator in if not follow_redirect then single_request ~ctx ~alpn_protocol ?config tls_config ~meth ~headers ?body uri else diff --git a/src/http_mirage_client.mli b/src/http_mirage_client.mli index 12303c0..2ab7e8c 100644 --- a/src/http_mirage_client.mli +++ b/src/http_mirage_client.mli @@ -25,6 +25,7 @@ val one_request : ?config:[ `H2 of H2.Config.t | `HTTP_1_1 of Httpaf.Config.t ] -> ?tls_config:Tls.Config.client -> t -> + ?authenticator:X509.Authenticator.t -> ?meth:Httpaf.Method.t -> ?headers:(string * string) list -> ?body:string -> From b707beed78f4fad375408555c57ba07be1372fc5 Mon Sep 17 00:00:00 2001 From: Romain Calascibetta Date: Mon, 17 Oct 2022 15:15:02 +0200 Subject: [PATCH 6/6] Add a comment into the HTTP_client device to explain why the Git word appears --- README.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/README.md b/README.md index 0087908..c39e22e 100644 --- a/README.md +++ b/README.md @@ -37,6 +37,10 @@ let dns = generic_dns_client stack let tcp = tcpv4v6_of_stackv4v6 stack let http_client = + (* XXX(dinosaure): it seems unconventional to use [git_happy_eyeballs] here + when we want to do HTTP requests only. The name was not so good and we + will fix that into the next release of the mirage tool. But structurally, + you don't bring anything related to Git. It's just a bad choice of name. *) let happy_eyeballs = git_happy_eyeballs stack dns (generic_happy_eyeballs stack dns) in http_client $ default_posix_clock $ tcp $ happy_eyeballs