Merge pull request #26 from robur-coop/expose-request

Expose the request used to communicate with the server

Author: dinosaure

src/httpcats.ml

@@ -8,6 +8,7 @@ module Server = Http_miou_server
 module Version = H1.Version
 module Status = H2.Status
 module Headers = H2.Headers
+module Method = H2.Method
 
 let ( % ) f g x = f (g x)
 
@@ -107,6 +108,8 @@ let add_authentication ?(meth = `Basic) ~add headers user_pass =
 
 let user_agent = "hurl/%%VERSION_NUM%%"
 
+type request = { meth: Method.t; target: string; headers: Headers.t }
+
 type response = {
     version: Version.t
   ; status: Status.t
@@ -135,7 +138,7 @@ let pp_error ppf = function
 
 type body = String of string | Stream of string Seq.t
 type meta = (Ipaddr.t * int) * Tls.Core.epoch_data option
-type 'a handler = meta -> response -> 'a -> string option -> 'a
+type 'a handler = meta -> request -> response -> 'a -> string option -> 'a
 
 type config = {
     meth: H2.Method.t
@@ -204,7 +207,7 @@ let prep_h2_headers cfg body =
   let hdr = List.sort (fun (a, _) (b, _) -> String.compare a b) hdr in
   H2.Headers.of_list hdr
 
-let from_h1 response =
+let resp_from_h1 response =
   {
     version= response.H1.Response.version
   ; status= (response.H1.Response.status :> H2.Status.t)
@@ -213,14 +216,28 @@ let from_h1 response =
       H2.Headers.of_list (H1.Headers.to_list response.H1.Response.headers)
   }
 
-let from_h2 response =
+let req_from_h1 req =
+  {
+    meth= req.H1.Request.meth
+  ; target= req.H1.Request.target
+  ; headers= H2.Headers.of_list (H1.Headers.to_list req.H1.Request.headers)
+  }
+
+let resp_from_h2 response =
   {
     version= { major= 2; minor= 0 }
   ; status= response.H2.Response.status
   ; reason= H2.Status.to_string response.H2.Response.status
   ; headers= response.H2.Response.headers
   }
 
+let req_from_h2 req =
+  {
+    meth= req.H2.Request.meth
+  ; target= req.H2.Request.target
+  ; headers= req.H2.Request.headers
+  }
+
 let _is_a_valid_redirection resp ~uri =
   if Status.is_redirection resp.status then
     match Headers.get resp.headers "location" with
@@ -253,7 +270,7 @@ let[@warning "-8"] single_http_1_1_request ?(config = H1.Config.default) flow
   let request = H1.Request.create ~headers meth path in
   let meta = ((cfg.ipaddr, cfg.port), cfg.epoch) in
   let f (`V1 resp : Client.response) acc str =
-    fn meta (from_h1 resp) acc (Some str)
+    fn meta (req_from_h1 request) (resp_from_h1 resp) acc (Some str)
   in
   let finally () =
     Log.debug (fun m -> m "close the underlying socket");
@@ -283,8 +300,9 @@ let[@warning "-8"] single_http_1_1_request ?(config = H1.Config.default) flow
   let* resp = Result.map_error (on_error % fst) resp in
   let* () = Result.map_error on_error (Miou.await sender) in
   let* () = Result.map_error on_error (Miou.await process) in
-  let resp = from_h1 resp in
-  Ok (resp, fn meta resp !acc None)
+  let req = req_from_h1 request in
+  let resp = resp_from_h1 resp in
+  Ok (resp, fn meta req resp !acc None)
 
 let h2_writer body seq () =
   let rec next seq reason =
@@ -313,7 +331,7 @@ let[@warning "-8"] single_h2_request ?(config = H2.Config.default) flow cfg
   let request = H2.Request.create ~scheme ~headers meth path in
   let meta = ((cfg.ipaddr, cfg.port), cfg.epoch) in
   let f (`V2 response : Client.response) acc str =
-    fn meta (from_h2 response) acc (Some str)
+    fn meta (req_from_h2 request) (resp_from_h2 response) acc (Some str)
   in
   let (Client.Process { version= V2; acc; response; body; process; _ }) =
     Client.run ~f acc (`V2 config) flow (`V2 request)
@@ -336,8 +354,9 @@ let[@warning "-8"] single_h2_request ?(config = H2.Config.default) flow cfg
   let* resp = Result.map_error (on_error % fst) resp in
   let* () = Result.map_error on_error (Miou.await sender) in
   let* () = Result.map_error on_error (Miou.await process) in
-  let resp = from_h2 resp in
-  Ok (resp, fn meta resp !acc None)
+  let req = req_from_h2 request in
+  let resp = resp_from_h2 resp in
+  Ok (resp, fn meta req resp !acc None)
 
 let alpn_protocol = function
   | `Tcp _ -> None

src/httpcats.mli

@@ -31,6 +31,10 @@ module Headers = H2.Headers
 
     Case-insensitive key-value pairs. *)
 
+module Method = H2.Method
+
+type request = { meth: Method.t; target: string; headers: Headers.t }
+
 type response = {
     version: Version.t
   ; status: Status.t
@@ -54,7 +58,7 @@ type meta = (Ipaddr.t * int) * Tls.Core.epoch_data option
     address and the configuration chosen during the TLS handshake). In this
     sense, all this information is condensed into the meta type. *)
 
