From 7d5f6cde3c29b9421681d00de237c36a403e209e Mon Sep 17 00:00:00 2001 From: Arseniy Alekseyev Date: Wed, 23 Jun 2021 15:56:32 +0100 Subject: [PATCH] Use ocaml inotify (#4747) This PR makes dune use inotify library directly instead of relying on an external process (inotifywait). The reasons for this are: This removes one opaque indirection in reasoning about inotify semantics, putting it under our control. (inotify is already complicated, inotifywait adds its own quirks to the mix). It lets us express interest in a part of the workspace that we're working with. With inotifywait you have to subscribe to the entire workspace, which uses more inotify watches and requires a full workspace scan at startup to establish those watches. Signed-off-by: Arseniy Alekseyev --- bin/common.ml | 4 +- boot/libs.ml | 3 + otherlibs/stdune-unstable/monoid.ml | 2 + otherlibs/stdune-unstable/monoid.mli | 32 +- src/async_inotify_for_dune/async_inotify.ml | 202 ++++++++++ src/async_inotify_for_dune/async_inotify.mli | 71 ++++ .../async_inotify_for_dune.ml | 1 + src/async_inotify_for_dune/dune | 3 + src/dune_engine/dune | 4 +- src/dune_engine/fs_memo.ml | 175 +++++--- src/dune_engine/fs_memo.mli | 27 +- src/dune_engine/scheduler.ml | 160 ++++---- src/dune_engine/scheduler.mli | 2 +- src/dune_file_watcher/dune | 8 +- src/dune_file_watcher/dune_file_watcher.ml | 375 +++++++++++++----- src/dune_file_watcher/dune_file_watcher.mli | 59 ++- src/memo/memo.ml | 34 +- src/memo/memo.mli | 4 +- .../test-cases/watching/test-1.t/run.t | 40 ++ .../dune_file_watcher_tests.ml | 12 +- test/expect-tests/vcs_tests.ml | 4 +- vendor/ocaml-inotify/src/dune | 5 + vendor/ocaml-inotify/src/inotify.ml | 133 +++++++ vendor/ocaml-inotify/src/inotify.mli | 119 ++++++ vendor/ocaml-inotify/src/inotify_stubs.c | 167 ++++++++ vendor/update-ocaml-inotify.sh | 29 ++ 26 files changed, 1367 insertions(+), 308 deletions(-) create mode 100644 src/async_inotify_for_dune/async_inotify.ml create mode 100644 src/async_inotify_for_dune/async_inotify.mli create mode 100644 src/async_inotify_for_dune/async_inotify_for_dune.ml create mode 100644 src/async_inotify_for_dune/dune create mode 100644 vendor/ocaml-inotify/src/dune create mode 100644 vendor/ocaml-inotify/src/inotify.ml create mode 100644 vendor/ocaml-inotify/src/inotify.mli create mode 100644 vendor/ocaml-inotify/src/inotify_stubs.c create mode 100755 vendor/update-ocaml-inotify.sh diff --git a/bin/common.ml b/bin/common.ml index 73d97f9c602..6f7f41bc736 100644 --- a/bin/common.ml +++ b/bin/common.ml @@ -892,10 +892,10 @@ let term = value & opt (enum - [ ("automatic", Dune_engine.Scheduler.Run.Detect_external) + [ ("automatic", Dune_engine.Scheduler.Run.Automatic) ; ("manual", No_watcher) ]) - Detect_external + Automatic & info [ "file-watcher" ] ~doc) and+ wait_for_filesystem_clock = Arg.( diff --git a/boot/libs.ml b/boot/libs.ml index 6a28ff4e030..55e9fdc3c80 100644 --- a/boot/libs.ml +++ b/boot/libs.ml @@ -32,6 +32,9 @@ let local_libraries = ; ("otherlibs/dune-rpc/private", Some "Dune_rpc_private", false, None) ; ("src/dune_rpc_server", Some "Dune_rpc_server", false, None) ; ("src/thread_worker", Some "Thread_worker", false, None) + ; ("vendor/ocaml-inotify/src", Some "Ocaml_inotify", false, None) + ; ("src/async_inotify_for_dune", Some "Async_inotify_for_dune", 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/otherlibs/stdune-unstable/monoid.ml b/otherlibs/stdune-unstable/monoid.ml index 0ae84d1a7a7..3ea242d1e7f 100644 --- a/otherlibs/stdune-unstable/monoid.ml +++ b/otherlibs/stdune-unstable/monoid.ml @@ -1,5 +1,7 @@ module type Basic = Monoid_intf.Basic +module type S = Monoid_intf.S + module Make (M : Basic) : Monoid_intf.S with type t = M.t = struct include M diff --git a/otherlibs/stdune-unstable/monoid.mli b/otherlibs/stdune-unstable/monoid.mli index 5ed891d4b5e..02999799f26 100644 --- a/otherlibs/stdune-unstable/monoid.mli +++ b/otherlibs/stdune-unstable/monoid.mli @@ -1,32 +1,34 @@ module type Basic = Monoid_intf.Basic +module type S = Monoid_intf.S + (** This functor extends the basic definition of a monoid by adding a convenient operator synonym [( @ ) = combine], as well as derived functions [reduce] and [map_reduce]. *) -module Make (M : Basic) : Monoid_intf.S with type t = M.t +module Make (M : Basic) : S with type t = M.t [@@inlined always] (** The monoid you get with [empty = false] and [combine = ( || )]. *) -module Exists : Monoid_intf.S with type t = bool +module Exists : S with type t = bool (** The monoid you get with [empty = true] and [combine = ( && )]. *) -module Forall : Monoid_intf.S with type t = bool +module Forall : S with type t = bool (** The string concatenation monoid with [empty = ""] and [combine = ( ^ )]. *) -module String : Monoid_intf.S with type t = string +module String : S with type t = string (** The list monoid with [empty = \[\]] and [combine = ( @ )]. *) module List (M : sig type t -end) : Monoid_intf.S with type t = M.t list +end) : S with type t = M.t list (** The list monoid with [empty = \[\]] and [combine = ( @ )]. *) module Appendable_list (M : sig type t -end) : Monoid_intf.S with type t = M.t Appendable_list.t +end) : S with type t = M.t Appendable_list.t (** The trivial monoid with [empty = ()] and [combine () () = ()]. *) -module Unit : Monoid_intf.S with type t = Unit.t +module Unit : S with type t = Unit.t (** The addition monoid with [empty = zero] and [combine = ( + )]. *) module Add (M : sig @@ -35,7 +37,7 @@ module Add (M : sig val zero : t val ( + ) : t -> t -> t -end) : Monoid_intf.S with type t = M.t +end) : S with type t = M.t (** The multiplication monoid with [empty = one] and [combine = ( * )]. *) module Mul (M : sig @@ -44,7 +46,7 @@ module Mul (M : sig val one : t val ( * ) : t -> t -> t -end) : Monoid_intf.S with type t = M.t +end) : S with type t = M.t (** The union monoid with [empty = M.empty] and [combine = M.union]. *) module Union (M : sig @@ -53,17 +55,17 @@ module Union (M : sig val empty : t val union : t -> t -> t -end) : Monoid_intf.S with type t = M.t +end) : S with type t = M.t (** The product of monoids where pairs are combined component-wise. *) module Product (A : Monoid_intf.Basic) (B : Monoid_intf.Basic) : - Monoid_intf.S with type t = A.t * B.t + S with type t = A.t * B.t (** Same as [Product] but for 3 monoids. *) module Product3 (A : Monoid_intf.Basic) (B : Monoid_intf.Basic) - (C : Monoid_intf.Basic) : Monoid_intf.S with type t = A.t * B.t * C.t + (C : Monoid_intf.Basic) : S with type t = A.t * B.t * C.t (** Functions that return a monoid form the following monoid: @@ -72,7 +74,7 @@ module Product3 module Function (A : sig type t end) -(M : Monoid_intf.Basic) : Monoid_intf.S with type t = A.t -> M.t +(M : Monoid_intf.Basic) : S with type t = A.t -> M.t (** Endofunctions, i.e., functions of type [t -> t], form two monoids. *) module Endofunction : sig @@ -83,7 +85,7 @@ module Endofunction : sig - combine f g = fun x -> g (f x) *) module Left (A : sig type t - end) : Monoid_intf.S with type t = A.t -> A.t + end) : S with type t = A.t -> A.t (** The right-to-left function composition monoid, where the argument is first passed to the rightmost function: @@ -92,5 +94,5 @@ module Endofunction : sig - combine f g = fun x -> f (g x) *) module Right (A : sig type t - end) : Monoid_intf.S with type t = A.t -> A.t + end) : S with type t = A.t -> A.t end diff --git a/src/async_inotify_for_dune/async_inotify.ml b/src/async_inotify_for_dune/async_inotify.ml new file mode 100644 index 00000000000..fe41eb94e54 --- /dev/null +++ b/src/async_inotify_for_dune/async_inotify.ml @@ -0,0 +1,202 @@ +open Stdune +open Poly + +(* We don't make calls to [Inotify] functions ([add_watch], [rm_watch]) in a + separate thread because: + + - we don't think they can block for a while - Inotify doesn't release the + OCaml lock anyway - it avoids racing with the select loop below, by + preventing adding a watch and seeing an event about it before having filled + the hashtable (not that we have observed this particular race). *) + +module External_deps = struct + module Unix = Unix + module String_table = String.Table + module Filename = Filename +end + +open External_deps +module Inotify = Ocaml_inotify.Inotify + +module Event = struct + type move = + | Away of string + | Into of string + | Move of string * string + + type t = + | Created of string + | Unlinked of string + | Modified of string + | Moved of move + | Queue_overflow + + let move_to_string m = + match m with + | Away s -> Printf.sprintf "%s -> Unknown" s + | Into s -> Printf.sprintf "Unknown -> %s" s + | Move (f, t) -> Printf.sprintf "%s -> %s" f t + + let to_string t = + match t with + | Created s -> Printf.sprintf "created %s" s + | Unlinked s -> Printf.sprintf "unlinked %s" s + | Moved mv -> Printf.sprintf "moved %s" (move_to_string mv) + | Modified s -> Printf.sprintf "modified %s" s + | Queue_overflow -> "queue overflow" +end + +open Event + +module Inotify_watch = struct + type t = Inotify.watch + + let hash t = Int.hash (Inotify.int_of_watch t) + + let equal a b = Int.equal (Inotify.int_of_watch a) (Inotify.int_of_watch b) + + let to_dyn t = Int.to_dyn (Inotify.int_of_watch t) +end + +module Watch_table = Hashtbl.Make (Inotify_watch) + +type t = + { fd : Unix.file_descr + ; log_error : string -> unit + ; watch_table : string Watch_table.t + ; path_table : Inotify.watch String_table.t + ; send_emit_events_job_to_scheduler : (unit -> Event.t list) -> unit + ; select_events : Inotify.selector list + } + +type file_info = string * Unix.stats + +type modify_event_selector = + [ `Any_change + | `Closed_writable_fd + ] + +let ( ^/ ) = Filename.concat + +let add t path = + let watch = Inotify.add_watch t.fd path t.select_events in + Watch_table.set t.watch_table watch path; + String_table.set t.path_table path watch + +let process_raw_events t events = + let watch_table = t.watch_table in + let ev_kinds = + List.filter_map events ~f:(fun (watch, ev_kinds, trans_id, fn) -> + if + Inotify.int_of_watch watch = -1 + (* queue overflow event is always reported on watch -1 *) + then + let maybe_overflow = + List.filter_map ev_kinds ~f:(fun ev -> + match ev with + | Inotify.Q_overflow -> Some (ev, trans_id, "") + | _ -> None) + in + match maybe_overflow with + | [] -> None + | _ :: _ -> Some maybe_overflow + else + match Watch_table.find watch_table watch with + | None -> + t.log_error + (Printf.sprintf "Events for an unknown watch (%d) [%s]\n" + (Inotify.int_of_watch watch) + (String.concat ~sep:", " + (List.map ev_kinds ~f:Inotify.string_of_event_kind))); + None + | Some path -> + let fn = + match fn with + | None -> path + | Some fn -> path ^/ fn + in + Some (List.map ev_kinds ~f:(fun ev -> (ev, trans_id, fn)))) + |> List.concat + in + let pending_mv, actions = + List.fold_left ev_kinds ~init:(None, []) + ~f:(fun (pending_mv, actions) (kind, trans_id, fn) -> + let add_pending lst = + match pending_mv with + | None -> lst + | Some (_, fn) -> Moved (Away fn) :: lst + in + match kind with + | Inotify.Moved_from -> (Some (trans_id, fn), add_pending actions) + | Inotify.Moved_to -> ( + match pending_mv with + | None -> (None, Moved (Into fn) :: actions) + | Some (m_trans_id, m_fn) -> + if m_trans_id = trans_id then + (None, Moved (Move (m_fn, fn)) :: actions) + else + (None, Moved (Away m_fn) :: Moved (Into fn) :: actions)) + | Inotify.Move_self -> (Some (trans_id, fn), add_pending actions) + | Inotify.Create -> (None, Created fn :: add_pending actions) + | Inotify.Delete -> (None, Unlinked fn :: add_pending actions) + | Inotify.Modify + | Inotify.Close_write -> + (None, Modified fn :: add_pending actions) + | Inotify.Q_overflow -> (None, Queue_overflow :: add_pending actions) + | Inotify.Delete_self -> (None, add_pending actions) + | Inotify.Access + | Inotify.Attrib + | Inotify.Open + | Inotify.Ignored + | Inotify.Isdir + | Inotify.Unmount + | Inotify.Close_nowrite -> + (None, add_pending actions)) + in + List.rev + (match pending_mv with + | None -> actions + | Some (_, fn) -> Moved (Away fn) :: actions) + +let pump_events t ~spawn_thread = + let fd = t.fd in + let () = + spawn_thread (fun () -> + while true do + let _, _, _ = + UnixLabels.select ~read:[ fd ] ~write:[] ~except:[] ~timeout:(-1.) + in + let events = Inotify.read fd in + t.send_emit_events_job_to_scheduler (fun () -> + process_raw_events t events) + done) + in + () + +let create ~spawn_thread ~modify_event_selector ~log_error + ~send_emit_events_job_to_scheduler = + let fd = Inotify.create () in + let watch_table = Watch_table.create 10 in + let modify_selector : Inotify.selector = + match modify_event_selector with + | `Any_change -> S_Modify + | `Closed_writable_fd -> S_Close_write + in + let t = + { fd + ; watch_table + ; path_table = String_table.create 10 + ; select_events = + [ S_Create + ; S_Delete + ; modify_selector + ; S_Move_self + ; S_Moved_from + ; S_Moved_to + ] + ; log_error + ; send_emit_events_job_to_scheduler + } + in + pump_events t ~spawn_thread; + t diff --git a/src/async_inotify_for_dune/async_inotify.mli b/src/async_inotify_for_dune/async_inotify.mli new file mode 100644 index 00000000000..b32e8d9db6d --- /dev/null +++ b/src/async_inotify_for_dune/async_inotify.mli @@ -0,0 +1,71 @@ +(** This library is a convenience layer on top of raw inotify interface that + maintains the required client-side bookkeeping to make sense of the events + generated by the kernel and translate them in a form convenient for the + client application. + + See [man 7 inotify] for the raw inotify documentation. + + The state maintained by [t] is not thread-safe and can only be interacted + with in the context of a "scheduler" (async scheduler or fiber scheduler in + dune). We assume that [add] is called in the context of the scheduler and + that [send_emit_events_job_to_scheduler f] runs [f] in the context of the + scheduler. + + Be aware that the interface of inotify makes it easy to write code with race + conditions or other subtle pitfalls. For instance, stat'ing a file then + watching it means you have lost any events between the stat and the watch. + Or the behavior when watching a path whose inode has multiple hardlinks is + non-obvious. *) + +type t + +type file_info = string * UnixLabels.stats + +module Event : sig + type move = + | Away of string + | Into of string + | Move of string * string + + type t = + | Created of string + | Unlinked of string + | Modified of string + | Moved of move + (** Queue overflow means that you are not consuming events fast enough + and just lost some of them. This means that some changes to files + you want might go unnoticed *) + | Queue_overflow + + val to_string : t -> string +end + +type modify_event_selector = + [ `Any_change + (** Send a Modified event whenever the contents of the file changes (which + can be very often when writing a large file) *) + | `Closed_writable_fd + (** Only send a Modify event when someone with a file descriptor with write + permission to that file is closed. There are usually many fewer of these + events (for large files), but they come later. *) + ] + +(** [create path] creates an inotify watching path. Returns the inotify type t + itself and the list of files currently being watched. By default, + recursively watches all subdirectories of the given path. See [add_all] for + caveats. + + [send_emit_events_job_to_scheduler f] is expected to run the job [f] in the + scheduler, and then process the events returned by that job. *) +val create : + spawn_thread:((unit -> unit) -> unit) + -> modify_event_selector:modify_event_selector + -> log_error:(string -> unit) + -> send_emit_events_job_to_scheduler:((unit -> Event.t list) -> unit) + -> t + +(** [add t path] add the path to t to be watched. The operation is synchronous, + so when it returns the kernel has already acknowledged that the watch was + set up. This may, in fact, block, but it's not safe to run this function in + a separate thread. *) +val add : t -> string -> unit diff --git a/src/async_inotify_for_dune/async_inotify_for_dune.ml b/src/async_inotify_for_dune/async_inotify_for_dune.ml new file mode 100644 index 00000000000..674306ef4f9 --- /dev/null +++ b/src/async_inotify_for_dune/async_inotify_for_dune.ml @@ -0,0 +1 @@ +module Async_inotify = Async_inotify diff --git a/src/async_inotify_for_dune/dune b/src/async_inotify_for_dune/dune new file mode 100644 index 00000000000..b17e9090795 --- /dev/null +++ b/src/async_inotify_for_dune/dune @@ -0,0 +1,3 @@ +(library + (name async_inotify_for_dune) + (libraries stdune unix ocaml_inotify threads.posix)) diff --git a/src/dune_engine/dune b/src/dune_engine/dune index 5b89867a885..a8ff6059b53 100644 --- a/src/dune_engine/dune +++ b/src/dune_engine/dune @@ -28,7 +28,9 @@ dune_rpc_server thread_worker spawn - dune_file_watcher) + dune_file_watcher + ocaml_inotify + async_inotify_for_dune) (synopsis "Internal Dune library, do not use!")) (ocamllex dune_lexer) diff --git a/src/dune_engine/fs_memo.ml b/src/dune_engine/fs_memo.ml index bc3fed49682..4ca1bfbca16 100644 --- a/src/dune_engine/fs_memo.ml +++ b/src/dune_engine/fs_memo.ml @@ -2,10 +2,99 @@ open! Stdune open! Import open Memo.Build.O +module Initialization_state = struct + type t = + | Uninitialized of Path.t list + | Initialized of { dune_file_watcher : Dune_file_watcher.t option } +end + +(* Ideally this should be an [Fdecl], but there are currently two reasons why + it's not: + + - We read the workspace file before we start the inotify watcher, so [init] + is called after [t_ref] is used. This means we have to invalidate some + entries of t when [init] is called and set up subscriptions. + + - There are tests that call [Scheduler.go] multiple times, therefore [init] + gets called multiple times. Since they don't use file watcher, it shouldn't + be a problem. *) +let t_ref = ref (Initialization_state.Uninitialized []) + +(* CR-someday aalekseyev: For [watch_path] to work correctly we need to ensure + that the parent directory of [path] exists. That is certainly not guaranteed + by the [Fs_memo] API, so we should do something to make it more robust, but I + believe that is masked by the fact that we usually (always?) look at the + source directory before looking for files in that directory. + + It might seem that the [ENOENT] "fall back" trick used below can be extended + to fall back all the way to the root, but it can't because subscribing to the + 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, _, _) -> ( + (* 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 + workspace dir under our feet, in which case all bets are off). *) + let containing_dir = Path.parent_exn path in + (* If the file is absent, we need to wait for it to be created by watching + 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, _, _) -> ()) + +let watch_path_using_ref path = + match !t_ref with + | Initialized { dune_file_watcher = None } -> () + | Initialized { dune_file_watcher = Some watcher } -> watch_path watcher path + | Uninitialized paths_to_watch -> + t_ref := Uninitialized (path :: paths_to_watch) + (* Files and directories have non-overlapping sets of paths, so we can track them using the same memoization table. *) let memo = - Memo.create "fs_memo" ~input:(module Path) (fun _path -> Memo.Build.return ()) + Memo.create "fs_memo" + ~input:(module Path) + (fun path -> + (* It may seem weird that we are adding a watch on every invalidation of + the cell. This is OK because [add_watch] is idempotent, in the sense + that we are not accumulating watches. + + In fact, if path disappears then we lose the watch and have to + re-establish it, so doing it on every computation is sometimes + necessary. *) + watch_path_using_ref path; + Memo.Build.return ()) + +let invalidate_path path = + match Memo.Expert.previously_evaluated_cell memo path with + | None -> Memo.Invalidation.empty + | Some cell -> Memo.Cell.invalidate cell + +let init ~dune_file_watcher = + match !t_ref with + | Initialized { dune_file_watcher = Some _ } -> + Code_error.raise + "Called [Fs_memo.init] a second time after a file watcher was already \ + set up " + [] + | Initialized { dune_file_watcher = None } -> + (* It would be nice to disallow this to simplify things, but there are tests + that call [Scheduler.go] multiple times, therefore [init] gets called + multiple times. Since they don't use the file watcher, it shouldn't be a + problem. *) + Memo.Invalidation.empty + | Uninitialized accessed_paths -> + let res = + Memo.Invalidation.reduce (List.map accessed_paths ~f:invalidate_path) + in + t_ref := Initialized { dune_file_watcher }; + Option.iter dune_file_watcher ~f:(fun watcher -> + List.iter accessed_paths ~f:(fun path -> watch_path watcher path)); + res (* Declare a dependency on a path. Instead of calling [depend] directly, you should prefer using the helper function [declaring_dependency], because it @@ -57,11 +146,6 @@ let with_lexbuf_from_file path ~f = let dir_contents_unsorted = declaring_dependency ~f:Path.Untracked.readdir_unsorted_with_kinds -let invalidate_path path = - match Memo.Expert.previously_evaluated_cell memo path with - | None -> Memo.Invalidation.empty - | Some cell -> Memo.Cell.invalidate cell - (* When a file or directory is created or deleted, we need to also invalidate the parent directory, so that the [dir_contents] queries are re-executed. *) let invalidate_path_and_its_parent path = @@ -70,61 +154,24 @@ let invalidate_path_and_its_parent path = | None -> Memo.Invalidation.empty | Some path -> invalidate_path path) -module Event = struct - (* Here are some assumptions about events: - - - If a file is renamed, we receive [File_created] and [File_deleted] events - with corresponding paths. - - - If a directory is renamed then in addition to the [Directory_created] and - [Directory_deleted] events for the directory itself, we receive events - about all file and directory paths in the corresponding file tree. - - - Similarly, if a directory is deleted, we receive the [Directory_deleted] - event for the directory itself, as well as deletion events for all paths in - the corresponding file tree. *) - type kind = - | File_created - | File_deleted - | File_changed - | Directory_created - | Directory_deleted - | Unknown (** Treated conservatively as any possible event. *) - - type t = - { path : Path.t - ; kind : kind - } - - let create ~kind ~path = - if Path.is_in_build_dir path then - Code_error.raise "Fs_memo.Event.create called on a build path" []; - { path; kind } - - (* CR-someday amokhov: The way we currently treat file system events is simple - and robust but doesn't take advantage of all the information we receive. - Here are some ideas for future optimisation: - - - Don't invalidate [path_exists] queries on [File_changed] events. - - - If a [path_exists] query currently returns [true] and we receive a - corresponding [File_deleted] event, we can change the query's result to - [false] without rerunning the [Path.exists] function (and vice versa). - - - Similarly, the result of [dir_contents] queries can be updated without - calling [Path.readdir_unsorted_with_kinds]: we know which file or directory - should be added to or removed from the result. *) - let handle { kind; path } : Memo.Invalidation.t = - match kind with - | File_changed -> invalidate_path path - | File_created - | File_deleted - | Directory_created - | Directory_deleted - | Unknown -> - invalidate_path_and_its_parent path - - let path t = t.path - - let kind t = t.kind -end +(* CR-someday amokhov: The way we currently treat file system events is simple + and robust but doesn't take advantage of all the information we receive. Here + are some ideas for future optimisation: + + - Don't invalidate [path_exists] queries on [File_changed] events. + + - If a [path_exists] query currently returns [true] and we receive a + corresponding [File_deleted] event, we can change the query's result to + [false] without rerunning the [Path.exists] function (and vice versa). + + - Similarly, the result of [dir_contents] queries can be updated without + calling [Path.readdir_unsorted_with_kinds]: we know which file or directory + should be added to or removed from the result. *) +let handle_fs_event ({ kind; path } : Dune_file_watcher.Fs_memo_event.t) : + Memo.Invalidation.t = + match kind with + | File_changed -> invalidate_path path + | Created + | Deleted + | Unknown -> + invalidate_path_and_its_parent path diff --git a/src/dune_engine/fs_memo.mli b/src/dune_engine/fs_memo.mli index cfb9e7bba4a..c31d884b810 100644 --- a/src/dune_engine/fs_memo.mli +++ b/src/dune_engine/fs_memo.mli @@ -1,6 +1,10 @@ open! Stdune open Import +(** [init] must be called at initialization. Returns the set of nodes that need + to be invalidated because they were accessed before [init] was called. *) +val init : dune_file_watcher:Dune_file_watcher.t option -> Memo.Invalidation.t + (** All functions in this module raise a code error when given a path in the build directory. *) @@ -38,24 +42,5 @@ val with_lexbuf_from_file : Path.t -> f:(Lexing.lexbuf -> 'a) -> 'a Memo.Build.t val dir_contents_unsorted : Path.t -> ((string * Unix.file_kind) list, Unix.error) result Memo.Build.t -(** Events generated by the file-watching backend. *) -module Event : sig - type kind = - | File_created - | File_deleted - | File_changed - | Directory_created - | Directory_deleted - | Unknown (** Treated conservatively as any possible event. *) - - type t - - val kind : t -> kind - - val path : t -> Path.t - - val create : kind:kind -> path:Path.t -> t - - (** Handle file system event. *) - val handle : t -> Memo.Invalidation.t -end +(** Handle file system event. *) +val handle_fs_event : Dune_file_watcher.Fs_memo_event.t -> Memo.Invalidation.t diff --git a/src/dune_engine/scheduler.ml b/src/dune_engine/scheduler.ml index be4afde57e9..d73dd4b2189 100644 --- a/src/dune_engine/scheduler.ml +++ b/src/dune_engine/scheduler.ml @@ -119,10 +119,11 @@ end module Event : sig type build_input_change = | Sync - | Fs_event of Fs_memo.Event.t + | Fs_event of Dune_file_watcher.Fs_memo_event.t | Invalidation of Memo.Invalidation.t type t = + | File_watcher_task of (unit -> Dune_file_watcher.Event.t list) | Build_inputs_changed of build_input_change Nonempty_list.t | File_system_watcher_terminated | Job_completed of job * Proc.Process_info.t @@ -141,9 +142,6 @@ module Event : sig returned first. *) val next : t -> event - (** Ignore the ne next file change event about this file. *) - val ignore_next_file_change_event : t -> Path.t -> unit - (** Pending worker tasks *) val pending_worker_tasks : t -> int @@ -157,7 +155,12 @@ module Event : sig val register_worker_task_started : t -> unit - (** Send an event to the main thread. *) + val send_file_watcher_task : + t -> (unit -> Dune_file_watcher.Event.t list) -> unit + + (** It's a bit weird to have both this and [send_file_watcher_task]. The + reason is that [send_file_watcher_task] uses [send_file_watcher_events] + internally. *) val send_file_watcher_events : t -> Dune_file_watcher.Event.t list -> unit val send_invalidation_event : t -> Memo.Invalidation.t -> unit @@ -172,10 +175,11 @@ module Event : sig end = struct type build_input_change = | Sync - | Fs_event of Fs_memo.Event.t + | Fs_event of Dune_file_watcher.Fs_memo_event.t | Invalidation of Memo.Invalidation.t type t = + | File_watcher_task of (unit -> Dune_file_watcher.Event.t list) | Build_inputs_changed of build_input_change Nonempty_list.t | File_system_watcher_terminated | Job_completed of job * Proc.Process_info.t @@ -194,18 +198,11 @@ end = struct type t = { jobs_completed : (job * Proc.Process_info.t) Queue.t + ; file_watcher_tasks : (unit -> Dune_file_watcher.Event.t list) Queue.t ; mutable invalidation_events : Invalidation_event.t list ; mutable signals : Signal.Set.t ; mutex : Mutex.t ; cond : Condition.t - (* CR-soon 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. *) - ; ignored_files : (string, unit) Table.t ; mutable pending_jobs : int ; mutable pending_worker_tasks : int ; worker_tasks_completed : Fiber.fill Queue.t @@ -216,20 +213,20 @@ end = struct let create stats = let jobs_completed = Queue.create () in + let file_watcher_tasks = Queue.create () in let worker_tasks_completed = Queue.create () in let invalidation_events = [] in let signals = Signal.Set.empty in let mutex = Mutex.create () in let cond = Condition.create () in - let ignored_files = Table.create (module String) 64 in let pending_jobs = 0 in let pending_worker_tasks = 0 in { jobs_completed + ; file_watcher_tasks ; invalidation_events ; signals ; mutex ; cond - ; ignored_files ; pending_jobs ; worker_tasks_completed ; pending_worker_tasks @@ -243,10 +240,6 @@ end = struct let register_worker_task_started q = q.pending_worker_tasks <- q.pending_worker_tasks + 1 - let ignore_next_file_change_event q path = - assert (Path.is_in_source_tree path); - Table.set q.ignored_files (Path.to_absolute_filename path) () - let add_event q f = Mutex.lock q.mutex; f q; @@ -274,6 +267,8 @@ end = struct val signal : t + val file_watcher_task : t + val invalidation : t val jobs_completed : t @@ -298,6 +293,10 @@ end = struct q.signals <- Signal.Set.remove q.signals signal; Signal signal) + let file_watcher_task q = + Option.map (Queue.pop q.file_watcher_tasks) ~f:(fun job -> + File_watcher_task job) + let invalidation q = match q.invalidation_events with | [] -> None @@ -305,22 +304,16 @@ end = struct q.invalidation_events <- []; let terminated = ref false in let events = - List.filter_map events ~f:(function - | Filesystem_event Sync -> Some (Sync : build_input_change) + List.concat_map events ~f:(function + | Filesystem_event Sync -> [ (Sync : build_input_change) ] | Invalidation invalidation -> - Some (Invalidation invalidation : build_input_change) + [ (Invalidation invalidation : build_input_change) ] | Filesystem_event Watcher_terminated -> terminated := true; - None - | Filesystem_event (File_changed path) -> - let abs_path = Path.to_absolute_filename path in - if Table.mem q.ignored_files abs_path then ( - (* only use ignored record once *) - Table.remove q.ignored_files abs_path; - None - ) else - (* CR-soon amokhov: Generate more precise events. *) - Some (Fs_event (Fs_memo.Event.create ~kind:Unknown ~path))) + [] + | Filesystem_event (Fs_memo_event event) -> [ Fs_event event ] + | Filesystem_event Queue_overflow -> + [ Invalidation Memo.Invalidation.clear_caches ]) in match !terminated with | true -> Some File_system_watcher_terminated @@ -357,12 +350,13 @@ end = struct (chain (* Event sources are listed in priority order. Signals are the highest priority to maximize responsiveness to Ctrl+C. - [worker_tasks_completed] and [invalidation] is used for - reacting to user input, so their latency is also important. - [jobs_completed] and [yield] are where the bulk of the work - is done, so they are the lowest priority to avoid starving - other things. *) + [file_watcher_task], [worker_tasks_completed] and + [invalidation] are used for reacting to user input, so their + latency is also important. [jobs_completed] and [yield] are + where the bulk of the work is done, so they are the lowest + priority to avoid starving other things. *) [ signal + ; file_watcher_task ; invalidation ; worker_tasks_completed ; jobs_completed @@ -402,6 +396,9 @@ end = struct let send_signal q signal = add_event q (fun q -> q.signals <- Signal.Set.add q.signals signal) + let send_file_watcher_task q job = + add_event q (fun q -> Queue.push q.file_watcher_tasks job) + let pending_jobs q = q.pending_jobs let pending_worker_tasks q = q.pending_worker_tasks @@ -650,6 +647,7 @@ type t = ; job_throttle : Fiber.Throttle.t ; events : Event.Queue.t ; process_watcher : Process_watcher.t + ; file_watcher : Dune_file_watcher.t option } let t : t Fiber.Var.t = Fiber.Var.create () @@ -670,9 +668,13 @@ let yield_if_there_are_pending_events () = let () = Memo.yield_if_there_are_pending_events := yield_if_there_are_pending_events -let ignore_for_watch p = +let ignore_for_watch path = let+ t = t () in - Event.Queue.ignore_next_file_change_event t.events p + match t.file_watcher with + | None -> () + | Some file_watcher -> + assert (Path.is_in_source_tree path); + Dune_file_watcher.ignore_next_file_change_event file_watcher path exception Build_cancelled @@ -733,28 +735,34 @@ let kill_and_wait_for_all_processes t = let prepare (config : Config.t) ~(handler : Handler.t) = let events = Event.Queue.create config.stats in - (* The signal watcher must be initialized first so that signals are blocked in - all threads. *) - Signal_watcher.init events; - let process_watcher = Process_watcher.init events in - let t = - { status = - (* Slightly weird initialization happening here: for polling mode we - initialize in "Building" state, immediately switch to Standing_by and - then back to "Building". It would make more sense to start in - "Stand_by" from the start. We can't "just" switch the initial value - here because then the non-polling mode would run in "Standing_by" - mode, which is even weirder. *) - Building - ; job_throttle = Fiber.Throttle.create config.concurrency - ; process_watcher - ; events - ; config - ; handler - } - in - global := Some t; - t + (* We return the scheduler in chunks to resolve the dependency cycle + (scheduler wants to know the file_watcher, file_watcher wants to send + events to scheduler) *) + ( events + , fun ~file_watcher -> + (* The signal watcher must be initialized first so that signals are + blocked in all threads. *) + Signal_watcher.init events; + let process_watcher = Process_watcher.init events in + let t = + { status = + (* Slightly weird initialization happening here: for polling mode we + initialize in "Building" state, immediately switch to Standing_by + and then back to "Building". It would make more sense to start in + "Stand_by" from the start. We can't "just" switch the initial + value here because then the non-polling mode would run in + "Standing_by" mode, which is even weirder. *) + Building + ; job_throttle = Fiber.Throttle.create config.concurrency + ; process_watcher + ; events + ; config + ; handler + ; file_watcher + } + in + global := Some t; + t ) module Run_once : sig type run_error = @@ -774,7 +782,7 @@ end = struct let handle_event event = match (event : Event.build_input_change) with | Invalidation invalidation -> invalidation - | Fs_event event -> Fs_memo.Event.handle event + | Fs_event event -> Fs_memo.handle_fs_event event | Sync -> Memo.Invalidation.empty in let invalidation = @@ -803,6 +811,10 @@ end = struct t.handler t.config Tick; match Event.Queue.next t.events with | Job_completed (job, proc_info) -> Fiber.Fill (job.ivar, proc_info) + | File_watcher_task job -> + let events = job () in + Event.Queue.send_file_watcher_events t.events events; + iter t | Build_inputs_changed events -> ( let invalidation = (handle_invalidation_events events : Memo.Invalidation.t) @@ -922,7 +934,7 @@ module Run = struct exception Build_cancelled = Build_cancelled type file_watcher = - | Detect_external + | Automatic | No_watcher module Event_queue = Event.Queue @@ -1047,20 +1059,22 @@ module Run = struct let go config ?(file_watcher = No_watcher) ~(on_event : Config.t -> Handler.Event.t -> unit) run = - let t = prepare config ~handler:on_event in - let watcher = + let events, prepare = prepare config ~handler:on_event in + let file_watcher = match file_watcher with | No_watcher -> None - | Detect_external -> + | Automatic -> Some (Dune_file_watcher.create_default ~scheduler: { spawn_thread = Thread.spawn - ; thread_safe_send_events = - (fun files_changed -> - Event_queue.send_file_watcher_events t.events files_changed) + ; thread_safe_send_emit_events_job = + (fun job -> Event_queue.send_file_watcher_task events job) }) in + let t = prepare ~file_watcher in + let initial_invalidation = Fs_memo.init ~dune_file_watcher:file_watcher in + Memo.reset initial_invalidation; let result = match Run_once.run_and_cleanup t run with | Ok a -> Result.Ok a @@ -1075,8 +1089,10 @@ module Run = struct | Error (Exn exn_with_bt) -> Error (exn_with_bt.exn, Some exn_with_bt.backtrace) in - Option.iter watcher ~f:(fun watcher -> - ignore (wait_for_process t (Dune_file_watcher.pid watcher) : _ Fiber.t)); + Option.iter file_watcher ~f:(fun watcher -> + match Dune_file_watcher.shutdown watcher with + | `Kill pid -> ignore (wait_for_process t pid : _ Fiber.t) + | `No_op -> ()); ignore (kill_and_wait_for_all_processes t : saw_signal); match result with | Ok a -> a diff --git a/src/dune_engine/scheduler.mli b/src/dune_engine/scheduler.mli index abf53a20c9e..7a7ee714884 100644 --- a/src/dune_engine/scheduler.mli +++ b/src/dune_engine/scheduler.mli @@ -49,7 +49,7 @@ module Run : sig end type file_watcher = - | Detect_external + | Automatic | No_watcher (** Raised when [go] terminates due to the user requesting a shutdown via rpc. diff --git a/src/dune_file_watcher/dune b/src/dune_file_watcher/dune index 2ef196986f0..f949f64b2d3 100644 --- a/src/dune_file_watcher/dune +++ b/src/dune_file_watcher/dune @@ -1,4 +1,10 @@ (library (name dune_file_watcher) - (libraries spawn unix stdune threads.posix) + (libraries + spawn + unix + stdune + threads.posix + ocaml_inotify + async_inotify_for_dune) (synopsis "Internal Dune library, do not use!")) diff --git a/src/dune_file_watcher/dune_file_watcher.ml b/src/dune_file_watcher/dune_file_watcher.ml index 72d56229775..d9ad7430875 100644 --- a/src/dune_file_watcher/dune_file_watcher.ml +++ b/src/dune_file_watcher/dune_file_watcher.ml @@ -1,25 +1,113 @@ open! Stdune +module Inotify_lib = Async_inotify_for_dune.Async_inotify + +let inotify_event_paths (event : Inotify_lib.Event.t) = + match event with + | Created path + | Unlinked path + | Modified path + | Moved (Away path) + | Moved (Into path) -> + [ path ] + | Moved (Move (from, to_)) -> [ from; to_ ] + | Queue_overflow -> [] + +type kind = + | Coarse of { wait_for_watches_established : unit -> unit } + | Fine of { inotify : Inotify_lib.t } type t = - { pid : Pid.t - ; wait_for_watches_established : unit -> unit + { shutdown : [ `Kill of Pid.t | `No_op ] + ; 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 + | Deleted + | File_changed + | Unknown (** Treated conservatively as any possible event. *) + + type t = + { path : Path.t + ; kind : kind + } + + let create ~kind ~path = + if Path.is_in_build_dir path then + Code_error.raise "Fs_memo.Event.create called on a build path" []; + { path; kind } +end + module Event = struct type t = - | File_changed of Path.t + | Fs_memo_event of Fs_memo_event.t + | Queue_overflow | Sync | Watcher_terminated end +(* [process_inotify_event] needs to run in the scheduler thread because it + accesses [t.ignored_files]. *) +let process_inotify_event ~ignored_files + (event : Async_inotify_for_dune.Async_inotify.Event.t) : Event.t list = + let should_ignore = + List.exists (inotify_event_paths event) ~f:(fun path -> + let path = Path.of_string path in + let abs_path = Path.to_absolute_filename path in + if Table.mem ignored_files abs_path then ( + (* only use ignored record once *) + Table.remove ignored_files abs_path; + true + ) else + false) + in + if should_ignore then + [] + else + match event with + | Created path -> + let path = Path.of_string path in + [ Fs_memo_event (Fs_memo_event.create ~kind:Created ~path) ] + | Unlinked path -> + let path = Path.of_string path in + [ Fs_memo_event (Fs_memo_event.create ~kind:Deleted ~path) ] + | Modified path -> + let path = Path.of_string path in + [ Fs_memo_event (Fs_memo_event.create ~kind:File_changed ~path) ] + | Moved move -> ( + match move with + | Away path -> + let path = Path.of_string path in + [ Fs_memo_event (Fs_memo_event.create ~kind:Deleted ~path) ] + | Into path -> + let path = Path.of_string path in + [ Fs_memo_event (Fs_memo_event.create ~kind:Created ~path) ] + | Move (from, to_) -> + let from = Path.of_string from in + let to_ = Path.of_string to_ in + [ Fs_memo_event (Fs_memo_event.create ~kind:Deleted ~path:from) + ; Fs_memo_event (Fs_memo_event.create ~kind:Created ~path:to_) + ]) + | Queue_overflow -> [ Event.Queue_overflow ] + module Scheduler = struct type t = - { thread_safe_send_events : Event.t list -> unit - ; spawn_thread : (unit -> unit) -> unit + { spawn_thread : (unit -> unit) -> unit + ; thread_safe_send_emit_events_job : (unit -> Event.t list) -> unit } end -let pid t = t.pid +let shutdown t = t.shutdown let buffer_capacity = 65536 @@ -63,7 +151,7 @@ module Buffer = struct List.rev !lines) end -module Inotify = struct +module Inotifywait = struct let wait_for_watches_established stderr = let buffer = Buffer.create ~capacity:65536 in let rec loop () = @@ -90,7 +178,7 @@ let special_file_for_inotify_sync = let path = lazy (Path.Build.relative Path.Build.root "dune-inotify-sync") in fun () -> Lazy.force path -let command ~root = +let command ~root ~backend = let exclude_patterns = [ {|/_opam|} ; {|/_esy|} @@ -114,13 +202,8 @@ let command ~root = let inotify_special_path = Path.Build.to_string (special_file_for_inotify_sync ()) in - match - if Sys.linux then - Bin.which ~path:(Env.path Env.initial) "inotifywait" - else - None - with - | Some inotifywait -> + match backend with + | `Inotifywait inotifywait -> (* On Linux, use inotifywait. *) let excludes = String.concat ~sep:"|" exclude_patterns in ( inotifywait @@ -138,48 +221,71 @@ let command ~root = ; [ "--format"; "e:%e:%w%f" ] ; [ "-m" ] ] - , Inotify.parse_message - , Some Inotify.wait_for_watches_established ) - | None -> ( + , Inotifywait.parse_message + , Some Inotifywait.wait_for_watches_established ) + | `Fswatch fswatch -> (* On all other platforms, try to use fswatch. fswatch's event filtering is not reliable (at least on Linux), so don't try to use it, instead act on all events. *) - match Bin.which ~path:(Env.path Env.initial) "fswatch" with - | Some fswatch -> - let excludes = - List.concat_map - (exclude_patterns @ List.map exclude_paths ~f:(fun p -> "/" ^ p)) - ~f:(fun x -> [ "--exclude"; x ]) - in - ( fswatch - , [ "-r" - ; root - ; (* If [inotify_special_path] is not passed here, then the [--exclude - _build] makes fswatch not descend into [_build], which means it - never even discovers that [inotify_special_path] exists. This is - despite the fact that [--include] appears before. *) - inotify_special_path - ; "--event" - ; "Created" - ; "--event" - ; "Updated" - ; "--event" - ; "Removed" - ] - @ [ "--include"; inotify_special_path ] - @ excludes - , (fun s -> Ok s) - , None ) - | None -> - User_error.raise - [ Pp.text - (if Sys.linux then - "Please install inotifywait to enable watch mode. If inotifywait \ - is unavailable, fswatch may also be used but will result in a \ - worse experience." - else - "Please install fswatch to enable watch mode.") - ]) + let excludes = + List.concat_map + (exclude_patterns @ List.map exclude_paths ~f:(fun p -> "/" ^ p)) + ~f:(fun x -> [ "--exclude"; x ]) + in + ( fswatch + , [ "-r" + ; root + ; (* If [inotify_special_path] is not passed here, then the [--exclude + _build] makes fswatch not descend into [_build], which means it never + even discovers that [inotify_special_path] exists. This is despite + the fact that [--include] appears before. *) + inotify_special_path + ; "--event" + ; "Created" + ; "--event" + ; "Updated" + ; "--event" + ; "Removed" + ] + @ [ "--include"; inotify_special_path ] + @ excludes + , (fun s -> Ok s) + , None ) + +let select_watcher_backend ~use_inotify_lib = + let try_fswatch () = + Option.map + (Bin.which ~path:(Env.path Env.initial) "fswatch") + ~f:(fun fswatch -> `Fswatch fswatch) + in + let try_inotifywait () = + Option.map + (Bin.which ~path:(Env.path Env.initial) "inotifywait") + ~f:(fun inotifywait -> `Inotifywait inotifywait) + in + let error str = User_error.raise [ Pp.text str ] in + match Sys.linux with + | false -> ( + match try_fswatch () with + | Some res -> res + | None -> error "Please install fswatch to enable watch mode.") + | true -> ( + if use_inotify_lib then ( + assert (Ocaml_inotify.Inotify.supported_by_the_os ()); + `Inotify_lib + ) else + match try_inotifywait () with + | Some res -> res + | None -> ( + match try_fswatch () with + | Some res -> res + | None -> + User_error.raise + [ Pp.text + "Please install inotifywait to enable watch mode. If \ + inotifywait is unavailable, fswatch may also be used but will \ + result in a worse experience." + ])) let emit_sync () = Io.write_file (Path.build (special_file_for_inotify_sync ())) "z" @@ -188,9 +294,9 @@ let prepare_sync () = Path.mkdir_p (Path.parent_exn (Path.build (special_file_for_inotify_sync ()))); emit_sync () -let spawn_external_watcher ~root = +let spawn_external_watcher ~root ~backend = prepare_sync (); - let prog, args, parse_line, wait_for_start = command ~root in + let prog, args, parse_line, wait_for_start = command ~root ~backend in let prog = Path.to_absolute_filename prog in let argv = prog :: args in let r_stdout, w_stdout = Unix.pipe () in @@ -210,57 +316,87 @@ let spawn_external_watcher ~root = Option.iter stderr ~f:Unix.close; ((r_stdout, parse_line, wait), pid) -let create_no_buffering ~(scheduler : Scheduler.t) ~root = +let create_inotifylib_watcher ~ignored_files ~(scheduler : Scheduler.t) = let special_file_for_inotify_sync = special_file_for_inotify_sync () in - let (pipe, parse_line, wait), pid = spawn_external_watcher ~root in + Inotify_lib.create ~spawn_thread:scheduler.spawn_thread + ~modify_event_selector:`Closed_writable_fd + ~send_emit_events_job_to_scheduler:(fun f -> + scheduler.thread_safe_send_emit_events_job (fun () -> + let events = f () in + List.concat_map events ~f:(fun event -> + match (event : Inotify_lib.Event.t) with + | Modified path + when Path.equal (Path.of_string path) + (Path.build special_file_for_inotify_sync) -> + [ Event.Sync ] + | event -> process_inotify_event ~ignored_files event))) + ~log_error:(fun error -> Console.print [ Pp.text error ]) + +let special_file_for_inotify_sync_absolute = + lazy + (Path.to_absolute_filename (Path.build (special_file_for_inotify_sync ()))) + +let is_special_file_for_inotify_sync (path : Path.t) = + match path with + | In_source_tree _ -> false + | External _ -> + 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 ()) + +let create_no_buffering ~(scheduler : Scheduler.t) ~root ~backend = + let ignored_files = Table.create (module String) 64 in + let (pipe, parse_line, wait), pid = spawn_external_watcher ~root ~backend in let worker_thread pipe = let buffer = Buffer.create ~capacity:buffer_capacity in - let special_file_for_inotify_sync_absolute = - Path.to_absolute_filename (Path.build special_file_for_inotify_sync) - in while true do - let lines = + (* the job must run on the scheduler thread because it accesses + [ignored_files] *) + let job = match Buffer.read_lines buffer pipe with - | `End_of_file _remaining -> [ Event.Watcher_terminated ] + | `End_of_file _remaining -> fun () -> [ Event.Watcher_terminated ] | `Ok lines -> - List.map lines ~f:(fun line -> - match parse_line line with - | Error s -> failwith s - | Ok path_s -> ( - let path = Path.of_string path_s in - match path with - | In_source_tree _ -> Event.File_changed path - | External _ -> - if String.equal path_s special_file_for_inotify_sync_absolute - then - Event.Sync - else - Event.File_changed path - | In_build_dir build_path -> - if Path.Build.( = ) build_path special_file_for_inotify_sync - then - Event.Sync + fun () -> + List.concat_map lines ~f:(fun line -> + match parse_line line with + | Error s -> failwith s + | Ok path_s -> + let path = Path.of_string path_s in + if is_special_file_for_inotify_sync path then + [ Event.Sync ] else - Event.File_changed path)) + let abs_path = Path.to_absolute_filename path in + if Table.mem ignored_files abs_path then ( + (* only use ignored record once *) + Table.remove ignored_files abs_path; + [] + ) else + [ Fs_memo_event + (Fs_memo_event.create ~kind:File_changed ~path) + ]) in - scheduler.thread_safe_send_events lines + scheduler.thread_safe_send_emit_events_job job done in scheduler.spawn_thread (fun () -> worker_thread pipe); - { pid; wait_for_watches_established = wait } + { shutdown = `Kill pid + ; kind = Coarse { wait_for_watches_established = wait } + ; ignored_files + } let with_buffering ~create ~(scheduler : Scheduler.t) ~debounce_interval = - let files_changed = ref [] in + let jobs = ref [] in let event_mtx = Mutex.create () in let event_cv = Condition.create () in let res = - let thread_safe_send_events lines = + let thread_safe_send_emit_events_job job = Mutex.lock event_mtx; - files_changed := List.rev_append lines !files_changed; + jobs := job :: !jobs; Condition.signal event_cv; Mutex.unlock event_mtx in - let scheduler = { scheduler with thread_safe_send_events } in + let scheduler = { scheduler with thread_safe_send_emit_events_job } in create ~scheduler in (* The buffer thread is used to avoid flooding the main thread with file @@ -277,33 +413,76 @@ let with_buffering ~create ~(scheduler : Scheduler.t) ~debounce_interval = [debounce_interval] *) let rec buffer_thread () = Mutex.lock event_mtx; - while List.is_empty !files_changed do + while List.is_empty !jobs do Condition.wait event_cv event_mtx done; - let files = !files_changed in - files_changed := []; + let jobs_batch = List.rev !jobs in + jobs := []; Mutex.unlock event_mtx; - scheduler.thread_safe_send_events files; + scheduler.thread_safe_send_emit_events_job (fun () -> + List.concat_map jobs_batch ~f:(fun job -> job ())); Thread.delay debounce_interval; buffer_thread () in scheduler.spawn_thread buffer_thread; res -let create ~root ~debounce_interval ~scheduler = +let create_external ~root ~debounce_interval ~scheduler ~backend = match debounce_interval with - | None -> create_no_buffering ~root ~scheduler + | None -> create_no_buffering ~root ~scheduler ~backend | Some debounce_interval -> with_buffering ~scheduler ~debounce_interval ~create:(create_no_buffering ~root) + ~backend + +let create_inotifylib ~scheduler = + prepare_sync (); + 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 ()))); + { kind = Fine { inotify }; shutdown = `No_op; ignored_files } + +let create_default ~scheduler = + match select_watcher_backend ~use_inotify_lib:true with + | (`Inotifywait _ | `Fswatch _) as backend -> + create_external ~scheduler ~root:Path.root + ~debounce_interval:(Some 0.5 (* seconds *)) ~backend + | `Inotify_lib -> create_inotifylib ~scheduler -let create_default = - create ~root:Path.root ~debounce_interval:(Some 0.5 (* seconds *)) +let create_external ~root ~debounce_interval ~scheduler = + match select_watcher_backend ~use_inotify_lib:false with + | (`Inotifywait _ | `Fswatch _) as backend -> + create_external ~root ~debounce_interval ~scheduler ~backend + | `Inotify_lib -> assert false -let wait_watches_established_blocking t = t.wait_for_watches_established () +let wait_for_initial_watches_established_blocking t = + match t.kind with + | Coarse { wait_for_watches_established } -> wait_for_watches_established () + | Fine { inotify = _ } -> + (* no initial watches needed: all watches should be set up at the time just + before file access *) + () + +let add_watch t path = + match t.kind with + | Coarse _ -> + (* 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 *) + () + | Fine { inotify } -> Inotify_lib.add inotify (Path.to_string path) module For_tests = struct - let suspend t = Unix.kill (Pid.to_int t.pid) Sys.sigstop + let pid t = + match t.shutdown with + | `Kill pid -> pid + | `No_op -> failwith "don't know how to suspend an inotifylib watcher" + + let suspend t = Unix.kill (Pid.to_int (pid t)) Sys.sigstop - let resume t = Unix.kill (Pid.to_int t.pid) Sys.sigcont + let resume t = Unix.kill (Pid.to_int (pid t)) Sys.sigcont end + +let ignore_next_file_change_event t path = + assert (Path.is_in_source_tree path); + Table.set t.ignored_files (Path.to_absolute_filename path) () diff --git a/src/dune_file_watcher/dune_file_watcher.mli b/src/dune_file_watcher/dune_file_watcher.mli index 06c3c645d1f..d7bfcf46de4 100644 --- a/src/dune_file_watcher/dune_file_watcher.mli +++ b/src/dune_file_watcher/dune_file_watcher.mli @@ -1,10 +1,45 @@ open! Stdune +module Inotify_lib := Async_inotify_for_dune.Async_inotify type t +val inotify_event_paths : Inotify_lib.Event.t -> string list + +module Fs_memo_event : sig + (* Here are some idealized assumptions the Fs_memo module in dune_engine makes + about events: + + - If a file is renamed, we receive [Created] and [Deleted] events with + corresponding paths. + + - If a directory is renamed then in addition to the [Created] and [Deleted] + events for the directory itself, we receive events about all file and + directory paths in the corresponding file tree. + + - Similarly, if a directory is deleted, we receive the [Deleted] event for + the directory itself, as well as deletion events for all watched paths in + the corresponding file tree. + + Not all of these assumptions we can currently uphold. In particular, + directory renames probably just give "created" and "deleted" for the + directory itself, which means we are not correctly handling directory + renames. *) + type kind = + | Created + | Deleted + | File_changed + | Unknown (** Treated conservatively as any possible event. *) + + type t = private + { path : Path.t + ; kind : kind + } +end + module Event : sig type t = - | File_changed of Path.t + | Fs_memo_event of Fs_memo_event.t + | Queue_overflow | Sync | Watcher_terminated end @@ -12,28 +47,29 @@ end module Scheduler : sig (** Hook into the fiber scheduler. *) type t = - { thread_safe_send_events : Event.t list -> unit - (** Send a list of events to the scheduler from a separate system - thread.. *) - ; spawn_thread : (unit -> unit) -> unit + { spawn_thread : (unit -> unit) -> unit (** We spawn threads through this function in case the scheduler wants to block signals *) + ; thread_safe_send_emit_events_job : (unit -> Event.t list) -> unit + (** Send some events to the scheduler. The events are sent in the form + of a thunk to be executed on the scheduler thread, so that we can + do some bookkeeping that needs to happen there. *) } end (** Create a new file watcher. [debounce_interval] is measured in seconds and it controls the minimum time between calls to [scheduler.thread_safe_send_files_changed]. *) -val create : +val create_external : root:Path.t -> debounce_interval:float option -> scheduler:Scheduler.t -> t (** Create a new file watcher with default settings. *) val create_default : scheduler:Scheduler.t -> t -(** Pid of the external file watcher process *) -val pid : t -> Pid.t +(** The action that needs to be taken to shutdown the watcher. *) +val shutdown : t -> [ `Kill of Pid.t | `No_op ] -val wait_watches_established_blocking : t -> unit +val wait_for_initial_watches_established_blocking : t -> unit (** Cause a [Sync] event to be propagated through the notification sybsystem to attemt to make sure that we've processed all the events that happened so @@ -45,3 +81,8 @@ module For_tests : sig val resume : t -> unit end + +val add_watch : t -> Path.t -> unit + +(** Ignore the ne next file change event about this file. *) +val ignore_next_file_change_event : t -> Path.t -> unit diff --git a/src/memo/memo.ml b/src/memo/memo.ml index acb4fb82023..a55f20e6405 100644 --- a/src/memo/memo.ml +++ b/src/memo/memo.ml @@ -1266,20 +1266,26 @@ module Invalidation = struct | Clear_caches -> Dyn.Variant ("Clear_caches", []) end - (* Represented as a tree mainly to get a tail-recursive execution. *) - type t = - | Empty - | Leaf of Leaf.t - | Combine of t * t - - let empty : t = Empty - - let combine a b = - match (a, b) with - | Empty, x - | x, Empty -> - x - | x, y -> Combine (x, y) + module T = struct + (* Represented as a tree mainly to get a tail-recursive execution. *) + type t = + | Empty + | Leaf of Leaf.t + | Combine of t * t + + let empty : t = Empty + + let combine a b = + match (a, b) with + | Empty, x + | x, Empty -> + x + | x, y -> Combine (x, y) + end + + include T + + include (Monoid.Make (T) : Monoid.S with type t := t) let execute_leaf = function | Leaf.Invalidate_node node -> invalidate_dep_node node diff --git a/src/memo/memo.mli b/src/memo/memo.mli index 74249ee91de..54c5648b338 100644 --- a/src/memo/memo.mli +++ b/src/memo/memo.mli @@ -180,9 +180,7 @@ module Invalidation : sig type t - val empty : t - - val combine : t -> t -> t + include Monoid.S with type t := t val is_empty : t -> bool diff --git a/test/blackbox-tests/test-cases/watching/test-1.t/run.t b/test/blackbox-tests/test-cases/watching/test-1.t/run.t index f11f70365aa..5bf0080e321 100644 --- a/test/blackbox-tests/test-cases/watching/test-1.t/run.t +++ b/test/blackbox-tests/test-cases/watching/test-1.t/run.t @@ -60,6 +60,24 @@ $ cat _build/default/y new-contents2 +---------------------------------------------------------------------------------- +* File rename + + $ mv x z + $ build y + Failure + + $ echo new-contents3 > z + + $ build y + Failure + + $ mv z x + $ build y + Success + $ cat _build/default/y + new-contents3 + $ with_timeout dune shutdown $ cat dune-output waiting for inotify sync @@ -71,3 +89,25 @@ waiting for inotify sync waited for inotify sync Success, waiting for filesystem changes... + waiting for inotify sync + waited for inotify sync + File "dune", line 1, characters 0-57: + 1 | (rule + 2 | (target y) + 3 | (deps x) + 4 | (action (bash "cat x > y"))) + Error: No rule found for x + Had errors, waiting for filesystem changes... + waiting for inotify sync + waited for inotify sync + File "dune", line 1, characters 0-57: + 1 | (rule + 2 | (target y) + 3 | (deps x) + 4 | (action (bash "cat x > y"))) + Error: No rule found for x + Had errors, waiting for filesystem changes... + waiting for inotify sync + waited for inotify sync + Success, waiting for filesystem changes... + diff --git a/test/expect-tests/dune_file_watcher/dune_file_watcher_tests.ml b/test/expect-tests/dune_file_watcher/dune_file_watcher_tests.ml index a31bb6d896c..ab3ac2e95bc 100644 --- a/test/expect-tests/dune_file_watcher/dune_file_watcher_tests.ml +++ b/test/expect-tests/dune_file_watcher/dune_file_watcher_tests.ml @@ -85,12 +85,13 @@ let%expect_test _ = in let events_buffer = ref [] in let watcher = - Dune_file_watcher.create ~debounce_interval:None + Dune_file_watcher.create_external ~debounce_interval:None ~scheduler: { spawn_thread = (fun f -> ignore (Thread.create f () : Thread.t)) - ; thread_safe_send_events = - (fun events -> + ; thread_safe_send_emit_events_job = + (fun job -> Mutex.lock mutex; + let events = job () in events_buffer := !events_buffer @ events; Mutex.unlock mutex) } @@ -105,11 +106,12 @@ let%expect_test _ = Some (List.map list ~f:(function | Dune_file_watcher.Event.Sync -> assert false - | Dune_file_watcher.Event.File_changed file -> file + | Dune_file_watcher.Event.Queue_overflow -> assert false + | Dune_file_watcher.Event.Fs_memo_event { path; kind = _ } -> path | Dune_file_watcher.Event.Watcher_terminated -> assert false))) in let print_events n = print_events ~try_to_get_events ~expected:n in - Dune_file_watcher.wait_watches_established_blocking watcher; + Dune_file_watcher.wait_for_initial_watches_established_blocking watcher; Stdio.Out_channel.write_all "x" ~data:"x"; print_events 1; [%expect {| diff --git a/test/expect-tests/vcs_tests.ml b/test/expect-tests/vcs_tests.ml index 57e8f221eca..48a48933fa5 100644 --- a/test/expect-tests/vcs_tests.ml +++ b/test/expect-tests/vcs_tests.ml @@ -39,8 +39,8 @@ let run (vcs : Vcs.t) args = |> String.concat ~sep:" "); Process.run Strict (Lazy.force prog) real_args ~env: - ((* One of the reasons to set GIT_DIR to override any GIT_DIR set by the - environment, which helps for example during [git rebase --exec]. *) + ((* One of the reasons to set GIT_DIR is to override any GIT_DIR set by + the environment, which helps for example during [git rebase --exec]. *) Env.add Env.initial ~var:"GIT_DIR" ~value:(Filename.concat (Path.to_absolute_filename vcs.root) ".git")) ~dir:vcs.root diff --git a/vendor/ocaml-inotify/src/dune b/vendor/ocaml-inotify/src/dune new file mode 100644 index 00000000000..38bdd6a71cc --- /dev/null +++ b/vendor/ocaml-inotify/src/dune @@ -0,0 +1,5 @@ +(library + (name ocaml_inotify) + (wrapped true) + (foreign_stubs (language c) (names inotify_stubs)) + (flags (-w -3-6-27-32-33-35-50))) diff --git a/vendor/ocaml-inotify/src/inotify.ml b/vendor/ocaml-inotify/src/inotify.ml new file mode 100644 index 00000000000..1284187f698 --- /dev/null +++ b/vendor/ocaml-inotify/src/inotify.ml @@ -0,0 +1,133 @@ +(* + * Copyright (C) 2006-2008 Vincent Hanquez + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * Inotify OCaml binding + *) + +type selector = +| S_Access +| S_Attrib +| S_Close_write +| S_Close_nowrite +| S_Create +| S_Delete +| S_Delete_self +| S_Modify +| S_Move_self +| S_Moved_from +| S_Moved_to +| S_Open +| S_Dont_follow +| S_Mask_add +| S_Oneshot +| S_Onlydir +(* convenience *) +| S_Move +| S_Close +| S_All + +type event_kind = +| Access +| Attrib +| Close_write +| Close_nowrite +| Create +| Delete +| Delete_self +| Modify +| Move_self +| Moved_from +| Moved_to +| Open +| Ignored +| Isdir +| Q_overflow +| Unmount + +let string_of_event_kind = function +| Access -> "ACCESS" +| Attrib -> "ATTRIB" +| Close_write -> "CLOSE_WRITE" +| Close_nowrite -> "CLOSE_NOWRITE" +| Create -> "CREATE" +| Delete -> "DELETE" +| Delete_self -> "DELETE_SELF" +| Modify -> "MODIFY" +| Move_self -> "MOVE_SELF" +| Moved_from -> "MOVED_FROM" +| Moved_to -> "MOVED_TO" +| Open -> "OPEN" +| Ignored -> "IGNORED" +| Isdir -> "ISDIR" +| Q_overflow -> "Q_OVERFLOW" +| Unmount -> "UNMOUNT" + +type watch = int +type event = watch * event_kind list * int32 * string option + +external create : unit -> Unix.file_descr = "caml_inotify_init" +external add_watch : Unix.file_descr -> string -> selector list -> watch + = "caml_inotify_add_watch" +external rm_watch : Unix.file_descr -> watch -> unit = "caml_inotify_rm_watch" + +external convert : Bytes.t -> (watch * event_kind list * int32 * int) + = "caml_inotify_convert" +external struct_size : unit -> int = "caml_inotify_struct_size" +external name_max : unit -> int = "caml_inotify_name_max" + +let int_of_watch watch = watch + +let watch_of_int watch = watch + +let string_of_event (watch, events, cookie, name) = + Printf.sprintf "watch=%d cookie=%ld events=%s%s" + watch cookie + (String.concat "|" (List.map string_of_event_kind events)) + (match name with + | None -> "" + | Some name' -> Printf.sprintf " %S" name') + +let read fd = + (* Turns out that reading from blocking descriptors always requires a buffer + of the maximum size, which is, from the inotify man page: + + The behavior when the buffer given to read(2) is too small to return + information about the next event depends on the kernel version: in + kernels before 2.6.21, read(2) returns 0; since kernel 2.6.21, + read(2) fails with the error EINVAL. Specifying a buffer of size + + sizeof(struct inotify_event) + NAME_MAX + 1 + *) + let event_size = struct_size () in + + let buf_size = event_size + (name_max ()) + 1 in + let buf = Bytes.create buf_size in + let bytes_read = Unix.read fd buf 0 buf_size in + + let read_c_string pos = + Bytes.sub_string buf pos ((Bytes.index_from buf pos '\x00') - pos) + in + + let rec read_one pos rest = + if bytes_read < pos + event_size then rest + else + let watch, mask, cookie, len = convert (Bytes.sub buf pos event_size) in + if bytes_read < pos + event_size + len then rest + else + let name = if len > 0 then Some (read_c_string (pos + event_size)) else None in + read_one (pos + event_size + len) ((watch, mask, cookie, name) :: rest) + in + + List.rev (read_one 0 []) + +external supported_by_the_os : unit -> bool = "caml_inotify_is_supported" diff --git a/vendor/ocaml-inotify/src/inotify.mli b/vendor/ocaml-inotify/src/inotify.mli new file mode 100644 index 00000000000..6d0a2a24d9c --- /dev/null +++ b/vendor/ocaml-inotify/src/inotify.mli @@ -0,0 +1,119 @@ +(* + * Copyright (C) 2006-2008 Vincent Hanquez + * Copyright (C) 2014 Peter Zotov + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + *) + +(** Inotify binding for OCaml + + @see Inotify manual page *) + +(** Type of event masks. *) +type selector = +| S_Access +| S_Attrib +| S_Close_write +| S_Close_nowrite +| S_Create +| S_Delete +| S_Delete_self +| S_Modify +| S_Move_self +| S_Moved_from +| S_Moved_to +| S_Open +| S_Dont_follow +| S_Mask_add +| S_Oneshot +| S_Onlydir +| S_Move +| S_Close +| S_All + +(** Type of observed events. *) +type event_kind = +| Access +| Attrib +| Close_write +| Close_nowrite +| Create +| Delete +| Delete_self +| Modify +| Move_self +| Moved_from +| Moved_to +| Open +| Ignored +| Isdir +| Q_overflow +| Unmount + +(** Type of watch descriptors. *) +type watch + +(** Type of received events, corresponding to [struct inotify_event]. + In event [wd, kinds, cookie, path], [wd] corresponds to [inotify_event.wd], + [kinds] corresponds to the bits set in [inotify_event.mask], [cookie] + corresponds to [inotify_event.cookie], [path] is [Some filename] if + [inotify_event.len > 0] and [None] otherwise. *) +type event = watch * event_kind list * int32 * string option + +(** [int_of_watch wd] returns the underlying integer representation of + watch descriptor [wd]. *) +val int_of_watch : watch -> int + +(**/**) + +(* [watch_of_int i] is the {!watch} corresponding to the integer + [i]. It violates the construction privacy of the {!watch} type but + is useful when using {!event} as a network portable type. *) +val watch_of_int : int -> watch + +(**/**) + +(** [string_of_event_kind ek] returns the string representation of event kind [ek], + e.g. [string_of_event_kind Move_self] ≡ ["MOVE_SELF"]. *) +val string_of_event_kind : event_kind -> string + +(** [string_of_event event] returns the string representation of event [ev], + e.g. [string_of_event] *) +val string_of_event : event -> string + +(** [create ()] returns a fresh inotify file descriptor or raises + [Unix.Unix_error(errno, "inotify_init", "")]. *) +val create : unit -> Unix.file_descr + +(** [add_watch fd path events] starts observing events from [events] for path [path] + at inotify file descriptor [fd] and returns a fresh watch descriptor, or raises + [Unix.Unix_error(errno, "inotify_add_watch", path)]. *) +val add_watch : Unix.file_descr -> string -> selector list -> watch + +(** [rm_watch fd watch] stops observing events corresponding to watch descriptor [watch] + at inotify file descriptor [fd], or raises + [Unix.Unix_error(errno, "inotify_rm_watch", path)]. *) +val rm_watch : Unix.file_descr -> watch -> unit + +(** [read fd] requests a list of events for inotify file descriptor [fd]. Each event + will include the watch descriptor, which can be used to determine the path that + caused it, and [Moved_to] and [Moved_from] events will include a cookie that allows + to associate them with each other. + + If {!read} is not called often enough, the kernel event buffer may overflow, in which + case the event kind list will consist of [[Q_overflow]]. Such an event would be + associated with a watch descriptor [-1], never returned from {!add_watch}. *) +val read : Unix.file_descr -> event list + +(** Returns [true] if inotify is supported by the OS. + So effectively it returns true on linux and false elsewhere. *) +val supported_by_the_os : unit -> bool diff --git a/vendor/ocaml-inotify/src/inotify_stubs.c b/vendor/ocaml-inotify/src/inotify_stubs.c new file mode 100644 index 00000000000..13737a99132 --- /dev/null +++ b/vendor/ocaml-inotify/src/inotify_stubs.c @@ -0,0 +1,167 @@ +/* + * Copyright (C) 2006-2008 Vincent Hanquez + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * Inotify Ocaml binding - C glue + */ + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#ifdef __linux__ + +#include +#include + +static int inotify_flag_table[] = { + IN_ACCESS, IN_ATTRIB, IN_CLOSE_WRITE, IN_CLOSE_NOWRITE, + IN_CREATE, IN_DELETE, IN_DELETE_SELF, IN_MODIFY, + IN_MOVE_SELF, IN_MOVED_FROM, IN_MOVED_TO, IN_OPEN, + IN_DONT_FOLLOW, IN_MASK_ADD, IN_ONESHOT, IN_ONLYDIR, + IN_MOVE, IN_CLOSE, IN_ALL_EVENTS, 0 +}; + +static int inotify_return_table[] = { + IN_ACCESS, IN_ATTRIB, IN_CLOSE_WRITE, IN_CLOSE_NOWRITE, + IN_CREATE, IN_DELETE, IN_DELETE_SELF, IN_MODIFY, + IN_MOVE_SELF, IN_MOVED_FROM, IN_MOVED_TO, IN_OPEN, + IN_IGNORED, IN_ISDIR, IN_Q_OVERFLOW, IN_UNMOUNT, 0 +}; + +value caml_inotify_is_supported (value unit) { + CAMLparam1(unit); + + CAMLreturn(Val_int(1)); +} + +value caml_inotify_init(value unit) { + CAMLparam1(unit); + + int fd = inotify_init1(IN_CLOEXEC); + if (fd == -1) uerror("inotify_init", Nothing); + + CAMLreturn(Val_int(fd)); +} + +value caml_inotify_add_watch(value fd, value path, value selector_flags) { + CAMLparam3(fd, path, selector_flags); + + int selector = caml_convert_flag_list(selector_flags, inotify_flag_table); + + int watch = inotify_add_watch(Int_val(fd), String_val(path), selector); + if (watch == -1) uerror("inotify_add_watch", path); + + CAMLreturn(Val_int(watch)); +} + +value caml_inotify_rm_watch(value fd, value watch) { + CAMLparam2(fd, watch); + + int ret = inotify_rm_watch(Int_val(fd), Int_val(watch)); + if (ret == -1) uerror("inotify_rm_watch", Nothing); + + CAMLreturn(Val_unit); +} + +value caml_inotify_struct_size(void) { + CAMLparam0(); + CAMLreturn(Val_int(sizeof(struct inotify_event))); +} + +value caml_inotify_name_max(void) { + CAMLparam0(); + CAMLreturn(Val_int(NAME_MAX)); +} + +value caml_inotify_convert(value buf) { + CAMLparam1(buf); + CAMLlocal3(event, list, next); + + list = next = Val_emptylist; + + struct inotify_event ievent; + memcpy(&ievent, String_val(buf), sizeof(struct inotify_event)); + + int flag; + for (flag = 0; inotify_return_table[flag]; flag++) { + if (!(ievent.mask & inotify_return_table[flag])) + continue; + + next = caml_alloc_small(2, Tag_cons); + Field(next, 0) = Val_int(flag); + Field(next, 1) = list; + list = next; + } + + event = caml_alloc_tuple(4); + Store_field(event, 0, Val_int(ievent.wd)); + Store_field(event, 1, list); + Store_field(event, 2, caml_copy_int32(ievent.cookie)); + Store_field(event, 3, Val_int(ievent.len)); + + CAMLreturn(event); +} + +#else + +value caml_inotify_is_supported (value unit) { + CAMLparam1(unit); + + CAMLreturn(Val_int(0)); +} + +value caml_inotify_init(value unit) { + CAMLparam1(unit); + + unix_error(ENOTSUP, "inotify_init", Nothing); +} + +value caml_inotify_add_watch(value fd, value path, value selector_flags) { + CAMLparam3(fd, path, selector_flags); + + unix_error(ENOTSUP, "inotify_add_watch", Nothing); +} + +value caml_inotify_rm_watch(value fd, value watch) { + CAMLparam2(fd, watch); + + unix_error(ENOTSUP, "inotify_rm_watch", Nothing); +} + +value caml_inotify_struct_size(value unit) { + CAMLparam1(unit); + unix_error(ENOTSUP, "inotify_struct_size", Nothing); +} + +value caml_inotify_name_max(value unit) { + CAMLparam1(unit); + unix_error(ENOTSUP, "inotify_name_max", Nothing); +} + +value caml_inotify_convert(value buf) { + CAMLparam1(buf); + + unix_error(ENOTSUP, "inotify_convert", Nothing); +} + +#endif diff --git a/vendor/update-ocaml-inotify.sh b/vendor/update-ocaml-inotify.sh new file mode 100755 index 00000000000..423272c742d --- /dev/null +++ b/vendor/update-ocaml-inotify.sh @@ -0,0 +1,29 @@ +#!/bin/bash + +version=1bfe079ddfc6bff72a3b6a8ae3c0408297b04434 + +set -e -u -o pipefail + +TMP="$(mktemp -d)" +TRAP_CMD=$(printf "rm -rf %q" "$TMP") +trap "$TRAP_CMD" EXIT + +lib_name=ocaml-inotify + +rm -rf "$lib_name" +mkdir -p "$lib_name/src" + +( + cd "$TMP" + git clone https://github.com/ocaml-dune/ocaml-inotify.git "$lib_name" + cd "$lib_name" + git -c advice.detachedHead=false checkout "$version" +) + +SRC=$TMP/$lib_name + +rm "$SRC"/lib/lwt_inotify.ml{,i} +cp -v "$SRC"/lib/*.{ml,mli,c} "$lib_name"/src +cp -v "$SRC"/lib/dune "$lib_name"/src + +git add -A .