irmin-http: make the concurrent tests work a bit more reliably

Related to #847

Makefile

@@ -4,7 +4,7 @@ all:
 	dune build
 
 test:
-	dune runtest -j1 --no-buffer
+	dune runtest
 
 examples:
 	dune build @examples

test/irmin-http/test_http.ml

@@ -18,13 +18,13 @@ open Lwt.Infix
 
 let ( / ) = Filename.concat
 
-let socket = Filename.get_temp_dir_name () / "irmin.sock"
+let test_http_dir = "test-http"
 
-let uri = Uri.of_string "http://irmin"
+let socket = test_http_dir / "irmin.sock"
 
-let pid_file = Filename.get_temp_dir_name () / "irmin-test.pid"
+let uri = Uri.of_string "http://irmin"
 
-let rewrite _ _ = Lwt.return (`Unix_domain_socket socket)
+let pid_file = test_http_dir / "irmin-test.pid"
 
 module Client = struct
   include Cohttp_lwt_unix.Client
@@ -44,14 +44,6 @@ let http_store (module S : Irmin_test.S) =
 
 let remove file = try Unix.unlink file with _ -> ()
 
-let signal pid =
-  let oc = open_out pid_file in
-  Logs.debug (fun l -> l "write PID %d in %s" pid pid_file);
-  output_string oc (string_of_int pid);
-  flush oc;
-  close_out oc;
-  Lwt.return_unit
-
 let rec wait_for_the_server_to_start () =
   if Sys.file_exists pid_file then (
     let ic = open_in pid_file in
@@ -69,6 +61,33 @@ let servers = [ (`Quick, Test_mem.suite); (`Quick, Test_git.suite) ]
 
 let root c = Irmin.Private.Conf.(get c root)
 
+let mkdir d =
+  Lwt.catch
+    (fun () -> Lwt_unix.mkdir d 0o755)
+    (function
+      | Unix.Unix_error (Unix.EEXIST, _, _) -> Lwt.return_unit
+      | e -> Lwt.fail e)
+
+let rec lock () =
+  Lwt_unix.openfile pid_file [ Unix.O_CREAT; Unix.O_RDWR ] 0o600 >>= fun fd ->
+  let pid = string_of_int (Unix.getpid ()) in
+  let pid_len = String.length pid in
+  Lwt.catch
+    (fun () ->
+      Lwt_unix.lockf fd Unix.F_LOCK 0 >>= fun () ->
+      Logs.debug (fun l -> l "write PID %s in %s" pid pid_file);
+      Lwt_unix.write fd (Bytes.of_string pid) 0 pid_len >>= fun len ->
+      if len <> pid_len then
+        Lwt_unix.close fd >>= fun () ->
+        Lwt.fail_with "Unable to write PID to lock file"
+      else Lwt.return fd)
+    (function
+      | Unix.Unix_error (Unix.EAGAIN, _, _) ->
+          Lwt_unix.close fd >>= fun () -> lock ()
+      | e -> Lwt_unix.close fd >>= fun () -> Lwt.fail e)
+
+let unlock fd = Lwt_unix.close fd
+
 let serve servers n =
   Logs.set_level ~all:true (Some Logs.Debug);
   Logs.debug (fun l -> l "pwd: %s" @@ Unix.getcwd ());
@@ -82,7 +101,7 @@ let serve servers n =
   let server () =
     server.init () >>= fun () ->
     Server.Repo.v server.config >>= fun repo ->
-    signal (Unix.getpid ()) >>= fun () ->
+    lock () >>= fun lock ->
     let spec = HTTP.v repo ~strict:false in
     Lwt.catch
       (fun () -> Lwt_unix.unlink socket)
@@ -93,6 +112,7 @@ let serve servers n =
     Cohttp_lwt_unix.Server.create
       ~on_exn:(Fmt.pr "Async exception caught: %a" Fmt.exn)
       ~mode spec
+    >>= fun () -> unlock lock
   in
   Lwt_main.run (server ())
 
@@ -103,14 +123,17 @@ let suite i server =
     name = Printf.sprintf "HTTP.%s" server.name;
     init =
       (fun () ->
+        remove socket;
         remove pid_file;
+        mkdir test_http_dir >>= fun () ->
         Lwt_io.flush_all () >>= fun () ->
         let pwd = Sys.getcwd () in
-        let chdir =
-          if Filename.basename pwd = "default" then "cd ../.. && " else ""
+        let root =
+          if Filename.basename pwd = "default" then ".." / ".." / "" else ""
         in
         let cmd =
-          Fmt.strf "%s_build/default/%s serve %d &" chdir Sys.argv.(0) i
+          root
+          ^ ("_build" / "default" / Fmt.strf "%s serve %d &" Sys.argv.(0) i)
         in
         Fmt.epr "pwd=%s\nExecuting: %S\n%!" pwd cmd;
         let _ = Sys.command cmd in
@@ -143,3 +166,5 @@ let with_server servers f =
     Logs.set_reporter (Irmin_test.reporter ~prefix:"S" ());
     serve servers n )
   else f ()
+
+type test = Alcotest.speed_level * Irmin_test.t

test/irmin-http/test_http.mli

@@ -0,0 +1,7 @@
+type test = Alcotest.speed_level * Irmin_test.t
+
+val servers : test list
+
+val suites : test list -> test list
+
+val with_server : test list -> (unit -> unit) -> unit