diff --git a/src/irmin-http/irmin_http.ml b/src/irmin-http/irmin_http.ml index f2c71061da..436aeb797e 100644 --- a/src/irmin-http/irmin_http.ml +++ b/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 diff --git a/src/irmin-http/irmin_http_server.ml b/src/irmin-http/irmin_http_server.ml index d23797d340..c6c6e24197 100644 --- a/src/irmin-http/irmin_http_server.ml +++ b/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 () diff --git a/test/irmin-http/test_http.ml b/test/irmin-http/test_http.ml index 37c854d803..c218dcd35c 100644 --- a/test/irmin-http/test_http.ml +++ b/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 ())