-type 'a handler = meta -> response -> 'a -> string option -> 'a
+type 'a handler = meta -> request -> response -> 'a -> string option -> 'a
 (** The handler is a function that is called each time a new part of the
     response body is retrieved. The end of the response content is notified by
     [None]. The user can then evolve a ['a] value between each call to the

test/test.ml

@@ -137,7 +137,7 @@ let test00 =
   let daemon, resolver = Happy_eyeballs_miou_unix.create () in
   match
     Httpcats.request ~resolver:(`Happy resolver)
-      ~f:(fun _ _resp buf -> function
+      ~f:(fun _ _req _resp buf -> function
         | Some str -> Buffer.add_string buf str; buf | None -> buf)
       ~uri:"http://127.0.0.1:4000/" (Buffer.create 0x10)
   with
@@ -195,7 +195,7 @@ let test01 =
   let daemon, resolver = Happy_eyeballs_miou_unix.create () in
   match
     Httpcats.request ~resolver:(`Happy resolver)
-      ~f:(fun _ _resp buf -> function
+      ~f:(fun _ _req _resp buf -> function
         | Some str -> Buffer.add_string buf str; buf | None -> buf)
       ~uri:"http://127.0.0.1:4000" (Buffer.create 0x1000)
   with
@@ -292,7 +292,7 @@ let test02 =
   in
   match
     Httpcats.request ~resolver:(`Happy resolver) ~meth:`POST ~body
-      ~f:(fun _ _resp buf -> function
+      ~f:(fun _ _req _resp buf -> function
         | Some str -> Buffer.add_string buf str; buf | None -> buf)
       ~uri:"http://127.0.0.1:4000" (Buffer.create 0x1000)
   with
@@ -358,7 +358,7 @@ let test03 =
       |> Result.get_ok
     in
     Httpcats.request ~resolver:(`Happy resolver) ~tls_config
-      ~f:(fun _ _resp buf -> function
+      ~f:(fun _ _req _resp buf -> function
         | Some str -> Buffer.add_string buf str; buf | None -> buf)
       ~uri:"https://127.0.0.1:4000" (Buffer.create 0x10)
     |> R.reword_error (R.msgf "%a" Httpcats.pp_error)
@@ -367,7 +367,7 @@ let test03 =
     Miou.async @@ fun () ->
     let* res =
       Httpcats.request ~resolver:(`Happy resolver) ~authenticator
-        ~f:(fun _ _resp buf -> function
+        ~f:(fun _ _req _resp buf -> function
           | Some str -> Buffer.add_string buf str; buf | None -> buf)
         ~uri:"https://127.0.0.1:4000" (Buffer.create 0x10)
       |> R.reword_error (R.msgf "%a" Httpcats.pp_error)
@@ -458,15 +458,15 @@ let test04 =
       |> Result.get_ok
     in
     Httpcats.request ~resolver:(`Happy resolver) ~tls_config
-      ~f:(fun _ _resp buf -> function
+      ~f:(fun _ _req _resp buf -> function
         | Some str -> Buffer.add_string buf str; buf | None -> buf)
       ~uri:"https://127.0.0.1:4000" (Buffer.create 0x1000)
     |> R.reword_error (R.msgf "%a" Httpcats.pp_error)
   in
   let h2 =
     Miou.async @@ fun () ->
     Httpcats.request ~resolver:(`Happy resolver) ~authenticator
-      ~f:(fun _ _resp buf -> function
+      ~f:(fun _ _req _resp buf -> function
         | Some str -> Buffer.add_string buf str; buf | None -> buf)
       ~uri:"https://127.0.0.1:4000" (Buffer.create 0x10)
     |> R.reword_error (R.msgf "%a" Httpcats.pp_error)
@@ -546,7 +546,7 @@ let test05 =
     in
     Httpcats.request ~resolver:(`Happy resolver) ~tls_config ~meth:`POST
       ~body:(Httpcats.string body)
-      ~f:(fun _ _resp buf -> function
+      ~f:(fun _ _req _resp buf -> function
         | Some str -> Buffer.add_string buf str; buf | None -> buf)
       ~uri:"https://127.0.0.1:4000" (Buffer.create 0x1000)
     |> R.reword_error (R.msgf "%a" Httpcats.pp_error)
@@ -555,7 +555,7 @@ let test05 =
     Miou.async @@ fun () ->
     Httpcats.request ~resolver:(`Happy resolver) ~authenticator ~meth:`POST
       ~body:(Httpcats.string body)
-      ~f:(fun _ _resp buf -> function
+      ~f:(fun _ _req _resp buf -> function
         | Some str -> Buffer.add_string buf str; buf | None -> buf)
       ~uri:"https://127.0.0.1:4000" (Buffer.create 0x1000)
     |> R.reword_error (R.msgf "%a" Httpcats.pp_error)
@@ -607,7 +607,7 @@ let test06 =
   let request =
     Miou.async @@ fun () ->
     Httpcats.request ~resolver:(`Happy resolver) ~authenticator
-      ~f:(fun _ _resp buf -> function
+      ~f:(fun _ _req _resp buf -> function
         | Some str -> Buffer.add_string buf str; buf | None -> buf)
       ~headers:
         [