diff --git a/bin/build_cmd.ml b/bin/build_cmd.ml index 259dd31f73e..8accf8f5bf3 100644 --- a/bin/build_cmd.ml +++ b/bin/build_cmd.ml @@ -18,47 +18,63 @@ let run_build_system ~common ~(request : unit Action_builder.t) () = ])); Fiber.return ()) -let run_build_command_poll ~(common : Common.t) ~config ~request ~setup = +let setup () = Import.Main.setup () + +let run_build_system ~common ~request = let open Fiber.O in - let every = - Fiber.of_thunk (fun () -> - Cached_digest.invalidate_cached_timestamps (); - let* setup = setup () in - let* request = - match - let open Option.O in - let* rpc = Common.rpc common in - Dune_rpc_impl.Server.pending_build_action rpc - with - | None -> Fiber.return (request setup) - | Some (Build (targets, ivar)) -> - let+ () = Fiber.Ivar.fill ivar Accepted in - Target.interpret_targets (Common.root common) config setup targets - in - run_build_system ~common ~request ()) - in - Scheduler.poll ~common ~config ~every ~finally:Hooks.End_of_build.run + Fiber.finalize + (fun () -> + Cached_digest.invalidate_cached_timestamps (); + let* setup = setup () in + let request = request setup in + run_build_system ~common ~request ()) + ~finally:(fun () -> + Hooks.End_of_build.run (); + Fiber.return ()) + +let run_build_command_poll_eager ~(common : Common.t) ~config ~request : unit = + Import.Scheduler.go_with_rpc_server_and_console_status_reporting ~common + ~config (fun () -> Scheduler.Run.poll (run_build_system ~common ~request)) + +let run_build_command_poll_passive ~(common : Common.t) ~config ~request:_ : + unit = + (* CR-someday aalekseyev: It would've been better to complain if [request] is + non-empty, but we can't check that here because [request] is a function.*) + let open Fiber.O in + match Common.rpc common with + | None -> + Code_error.raise + "Attempted to start a passive polling mode without an RPC server" [] + | Some rpc -> + Import.Scheduler.go_with_rpc_server_and_console_status_reporting ~common + ~config (fun () -> + Scheduler.Run.poll_passive + ~get_build_request: + (let+ (Build (targets, ivar)) = + Dune_rpc_impl.Server.pending_build_action rpc + in + let request setup = + Target.interpret_targets (Common.root common) config setup + targets + in + (run_build_system ~common ~request, ivar))) -let run_build_command_once ~(common : Common.t) ~config ~request ~setup = +let run_build_command_once ~(common : Common.t) ~config ~request = let open Fiber.O in let once () = - let* setup = setup () in - let+ res = run_build_system ~common ~request:(request setup) () in + let+ res = run_build_system ~common ~request in match res with - | Error `Already_reported -> - (* to ensure non-zero exit code *) - raise Dune_util.Report_error.Already_reported + | Error `Already_reported -> raise Dune_util.Report_error.Already_reported | Ok () -> () in Scheduler.go ~common ~config once let run_build_command ~(common : Common.t) ~config ~request = - let setup () = Import.Main.setup () in - (if Common.watch common then - run_build_command_poll - else - run_build_command_once) - ~setup ~common ~config ~request + (match Common.watch common with + | Yes Eager -> run_build_command_poll_eager + | Yes Passive -> run_build_command_poll_passive + | No -> run_build_command_once) + ~common ~config ~request let runtest = let doc = "Run tests." in diff --git a/bin/common.ml b/bin/common.ml index 1272ab69c80..73d97f9c602 100644 --- a/bin/common.ml +++ b/bin/common.ml @@ -37,7 +37,7 @@ type t = orig_args : string list ; rpc : Dune_rpc_impl.Server.t option ; default_target : Arg.Dep.t (* For build & runtest only *) - ; watch : bool + ; watch : Dune_engine.Watch_mode_config.t ; print_metrics : bool ; stats_trace_file : string option ; always_show_command_line : bool @@ -525,6 +525,11 @@ let display_term = {|Control the display mode of Dune. See $(b,dune-config\(5\)) for more details.|}) +let simple_arg_conv ~to_string ~of_string = + Arg.conv + ( (fun s -> Result.map_error (of_string s) ~f:(fun s -> `Msg s)) + , fun pp x -> Format.pp_print_string pp (to_string x) ) + let shared_with_config_file = let docs = copts_sect in let+ concurrency = @@ -542,12 +547,8 @@ let shared_with_config_file = ~doc:{|Run no more than $(i,JOBS) commands simultaneously.|}) and+ sandboxing_preference = let arg = - Arg.conv - ( (fun s -> - Result.map_error (Dune_engine.Sandbox_mode.of_string s) ~f:(fun s -> - `Msg s)) - , fun pp x -> - Format.pp_print_string pp (Dune_engine.Sandbox_mode.to_string x) ) + simple_arg_conv ~of_string:Dune_engine.Sandbox_mode.of_string + ~to_string:Dune_engine.Sandbox_mode.to_string in Arg.( value @@ -799,9 +800,14 @@ let term = "Force actions associated to aliases to be re-executed even\n\ \ if their dependencies haven't changed.") and+ watch = + let watch_arg_name = "watch" in Arg.( - value & flag - & info [ "watch"; "w" ] + value + & opt ~vopt:(Dune_engine.Watch_mode_config.Yes Eager) + (simple_arg_conv ~to_string:Dune_engine.Watch_mode_config.to_string + ~of_string:Dune_engine.Watch_mode_config.of_string) + Dune_engine.Watch_mode_config.No + & info [ watch_arg_name; "w" ] ~doc: "Instead of terminating build after completion, wait continuously \ for file changes.") @@ -928,10 +934,9 @@ let term = let build_dir = Option.value ~default:default_build_dir build_dir in let root = Workspace_root.create ~specified_by_user:root in let rpc = - if watch then - Some (Dune_rpc_impl.Server.create ()) - else - None + match watch with + | Yes _ -> Some (Dune_rpc_impl.Server.create ()) + | No -> None in let stats = Option.map stats_trace_file ~f:(fun f -> diff --git a/bin/common.mli b/bin/common.mli index 20d412dc2cb..22eef87ccff 100644 --- a/bin/common.mli +++ b/bin/common.mli @@ -10,7 +10,7 @@ val stats : t -> Dune_stats.t option val print_metrics : t -> bool -val watch : t -> bool +val watch : t -> Dune_engine.Watch_mode_config.t val file_watcher : t -> Dune_engine.Scheduler.Run.file_watcher diff --git a/bin/import.ml b/bin/import.ml index 0e6d4b38b7f..b36df6c9dd5 100644 --- a/bin/import.ml +++ b/bin/import.ml @@ -32,7 +32,13 @@ include Common.Let_syntax let in_group (t, info) = (Term.Group.Term t, info) -module Main = struct +module Main : sig + include module type of struct + include Dune_rules.Main + end + + val setup : unit -> build_system Fiber.t +end = struct include Dune_rules.Main let setup () = @@ -92,18 +98,13 @@ module Scheduler = struct let config = Dune_config.for_scheduler dune_config None stats in Scheduler.Run.go config ~on_event:(on_event dune_config) f - let poll ~(common : Common.t) ~config:dune_config ~every ~finally = + let go_with_rpc_server_and_console_status_reporting ~(common : Common.t) + ~config:dune_config run = let stats = Common.stats common in let rpc_where = Some (Dune_rpc_private.Where.default ()) in let config = Dune_config.for_scheduler dune_config rpc_where stats in let file_watcher = Common.file_watcher common in let run = - let run () = - Scheduler.Run.poll - (Fiber.finalize - (fun () -> every) - ~finally:(fun () -> Fiber.return (finally ()))) - in match Common.rpc common with | None -> run | Some rpc -> diff --git a/bin/rpc.ml b/bin/rpc.ml index 23896d5061c..f8ad8985e6a 100644 --- a/bin/rpc.ml +++ b/bin/rpc.ml @@ -30,50 +30,66 @@ let raise_rpc_error (e : Dune_rpc_private.Response.Error.t) = ; Pp.textf "%s (error kind: %s)" e.message (interpret_kind e.kind) ] +let retry_loop once = + let open Fiber.O in + let rec loop sleeper = + let* res = once () in + match res with + | Some result -> + (match sleeper with + | None -> () + | Some s -> Scheduler.Worker.stop s); + Fiber.return result + | None -> + let* sleeper = Scheduler.Worker.create () in + let* () = + Scheduler.Worker.task_exn sleeper ~f:(fun () -> Unix.sleepf 0.2) + in + loop (Some sleeper) + in + loop None + +let establish_connection_or_raise ~wait ~common once = + let open Fiber.O in + if wait then + retry_loop once + else + let+ res = once () in + match res with + | Some (client, session) -> (client, session) + | None -> + let (_ : Dune_rpc_private.Where.t) = wait_for_server common in + User_error.raise + [ Pp.text + "failed to establish connection even though server seems to be \ + running" + ] + +let wait_term = + let doc = + "poll until server starts listening and then establish connection." + in + Arg.(value & flag & info [ "wait" ] ~doc) + +let establish_client_session ~common ~wait = + let open Fiber.O in + let once () = + let where = Dune_rpc.Where.get () in + match where with + | None -> Fiber.return None + | Some where -> ( + let* client = Dune_rpc_impl.Run.Connect.csexp_client where in + let+ session = Csexp_rpc.Client.connect client in + match session with + | Error _ -> None + | Ok session -> Some (client, session)) + in + establish_connection_or_raise ~wait ~common once + module Init = struct let connect ~wait common = let open Fiber.O in - let* client, session = - let once () = - let where = Dune_rpc.Where.get () in - match where with - | None -> Fiber.return None - | Some where -> ( - let* client = Dune_rpc_impl.Run.Connect.csexp_client where in - let+ session = Csexp_rpc.Client.connect client in - match session with - | Error _ -> None - | Ok session -> Some (client, session)) - in - let rec loop sleeper = - let* res = once () in - match res with - | Some (client, session) -> - (match sleeper with - | None -> () - | Some s -> Scheduler.Worker.stop s); - Fiber.return (client, session) - | None -> - let* sleeper = Scheduler.Worker.create () in - let* () = - Scheduler.Worker.task_exn sleeper ~f:(fun () -> Unix.sleepf 0.2) - in - loop (Some sleeper) - in - if wait then - loop None - else - let+ res = once () in - match res with - | Some (client, session) -> (client, session) - | None -> - let (_ : Dune_rpc_private.Where.t) = wait_for_server common in - User_error.raise - [ Pp.text - "failed to establish connection even though server seems to be \ - running" - ] - in + let* client, session = establish_client_session ~common ~wait in let* stdio = Csexp_rpc.Session.create ~socket:false stdin stdout in let forward f t = Fiber.repeat_while ~init:() ~f:(fun () -> @@ -94,12 +110,7 @@ module Init = struct let term = let+ (common : Common.t) = Common.term - and+ wait = - let doc = - "poll until server starts listening and then establish connection." - in - Arg.(value & flag & info [ "wait" ] ~doc) - in + and+ wait = wait_term in client_term common (connect ~wait) let man = [ `Blocks Common.help_secs ] @@ -111,6 +122,10 @@ module Init = struct let term = (Term.Group.Term term, info) end +let report_error error = + Printf.printf "Error: %s\n%!" + (Dyn.to_string (Dune_rpc_private.Response.Error.to_dyn error)) + module Status = struct let term = let+ (common : Common.t) = Common.term in @@ -129,20 +144,54 @@ module Status = struct () in match response with - | Error _ -> assert false - (* TODO *) + | Error error -> report_error error | Ok { clients } -> List.iter clients ~f:(fun client -> let sexp = Dune_rpc.Conv.to_sexp Dune_rpc.Id.sexp client in Sexp.to_string sexp |> print_endline)) let info = - let doc = "shot active connections" in + let doc = "show active connections" in Term.info "status" ~doc let term = (Term.Group.Term term, info) end +module Build = struct + let term = + let name_ = Arg.info [] ~docv:"TARGET" in + let+ (common : Common.t) = Common.term + and+ wait = wait_term + and+ targets = Arg.(value & pos_all string [] name_) in + client_term common @@ fun common -> + let open Fiber.O in + let* _client, session = establish_client_session ~common ~wait in + Dune_rpc_impl.Run.client_with_session ~session + (Dune_rpc.Initialize.Request.create + ~id:(Dune_rpc.Id.make (Sexp.Atom "build"))) + ~on_notification:(fun _ -> assert false) + ~f:(fun session -> + let open Fiber.O in + let+ response = + Dune_rpc_impl.Client.request session Dune_rpc_impl.Server.Decl.build + targets + in + match response with + | Error (error : Dune_rpc_private.Response.Error.t) -> + report_error error + | Ok Failure -> print_endline "Failure" + | Ok Success -> print_endline "Success") + + let info = + let doc = + "build a given target (requires dune to be running in passive watching \ + mode)" + in + Term.info "build" ~doc + + let term = (Term.Group.Term term, info) +end + module Ping = struct let send_ping cli = let open Fiber.O in @@ -186,4 +235,5 @@ let info = in Term.info "rpc" ~doc ~man -let group = (Term.Group.Group [ Init.term; Status.term; Ping.term ], info) +let group = + (Term.Group.Group [ Init.term; Status.term; Build.term; Ping.term ], info) diff --git a/otherlibs/dune-rpc/private/dune_rpc_private.mli b/otherlibs/dune-rpc/private/dune_rpc_private.mli index 9c37b52f1f3..3ad5ec8f953 100644 --- a/otherlibs/dune-rpc/private/dune_rpc_private.mli +++ b/otherlibs/dune-rpc/private/dune_rpc_private.mli @@ -52,6 +52,8 @@ module Response : sig exception E of t + val to_dyn : t -> Stdune.Dyn.t + val of_conv : Conv.error -> t val create : ?payload:Csexp.t -> kind:kind -> message:string -> unit -> t diff --git a/otherlibs/dune-rpc/private/types.mli b/otherlibs/dune-rpc/private/types.mli index 4370ebfd89c..dd90089001a 100644 --- a/otherlibs/dune-rpc/private/types.mli +++ b/otherlibs/dune-rpc/private/types.mli @@ -58,6 +58,8 @@ module Response : sig ; kind : kind } + val to_dyn : t -> Dyn.t + val payload : t -> Sexp.t option val message : t -> string diff --git a/src/dune_engine/clflags.ml b/src/dune_engine/clflags.ml index 6902674a8a3..cee6e1b79bf 100644 --- a/src/dune_engine/clflags.ml +++ b/src/dune_engine/clflags.ml @@ -26,7 +26,7 @@ let promote = ref None let force = ref false -let watch = ref false +let watch = ref Watch_mode_config.No let no_print_directory = ref false diff --git a/src/dune_engine/clflags.mli b/src/dune_engine/clflags.mli index c6636ca9e48..0bb7da9a205 100644 --- a/src/dune_engine/clflags.mli +++ b/src/dune_engine/clflags.mli @@ -37,7 +37,7 @@ val promote : Promote.t option ref val force : bool ref (** Instead of terminating build after completion, watch for changes *) -val watch : bool ref +val watch : Watch_mode_config.t ref (** Do not print "Entering directory" messages *) val no_print_directory : bool ref diff --git a/src/dune_engine/dune_engine.ml b/src/dune_engine/dune_engine.ml index 4ee824a6bba..3fb795ccc5d 100644 --- a/src/dune_engine/dune_engine.ml +++ b/src/dune_engine/dune_engine.ml @@ -58,4 +58,5 @@ module Execution_parameters = Execution_parameters module Cache_debug_flags = Cache_debug_flags module Reversible_digest = Reversible_digest module Report_errors_config = Report_errors_config +module Watch_mode_config = Watch_mode_config module Compound_user_error = Compound_user_error diff --git a/src/dune_engine/fs_memo.ml b/src/dune_engine/fs_memo.ml index b4e78ebea80..bc3fed49682 100644 --- a/src/dune_engine/fs_memo.ml +++ b/src/dune_engine/fs_memo.ml @@ -123,4 +123,8 @@ module Event = struct | Directory_deleted | Unknown -> invalidate_path_and_its_parent path + + let path t = t.path + + let kind t = t.kind end diff --git a/src/dune_engine/fs_memo.mli b/src/dune_engine/fs_memo.mli index 6355caf08dd..cfb9e7bba4a 100644 --- a/src/dune_engine/fs_memo.mli +++ b/src/dune_engine/fs_memo.mli @@ -50,6 +50,10 @@ module Event : sig type t + val kind : t -> kind + + val path : t -> Path.t + val create : kind:kind -> path:Path.t -> t (** Handle file system event. *) diff --git a/src/dune_engine/scheduler.ml b/src/dune_engine/scheduler.ml index d69f4fe208b..0e5973c830a 100644 --- a/src/dune_engine/scheduler.ml +++ b/src/dune_engine/scheduler.ml @@ -118,6 +118,7 @@ end (** The event queue *) module Event : sig type build_input_change = + | Sync | Fs_event of Fs_memo.Event.t | Invalidation of Memo.Invalidation.t @@ -170,6 +171,7 @@ module Event : sig with type event := t end = struct type build_input_change = + | Sync | Fs_event of Fs_memo.Event.t | Invalidation of Memo.Invalidation.t @@ -295,6 +297,7 @@ end = struct let terminated = ref false in let events = List.filter_map events ~f:(function + | Filesystem_event Sync -> Some (Sync : build_input_change) | Invalidation invalidation -> Some (Invalidation invalidation : build_input_change) | Filesystem_event Watcher_terminated -> @@ -555,14 +558,25 @@ type waiting_for_file_changes = | Build_inputs_changed of Memo.Invalidation.t type status = - (* Waiting for file changes to start a new a build *) - | Waiting_for_file_changes of waiting_for_file_changes Fiber.Ivar.t - (* Running a build *) - | Building - (* Cancellation requested. Build jobs are immediately rejected in this state *) - | Restarting_build of Memo.Invalidation.t - (* Shut down requested. No new new builds will start *) - | Shutting_down + | (* Ready to start the next build. Waiting for a signal from the user, the + test harness, or the polling loop. The payload is the collection of + filesystem events. *) + Standing_by of + Memo.Invalidation.t + | (* Waiting for file changes to start a new a build *) + Waiting_for_file_changes of + waiting_for_file_changes Fiber.Ivar.t + | (* Waiting for the propagation of inotify events to finish before starting a + build. *) + Waiting_for_inotify_sync of + Memo.Invalidation.t * unit Fiber.Ivar.t + | (* Running a build *) + Building + | (* Cancellation requested. Build jobs are immediately rejected in this state *) + Restarting_build of + Memo.Invalidation.t + | (* Shut down requested. No new new builds will start *) + Shutting_down module Handler = struct module Event = struct @@ -621,7 +635,9 @@ let with_job_slot f = | Shutting_down -> raise (Memo.Non_reproducible Build_cancelled) | Building -> () - | Waiting_for_file_changes _ -> + | Waiting_for_file_changes _ + | Waiting_for_inotify_sync _ + | Standing_by _ -> (* At this stage, we're not running a build, so we shouldn't be running tasks here. *) assert false @@ -673,7 +689,14 @@ let prepare (config : Config.t) ~(handler : Handler.t) = Signal_watcher.init events; let process_watcher = Process_watcher.init events in let t = - { status = Building + { 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 @@ -703,6 +726,7 @@ end = struct match (event : Event.build_input_change) with | Invalidation invalidation -> invalidation | Fs_event event -> Fs_memo.Event.handle event + | Sync -> Memo.Invalidation.empty in let invalidation = let events = Nonempty_list.to_list events in @@ -735,7 +759,12 @@ end = struct let invalidation = (handle_invalidation_events events : Memo.Invalidation.t) in - match Memo.Invalidation.is_empty invalidation with + let have_sync = + List.exists (Nonempty_list.to_list events) ~f:(function + | (Sync : Event.build_input_change) -> true + | _ -> false) + in + match Memo.Invalidation.is_empty invalidation && not have_sync with | true -> iter t (* Ignore the event *) | false -> ( match t.status with @@ -746,13 +775,29 @@ end = struct (Memo.Invalidation.combine prev_invalidation invalidation); (* We're already cancelling build, so file change events don't matter *) iter t + | Standing_by prev_invalidation -> + t.status <- + Standing_by + (Memo.Invalidation.combine prev_invalidation invalidation); + iter t | Building -> t.handler t.config Build_interrupted; t.status <- Restarting_build invalidation; Process_watcher.killall t.process_watcher Sys.sigkill; iter t | Waiting_for_file_changes ivar -> - Fill (ivar, Build_inputs_changed invalidation))) + Fill (ivar, Build_inputs_changed invalidation) + | Waiting_for_inotify_sync (prev_invalidation, ivar) -> + let invalidation = + Memo.Invalidation.combine prev_invalidation invalidation + in + if have_sync then ( + t.status <- Standing_by invalidation; + Fill (ivar, ()) + ) else ( + t.status <- Waiting_for_inotify_sync (invalidation, ivar); + iter t + ))) | Worker_task fill -> fill | File_system_watcher_terminated -> filesystem_watcher_terminated (); @@ -836,41 +881,119 @@ module Run = struct module Event_queue = Event.Queue module Event = Handler.Event - let poll step = + module Build_outcome = struct + type t = + | Shutdown + | Cancelled_due_to_file_changes + | Finished of (unit, [ `Already_reported ]) Result.t + end + + let poll_iter t step = + (match t.status with + | Standing_by invalidations -> Memo.reset invalidations + | _ -> + Code_error.raise "[poll_iter]: expected the build status [Standing_by]" []); + t.status <- Building; + let+ res = step in + match t.status with + | Waiting_for_file_changes _ + | Waiting_for_inotify_sync _ + | Standing_by _ -> + (* We just finished a build, so there's no way this was set *) + assert false + | Shutting_down -> Build_outcome.Shutdown + | Restarting_build invalidations -> + t.status <- Standing_by invalidations; + Build_outcome.Cancelled_due_to_file_changes + | Building -> + let build_result : Handler.Event.build_result = + match res with + | Error `Already_reported -> Failure + | Ok _ -> Success + in + t.handler t.config (Build_finish build_result); + t.status <- Standing_by Memo.Invalidation.empty; + Build_outcome.Finished res + + type handle_outcome_result = + | Shutdown + | Proceed + + type step = (unit, [ `Already_reported ]) Result.t Fiber.t + + let poll_gen ~get_build_request = let* t = t () in - let rec loop () : unit Fiber.t = - t.status <- Building; - let* res = step in - match t.status with - | Waiting_for_file_changes _ -> - (* We just finished a build, so there's no way this was set *) - assert false - | Shutting_down -> Fiber.return () - | Restarting_build invalidations -> - Memo.reset invalidations; - loop () - | Building -> ( - let build_result : Handler.Event.build_result = - match res with - | Error _ -> Failure - | Ok _ -> Success - in - t.handler t.config (Build_finish build_result); - let ivar = Fiber.Ivar.create () in - t.status <- Waiting_for_file_changes ivar; - let* next = Fiber.Ivar.read ivar in - match next with - | Shutdown_requested -> Fiber.return () - | Build_inputs_changed invalidations -> ( - Memo.reset invalidations; - t.handler t.config Source_files_changed; - match res with - | Error `Already_reported - | Ok () -> - loop ())) + (match t.status with + | Building -> t.status <- Standing_by Memo.Invalidation.empty + | _ -> assert false); + let rec loop () = + let* (build_request : step), handle_outcome = get_build_request t in + let* res = poll_iter t build_request in + let* next = handle_outcome res in + match next with + | Shutdown -> Fiber.return () + | Proceed -> loop () in loop () + let poll step = + poll_gen ~get_build_request:(fun (t : t) -> + let handle_outcome (outcome : Build_outcome.t) = + match outcome with + | Shutdown -> Fiber.return Shutdown + | Cancelled_due_to_file_changes -> Fiber.return Proceed + | Finished _res -> ( + let ivar = Fiber.Ivar.create () in + t.status <- Waiting_for_file_changes ivar; + let* next = Fiber.Ivar.read ivar in + match next with + | Shutdown_requested -> Fiber.return Shutdown + | Build_inputs_changed invalidations -> + t.status <- Standing_by invalidations; + t.handler t.config Source_files_changed; + Fiber.return Proceed) + in + Fiber.return (step, handle_outcome)) + + let wait_for_inotify_sync t = + let ivar = Fiber.Ivar.create () in + match t.status with + | Standing_by invalidation -> + t.status <- Waiting_for_inotify_sync (invalidation, ivar); + Fiber.Ivar.read ivar + | _ -> assert false + + let do_inotify_sync t = + Dune_file_watcher.emit_sync (); + Console.print [ Pp.text "waiting for inotify sync" ]; + let+ () = wait_for_inotify_sync t in + Console.print [ Pp.text "waited for inotify sync" ]; + () + + module Build_outcome_for_rpc = struct + type t = + | Success + | Failure + end + + let poll_passive ~get_build_request = + poll_gen ~get_build_request:(fun t -> + let* request, response_ivar = get_build_request in + let+ () = do_inotify_sync t in + let handle_outcome (res : Build_outcome.t) = + let+ () = + Fiber.Ivar.fill response_ivar + (match res with + | Finished (Ok _) -> Build_outcome_for_rpc.Success + | Finished (Error _) + | Cancelled_due_to_file_changes + | Shutdown -> + Build_outcome_for_rpc.Failure) + in + Proceed + in + (request, handle_outcome)) + exception Shutdown_requested let go config ?(file_watcher = No_watcher) diff --git a/src/dune_engine/scheduler.mli b/src/dune_engine/scheduler.mli index 78f461ef92b..abf53a20c9e 100644 --- a/src/dune_engine/scheduler.mli +++ b/src/dune_engine/scheduler.mli @@ -59,14 +59,30 @@ module Run : sig exception Build_cancelled - (** Runs [once] in a loop, executing [finally] after every iteration, even if - Fiber.Never was encountered. + type step = (unit, [ `Already_reported ]) Result.t Fiber.t + + (** [poll once] runs [once] in a loop. If any source files change in the middle of iteration, it gets canceled. If [shutdown] is called, the current build will be canceled and new builds will not start. *) - val poll : (unit, [ `Already_reported ]) Result.t Fiber.t -> unit Fiber.t + val poll : step -> unit Fiber.t + + module Build_outcome_for_rpc : sig + type t = + | Success + | Failure + end + + (** [poll_passive] is similar to [poll], but it can be used to drive the + polling loop explicitly instead of starting new iterations automatically. + + The fiber [get_build_request] is run at the beginning of every iteration + to wait for the build signal. *) + val poll_passive : + get_build_request:(step * Build_outcome_for_rpc.t Fiber.Ivar.t) Fiber.t + -> unit Fiber.t val go : Config.t diff --git a/src/dune_engine/watch_mode_config.ml b/src/dune_engine/watch_mode_config.ml new file mode 100644 index 00000000000..96544b29590 --- /dev/null +++ b/src/dune_engine/watch_mode_config.ml @@ -0,0 +1,26 @@ +open Stdune + +type rebuild_trigger = + | Eager + | Passive + +type t = + | No + | Yes of rebuild_trigger + +let all = [ No; Yes Eager; Yes Passive ] + +let to_string = function + | No -> "no" + | Yes Eager -> "eager" + | Yes Passive -> "passive" + +let of_string s = + match s with + | "no" -> Ok No + | "eager" -> Ok (Yes Eager) + | "passive" -> Ok (Yes Passive) + | s -> + Error + (Printf.sprintf "invalid watch mode %S, should be one of: %s" s + (String.concat ~sep:", " (List.map ~f:to_string all))) diff --git a/src/dune_engine/watch_mode_config.mli b/src/dune_engine/watch_mode_config.mli new file mode 100644 index 00000000000..abf64ea0428 --- /dev/null +++ b/src/dune_engine/watch_mode_config.mli @@ -0,0 +1,11 @@ +type rebuild_trigger = + | Eager + | Passive + +type t = + | No + | Yes of rebuild_trigger + +val to_string : t -> string + +val of_string : string -> (t, string) Result.t diff --git a/src/dune_file_watcher/dune_file_watcher.ml b/src/dune_file_watcher/dune_file_watcher.ml index 9ef595d4b8c..08d9030e8e1 100644 --- a/src/dune_file_watcher/dune_file_watcher.ml +++ b/src/dune_file_watcher/dune_file_watcher.ml @@ -8,6 +8,7 @@ type t = module Event = struct type t = | File_changed of Path.t + | Sync | Watcher_terminated end @@ -85,10 +86,12 @@ module Inotify = struct | None -> Error "invalid message (event type missing)") end +let special_file_for_inotify_sync () = + Path.build (Path.Build.relative Path.Build.root "dune-inotify-sync") + let command ~root = - let excludes = - [ {|/_build|} - ; {|/_opam|} + let exclude_patterns = + [ {|/_opam|} ; {|/_esy|} ; {|/\..+|} ; {|~$|} @@ -96,7 +99,20 @@ let command ~root = ; {|4913|} (* https://github.com/neovim/neovim/issues/3460 *) ] in - let path = Path.to_string_maybe_quoted root in + let exclude_paths = + (* These paths should already exist on the filesystem when the watches are + initially set up, otherwise the @ has no effect for inotifywait. If + the file is deleted and re-created then "exclusion" is lost. This is why + we're not including "_opam" and "_esy" in this list, in case they are + created when dune is already running. *) + (* these paths are used as patterns for fswatch, so they better not contain + any regex-special characters *) + [ "_build" ] + in + let root = Path.to_string root in + let inotify_special_path = + Path.to_string (special_file_for_inotify_sync ()) + in match if Sys.linux then Bin.which ~path:(Env.path Env.initial) "inotifywait" @@ -105,20 +121,22 @@ let command ~root = with | Some inotifywait -> (* On Linux, use inotifywait. *) - let excludes = String.concat ~sep:"|" excludes in + let excludes = String.concat ~sep:"|" exclude_patterns in ( inotifywait - , [ "-r" - ; path - ; "--exclude" - ; excludes - ; "-e" - ; "close_write" - ; "-e" - ; "delete" - ; "--format" - ; "e:%e:%w%f" - ; "-m" - ] + , List.concat + [ [ "-r"; root ] + (* excluding with "@" is more efficient that using --exclude because + it avoids creating inotify watches altogether, while --exclude + merely filters the events after they are generated *) + ; List.map exclude_paths ~f:(fun path -> + "@" ^ Filename.concat root path) + ; [ inotify_special_path ] + ; [ "--exclude"; excludes ] + ; [ "-e"; "close_write" ] + ; [ "-e"; "delete" ] + ; [ "--format"; "e:%e:%w%f" ] + ; [ "-m" ] + ] , Inotify.parse_message , Some Inotify.wait_for_watches_established ) | None -> ( @@ -128,11 +146,13 @@ let command ~root = match Bin.which ~path:(Env.path Env.initial) "fswatch" with | Some fswatch -> let excludes = - List.concat_map excludes ~f:(fun x -> [ "--exclude"; x ]) + List.concat_map + (exclude_patterns @ List.map exclude_paths ~f:(fun p -> "/" ^ p)) + ~f:(fun x -> [ "--exclude"; x ]) in ( fswatch , [ "-r" - ; path + ; root ; "--event" ; "Created" ; "--event" @@ -140,6 +160,7 @@ let command ~root = ; "--event" ; "Removed" ] + @ [ "--include"; inotify_special_path ] @ excludes , (fun s -> Ok s) , None ) @@ -154,7 +175,14 @@ let command ~root = "Please install fswatch to enable watch mode.") ]) +let emit_sync () = Io.write_file (special_file_for_inotify_sync ()) "z" + +let prepare_sync () = + Path.mkdir_p (Path.parent_exn (special_file_for_inotify_sync ())); + emit_sync () + let spawn_external_watcher ~root = + prepare_sync (); let prog, args, parse_line, wait_for_start = command ~root in let prog = Path.to_absolute_filename prog in let argv = prog :: args in @@ -176,6 +204,7 @@ let spawn_external_watcher ~root = ((r_stdout, parse_line, wait), pid) let create_no_buffering ~(scheduler : Scheduler.t) ~root = + let special_file_for_inotify_sync = special_file_for_inotify_sync () in let (pipe, parse_line, wait), pid = spawn_external_watcher ~root in let worker_thread pipe = let buffer = Buffer.create ~capacity:buffer_capacity in @@ -187,7 +216,12 @@ let create_no_buffering ~(scheduler : Scheduler.t) ~root = List.map lines ~f:(fun line -> match parse_line line with | Error s -> failwith s - | Ok path -> Event.File_changed (Path.of_string path)) + | Ok path -> + let path = Path.of_string path in + if Path.( = ) path special_file_for_inotify_sync then + Event.Sync + else + Event.File_changed path) in scheduler.thread_safe_send_events lines done diff --git a/src/dune_file_watcher/dune_file_watcher.mli b/src/dune_file_watcher/dune_file_watcher.mli index 1b574ad7024..06c3c645d1f 100644 --- a/src/dune_file_watcher/dune_file_watcher.mli +++ b/src/dune_file_watcher/dune_file_watcher.mli @@ -5,6 +5,7 @@ type t module Event : sig type t = | File_changed of Path.t + | Sync | Watcher_terminated end @@ -34,6 +35,11 @@ val pid : t -> Pid.t val wait_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 + far. *) +val emit_sync : unit -> unit + module For_tests : sig val suspend : t -> unit diff --git a/src/dune_rpc_impl/run.ml b/src/dune_rpc_impl/run.ml index f5de789a424..52083ce8d1d 100644 --- a/src/dune_rpc_impl/run.ml +++ b/src/dune_rpc_impl/run.ml @@ -142,3 +142,6 @@ let client p init ~on_notification ~f = let* c = Connect.csexp_client p in let* session = Csexp_rpc.Client.connect_exn c in Client.connect_raw session init ~on_notification ~f + +let client_with_session init ~session ~on_notification ~f = + Client.connect_raw session init ~on_notification ~f diff --git a/src/dune_rpc_impl/run.mli b/src/dune_rpc_impl/run.mli index cf4b165942b..e1e49e1b507 100644 --- a/src/dune_rpc_impl/run.mli +++ b/src/dune_rpc_impl/run.mli @@ -29,6 +29,14 @@ val client : -> f:(Client.t -> 'a Fiber.t) -> 'a Fiber.t +(** Like [client], but start with an already-established session. *) +val client_with_session : + Dune_rpc.Initialize.Request.t + -> session:Csexp_rpc.Session.t + -> on_notification:(Dune_rpc.Call.t -> unit Fiber.t) + -> f:(Client.t -> 'a Fiber.t) + -> 'a Fiber.t + module Connect : sig (** [csexp_client t path] connects to [path] and returns the client. diff --git a/src/dune_rpc_impl/server.ml b/src/dune_rpc_impl/server.ml index d8a977cc8e2..d256c9e9c0b 100644 --- a/src/dune_rpc_impl/server.ml +++ b/src/dune_rpc_impl/server.ml @@ -5,15 +5,16 @@ open Dune_rpc_private module Dep_conf = Dune_rules.Dep_conf module Build_system = Dune_engine.Build_system -module Status = struct - type t = - | Accepted - | Rejected +module Build_outcome = struct + type t = Dune_engine.Scheduler.Run.Build_outcome_for_rpc.t = + | Success + | Failure - let sexp = Conv.enum [ ("Accepted", Accepted); ("Rejected", Rejected) ] + let sexp = Conv.enum [ ("Success", Success); ("Failure", Failure) ] end -type pending_build_action = Build of Dep_conf.t list * Status.t Fiber.Ivar.t +type pending_build_action = + | Build of Dep_conf.t list * Build_outcome.t Fiber.Ivar.t let diagnostic_of_error : Build_system.Error.t -> Dune_rpc_private.Diagnostic.t = @@ -61,7 +62,8 @@ let dep_parser = module Decl = struct module Decl = Decl - let build = Decl.request ~method_:"build" Conv.(list string) Status.sexp + let build = + Decl.request ~method_:"build" Conv.(list string) Build_outcome.sexp let shutdown = Decl.notification ~method_:"shutdown" Conv.unit @@ -128,9 +130,59 @@ module Subscribers = struct Fiber.parallel_iter_set (module Session_set) set ~f end +(** Primitive unbounded FIFO channel. Reads are blocking. Writes are not + blocking. At most one read is allowed at a time. *) +module Job_queue : sig + type 'a t + + (** Remove the element from the internal queue without waiting for the next + element. *) + val pop_internal : 'a t -> 'a option + + val create : unit -> 'a t + + val read : 'a t -> 'a Fiber.t + + val write : 'a t -> 'a -> unit Fiber.t +end = struct + (* invariant: if reader is Some then queue is empty *) + type 'a t = + { queue : 'a Queue.t + ; mutable reader : 'a Fiber.Ivar.t option + } + + let create () = { queue = Queue.create (); reader = None } + + let pop_internal t = Queue.pop t.queue + + let read t = + Fiber.of_thunk (fun () -> + match t.reader with + | Some _ -> + Code_error.raise "multiple concurrent reads of build job queue" [] + | None -> ( + match Queue.pop t.queue with + | None -> + let ivar = Fiber.Ivar.create () in + t.reader <- Some ivar; + Fiber.Ivar.read ivar + | Some v -> Fiber.return v)) + + let write t elem = + Fiber.of_thunk (fun () -> + match t.reader with + | Some ivar -> + t.reader <- None; + Fiber.Ivar.fill ivar elem + | None -> + Queue.push t.queue elem; + Fiber.return ()) +end + type t = { config : Run.Config.t - ; pending_build_jobs : (Dep_conf.t list * Status.t Fiber.Ivar.t) Queue.t + ; pending_build_jobs : + (Dep_conf.t list * Build_outcome.t Fiber.Ivar.t) Job_queue.t ; build_handler : Build_system.Handler.t ; pool : Fiber.Pool.t ; mutable subscribers : Subscribers.t @@ -169,21 +221,29 @@ let handler (t : t Fdecl.t) : 'a Dune_rpc_server.Handler.t = let ivar = Fiber.Ivar.create () in let targets = List.map targets ~f:(fun s -> - Dune_lang.Decoder.parse dep_parser Univ_map.empty + Dune_lang.Decoder.parse dep_parser + (Univ_map.set Univ_map.empty + Dune_engine.String_with_vars.decoding_env_key + (* CR-someday aalekseyev: hardcoding the version here is not + ideal, but it will do for now since this command is not + stable and we're only using it in tests. *) + (Dune_engine.Pform.Env.initial (3, 0))) (Dune_lang.Parser.parse_string ~fname:"dune rpc" ~mode:Dune_lang.Parser.Mode.Single s)) in - Queue.push (Fdecl.get t).pending_build_jobs (targets, ivar); + let* () = + Job_queue.write (Fdecl.get t).pending_build_jobs (targets, ivar) + in Fiber.Ivar.read ivar in Handler.request rpc (Handler.callback Handler.private_ build) Decl.build in let () = let rec cancel_pending_jobs () = - match Queue.pop (Fdecl.get t).pending_build_jobs with + match Job_queue.pop_internal (Fdecl.get t).pending_build_jobs with | None -> Fiber.return () | Some (_, job) -> - let* () = Fiber.Ivar.fill job Status.Rejected in + let* () = Fiber.Ivar.fill job Build_outcome.Failure in cancel_pending_jobs () in let shutdown () = @@ -299,7 +359,7 @@ let build_event t (event : Build_system.Handler.event) = let create () = let t = Fdecl.create Dyn.Encoder.opaque in - let pending_build_jobs = Queue.create () in + let pending_build_jobs = Job_queue.create () in let handler = Dune_rpc_server.make (handler t) in let pool = Fiber.Pool.create () in let config = Run.Config.Server { handler; backlog = 10; pool } in @@ -322,5 +382,5 @@ let create () = let config t = t.config let pending_build_action t = - Queue.pop t.pending_build_jobs - |> Option.map ~f:(fun (targets, ivar) -> Build (targets, ivar)) + Job_queue.read t.pending_build_jobs + |> Fiber.map ~f:(fun (targets, ivar) -> Build (targets, ivar)) diff --git a/src/dune_rpc_impl/server.mli b/src/dune_rpc_impl/server.mli index 2e868f67614..d7538b64f8c 100644 --- a/src/dune_rpc_impl/server.mli +++ b/src/dune_rpc_impl/server.mli @@ -2,16 +2,16 @@ open Dune_rpc_private type t -module Status : sig - type t = - | Accepted - | Rejected +module Build_outcome : sig + type t = Dune_engine.Scheduler.Run.Build_outcome_for_rpc.t = + | Success + | Failure end module Decl : sig open Dune_rpc_private.Decl - val build : (string list, Status.t) request + val build : (string list, Build_outcome.t) request val shutdown : unit notification @@ -29,6 +29,6 @@ val config : t -> Run.Config.t val build_handler : t -> Dune_engine.Build_system.Handler.t type pending_build_action = - | Build of Dune_rules.Dep_conf.t list * Status.t Fiber.Ivar.t + | Build of Dune_rules.Dep_conf.t list * Build_outcome.t Fiber.Ivar.t -val pending_build_action : t -> pending_build_action option +val pending_build_action : t -> pending_build_action Fiber.t diff --git a/test/blackbox-tests/test-cases/dune b/test/blackbox-tests/test-cases/dune index 94b6fd0cb29..1b1d50765af 100644 --- a/test/blackbox-tests/test-cases/dune +++ b/test/blackbox-tests/test-cases/dune @@ -121,3 +121,10 @@ (executable (libraries stdune spawn) (name test))) + +(subdir + watching + ; macos CI does not have fswatch installed + (cram + (enabled_if + (<> "macosx" %{ocaml-config:system})))) 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 new file mode 100644 index 00000000000..0a4374889e7 --- /dev/null +++ b/test/blackbox-tests/test-cases/watching/test-1.t/run.t @@ -0,0 +1,71 @@ + $ DUNE_RUNNING=0 + + $ start_dune () { + > ((dune build "$@" --watch=passive > dune-output 2>&1) || (echo exit $? >> dune-output)) & + > DUNE_PID=$!; + > DUNE_RUNNING=1; + > } + + $ with_timeout () { + > timeout 2 "$@" + > exit_code=$? + > if [ "$exit_code" = 124 ] + > then + > printf "Timed out" + > else + > return "$exit_code" + > fi + > } + + $ build () { + > with_timeout dune rpc build --wait "$@" + > } + +---------------------------------------------------------------------------------- +* Compile a simple rule + + $ echo "(lang dune 2.0)" > dune-project + + $ cat > x < original-contents + > EOF + + $ cat >dune < (rule + > (target y) + > (deps x) + > (action (bash "cat x > y"))) + > EOF + + $ start_dune + + $ build y + Success + $ cat _build/default/y + original-contents + + $ echo new-contents > x + + $ build y + Success + $ cat _build/default/y + new-contents + + $ echo new-contents2 > x + + $ build y + Success + $ cat _build/default/y + new-contents2 + + $ with_timeout dune shutdown + $ cat dune-output + waiting for inotify sync + waited for inotify sync + Success, waiting for filesystem changes... + waiting for inotify sync + waited for inotify sync + Success, 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 0b0a6c89219..a31bb6d896c 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 @@ -104,6 +104,7 @@ let%expect_test _ = events_buffer := []; 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.Watcher_terminated -> assert false))) in diff --git a/vendor/cmdliner/src/cmdliner_cline.ml b/vendor/cmdliner/src/cmdliner_cline.ml index 9752abde030..fb6b606e03e 100644 --- a/vendor/cmdliner/src/cmdliner_cline.ml +++ b/vendor/cmdliner/src/cmdliner_cline.ml @@ -101,8 +101,8 @@ let parse_opt_args ~peek_opts optidx cl args = match Cmdliner_trie.find optidx name with | `Ok a -> let value, args = match value, Cmdliner_info.arg_opt_kind a with - | Some v, Cmdliner_info.Flag when is_short_opt name -> - None, ("-" ^ v) :: args + | Some v, (Cmdliner_info.Flag | Opt_vopt _) when is_short_opt name -> + None, ("-" ^ v) :: args | Some _, _ -> value, args | None, Cmdliner_info.Flag -> value, args | None, _ ->