diff --git a/bin/build.ml b/bin/build.ml index 95ee28fa998..62fce29c983 100644 --- a/bin/build.ml +++ b/bin/build.ml @@ -92,11 +92,16 @@ let poll_handling_rpc_build_requests ~(common : Common.t) ~config = in Dune_engine.Scheduler.Run.poll_passive ~get_build_request: - (let+ (Build (targets, ivar)) = Dune_rpc_impl.Server.pending_build_action rpc in + (let+ { kind; outcome } = Dune_rpc_impl.Server.pending_action rpc in let request setup = - Target.interpret_targets (Common.root common) config setup targets + let root = Common.root common in + match kind with + | Build targets -> + Target.interpret_targets (Common.root common) config setup targets + | Runtest dir_or_cram_test_paths -> + Runtest_common.make_request ~dir_or_cram_test_paths ~to_cwd:root.to_cwd setup in - run_build_system ~common ~request, ivar) + run_build_system ~common ~request, outcome) ;; let run_build_command_poll_eager ~(common : Common.t) ~config ~request : unit = @@ -138,10 +143,10 @@ let run_build_command ~(common : Common.t) ~config ~request = ~request ;; -let build_via_rpc_server ~print_on_success ~targets = +let build_via_rpc_server ~print_on_success ~targets builder lock_held_by = Rpc.Rpc_common.wrap_build_outcome_exn ~print_on_success - (Rpc.Group.Build.build ~wait:true) + (Rpc.Group.Build.build ~wait:true builder lock_held_by) targets () ;; @@ -199,11 +204,9 @@ let build = perform the RPC call. *) Rpc.Rpc_common.run_via_rpc - ~builder ~common ~config - lock_held_by - (Rpc.Group.Build.build ~wait:true) + (Rpc.Group.Build.build ~wait:true builder lock_held_by) targets | Ok () -> let request setup = diff --git a/bin/build.mli b/bin/build.mli index eadbc98076c..b7f2cf000c9 100644 --- a/bin/build.mli +++ b/bin/build.mli @@ -8,6 +8,8 @@ open Import val build_via_rpc_server : print_on_success:bool -> targets:Dune_lang.Dep_conf.t list + -> Common.Builder.t + -> Dune_util.Global_lock.Lock_held_by.t -> unit Fiber.t val run_build_system diff --git a/bin/exec.ml b/bin/exec.ml index d768cf251ce..810859d2818 100644 --- a/bin/exec.ml +++ b/bin/exec.ml @@ -187,7 +187,7 @@ let step ~prog ~args ~common ~no_rebuild ~context ~on_exit () = directory lock. Returns the absolute path to the executable. *) -let build_prog_via_rpc_if_necessary ~dir ~no_rebuild prog = +let build_prog_via_rpc_if_necessary ~dir ~no_rebuild builder lock_held_by prog = match Filename.analyze_program_name prog with | In_path -> (* This case is reached if [dune exec] is passed the name of an @@ -225,7 +225,11 @@ let build_prog_via_rpc_if_necessary ~dir ~no_rebuild prog = Dune_lang.Dep_conf.File (Dune_lang.String_with_vars.make_text Loc.none (Path.to_string path)) in - Build.build_via_rpc_server ~print_on_success:false ~targets:[ target ]) + Build.build_via_rpc_server + ~print_on_success:false + ~targets:[ target ] + builder + lock_held_by) in Path.to_absolute_filename path | Absolute -> @@ -234,7 +238,7 @@ let build_prog_via_rpc_if_necessary ~dir ~no_rebuild prog = else not_found ~hints:[] ~prog ;; -let exec_building_via_rpc_server ~common ~prog ~args ~no_rebuild = +let exec_building_via_rpc_server ~common ~prog ~args ~no_rebuild builder lock_held_by = let open Fiber.O in let ensure_terminal v = match (v : Cmd_arg.t) with @@ -252,7 +256,9 @@ let exec_building_via_rpc_server ~common ~prog ~args ~no_rebuild = let dir = Context_name.build_dir context in let prog = ensure_terminal prog in let args = List.map args ~f:ensure_terminal in - let+ prog = build_prog_via_rpc_if_necessary ~dir ~no_rebuild prog in + let+ prog = + build_prog_via_rpc_if_necessary ~dir ~no_rebuild builder lock_held_by prog + in restore_cwd_and_execve (Common.root common) prog args Env.initial ;; @@ -311,18 +317,9 @@ let term : unit Term.t = | Pid_from_lockfile pid -> sprintf " (pid: %d)" pid) ] | No -> - if not (Common.Builder.equal builder Common.Builder.default) - then - User_warning.emit - [ Pp.textf - "Your build request is being forwarded to a running Dune instance%s. Note \ - that certain command line arguments may be ignored." - (match lock_held_by with - | Unknown -> "" - | Pid_from_lockfile pid -> sprintf " (pid: %d)" pid) - ]; Scheduler.go_without_rpc_server ~common ~config - @@ fun () -> exec_building_via_rpc_server ~common ~prog ~args ~no_rebuild) + @@ fun () -> + exec_building_via_rpc_server ~common ~prog ~args ~no_rebuild builder lock_held_by) | Ok () -> exec_building_directly ~common ~config ~context ~prog ~args ~no_rebuild ;; diff --git a/bin/fmt.ml b/bin/fmt.ml index 03c5aed30b9..08ed08702e0 100644 --- a/bin/fmt.ml +++ b/bin/fmt.ml @@ -26,7 +26,7 @@ let lock_ocamlformat () = else Fiber.return () ;; -let run_fmt_command ~common ~config ~preview = +let run_fmt_command ~common ~config ~preview builder = let open Fiber.O in let once () = let* () = lock_ocamlformat () in @@ -50,6 +50,9 @@ let run_fmt_command ~common ~config ~preview = Rpc.Rpc_common.fire_request ~name:"format" ~wait:true + ~warn_forwarding:false + ~lock_held_by + builder Dune_rpc.Procedures.Public.format ()) in @@ -81,7 +84,7 @@ let command = Common.Builder.set_promote builder (if preview then Never else Automatically) in let common, config = Common.init builder in - run_fmt_command ~common ~config ~preview + run_fmt_command ~common ~config ~preview builder in Cmd.v (Cmd.info "fmt" ~doc ~man ~envs:Common.envs) term ;; diff --git a/bin/promotion.ml b/bin/promotion.ml index ede7884c494..ac868aeb2c1 100644 --- a/bin/promotion.ml +++ b/bin/promotion.ml @@ -63,13 +63,13 @@ module Apply = struct Diff_promotion.promote_files_registered_in_last_run files_to_promote) | Error lock_held_by -> Rpc.Rpc_common.run_via_rpc - ~builder ~common ~config - lock_held_by (Rpc.Rpc_common.fire_request ~name:"promote_many" ~wait:true + ~lock_held_by + builder Dune_rpc_private.Procedures.Public.promote_many) files_to_promote ;; diff --git a/bin/rpc/rpc_build.ml b/bin/rpc/rpc_build.ml index 81dd5d066e2..a751c2b9042 100644 --- a/bin/rpc/rpc_build.ml +++ b/bin/rpc/rpc_build.ml @@ -1,12 +1,18 @@ open Import -let build ~wait targets = +let build ~wait builder lock_held_by targets = let targets = List.map targets ~f:(fun target -> let sexp = Dune_lang.Dep_conf.encode target in Dune_lang.to_string sexp) in - Rpc_common.fire_request ~name:"build" ~wait Dune_rpc_impl.Decl.build targets + Rpc_common.fire_request + ~name:"build" + ~wait + ~lock_held_by + builder + Dune_rpc_impl.Decl.build + targets ;; let term = @@ -18,7 +24,7 @@ let term = @@ fun () -> let open Fiber.O in let+ response = - Rpc_common.fire_request ~name:"build" ~wait Dune_rpc_impl.Decl.build targets + Rpc_common.fire_request ~name:"build" ~wait builder Dune_rpc_impl.Decl.build targets in match response with | Error (error : Dune_rpc.Response.Error.t) -> diff --git a/bin/rpc/rpc_build.mli b/bin/rpc/rpc_build.mli index 73b1a078dd6..336f467c22a 100644 --- a/bin/rpc/rpc_build.mli +++ b/bin/rpc/rpc_build.mli @@ -6,6 +6,8 @@ open! Import running then raise a [User_error]. *) val build : wait:bool + -> Common.Builder.t + -> Dune_util.Global_lock.Lock_held_by.t -> Dune_lang.Dep_conf.t list -> (Dune_rpc.Build_outcome_with_diagnostics.t, Dune_rpc.Response.Error.t) result Fiber.t diff --git a/bin/rpc/rpc_common.ml b/bin/rpc/rpc_common.ml index 1d00e33b42f..d7572e91ffc 100644 --- a/bin/rpc/rpc_common.ml +++ b/bin/rpc/rpc_common.ml @@ -75,9 +75,30 @@ let establish_client_session ~wait = if wait then establish_connection_with_retry () else establish_connection_exn () ;; -let fire_request ~name ~wait request arg = +let warn_ignore_arguments lock_held_by = + User_warning.emit + [ Pp.paragraphf + "Your build request is being forwarded to a running Dune instance%s. Note that \ + certain command line arguments may be ignored." + (match lock_held_by with + | Dune_util.Global_lock.Lock_held_by.Unknown -> "" + | Pid_from_lockfile pid -> sprintf " (pid: %d)" pid) + ] +;; + +let fire_request + ~name + ~wait + ?(warn_forwarding = true) + ?(lock_held_by = Dune_util.Global_lock.Lock_held_by.Unknown) + builder + request + arg + = let open Fiber.O in let* connection = establish_client_session ~wait in + if warn_forwarding && not (Common.Builder.equal builder Common.Builder.default) + then warn_ignore_arguments lock_held_by; Dune_rpc_impl.Client.client connection (Dune_rpc.Initialize.Request.create ~id:(Dune_rpc.Id.make (Sexp.Atom name))) @@ -107,20 +128,7 @@ let wrap_build_outcome_exn ~print_on_success f args () = Console.print [ error_msg |> Pp.tag User_message.Style.Error ] ;; -let warn_ignore_arguments lock_held_by = - User_warning.emit - [ Pp.paragraphf - "Your build request is being forwarded to a running Dune instance%s. Note that \ - certain command line arguments may be ignored." - (match lock_held_by with - | Dune_util.Global_lock.Lock_held_by.Unknown -> "" - | Pid_from_lockfile pid -> sprintf " (pid: %d)" pid) - ] -;; - -let run_via_rpc ~builder ~common ~config lock_held_by f args = - if not (Common.Builder.equal builder Common.Builder.default) - then warn_ignore_arguments lock_held_by; +let run_via_rpc ~common ~config f args = Scheduler.go_without_rpc_server ~common ~config diff --git a/bin/rpc/rpc_common.mli b/bin/rpc/rpc_common.mli index 201bbf0fe39..cb370d2b291 100644 --- a/bin/rpc/rpc_common.mli +++ b/bin/rpc/rpc_common.mli @@ -22,10 +22,16 @@ val client_term : Common.Builder.t -> (unit -> 'a Fiber.t) -> 'a val wait_term : bool Cmdliner.Term.t (** Send a request to the RPC server. If [wait], it will poll forever until a server is listening. - Should be scheduled by a scheduler that does not come with a RPC server on its own. *) + Should be scheduled by a scheduler that does not come with a RPC server on its own. + + [warn_forwarding] defaults to true, warns the user that since a RPC server is running, some arguments are ignored. + [lock_held_by] defaults to [Unknown], is only used to allow error messages to print the PID. *) val fire_request : name:string -> wait:bool + -> ?warn_forwarding:bool + -> ?lock_held_by:Dune_util.Global_lock.Lock_held_by.t + -> Common.Builder.t -> ('a, 'b) Dune_rpc.Decl.request -> 'a -> ('b, Dune_rpc.Response.Error.t) result Fiber.t @@ -44,10 +50,8 @@ val warn_ignore_arguments : Dune_util.Global_lock.Lock_held_by.t -> unit (** Schedule a fiber to run via RPC, wrapping any errors. *) val run_via_rpc - : builder:Common.Builder.t - -> common:Common.t + : common:Common.t -> config:Dune_config_file.Dune_config.t - -> Dune_util.Global_lock.Lock_held_by.t -> ('a -> (Dune_rpc.Build_outcome_with_diagnostics.t, Dune_rpc.Response.Error.t) result Fiber.t) diff --git a/bin/rpc/rpc_ping.ml b/bin/rpc/rpc_ping.ml index 12fcda12eb1..f131f51c210 100644 --- a/bin/rpc/rpc_ping.ml +++ b/bin/rpc/rpc_ping.ml @@ -18,6 +18,7 @@ let term = Rpc_common.fire_request ~name:"ping_cmd" ~wait + builder Dune_rpc_private.Procedures.Public.ping () >>| function diff --git a/bin/runtest.ml b/bin/runtest.ml index f5a64fbc047..612aef491ca 100644 --- a/bin/runtest.ml +++ b/bin/runtest.ml @@ -33,129 +33,33 @@ let runtest_info = Cmd.info "runtest" ~doc ~man ~envs:Common.envs ;; -let find_cram_test path ~parent_dir = - let open Memo.O in - Source_tree.find_dir parent_dir - >>= function - | None -> Memo.return None - | Some dir -> - Dune_rules.Cram_rules.cram_tests dir - >>| List.find_map ~f:(function - | Ok cram_test when Path.Source.equal path (Source.Cram_test.path cram_test) -> - Some cram_test - (* We raise any error we encounter when looking for our test specifically. *) - | Error (Dune_rules.Cram_rules.Missing_run_t cram_test) - when Path.Source.equal path (Source.Cram_test.path cram_test) -> - Dune_rules.Cram_rules.missing_run_t cram_test - (* Any errors or successes unrelated to our test are discarded. *) - | Error (Dune_rules.Cram_rules.Missing_run_t _) | Ok _ -> None) -;; - -let explain_unsuccessful_search path ~parent_dir = - let open Memo.O in - (* If the user misspelled the test name, we give them a hint. *) - let+ hints = - (* We search for all files and directories in the parent directory and - suggest them as possible candidates. *) - let+ candidates = - let+ file_candidates = - let+ files = Source_tree.files_of parent_dir in - Path.Source.Set.to_list_map files ~f:Path.Source.to_string - and+ dir_candidates = - let* parent_source_dir = Source_tree.find_dir parent_dir in - match parent_source_dir with - | None -> Memo.return [] - | Some parent_source_dir -> - let dirs = Source_tree.Dir.sub_dirs parent_source_dir in - String.Map.to_list dirs - |> Memo.List.map ~f:(fun (_candidate, candidate_path) -> - Source_tree.Dir.sub_dir_as_t candidate_path - >>| Source_tree.Dir.path - >>| Path.Source.to_string) - in - List.concat [ file_candidates; dir_candidates ] - in - User_message.did_you_mean (Path.Source.to_string path) ~candidates - in - User_error.raise - ~hints - [ Pp.textf "%S does not match any known test." (Path.Source.to_string path) ] -;; - -(* [disambiguate_test_name path] is a function that takes in a - directory [path] and classifies it as either a cram test or a directory to - run tests in. *) -let disambiguate_test_name path = - match Path.Source.parent path with - | None -> Memo.return @@ `Runtest (Path.source Path.Source.root) - | Some parent_dir -> - let open Memo.O in - find_cram_test path ~parent_dir - >>= (function - | Some test -> - (* If we find the cram test, then we request that is run. *) - Memo.return (`Cram (parent_dir, test)) - | None -> - (* If we don't find it, then we assume the user intended a directory for - @runtest to be used. *) - Source_tree.find_dir path - >>= (function - (* We need to make sure that this directory or file exists. *) - | Some _ -> Memo.return (`Runtest (Path.source path)) - | None -> explain_unsuccessful_search path ~parent_dir)) -;; - let runtest_term = let name = Arg.info [] ~docv:"TEST" in let+ builder = Common.Builder.term - and+ dirs = Arg.(value & pos_all string [ "." ] name) in + and+ dir_or_cram_test_paths = Arg.(value & pos_all string [ "." ] name) in let common, config = Common.init builder in - let request (setup : Import.Main.build_system) = - let contexts = setup.contexts in - List.map dirs ~f:(fun dir -> - let dir = Path.of_string dir |> Path.Expert.try_localize_external in - let open Action_builder.O in - let* contexts, alias_kind = - match (Util.check_path contexts dir : Util.checked) with - | In_build_dir (context, dir) -> - let+ res = Action_builder.of_memo (disambiguate_test_name dir) in - [ context ], res - | In_source_dir dir -> - (* We need to adjust the path here to make up for the current working directory. *) - let { Workspace_root.to_cwd; _ } = Common.root common in - let dir = - Path.Source.L.relative Path.Source.root (to_cwd @ Path.Source.explode dir) - in - let+ res = Action_builder.of_memo (disambiguate_test_name dir) in - contexts, res - | In_private_context _ | In_install_dir _ -> - User_error.raise - [ Pp.textf - "This path is internal to dune: %s" - (Path.to_string_maybe_quoted dir) - ] - | External _ -> - User_error.raise - [ Pp.textf - "This path is outside the workspace: %s" - (Path.to_string_maybe_quoted dir) - ] - in - Alias.request - @@ - match alias_kind with - | `Cram (dir, cram) -> - let alias_name = Source.Cram_test.name cram in - Alias.in_dir - ~name:(Dune_engine.Alias.Name.of_string alias_name) - ~recursive:false - ~contexts - (Path.source dir) - | `Runtest dir -> - Alias.in_dir ~name:Dune_rules.Alias.runtest ~recursive:true ~contexts dir) - |> Action_builder.all_unit - in - Build.run_build_command ~common ~config ~request + match Dune_util.Global_lock.lock ~timeout:None with + | Ok () -> + Build.run_build_command + ~common + ~config + ~request: + (Runtest_common.make_request + ~dir_or_cram_test_paths + ~to_cwd:(Common.root common).to_cwd) + | Error lock_held_by -> + Scheduler.go_without_rpc_server + ~common + ~config + (Rpc.Rpc_common.wrap_build_outcome_exn + ~print_on_success:true + (Rpc.Rpc_common.fire_request + ~name:"runtest" + ~wait:false + ~lock_held_by + builder + Dune_rpc.Procedures.Public.runtest) + dir_or_cram_test_paths) ;; let commands = diff --git a/bin/runtest_common.ml b/bin/runtest_common.ml new file mode 100644 index 00000000000..c2c279e9962 --- /dev/null +++ b/bin/runtest_common.ml @@ -0,0 +1,116 @@ +open! Import + +let find_cram_test path ~parent_dir = + let open Memo.O in + Source_tree.find_dir parent_dir + >>= function + | None -> Memo.return None + | Some dir -> + Dune_rules.Cram_rules.cram_tests dir + >>| List.find_map ~f:(function + | Ok cram_test when Path.Source.equal path (Source.Cram_test.path cram_test) -> + Some cram_test + (* We raise any error we encounter when looking for our test specifically. *) + | Error (Dune_rules.Cram_rules.Missing_run_t cram_test) + when Path.Source.equal path (Source.Cram_test.path cram_test) -> + Dune_rules.Cram_rules.missing_run_t cram_test + (* Any errors or successes unrelated to our test are discarded. *) + | Error (Dune_rules.Cram_rules.Missing_run_t _) | Ok _ -> None) +;; + +let explain_unsuccessful_search path ~parent_dir = + let open Memo.O in + (* If the user misspelled the test name, we give them a hint. *) + let+ hints = + (* We search for all files and directories in the parent directory and + suggest them as possible candidates. *) + let+ candidates = + let+ file_candidates = + let+ files = Source_tree.files_of parent_dir in + Path.Source.Set.to_list_map files ~f:Path.Source.to_string + and+ dir_candidates = + let* parent_source_dir = Source_tree.find_dir parent_dir in + match parent_source_dir with + | None -> Memo.return [] + | Some parent_source_dir -> + let dirs = Source_tree.Dir.sub_dirs parent_source_dir in + String.Map.to_list dirs + |> Memo.List.map ~f:(fun (_candidate, candidate_path) -> + Source_tree.Dir.sub_dir_as_t candidate_path + >>| Source_tree.Dir.path + >>| Path.Source.to_string) + in + List.concat [ file_candidates; dir_candidates ] + in + User_message.did_you_mean (Path.Source.to_string path) ~candidates + in + User_error.raise + ~hints + [ Pp.textf "%S does not match any known test." (Path.Source.to_string path) ] +;; + +(* [disambiguate_test_name path] is a function that takes in a + directory [path] and classifies it as either a cram test or a directory to + run tests in. *) +let disambiguate_test_name path = + match Path.Source.parent path with + | None -> Memo.return @@ `Runtest (Path.source Path.Source.root) + | Some parent_dir -> + let open Memo.O in + find_cram_test path ~parent_dir + >>= (function + | Some test -> + (* If we find the cram test, then we request that is run. *) + Memo.return (`Cram (parent_dir, test)) + | None -> + (* If we don't find it, then we assume the user intended a directory for + @runtest to be used. *) + Source_tree.find_dir path + >>= (function + (* We need to make sure that this directory or file exists. *) + | Some _ -> Memo.return (`Runtest (Path.source path)) + | None -> explain_unsuccessful_search path ~parent_dir)) +;; + +let make_request ~dir_or_cram_test_paths ~to_cwd (setup : Import.Main.build_system) = + let contexts = setup.contexts in + List.map dir_or_cram_test_paths ~f:(fun dir -> + let dir = Path.of_string dir |> Path.Expert.try_localize_external in + let open Action_builder.O in + let* contexts, alias_kind = + match (Util.check_path contexts dir : Util.checked) with + | In_build_dir (context, dir) -> + let+ res = Action_builder.of_memo (disambiguate_test_name dir) in + [ context ], res + | In_source_dir dir -> + (* We need to adjust the path here to make up for the current working directory. *) + let dir = + Path.Source.L.relative Path.Source.root (to_cwd @ Path.Source.explode dir) + in + let+ res = Action_builder.of_memo (disambiguate_test_name dir) in + contexts, res + | In_private_context _ | In_install_dir _ -> + User_error.raise + [ Pp.textf "This path is internal to dune: %s" (Path.to_string_maybe_quoted dir) + ] + | External _ -> + User_error.raise + [ Pp.textf + "This path is outside the workspace: %s" + (Path.to_string_maybe_quoted dir) + ] + in + Alias.request + @@ + match alias_kind with + | `Cram (dir, cram) -> + let alias_name = Source.Cram_test.name cram in + Alias.in_dir + ~name:(Dune_engine.Alias.Name.of_string alias_name) + ~recursive:false + ~contexts + (Path.source dir) + | `Runtest dir -> + Alias.in_dir ~name:Dune_rules.Alias.runtest ~recursive:true ~contexts dir) + |> Action_builder.all_unit +;; diff --git a/bin/runtest_common.mli b/bin/runtest_common.mli new file mode 100644 index 00000000000..5c0cda0bc47 --- /dev/null +++ b/bin/runtest_common.mli @@ -0,0 +1,10 @@ +open! Import + +(** [make_request ~dir_or_cram_test_paths ~to_cwd] returns a function suitable + for passing to [Build_cmd.run_build_system] which runs the tests referred + to by the elements of [dir_or_cram_test_paths]. *) +val make_request + : dir_or_cram_test_paths:string list + -> to_cwd:string list + -> Dune_rules.Main.build_system + -> unit Action_builder.t diff --git a/bin/tools/tools_common.ml b/bin/tools/tools_common.ml index 8d721e4bfdb..6d1c2fd9bbc 100644 --- a/bin/tools/tools_common.ml +++ b/bin/tools/tools_common.ml @@ -33,18 +33,22 @@ let build_dev_tool_directly common dev_tool = | Ok () -> () ;; -let build_dev_tool_via_rpc dev_tool = +let build_dev_tool_via_rpc builder lock_held_by dev_tool = let target = dev_tool_build_target dev_tool in - Build.build_via_rpc_server ~print_on_success:false ~targets:[ target ] + Build.build_via_rpc_server + ~print_on_success:false + ~targets:[ target ] + builder + lock_held_by ;; -let lock_and_build_dev_tool ~common ~config dev_tool = +let lock_and_build_dev_tool ~common ~config builder dev_tool = let open Fiber.O in match Dune_util.Global_lock.lock ~timeout:None with - | Error _lock_held_by -> + | Error lock_held_by -> Scheduler.go_without_rpc_server ~common ~config (fun () -> let* () = Lock_dev_tool.lock_dev_tool dev_tool |> Memo.run in - build_dev_tool_via_rpc dev_tool) + build_dev_tool_via_rpc builder lock_held_by dev_tool) | Ok () -> Scheduler.go_with_rpc_server ~common ~config (fun () -> build_dev_tool_directly common dev_tool) @@ -62,8 +66,8 @@ let run_dev_tool workspace_root dev_tool ~args = restore_cwd_and_execve workspace_root exe_path_string args env ;; -let lock_build_and_run_dev_tool ~common ~config dev_tool ~args = - lock_and_build_dev_tool ~common ~config dev_tool; +let lock_build_and_run_dev_tool ~common ~config builder dev_tool ~args = + lock_and_build_dev_tool ~common ~config builder dev_tool; run_dev_tool (Common.root common) dev_tool ~args ;; @@ -106,7 +110,7 @@ let install_command dev_tool = let term = let+ builder = Common.Builder.term in let common, config = Common.init builder in - lock_and_build_dev_tool ~common ~config dev_tool + lock_and_build_dev_tool ~common ~config builder dev_tool in let info = let doc = sprintf "Install %s as a dev tool" exe_name in @@ -121,7 +125,7 @@ let exec_command dev_tool = let+ builder = Common.Builder.term and+ args = Arg.(value & pos_all string [] (info [] ~docv:"ARGS")) in let common, config = Common.init builder in - lock_build_and_run_dev_tool ~common ~config dev_tool ~args + lock_build_and_run_dev_tool ~common ~config builder dev_tool ~args in let info = let doc = diff --git a/bin/tools/tools_common.mli b/bin/tools/tools_common.mli index 3009caad76c..443d5cd254a 100644 --- a/bin/tools/tools_common.mli +++ b/bin/tools/tools_common.mli @@ -6,6 +6,7 @@ open! Import val lock_build_and_run_dev_tool : common:Common.t -> config:Dune_config_file.Dune_config.t + -> Common.Builder.t -> Dune_pkg.Dev_tool.t -> args:string list -> 'a diff --git a/otherlibs/dune-rpc/private/dune_rpc_private.ml b/otherlibs/dune-rpc/private/dune_rpc_private.ml index 51344ab5d15..420d7b90bf5 100644 --- a/otherlibs/dune-rpc/private/dune_rpc_private.ml +++ b/otherlibs/dune-rpc/private/dune_rpc_private.ml @@ -620,6 +620,7 @@ module Client = struct Builder.declare_request t Procedures.Public.promote; Builder.declare_request t Procedures.Public.promote_many; Builder.declare_request t Procedures.Public.build_dir; + Builder.declare_request t Procedures.Public.runtest; Builder.implement_notification t Procedures.Server_side.abort (fun () -> handler.abort); Builder.implement_notification t Procedures.Server_side.log (fun () -> handler.log); diff --git a/otherlibs/dune-rpc/private/dune_rpc_private.mli b/otherlibs/dune-rpc/private/dune_rpc_private.mli index 9c991e4fde0..efd9a26eb76 100644 --- a/otherlibs/dune-rpc/private/dune_rpc_private.mli +++ b/otherlibs/dune-rpc/private/dune_rpc_private.mli @@ -202,6 +202,7 @@ module Procedures : sig : (Files_to_promote.t, Build_outcome_with_diagnostics.t) Decl.Request.t val build_dir : (unit, Path.t) Decl.Request.t + val runtest : (string list, Build_outcome_with_diagnostics.t) Decl.Request.t end module Server_side : sig @@ -248,6 +249,7 @@ module Public : sig val promote : (Path.t, unit) t val promote_many : (Files_to_promote.t, Build_outcome_with_diagnostics.t) t val build_dir : (unit, Path.t) t + val runtest : (string list, Build_outcome_with_diagnostics.t) t end module Notification : sig diff --git a/otherlibs/dune-rpc/private/procedures.ml b/otherlibs/dune-rpc/private/procedures.ml index b1b5fce69df..4fb76689f71 100644 --- a/otherlibs/dune-rpc/private/procedures.ml +++ b/otherlibs/dune-rpc/private/procedures.ml @@ -77,6 +77,17 @@ module Public = struct let decl = Decl.Request.make ~method_:"build_dir" ~generations:[ v1 ] end + module Runtest = struct + let v1 = + Decl.Request.make_current_gen + ~req:Conv.(list string) + ~resp:Build_outcome_with_diagnostics.sexp + ~version:1 + ;; + + let decl = Decl.Request.make ~method_:"runtest" ~generations:[ v1 ] + end + let ping = Ping.decl let diagnostics = Diagnostics.decl let shutdown = Shutdown.decl @@ -85,6 +96,7 @@ module Public = struct let promote = Promote.decl let promote_many = Promote_many.decl let build_dir = Build_dir.decl + let runtest = Runtest.decl end module Server_side = struct diff --git a/otherlibs/dune-rpc/private/procedures.mli b/otherlibs/dune-rpc/private/procedures.mli index 77dddbaabad..ecd8539e5da 100644 --- a/otherlibs/dune-rpc/private/procedures.mli +++ b/otherlibs/dune-rpc/private/procedures.mli @@ -10,6 +10,7 @@ module Public : sig val promote : (Path.t, unit) Decl.Request.t val promote_many : (Files_to_promote.t, Build_outcome_with_diagnostics.t) Decl.Request.t val build_dir : (unit, Path.t) Decl.Request.t + val runtest : (string list, Build_outcome_with_diagnostics.t) Decl.Request.t end module Server_side : sig diff --git a/otherlibs/dune-rpc/private/public.ml b/otherlibs/dune-rpc/private/public.ml index d27e8b39cc6..4f793795c43 100644 --- a/otherlibs/dune-rpc/private/public.ml +++ b/otherlibs/dune-rpc/private/public.ml @@ -11,6 +11,7 @@ module Request = struct let promote = Procedures.Public.promote.decl let promote_many = Procedures.Public.promote_many.decl let build_dir = Procedures.Public.build_dir.decl + let runtest = Procedures.Public.runtest.decl end module Notification = struct diff --git a/src/dune_rpc_impl/server.ml b/src/dune_rpc_impl/server.ml index eda6d490388..0d3fc831a62 100644 --- a/src/dune_rpc_impl/server.ml +++ b/src/dune_rpc_impl/server.ml @@ -107,8 +107,14 @@ module Run = struct ;; end -type 'build_arg pending_build_action = - | Build of 'build_arg list * Dune_engine.Scheduler.Run.Build_outcome.t Fiber.Ivar.t +type 'build_arg pending_action_kind = + | Build of 'build_arg list + | Runtest of string list + +type 'build_arg pending_action = + { kind : 'build_arg pending_action_kind + ; outcome : Dune_engine.Scheduler.Run.Build_outcome.t Fiber.Ivar.t + } module Client = Stdune.Unit @@ -191,7 +197,7 @@ end type 'build_arg t = { config : Run.t - ; pending_build_jobs : ('build_arg list * Build_outcome.t Fiber.Ivar.t) Job_queue.t + ; pending_jobs : 'build_arg pending_action Job_queue.t ; parse_build_arg : string -> 'build_arg ; mutable clients : Clients.t } @@ -326,18 +332,27 @@ let handler (t : _ t Fdecl.t) handle : 'build_arg Dune_rpc_server.Handler.t = Handler.declare_notification rpc Procedures.Server_side.log in let () = Handler.implement_request rpc Procedures.Public.ping (fun _ -> Fiber.return) in - let () = - let f _ targets = + let implement_request_pending_action decl ~f = + let handler _session input = let server = Fdecl.get t in - let ivar = Fiber.Ivar.create () in - let targets = List.map targets ~f:server.parse_build_arg in - let* () = Job_queue.write server.pending_build_jobs (targets, ivar) in - let+ build_outcome = Fiber.Ivar.read ivar in + let outcome = Fiber.Ivar.create () in + let* () = Job_queue.write server.pending_jobs { kind = f input; outcome } in + let+ build_outcome = Fiber.Ivar.read outcome in match (build_outcome : Build_outcome.t) with | Success -> Dune_rpc.Build_outcome_with_diagnostics.Success | Failure -> Failure (get_current_diagnostic_errors ()) in - Handler.implement_request rpc Decl.build f + Handler.implement_request rpc decl handler + in + let () = + implement_request_pending_action Decl.build ~f:(fun targets -> + let server = Fdecl.get t in + let targets = List.map targets ~f:server.parse_build_arg in + Build targets) + in + let () = + implement_request_pending_action Procedures.Public.runtest ~f:(fun paths -> + Runtest paths) in let () = let f _ () = @@ -346,7 +361,9 @@ let handler (t : _ t Fdecl.t) handle : 'build_arg Dune_rpc_server.Handler.t = let target = Dune_lang.Dep_conf.Alias_rec (Dune_lang.String_with_vars.make_text Loc.none "fmt") in - let* () = Job_queue.write server.pending_build_jobs ([ target ], outcome) in + let* () = + Job_queue.write server.pending_jobs { kind = Build [ target ]; outcome } + in let+ build_outcome = Fiber.Ivar.read outcome in match build_outcome with (* A 'successful' formatting means there is nothing to promote. *) @@ -359,10 +376,10 @@ let handler (t : _ t Fdecl.t) handle : 'build_arg Dune_rpc_server.Handler.t = in let () = let rec cancel_pending_jobs () = - match Job_queue.pop_internal (Fdecl.get t).pending_build_jobs with + match Job_queue.pop_internal (Fdecl.get t).pending_jobs with | None -> Fiber.return () - | Some (_, job) -> - let* () = Fiber.Ivar.fill job Build_outcome.Failure in + | Some { kind = _; outcome } -> + let* () = Fiber.Ivar.fill outcome Build_outcome.Failure in cancel_pending_jobs () in let shutdown _ () = @@ -430,7 +447,7 @@ let handler (t : _ t Fdecl.t) handle : 'build_arg Dune_rpc_server.Handler.t = let create ~lock_timeout ~registry ~root ~handle stats ~parse_build_arg = let t = Fdecl.create Dyn.opaque in - let pending_build_jobs = Job_queue.create () in + let pending_jobs = Job_queue.create () in let handler = Dune_rpc_server.make (handler t handle) in let pool = Fiber.Pool.create () in let where = Where.default () in @@ -466,7 +483,7 @@ let create ~lock_timeout ~registry ~root ~handle stats ~parse_build_arg = ; server_ivar = Fiber.Ivar.create () } in - let res = { config; pending_build_jobs; clients = Clients.empty; parse_build_arg } in + let res = { config; pending_jobs; clients = Clients.empty; parse_build_arg } in Fdecl.set t res; res ;; @@ -476,7 +493,4 @@ let run t = Run.run t.config ;; -let pending_build_action t = - Job_queue.read t.pending_build_jobs - |> Fiber.map ~f:(fun (targets, ivar) -> Build (targets, ivar)) -;; +let pending_action t = Job_queue.read t.pending_jobs diff --git a/src/dune_rpc_impl/server.mli b/src/dune_rpc_impl/server.mli index 60201e47604..3dca36e3444 100644 --- a/src/dune_rpc_impl/server.mli +++ b/src/dune_rpc_impl/server.mli @@ -13,15 +13,21 @@ val create -> parse_build_arg:(string -> Dune_lang.Dep_conf.t) -> Dune_lang.Dep_conf.t t +type 'build_arg pending_action_kind = + | Build of 'build_arg list + | Runtest of string list + (** This type allows the build request handler to be defined externally to the - RPC server. The ivar is expected to be filled with the outcome of the build - by the build request handler when the build completes (successfully or not) - and triggers the RPC server to reply to the client with the outcome of their - request. *) -type 'build_arg pending_build_action = - | Build of 'build_arg list * Dune_engine.Scheduler.Run.Build_outcome.t Fiber.Ivar.t + RPC server. The [outcome] ivar is expected to be filled with the outcome of + the build by the build request handler when the build completes + (successfully or not) and triggers the RPC server to reply to the client + with the outcome of their request. *) +type 'build_arg pending_action = + { kind : 'build_arg pending_action_kind + ; outcome : Dune_engine.Scheduler.Run.Build_outcome.t Fiber.Ivar.t + } -val pending_build_action : 'build_arg t -> 'build_arg pending_build_action Fiber.t +val pending_action : 'build_arg t -> 'build_arg pending_action Fiber.t (** Stop accepting new rpc connections. Fiber returns when all existing connections terminate *) diff --git a/test/blackbox-tests/test-cases/cram/custom-build-dir.t b/test/blackbox-tests/test-cases/cram/custom-build-dir.t index 68e74c2d6b6..8a951275e77 100644 --- a/test/blackbox-tests/test-cases/cram/custom-build-dir.t +++ b/test/blackbox-tests/test-cases/cram/custom-build-dir.t @@ -21,7 +21,8 @@ path $TESTCASE_ROOT/tmp/default/foo.t.corrected to foo.t. [1] - $ sed -E '/\(pid: [0-9]+\)/{s//(pid: ###)/; s/instance.*/.../g; q;}' foo.t + $ cat foo.t $ echo " $ echo bar" >bar.t $ dune runtest - Error: A running dune (pid: ###) ... + Error: RPC server not running. + [1] diff --git a/test/blackbox-tests/test-cases/watching/watching-eager-concurrent-runtest-command.t b/test/blackbox-tests/test-cases/watching/watching-eager-concurrent-runtest-command.t new file mode 100644 index 00000000000..e3928889f11 --- /dev/null +++ b/test/blackbox-tests/test-cases/watching/watching-eager-concurrent-runtest-command.t @@ -0,0 +1,36 @@ +Demonstrate running "dune runtest" concurrently with an eager rpc server. + + $ echo '(lang dune 3.18)' > dune-project + +Define a test that just prints "Hello, World!" + $ cat > dune << 'EOF' + > (rule + > (alias runtest) + > (action (echo "Hello, World!"))) + > EOF + + $ dune build --watch & + Success, waiting for filesystem changes... + Success, waiting for filesystem changes... + Success, waiting for filesystem changes... + Hello, World! + +Make sure the RPC server is properly started: + $ dune rpc ping --wait + Server appears to be responding normally + +Test that we can run a test while another instance of dune is running in watch +mode: + $ dune runtest 2>&1 + Success + +Test that passing extra arguments to `dune runtest` prints a warning when +running concurrently with another instance of dune in watch mode: + $ dune runtest --auto-promote 2>&1 | sed 's/[0-9]*)/PID)/g' + Warning: + Your build request is being forwarded to a running Dune instance (pid: + PID). Note that certain command line arguments may be ignored. + Success + + $ dune shutdown + $ wait