diff --git a/bin/cohttp_server_lwt.ml b/bin/cohttp_server_lwt.ml index ceeb330420..dfa226ce0d 100644 --- a/bin/cohttp_server_lwt.ml +++ b/bin/cohttp_server_lwt.ml @@ -136,11 +136,11 @@ let string_of_sockaddr = function let start_server docroot port host index verbose cert key () = printf "Listening for HTTP request on: %s %d\n" host port; let info = sprintf "Served by Cohttp/Lwt listening on %s:%d" host port in - let conn_closed (ch,conn) () = + let conn_closed (ch,conn) = printf "connection %s closed\n%!" (Sexplib.Sexp.to_string_hum (Conduit_lwt_unix.sexp_of_flow ch)) in let callback = handler ~info ~docroot ~verbose ~index in - let config = { Server.callback; conn_closed } in + let config = Server.make ~callback ~conn_closed in let mode = match cert, key with | Some c, Some k -> `TLS (`Crt_file_path c, `Key_file_path k, `No_password, `Port port) | _ -> `TCP (`Port port) diff --git a/lib_test/test_net_lwt_client_and_server.ml b/lib_test/test_net_lwt_client_and_server.ml index fe4a550f7d..a720ca92c1 100644 --- a/lib_test/test_net_lwt_client_and_server.ml +++ b/lib_test/test_net_lwt_client_and_server.ml @@ -40,11 +40,10 @@ let make_server () = Server.respond_string ~status:`OK ~body:"nodrain" () |_ -> exit 0 in - let conn_closed _ () = () in lwt ctx = Conduit_lwt_unix.init ~src:address () in let ctx = Cohttp_lwt_unix_net.init ~ctx () in let mode = `TCP (`Port port) in - let config = { Server.callback; conn_closed } in + let config = Server.make ~callback in Server.create ~ctx ~mode config let not_none n t fn = diff --git a/lib_test/test_net_lwt_server.ml b/lib_test/test_net_lwt_server.ml index 804801ceeb..9670cb6e63 100644 --- a/lib_test/test_net_lwt_server.ml +++ b/lib_test/test_net_lwt_server.ml @@ -91,10 +91,10 @@ let make_server () = let fname = Server.resolve_file ~docroot:"." ~uri:(Request.uri req) in Server.respond_file ~fname () in - let conn_closed (ch,conn_id) () = + let conn_closed (ch,conn_id) = Printf.eprintf "conn %s closed\n%!" (Connection.to_string conn_id) in - let config = { Server.callback; conn_closed } in + let config = Server.make ~callback ~conn_closed in let ctx = Cohttp_lwt_unix_net.init () in let port = 8081 in let tcp_mode = `TCP (`Port port) in diff --git a/lwt/cohttp_lwt.ml b/lwt/cohttp_lwt.ml index 7825fc6b7d..17ca1a20ec 100644 --- a/lwt/cohttp_lwt.ml +++ b/lwt/cohttp_lwt.ml @@ -219,15 +219,14 @@ module type Server = sig type ctx with sexp_of val default_ctx : ctx - type t = { - callback : - (IO.conn * Cohttp.Connection.t) -> - Cohttp.Request.t -> - Cohttp_lwt_body.t -> - (Cohttp.Response.t * Cohttp_lwt_body.t) Lwt.t; - conn_closed: - (IO.conn * Cohttp.Connection.t) -> unit -> unit; - } + type conn = IO.conn * Cohttp.Connection.t + + type t + + val make : ?conn_closed:(conn -> unit) + -> callback:(conn -> Cohttp.Request.t -> Cohttp_lwt_body.t + -> (Cohttp.Response.t * Cohttp_lwt_body.t) Lwt.t) + -> t val resolve_local_file : docroot:string -> uri:Uri.t -> string @@ -273,16 +272,20 @@ module Make_server(IO:Cohttp.S.IO with type 'a t = 'a Lwt.t) type ctx = Net.ctx with sexp_of let default_ctx = Net.default_ctx + type conn = IO.conn * Cohttp.Connection.t + type t = { callback : - (IO.conn * Cohttp.Connection.t) -> + conn -> Cohttp.Request.t -> Cohttp_lwt_body.t -> (Cohttp.Response.t * Cohttp_lwt_body.t) Lwt.t; - conn_closed: - (IO.conn * Cohttp.Connection.t) -> unit -> unit; + conn_closed: conn -> unit; } + let make ?(conn_closed=ignore) ~callback = + { conn_closed ; callback } + module Transfer_IO = Transfer_io.Make(IO) let resolve_local_file ~docroot ~uri = @@ -327,6 +330,7 @@ module Make_server(IO:Cohttp.S.IO with type 'a t = 'a Lwt.t) let callback spec = let daemon_callback io_id ic oc = let conn_id = Connection.create () in + let conn_closed () = spec.conn_closed (io_id,conn_id) in let read_m = Lwt_mutex.create () in (* If the request is HTTP version 1.0 then the request stream should be considered closed after the first request/response. *) @@ -372,7 +376,7 @@ module Make_server(IO:Cohttp.S.IO with type 'a t = 'a Lwt.t) ) req_stream in (* Clean up resources when the response stream terminates and call * the user callback *) - Lwt_stream.on_terminate res_stream (spec.conn_closed (io_id,conn_id)); + Lwt_stream.on_terminate res_stream conn_closed; (* Transmit the responses *) for_lwt (res,body) in res_stream do let flush = Response.flush res in diff --git a/lwt/cohttp_lwt.mli b/lwt/cohttp_lwt.mli index b29e7b4944..82cb7fe4b0 100644 --- a/lwt/cohttp_lwt.mli +++ b/lwt/cohttp_lwt.mli @@ -161,15 +161,14 @@ module type Server = sig type ctx with sexp_of val default_ctx : ctx - type t = { - callback : - (IO.conn * Cohttp.Connection.t) -> - Cohttp.Request.t -> - Cohttp_lwt_body.t -> - (Cohttp.Response.t * Cohttp_lwt_body.t) Lwt.t; - conn_closed: - (IO.conn * Cohttp.Connection.t) -> unit -> unit; - } + type conn = IO.conn * Cohttp.Connection.t + + type t + + val make : ?conn_closed:(conn -> unit) + -> callback:(conn -> Cohttp.Request.t -> Cohttp_lwt_body.t + -> (Cohttp.Response.t * Cohttp_lwt_body.t) Lwt.t) + -> t (** Resolve a URI and a docroot into a concrete local filename. *) val resolve_local_file : docroot:string -> uri:Uri.t -> string