Simplify lwt server

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)

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 =

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

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

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