Remove test raciness by adding low level api

Signed-off-by: Rudi Grinberg <[email protected]>

src/fsevents/fsevents.ml

@@ -153,8 +153,14 @@ external stop : t -> unit = "dune_fsevents_stop"
 
 external start : t -> unit = "dune_fsevents_start"
 
+external loop : t -> unit = "dune_fsevents_loop"
+
+external break : t -> unit = "dune_fsevents_break"
+
 external flush_sync : t -> unit = "dune_fsevents_flush_sync"
 
+external destroy : t -> unit = "dune_fsevents_destroy"
+
 external dune_fsevents_create :
   string list -> float -> (t -> Event.t list -> unit) -> t
   = "dune_fsevents_create"

src/fsevents/fsevents.mli

@@ -60,14 +60,23 @@ type t
 val create :
   paths:string list -> latency:float -> f:(t -> Event.t list -> unit) -> t
 
-(** [start t] will start listening. This function blocks until [stop t] is
-    called *)
+(** [start t] will start listening for fsevents. Note that the callback will not
+    be called until [loop t] is called. *)
 val start : t -> unit
 
-(** [stop t] stop and destory the watcher. after this function returns, the
-    callback is guaranteed to never be called again*)
+(** [stop t] stop listening to events. Note that this will not make [loop]
+    return until [break] is called. *)
 val stop : t -> unit
 
+(** [loop t] start the event loop and execute the callback for the fsevents. *)
+val loop : t -> unit
+
+(** [break t] stop the event loop. This will make [loop t] terminate. *)
+val break : t -> unit
+
+(** [destroy t] cleanup the resources held by [t] *)
+val destroy : t -> unit
+
 (** [flush_sync t] flush all pending events that might be held up by debouncing.
     this function blocks until the final invocation of the callback for all
     buffered events completes. *)

src/fsevents/fsevents_stubs.c

