irmin-http: limit the number of concurrent connection in the test server

src/irmin-http/irmin_http.ml

@@ -161,25 +161,30 @@ module Helper (Client: Cohttp_lwt.S.Client) = struct
       in
       Lwt.return stream
 
-  let headers = Cohttp.Header.of_list [
-      "Connection"  , "Keep-Alive";
+  let headers ~keep_alive () =
+    let keep_alive = if keep_alive then ["Connection", "Keep-Alive"] else [] in
+    Cohttp.Header.of_list ([
       irmin_version , Irmin.version;
       "Content-type", "application/json";
-    ]
+    ] @ keep_alive)
 
-  let map_call meth t ctx ?body path fn =
+  let map_call meth t ctx ~keep_alive ?body path fn =
     let uri = uri_append t path in
     let body = match body with None -> None | Some b -> Some (`String b) in
+    let headers = headers ~keep_alive () in
     Log.debug  (fun f ->
         f "%s %s" (Cohttp.Code.string_of_method meth) (Uri.path uri)
       );
-    Client.call ?ctx meth ~headers ?body uri >>= fn
-
-  let call meth t ctx ?body  path parse =
-    map_call meth t ctx ?body path (map_string_response parse)
-
+    Lwt.catch
+      (fun () -> Client.call ?ctx meth ~headers ?body uri >>= fn)
+      (fun e  ->
+         Log.debug (fun l -> l "request to %a failed: %a" Uri.pp_hum uri Fmt.exn e);
+         Lwt.fail e)
+
+  let call meth t ctx ?body path parse =
+    map_call meth t ctx ~keep_alive:false ?body path (map_string_response parse)
   let call_stream meth t ctx ?body path parse =
-    map_call meth t ctx ?body path (map_stream_response parse)
+    map_call meth t ctx ~keep_alive:true ?body path (map_stream_response parse)
 
 end
 
@@ -201,12 +206,14 @@ module RO (Client: Cohttp_lwt.S.Client)
   let key_str = Fmt.to_to_string K.pp
 
   let find t key =
-    HTTP.map_call `GET t.uri t.ctx [t.item; key_str key] (fun (r, _ as x) ->
+    HTTP.map_call `GET t.uri t.ctx ~keep_alive:false
+      [t.item; key_str key] (fun (r, _ as x) ->
         if Cohttp.Response.status r = `Not_found then Lwt.return_none
         else HTTP.map_string_response V.of_string x >|= fun x -> Some x)
 
   let mem t key =
-    HTTP.map_call `GET t.uri t.ctx [t.item; key_str key] (fun (r, _ ) ->
+    HTTP.map_call `GET t.uri t.ctx ~keep_alive:false
+      [t.item; key_str key] (fun (r, _ ) ->
         if Cohttp.Response.status r = `Not_found then Lwt.return_false
         else Lwt.return_true)
 
@@ -281,7 +288,8 @@ module RW (Client: Cohttp_lwt.S.Client)
     | e       -> Lwt.fail_with e
 
   let remove t key =
-    HTTP.map_call `DELETE (RO.uri t.t) t.t.ctx [RO.item t.t; key_str key]
+    HTTP.map_call `DELETE (RO.uri t.t) t.t.ctx ~keep_alive:false
+      [RO.item t.t; key_str key]
       (fun (r, b) ->
          match Cohttp.Response.status r with
          | `Not_found | `OK -> Lwt.return_unit

src/irmin-http/irmin_http_server.ml

@@ -322,25 +322,30 @@ module Make (HTTP: Cohttp_lwt.S.Server) (S: Irmin.S) = struct
       ("/watches"   , fun () -> new Branch.watches branch);
       ("/watch/*"   , fun () -> new Branch.watch   branch);
     ] in
-    let callback (_ch, _conn) request body =
+    let pp_con = Fmt.of_to_string Cohttp.Connection.to_string in
+    let callback (_ch, conn) request body =
       let open Cohttp in
+      Log.debug (fun l -> l "new connection %a" pp_con conn);
       (Wm.dispatch' routes ~body ~request >|= function
         | None        -> (`Not_found, Header.init (), `String "Not found", [])
         | Some result -> result)
       >>= fun (status, headers, body, path) ->
       Log.info (fun l ->
-          l "%d - %s %s"
+          l "[%a] %d - %s %s"
+            pp_con conn
             (Code.code_of_status status)
             (Code.string_of_method (Request.meth request))
             (Uri.path (Request.uri request)));
-      Log.debug (fun l -> l "path=%a" Fmt.(Dump.list string) path);
+      Log.debug (fun l ->
+          l "[%a] path=%a"
+            pp_con conn
+            Fmt.(Dump.list string) path);
       (* Finally, send the response to the client *)
       HTTP.respond ~headers ~body ~status ()
     in
     (* create the server and handle requests with the function defined above *)
     let conn_closed (_, conn) =
-      Log.info (fun l ->
-          l "connection %s closed\n%!" (Cohttp.Connection.to_string conn))
+      Log.debug (fun l -> l "connection %a closed" pp_con conn);
     in
     HTTP.make ~callback ~conn_closed ()
 

test/irmin-http/test_http.ml

@@ -93,7 +93,9 @@ let serve servers n =
       (fun () -> Lwt_unix.unlink socket)
       (function Unix.Unix_error _ -> Lwt.return () | e -> Lwt.fail e)
     >>= fun () ->
-    Cohttp_lwt_unix.Server.create ~mode:(`Unix_domain_socket (`File socket)) spec
+    let mode = `Unix_domain_socket (`File socket) in
+    Conduit_lwt_unix.set_max_active 100;
+    Cohttp_lwt_unix.Server.create ~mode spec
   in
   Lwt_main.run (server ())