adapt to tls 1.0.0 (#1)

//cc @dinosaure

Reviewed-on: https://git.robur.coop///robur/http-mirage-client/pulls/1

.ocamlformat

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

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}

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 =
+      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)
         ~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 "host", H2.Headers.get headers ":authority"
-      H2.Headers.get headers ":authority"
     with
     | None, None -> headers, host
     | 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 ->
       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);
+        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 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 =
+      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)
         ~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)
+       Ok ("http", Mimic.add http_scheme "http" ctx)
-    else if String.equal proto "https:" then
+     else if String.equal proto "https:" then
-      Ok ("https", Mimic.add http_scheme "https" ctx)
+       Ok ("https", Mimic.add http_scheme "https" ctx)
-    else Error (`Msg "Couldn't decode user and password"))
+     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
+    (let ( let* ) = Result.bind in
-    | Some cfg -> Ok (`Custom cfg)
+     match tls_config with
-    | None -> (
+     | Some cfg -> Ok (`Custom cfg)
-      let alpn_protocols =
+     | None ->
-        match config with
+       let alpn_protocols =
-        | None -> ["h2"; "http/1.1"]
+         match config with
-        | Some (`H2 _) -> ["h2"]
+         | None -> ["h2"; "http/1.1"]
-        | Some (`HTTP_1_1 _) -> ["http/1.1"] in
+         | Some (`H2 _) -> ["h2"]
-      match authenticator, user's_authenticator with
+         | Some (`HTTP_1_1 _) -> ["http/1.1"] in
-      | Ok authenticator, None ->
+       let* authenticator =
-        Ok (`Default (Tls.Config.client ~alpn_protocols ~authenticator ()))
+         match authenticator, user's_authenticator with
-      | _, Some authenticator ->
+         | Ok authenticator, None -> Ok authenticator
-        Ok (`Default (Tls.Config.client ~alpn_protocols ~authenticator ()))
+         | _, Some authenticator -> Ok authenticator
-      | (Error _ as err), None -> err))
+         | (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

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
+   mirage-clock-unix mirage-crypto-rng mirage-time-unix mimic-happy-eyeballs
-   mimic-happy-eyeballs alcotest-lwt))
+   alcotest-lwt))
 
 (rule
  (alias runtest)

test/test.ml

@@ -1,8 +1,6 @@
 let reporter ppf =
   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 =
       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
+    Tcpip_stack_socket.V4V6.TCP.connect ~ipv4_only ~ipv6_only ip None in
-  in
   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
 
 let test01 =