Merge pull request aantron#55 from dinosaure/with-flow

Let the user to manipulate the flow if he/she wants
tchibanda24 · Dec 23, 2021 · 2661b78 · 2661b78
2 parents 4d1b07a + c74dcc1
commit 2661b78
Show file tree

Hide file tree

Showing 4 changed files with 10 additions and 9 deletions.
diff --git a/lib/paf_mirage.ml b/lib/paf_mirage.ml
@@ -22,14 +22,14 @@ module type S = sig
   val http_service :
     ?config:Httpaf.Config.t ->
     error_handler:(dst -> Httpaf.Server_connection.error_handler) ->
-    (dst -> Httpaf.Server_connection.request_handler) ->
+    (TCP.flow -> dst -> Httpaf.Server_connection.request_handler) ->
     t Paf.service
 
   val https_service :
     tls:Tls.Config.server ->
     ?config:Httpaf.Config.t ->
     error_handler:(dst -> Httpaf.Server_connection.error_handler) ->
-    (dst -> Httpaf.Server_connection.request_handler) ->
+    (TLS.flow -> dst -> Httpaf.Server_connection.request_handler) ->
     t Paf.service
 
   val serve :
@@ -194,7 +194,7 @@ module Make (Time : Mirage_time.S) (Stack : Tcpip.Stack.V4V6) :
     let connection flow =
       let dst = Stack.TCP.dst flow in
       let error_handler = error_handler dst in
-      let request_handler = request_handler dst in
+      let request_handler = request_handler flow dst in
       let conn =
         Httpaf.Server_connection.create ?config ~error_handler request_handler
       in
@@ -225,7 +225,7 @@ module Make (Time : Mirage_time.S) (Stack : Tcpip.Stack.V4V6) :
               Stack.TCP.close flow >>= fun () -> Lwt.return_error err) in
     let connection (dst, flow) =
       let error_handler = error_handler dst in
-      let request_handler = request_handler dst in
+      let request_handler = request_handler flow dst in
       let conn =
         Httpaf.Server_connection.create ?config ~error_handler request_handler
       in

diff --git a/lib/paf_mirage.mli b/lib/paf_mirage.mli
@@ -29,7 +29,7 @@ module type S = sig
   val http_service :
     ?config:Httpaf.Config.t ->
     error_handler:(dst -> Httpaf.Server_connection.error_handler) ->
-    (dst -> Httpaf.Server_connection.request_handler) ->
+    (TCP.flow -> dst -> Httpaf.Server_connection.request_handler) ->
     t Paf.service
   (** [http_service ~error_handler request_handler] makes an HTTP/AF service
       where any HTTP/1.1 requests are handled by [request_handler]. The returned
@@ -39,7 +39,7 @@ module type S = sig
     tls:Tls.Config.server ->
     ?config:Httpaf.Config.t ->
     error_handler:(dst -> Httpaf.Server_connection.error_handler) ->
-    (dst -> Httpaf.Server_connection.request_handler) ->
+    (TLS.flow -> dst -> Httpaf.Server_connection.request_handler) ->
     t Paf.service
   (** [https_service ~tls ~error_handler request_handler] makes an HTTP/AF
       service over TLS (from the given TLS configuration). Then, HTTP/1.1

diff --git a/test/simple_server.ml b/test/simple_server.ml
@@ -94,7 +94,7 @@ let http_ping_pong (_ip, _port) ic oc =
         Lwt.return_unit in
   Lwt.async go
 
-let request_handler large (ip, port) reqd =
+let request_handler large _flow (ip, port) reqd =
   let open Httpaf in
   let request = Reqd.request reqd in
   match request.Request.target with

diff --git a/test/test_cohttp.ml b/test/test_cohttp.ml
@@ -60,8 +60,9 @@ let run_http_and_https_server ~request_handler stop =
   unix_stack () >|= Tcpip_stack_socket.V4V6.tcp >>= fun stack ->
   P.init ~port:9090 stack >>= fun socket0 ->
   P.init ~port:3434 stack >>= fun socket1 ->
-  let http = P.http_service ~error_handler request_handler in
-  let https = P.https_service ~tls ~error_handler request_handler in
+  let http = P.http_service ~error_handler (fun _flow -> request_handler) in
+  let https =
+    P.https_service ~tls ~error_handler (fun _flow -> request_handler) in
   let (`Initialized fiber0) = P.serve ~stop http socket0 in
   let (`Initialized fiber1) = P.serve ~stop https socket1 in
   Logs.debug (fun m -> m "Server initialised.") ;