Skip to content
Permalink
Browse files

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

Related to #847
  • Loading branch information...
samoht committed Aug 31, 2019
1 parent 0d2a3a6 commit 0e205b7c8d6399bc63492783f634ec3853b8ec28
Showing with 49 additions and 17 deletions.
  1. +1 −1 Makefile
  2. +41 −16 test/irmin-http/test_http.ml
  3. +7 −0 test/irmin-http/test_http.mli
@@ -4,7 +4,7 @@ all:
dune build

test:
dune runtest -j1 --no-buffer
dune runtest

examples:
dune build @examples
@@ -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
@@ -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

0 comments on commit 0e205b7

Please sign in to comment.
You can’t perform that action at this time.