diff --git a/doc/changes/fixed/14725.md b/doc/changes/fixed/14725.md new file mode 100644 index 00000000000..81cb293a7a3 --- /dev/null +++ b/doc/changes/fixed/14725.md @@ -0,0 +1 @@ +- Fix decoding coalesced MacOS file notification events. (#14725, @rgrinberg) diff --git a/src/dune_scheduler/file_watcher.ml b/src/dune_scheduler/file_watcher.ml index 44410bc9786..20d8d3e6c8f 100644 --- a/src/dune_scheduler/file_watcher.ml +++ b/src/dune_scheduler/file_watcher.ml @@ -506,8 +506,8 @@ let create_fsevents ?(latency = Time.Span.of_secs 0.2) ~event_queue ~should_excl match Fsevents.Event.action event with | Remove -> None | Rename | Unknown | Create | Modify -> - Option.map (Fs_sync.consume_event sync_table path) ~f:(fun id -> - Event.Sync id))) + Fs_sync.consume_event sync_table path + |> Option.map ~f:(fun id -> Event.Sync id))) in let on_event = fsevents_standard_event ~should_exclude in let source = diff --git a/src/dune_scheduler/fsevents.ml b/src/dune_scheduler/fsevents.ml index 3b65f3e7cec..3309fd23286 100644 --- a/src/dune_scheduler/fsevents.ml +++ b/src/dune_scheduler/fsevents.ml @@ -179,43 +179,84 @@ module Event = struct let id t = t.id let path t = t.path - type kind = - | Dir - | File - | Dir_and_descendants - - let dyn_of_kind kind = - Dyn.string - (match kind with - | Dir -> "Dir" - | File -> "File" - | Dir_and_descendants -> "Dir_and_descendants") - ;; + module Kind = struct + type t = + | Dir + | File + | Dir_and_descendants + + let repr = + Repr.variant + "fsevents-kind" + [ Repr.case0 "Dir" ~test:(function + | Dir -> true + | File | Dir_and_descendants -> false) + ; Repr.case0 "File" ~test:(function + | File -> true + | Dir | Dir_and_descendants -> false) + ; Repr.case0 "Dir_and_descendants" ~test:(function + | Dir_and_descendants -> true + | Dir | File -> false) + ] + ;; + + include Repr.Poly (struct + type nonrec t = t - external kind : Int32.t -> kind = "dune_fsevents_kind" + let repr = repr + end) - let kind t = kind t.flags + let to_dyn = Repr.to_dyn repr + end - type action = - | Create - | Remove - | Modify - | Rename - | Unknown + let dyn_of_kind = Kind.to_dyn - external action : Int32.t -> action = "dune_fsevents_action" + external kind_of_flags : Int32.t -> Kind.t = "dune_fsevents_kind" - let action t = action t.flags + let kind t = kind_of_flags t.flags - let dyn_of_action a = - Dyn.string - (match a with - | Create -> "Create" - | Remove -> "Remove" - | Modify -> "Modify" - | Unknown -> "Unknown" - | Rename -> "Rename") - ;; + module Action = struct + type t = + | Create + | Remove + | Modify + | Rename + | Unknown + + let repr = + Repr.variant + "fsevents-action" + [ Repr.case0 "Create" ~test:(function + | Create -> true + | Remove | Modify | Rename | Unknown -> false) + ; Repr.case0 "Remove" ~test:(function + | Remove -> true + | Create | Modify | Rename | Unknown -> false) + ; Repr.case0 "Modify" ~test:(function + | Modify -> true + | Create | Remove | Rename | Unknown -> false) + ; Repr.case0 "Rename" ~test:(function + | Rename -> true + | Create | Remove | Modify | Unknown -> false) + ; Repr.case0 "Unknown" ~test:(function + | Unknown -> true + | Create | Remove | Modify | Rename -> false) + ] + ;; + + include Repr.Poly (struct + type nonrec t = t + + let repr = repr + end) + + let to_dyn = Repr.to_dyn repr + end + + external action_of_flags : Int32.t -> Action.t = "dune_fsevents_action" + + let action t = action_of_flags t.flags + let dyn_of_action = Action.to_dyn let to_dyn t = let open Dyn in @@ -225,6 +266,51 @@ module Event = struct ; "path", string t.path ] ;; + + external flag_examples : unit -> (string * Int32.t) list = "dune_fsevents_flag_examples" + + let%expect_test "fsevents flag decoding" = + if available () + then ( + let decoded = + flag_examples () + |> List.map ~f:(fun (name, flags) -> + name, action_of_flags flags, kind_of_flags flags) + in + let expected = + [ "created_file", Action.Create, Kind.File + ; "removed_file", Action.Remove, Kind.File + ; "modified_file", Action.Modify, Kind.File + ; "renamed_file", Action.Rename, Kind.File + ; "created_dir", Action.Create, Kind.Dir + ; "must_scan_subdirs", Action.Unknown, Kind.Dir_and_descendants + ; "must_scan_dir", Action.Unknown, Kind.Dir_and_descendants + ; "created_and_modified", Action.Unknown, Kind.File + ; "removed_and_renamed", Action.Unknown, Kind.File + ] + in + let module Decoded = struct + type t = string * Action.t * Kind.t + + let repr = Repr.triple Repr.string Action.repr Kind.repr + + include Repr.Poly (struct + type nonrec t = t + + let repr = repr + end) + + let to_dyn = Repr.to_dyn repr + end + in + if not (List.equal Decoded.equal decoded expected) + then + Code_error.raise + "unexpected fsevents flag decoding" + [ "decoded", Dyn.list Decoded.to_dyn decoded + ; "expected", Dyn.list Decoded.to_dyn expected + ]) + ;; end module Raw = struct diff --git a/src/dune_scheduler/fsevents.mli b/src/dune_scheduler/fsevents.mli index bf7feb05564..541f860d4c2 100644 --- a/src/dune_scheduler/fsevents.mli +++ b/src/dune_scheduler/fsevents.mli @@ -31,31 +31,35 @@ module Event : sig (** [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 + module Kind : sig + type t = + | Dir (** directory *) + | File (** file event *) + | Dir_and_descendants + (** non-specific directory event. all descendants of this directory are + invalidated *) + + val to_dyn : t -> Dyn.t + end (** [kind t] describes the [kind] of [path t] *) - val kind : t -> kind - - type action = - | Create (* [path t] guaranteed to exist *) - | Remove (* [path t] guaranteed to be absent *) - | Modify (* [path t] guaranteed to exist *) - | Rename - | Unknown - (** multiple actions merged into one by debouncing or an uninformative - "rename". inspect the FS to see what happened *) - - val dyn_of_action : action -> Dyn.t + val kind : t -> Kind.t + + module Action : sig + type t = + | Create (* [path t] guaranteed to exist *) + | Remove (* [path t] guaranteed to be absent *) + | Modify (* [path t] guaranteed to exist *) + | Rename + | Unknown + (** multiple actions merged into one by debouncing or an uninformative + "rename". inspect the FS to see what happened *) + + val to_dyn : t -> Dyn.t + end (** [action t] describes the action occurred to [path t] *) - val action : t -> action + val action : t -> Action.t end (** the type of fsevents watcher *) diff --git a/src/dune_scheduler/fsevents_stubs.c b/src/dune_scheduler/fsevents_stubs.c index 8dcb105fd77..e6caf0405d9 100644 --- a/src/dune_scheduler/fsevents_stubs.c +++ b/src/dune_scheduler/fsevents_stubs.c @@ -345,41 +345,108 @@ CAMLprim value dune_fsevents_flush_sync(value v_t) { CAMLreturn(Val_unit); } +// Keep in sync with the Event.Kind.t variant in fsevents.ml. +enum dune_fsevents_kind_tag { + DUNE_FSEVENTS_KIND_DIR = 0, + DUNE_FSEVENTS_KIND_FILE = 1, + DUNE_FSEVENTS_KIND_DIR_AND_DESCENDANTS = 2, +}; + +static value dune_fsevents_kind_of_flags(FSEventStreamEventFlags flags) { + if (flags & kFSEventStreamEventFlagMustScanSubDirs) { + return Val_int(DUNE_FSEVENTS_KIND_DIR_AND_DESCENDANTS); + } else if (flags & kFSEventStreamEventFlagItemIsDir) { + return Val_int(DUNE_FSEVENTS_KIND_DIR); + } else { + return Val_int(DUNE_FSEVENTS_KIND_FILE); + } +} + 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); + CAMLreturn(dune_fsevents_kind_of_flags(Int32_val(v_flags))); } 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; - if (flags & kFSEventStreamEventFlagItemCreated) { - v_action = Val_int(0); - } else if (flags & kFSEventStreamEventFlagItemRemoved) { - v_action = Val_int(1); - } else if (flags & kFSEventStreamEventFlagItemModified) { - v_action = Val_int(2); - } else if (flags & kFSEventStreamEventFlagItemRenamed) { - v_action = Val_int(3); +// Keep in sync with the Event.action variant in fsevents.ml. +enum dune_fsevents_action_tag { + DUNE_FSEVENTS_ACTION_CREATE = 0, + DUNE_FSEVENTS_ACTION_REMOVE = 1, + DUNE_FSEVENTS_ACTION_MODIFY = 2, + DUNE_FSEVENTS_ACTION_RENAME = 3, + DUNE_FSEVENTS_ACTION_UNKNOWN = 4, +}; + +static value dune_fsevents_action_of_flags(FSEventStreamEventFlags flags) { + flags &= action_mask; + if (flags == kFSEventStreamEventFlagItemCreated) { + return Val_int(DUNE_FSEVENTS_ACTION_CREATE); + } else if (flags == kFSEventStreamEventFlagItemRemoved) { + return Val_int(DUNE_FSEVENTS_ACTION_REMOVE); + } else if (flags == kFSEventStreamEventFlagItemModified) { + return Val_int(DUNE_FSEVENTS_ACTION_MODIFY); + } else if (flags == kFSEventStreamEventFlagItemRenamed) { + return Val_int(DUNE_FSEVENTS_ACTION_RENAME); } else { - v_action = Val_int(4); + return Val_int(DUNE_FSEVENTS_ACTION_UNKNOWN); } +} - CAMLreturn(v_action); +CAMLprim value dune_fsevents_action(value v_flags) { + CAMLparam1(v_flags); + CAMLreturn(dune_fsevents_action_of_flags(Int32_val(v_flags))); +} + +typedef struct dune_fsevents_flag_example { + const char *name; + FSEventStreamEventFlags flags; +} dune_fsevents_flag_example; + +static const dune_fsevents_flag_example flag_examples[] = { + {"created_file", kFSEventStreamEventFlagItemCreated | + kFSEventStreamEventFlagItemIsFile}, + {"removed_file", kFSEventStreamEventFlagItemRemoved | + kFSEventStreamEventFlagItemIsFile}, + {"modified_file", kFSEventStreamEventFlagItemModified | + kFSEventStreamEventFlagItemIsFile}, + {"renamed_file", kFSEventStreamEventFlagItemRenamed | + kFSEventStreamEventFlagItemIsFile}, + {"created_dir", kFSEventStreamEventFlagItemCreated | + kFSEventStreamEventFlagItemIsDir}, + {"must_scan_subdirs", kFSEventStreamEventFlagMustScanSubDirs}, + {"must_scan_dir", kFSEventStreamEventFlagMustScanSubDirs | + kFSEventStreamEventFlagItemIsDir}, + {"created_and_modified", kFSEventStreamEventFlagItemCreated | + kFSEventStreamEventFlagItemModified | + kFSEventStreamEventFlagItemIsFile}, + {"removed_and_renamed", kFSEventStreamEventFlagItemRemoved | + kFSEventStreamEventFlagItemRenamed | + kFSEventStreamEventFlagItemIsFile}, +}; + +CAMLprim value dune_fsevents_flag_examples(value v_unit) { + CAMLparam1(v_unit); + CAMLlocal5(v_list, v_cons, v_tuple, v_name, v_flags); + size_t len = sizeof(flag_examples) / sizeof(dune_fsevents_flag_example); + v_list = Val_emptylist; + for (size_t i = len; i > 0; i--) { + dune_fsevents_flag_example example = flag_examples[i - 1]; + v_name = caml_copy_string(example.name); + v_flags = caml_copy_int32(example.flags); + v_tuple = caml_alloc_tuple(2); + Store_field(v_tuple, 0, v_name); + Store_field(v_tuple, 1, v_flags); + v_cons = caml_alloc(2, 0); + Store_field(v_cons, 0, v_tuple); + Store_field(v_cons, 1, v_list); + v_list = v_cons; + } + CAMLreturn(v_list); } + static const FSEventStreamEventFlags all_flags[] = { kFSEventStreamEventFlagMustScanSubDirs, kFSEventStreamEventFlagUserDropped, @@ -471,6 +538,10 @@ CAMLprim value dune_fsevents_action(value v_flags) { (void)v_flags; caml_failwith(unavailable_message); } +CAMLprim value dune_fsevents_flag_examples(value v_unit) { + (void)v_unit; + caml_failwith(unavailable_message); +} CAMLprim value dune_fsevents_raw(value v_flags) { (void)v_flags; caml_failwith(unavailable_message); diff --git a/test/expect-tests/fsevents/fsevents_tests.ml b/test/expect-tests/fsevents/fsevents_tests.ml index e905eb69ca3..e2114ca4c36 100644 --- a/test/expect-tests/fsevents/fsevents_tests.ml +++ b/test/expect-tests/fsevents/fsevents_tests.ml @@ -85,8 +85,8 @@ let print_event ~logger ~cwd e = let dyn = let open Dyn in record - [ "action", Event.dyn_of_action (Event.action e) - ; "kind", Event.dyn_of_kind (Event.kind e) + [ "action", Event.Action.to_dyn (Event.action e) + ; "kind", Event.Kind.to_dyn (Event.kind e) ; ( "path" , string (let path = Event.path e in