adapt to tls 1.0.0 (#1)

//cc @dinosaure

Reviewed-on: https://git.robur.coop///robur/http-mirage-client/pulls/1
This commit is contained in:
Hannes Mehnert 2024-08-29 10:42:23 +00:00
parent 8497990c8a
commit 1e307d2c5b
5 changed files with 48 additions and 49 deletions

View file

@ -1,4 +1,4 @@
version=0.23.0
version=0.26.2
profile=conventional
break-struct=natural
break-infix=fit-or-vertical

View file

@ -17,11 +17,13 @@ depends: [
"lwt" {>= "5.5.0"}
"mimic-happy-eyeballs" {>= "0.0.9"}
"httpaf"
"alcotest-lwt" {with-test}
"alcotest-lwt" {with-test & >= "1.0.0"}
"mirage-clock-unix" {with-test & >= "4.0.0"}
"mirage-crypto-rng" {with-test}
"mirage-time-unix" {with-test & >= "3.0.0"}
"h2" {>= "0.10.0"}
"tls" {>= "1.0.0"}
"x509" {>= "1.0.0"}
]
build: [
["dune" "subst"] {dev}

View file

@ -6,6 +6,7 @@ let tls_config = Mimic.make ~name:"tls-config"
open Lwt.Infix
let src = Logs.Src.create "http_mirage_client" ~doc:"HTTP client"
module Log = (val Logs.src_log src : Logs.LOG)
type t = {
@ -184,9 +185,7 @@ let single_http_1_1_request
let str = Bigstringaf.substring ~off ~len ba in
(* XXX(dinosaure): the copy must be done **before** any [>>=].
The given [ba] is re-used by the [Httpaf] scheduler then. *)
let acc =
acc >>= fun acc -> f response acc str
in
let acc = acc >>= fun acc -> f response acc str in
Httpaf.Body.schedule_read body ~on_read:(on_read on_eof acc)
~on_eof:(on_eof response acc) in
let f_init = Lwt.return f_init in
@ -215,27 +214,27 @@ let prepare_h2_headers headers host user_pass body_length =
specially *)
(* also note that "host" is no longer a thing, but :authority is -- so if
we find a host header, we'll rephrase that as authority. *)
let headers = List.rev_map (fun (k, v) -> (String.lowercase_ascii k, v)) headers in
let headers =
List.rev_map (fun (k, v) -> String.lowercase_ascii k, v) headers in
let headers = H2.Headers.of_rev_list headers in
let headers, authority =
match
H2.Headers.get headers "host",
H2.Headers.get headers ":authority"
H2.Headers.get headers "host", H2.Headers.get headers ":authority"
with
| None, None -> headers, host
| Some h, None ->
Log.debug (fun m -> m "removing host header (inserting authority instead)");
H2.Headers.remove headers "host", h
| None, Some a ->
H2.Headers.remove headers ":authority", a
Log.debug (fun m ->
m "removing host header (inserting authority instead)")
; H2.Headers.remove headers "host", h
| None, Some a -> H2.Headers.remove headers ":authority", a
| Some h, Some a ->
if String.equal h a then
H2.Headers.remove (H2.Headers.remove headers ":authority") "host", h
else begin
Log.warn (fun m -> m "authority header %s mismatches host %s (keeping both)" a h);
H2.Headers.remove headers ":authority", a
end
in
Log.warn (fun m ->
m "authority header %s mismatches host %s (keeping both)" a h)
; H2.Headers.remove headers ":authority", a
end in
let add hdr = H2.Headers.add_unless_exists hdr ?sensitive:None in
let hdr = add H2.Headers.empty ":authority" authority in
let hdr = H2.Headers.add_list hdr (H2.Headers.to_rev_list headers) in
@ -269,9 +268,7 @@ let single_h2_request
let str = Bigstringaf.substring ~off ~len ba in
(* XXX(dinosaure): the copy must be done **before** any [>>=].
The given [ba] is re-used by the [H2] scheduler then. *)
let acc =
acc >>= fun acc -> f response acc str
in
let acc = acc >>= fun acc -> f response acc str in
H2.Body.Reader.schedule_read response_body ~on_read:(on_read on_eof acc)
~on_eof:(on_eof response acc) in
let f_init = Lwt.return f_init in
@ -290,7 +287,8 @@ let single_h2_request
| `Exn e -> Error (`Msg ("Exception here: " ^ Printexc.to_string e)) in
wakeup err in
let conn =
H2.Client_connection.create ?config ?push_handler:None ~error_handler () in
H2.Client_connection.create ?config ?push_handler:None ~error_handler ()
in
let request_body =
H2.Client_connection.request conn req ~error_handler ~response_handler in
Lwt.async (fun () -> Paf.run (module H2.Client_connection) conn flow)
@ -383,20 +381,22 @@ let single_request
let tls_config ?tls_config ?config authenticator user's_authenticator =
lazy
(match tls_config with
(let ( let* ) = Result.bind in
match tls_config with
| Some cfg -> Ok (`Custom cfg)
| None -> (
| None ->
let alpn_protocols =
match config with
| None -> ["h2"; "http/1.1"]
| Some (`H2 _) -> ["h2"]
| Some (`HTTP_1_1 _) -> ["http/1.1"] in
let* 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))
| Ok authenticator, None -> Ok authenticator
| _, Some authenticator -> Ok authenticator
| (Error _ as err), None -> err in
let* cfg = Tls.Config.client ~alpn_protocols ~authenticator () in
Ok (`Default cfg))
let resolve_location ~uri ~location =
match String.split_on_char '/' location with

View file

@ -1,8 +1,8 @@
(executable
(name test)
(libraries fmt.tty logs.fmt http-mirage-client tcpip.stack-socket paf.mirage
mirage-clock-unix mirage-crypto-rng mirage-time-unix
mimic-happy-eyeballs alcotest-lwt))
mirage-clock-unix mirage-crypto-rng mirage-time-unix mimic-happy-eyeballs
alcotest-lwt))
(rule
(alias runtest)

View file

@ -1,8 +1,6 @@
let reporter ppf =
let report src level ~over k msgf =
let k _ =
over () ;
k () in
let k _ = over () ; k () in
let with_metadata header _tags k ppf fmt =
Format.kfprintf k ppf
("%a[%a]: " ^^ fmt ^^ "\n%!")
@ -23,7 +21,8 @@ module Happy_eyeballs =
module DNS_client =
Dns_client_mirage.Make (Mirage_crypto_rng) (Time) (Mclock) (Pclock)
(Tcpip_stack_socket.V4V6) (Happy_eyeballs)
(Tcpip_stack_socket.V4V6)
(Happy_eyeballs)
module Mimic_happy_eyeballs =
Mimic_happy_eyeballs.Make (Tcpip_stack_socket.V4V6) (Happy_eyeballs)
@ -135,11 +134,9 @@ let stack () =
let ip = Ipaddr.V4.(Prefix.make 8 localhost) in
let ipv4_only = true and ipv6_only = false in
let* tcpv4v6 =
Tcpip_stack_socket.V4V6.TCP.connect ~ipv4_only ~ipv6_only ip None
in
Tcpip_stack_socket.V4V6.TCP.connect ~ipv4_only ~ipv6_only ip None in
let* udpv4v6 =
Tcpip_stack_socket.V4V6.UDP.connect ~ipv4_only ~ipv6_only ip None
in
Tcpip_stack_socket.V4V6.UDP.connect ~ipv4_only ~ipv6_only ip None in
Tcpip_stack_socket.V4V6.connect udpv4v6 tcpv4v6
let test01 =