adapt to tls 1.0.0 #1

Merged
hannes merged 4 commits from tls-1 into main 2024-08-29 10:42:24 +00:00
3 changed files with 41 additions and 47 deletions
Showing only changes of commit 906a9ffda3 - Show all commits

View file

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

View file

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

View file

@ -1,8 +1,6 @@
let reporter ppf = let reporter ppf =
let report src level ~over k msgf = let report src level ~over k msgf =
let k _ = let k _ = over () ; k () in
over () ;
k () in
let with_metadata header _tags k ppf fmt = let with_metadata header _tags k ppf fmt =
Format.kfprintf k ppf Format.kfprintf k ppf
("%a[%a]: " ^^ fmt ^^ "\n%!") ("%a[%a]: " ^^ fmt ^^ "\n%!")
@ -10,7 +8,7 @@ let reporter ppf =
Fmt.(styled `Magenta string) Fmt.(styled `Magenta string)
(Logs.Src.name src) in (Logs.Src.name src) in
msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt in msgf @@ fun ?header ?tags fmt -> with_metadata header tags k ppf fmt in
{ Logs.report } {Logs.report}
let () = Fmt_tty.setup_std_outputs ~style_renderer:`Ansi_tty ~utf_8:true () let () = Fmt_tty.setup_std_outputs ~style_renderer:`Ansi_tty ~utf_8:true ()
let () = Logs.set_reporter (reporter Fmt.stdout) let () = Logs.set_reporter (reporter Fmt.stdout)
@ -23,7 +21,8 @@ module Happy_eyeballs =
module DNS_client = module DNS_client =
Dns_client_mirage.Make (Mirage_crypto_rng) (Time) (Mclock) (Pclock) 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 = module Mimic_happy_eyeballs =
Mimic_happy_eyeballs.Make (Tcpip_stack_socket.V4V6) (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 ip = Ipaddr.V4.(Prefix.make 8 localhost) in
let ipv4_only = true and ipv6_only = false in let ipv4_only = true and ipv6_only = false in
let* tcpv4v6 = let* tcpv4v6 =
Tcpip_stack_socket.V4V6.TCP.connect ~ipv4_only ~ipv6_only ip None Tcpip_stack_socket.V4V6.TCP.connect ~ipv4_only ~ipv6_only ip None in
in
let* udpv4v6 = let* udpv4v6 =
Tcpip_stack_socket.V4V6.UDP.connect ~ipv4_only ~ipv6_only ip None Tcpip_stack_socket.V4V6.UDP.connect ~ipv4_only ~ipv6_only ip None in
in
Tcpip_stack_socket.V4V6.connect udpv4v6 tcpv4v6 Tcpip_stack_socket.V4V6.connect udpv4v6 tcpv4v6
let test01 = let test01 =