diff --git a/CHANGES.md b/CHANGES.md index 615bb77f233..41f1dbe059e 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -139,6 +139,8 @@ Unreleased - Auto-detect `dune-workspace` files as `dune` files in Emacs (#7061, @ilankri) +- Add native support for polling mode on Windows (#7010, @yams-yams, @nojb) + 3.6.2 (2022-12-21) ------------------ diff --git a/boot/libs.ml b/boot/libs.ml index 72dc3969ce5..258bc11cbcb 100644 --- a/boot/libs.ml +++ b/boot/libs.ml @@ -48,6 +48,7 @@ let local_libraries = ; ("vendor/ocaml-inotify/src", Some "Ocaml_inotify", false, None) ; ("src/async_inotify_for_dune", Some "Async_inotify_for_dune", false, None) + ; ("src/fswatch_win", Some "Fswatch_win", false, None) ; ("src/dune_file_watcher", Some "Dune_file_watcher", false, None) ; ("src/dune_engine", Some "Dune_engine", false, None) ; ("src/dune_config", Some "Dune_config", false, None) diff --git a/src/dune_file_watcher/dune b/src/dune_file_watcher/dune index 3281e2bb9d3..f6e3f527922 100644 --- a/src/dune_file_watcher/dune +++ b/src/dune_file_watcher/dune @@ -9,7 +9,8 @@ threads.posix ocaml_inotify async_inotify_for_dune - dune_re) + dune_re + fswatch_win) (synopsis "Internal Dune library, do not use!") (instrumentation (backend bisect_ppx))) diff --git a/src/dune_file_watcher/dune_file_watcher.ml b/src/dune_file_watcher/dune_file_watcher.ml index 0b04607c563..5b679f2478c 100644 --- a/src/dune_file_watcher/dune_file_watcher.ml +++ b/src/dune_file_watcher/dune_file_watcher.ml @@ -137,6 +137,10 @@ type kind = ; latency : float } | Inotify of Inotify_lib.t + | Fswatch_win of + { t : Fswatch_win.t + ; scheduler : Scheduler.t + } type t = { kind : kind @@ -156,6 +160,9 @@ let exclude_patterns = ; {|/#[^#]*#$|} ; {|^4913$|} (* https://github.com/neovim/neovim/issues/3460 *) ; {|/4913$|} + ; {|/.git|} + ; {|/.hg|} + ; {|:/windows|} ] module Re = Dune_re @@ -203,6 +210,7 @@ let shutdown t = Fsevents.stop fsevents.sync; Watch_trie.to_list fsevents.external_ |> List.iter ~f:(fun (_, fs) -> Fsevents.stop fs)) + | Fswatch_win { t; _ } -> `Thunk (fun () -> Fswatch_win.shutdown t) let buffer_capacity = 65536 @@ -354,6 +362,7 @@ let select_watcher_backend () = assert (Ocaml_inotify.Inotify.supported_by_the_os ()); `Inotify_lib) else if Fsevents.available () then `Fsevents + else if Sys.win32 then `Fswatch_win else fswatch_backend () let prepare_sync () = @@ -582,6 +591,48 @@ let create_fsevents ?(latency = 0.2) ~(scheduler : Scheduler.t) () = ; sync_table } +let fswatch_win_callback ~(scheduler : Scheduler.t) ~sync_table event = + let dir = Fswatch_win.Event.directory event in + let filename = Filename.concat dir (Fswatch_win.Event.path event) in + let localized_path = + Path.Expert.try_localize_external (Path.of_string filename) + in + match localized_path with + | In_build_dir _ -> ( + if Fs_sync.is_special_file_fsevents localized_path then + match Fswatch_win.Event.action event with + | Added | Modified -> ( + match Fs_sync.consume_event sync_table filename with + | None -> () + | Some id -> + scheduler.thread_safe_send_emit_events_job (fun () -> [ Sync id ])) + | Removed | Renamed_new | Renamed_old -> ()) + | path -> + let normalized_filename = + String.concat ~sep:"/" + (String.split_on_char ~sep:'\\' (String.lowercase_ascii filename)) + in + if not (should_exclude normalized_filename) then + scheduler.thread_safe_send_emit_events_job (fun () -> + let kind = + match Fswatch_win.Event.action event with + | Added | Renamed_new -> Fs_memo_event.Created + | Removed | Renamed_old -> Deleted + | Modified -> File_changed + in + [ Fs_memo_event { kind; path } ]) + +let create_fswatch_win ~(scheduler : Scheduler.t) ~debounce_interval:sleep = + let sync_table = Table.create (module String) 64 in + let t = Fswatch_win.create () in + Fswatch_win.add t (Path.to_absolute_filename Path.root); + scheduler.spawn_thread (fun () -> + while true do + let events = Fswatch_win.wait t ~sleep in + List.iter ~f:(fswatch_win_callback ~scheduler ~sync_table) events + done); + { kind = Fswatch_win { t; scheduler }; sync_table } + let create_external ~root ~debounce_interval ~scheduler ~backend = match debounce_interval with | None -> create_no_buffering ~root ~scheduler ~backend @@ -597,15 +648,31 @@ let create_default ?fsevents_debounce ~scheduler () = ~debounce_interval:(Some 0.5 (* seconds *)) ~backend | `Fsevents -> create_fsevents ?latency:fsevents_debounce ~scheduler () | `Inotify_lib -> create_inotifylib ~scheduler + | `Fswatch_win -> + create_fswatch_win ~scheduler ~debounce_interval:500 (* milliseconds *) let wait_for_initial_watches_established_blocking t = match t.kind with | Fswatch c -> c.wait_for_watches_established () - | Fsevents _ | Inotify _ -> + | Fsevents _ | Inotify _ | Fswatch_win _ -> (* no initial watches needed: all watches should be set up at the time just before file access *) () +(* Return the parent directory of [ext] if [ext] denotes a file. *) +let parent_directory ext = + let rec loop p = + if Path.is_directory (Path.external_ p) then Some ext + else + match Path.External.parent p with + | None -> + User_warning.emit + [ Pp.textf "Refusing to watch %s" (Path.External.to_string ext) ]; + None + | Some ext -> loop ext + in + loop ext + let add_watch t path = match t.kind with | Fsevents f -> ( @@ -614,21 +681,7 @@ let add_watch t path = | In_build_dir _ -> Code_error.raise "attempted to watch a directory in build" [] | External ext -> ( - let ext = - let rec loop p = - if Path.is_directory (Path.external_ p) then Some ext - else - match Path.External.parent p with - | None -> - User_warning.emit - [ Pp.textf "Refusing to watch %s" (Path.External.to_string ext) - ]; - None - | Some ext -> loop ext - in - loop ext - in - match ext with + match parent_directory ext with | None -> Ok () | Some ext -> ( let watch = @@ -652,5 +705,16 @@ let add_watch t path = | Inotify inotify -> ( try Ok (Inotify_lib.add inotify (Path.to_string path)) with Unix.Unix_error (ENOENT, _, _) -> Error `Does_not_exist) + | Fswatch_win fswatch -> ( + match path with + | In_build_dir _ -> + Code_error.raise "attempted to watch a directory in build" [] + | Path.In_source_tree _ -> Ok () + | External ext -> ( + match parent_directory ext with + | None -> Ok () + | Some _ -> + Fswatch_win.add fswatch.t (Path.to_absolute_filename path); + Ok ())) let emit_sync = Fs_sync.emit diff --git a/src/fswatch_win/bin/dune b/src/fswatch_win/bin/dune new file mode 100644 index 00000000000..ea7e4892f6a --- /dev/null +++ b/src/fswatch_win/bin/dune @@ -0,0 +1,5 @@ +;; A little binary to test out Windows file watcher library + +(executable + (name dune_fswatch_win) + (libraries fswatch_win stdune dyn)) diff --git a/src/fswatch_win/bin/dune_fswatch_win.ml b/src/fswatch_win/bin/dune_fswatch_win.ml new file mode 100644 index 00000000000..f330e4c9977 --- /dev/null +++ b/src/fswatch_win/bin/dune_fswatch_win.ml @@ -0,0 +1,17 @@ +open! Stdune + +let paths = + let paths = ref [] in + let anon p = paths := p :: !paths in + Arg.parse [] anon "dune_fswatch_win [path]+"; + List.rev !paths + +let () = + let t = Fswatch_win.create () in + List.iter ~f:(Fswatch_win.add t) paths; + let f event = + Printf.printf "%s\n%!" (Dyn.to_string (Fswatch_win.Event.to_dyn event)) + in + while true do + List.iter ~f (Fswatch_win.wait t ~sleep:500) + done diff --git a/src/fswatch_win/dune b/src/fswatch_win/dune new file mode 100644 index 00000000000..cd3cac91682 --- /dev/null +++ b/src/fswatch_win/dune @@ -0,0 +1,6 @@ +(library + (name fswatch_win) + (libraries stdune dune_util) + (foreign_stubs + (language c) + (names fswatch_win_stubs))) diff --git a/src/fswatch_win/fswatch_win.ml b/src/fswatch_win/fswatch_win.ml new file mode 100644 index 00000000000..cf99648f774 --- /dev/null +++ b/src/fswatch_win/fswatch_win.ml @@ -0,0 +1,53 @@ +module Event = struct + type action = + | Added + | Removed + | Modified + | Renamed_old + | Renamed_new + + type t = + { directory : string + ; path : string + ; action : action + } + + let directory t = t.directory + + let path t = t.path + + let action t = t.action + + let dyn_of_action = function + | Added -> Dyn.variant "Added" [] + | Removed -> Dyn.variant "Removed" [] + | Modified -> Dyn.variant "Modified" [] + | Renamed_old -> Dyn.variant "Renamed_old" [] + | Renamed_new -> Dyn.variant "Renamed_new" [] + + let to_dyn t = + Dyn.record + [ ("directory", Dyn.string t.directory) + ; ("path", Dyn.String t.path) + ; ("action", dyn_of_action t.action) + ] +end + +type t + +external create : unit -> t = "fswatch_win_create" + +external wait : t -> sleep:int -> Event.t list = "fswatch_win_wait" + +external add : t -> string -> unit = "fswatch_win_add" + +let wait t ~sleep = + List.filter + (function + | { Event.action = Modified; path; directory } -> ( + try not (Sys.is_directory (Filename.concat directory path)) + with Sys_error _ -> true) + | _ -> true) + (wait t ~sleep) + +external shutdown : t -> unit = "fswatch_win_shutdown" diff --git a/src/fswatch_win/fswatch_win.mli b/src/fswatch_win/fswatch_win.mli new file mode 100644 index 00000000000..e3b0cde370f --- /dev/null +++ b/src/fswatch_win/fswatch_win.mli @@ -0,0 +1,52 @@ +(** File-watching support under Windows *) + +module Event : sig + (** The type of events *) + type action = + | Added (** The file was added. *) + | Removed (** The file was removed. *) + | Modified (** The file was modified. *) + | Renamed_old + (** The file was renamed. This corresponds to the old name. *) + | Renamed_new + (** The file was renamed. This corresponds to the new name. *) + + type t + + (** The directory being watched. *) + val directory : t -> string + + (** The path to the file relevant to the event. Relative to the directory + being watched (see {!directory}). *) + val path : t -> string + + (** The description of the event action. *) + val action : t -> action + + (** For debugging. *) + val to_dyn : t -> Dyn.t +end + +(** The type of file watchers. Each file watcher can watch an arbitrary + collection of directories. Multiple file watchers can be used + simultaneously, if needed. *) +type t + +(** Create a file watcher. This creates a native thread that will monitor for + changes in the background. *) +val create : unit -> t + +(** Start watching a directory for changes. The watching is recursive: all + subdirectories are watched as well. Watching a single file is not possible. *) +val add : t -> string -> unit + +(** Wait for events. This function will block until it receives some file change + notifications. After it receives a notification, it will wait for [sleep] + milliseconds before retrieving them and returning them to the user. This is + done to avoid triggering multiple rebuilds in close succession. *) +val wait : t -> sleep:int -> Event.t list + +(** Shutdown the file watcher. This tears down the background thread and frees + all allocated resources. It is an error to call [add] or [wait] after this + function returns. *) +val shutdown : t -> unit diff --git a/src/fswatch_win/fswatch_win_stubs.c b/src/fswatch_win/fswatch_win_stubs.c new file mode 100644 index 00000000000..adc2c176c2a --- /dev/null +++ b/src/fswatch_win/fswatch_win_stubs.c @@ -0,0 +1,515 @@ +/* File-watching support under Windows + + We implement file-watching support under Windows using ReadDirectoryChangesW + and I/O completion ports. The notification of events is pull-based (one needs + to retrive them explicitly, there is no callback that is invoked on each + notification). + + The main type is [fsenv] which keeps track of the state of a file watcher + (including all changes that have been notified by the operator system, but + that have not yet been retrieved by the user). + + There is one value of type [watch] for each directory being watched. It keeps + track of the various buffers needed to use the ReadDirectoryChangesW function + call. + + When the first watch is created a native (not OCaml) thread is triggered + which runs the main event loop, waiting for notifications from the I/O + completion port. When a notification arrives, it is recorded in the [fsenv] + and it will stay there until the user retrives it by calling [wait]. We + notify the user that new notifications have arrived by signalling an event + object which causes the [wait] function to return. + + The [.events] field of the [fsenv] type which is mutated from multiple + threads. Standard lockless techniques are used to avoid data races. + */ + +#define CAML_NAME_SPACE + +#include + +#include +#include +#include +#include +#include +#include +#include +#include + +#if OCAML_VERSION_MAJOR < 5 +#define caml_uerror uerror +#define caml_win32_maperr win32_maperr +#endif + +#if 0 +#define DEBUG(fmt, ...) \ + do { fprintf(stderr, "DEBUG: " __FUNCTION__ ": " fmt "\n", __VA_ARGS__); fflush(stderr); } while (0) +#else +#define DEBUG(fmt, ...) ((void) 0) +#endif + +#ifdef _WIN32 + +#define WIN32_LEAN_AND_MEAN +#include + +#define FILE_NOTIFY_BUFFER_LENGTH ((sizeof(DWORD) * 4) * 1000) + +struct events { + struct events* next; + char* path; + LPVOID buffer; +}; + +struct fsenv { + struct events* events; /* mutated from multiple threads */ + HANDLE completionPort; + HANDLE signal; + HANDLE thread; +}; + +struct watch { + struct watch* next; + char* path; + WCHAR* realpath; + HANDLE handle; + LPOVERLAPPED overlapped; + LPVOID buffer; +}; + +#define unix_error(s, err) \ + do { \ + caml_win32_maperr(err); \ + caml_uerror(s, Nothing); \ + } while (0) + +static void push_events(struct fsenv* fsenv, struct watch* w) { + struct events* e = malloc(sizeof(struct events)); + e->buffer = w->buffer; + e->path = _strdup(w->path); + w->buffer = NULL; + + /* Perform [e->next = fsenv->events; fsenv->events = e] atomically */ + do { + e->next = fsenv->events; + } while (InterlockedCompareExchangePointer(&(fsenv->events), e, e->next) != e->next); + + SetEvent(fsenv->signal); /* wakeup OCaml thread */ +} + +/* Retrieve the list of events from the shared list. */ +static struct events* pop_events(struct fsenv* fsenv) { + struct events* res; + + /* Perform [res = fsenv->events; fsenv->events = NULL] atomically */ + do { + res = fsenv->events; + } while (InterlockedCompareExchangePointer(&(fsenv->events), NULL, res) != res); + + return res; +} + +/* Same order as Event.action */ +static DWORD actions[] = { + FILE_ACTION_ADDED, + FILE_ACTION_REMOVED, + FILE_ACTION_MODIFIED, + FILE_ACTION_RENAMED_OLD_NAME, + FILE_ACTION_RENAMED_NEW_NAME, +}; + +static value Val_action(DWORD action) { + for (int tag = 0; tag < sizeof(actions) / sizeof(DWORD); tag ++) { + if (actions[tag] == action) + return Val_int(tag); + } + assert(0); + return Val_unit; /* unreachable */ +} + +/* Assumes [s] is NULL-terminated. */ +static WCHAR* utf8_to_utf16(const char* s) { + int buflen = MultiByteToWideChar(CP_UTF8, 0, s, -1, NULL, 0); + if (buflen == 0) { + DEBUG("MultiByteToWideChar: error %d", GetLastError()); + return NULL; + } + WCHAR* buf = malloc(buflen * sizeof(WCHAR)); + if (MultiByteToWideChar(CP_UTF8, 0, s, -1, buf, buflen) == 0) { + DEBUG("MultiByteToWideChar: error %d", GetLastError()); + free(buf); + return NULL; + } + return buf; +} + +/* Assumes [s] is *not* NULL-terminated. */ +static char* utf16_to_utf8(const WCHAR* s, int slen) { + int buflen = WideCharToMultiByte(CP_UTF8, 0, s, slen, NULL, 0, NULL, NULL); + if (buflen == 0) { + DEBUG("WideCharToMultiByte: error %d", GetLastError()); + return NULL; + } + char* buf = malloc(buflen + 1); + if (WideCharToMultiByte(CP_UTF8, 0, s, slen, buf, buflen, NULL, NULL) == 0) { + DEBUG("WideCharToMultiByte: error %d", GetLastError()); + free(buf); + return NULL; + } + buf[buflen] = 0; + return buf; +} + +static value parse_events(struct events* e) { + CAMLparam0(); + CAMLlocal5(res, cell, ev, v_path, v_filename); + + while (e != NULL) { + struct events* next = e->next; + PFILE_NOTIFY_INFORMATION info = e->buffer; + v_path = caml_copy_string(e->path); + + for (;;) { + char* filename = utf16_to_utf8(info->FileName, info->FileNameLength / sizeof(WCHAR)); + if (filename == NULL) { + DEBUG("%s: could not decode event", e->path); + break; /* skip this packet of events */ + } + v_filename = caml_copy_string(filename); + free(filename); + + /* Allocate Event.t */ + ev = caml_alloc_tuple(3); + Store_field(ev, 0, v_path); + Store_field(ev, 1, v_filename); + Store_field(ev, 2, Val_action(info->Action)); + + /* Allocate list cell */ + cell = caml_alloc_tuple(2); + Store_field(cell, 0, ev); + Store_field(cell, 1, res); + res = cell; + + if (info->NextEntryOffset == 0) + break; + + info = (PFILE_NOTIFY_INFORMATION)((char*)info + info->NextEntryOffset); + } + + free(e->buffer); + free(e->path); + free(e); + + e = next; + } + + CAMLreturn(res); +} + +static DWORD read_changes(struct watch *w) { + memset(w->overlapped, 0, sizeof(OVERLAPPED)); + if (w->buffer == NULL) w->buffer = malloc(FILE_NOTIFY_BUFFER_LENGTH); + BOOL res = + ReadDirectoryChangesW(w->handle, w->buffer, FILE_NOTIFY_BUFFER_LENGTH, TRUE, + FILE_NOTIFY_CHANGE_FILE_NAME | FILE_NOTIFY_CHANGE_DIR_NAME | FILE_NOTIFY_CHANGE_LAST_WRITE, + NULL, w->overlapped, NULL); + if (res == 0) DEBUG("ReadDirectoryChangesW: %s: error %d", w->path, GetLastError()); + return res; +} + +static void free_watch(struct watch* w) { + free(w->path); + free(w->realpath); + free(w->overlapped); + free(w->buffer); + if (w->handle != INVALID_HANDLE_VALUE) CloseHandle(w->handle); + free(w); +} + +static BOOL isprefix(WCHAR* prefix, WCHAR* s) { + for (int i = 0; prefix[i]; i ++) { + if (s[i] == 0 || prefix[i] != s[i]) + return FALSE; + } + return TRUE; +} + +static WCHAR* get_final_path(HANDLE handle) { + DWORD buflen = GetFinalPathNameByHandleW(handle, NULL, 0, 0); + if (buflen == 0) { + DEBUG("GetFinalPathNameByHandleW: error %d", GetLastError()); + return NULL; + } + WCHAR* buf = malloc(buflen * sizeof(WCHAR)); + if (GetFinalPathNameByHandleW(handle, buf, buflen, 0) == 0) { + DEBUG("GetFinalPathNameByHandleW: error %d", GetLastError()); + free(buf); + return NULL; + } + return buf; +} + +/* Takes owernship of [path]. Return NULL if the path is already being watched + or if an error occurs. */ +static struct watch* add_watch(struct fsenv* fsenv, char* path, struct watch** lst) { + DEBUG("adding: %s", path); + WCHAR* utf16path = utf8_to_utf16(path); + if (utf16path == NULL) { + free(path); + return NULL; + } + HANDLE handle = + CreateFileW(utf16path, FILE_LIST_DIRECTORY, FILE_SHARE_READ | FILE_SHARE_DELETE, + NULL, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OVERLAPPED, NULL); + free(utf16path); + if (handle == INVALID_HANDLE_VALUE) { + DEBUG("%s could not be opened: CreateFileW: error %d", path, GetLastError()); + free(path); + return NULL; + } + + struct watch* w = malloc(sizeof(struct watch)); + w->next = *lst; + w->path = path; + w->realpath = get_final_path(handle); + w->overlapped = malloc(sizeof(OVERLAPPED)); + w->handle = handle; + w->buffer = NULL; + + for (struct watch *p = *lst; p; p = p->next) { + if (isprefix(p->realpath, w->realpath)) { + DEBUG("%ls is already being watched, ignoring", w->realpath); + free_watch(w); + return NULL; + } + } + + if (CreateIoCompletionPort(handle, fsenv->completionPort, (ULONG_PTR)w, 1) == NULL) { + DEBUG("could not add %ls: CreateIoCompletionPort: error %d", w->realpath, GetLastError()); + free_watch(w); + return NULL; + } + + for (struct watch *p = *lst; p; p = p->next) { + if (isprefix(w->realpath, p->realpath)) { + DEBUG("%ls is included in %ls, removing", p->realpath, w->realpath); + CancelIo(p->handle); + CloseHandle(p->handle); + p->handle = INVALID_HANDLE_VALUE; + } + } + + *lst = w; + + return w; +} + +enum { + ADDWATCH = 1, + SHUTDOWN = 3 +}; + +static void remove_watch(struct watch* w, struct watch** lst) { + DEBUG("removing: %s", w->path); + if (*lst == w) { + *lst = w->next; + } else { + for (struct watch *p = *lst; p; p = p -> next) { + if (p->next == w) { + p->next = w->next; + break; + } + } + } + free_watch(w); +} + +static DWORD WINAPI watch_thread(struct fsenv* fsenv) { + struct watch* watches = NULL; + BOOL shuttingDown = FALSE; + + while (watches != NULL || !shuttingDown) { + LPVOID key; + DWORD numBytes; + LPOVERLAPPED overlapped; + + if (GetQueuedCompletionStatus(fsenv->completionPort, &numBytes, (PULONG_PTR)&key, &overlapped, INFINITE) == FALSE) { + DEBUG("GetQueuedCompletionStatus: error %d", GetLastError()); + if (overlapped == NULL) { + DEBUG("ignoring GetQueuedCompletionStatus error"); + } else { + remove_watch(key, &watches); + } + continue; + } + + if (numBytes > 0) { + if (shuttingDown) { + remove_watch(key, &watches); + } else { + push_events(fsenv, key); + if (read_changes(key) == 0) remove_watch(key, &watches); + } + } else if (overlapped == (LPOVERLAPPED)ADDWATCH) { + if (shuttingDown) { + DEBUG("add received for %s; ignoring due to shutdown", (char *)key); + free(key); /* ignore request */ + } else { + struct watch *w = add_watch(fsenv, key, &watches); + if (w != NULL && read_changes(w) == 0) remove_watch(w, &watches); + } + } else if (overlapped == (LPOVERLAPPED)SHUTDOWN) { + DEBUG("shutting down"); + shuttingDown = TRUE; + for (struct watch *p = watches; p; p = p->next) { + CancelIo(p->handle); + CloseHandle(p->handle); + p->handle = INVALID_HANDLE_VALUE; + } + } + } + + return 0; +} + +static struct custom_operations fsenv_ops = { + "fswatch_win.fsenv", + custom_finalize_default, + custom_compare_default, + custom_hash_default, + custom_serialize_default, + custom_deserialize_default, + custom_compare_ext_default, + custom_fixed_length_default +}; + +#define Fsenv_val(v) (*((struct fsenv**)Data_custom_val(v))) + +value fswatch_win_create(value v_unit) { + HANDLE completionPort = CreateIoCompletionPort(INVALID_HANDLE_VALUE, NULL, 0, 1); + if (completionPort == NULL) { + unix_error("CreateIoCompletionPort", GetLastError()); + } + + HANDLE signal = CreateEvent(NULL, FALSE, FALSE, NULL); + if (signal == NULL) { + DWORD err = GetLastError(); + CloseHandle(completionPort); + unix_error("CreateEvent", err); + } + + struct fsenv* fsenv = caml_stat_alloc(sizeof(struct fsenv)); + fsenv->events = NULL; + fsenv->completionPort = completionPort; + fsenv->signal = signal; + + HANDLE thread = CreateThread(NULL, 0, &watch_thread, fsenv, 0, NULL); + if (thread == NULL) { + DWORD err = GetLastError(); + caml_stat_free(fsenv); + CloseHandle(signal); + CloseHandle(completionPort); + unix_error("CreateThread", err); + } + fsenv->thread = thread; + + value v_fsenv = caml_alloc_custom(&fsenv_ops, sizeof(struct fsenv*), 0, 1); + Fsenv_val(v_fsenv) = fsenv; + + return v_fsenv; +} + +value fswatch_win_add(value v_fsenv, value v_path) { + struct fsenv* fsenv = Fsenv_val(v_fsenv); + + if (fsenv == NULL) + caml_invalid_argument("Fswatch_win.add: already shut down"); + + if (! caml_string_is_c_safe(v_path)) + caml_invalid_argument("Fswatch_win.add"); + + if (PostQueuedCompletionStatus(fsenv->completionPort, 0, (ULONG_PTR)_strdup(String_val(v_path)), (LPOVERLAPPED)ADDWATCH) == 0) { + unix_error("PostQueuedCompletionStatus", GetLastError()); + } + + return Val_unit; +} + +value fswatch_win_wait(value v_fsenv, value v_debounce) { + struct fsenv *fsenv = Fsenv_val(v_fsenv); + + if (fsenv == NULL) + caml_invalid_argument("Fswatch_win.wait: already shut down"); + + caml_release_runtime_system(); + + DWORD res = WaitForSingleObject(fsenv->signal, INFINITE); + if (res == WAIT_OBJECT_0 && Int_val(v_debounce) > 0) Sleep(Int_val(v_debounce)); + + caml_acquire_runtime_system(); + + if (res != WAIT_OBJECT_0) + unix_error("WaitForSingleObject", GetLastError()); + + struct events *e = pop_events(fsenv); + + if (ResetEvent(fsenv->signal) == 0) + unix_error("ResetEvent", GetLastError()); + + return parse_events(e); +} + +value fswatch_win_shutdown(value v_fsenv) { + struct fsenv *fsenv = Fsenv_val(v_fsenv); + + if (fsenv == NULL) + return Val_unit; + + Fsenv_val(v_fsenv) = NULL; + + if (PostQueuedCompletionStatus(fsenv->completionPort, 0, 0, (LPOVERLAPPED)SHUTDOWN) == 0) { + unix_error("PostQueuedCompletionStatus", GetLastError()); + } + + caml_release_runtime_system(); + + if (WaitForSingleObject(fsenv->thread, 2000) != WAIT_OBJECT_0) + DEBUG("thread did not terminate in time"); + + CloseHandle(fsenv->thread); + CloseHandle(fsenv->completionPort); + CloseHandle(fsenv->signal); + + for (struct events *e = pop_events(fsenv); e; e = e->next) { + free(e->path); + free(e->buffer); + free(e); + } + + caml_acquire_runtime_system(); + + caml_stat_free(fsenv); + + return Val_unit; +} + +#else + +value fswatch_win_create(value v_unit) { + caml_invalid_argument("fswatch_win_create: not implemented"); +} + +value fswatch_win_wait(value v_fsenv, value v_debounce) { + caml_invalid_argument("fswatch_win_wait: not implemented"); +} + +value fswatch_win_add(value v_fsenv, value v_path) { + caml_invalid_argument("fswatch_win_add: not implemented"); +} + +value fswatch_win_shutdown(value v_fsenv) { + caml_invalid_argument("fswatch_win_shutdown: not implemented"); +} + +#endif diff --git a/test/unit-tests/fswatch_win/dune b/test/unit-tests/fswatch_win/dune new file mode 100644 index 00000000000..8f31633fa1a --- /dev/null +++ b/test/unit-tests/fswatch_win/dune @@ -0,0 +1,10 @@ +(executable + (name fswatch_win_tests) + (libraries fswatch_win stdune)) + +(rule + (alias fswatch_win_tests) + (deps + (sandbox always)) + (action + (run ./fswatch_win_tests.exe))) diff --git a/test/unit-tests/fswatch_win/fswatch_win_tests.ml b/test/unit-tests/fswatch_win/fswatch_win_tests.ml new file mode 100644 index 00000000000..6eb572053ea --- /dev/null +++ b/test/unit-tests/fswatch_win/fswatch_win_tests.ml @@ -0,0 +1,287 @@ +open Stdune + +let remove_dot_slash s = + String.drop_prefix s ~prefix:".\\" |> Option.value ~default:s + +let create_file fn = Io.String_path.write_file fn "" + +let mkdir fn = Unix.mkdir fn 0o777 + +type event = + { action : string + ; path : string + } + +let dyn_of_event ev = + let action = + match Fswatch_win.Event.action ev with + | Added -> "added" + | Removed -> "removed" + | Modified -> "modified" + | Renamed_old -> "renamed_old" + | Renamed_new -> "renamed_new" + in + let path = remove_dot_slash (Fswatch_win.Event.path ev) in + Dyn.record [ ("action", Dyn.string action); ("path", Dyn.string path) ] + +let dyn_of_event' { action; path } = + let path = remove_dot_slash path in + Dyn.record [ ("action", Dyn.string action); ("path", Dyn.string path) ] + +let print_events events = print_endline (Dyn.to_string (Dyn.list Fun.id events)) + +let markdir = Filename.concat (Sys.getcwd ()) "mark" + +let beginning_of_test = "BEGINNING_OF_TEST" + +let end_of_test = "END_OF_TEST" + +let watch, collect_events = + (* File used to mark the beginning and end of tests. *) + mkdir markdir; + let beginning_of_test_file = Filename.concat markdir beginning_of_test in + let end_of_test_file = Filename.concat markdir end_of_test in + create_file beginning_of_test_file; + create_file end_of_test_file; + let fswatch = Fswatch_win.create ~debounce_interval:0 in + let watch dir = Fswatch_win.add fswatch dir in + watch markdir; + let rec collect_events acc = function + | [] -> + let events = Fswatch_win.wait fswatch in + collect_events acc events + | e :: events when Fswatch_win.Event.path e = end_of_test -> + if not (List.is_empty events) then ( + Printf.printf + "***** Leftover events after end of test marker event *****\n"; + print_events (List.map ~f:dyn_of_event events)); + List.rev_map ~f:dyn_of_event acc + | ev :: events -> collect_events (ev :: acc) events + in + let collect_events () = + (* Mark the beginning of the current test *) + create_file end_of_test_file; + let events = + let events = Fswatch_win.wait fswatch in + (* List.iter ~f:(fun ev -> print_endline (Dyn.to_string (Fswatch_win.Event.to_dyn ev))) events; *) + match events with + | [] -> assert false + | e :: events when Fswatch_win.Event.path e = beginning_of_test -> + collect_events [] events + | events -> + Printf.printf + "***** First event is not the beginning of test marker *****\n"; + collect_events [] events + in + (* Mark the beginning of the next test *) + create_file beginning_of_test_file; + events + in + create_file beginning_of_test_file; + (watch, collect_events) + +(* Run a function in a sub-directory *) +let in_sub_dir = + let n = ref 0 in + fun f -> + incr n; + let dir = Printf.sprintf "test%d" !n in + mkdir dir; + Sys.chdir dir; + Exn.protect ~finally:(fun () -> Sys.chdir "..") ~f + +let check_events ~real_events expected_events = + let expected_events = List.map ~f:dyn_of_event' expected_events in + if real_events = expected_events then () + else ( + print_endline "** FAILURE **"; + print_endline "ACTUAL:"; + print_events real_events; + print_endline "EXPECTED:"; + print_events expected_events; + exit 1) + +let _ = + in_sub_dir @@ fun () -> + let fn = "file" in + create_file fn; + watch "."; + create_file fn; + check_events ~real_events:(collect_events ()) + [ { action = "modified"; path = fn } ] + +let fold_int n ~init ~f = + let rec loop i acc = if i = n then acc else loop (i + 1) (f i acc) in + loop 0 init + +type kind = + | File + | Dir + +let rec gen_tree acc ~dir ~depth ~files_per_dir ~sub_dirs_per_dir = + let acc = + fold_int files_per_dir ~init:acc ~f:(fun n acc -> + let fn = Filename.concat dir (Printf.sprintf "f%d" (n + 1)) in + create_file fn; + (File, fn) :: acc) + in + if depth = 0 then acc + else + fold_int sub_dirs_per_dir ~init:acc ~f:(fun n acc -> + let dir = Filename.concat dir (Printf.sprintf "d%d" (n + 1)) in + let acc = (Dir, dir) :: acc in + mkdir dir; + gen_tree acc ~dir ~depth:(depth - 1) ~files_per_dir ~sub_dirs_per_dir) + +let gen_tree ~depth ~files_per_dir ~sub_dirs_per_dir = + List.rev + (gen_tree [ (Dir, ".") ] ~dir:"." ~depth ~files_per_dir ~sub_dirs_per_dir) + +let _ = + (* Show that gen_tree generates filenames in the right order *) + in_sub_dir @@ fun () -> + let entries = + List.map + (gen_tree ~depth:1 ~files_per_dir:2 ~sub_dirs_per_dir:2) + ~f:Stdlib.snd + in + (* List.iter ~f:print_endline entries; *) + assert ( + List.map ~f:remove_dot_slash entries + = [ "."; "f1"; "f2"; "d1"; "d1\\f1"; "d1\\f2"; "d2"; "d2\\f1"; "d2\\f2" ]) + +(* Return the expected set of inotify events *) +let gen_changes files = + List.iter files ~f:(function + | Dir, fn -> + let new_file = Filename.concat fn "new-file" in + let new_dir = Filename.concat fn "new-dir" in + create_file new_file; + mkdir new_dir; + Unix.rmdir new_dir; + Sys.remove new_file + | File, fn -> create_file fn) + +let setup1 ~depth ~files_per_dir ~sub_dirs_per_dir = + let files = gen_tree ~depth ~files_per_dir ~sub_dirs_per_dir in + watch "."; + (files, collect_events) + +let _ = + (* Check that FS events are reported chronologically *) + in_sub_dir @@ fun () -> + let files, collect_events = + setup1 ~depth:2 ~files_per_dir:3 ~sub_dirs_per_dir:2 + in + gen_changes files; + check_events ~real_events:(collect_events ()) + [ { action = "added"; path = "new-file" } + ; { action = "added"; path = "new-dir" } + ; { action = "removed"; path = "new-dir" } + ; { action = "removed"; path = "new-file" } + ; { action = "modified"; path = "f1" } + ; { action = "modified"; path = "f2" } + ; { action = "modified"; path = "f3" } + ; { action = "added"; path = "d1\\new-file" } + ; { action = "added"; path = "d1\\new-dir" } + ; { action = "removed"; path = "d1\\new-dir" } + ; { action = "removed"; path = "d1\\new-file" } + ; { action = "modified"; path = "d1\\f1" } + ; { action = "modified"; path = "d1\\f2" } + ; { action = "modified"; path = "d1\\f3" } + ; { action = "added"; path = "d1\\d1\\new-file" } + ; { action = "added"; path = "d1\\d1\\new-dir" } + ; { action = "removed"; path = "d1\\d1\\new-dir" } + ; { action = "removed"; path = "d1\\d1\\new-file" } + ; { action = "modified"; path = "d1\\d1\\f1" } + ; { action = "modified"; path = "d1\\d1\\f2" } + ; { action = "modified"; path = "d1\\d1\\f3" } + ; { action = "added"; path = "d1\\d2\\new-file" } + ; { action = "added"; path = "d1\\d2\\new-dir" } + ; { action = "removed"; path = "d1\\d2\\new-dir" } + ; { action = "removed"; path = "d1\\d2\\new-file" } + ; { action = "modified"; path = "d1\\d2\\f1" } + ; { action = "modified"; path = "d1\\d2\\f2" } + ; { action = "modified"; path = "d1\\d2\\f3" } + ; { action = "added"; path = "d2\\new-file" } + ; { action = "added"; path = "d2\\new-dir" } + ; { action = "removed"; path = "d2\\new-dir" } + ; { action = "removed"; path = "d2\\new-file" } + ; { action = "modified"; path = "d2\\f1" } + ; { action = "modified"; path = "d2\\f2" } + ; { action = "modified"; path = "d2\\f3" } + ; { action = "added"; path = "d2\\d1\\new-file" } + ; { action = "added"; path = "d2\\d1\\new-dir" } + ; { action = "removed"; path = "d2\\d1\\new-dir" } + ; { action = "removed"; path = "d2\\d1\\new-file" } + ; { action = "modified"; path = "d2\\d1\\f1" } + ; { action = "modified"; path = "d2\\d1\\f2" } + ; { action = "modified"; path = "d2\\d1\\f3" } + ; { action = "added"; path = "d2\\d2\\new-file" } + ; { action = "added"; path = "d2\\d2\\new-dir" } + ; { action = "removed"; path = "d2\\d2\\new-dir" } + ; { action = "removed"; path = "d2\\d2\\new-file" } + ; { action = "modified"; path = "d2\\d2\\f1" } + ; { action = "modified"; path = "d2\\d2\\f2" } + ; { action = "modified"; path = "d2\\d2\\f3" } + ] + +(* Check interleaving more specifically *) +let _ = + in_sub_dir @@ fun () -> + mkdir "a"; + mkdir "b"; + watch "."; + create_file "a\\x"; + create_file "b\\x"; + create_file "a\\y"; + check_events ~real_events:(collect_events ()) + [ { action = "added"; path = "a\\x" } + ; { action = "added"; path = "b\\x" } + ; { action = "added"; path = "a\\y" } + ] + +let run cmd = + match + snd + (Unix.waitpid [] + (Unix.create_process (List.hd cmd) (Array.of_list cmd) Unix.stdin + Unix.stdout Unix.stderr)) + with + | WEXITED 0 -> () + | _ -> assert false + +(* Check that ordering is respected when the changes are made by an external + process. Which is the assumption we are making for the fs sync mechanism of + the file watcher. *) +let _ = + in_sub_dir @@ fun () -> + mkdir "_build"; + mkdir "_build\\.sync"; + watch "."; + let actions = + [ `Me; `Ext; `Me; `Ext; `Ext ] + |> List.mapi ~f:(fun i who -> (string_of_int i, who)) + in + let actions = actions @ [ ("_build\\.sync\\1", `Me) ] in + let do_actions () = + List.iter actions ~f:(fun (fn, who) -> + match who with + | `Me -> create_file fn + | `Ext -> run [ "touch"; fn ]) + in + do_actions (); + let real_events = collect_events () in + let expected_events = + [ { action = "added"; path = "0" } + ; { action = "added"; path = "1" } + ; { action = "modified"; path = "1" } + ; { action = "added"; path = "2" } + ; { action = "added"; path = "3" } + ; { action = "modified"; path = "3" } + ; { action = "added"; path = "4" } + ; { action = "modified"; path = "4" } + ; { action = "added"; path = "_build\\.sync\\1" } + ] + in + check_events ~real_events expected_events diff --git a/test/unit-tests/fswatch_win/fswatch_win_tests.mli b/test/unit-tests/fswatch_win/fswatch_win_tests.mli new file mode 100644 index 00000000000..e69de29bb2d