@@ -138,29 +138,45 @@ CAMLprim value dune_fsevents_set_exclusion_paths(value v_t, value v_paths) {
 CAMLprim value dune_fsevents_start(value v_t) {
   CAMLparam1(v_t);
   dune_fsevents_t *t = (dune_fsevents_t *)Nativeint_val(v_t);
-  caml_release_runtime_system();
   CFRunLoopRef runLoop = CFRunLoopGetCurrent();
   t->runLoop = runLoop;
   FSEventStreamScheduleWithRunLoop(t->stream, runLoop, kCFRunLoopDefaultMode);
   bool res = FSEventStreamStart(t->stream);
-  if (res) {
-    CFRunLoopRun();
-    caml_acquire_runtime_system();
-  } else {
-    caml_acquire_runtime_system();
+  if (!res) {
     caml_failwith("Fsevents.start: failed to start");
   }
   CAMLreturn(Val_unit);
 }
 
+CAMLprim value dune_fsevents_loop(value v_t) {
+  CAMLparam1(v_t);
+  dune_fsevents_t *t = (dune_fsevents_t *)Nativeint_val(v_t);
+  caml_release_runtime_system();
+  CFRunLoopRun();
+  caml_acquire_runtime_system();
+  CAMLreturn(Val_unit);
+}
+
 CAMLprim value dune_fsevents_stop(value v_t) {
   CAMLparam1(v_t);
   dune_fsevents_t *t = (dune_fsevents_t *)Nativeint_val(v_t);
   FSEventStreamStop(t->stream);
+  CAMLreturn(Val_unit);
+}
+
+CAMLprim value dune_fsevents_break(value v_t) {
+  CAMLparam1(v_t);
+  dune_fsevents_t *t = (dune_fsevents_t *)Nativeint_val(v_t);
   FSEventStreamInvalidate(t->stream);
+  CFRunLoopStop(t->runLoop);
+  CAMLreturn(Val_unit);
+}
+
+CAMLprim value dune_fsevents_destroy(value v_t) {
+  CAMLparam1(v_t);
+  dune_fsevents_t *t = (dune_fsevents_t *)Nativeint_val(v_t);
   FSEventStreamRelease(t->stream);
   caml_remove_global_root(&t->v_callback);
-  CFRunLoopStop(t->runLoop);
   free(t);
   CAMLreturn(Val_unit);
 }

test/expect-tests/fsevents/fsevents_tests.ml

@@ -9,6 +9,14 @@ let timeout_thread ~wait f =
   let (_ : Thread.t) = Thread.create spawn () in
   ()
 
+let start_filename = ".dune_fsevents_start"
+
+let end_filename = ".dune_fsevents_end"
+
+let emit_start () = Io.String_path.write_file start_filename ""
+
+let emit_end () = Io.String_path.write_file end_filename ""
+
 let test f =
   let cv = Condition.create () in
   let mutex = Mutex.create () in
@@ -60,28 +68,42 @@ let print_event ~cwd e =
   in
   printfn "> %s" (Dyn.to_string dyn)
 
-let make_callback cwd ~f =
+let make_callback ~f =
   (* hack to skip the first event if it's creating the temp dir *)
-  let ignore = ref `Try in
+  let state = ref `Looking_start in
   fun t events ->
-    match !ignore with
-    | `Dont -> f t events
-    | `Try -> (
-      ignore := `Dont;
-      match events with
-      | [] -> assert false
-      | e :: evts ->
-        if Event.path e = cwd && Event.action e = Create && Event.kind e = Dir
-        then
-          match evts with
-          | [] -> ()
-          | _ -> f t evts
-        else
-          f t (e :: evts))
+    let is_marker event filename =
+      Event.kind event = File
+      && Filename.basename (Event.path event) = filename
+      && Event.action event = Create
+    in
+    let stop =
+      lazy
+        (Fsevents.stop t;
+         Fsevents.break t)
+    in
+    let events =
+      List.fold_left events ~init:[] ~f:(fun acc event ->
+          match !state with
+          | `Looking_start ->
+            if is_marker event start_filename then state := `Keep;
+            acc
+          | `Finish -> acc
+          | `Keep ->
+            if is_marker event end_filename then (
+              state := `Finish;
+              Lazy.force stop;
+              acc
+            ) else
+              event :: acc)
+    in
+    match events with
+    | [] -> ()
+    | _ -> f events
 
 let fsevents ~cwd ~paths =
   Fsevents.create ~paths
-    ~f:(make_callback cwd ~f:(fun _ -> List.iter ~f:(print_event ~cwd)))
+    ~f:(make_callback ~f:(List.iter ~f:(print_event ~cwd)))
     ~latency:0.
 
 let test_with_operations f =
@@ -90,29 +112,36 @@ let test_with_operations f =
         let cwd = Sys.getcwd () in
         fsevents ~paths:[ cwd ] ~cwd
       in
-      timeout_thread ~wait:0.5 (fun () ->
-          f ();
-          Thread.delay 0.2;
-          Fsevents.flush_sync t;
-          Fsevents.stop t;
-          finish ());
-      Fsevents.start t)
+      Fsevents.start t;
+      let (_ : Thread.t) =
+        Thread.create
+          (fun () ->
+            emit_start ();
+            f ();
+            emit_end ())
+          ()
+      in
+      Fsevents.loop t;
+      Fsevents.destroy t;
+      finish ())
 
 let%expect_test "file create event" =
   test_with_operations (fun () -> Io.String_path.write_file "./file" "foobar");
   [%expect
-    {| > { action = "Unknown"; kind = "File"; path = "$TESTCASE_ROOT/file" } |}]
+    {|
+      > { action = "Unknown"; kind = "File"; path = "$TESTCASE_ROOT/file" } |}]
 
 let%expect_test "dir create event" =
   test_with_operations (fun () -> ignore (Fpath.mkdir "./blahblah"));
   [%expect
-    {| > { action = "Create"; kind = "Dir"; path = "$TESTCASE_ROOT/blahblah" } |}]
+    {|
+      > { action = "Create"; kind = "Dir"; path = "$TESTCASE_ROOT/blahblah" } |}]
 
 let%expect_test "move file" =
   test_with_operations (fun () ->
       Io.String_path.write_file "old" "foobar";
       Unix.rename "old" "new");
   [%expect
     {|
-      > { action = "Unknown"; kind = "File"; path = "$TESTCASE_ROOT/old" }
-      > { action = "Unknown"; kind = "File"; path = "$TESTCASE_ROOT/new" } |}]
+      > { action = "Unknown"; kind = "File"; path = "$TESTCASE_ROOT/new" }
+      > { action = "Unknown"; kind = "File"; path = "$TESTCASE_ROOT/old" } |}]