Merge pull request 'Add .gitignore and .ocamlformat' (#1) from ocamlformat into main

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

.gitignore

@@ -0,0 +1,11 @@
+_build
+setup.data
+setup.log
+doc/*.html
+*.native
+*.byte
+*.so
+*.tar.gz
+_tests
+*.merlin
+*.install

.ocamlformat

@@ -0,0 +1,17 @@
+version=0.23.0
+profile=conventional
+break-struct=natural
+break-infix=fit-or-vertical
+break-sequences=false
+break-collection-expressions=wrap
+break-separators=before
+exp-grouping=preserve
+parens-tuple=multi-line-only
+space-around-lists=false
+space-around-records=false
+space-around-arrays=false
+break-fun-decl=smart
+cases-exp-indent=2
+sequence-style=before
+field-space=tight
+break-before-in=auto

src/http_mirage_client.ml

@@ -5,10 +5,11 @@ let tls_config = Mimic.make ~name:"tls-config"
 
 open Lwt.Infix
 
-type t =
+type t = {
-  { ctx : Mimic.ctx
+    ctx: Mimic.ctx
   ; alpn_protocol: Mimic.flow -> string option
-  ; authenticator : (X509.Authenticator.t, [ `Msg of string ]) result }
+  ; authenticator: (X509.Authenticator.t, [ `Msg of string ]) result
+}
 
 module type S = sig
   type nonrec t = t
@@ -19,14 +20,18 @@ end
 module Make
     (Pclock : Mirage_clock.PCLOCK)
     (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
     include TCP
+
     type endpoint = Happy_eyeballs.t * string * int
+
     type nonrec write_error =
       [ `Write of write_error | `Connect of string | `Closed ]
+
     let pp_write_error ppf = function
       | `Connect err -> Fmt.string ppf err
       | `Write err -> pp_write_error ppf err
@@ -58,20 +63,21 @@ module Make
 
     let connect (happy_eyeballs, cfg, hostname, port) =
       let peer_name =
-        Result.(to_option (bind (Domain_name.of_string hostname) Domain_name.host)) in
+        Result.(
+          to_option (bind (Domain_name.of_string hostname) Domain_name.host))
+      in
       Happy_eyeballs.resolve happy_eyeballs hostname [port] >>= function
       | Ok ((_ipaddr, _port), flow) -> client_of_flow cfg ?host:peer_name flow
       | Error (`Msg err) -> Lwt.return_error (`Write (`Connect err))
   end
 
-  let tls_edn, tls_protocol =
+  let tls_edn, tls_protocol = Mimic.register ~name:"tls" (module TLS)
-    Mimic.register ~name:"tls" (module TLS)
 
   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
-    | M.T flow ->
+    | M.T flow -> (
-      ( match TLS.epoch flow with
+      match TLS.epoch flow with
       | Ok {Tls.Core.alpn_protocol; _} -> alpn_protocol
       | Error _ -> None)
     | _ -> None
@@ -81,37 +87,50 @@ module Make
     V.authenticator ()
 
   let connect ctx =
-    let k0 happy_eyeballs http_scheme http_hostname http_port = match http_scheme with
+    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
+    let k1 happy_eyeballs http_scheme http_hostname http_port tls_config =
-      | "https" -> Lwt.return_some (happy_eyeballs, tls_config, http_hostname, http_port)
+      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
+    let ctx =
-      Mimic.Fun.[ req Happy_eyeballs.happy_eyeballs
+      Mimic.fold tcp_edn
-                ; req http_scheme; req http_hostname; dft http_port 80 ]
+        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
+    let ctx =
-                  Mimic.Fun.[ req Happy_eyeballs.happy_eyeballs
+      Mimic.fold tls_edn
-                            ; req http_scheme; req http_hostname; dft http_port 443
+        Mimic.Fun.
-                            ; req tls_config ]
+          [
+            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; }
+    Lwt.return {ctx; alpn_protocol; authenticator}
 end
 
 module Version = Httpaf.Version
 module Status = H2.Status
 module Headers = H2.Headers
 
-type response =
+type response = {
-  { version : Version.t
+    version: Version.t
   ; status: Status.t
   ; reason: string
-  ; headers : Headers.t }
+  ; headers: Headers.t
+}
 
 module HTTP_1_1 = struct
   include Httpaf.Client_connection
+
   let yield_reader _ = assert false
+
   let next_read_operation t =
     (next_read_operation t :> [ `Close | `Read | `Yield ])
 end
@@ -125,10 +144,11 @@ let add_authentication ~add headers = function
 let prepare_http_1_1_headers headers host user_pass body_length =
   let headers = Httpaf.Headers.of_list headers in
   let add = Httpaf.Headers.add_unless_exists in
-  let headers = add headers "user-agent" ("http-mirage-client/%%VERSION%%") in
+  let headers = add headers "user-agent" "http-mirage-client/%%VERSION%%" in
   let headers = add headers "host" host in
   let headers = add headers "connection" "close" in
-  let headers = match body_length with
+  let headers =
+    match body_length with
     | None -> headers
     | Some v -> add headers "content-length" (string_of_int v) in
   add_authentication ~add headers user_pass
@@ -138,123 +158,157 @@ let single_http_1_1_request ?config flow user_pass host meth path headers body =
   let headers = prepare_http_1_1_headers headers host user_pass body_length in
   let req = Httpaf.Request.create ~headers meth path in
   let finished, notify_finished = Lwt.wait () in
-  let wakeup = let w = ref false in
+  let wakeup =
-    fun v -> if not !w then Lwt.wakeup_later notify_finished v ; w := true in
+    let w = ref false in
+    fun v ->
+      if not !w then Lwt.wakeup_later notify_finished v
+      ; w := true in
   let response_handler response body =
     let buf = Buffer.create 0x100 in
     let rec on_eof () =
       let response =
-        { version= response.Httpaf.Response.version
+        {
+          version= response.Httpaf.Response.version
         ; status= (response.Httpaf.Response.status :> H2.Status.t)
         ; reason= response.Httpaf.Response.reason
-        ; headers= H2.Headers.of_list (Httpaf.Headers.to_list response.Httpaf.Response.headers) } in
+        ; headers=
+            H2.Headers.of_list
+              (Httpaf.Headers.to_list response.Httpaf.Response.headers)
+        } in
       wakeup (Ok (response, Some (Buffer.contents buf)))
     and on_read ba ~off ~len =
-      Buffer.add_string buf (Bigstringaf.substring ~off ~len ba) ;
+      Buffer.add_string buf (Bigstringaf.substring ~off ~len ba)
-      Httpaf.Body.schedule_read body ~on_read ~on_eof in
+      ; Httpaf.Body.schedule_read body ~on_read ~on_eof in
     let on_eof () =
       let response =
-        { version= response.Httpaf.Response.version
+        {
+          version= response.Httpaf.Response.version
         ; status= (response.Httpaf.Response.status :> H2.Status.t)
         ; reason= response.Httpaf.Response.reason
-        ; headers= H2.Headers.of_list (Httpaf.Headers.to_list response.Httpaf.Response.headers) } in
+        ; headers=
+            H2.Headers.of_list
+              (Httpaf.Headers.to_list response.Httpaf.Response.headers)
+        } in
       wakeup (Ok (response, None)) in
     Httpaf.Body.schedule_read body ~on_read ~on_eof in
   let error_handler e =
-    let err = match e with
+    let err =
+      match e with
       | `Malformed_response x -> Error (`Msg ("Malformed response: " ^ x))
-      | `Invalid_response_body_length _ -> Error (`Msg ("Invalid response body length"))
+      | `Invalid_response_body_length _ ->
+        Error (`Msg "Invalid response body length")
       | `Exn e -> Error (`Msg ("Exception here: " ^ Printexc.to_string e)) in
     wakeup err in
-  let request_body, conn = Httpaf.Client_connection.request ?config req ~error_handler
+  let request_body, conn =
+    Httpaf.Client_connection.request ?config req ~error_handler
       ~response_handler in
-  Lwt.async (fun () -> Paf.run (module HTTP_1_1) conn flow) ;
+  Lwt.async (fun () -> Paf.run (module HTTP_1_1) conn flow)
-  Option.iter (Httpaf.Body.write_string request_body) body ;
+  ; Option.iter (Httpaf.Body.write_string request_body) body
-  Httpaf.Body.close_writer request_body ;
+  ; Httpaf.Body.close_writer request_body
-  finished
+  ; finished
 
 let prepare_h2_headers headers host user_pass body_length =
   let headers = H2.Headers.of_list headers in
   let add hdr = H2.Headers.add_unless_exists hdr ?sensitive:None in
   let headers = add headers ":authority" host in
-  let headers = add headers "content-length" (string_of_int (Option.value ~default:0 body_length)) in
+  let headers =
+    add headers "content-length"
+      (string_of_int (Option.value ~default:0 body_length)) in
   add_authentication ~add headers user_pass
 
-let single_h2_request ?config ~scheme flow user_pass host meth path headers body =
+let single_h2_request ?config ~scheme flow user_pass host meth path headers body
+    =
   let body_length = Option.map String.length body in
   let headers = prepare_h2_headers headers host user_pass body_length in
   let req = H2.Request.create ~scheme ~headers meth path in
   let finished, notify_finished = Lwt.wait () in
-  let wakeup = let w = ref false in
+  let wakeup =
-    fun v -> if not !w then Lwt.wakeup_later notify_finished v ; w := true in
+    let w = ref false in
+    fun v ->
+      if not !w then Lwt.wakeup_later notify_finished v
+      ; w := true in
   let response_handler response response_body =
     let buf = Buffer.create 0x100 in
     let rec on_eof () =
       let response =
-        { version= { major= 2; minor= 0; }
+        {
+          version= {major= 2; minor= 0}
         ; status= response.H2.Response.status
         ; reason= ""
-        ; headers= response.H2.Response.headers } in
+        ; headers= response.H2.Response.headers
+        } in
       wakeup (Ok (response, Some (Buffer.contents buf)))
     and on_read ba ~off ~len =
-      Buffer.add_string buf (Bigstringaf.substring ~off ~len ba) ;
+      Buffer.add_string buf (Bigstringaf.substring ~off ~len ba)
-      H2.Body.Reader.schedule_read response_body
+      ; H2.Body.Reader.schedule_read response_body ~on_read ~on_eof in
-        ~on_read ~on_eof in
     let on_eof () =
       let response =
-        { version= { major= 2; minor= 0; }
+        {
+          version= {major= 2; minor= 0}
         ; status= response.H2.Response.status
         ; reason= ""
-        ; headers= response.H2.Response.headers } in
+        ; headers= response.H2.Response.headers
+        } in
       wakeup (Ok (response, None)) in
-    H2.Body.Reader.schedule_read response_body
+    H2.Body.Reader.schedule_read response_body ~on_read ~on_eof in
-      ~on_read ~on_eof in
   let error_handler e =
-    let err = match e with
+    let err =
+      match e with
       | `Malformed_response x -> Error (`Msg ("Malformed response: " ^ x))
-      | `Invalid_response_body_length _ -> Error (`Msg "Invalid response body length")
+      | `Invalid_response_body_length _ ->
+        Error (`Msg "Invalid response body length")
       | `Protocol_error (err, msg) ->
         let kerr _ = Error (`Msg (Format.flush_str_formatter ())) in
-        Format.kfprintf kerr Format.str_formatter "%a: %s" H2.Error_code.pp_hum err msg
+        Format.kfprintf kerr Format.str_formatter "%a: %s" H2.Error_code.pp_hum
+          err msg
       | `Exn e -> Error (`Msg ("Exception here: " ^ Printexc.to_string e)) in
     wakeup err in
-  let conn = H2.Client_connection.create ?config ?push_handler:None
+  let conn =
-    ~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
+  let request_body =
-  Lwt.async (fun () -> Paf.run (module H2.Client_connection) conn flow) ;
+    H2.Client_connection.request conn req ~error_handler ~response_handler in
-  Option.iter (H2.Body.Writer.write_string request_body) body ;
+  Lwt.async (fun () -> Paf.run (module H2.Client_connection) conn flow)
-  H2.Body.Writer.close request_body ;
+  ; Option.iter (H2.Body.Writer.write_string request_body) body
-  finished >|= fun v ->
+  ; H2.Body.Writer.close request_body
-  H2.Client_connection.shutdown conn ;
+  ; finished >|= fun v ->
-  v
+    H2.Client_connection.shutdown conn
+    ; v
 
 let decode_uri ~ctx uri =
   let ( >>= ) = Result.bind in
   match String.split_on_char '/' uri with
   | proto :: "" :: user_pass_host_port :: path ->
-    ( if String.equal proto "http:"
+    (if String.equal proto "http:" then
-      then Ok ("http", Mimic.add http_scheme "http" ctx)
+     Ok ("http", Mimic.add http_scheme "http" ctx)
-      else if String.equal proto "https:"
+    else if String.equal proto "https:" then
-      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") ) >>= fun (scheme, ctx) ->
+    else Error (`Msg "Couldn't decode user and password"))
-    let decode_user_pass up = match String.split_on_char ':' up with
+    >>= fun (scheme, ctx) ->
-      | [ user; pass; ] -> Ok (user, pass)
+    let decode_user_pass up =
+      match String.split_on_char ':' up with
+      | [user; pass] -> Ok (user, pass)
       | _ -> Error (`Msg "Couldn't decode user and password") in
     (match String.split_on_char '@' user_pass_host_port with
     | [host_port] -> Ok (None, host_port)
     | [user_pass; host_port] ->
-      decode_user_pass user_pass >>= fun up ->
+      decode_user_pass user_pass >>= fun up -> Ok (Some up, host_port)
-      Ok (Some up, host_port)
+    | _ -> Error (`Msg "Couldn't decode URI"))
-    | _ -> Error (`Msg "Couldn't decode URI") ) >>= fun (user_pass, host_port) ->
+    >>= fun (user_pass, host_port) ->
     (match String.split_on_char ':' host_port with
     | [] -> Error (`Msg "Empty host & port")
     | [hostname] -> Ok (hostname, Mimic.add http_hostname hostname ctx)
-    | hd :: tl ->
+    | hd :: tl -> (
-      let port, hostname = match List.rev (hd :: tl) with
+      let port, hostname =
+        match List.rev (hd :: tl) with
         | hd :: tl -> hd, String.concat ":" (List.rev tl)
         | _ -> assert false in
-      ( try Ok (hostname, Mimic.add http_hostname hostname (Mimic.add http_port (int_of_string port) ctx))
+      try
-        with Failure _ -> Error (`Msg "Couldn't decode port") ) ) >>= fun (hostname, ctx) ->
+        Ok
+          ( hostname
+          , Mimic.add http_hostname hostname
+              (Mimic.add http_port (int_of_string port) ctx) )
+      with Failure _ -> Error (`Msg "Couldn't decode port")))
+    >>= fun (hostname, ctx) ->
     Ok (ctx, scheme, hostname, user_pass, "/" ^ String.concat "/" path)
   | _ -> Error (`Msg "Couldn't decode URI on top")
 
@@ -266,11 +320,13 @@ let alpn_protocol_of_string = function
   | _ -> None
 
 let single_request ~ctx ~alpn_protocol ?config cfg ~meth ~headers ?body uri =
-  Lwt.return (decode_uri ~ctx uri) >>? fun (ctx, scheme, host, user_pass, path) ->
+  Lwt.return (decode_uri ~ctx uri)
-  let ctx = match Lazy.force cfg with
+  >>? fun (ctx, scheme, host, user_pass, path) ->
+  let ctx =
+    match Lazy.force cfg with
     | Ok (`Custom cfg) -> Mimic.add tls_config cfg ctx
-    | Ok (`Default cfg) ->
+    | Ok (`Default cfg) -> (
-      ( match Result.bind (Domain_name.of_string host) Domain_name.host with
+      match Result.bind (Domain_name.of_string host) Domain_name.host with
       | Ok peer -> Mimic.add tls_config (Tls.Config.peer cfg peer) ctx
       | Error _ -> Mimic.add tls_config cfg ctx)
     | Error _ -> ctx in
@@ -284,25 +340,29 @@ let single_request ~ctx ~alpn_protocol ?config cfg ~meth ~headers ?body uri =
     single_h2_request ~config ~scheme flow user_pass host meth path headers body
   | Some `H2, None ->
     single_h2_request ~scheme flow user_pass host meth path headers body
-   | Some `H2, (Some (`HTTP_1_1 _)) ->
+  | Some `H2, Some (`HTTP_1_1 _) ->
     single_h2_request ~scheme flow user_pass host meth path headers body
   | Some `HTTP_1_1, Some (`H2 _) ->
-     single_http_1_1_request flow user_pass host meth path headers body) >>= fun r ->
+    single_http_1_1_request flow user_pass host meth path headers body)
-  Mimic.close flow >|= fun () ->
+  >>= fun r ->
-  r
+  Mimic.close flow >|= fun () -> r
 
 let tls_config ?tls_config ?config authenticator user's_authenticator =
-  lazy ( match tls_config with
+  lazy
+    (match tls_config with
     | Some cfg -> Ok (`Custom cfg)
-  | None ->
+    | None -> (
-    let alpn_protocols = match config with
+      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 ()))
+      | Ok authenticator, None ->
-    | _, Some authenticator -> Ok (`Default (Tls.Config.client ~alpn_protocols ~authenticator ()))
+        Ok (`Default (Tls.Config.client ~alpn_protocols ~authenticator ()))
-    | (Error _ as err), None -> err )
+      | _, Some authenticator ->
+        Ok (`Default (Tls.Config.client ~alpn_protocols ~authenticator ()))
+      | (Error _ as err), None -> err))
 
 let resolve_location ~uri ~location =
   match String.split_on_char '/' location with
@@ -311,8 +371,8 @@ let resolve_location ~uri ~location =
   | "" :: "" :: _ ->
     let schema = String.sub uri 0 (String.index uri '/') in
     Ok (schema ^ location)
-  | "" :: _ ->
+  | "" :: _ -> (
-    (match String.split_on_char '/' uri with
+    match String.split_on_char '/' uri with
     | schema :: "" :: user_pass_host_port :: _ ->
       Ok (String.concat "/" [schema; ""; user_pass_host_port ^ location])
     | _ -> Error (`Msg ("expected an absolute uri, got: " ^ uri)))
@@ -321,29 +381,31 @@ let resolve_location ~uri ~location =
 let one_request
     ?config
     ?tls_config:cfg
-  { ctx; alpn_protocol; authenticator; }
+    {ctx; alpn_protocol; authenticator}
     ?authenticator:user's_authenticator
     ?(meth = `GET)
     ?(headers = [])
     ?body
     ?(max_redirect = 5)
-  ?(follow_redirect= true) uri =
+    ?(follow_redirect = true)
-  let tls_config = tls_config ?tls_config:cfg ?config authenticator user's_authenticator in
+    uri =
-  if not follow_redirect
+  let tls_config =
-  then single_request ~ctx ~alpn_protocol ?config tls_config ~meth ~headers ?body uri
+    tls_config ?tls_config:cfg ?config authenticator user's_authenticator in
+  if not follow_redirect then
+    single_request ~ctx ~alpn_protocol ?config tls_config ~meth ~headers ?body
+      uri
   else
     let rec follow_redirect count uri =
       if count = 0 then Lwt.return_error (`Msg "Redirect limit exceeded")
       else
-        single_request ~ctx ~alpn_protocol ?config tls_config ~meth ~headers ?body uri
+        single_request ~ctx ~alpn_protocol ?config tls_config ~meth ~headers
+          ?body uri
         >>? fun (resp, body) ->
         if Status.is_redirection resp.status then
-          ( match Headers.get resp.headers "location" with
+          match Headers.get resp.headers "location" with
           | Some location ->
             Lwt.return (resolve_location ~uri ~location) >>? fun uri ->
             follow_redirect (pred count) uri
-          | None ->
+          | None -> Lwt.return_ok (resp, body)
-            Lwt.return_ok (resp, body) )
+        else Lwt.return_ok (resp, body) in
-        else
-          Lwt.return_ok (resp, body) in
     follow_redirect max_redirect uri

src/http_mirage_client.mli

@@ -15,21 +15,22 @@ module Version = Httpaf.Version
 module Status = H2.Status
 module Headers = H2.Headers
 
-type response =
+type response = {
-  { version : Version.t
+    version: Version.t
   ; status: Status.t
   ; reason: string
-  ; headers : Headers.t }
+  ; headers: Headers.t
+}
 
 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
-  t ->
+  -> t
-  ?authenticator:X509.Authenticator.t ->
+  -> ?authenticator:X509.Authenticator.t
-  ?meth:Httpaf.Method.t ->
+  -> ?meth:Httpaf.Method.t
-  ?headers:(string * string) list ->
+  -> ?headers:(string * string) list
-  ?body:string ->
+  -> ?body:string
-  ?max_redirect:int ->
+  -> ?max_redirect:int
-  ?follow_redirect:bool ->
+  -> ?follow_redirect:bool
-  string ->
+  -> string
-  (response * string option, [> Mimic.error ]) result Lwt.t
+  -> (response * string option, [> Mimic.error ]) result Lwt.t