From 1e307d2c5b030adf9f80b98b459d202bfc81f577 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Thu, 29 Aug 2024 10:42:23 +0000 Subject: [PATCH] adapt to tls 1.0.0 (#1) //cc @dinosaure Reviewed-on: https://git.robur.coop///robur/http-mirage-client/pulls/1 --- .ocamlformat | 2 +- http-mirage-client.opam | 4 ++- src/http_mirage_client.ml | 72 +++++++++++++++++++-------------------- test/dune | 4 +-- test/test.ml | 15 ++++---- 5 files changed, 48 insertions(+), 49 deletions(-) diff --git a/.ocamlformat b/.ocamlformat index a226ec0..54720f6 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,4 @@ -version=0.23.0 +version=0.26.2 profile=conventional break-struct=natural break-infix=fit-or-vertical diff --git a/http-mirage-client.opam b/http-mirage-client.opam index 041591b..e8f36dc 100644 --- a/http-mirage-client.opam +++ b/http-mirage-client.opam @@ -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} diff --git a/src/http_mirage_client.ml b/src/http_mirage_client.ml index 1c55ae2..476e140 100644 --- a/src/http_mirage_client.ml +++ b/src/http_mirage_client.ml @@ -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) @@ -305,10 +303,10 @@ let decode_uri ~ctx uri = match String.split_on_char '/' uri with | proto :: "" :: user_pass_host_port :: path -> (if String.equal proto "http:" then - Ok ("http", Mimic.add http_scheme "http" ctx) - else if String.equal proto "https:" then - Ok ("https", Mimic.add http_scheme "https" ctx) - else Error (`Msg "Couldn't decode user and password")) + Ok ("http", Mimic.add http_scheme "http" ctx) + else if String.equal proto "https:" then + Ok ("https", Mimic.add http_scheme "https" ctx) + else Error (`Msg "Couldn't decode user and password")) >>= fun (scheme, ctx) -> let decode_user_pass up = match String.split_on_char ':' up with @@ -383,20 +381,22 @@ let single_request let tls_config ?tls_config ?config authenticator user's_authenticator = lazy - (match tls_config with - | Some cfg -> Ok (`Custom cfg) - | None -> ( - let alpn_protocols = - match config with - | None -> ["h2"; "http/1.1"] - | Some (`H2 _) -> ["h2"] - | Some (`HTTP_1_1 _) -> ["http/1.1"] in - 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 ( let* ) = Result.bind in + match tls_config with + | Some cfg -> Ok (`Custom cfg) + | 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 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 diff --git a/test/dune b/test/dune index ed4cdcb..cba97d5 100644 --- a/test/dune +++ b/test/dune @@ -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) diff --git a/test/test.ml b/test/test.ml index 2aaee6f..1453963 100644 --- a/test/test.ml +++ b/test/test.ml @@ -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%!") @@ -10,7 +8,7 @@ let reporter ppf = Fmt.(styled `Magenta string) (Logs.Src.name src) 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 () = Logs.set_reporter (reporter Fmt.stdout) @@ -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 =