Merge pull request #1 from roburio/improve

Improve the library

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.

README.md

@@ -0,0 +1,65 @@
+# 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 =
+  (* 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
+```
+
+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://mirage.io/"
+    >>= 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

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
@@ -283,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 ->
@@ -291,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
@@ -310,15 +321,14 @@ let resolve_location ~uri ~location =
 let one_request
   ?config
   ?tls_config:cfg
-  ~ctx
-  ~alpn_protocol
-  ~authenticator
+  { 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

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,8 @@ 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 ->
+  ?authenticator:X509.Authenticator.t ->
   ?meth:Httpaf.Method.t ->
   ?headers:(string * string) list ->
   ?body:string ->