diff --git a/src/dune_engine/fs_memo.ml b/src/dune_engine/fs_memo.ml index 52e3134e9501..4e758ccab1d4 100644 --- a/src/dune_engine/fs_memo.ml +++ b/src/dune_engine/fs_memo.ml @@ -31,8 +31,9 @@ let t_ref = ref (Initialization_state.Uninitialized []) root is not sufficient to receive events for creation of "root/a/b/c/d". (however, subscribing to "root/a/b/c" is sufficient for that) *) let watch_path dune_file_watcher path = - try Dune_file_watcher.add_watch dune_file_watcher path with - | Unix.Unix_error (ENOENT, _, _) -> ( + match Dune_file_watcher.add_watch dune_file_watcher path with + | Ok () -> () + | Error `Does_not_exist -> ( (* If we're at the root of the workspace (or the unix root) then we can't get ENOENT because dune can't start without a workspace and unix root always exists, so this [_exn] can't raise (except if the user delets the @@ -42,9 +43,17 @@ let watch_path dune_file_watcher path = the parent. We still try to add a watch for the file itself after that succeeds, in case the file was created already before we started watching its parent. *) - Dune_file_watcher.add_watch dune_file_watcher containing_dir; - try Dune_file_watcher.add_watch dune_file_watcher path with - | Unix.Unix_error (ENOENT, _, _) -> ()) + (match Dune_file_watcher.add_watch dune_file_watcher containing_dir with + | Ok () -> () + | Error `Does_not_exist -> + Log.info + [ Pp.textf "attempted to add watch to non-existant directory %s" + (Path.to_string containing_dir) + ]); + match Dune_file_watcher.add_watch dune_file_watcher path with + | Error `Does_not_exist + | Ok () -> + ()) let watch_path_using_ref path = match !t_ref with diff --git a/src/dune_file_watcher/dune_file_watcher.ml b/src/dune_file_watcher/dune_file_watcher.ml index c8a1276e39d2..80b9998e4f46 100644 --- a/src/dune_file_watcher/dune_file_watcher.ml +++ b/src/dune_file_watcher/dune_file_watcher.ml @@ -20,28 +20,6 @@ let decompose_inotify_event (event : Inotify_lib.Event.t) = let inotify_event_paths event = List.map ~f:fst (decompose_inotify_event event) -type kind = - | Fswatch of - { pid : Pid.t - ; wait_for_watches_established : unit -> unit - } - | Fsevents of Fsevents.t - | Inotify of Inotify_lib.t - -type t = - { kind : kind - (* CR-someday amokhov: The way we handle "ignored files" using this - mutable table is fragile and also wrong. We use [ignored_files] for - the [(mode promote)] feature: if a file is promoted, we call - [ignore_next_file_change_event] so that the upcoming file-change - event does not invalidate the current build. However, instead of - ignoring the events, we should merely postpone them and restart the - build to take the promoted files into account if need be. *) - (* The [ignored_files] table should be accessed in the scheduler - thread. *) - ; ignored_files : (string, unit) Table.t - } - module Fs_memo_event = struct type kind = | Created @@ -80,6 +58,115 @@ module Event = struct | Watcher_terminated end +module Scheduler = struct + type t = + { spawn_thread : (unit -> unit) -> unit + ; thread_safe_send_emit_events_job : (unit -> Event.t list) -> unit + } +end + +module Watch_trie : sig + (** Specialized trie for fsevent watches *) + type 'a t + + val empty : 'a t + + val to_list : 'a t -> (Path.External.t * 'a) list + + type 'a add = + | Under_existing_node + | Inserted of + { new_t : 'a t + ; removed : (Path.External.t * 'a) list + } + + val add : 'a t -> Path.External.t -> 'a Lazy.t -> 'a add +end = struct + (* the invariant is that a node can contain either a value or branches, but + not both *) + type 'a t = + | Leaf of Path.External.t * 'a + | Branch of 'a t String.Map.t + + type 'a add = + | Under_existing_node + | Inserted of + { new_t : 'a t + ; removed : (Path.External.t * 'a) list + } + + let empty = Branch String.Map.empty + + let to_list t = + let rec loop t acc = + match t with + | Leaf (k, v) -> (k, v) :: acc + | Branch m -> String.Map.fold m ~init:acc ~f:loop + in + loop t [] + + let rec path p a = function + | [] -> Leaf (p, a) + | x :: xs -> Branch (String.Map.singleton x (path p a xs)) + + let add t key v = + (* wrong in general, but this is only needed for fsevents *) + let comps = + match String.split ~on:'/' (Path.External.to_string key) with + | "" :: comps -> comps + | _ -> + (* fsevents gives us only absolute paths *) + assert false + in + let rec add comps t = + match (comps, t) with + | _, Leaf (_, _) -> Under_existing_node + | [], Branch _ -> + Inserted { new_t = Leaf (key, Lazy.force v); removed = to_list t } + | x :: xs, Branch m -> ( + match String.Map.find m x with + | None -> + Inserted + { new_t = Branch (String.Map.set m x (path key (Lazy.force v) xs)) + ; removed = [] + } + | Some m' -> ( + match add xs m' with + | Under_existing_node -> Under_existing_node + | Inserted i -> + Inserted { i with new_t = Branch (String.Map.set m x i.new_t) })) + in + add comps t +end + +type kind = + | Fswatch of + { pid : Pid.t + ; wait_for_watches_established : unit -> unit + } + | Fsevents of + { mutable external_ : Fsevents.t Watch_trie.t + ; runloop : Fsevents.RunLoop.t + ; scheduler : Scheduler.t + ; source : Fsevents.t + ; sync : Fsevents.t + } + | Inotify of Inotify_lib.t + +type t = + { kind : kind + (* CR-someday amokhov: The way we handle "ignored files" using this + mutable table is fragile and also wrong. We use [ignored_files] for + the [(mode promote)] feature: if a file is promoted, we call + [ignore_next_file_change_event] so that the upcoming file-change + event does not invalidate the current build. However, instead of + ignoring the events, we should merely postpone them and restart the + build to take the promoted files into account if need be. *) + (* The [ignored_files] table should be accessed in the scheduler + thread. *) + ; ignored_files : (string, unit) Table.t + } + let exclude_patterns = [ {|/_opam|} ; {|/_esy|} @@ -157,13 +244,6 @@ let process_inotify_event ~ignored_files ]) | Queue_overflow -> [ Event.Queue_overflow ] -module Scheduler = struct - type t = - { spawn_thread : (unit -> unit) -> unit - ; thread_safe_send_emit_events_job : (unit -> Event.t list) -> unit - } -end - let shutdown t = match t.kind with | Fswatch { pid; _ } -> `Kill pid @@ -171,8 +251,11 @@ let shutdown t = | Fsevents fsevents -> `Thunk (fun () -> - List.iter [ Fsevents.stop; Fsevents.break; Fsevents.destroy ] - ~f:(fun f -> f fsevents)) + Fsevents.stop fsevents.source; + Fsevents.stop fsevents.sync; + Watch_trie.to_list fsevents.external_ + |> List.iter ~f:(fun (_, fs) -> Fsevents.stop fs); + Fsevents.RunLoop.stop fsevents.runloop) let buffer_capacity = 65536 @@ -216,13 +299,16 @@ module Buffer = struct List.rev !lines) end -let special_file_for_inotify_sync = - let path = lazy (Path.Build.relative Path.Build.root "dune-inotify-sync") in +let special_file_for_fs_sync = + let path = + lazy + (let dir = Path.Build.relative Path.Build.root ".sync" in + Path.Build.relative dir "token") + in fun () -> Lazy.force path let special_file_for_inotify_sync_absolute = - lazy - (Path.to_absolute_filename (Path.build (special_file_for_inotify_sync ()))) + lazy (Path.to_absolute_filename (Path.build (special_file_for_fs_sync ()))) let is_special_file_for_inotify_sync (path : Path.t) = match path with @@ -231,7 +317,7 @@ let is_special_file_for_inotify_sync (path : Path.t) = String.equal (Path.to_string path) (Lazy.force special_file_for_inotify_sync_absolute) | In_build_dir build_path -> - Path.Build.( = ) build_path (special_file_for_inotify_sync ()) + Path.Build.( = ) build_path (special_file_for_fs_sync ()) let command ~root ~backend = let exclude_paths = @@ -246,7 +332,7 @@ let command ~root ~backend = in let root = Path.to_string root in let inotify_special_path = - Path.Build.to_string (special_file_for_inotify_sync ()) + Path.Build.to_string (special_file_for_fs_sync ()) in match backend with | `Fswatch fswatch -> @@ -298,10 +384,12 @@ let select_watcher_backend () = fswatch_backend () let emit_sync () = - Io.write_file (Path.build (special_file_for_inotify_sync ())) "z" + let path = Path.build (special_file_for_fs_sync ()) in + Io.write_file path "z" let prepare_sync () = - Path.mkdir_p (Path.parent_exn (Path.build (special_file_for_inotify_sync ()))); + let dir = Path.parent_exn (Path.build (special_file_for_fs_sync ())) in + Path.mkdir_p dir; emit_sync () let spawn_external_watcher ~root ~backend = @@ -317,7 +405,7 @@ let spawn_external_watcher ~root ~backend = ((r_stdout, parse_line, wait), pid) let create_inotifylib_watcher ~ignored_files ~(scheduler : Scheduler.t) = - let special_file_for_inotify_sync = special_file_for_inotify_sync () in + let special_file_for_inotify_sync = special_file_for_fs_sync () in Inotify_lib.create ~spawn_thread:scheduler.spawn_thread ~modify_event_selector:`Closed_writable_fd ~send_emit_events_job_to_scheduler:(fun f -> @@ -418,61 +506,106 @@ let create_inotifylib ~scheduler = let ignored_files = Table.create (module String) 64 in let inotify = create_inotifylib_watcher ~ignored_files ~scheduler in Inotify_lib.add inotify - (Path.to_string (Path.build (special_file_for_inotify_sync ()))); + (Path.to_string (Path.build (special_file_for_fs_sync ()))); { kind = Inotify inotify; ignored_files } +let fsevents_callback (scheduler : Scheduler.t) ~f events = + scheduler.thread_safe_send_emit_events_job (fun () -> + List.filter_map events ~f:(fun event -> + let path = + Fsevents.Event.path event |> Path.of_string + |> Path.Expert.try_localize_external + in + f event path)) + +let fsevents ?exclusion_paths ~paths scheduler f = + let paths = List.map paths ~f:Path.to_absolute_filename in + let fsevents = + Fsevents.create ~latency:0.2 ~paths ~f:(fsevents_callback scheduler ~f) + in + Option.iter exclusion_paths ~f:(fun paths -> + Fsevents.set_exclusion_paths fsevents ~paths); + fsevents + +let fsevents_standard_event event ~ignored_files path = + let string_path = Fsevents.Event.path event in + if Table.mem ignored_files string_path then ( + Table.remove ignored_files string_path; + None + ) else + let action = Fsevents.Event.action event in + let kind = + match action with + | Unknown -> Fs_memo_event.Unknown + | Create -> Created + | Remove -> Deleted + | Modify -> + if Fsevents.Event.kind event = File then + File_changed + else + Unknown + in + Some (Event.Fs_memo_event { Fs_memo_event.kind; path }) + let create_fsevents ~(scheduler : Scheduler.t) = + prepare_sync (); let ignored_files = Table.create (module String) 64 in - let fsevents = - let paths = [ Path.to_string Path.root ] in - Fsevents.create ~paths ~latency:0.2 ~f:(fun _ events -> - scheduler.thread_safe_send_emit_events_job (fun () -> - List.filter_map events ~f:(fun event -> - let path = - Fsevents.Event.path event |> Path.of_string - |> Path.Expert.try_localize_external - in - let action = Fsevents.Event.action event in - if is_special_file_for_inotify_sync path then - match action with - | Unknown - | Create - | Modify -> - Some Event.Sync - | Remove -> None - else if Path.is_in_build_dir path then - (* we cannot ignore the build dir by setting the exclusion - path because we'd miss the sync events *) - None - else - let kind = - match action with - | Unknown -> Fs_memo_event.Unknown - | Create -> Created - | Remove -> Deleted - | Modify -> - if Fsevents.Event.kind event = File then - File_changed - else - Unknown - in - Some (Event.Fs_memo_event { Fs_memo_event.kind; path })))) + let sync = + fsevents scheduler + ~paths: + [ special_file_for_fs_sync () |> Path.Build.parent_exn |> Path.build ] + (fun event path -> + let action = Fsevents.Event.action event in + if is_special_file_for_inotify_sync path then + match action with + | Unknown + | Create + | Modify -> + Some Event.Sync + | Remove -> None + else + None) + in + let source = + let paths = [ Path.root ] in + let exclusion_paths = + Path.(build Build.root) + :: ([ "_esy"; "_opam"; ".git"; ".hg" ] + |> List.rev_map ~f:(fun base -> + let path = Path.relative (Path.source Path.Source.root) base in + path)) + |> List.rev_map ~f:Path.to_absolute_filename + in + fsevents scheduler ~exclusion_paths ~paths + (fsevents_standard_event ~ignored_files) in + let cv = Condition.create () in + let runloop_ref = ref None in + let mutex = Mutex.create () in scheduler.spawn_thread (fun () -> - Fsevents.start fsevents; - match Fsevents.loop fsevents with + let runloop = Fsevents.RunLoop.in_current_thread () in + Mutex.lock mutex; + runloop_ref := Some runloop; + Condition.signal cv; + Mutex.unlock mutex; + Fsevents.start source runloop; + Fsevents.start sync runloop; + match Fsevents.RunLoop.run_current_thread runloop with | Ok () -> () | Error exn -> Code_error.raise "fsevents callback raised" [ ("exn", Exn.to_dyn exn) ]); - Fsevents.set_exclusion_paths fsevents - ~paths: - ((* For now, we don't ignore the build directroy because we want to - receive events from the special event sync event *) - [ "_esy"; "_opam"; ".git"; ".hg" ] - |> List.rev_map ~f:(fun base -> - let path = Path.relative (Path.source Path.Source.root) base in - Path.to_absolute_filename path)); - { kind = Fsevents fsevents; ignored_files } + let external_ = Watch_trie.empty in + let runloop = + Mutex.lock mutex; + while !runloop_ref = None do + Condition.wait cv mutex + done; + Mutex.unlock mutex; + Option.value_exn !runloop_ref + in + { kind = Fsevents { scheduler; sync; source; external_; runloop } + ; ignored_files + } let create_external ~root ~debounce_interval ~scheduler ~backend = match debounce_interval with @@ -501,13 +634,51 @@ let wait_for_initial_watches_established_blocking t = let add_watch t path = match t.kind with - | Fsevents _ + | Fsevents f -> ( + match path with + | Path.In_source_tree _ -> (* already watched by source watcher *) Ok () + | 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 + | None -> Ok () + | Some ext -> ( + let watch = + lazy + (fsevents f.scheduler ~paths:[ path ] + (fsevents_standard_event ~ignored_files:t.ignored_files)) + in + match Watch_trie.add f.external_ ext watch with + | Watch_trie.Under_existing_node -> Ok () + | Inserted { new_t; removed } -> + let watch = Lazy.force watch in + Fsevents.start watch f.runloop; + List.iter removed ~f:(fun (_, fs) -> Fsevents.stop fs); + f.external_ <- new_t; + Ok ()))) | Fswatch _ -> (* Here we assume that the path is already being watched because the coarse file watchers are expected to watch all the source files from the start *) - () - | Inotify inotify -> Inotify_lib.add inotify (Path.to_string path) + Ok () + | Inotify inotify -> ( + try Ok (Inotify_lib.add inotify (Path.to_string path)) with + | Unix.Unix_error (ENOENT, _, _) -> Error `Does_not_exist) let ignore_next_file_change_event t path = assert (Path.is_in_source_tree path); diff --git a/src/dune_file_watcher/dune_file_watcher.mli b/src/dune_file_watcher/dune_file_watcher.mli index 43f4f360a00e..b07fecd17af0 100644 --- a/src/dune_file_watcher/dune_file_watcher.mli +++ b/src/dune_file_watcher/dune_file_watcher.mli @@ -72,7 +72,7 @@ val wait_for_initial_watches_established_blocking : t -> unit far. *) val emit_sync : unit -> unit -val add_watch : t -> Path.t -> unit +val add_watch : t -> Path.t -> (unit, [ `Does_not_exist ]) result (** Ignore the ne next file change event about this file. *) val ignore_next_file_change_event : t -> Path.t -> unit diff --git a/src/fsevents/bin/dune_fsevents.ml b/src/fsevents/bin/dune_fsevents.ml index 500a01a20e66..1276f7d160f7 100644 --- a/src/fsevents/bin/dune_fsevents.ml +++ b/src/fsevents/bin/dune_fsevents.ml @@ -8,8 +8,13 @@ let paths, latency = (!paths, !latency) let fsevents = - Fsevents.create ~paths ~latency ~f:(fun _ events -> + 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 +let () = + let runloop = Fsevents.RunLoop.in_current_thread () in + Fsevents.start fsevents runloop; + match Fsevents.RunLoop.run_current_thread runloop with + | Ok () -> () + | Error e -> raise e diff --git a/src/fsevents/dune b/src/fsevents/dune index 9f564ab99102..0fa17a85f910 100644 --- a/src/fsevents/dune +++ b/src/fsevents/dune @@ -6,4 +6,4 @@ (foreign_stubs (language c) (names fsevents_stubs)) - (libraries dyn stdune)) + (libraries dyn threads.posix stdune)) diff --git a/src/fsevents/fsevents.ml b/src/fsevents/fsevents.ml index 502a48e9f052..e03d51e9272f 100644 --- a/src/fsevents/fsevents.ml +++ b/src/fsevents/fsevents.ml @@ -1,5 +1,84 @@ open Stdune +external available : unit -> bool = "dune_fsevents_available" + +module State : sig + type 'a t + + val create : 'a -> 'a t + + type 'a ref + + val get : 'a ref -> 'a + + val set : 'a ref -> 'a -> unit + + val critical_section : 'a t -> ('a ref -> 'b) -> 'b +end = struct + type 'a t = + { mutex : Mutex.t + ; mutable data : 'a + } + + type 'a ref = 'a t + + let set t a = t.data <- a + + let get t = t.data + + let create data = { mutex = Mutex.create (); data } + + let critical_section (type a) (t : a t) f = + Mutex.lock t.mutex; + Fun.protect (fun () -> f t) ~finally:(fun () -> Mutex.unlock t.mutex) +end + +module RunLoop = struct + module Raw = struct + type t + + external in_current_thread : unit -> t = "dune_fsevents_runloop_current" + + (* After this function terminates, the reference to [t] is no longer + valid *) + external run_current_thread : t -> unit = "dune_fsevents_runloop_run" + + external stop : t -> unit = "dune_fsevents_runloop_stop" + end + + type state = + | Idle of Raw.t + | Running of Raw.t + | Stopped + + type t = state State.t + + let in_current_thread () = State.create (Idle (Raw.in_current_thread ())) + + let stop (t : t) = + State.critical_section t (fun t -> + match State.get t with + | Running raw -> + State.set t Stopped; + Raw.stop raw + | Stopped -> () + | Idle _ -> Code_error.raise "RunLoop.stop: not started" []) + + let run_current_thread t = + let w = + State.critical_section t (fun t -> + match State.get t with + | Stopped -> Code_error.raise "RunLoop.run_current_thread: stopped" [] + | Running _ -> + Code_error.raise "RunLoop.run_current_thread: running" [] + | Idle w -> + State.set t (Running w); + w) + in + try Ok (Raw.run_current_thread w) with + | exn -> Error exn +end + module Event = struct module Id = struct type t @@ -144,48 +223,89 @@ module Event = struct ] end -type t - -external available : unit -> bool = "dune_fsevents_available" - -external stop : t -> unit = "dune_fsevents_stop" +module Raw = struct + type t -external start : t -> unit = "dune_fsevents_start" + external stop : t -> unit = "dune_fsevents_stop" -external loop : t -> unit = "dune_fsevents_loop" + external start : t -> RunLoop.Raw.t -> unit = "dune_fsevents_start" -let loop t = - match loop t with - | exception exn -> Error exn - | () -> Ok () + external create : string list -> float -> (Event.t list -> unit) -> t + = "dune_fsevents_create" -external break : t -> unit = "dune_fsevents_break" + external set_exclusion_paths : t -> string list -> unit + = "dune_fsevents_set_exclusion_paths" -external flush_sync : t -> unit = "dune_fsevents_flush_sync" + external flush_sync : t -> unit = "dune_fsevents_flush_sync" -external destroy : t -> unit = "dune_fsevents_destroy" + (* external flush_async : t -> Event.Id.t = "dune_fsevents_flush_async" *) +end -external dune_fsevents_create : - string list -> float -> (t -> Event.t list -> unit) -> t - = "dune_fsevents_create" +type state = + | Idle of Raw.t + | Start of Raw.t * RunLoop.t + | Stop of RunLoop.t + +type t = state State.t + +let stop t = + State.critical_section t (fun t -> + match State.get t with + | Idle _ -> Code_error.raise "Fsevents.stop: idle" [] + | Stop _ -> () + | Start (raw, rl) -> + State.set t (Stop rl); + Raw.stop raw) + +let start t (rl : RunLoop.t) = + State.critical_section t (fun t -> + match State.get t with + | Stop _ -> Code_error.raise "Fsevents.start: stop" [] + | Start _ -> Code_error.raise "Fsevents.start: start" [] + | Idle r -> + State.critical_section rl (fun rl' -> + match State.get rl' with + | Stopped -> Code_error.raise "Fsevents.start: runloop stopped" [] + | Idle rl' + | Running rl' -> + State.set t (Start (r, rl)); + Raw.start r rl')) + +let runloop t = + State.critical_section t (fun t -> + match State.get t with + | Idle _ -> None + | Start (_, rl) + | Stop rl -> + Some rl) + +let flush_sync t = + let t = + State.critical_section t (fun t -> + match State.get t with + | Idle _ -> Code_error.raise "Fsevents.flush_sync: idle" [] + | Stop _ -> Code_error.raise "Fsevents.flush_sync: stop" [] + | Start (r, _) -> r) + in + Raw.flush_sync t 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" + State.create (Idle (Raw.create paths latency f)) 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 + State.critical_section t (fun t -> + match State.get t with + | Stop _ -> Code_error.raise "Fsevents.set_exclusion_paths: stop" [] + | Idle r + | Start (r, _) -> + Raw.set_exclusion_paths r paths) (* let flush_async t = *) (* let res = flush_async t in *) diff --git a/src/fsevents/fsevents.mli b/src/fsevents/fsevents.mli index 4f2f3a039066..3216e3cb3179 100644 --- a/src/fsevents/fsevents.mli +++ b/src/fsevents/fsevents.mli @@ -4,6 +4,16 @@ val available : unit -> bool +module RunLoop : sig + type t + + val in_current_thread : unit -> t + + val run_current_thread : t -> (unit, exn) result + + val stop : t -> unit +end + module Event : sig module Id : sig (** monotonically increasing id *) @@ -55,26 +65,18 @@ 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 +val create : paths:string list -> latency:float -> f:(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 +val start : t -> RunLoop.t -> unit + +val runloop : t -> RunLoop.t option (** [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. *) diff --git a/src/fsevents/fsevents_stubs.c b/src/fsevents/fsevents_stubs.c index cf7bf6c5e5ca..26ff0c6f9e53 100644 --- a/src/fsevents/fsevents_stubs.c +++ b/src/fsevents/fsevents_stubs.c @@ -9,13 +9,52 @@ #include #include +typedef struct dune_runloop { + CFRunLoopRef runloop; + value v_exn; +} dune_runloop; + typedef struct dune_fsevents_t { - CFRunLoopRef runLoop; + dune_runloop *runloop; value v_callback; FSEventStreamRef stream; value v_exn; } dune_fsevents_t; +CAMLprim value dune_fsevents_runloop_current(value v_unit) { + CAMLparam1(v_unit); + dune_runloop *rl; + rl = caml_stat_alloc(sizeof(dune_runloop)); + rl->runloop = CFRunLoopGetCurrent(); + rl->v_exn = Val_unit; + caml_register_global_root(&rl->v_exn); + CAMLreturn(caml_copy_nativeint((intnat)rl)); +} + +CAMLprim value dune_fsevents_runloop_run(value v_runloop) { + CAMLparam1(v_runloop); + CAMLlocal1(v_exn); + dune_runloop *runloop = (dune_runloop *)Nativeint_val(v_runloop); + caml_release_runtime_system(); + CFRunLoopRun(); + caml_acquire_runtime_system(); + caml_remove_global_root(&runloop->v_exn); + v_exn = runloop->v_exn; + caml_stat_free(runloop); + if (v_exn != Val_unit) + caml_raise(v_exn); + CAMLreturn(Val_unit); +} + +CAMLprim value dune_fsevents_runloop_stop(value v_runloop) { + CAMLparam1(v_runloop); + dune_runloop *runloop = (dune_runloop *)Nativeint_val(v_runloop); + caml_release_runtime_system(); + CFRunLoopStop(runloop->runloop); + caml_acquire_runtime_system(); + CAMLreturn(Val_unit); +} + static FSEventStreamEventFlags interesting_flags = kFSEventStreamEventFlagItemCreated | kFSEventStreamEventFlagItemRemoved | kFSEventStreamEventFlagItemRenamed | kFSEventStreamEventFlagItemModified | @@ -66,13 +105,10 @@ static void dune_fsevents_callback(const FSEventStreamRef streamRef, 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); + v_res = caml_callback_exn(t->v_callback, 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); + t->runloop->v_exn = Extract_exception(v_res); + CFRunLoopStop(t->runloop->runloop); } CAMLdrop; caml_release_runtime_system(); @@ -120,10 +156,8 @@ CAMLprim value dune_fsevents_create(value v_paths, value 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)); } @@ -143,54 +177,48 @@ CAMLprim value dune_fsevents_set_exclusion_paths(value v_t, value v_paths) { CAMLreturn(Val_unit); } -CAMLprim value dune_fsevents_start(value v_t) { - CAMLparam1(v_t); +CAMLprim value dune_fsevents_start(value v_t, value v_runloop) { + CAMLparam2(v_t, v_runloop); dune_fsevents_t *t = (dune_fsevents_t *)Nativeint_val(v_t); - CFRunLoopRef runLoop = CFRunLoopGetCurrent(); - t->runLoop = runLoop; - FSEventStreamScheduleWithRunLoop(t->stream, runLoop, kCFRunLoopDefaultMode); + dune_runloop *runloop = (dune_runloop *)Nativeint_val(v_runloop); + t->runloop = runloop; + FSEventStreamScheduleWithRunLoop(t->stream, runloop->runloop, + kCFRunLoopDefaultMode); bool res = FSEventStreamStart(t->stream); if (!res) { + /* the docs say this is impossible anyway */ caml_failwith("Fsevents.start: failed to start"); } CAMLreturn(Val_unit); } -CAMLprim value dune_fsevents_destroy(value v_t) { +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); + FSEventStreamInvalidate(t->stream); 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); +static inline value Val_some(value v) { + CAMLparam1(v); + CAMLlocal1(some); + some = caml_alloc_small(1, 0); + Field(some, 0) = v; + CAMLreturn(some); } -CAMLprim value dune_fsevents_break(value v_t) { +CAMLprim value dune_fsevents_runloop_get(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); + if (t->runloop == NULL) { + CAMLreturn(Val_int(0)); + } else { + CAMLreturn(Val_some(caml_copy_nativeint((intnat)t->runloop))); + } } CAMLprim value dune_fsevents_flush_async(value v_t) { @@ -350,6 +378,16 @@ CAMLprim value dune_fsevents_loop(value v_t) { caml_failwith("fsevents is only available on macos"); } +CAMLprim value dune_fsevents_runloop_current(value v_unit) { + caml_failwith("fsevents is only available on macos"); +} +CAMLprim value dune_fsevents_runloop_run(value v_unit) { + caml_failwith("fsevents is only available on macos"); +} +CAMLprim value dune_fsevents_runloop_stop(value v_runloop) { + caml_failwith("fsevents is only available on macos"); +} + CAMLprim value dune_fsevents_available(value unit) { CAMLparam1(unit); CAMLreturn(Val_false); diff --git a/test/expect-tests/dune_file_watcher/dune_file_watcher_tests_linux.ml b/test/expect-tests/dune_file_watcher/dune_file_watcher_tests_linux.ml index a56de9253c99..8f05cd40041c 100644 --- a/test/expect-tests/dune_file_watcher/dune_file_watcher_tests_linux.ml +++ b/test/expect-tests/dune_file_watcher/dune_file_watcher_tests_linux.ml @@ -36,7 +36,9 @@ let%expect_test _ = | Watcher_terminated -> assert false))) in let print_events n = print_events ~try_to_get_events ~expected:n in - Dune_file_watcher.add_watch watcher (Path.of_string "."); + (match Dune_file_watcher.add_watch watcher (Path.of_string ".") with + | Error _ -> assert false + | Ok () -> ()); Dune_file_watcher.wait_for_initial_watches_established_blocking watcher; Stdio.Out_channel.write_all "x" ~data:"x"; print_events 2; @@ -54,7 +56,9 @@ let%expect_test _ = { path = In_source_tree "y"; kind = "Created" } |}]; let (_ : _) = Fpath.mkdir_p "d/w" in - Dune_file_watcher.add_watch watcher (Path.of_string "d/w"); + (match Dune_file_watcher.add_watch watcher (Path.of_string "d/w") with + | Error _ -> assert false + | Ok () -> ()); Stdio.Out_channel.write_all "d/w/x" ~data:"x"; print_events 3; [%expect diff --git a/test/expect-tests/fsevents/fsevents_tests.ml b/test/expect-tests/fsevents/fsevents_tests.ml index d91fa5de67ee..32288f161917 100644 --- a/test/expect-tests/fsevents/fsevents_tests.ml +++ b/test/expect-tests/fsevents/fsevents_tests.ml @@ -13,9 +13,13 @@ let start_filename = ".dune_fsevents_start" let end_filename = ".dune_fsevents_end" -let emit_start () = Io.String_path.write_file start_filename "" +let emit_start dir = + ignore (Fpath.mkdir_p dir); + Io.String_path.write_file (Filename.concat dir start_filename) "" -let emit_end () = Io.String_path.write_file end_filename "" +let emit_end dir = + ignore (Fpath.mkdir_p dir); + Io.String_path.write_file (Filename.concat dir end_filename) "" let test f = let cv = Condition.create () in @@ -68,10 +72,11 @@ let print_event ~cwd e = in printfn "> %s" (Dyn.to_string dyn) -let make_callback ~f = +let make_callback t ~f = (* hack to skip the first event if it's creating the temp dir *) let state = ref `Looking_start in - fun t events -> + fun events -> + let t = Option.value_exn !t in let is_marker event filename = Event.kind event = File && Filename.basename (Event.path event) = filename @@ -80,7 +85,7 @@ let make_callback ~f = let stop = lazy (Fsevents.stop t; - Fsevents.break t) + Fsevents.RunLoop.stop (Option.value_exn (Fsevents.runloop t))) in let events = List.fold_left events ~init:[] ~f:(fun acc event -> @@ -101,50 +106,72 @@ let make_callback ~f = | [] -> () | _ -> 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. +type test_config = + { on_events : Event.t list -> unit + ; exclusion_paths : string list + ; dir : string + } -let test_with_operations ?on_event ?exclusion_paths f = +let default_test_config cwd = + { on_events = List.iter ~f:(print_event ~cwd) + ; dir = cwd + ; exclusion_paths = [] + } + +let test_with_multiple_fsevents ~setup ~test: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 configs = setup ~cwd (default_test_config cwd) in + let fsevents = + List.map configs ~f:(fun config -> + let t = ref None in + let res = + Fsevents.create ~paths:[ config.dir ] ~latency:0.0 + ~f:(make_callback t ~f:config.on_events) + in + t := Some res; + res) + in + let runloop = Fsevents.RunLoop.in_current_thread () in + List.iter fsevents ~f:(fun f -> Fsevents.start f runloop); let (_ : Thread.t) = Thread.create (fun () -> - emit_start (); + List.iter configs ~f:(fun config -> emit_start config.dir); f (); - emit_end ()) + List.iter configs ~f:(fun config -> emit_end config.dir)) () in - (match Fsevents.loop t with + (match Fsevents.RunLoop.run_current_thread runloop with | Error Exit -> print_endline "[EXIT]" | Error _ -> assert false | Ok () -> ()); - Fsevents.destroy t; + List.iter fsevents ~f:Fsevents.stop; finish ()) +let test_with_operations ?on_event ?exclusion_paths f = + test_with_multiple_fsevents ~test:f ~setup:(fun ~cwd config -> + let config = + match exclusion_paths with + | None -> config + | Some f -> { config with exclusion_paths = f cwd } + in + [ (match on_event with + | None -> config + | Some on_event -> { config with on_events = List.iter ~f:on_event }) + ]) + 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 () -> @@ -179,10 +206,30 @@ let%expect_test "set exclusion paths" = (* absolute paths work *) run Filename.concat; [%expect - {| > { action = "Create"; kind = "Dir"; path = "$TESTCASE_ROOT/ignored" } |}]; + {| + > { action = "Unknown"; kind = "File"; path = "$TESTCASE_ROOT/ignored/old" } + > { 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" } |}] + +let%expect_test "multiple fsevents" = + test_with_multiple_fsevents + ~setup:(fun ~cwd config -> + let create path = + let dir = Filename.concat cwd path in + ignore (Fpath.mkdir dir); + { config with dir } + in + [ create "foo"; create "bar" ]) + ~test:(fun () -> + Io.String_path.write_file "foo/file" ""; + Io.String_path.write_file "bar/file" ""; + Io.String_path.write_file "xxx" "" (* this one is ignored *)); + [%expect + {| + > { action = "Create"; kind = "File"; path = "$TESTCASE_ROOT/foo/file" } + > { action = "Create"; kind = "File"; path = "$TESTCASE_ROOT/bar/file" } |}] diff --git a/test/expect-tests/fsevents/fsevents_tests.mli b/test/expect-tests/fsevents/fsevents_tests.mli new file mode 100644 index 000000000000..e69de29bb2d1