Improve the API to be more user-friendly (@pitag-ha)

This commit is contained in:
Romain Calascibetta 2022-10-17 14:36:15 +02:00
parent a4a7358c4d
commit 809fa5cd33
2 changed files with 35 additions and 29 deletions

View file

@ -5,16 +5,23 @@ let tls_config = Mimic.make ~name:"tls-config"
open Lwt.Infix 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 module type S = sig
val connect : Mimic.ctx -> Mimic.ctx Lwt.t type nonrec t = t
val alpn_protocol : Mimic.flow -> string option
val authenticator : (X509.Authenticator.t, [> `Msg of string ]) result val connect : Mimic.ctx -> t Lwt.t
end end
module Make module Make
(Pclock : Mirage_clock.PCLOCK) (Pclock : Mirage_clock.PCLOCK)
(TCP : Tcpip.Tcp.S) (TCP : Tcpip.Tcp.S)
(Happy_eyeballs : Mimic_happy_eyeballs.S with type flow = TCP.flow) : S = struct (Happy_eyeballs : Mimic_happy_eyeballs.S with type flow = TCP.flow) : S = struct
type nonrec t = t
module TCP = struct module TCP = struct
include TCP include TCP
type endpoint = Happy_eyeballs.t * string * int type endpoint = Happy_eyeballs.t * string * int
@ -60,23 +67,6 @@ module Make
let tls_edn, tls_protocol = let tls_edn, tls_protocol =
Mimic.register ~name:"tls" (module TLS) 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 alpn_protocol flow =
let module M = (val (Mimic.repr tls_protocol)) in let module M = (val (Mimic.repr tls_protocol)) in
match flow with match flow with
@ -89,6 +79,24 @@ module Make
let authenticator = let authenticator =
let module V = Ca_certs_nss.Make (Pclock) in let module V = Ca_certs_nss.Make (Pclock) in
V.authenticator () 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 end
module Version = Httpaf.Version module Version = Httpaf.Version
@ -310,9 +318,7 @@ let resolve_location ~uri ~location =
let one_request let one_request
?config ?config
?tls_config:cfg ?tls_config:cfg
~ctx { ctx; alpn_protocol; authenticator; }
~alpn_protocol
~authenticator
?(meth= `GET) ?(meth= `GET)
?(headers= []) ?(headers= [])
?body ?body

View file

@ -1,7 +1,9 @@
type t
module type S = sig module type S = sig
val connect : Mimic.ctx -> Mimic.ctx Lwt.t type nonrec t = t
val alpn_protocol : Mimic.flow -> string option
val authenticator : (X509.Authenticator.t, [> `Msg of string ]) result val connect : Mimic.ctx -> t Lwt.t
end end
module Make module Make
@ -22,9 +24,7 @@ type response =
val one_request : val one_request :
?config:[ `H2 of H2.Config.t | `HTTP_1_1 of Httpaf.Config.t ] -> ?config:[ `H2 of H2.Config.t | `HTTP_1_1 of Httpaf.Config.t ] ->
?tls_config:Tls.Config.client -> ?tls_config:Tls.Config.client ->
ctx:Mimic.ctx -> t ->
alpn_protocol:(Mimic.flow -> string option) ->
authenticator:(X509.Authenticator.t, [> `Msg of string ]) result ->
?meth:Httpaf.Method.t -> ?meth:Httpaf.Method.t ->
?headers:(string * string) list -> ?headers:(string * string) list ->
?body:string -> ?body:string ->