From 4fb6c68b4e1d525327a7a102209b9c63089e205a Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Sun, 19 Sep 2021 17:45:28 -0600 Subject: [PATCH] Add native fsevents library Signed-off-by: Rudi Grinberg --- src/fsevents/bin/dune | 5 + src/fsevents/bin/dune_fsevents.ml | 15 + src/fsevents/dune | 9 + src/fsevents/flags/dune | 10 + src/fsevents/flags/gen_flags.ml | 6 + src/fsevents/fsevents.ml | 197 ++++++++++ src/fsevents/fsevents.mli | 89 +++++ src/fsevents/fsevents_stubs.c | 358 +++++++++++++++++++ test/expect-tests/fsevents/dune | 18 + test/expect-tests/fsevents/fsevents_tests.ml | 188 ++++++++++ 10 files changed, 895 insertions(+) create mode 100644 src/fsevents/bin/dune create mode 100644 src/fsevents/bin/dune_fsevents.ml create mode 100644 src/fsevents/dune create mode 100644 src/fsevents/flags/dune create mode 100644 src/fsevents/flags/gen_flags.ml create mode 100644 src/fsevents/fsevents.ml create mode 100644 src/fsevents/fsevents.mli create mode 100644 src/fsevents/fsevents_stubs.c create mode 100644 test/expect-tests/fsevents/dune create mode 100644 test/expect-tests/fsevents/fsevents_tests.ml diff --git a/src/fsevents/bin/dune b/src/fsevents/bin/dune new file mode 100644 index 000000000000..f6267391aba3 --- /dev/null +++ b/src/fsevents/bin/dune @@ -0,0 +1,5 @@ +;; a little binary to test out our fsevents bindings + +(executable + (name dune_fsevents) + (libraries threads.posix dyn fsevents)) diff --git a/src/fsevents/bin/dune_fsevents.ml b/src/fsevents/bin/dune_fsevents.ml new file mode 100644 index 000000000000..500a01a20e66 --- /dev/null +++ b/src/fsevents/bin/dune_fsevents.ml @@ -0,0 +1,15 @@ +let paths, latency = + let latency = ref 0. in + let paths = ref [] in + let anon p = paths := p :: !paths in + Arg.parse + [ ("--latency", Arg.Set_float latency, "latency") ] + anon "dune_fsevents [--latency float] [path]+"; + (!paths, !latency) + +let fsevents = + Fsevents.create ~paths ~latency ~f:(fun _ events -> + ListLabels.iter events ~f:(fun evt -> + Printf.printf "%s\n%!" (Dyn.to_string (Fsevents.Event.to_dyn_raw evt)))) + +let () = Fsevents.start fsevents diff --git a/src/fsevents/dune b/src/fsevents/dune new file mode 100644 index 000000000000..9f564ab99102 --- /dev/null +++ b/src/fsevents/dune @@ -0,0 +1,9 @@ +(library + (name fsevents) + (synopsis "minimal bindings for fsvents on macos") + (library_flags + (:include flags/sexp)) + (foreign_stubs + (language c) + (names fsevents_stubs)) + (libraries dyn stdune)) diff --git a/src/fsevents/flags/dune b/src/fsevents/flags/dune new file mode 100644 index 000000000000..5bf0c75c4d6c --- /dev/null +++ b/src/fsevents/flags/dune @@ -0,0 +1,10 @@ +(executable + (name gen_flags)) + +(rule + (deps + (:script gen_flags.ml)) + (action + (with-stdout-to + sexp + (run ./gen_flags.exe %{system})))) diff --git a/src/fsevents/flags/gen_flags.ml b/src/fsevents/flags/gen_flags.ml new file mode 100644 index 000000000000..a71a8a66219c --- /dev/null +++ b/src/fsevents/flags/gen_flags.ml @@ -0,0 +1,6 @@ +let () = + if Sys.argv.(1) = "macosx" then + Printf.printf + {|(-cclib "-framework Foundation" -cclib "-framework CoreServices")|} + else + print_string "()" diff --git a/src/fsevents/fsevents.ml b/src/fsevents/fsevents.ml new file mode 100644 index 000000000000..502a48e9f052 --- /dev/null +++ b/src/fsevents/fsevents.ml @@ -0,0 +1,197 @@ +open Stdune + +module Event = struct + module Id = struct + type t + end + + type t = + { path : string + ; id : Id.t + ; flags : Int32.t + } + + module Raw = struct + type t = + { must_scan_subdirs : bool + ; user_dropped : bool + ; kernel_dropped : bool + ; event_ids_wrapped : bool + ; history_done : bool + ; root_changed : bool + ; mount : bool + ; unmount : bool + ; item_created : bool + ; item_removed : bool + ; item_inode_meta_mod : bool + ; item_renamed : bool + ; item_modified : bool + ; item_finder_info_mod : bool + ; item_change_owner : bool + ; item_xattr_mod : bool + ; item_is_file : bool + ; item_is_dir : bool + ; item_is_symlink : bool + ; own_event : bool + ; item_is_hardlink : bool + ; item_is_last_hardlink : bool + ; item_cloned : bool + } + + let to_dyn + { must_scan_subdirs + ; user_dropped + ; kernel_dropped + ; event_ids_wrapped + ; history_done + ; root_changed + ; mount + ; unmount + ; own_event + ; item_created + ; item_removed + ; item_inode_meta_mod + ; item_renamed + ; item_modified + ; item_finder_info_mod + ; item_change_owner + ; item_xattr_mod + ; item_is_file + ; item_is_dir + ; item_is_symlink + ; item_is_hardlink + ; item_is_last_hardlink + ; item_cloned + } = + let open Dyn.Encoder in + record + [ ("must_scan_subdirs", bool must_scan_subdirs) + ; ("user_dropped", bool user_dropped) + ; ("kernel_dropped", bool kernel_dropped) + ; ("event_ids_wrapped", bool event_ids_wrapped) + ; ("history_done", bool history_done) + ; ("root_changed", bool root_changed) + ; ("mount", bool mount) + ; ("unmount", bool unmount) + ; ("own_event", bool own_event) + ; ("item_created", bool item_created) + ; ("item_removed", bool item_removed) + ; ("item_inode_meta_mod", bool item_inode_meta_mod) + ; ("item_renamed", bool item_renamed) + ; ("item_modified", bool item_modified) + ; ("item_finder_info_mod", bool item_finder_info_mod) + ; ("item_change_owner", bool item_change_owner) + ; ("item_xattr_mod", bool item_xattr_mod) + ; ("item_is_file", bool item_is_file) + ; ("item_is_dir", bool item_is_dir) + ; ("item_is_symlink", bool item_is_symlink) + ; ("item_is_hardlink", bool item_is_hardlink) + ; ("item_is_last_hardlink", bool item_is_last_hardlink) + ; ("item_cloned", bool item_cloned) + ] + end + + external raw : Int32.t -> Raw.t = "dune_fsevents_raw" + + let to_dyn_raw t = + let open Dyn.Encoder in + record [ ("flags", Raw.to_dyn (raw t.flags)); ("path", string t.path) ] + + let id t = t.id + + let path t = t.path + + type kind = + | Dir + | File + | Dir_and_descendants + + let dyn_of_kind kind = + Dyn.Encoder.string + (match kind with + | Dir -> "Dir" + | File -> "File" + | Dir_and_descendants -> "Dir_and_descendants") + + external kind : Int32.t -> kind = "dune_fsevents_kind" + + let kind t = kind t.flags + + type action = + | Unknown + | Create + | Remove + | Modify + + external action : Int32.t -> action = "dune_fsevents_action" + + let action t = action t.flags + + let dyn_of_action a = + Dyn.Encoder.string + (match a with + | Create -> "Create" + | Remove -> "Remove" + | Modify -> "Modify" + | Unknown -> "Unknown") + + let to_dyn t = + let open Dyn.Encoder in + record + [ ("action", dyn_of_action (action t)) + ; ("kind", dyn_of_kind (kind t)) + ; ("path", string t.path) + ] +end + +type t + +external available : unit -> bool = "dune_fsevents_available" + +external stop : t -> unit = "dune_fsevents_stop" + +external start : t -> unit = "dune_fsevents_start" + +external loop : t -> unit = "dune_fsevents_loop" + +let loop t = + match loop t with + | exception exn -> Error exn + | () -> Ok () + +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" + +let create ~paths ~latency ~f = + (match paths with + | [] -> Code_error.raise "Fsevents.create: paths empty" [] + | _ -> ()); + dune_fsevents_create paths latency f + +(* external flush_async : t -> Event.Id.t = "dune_fsevents_flush_async" *) + +external set_exclusion_paths : t -> string list -> unit + = "dune_fsevents_set_exclusion_paths" + +let set_exclusion_paths t ~paths = + if List.length paths > 8 then + Code_error.raise + "Fsevents.set_exclusion_paths: 8 directories should be enough for anybody" + [ ("paths", Dyn.Encoder.(list string) paths) ]; + set_exclusion_paths t paths + +(* let flush_async t = *) +(* let res = flush_async t in *) +(* if UInt64.equal res UInt64.zero then *) +(* `No_events_queued *) +(* else *) +(* `Last res *) + +let flush_async _ = failwith "temporarily disabled" diff --git a/src/fsevents/fsevents.mli b/src/fsevents/fsevents.mli new file mode 100644 index 000000000000..4f2f3a039066 --- /dev/null +++ b/src/fsevents/fsevents.mli @@ -0,0 +1,89 @@ +(** Minimal bindings for fsevents on macos. + + We only bind to the subset of fsevents relevant to dune. *) + +val available : unit -> bool + +module Event : sig + module Id : sig + (** monotonically increasing id *) + type t + end + + (** file system event *) + type t + + val to_dyn_raw : t -> Dyn.t + + val to_dyn : t -> Dyn.t + + (** [id t] return the id of the event *) + val id : t -> Id.t + + (** [path t] returns the file path this event applies to *) + val path : t -> string + + type kind = + | Dir (** directory *) + | File (** file event *) + | Dir_and_descendants + (** non-specific directory event. all descendants of this directory are + invalidated *) + + val dyn_of_kind : kind -> Dyn.t + + (** [kind t] describes the [kind] of [path t] *) + val kind : t -> kind + + type action = + | Unknown + (** multiple actions merged into one by debouncing or an uninformative + "rename". inspect the FS to see what happened *) + | Create (* [path t] guaranteed to exist *) + | Remove (* [path t] guaranteed to be absent *) + | Modify + (* [path t] guaranteed to exist *) + + val dyn_of_action : action -> Dyn.t + + (** [action t] describes the action occured to [path t] *) + val action : t -> action +end + +(** the type of fsevents watcher *) +type t + +(** [create ~paths ~latency ~f] create a new watcher watching [paths], with + debouncing based on [latency]. [f] is called for every new event *) +val create : + paths:string list -> latency:float -> f:(t -> Event.t list -> unit) -> t + +(** [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 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, exn) result + +(** [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. *) +val flush_sync : t -> unit + +(** Set a list of directories to ignore. A maximum of 8 directories may be + specified *) +val set_exclusion_paths : t -> paths:string list -> unit + +(** [flush_async t] ask to flush buffered events but do not block. returns the + id of the last event buffered (if it exists) *) +val flush_async : t -> [ `Last of Event.Id.t | `No_events_queued ] diff --git a/src/fsevents/fsevents_stubs.c b/src/fsevents/fsevents_stubs.c new file mode 100644 index 000000000000..cf7bf6c5e5ca --- /dev/null +++ b/src/fsevents/fsevents_stubs.c @@ -0,0 +1,358 @@ +#include +#include +#include +#include +#include +#include + +#if defined(__APPLE__) +#include +#include + +typedef struct dune_fsevents_t { + CFRunLoopRef runLoop; + value v_callback; + FSEventStreamRef stream; + value v_exn; +} dune_fsevents_t; + +static FSEventStreamEventFlags interesting_flags = + kFSEventStreamEventFlagItemCreated | kFSEventStreamEventFlagItemRemoved | + kFSEventStreamEventFlagItemRenamed | kFSEventStreamEventFlagItemModified | + kFSEventStreamEventFlagMustScanSubDirs; + +static void dune_fsevents_callback(const FSEventStreamRef streamRef, + dune_fsevents_t *t, size_t numEvents, + CFArrayRef eventPaths, + const FSEventStreamEventFlags eventFlags[], + const FSEventStreamEventId eventIds[]) { + caml_acquire_runtime_system(); + CAMLparam0(); + CAMLlocal5(v_events_xs, v_events_x, v_flags, v_id, v_event); + CAMLlocal2(v_path, v_res); + v_events_xs = Val_emptylist; + + // we iterate over the events backwards to avoid reversing the list in the end + size_t j = 0; + size_t i = numEvents - 1; + for (; j < numEvents; j++, i = numEvents - j - 1) { + FSEventStreamEventFlags flags = eventFlags[i]; + if (!(interesting_flags & flags)) { + continue; + } + CFDictionaryRef details = CFArrayGetValueAtIndex(eventPaths, i); + CFStringRef cf_path = + CFDictionaryGetValue(details, kFSEventStreamEventExtendedDataPathKey); + CFIndex len = CFStringGetLength(cf_path); + CFIndex byte_len; + CFIndex res = + CFStringGetBytes(cf_path, CFRangeMake(0, len), kCFStringEncodingUTF8, 0, + 0, NULL, 0, &byte_len); + v_path = caml_alloc_string(byte_len); + unsigned char *p = Bytes_val(v_path); + res = CFStringGetBytes(cf_path, CFRangeMake(0, len), kCFStringEncodingUTF8, + 0, 0, (UInt8 *)p, byte_len, NULL); + assert(res == len); + + v_event = caml_alloc(3, 0); + v_id = caml_copy_int64(eventIds[i]); + v_flags = caml_copy_int32(flags); + Store_field(v_event, 0, v_path); + Store_field(v_event, 1, v_id); + Store_field(v_event, 2, v_flags); + + v_events_x = caml_alloc(2, 0); + Store_field(v_events_x, 0, v_event); + Store_field(v_events_x, 1, v_events_xs); + v_events_xs = v_events_x; + } + // TODO what happens if this function raises? + v_res = caml_callback2_exn(t->v_callback, caml_copy_nativeint((intnat)t), v_events_xs); + if (Is_exception_result(v_res)) { + t->v_exn = Extract_exception(v_res); + FSEventStreamStop(t->stream); + FSEventStreamInvalidate(t->stream); + CFRunLoopStop(t->runLoop); + } + CAMLdrop; + caml_release_runtime_system(); +} + +CFMutableArrayRef paths_of_list(value v_paths) { + CFMutableArrayRef paths = + CFArrayCreateMutable(kCFAllocatorDefault, 0, &kCFTypeArrayCallBacks); + + int i = 0; + CAMLparam0(); + CAMLlocal1(path); + while (v_paths != Val_emptylist) { + path = Field(v_paths, 0); + CFStringRef s = CFStringCreateWithCString( + kCFAllocatorDefault, String_val(path), kCFStringEncodingUTF8); + CFArraySetValueAtIndex(paths, i, s); + v_paths = Field(v_paths, 1); + i++; + } + + return paths; +} + +CAMLprim value dune_fsevents_create(value v_paths, value v_latency, + value v_callback) { + CAMLparam3(v_paths, v_latency, v_callback); + CAMLlocal1(path); + + CFMutableArrayRef paths = paths_of_list(v_paths); + + const FSEventStreamEventFlags flags = + kFSEventStreamCreateFlagNoDefer | + kFSEventStreamCreateFlagUseExtendedData | + kFSEventStreamCreateFlagUseCFTypes | kFSEventStreamCreateFlagFileEvents; + + dune_fsevents_t *t; + t = caml_stat_alloc(sizeof(dune_fsevents_t)); + + FSEventStreamContext context = {0, (void *)t, NULL /*retain*/, + NULL /*release*/, NULL}; + FSEventStreamRef stream = FSEventStreamCreate( + kCFAllocatorDefault, (FSEventStreamCallback)&dune_fsevents_callback, + &context, paths, kFSEventStreamEventIdSinceNow, Double_val(v_latency), + flags); + CFRelease(paths); + caml_register_global_root(&t->v_callback); + caml_register_global_root(&t->v_exn); + t->v_callback = v_callback; + t->stream = stream; + t->v_exn = Val_unit; + + CAMLreturn(caml_copy_nativeint((intnat)t)); +} + +CAMLprim value dune_fsevents_set_exclusion_paths(value v_t, value v_paths) { + CAMLparam2(v_t, v_paths); + CAMLlocal1(path); + dune_fsevents_t *t = (dune_fsevents_t *)Nativeint_val(v_t); + CFMutableArrayRef paths = paths_of_list(v_paths); + + bool ret = FSEventStreamSetExclusionPaths(t->stream, paths); + CFRelease(paths); + if (!ret) { + // TODO use code errors + caml_failwith("Fsevents.set_exclusion_paths: unable to set"); + } + CAMLreturn(Val_unit); +} + +CAMLprim value dune_fsevents_start(value v_t) { + CAMLparam1(v_t); + dune_fsevents_t *t = (dune_fsevents_t *)Nativeint_val(v_t); + CFRunLoopRef runLoop = CFRunLoopGetCurrent(); + t->runLoop = runLoop; + FSEventStreamScheduleWithRunLoop(t->stream, runLoop, kCFRunLoopDefaultMode); + bool res = FSEventStreamStart(t->stream); + if (!res) { + caml_failwith("Fsevents.start: failed to start"); + } + 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); + caml_remove_global_root(&t->v_exn); + caml_stat_free(t); + 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(); + if(t->v_exn != Val_unit) { + caml_raise(t->v_exn); + } + 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_flush_async(value v_t) { + CAMLparam1(v_t); + dune_fsevents_t *t = (dune_fsevents_t *)Nativeint_val(v_t); + CAMLlocal1(v_event); + uint64_t id = FSEventStreamFlushAsync(t->stream); + v_event = caml_copy_int64(id); + CAMLreturn(v_event); +} + +CAMLprim value dune_fsevents_flush_sync(value v_t) { + CAMLparam1(v_t); + dune_fsevents_t *t = (dune_fsevents_t *)Nativeint_val(v_t); + caml_release_runtime_system(); + FSEventStreamFlushSync(t->stream); + caml_acquire_runtime_system(); + CAMLreturn(Val_unit); +} + +CAMLprim value dune_fsevents_kind(value v_flags) { + CAMLparam1(v_flags); + CAMLlocal1(v_kind); + uint32_t flags = Int32_val(v_flags); + if (flags & kFSEventStreamEventFlagItemIsDir) { + v_kind = Val_int(flags & kFSEventStreamEventFlagMustScanSubDirs ? 2 : 0); + } else { + v_kind = Val_int(1); + }; + CAMLreturn(v_kind); +} + +static const FSEventStreamEventFlags action_mask = + kFSEventStreamEventFlagItemCreated | kFSEventStreamEventFlagItemRemoved | + kFSEventStreamEventFlagItemRenamed | kFSEventStreamEventFlagItemModified; + +CAMLprim value dune_fsevents_action(value v_flags) { + CAMLparam1(v_flags); + CAMLlocal1(v_action); + + uint32_t flags = Int32_val(v_flags) & action_mask; + // XXX slow + int count = 0; + while (flags) { + count += (flags & 1); + flags >>= 1; + } + + flags = Int32_val(v_flags); + if (count >= 2 || flags & kFSEventStreamEventFlagItemRenamed) { + // we don't bother tracking renamed acurately for now. macos makes it + // tricky by not telling is which path is created and which one is deleted. + // it is possible to reverse engineer this from the chain of inodes in the + // events, but it's also error prone as inodes can be reused. so for now, we + // avoid this is and treat renamed as unknown + v_action = Val_int(0); + } else if (flags & kFSEventStreamEventFlagItemCreated) { + v_action = Val_int(1); + } else if (flags & kFSEventStreamEventFlagItemRemoved) { + v_action = Val_int(2); + } else if (flags & kFSEventStreamEventFlagItemModified) { + v_action = Val_int(3); + } else { + caml_failwith("fsevents: unexpected event action"); + } + + CAMLreturn(v_action); +} +static const FSEventStreamEventFlags all_flags[] = { + kFSEventStreamEventFlagMustScanSubDirs, + kFSEventStreamEventFlagUserDropped, + kFSEventStreamEventFlagKernelDropped, + kFSEventStreamEventFlagEventIdsWrapped, + kFSEventStreamEventFlagHistoryDone, + kFSEventStreamEventFlagRootChanged, + kFSEventStreamEventFlagMount, + kFSEventStreamEventFlagUnmount, + kFSEventStreamEventFlagItemCreated, + kFSEventStreamEventFlagItemRemoved, + kFSEventStreamEventFlagItemInodeMetaMod, + kFSEventStreamEventFlagItemRenamed, + kFSEventStreamEventFlagItemModified, + kFSEventStreamEventFlagItemFinderInfoMod, + kFSEventStreamEventFlagItemChangeOwner, + kFSEventStreamEventFlagItemXattrMod, + kFSEventStreamEventFlagItemIsFile, + kFSEventStreamEventFlagItemIsDir, + kFSEventStreamEventFlagItemIsSymlink, + kFSEventStreamEventFlagOwnEvent, + kFSEventStreamEventFlagItemIsHardlink, + kFSEventStreamEventFlagItemIsLastHardlink, + kFSEventStreamEventFlagItemCloned}; + +CAMLprim value dune_fsevents_raw(value v_flags) { + CAMLparam1(v_flags); + CAMLlocal1(v_raw); + size_t len = sizeof(all_flags) / sizeof(FSEventStreamEventFlags); + v_raw = caml_alloc(len, 0); + uint32_t flags = Int32_val(v_flags); + for (size_t i = 0; i < len; i++) { + Store_field(v_raw, i, flags & all_flags[i] ? Val_true : Val_false); + } + CAMLreturn(v_raw); +} + +CAMLprim value dune_fsevents_available(value unit) { + CAMLparam1(unit); + CAMLreturn(Val_true); +} + +#else + +CAMLprim value dune_fsevents_stop(value v_t) { + caml_failwith("fsevents is only available on macos"); +} + +CAMLprim value dune_fsevents_start(value v_t) { + caml_failwith("fsevents is only available on macos"); +} + +CAMLprim value dune_fsevents_create(value v_paths, value v_latency, + value v_callback) { + caml_failwith("fsevents is only available on macos"); +} +CAMLprim value dune_fsevents_set_exclusion_paths(value v_t, value v_paths) { + caml_failwith("fsevents is only available on macos"); +} +CAMLprim value dune_fsevents_flush_async(value v_t) { + + caml_failwith("fsevents is only available on macos"); +} +CAMLprim value dune_fsevents_kind(value v_flags) { + + caml_failwith("fsevents is only available on macos"); +} +CAMLprim value dune_fsevents_action(value v_flags) { + + caml_failwith("fsevents is only available on macos"); +} +CAMLprim value dune_fsevents_raw(value v_flags) { + caml_failwith("fsevents is only available on macos"); +} + +CAMLprim value dune_fsevents_flush_sync(value v_t) { + caml_failwith("fsevents is only available on macos"); +} + +CAMLprim value dune_fsevents_destroy(value v_t) { + caml_failwith("fsevents is only available on macos"); +} + +CAMLprim value dune_fsevents_break(value v_t) { + caml_failwith("fsevents is only available on macos"); +} + +CAMLprim value dune_fsevents_loop(value v_t) { + caml_failwith("fsevents is only available on macos"); +} + +CAMLprim value dune_fsevents_available(value unit) { + CAMLparam1(unit); + CAMLreturn(Val_false); +} + +#endif diff --git a/test/expect-tests/fsevents/dune b/test/expect-tests/fsevents/dune new file mode 100644 index 000000000000..6cbae74b7a8d --- /dev/null +++ b/test/expect-tests/fsevents/dune @@ -0,0 +1,18 @@ +(library + (name fsevents_tests) + (inline_tests) + (enabled_if + (= %{system} macosx)) + (libraries + fsevents + stdune + threads.posix + ;; This is because of the (implicit_transitive_deps false) + ;; in dune-project + ppx_expect.config + ppx_expect.config_types + ppx_expect.common + base + ppx_inline_test.config) + (preprocess + (pps ppx_expect))) diff --git a/test/expect-tests/fsevents/fsevents_tests.ml b/test/expect-tests/fsevents/fsevents_tests.ml new file mode 100644 index 000000000000..d91fa5de67ee --- /dev/null +++ b/test/expect-tests/fsevents/fsevents_tests.ml @@ -0,0 +1,188 @@ +open Stdune +module Event = Fsevents.Event + +let timeout_thread ~wait f = + let spawn () = + Thread.delay wait; + f () + in + 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 + let finished = ref false in + let finish () = + Mutex.lock mutex; + finished := true; + Condition.signal cv; + Mutex.unlock mutex + in + timeout_thread ~wait:3.0 (fun () -> + Mutex.lock mutex; + if not !finished then ( + Format.eprintf "Test timed out@."; + finished := true; + Condition.signal cv + ); + Mutex.unlock mutex); + let test () = + let dir = Temp.create Dir ~prefix:"fsevents_dune" ~suffix:"" in + let old = Sys.getcwd () in + Sys.chdir (Path.to_string dir); + Exn.protect + ~f:(fun () -> f finish) + ~finally:(fun () -> + Sys.chdir old; + Temp.destroy Dir dir) + in + let (_ : Thread.t) = Thread.create test () in + Mutex.lock mutex; + while not !finished do + Condition.wait cv mutex + done; + Mutex.unlock mutex + +let print_event ~cwd e = + let dyn = + let open Dyn.Encoder in + record + [ ("action", Event.dyn_of_action (Event.action e)) + ; ("kind", Event.dyn_of_kind (Event.kind e)) + ; ( "path" + , string + (let path = Event.path e in + match String.drop_prefix ~prefix:cwd path with + | None -> path + | Some p -> "$TESTCASE_ROOT" ^ p) ) + ] + in + printfn "> %s" (Dyn.to_string dyn) + +let make_callback ~f = + (* hack to skip the first event if it's creating the temp dir *) + let state = ref `Looking_start in + fun t events -> + 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 ?on_event ~cwd ~paths () = + let on_event = + match on_event with + | None -> print_event ~cwd + | Some s -> s + in + Fsevents.create ~paths + ~f:(make_callback ~f:(List.iter ~f:on_event)) + ~latency:0. + +let test_with_operations ?on_event ?exclusion_paths f = + test (fun finish -> + let cwd = Sys.getcwd () in + let t = fsevents ?on_event ~paths:[ cwd ] ~cwd () in + (match exclusion_paths with + | None -> () + | Some f -> + let paths = f cwd in + Fsevents.set_exclusion_paths t ~paths); + Fsevents.start t; + let (_ : Thread.t) = + Thread.create + (fun () -> + emit_start (); + f (); + emit_end ()) + () + in + (match Fsevents.loop t with + | Error Exit -> print_endline "[EXIT]" + | Error _ -> assert false + | Ok () -> ()); + 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" } |}] + +let%expect_test "dir create event" = + test_with_operations (fun () -> ignore (Fpath.mkdir "./blahblah")); + [%expect + {| > { 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/new" } + > { action = "Unknown"; kind = "File"; path = "$TESTCASE_ROOT/old" } |}] + +let%expect_test "raise inside callback" = + test_with_operations + ~on_event:(fun _ -> + print_endline "exiting."; + raise Exit) + (fun () -> + Io.String_path.write_file "old" "foobar"; + Io.String_path.write_file "old" "foobar"); + [%expect {| + exiting. + [EXIT] |}] + +let%expect_test "set exclusion paths" = + let run paths = + let ignored = "ignored" in + test_with_operations + ~exclusion_paths:(fun cwd -> [ paths cwd ignored ]) + (fun () -> + let (_ : Fpath.mkdir_p_result) = Fpath.mkdir_p ignored in + Io.String_path.write_file (Filename.concat ignored "old") "foobar") + in + (* absolute paths work *) + run Filename.concat; + [%expect + {| > { action = "Create"; kind = "Dir"; path = "$TESTCASE_ROOT/ignored" } |}]; + (* but relative paths do not *) + run (fun _ name -> name); + [%expect + {| + > { action = "Unknown"; kind = "File"; path = "$TESTCASE_ROOT/ignored/old" } + > { action = "Create"; kind = "Dir"; path = "$TESTCASE_ROOT/ignored" } |}]