From d53615a04290d188bd2e689a2809b8daae7aeba2 Mon Sep 17 00:00:00 2001 From: Ambre Austen Suhamy Date: Fri, 12 Sep 2025 18:20:55 +0200 Subject: [PATCH 1/7] Allow running tests concurrently with watch server Signed-off-by: Ambre Austen Suhamy --- bin/build.ml | 10 +- bin/rpc/group.ml | 1 + bin/rpc/group.mli | 1 + bin/rpc/rpc.ml | 1 + bin/rpc/rpc_build.ml | 5 + bin/rpc/rpc_common.mli | 2 + bin/rpc/runtest_rpc.ml | 9 + bin/rpc/runtest_rpc.mli | 7 + bin/runtest.ml | 160 +++++------------- bin/runtest_common.ml | 112 ++++++++++++ bin/runtest_common.mli | 9 + src/dune_rpc_impl/client.ml | 2 +- src/dune_rpc_impl/decl.ml | 12 ++ src/dune_rpc_impl/decl.mli | 1 + src/dune_rpc_impl/server.ml | 53 +++--- src/dune_rpc_impl/server.mli | 20 ++- test/blackbox-tests/test-cases/watching/dune | 3 +- ...atching-eager-concurrent-runtest-command.t | 34 ++++ 18 files changed, 293 insertions(+), 149 deletions(-) create mode 100644 bin/rpc/runtest_rpc.ml create mode 100644 bin/rpc/runtest_rpc.mli create mode 100644 bin/runtest_common.ml create mode 100644 bin/runtest_common.mli create mode 100644 test/blackbox-tests/test-cases/watching/watching-eager-concurrent-runtest-command.t diff --git a/bin/build.ml b/bin/build.ml index 95ee28fa998..c3f13ba3e4b 100644 --- a/bin/build.ml +++ b/bin/build.ml @@ -92,11 +92,15 @@ 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+ pending_action = Dune_rpc_impl.Server.pending_action rpc in let request setup = - Target.interpret_targets (Common.root common) config setup targets + match pending_action.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 setup in - run_build_system ~common ~request, ivar) + run_build_system ~common ~request, pending_action.outcome) ;; let run_build_command_poll_eager ~(common : Common.t) ~config ~request : unit = diff --git a/bin/rpc/group.ml b/bin/rpc/group.ml index 5867b10314f..47d4570d5db 100644 --- a/bin/rpc/group.ml +++ b/bin/rpc/group.ml @@ -14,3 +14,4 @@ let info = let group = Cmd.group info [ Rpc_status.cmd; Rpc_build.cmd; Rpc_ping.cmd ] module Build = Rpc_build +module Runtest_rpc = Runtest_rpc diff --git a/bin/rpc/group.mli b/bin/rpc/group.mli index 31ec57129bf..4f464a5dbe9 100644 --- a/bin/rpc/group.mli +++ b/bin/rpc/group.mli @@ -2,3 +2,4 @@ val group : unit Cmdliner.Cmd.t module Build = Rpc_build +module Runtest_rpc = Runtest_rpc diff --git a/bin/rpc/rpc.ml b/bin/rpc/rpc.ml index 839470cc088..09ff25cb0f7 100644 --- a/bin/rpc/rpc.ml +++ b/bin/rpc/rpc.ml @@ -3,3 +3,4 @@ module Rpc_build = Rpc_build module Rpc_common = Rpc_common module Rpc_ping = Rpc_ping module Rpc_status = Rpc_status +module Runtest_rpc = Runtest_rpc diff --git a/bin/rpc/rpc_build.ml b/bin/rpc/rpc_build.ml index 81dd5d066e2..7384ef176b3 100644 --- a/bin/rpc/rpc_build.ml +++ b/bin/rpc/rpc_build.ml @@ -1,5 +1,10 @@ open Import +(* TODO: remove comment? +Sends a request to build [targets] to the RPC server at [where]. The targets + are specified as strings containing sexp-encoded targets that are passed to + this command as arguments on the command line. *) + let build ~wait targets = let targets = List.map targets ~f:(fun target -> diff --git a/bin/rpc/rpc_common.mli b/bin/rpc/rpc_common.mli index 201bbf0fe39..f8c24297f3c 100644 --- a/bin/rpc/rpc_common.mli +++ b/bin/rpc/rpc_common.mli @@ -18,6 +18,8 @@ val request_exn (** Cmdliner term for a generic RPC client. *) val client_term : Common.Builder.t -> (unit -> 'a Fiber.t) -> 'a +val establish_client_session : wait:bool -> Dune_rpc_client.Client.Connection.t Fiber.t + (** Cmdliner argument for a wait flag. *) val wait_term : bool Cmdliner.Term.t diff --git a/bin/rpc/runtest_rpc.ml b/bin/rpc/runtest_rpc.ml new file mode 100644 index 00000000000..17ffab30aef --- /dev/null +++ b/bin/rpc/runtest_rpc.ml @@ -0,0 +1,9 @@ +open! Import + +let runtest ~wait ~dir_or_cram_test_paths = + Rpc_common.fire_request + ~name:"runtest" + ~wait + Dune_rpc_impl.Decl.runtest + dir_or_cram_test_paths +;; diff --git a/bin/rpc/runtest_rpc.mli b/bin/rpc/runtest_rpc.mli new file mode 100644 index 00000000000..30b7426a0de --- /dev/null +++ b/bin/rpc/runtest_rpc.mli @@ -0,0 +1,7 @@ +open! Import + +(** Sends a request to run the specified tests on the RPC server at [where]. *) +val runtest + : wait:bool + -> dir_or_cram_test_paths:string list + -> (Dune_rpc.Build_outcome_with_diagnostics.t, Dune_rpc.Response.Error.t) result Fiber.t diff --git a/bin/runtest.ml b/bin/runtest.ml index f5a64fbc047..10cd0d7a572 100644 --- a/bin/runtest.ml +++ b/bin/runtest.ml @@ -33,129 +33,55 @@ 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_via_rpc_server ~dir_or_cram_test_paths = + let open Fiber.O in + let+ response = Rpc.Runtest_rpc.runtest ~wait:true ~dir_or_cram_test_paths in + match response with + | Error (error : Dune_rpc_private.Response.Error.t) -> + Printf.eprintf + "Error: %s\n%!" + (Dyn.to_string (Dune_rpc_private.Response.Error.to_dyn error)) + | Ok Success -> + Console.print_user_message + (User_message.make [ Pp.text "Success" |> Pp.tag User_message.Style.Success ]) + | Ok (Failure errors) -> + List.iter errors ~f:(fun { Dune_rpc.Compound_user_error.main; _ } -> + Console.print_user_message main); + User_error.raise + [ (match List.length errors with + | 0 -> + Code_error.raise + "Runtest via RPC failed, but the RPC server did not send an error message." + [] + | 1 -> Pp.textf "Build failed with 1 error." + | n -> Pp.textf "Build failed with %d errors." n) + ] ;; 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 + | Error lock_held_by -> + Scheduler.go_without_rpc_server ~common ~config (fun () -> + 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 so \ + most command-line arguments will be ignored." + (match (lock_held_by : Dune_util.Global_lock.Lock_held_by.t) with + | Unknown -> "" + | Pid_from_lockfile pid -> sprintf " (pid: %d)" pid) + ]; + runtest_via_rpc_server ~dir_or_cram_test_paths) + | Ok () -> + Build.run_build_command + ~common + ~config + ~request:(Runtest_common.make_request ~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..6a22a6b8d6c --- /dev/null +++ b/bin/runtest_common.ml @@ -0,0 +1,112 @@ +open! Import + +let find_cram_test path ~parent_dir = + let open Memo.O in + Source_tree.nearest_dir parent_dir + >>= Dune_rules.Cram_rules.cram_tests + (* We ignore the errors we get when searching for cram tests as they will + be reported during building anyway. We are only interested in the + presence of cram tests. *) + >>| List.filter_map ~f:Result.to_option + (* We search our list of known cram tests for the test we are looking + for. *) + >>| List.find ~f:(fun (test : Source.Cram_test.t) -> + let src = + match test with + | File src -> src + | Dir { dir = src; _ } -> src + in + Path.Source.equal path src) +;; + +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 (`Test (parent_dir, Source.Cram_test.name 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 (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 -> + 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 + | `Test (dir, alias_name) -> + 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..faf2478e109 --- /dev/null +++ b/bin/runtest_common.mli @@ -0,0 +1,9 @@ +open! Import + +(** [make_request ~dir_or_cram_test_paths] 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 + -> Dune_rules.Main.build_system + -> unit Action_builder.t diff --git a/src/dune_rpc_impl/client.ml b/src/dune_rpc_impl/client.ml index 739dfbc43cf..f01ea7ac474 100644 --- a/src/dune_rpc_impl/client.ml +++ b/src/dune_rpc_impl/client.ml @@ -3,7 +3,7 @@ open Import let client ?handler connection init ~f = Client.client ?handler - ~private_menu:[ Request Decl.build; Request Decl.status ] + ~private_menu:[ Request Decl.build; Request Decl.status; Request Decl.runtest ] connection init ~f diff --git a/src/dune_rpc_impl/decl.ml b/src/dune_rpc_impl/decl.ml index f81507803c2..4ca23bd3edd 100644 --- a/src/dune_rpc_impl/decl.ml +++ b/src/dune_rpc_impl/decl.ml @@ -49,5 +49,17 @@ module Build = struct let decl = Decl.Request.make ~method_:"build" ~generations:[ v1; v2 ] end +module Runtest = struct + let v1 = + Decl.Request.make_current_gen + ~req:(Conv.list Conv.string) + ~resp:Build_outcome_with_diagnostics.sexp_v2 + ~version:1 + ;; + + let decl = Decl.Request.make ~method_:"runtest" ~generations:[ v1 ] +end + let build = Build.decl let status = Status.decl +let runtest = Runtest.decl diff --git a/src/dune_rpc_impl/decl.mli b/src/dune_rpc_impl/decl.mli index f4ac536bc82..a6d81afda8e 100644 --- a/src/dune_rpc_impl/decl.mli +++ b/src/dune_rpc_impl/decl.mli @@ -19,3 +19,4 @@ end val build : (string list, Build_outcome_with_diagnostics.t) Decl.Request.t val status : (unit, Status.t) Decl.Request.t +val runtest : (string list, Build_outcome_with_diagnostics.t) Decl.Request.t diff --git a/src/dune_rpc_impl/server.ml b/src/dune_rpc_impl/server.ml index eda6d490388..c8314f495fb 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,26 @@ 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 Decl.runtest ~f:(fun paths -> Runtest paths) in let () = let f _ () = @@ -346,7 +360,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 +375,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 pending_action -> + let* () = Fiber.Ivar.fill pending_action.outcome Build_outcome.Failure in cancel_pending_jobs () in let shutdown _ () = @@ -430,7 +446,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 +482,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 +492,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/watching/dune b/test/blackbox-tests/test-cases/watching/dune index dee67dc09f9..5c17c1e5867 100644 --- a/test/blackbox-tests/test-cases/watching/dune +++ b/test/blackbox-tests/test-cases/watching/dune @@ -30,5 +30,6 @@ (cram (applies_to watching-eager-concurrent-build-command - watching-eager-concurrent-exec-command) + watching-eager-concurrent-exec-command + watching-eager-concurrent-runtest-command) (enabled_if false)) 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..7ea39fc5dc2 --- /dev/null +++ b/test/blackbox-tests/test-cases/watching/watching-eager-concurrent-runtest-command.t @@ -0,0 +1,34 @@ +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 + +Build the project once before starting the watch server so the watch server +starts immediately. + $ dune build + $ dune build --watch & + Success, waiting for filesystem changes... + Success, waiting for filesystem changes... + Success, waiting for filesystem changes... + Hello, World! + +Test that we can run a test while another instance of dune is running in watch +mode: + $ dune runtest 2>&1 | sed 's/pid: [0-9]*/pid: PID/g' + 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/pid: [0-9]*/pid: PID/g' + Warning: Your build request is being forwarded to a running Dune instance + (pid: PID) so most command-line arguments will be ignored. + Success + + $ dune shutdown + $ wait From 9e0fa789af45c35ef745ec1886c7bcd38d55bbbf Mon Sep 17 00:00:00 2001 From: Ambre Austen Suhamy Date: Fri, 12 Sep 2025 19:37:11 +0200 Subject: [PATCH 2/7] Un-private the runtest RPC method, like promote & fmt Signed-off-by: Ambre Austen Suhamy --- bin/rpc/group.ml | 1 - bin/rpc/group.mli | 1 - bin/rpc/rpc.ml | 1 - bin/rpc/runtest_rpc.ml | 9 ---- bin/rpc/runtest_rpc.mli | 7 --- bin/runtest.ml | 49 +++++-------------- .../dune-rpc/private/dune_rpc_private.ml | 1 + .../dune-rpc/private/dune_rpc_private.mli | 2 + otherlibs/dune-rpc/private/procedures.ml | 12 +++++ otherlibs/dune-rpc/private/procedures.mli | 1 + otherlibs/dune-rpc/private/public.ml | 1 + src/dune_rpc_impl/client.ml | 2 +- src/dune_rpc_impl/decl.ml | 12 ----- src/dune_rpc_impl/decl.mli | 1 - src/dune_rpc_impl/server.ml | 3 +- 15 files changed, 31 insertions(+), 72 deletions(-) delete mode 100644 bin/rpc/runtest_rpc.ml delete mode 100644 bin/rpc/runtest_rpc.mli diff --git a/bin/rpc/group.ml b/bin/rpc/group.ml index 47d4570d5db..5867b10314f 100644 --- a/bin/rpc/group.ml +++ b/bin/rpc/group.ml @@ -14,4 +14,3 @@ let info = let group = Cmd.group info [ Rpc_status.cmd; Rpc_build.cmd; Rpc_ping.cmd ] module Build = Rpc_build -module Runtest_rpc = Runtest_rpc diff --git a/bin/rpc/group.mli b/bin/rpc/group.mli index 4f464a5dbe9..31ec57129bf 100644 --- a/bin/rpc/group.mli +++ b/bin/rpc/group.mli @@ -2,4 +2,3 @@ val group : unit Cmdliner.Cmd.t module Build = Rpc_build -module Runtest_rpc = Runtest_rpc diff --git a/bin/rpc/rpc.ml b/bin/rpc/rpc.ml index 09ff25cb0f7..839470cc088 100644 --- a/bin/rpc/rpc.ml +++ b/bin/rpc/rpc.ml @@ -3,4 +3,3 @@ module Rpc_build = Rpc_build module Rpc_common = Rpc_common module Rpc_ping = Rpc_ping module Rpc_status = Rpc_status -module Runtest_rpc = Runtest_rpc diff --git a/bin/rpc/runtest_rpc.ml b/bin/rpc/runtest_rpc.ml deleted file mode 100644 index 17ffab30aef..00000000000 --- a/bin/rpc/runtest_rpc.ml +++ /dev/null @@ -1,9 +0,0 @@ -open! Import - -let runtest ~wait ~dir_or_cram_test_paths = - Rpc_common.fire_request - ~name:"runtest" - ~wait - Dune_rpc_impl.Decl.runtest - dir_or_cram_test_paths -;; diff --git a/bin/rpc/runtest_rpc.mli b/bin/rpc/runtest_rpc.mli deleted file mode 100644 index 30b7426a0de..00000000000 --- a/bin/rpc/runtest_rpc.mli +++ /dev/null @@ -1,7 +0,0 @@ -open! Import - -(** Sends a request to run the specified tests on the RPC server at [where]. *) -val runtest - : wait:bool - -> dir_or_cram_test_paths:string list - -> (Dune_rpc.Build_outcome_with_diagnostics.t, Dune_rpc.Response.Error.t) result Fiber.t diff --git a/bin/runtest.ml b/bin/runtest.ml index 10cd0d7a572..adb91e22a56 100644 --- a/bin/runtest.ml +++ b/bin/runtest.ml @@ -33,55 +33,28 @@ let runtest_info = Cmd.info "runtest" ~doc ~man ~envs:Common.envs ;; -let runtest_via_rpc_server ~dir_or_cram_test_paths = - let open Fiber.O in - let+ response = Rpc.Runtest_rpc.runtest ~wait:true ~dir_or_cram_test_paths in - match response with - | Error (error : Dune_rpc_private.Response.Error.t) -> - Printf.eprintf - "Error: %s\n%!" - (Dyn.to_string (Dune_rpc_private.Response.Error.to_dyn error)) - | Ok Success -> - Console.print_user_message - (User_message.make [ Pp.text "Success" |> Pp.tag User_message.Style.Success ]) - | Ok (Failure errors) -> - List.iter errors ~f:(fun { Dune_rpc.Compound_user_error.main; _ } -> - Console.print_user_message main); - User_error.raise - [ (match List.length errors with - | 0 -> - Code_error.raise - "Runtest via RPC failed, but the RPC server did not send an error message." - [] - | 1 -> Pp.textf "Build failed with 1 error." - | n -> Pp.textf "Build failed with %d errors." n) - ] -;; - let runtest_term = let name = Arg.info [] ~docv:"TEST" in let+ builder = Common.Builder.term and+ dir_or_cram_test_paths = Arg.(value & pos_all string [ "." ] name) in let common, config = Common.init builder in match Dune_util.Global_lock.lock ~timeout:None with - | Error lock_held_by -> - Scheduler.go_without_rpc_server ~common ~config (fun () -> - 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 so \ - most command-line arguments will be ignored." - (match (lock_held_by : Dune_util.Global_lock.Lock_held_by.t) with - | Unknown -> "" - | Pid_from_lockfile pid -> sprintf " (pid: %d)" pid) - ]; - runtest_via_rpc_server ~dir_or_cram_test_paths) | Ok () -> Build.run_build_command ~common ~config ~request:(Runtest_common.make_request ~dir_or_cram_test_paths) + | Error lock_held_by -> + Rpc.Rpc_common.run_via_rpc + ~builder + ~common + ~config + lock_held_by + (Rpc.Rpc_common.fire_request + ~name:"runtest" + ~wait:true + Dune_rpc.Procedures.Public.runtest) + dir_or_cram_test_paths ;; let commands = 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..78a9319829d 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 Conv.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/client.ml b/src/dune_rpc_impl/client.ml index f01ea7ac474..739dfbc43cf 100644 --- a/src/dune_rpc_impl/client.ml +++ b/src/dune_rpc_impl/client.ml @@ -3,7 +3,7 @@ open Import let client ?handler connection init ~f = Client.client ?handler - ~private_menu:[ Request Decl.build; Request Decl.status; Request Decl.runtest ] + ~private_menu:[ Request Decl.build; Request Decl.status ] connection init ~f diff --git a/src/dune_rpc_impl/decl.ml b/src/dune_rpc_impl/decl.ml index 4ca23bd3edd..f81507803c2 100644 --- a/src/dune_rpc_impl/decl.ml +++ b/src/dune_rpc_impl/decl.ml @@ -49,17 +49,5 @@ module Build = struct let decl = Decl.Request.make ~method_:"build" ~generations:[ v1; v2 ] end -module Runtest = struct - let v1 = - Decl.Request.make_current_gen - ~req:(Conv.list Conv.string) - ~resp:Build_outcome_with_diagnostics.sexp_v2 - ~version:1 - ;; - - let decl = Decl.Request.make ~method_:"runtest" ~generations:[ v1 ] -end - let build = Build.decl let status = Status.decl -let runtest = Runtest.decl diff --git a/src/dune_rpc_impl/decl.mli b/src/dune_rpc_impl/decl.mli index a6d81afda8e..f4ac536bc82 100644 --- a/src/dune_rpc_impl/decl.mli +++ b/src/dune_rpc_impl/decl.mli @@ -19,4 +19,3 @@ end val build : (string list, Build_outcome_with_diagnostics.t) Decl.Request.t val status : (unit, Status.t) Decl.Request.t -val runtest : (string list, Build_outcome_with_diagnostics.t) Decl.Request.t diff --git a/src/dune_rpc_impl/server.ml b/src/dune_rpc_impl/server.ml index c8314f495fb..dc77655994f 100644 --- a/src/dune_rpc_impl/server.ml +++ b/src/dune_rpc_impl/server.ml @@ -351,7 +351,8 @@ let handler (t : _ t Fdecl.t) handle : 'build_arg Dune_rpc_server.Handler.t = Build targets) in let () = - implement_request_pending_action Decl.runtest ~f:(fun paths -> Runtest paths) + implement_request_pending_action Procedures.Public.runtest ~f:(fun paths -> + Runtest paths) in let () = let f _ () = From 58ac1159a7e68d16662c569b51d6b882d6b3c29f Mon Sep 17 00:00:00 2001 From: Ambre Austen Suhamy Date: Wed, 17 Sep 2025 19:01:05 +0200 Subject: [PATCH 3/7] Apply new commits to runtest_common Signed-off-by: Ambre Austen Suhamy --- bin/build.ml | 6 +-- bin/runtest.ml | 5 ++- bin/runtest_common.ml | 40 ++++++++++--------- bin/runtest_common.mli | 1 + src/dune_rpc_impl/server.ml | 12 +++++- .../test-cases/cram/custom-build-dir.t | 2 + 6 files changed, 42 insertions(+), 24 deletions(-) diff --git a/bin/build.ml b/bin/build.ml index c3f13ba3e4b..a86292f251e 100644 --- a/bin/build.ml +++ b/bin/build.ml @@ -94,11 +94,11 @@ let poll_handling_rpc_build_requests ~(common : Common.t) ~config = ~get_build_request: (let+ pending_action = Dune_rpc_impl.Server.pending_action rpc in let request setup = + let root = Common.root common in match pending_action.kind with - | Build targets -> - Target.interpret_targets (Common.root common) config setup targets + | Build targets -> Target.interpret_targets root config setup targets | Runtest dir_or_cram_test_paths -> - Runtest_common.make_request ~dir_or_cram_test_paths setup + Runtest_common.make_request ~dir_or_cram_test_paths ~to_cwd:root.to_cwd setup in run_build_system ~common ~request, pending_action.outcome) ;; diff --git a/bin/runtest.ml b/bin/runtest.ml index adb91e22a56..e56c5a111c8 100644 --- a/bin/runtest.ml +++ b/bin/runtest.ml @@ -43,7 +43,10 @@ let runtest_term = Build.run_build_command ~common ~config - ~request:(Runtest_common.make_request ~dir_or_cram_test_paths) + ~request: + (Runtest_common.make_request + ~dir_or_cram_test_paths + ~to_cwd:(Common.root common).to_cwd) | Error lock_held_by -> Rpc.Rpc_common.run_via_rpc ~builder diff --git a/bin/runtest_common.ml b/bin/runtest_common.ml index 6a22a6b8d6c..c2c279e9962 100644 --- a/bin/runtest_common.ml +++ b/bin/runtest_common.ml @@ -2,21 +2,20 @@ open! Import let find_cram_test path ~parent_dir = let open Memo.O in - Source_tree.nearest_dir parent_dir - >>= Dune_rules.Cram_rules.cram_tests - (* We ignore the errors we get when searching for cram tests as they will - be reported during building anyway. We are only interested in the - presence of cram tests. *) - >>| List.filter_map ~f:Result.to_option - (* We search our list of known cram tests for the test we are looking - for. *) - >>| List.find ~f:(fun (test : Source.Cram_test.t) -> - let src = - match test with - | File src -> src - | Dir { dir = src; _ } -> src - in - Path.Source.equal path src) + 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 = @@ -62,7 +61,7 @@ let disambiguate_test_name path = >>= (function | Some test -> (* If we find the cram test, then we request that is run. *) - Memo.return (`Test (parent_dir, Source.Cram_test.name test)) + 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. *) @@ -73,7 +72,7 @@ let disambiguate_test_name path = | None -> explain_unsuccessful_search path ~parent_dir)) ;; -let make_request ~dir_or_cram_test_paths (setup : Import.Main.build_system) = +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 @@ -84,6 +83,10 @@ let make_request ~dir_or_cram_test_paths (setup : Import.Main.build_system) = 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 _ -> @@ -100,7 +103,8 @@ let make_request ~dir_or_cram_test_paths (setup : Import.Main.build_system) = Alias.request @@ match alias_kind with - | `Test (dir, alias_name) -> + | `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 diff --git a/bin/runtest_common.mli b/bin/runtest_common.mli index faf2478e109..f6f3f02001e 100644 --- a/bin/runtest_common.mli +++ b/bin/runtest_common.mli @@ -5,5 +5,6 @@ open! Import 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/src/dune_rpc_impl/server.ml b/src/dune_rpc_impl/server.ml index dc77655994f..67006792359 100644 --- a/src/dune_rpc_impl/server.ml +++ b/src/dune_rpc_impl/server.ml @@ -351,8 +351,16 @@ let handler (t : _ t Fdecl.t) handle : 'build_arg Dune_rpc_server.Handler.t = Build targets) in let () = - implement_request_pending_action Procedures.Public.runtest ~f:(fun paths -> - Runtest paths) + let f _ paths = + let server = Fdecl.get t in + let outcome = Fiber.Ivar.create () in + let* () = Job_queue.write server.pending_jobs { kind = Runtest paths; outcome } in + let+ build_outcome = Fiber.Ivar.read outcome in + match build_outcome with + | Success -> Dune_rpc.Build_outcome_with_diagnostics.Success + | Failure -> Failure (get_current_diagnostic_errors ()) + in + Handler.implement_request rpc Procedures.Public.runtest f in let () = let f _ () = 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..1782847d673 100644 --- a/test/blackbox-tests/test-cases/cram/custom-build-dir.t +++ b/test/blackbox-tests/test-cases/cram/custom-build-dir.t @@ -10,6 +10,8 @@ path > $ dune runtest > EOF + $ dune rpc ping --wait + $ DUNE_BUILD_DIR=$PWD/tmp dune runtest --auto-promote File "foo.t", line 1, characters 0-0: Error: Files From 3c83c7c06880e486aa77f4ecaf5a0c803f6be861 Mon Sep 17 00:00:00 2001 From: Ambre Austen Suhamy Date: Wed, 17 Sep 2025 19:34:00 +0200 Subject: [PATCH 4/7] Fix comments Signed-off-by: Ambre Austen Suhamy --- bin/rpc/rpc_build.ml | 5 ----- bin/runtest_common.mli | 2 +- 2 files changed, 1 insertion(+), 6 deletions(-) diff --git a/bin/rpc/rpc_build.ml b/bin/rpc/rpc_build.ml index 7384ef176b3..81dd5d066e2 100644 --- a/bin/rpc/rpc_build.ml +++ b/bin/rpc/rpc_build.ml @@ -1,10 +1,5 @@ open Import -(* TODO: remove comment? -Sends a request to build [targets] to the RPC server at [where]. The targets - are specified as strings containing sexp-encoded targets that are passed to - this command as arguments on the command line. *) - let build ~wait targets = let targets = List.map targets ~f:(fun target -> diff --git a/bin/runtest_common.mli b/bin/runtest_common.mli index f6f3f02001e..5c0cda0bc47 100644 --- a/bin/runtest_common.mli +++ b/bin/runtest_common.mli @@ -1,6 +1,6 @@ open! Import -(** [make_request ~dir_or_cram_test_paths] returns a function suitable +(** [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 From 0cbe35494bd1863fd89d79ef5d18ce13c0d9ade3 Mon Sep 17 00:00:00 2001 From: Ambre Austen Suhamy Date: Wed, 17 Sep 2025 19:43:09 +0200 Subject: [PATCH 5/7] Un-public a function which didn't need it Signed-off-by: Ambre Austen Suhamy --- bin/rpc/rpc_common.mli | 2 -- 1 file changed, 2 deletions(-) diff --git a/bin/rpc/rpc_common.mli b/bin/rpc/rpc_common.mli index f8c24297f3c..201bbf0fe39 100644 --- a/bin/rpc/rpc_common.mli +++ b/bin/rpc/rpc_common.mli @@ -18,8 +18,6 @@ val request_exn (** Cmdliner term for a generic RPC client. *) val client_term : Common.Builder.t -> (unit -> 'a Fiber.t) -> 'a -val establish_client_session : wait:bool -> Dune_rpc_client.Client.Connection.t Fiber.t - (** Cmdliner argument for a wait flag. *) val wait_term : bool Cmdliner.Term.t From 4ad93479d95a94167829300f1d9108451e9a5acf Mon Sep 17 00:00:00 2001 From: Ambre Austen Suhamy Date: Tue, 30 Sep 2025 11:32:48 +0200 Subject: [PATCH 6/7] Without wait the behaviour is correct, the error message is missing though Signed-off-by: Ambre Austen Suhamy --- bin/build.ml | 6 +++--- bin/fmt.ml | 2 +- bin/promotion.ml | 8 ++++---- bin/rpc/rpc_common.ml | 8 ++++---- bin/rpc/rpc_common.mli | 6 +++--- bin/runtest.ml | 8 ++++---- test/blackbox-tests/test-cases/cram/custom-build-dir.t | 10 ++++++---- .../watching-eager-concurrent-runtest-command.t | 2 +- 8 files changed, 26 insertions(+), 24 deletions(-) diff --git a/bin/build.ml b/bin/build.ml index a86292f251e..45d78f3943d 100644 --- a/bin/build.ml +++ b/bin/build.ml @@ -203,10 +203,10 @@ let build = perform the RPC call. *) Rpc.Rpc_common.run_via_rpc - ~builder - ~common - ~config + builder lock_held_by + common + config (Rpc.Group.Build.build ~wait:true) targets | Ok () -> diff --git a/bin/fmt.ml b/bin/fmt.ml index 03c5aed30b9..30b149932e8 100644 --- a/bin/fmt.ml +++ b/bin/fmt.ml @@ -49,7 +49,7 @@ let run_fmt_command ~common ~config ~preview = Scheduler.go_without_rpc_server ~common ~config (fun () -> Rpc.Rpc_common.fire_request ~name:"format" - ~wait:true + ~wait:false Dune_rpc.Procedures.Public.format ()) in diff --git a/bin/promotion.ml b/bin/promotion.ml index ede7884c494..c1c5287f735 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 + builder lock_held_by + common + config (Rpc.Rpc_common.fire_request ~name:"promote_many" - ~wait:true + ~wait:false Dune_rpc_private.Procedures.Public.promote_many) files_to_promote ;; diff --git a/bin/rpc/rpc_common.ml b/bin/rpc/rpc_common.ml index 1d00e33b42f..8a76c6ebe91 100644 --- a/bin/rpc/rpc_common.ml +++ b/bin/rpc/rpc_common.ml @@ -84,9 +84,9 @@ let fire_request ~name ~wait request arg = ~f:(fun client -> request_exn client request arg) ;; -let wrap_build_outcome_exn ~print_on_success f args () = +let wrap_build_outcome_exn ~print_on_success f arg () = let open Fiber.O in - let+ response = f args in + let+ response = f arg in match response with | Error (error : Rpc_error.t) -> raise_rpc_error error | Ok Dune_rpc.Build_outcome_with_diagnostics.Success -> @@ -118,11 +118,11 @@ let warn_ignore_arguments lock_held_by = ] ;; -let run_via_rpc ~builder ~common ~config lock_held_by f args = +let run_via_rpc builder lock_held_by common config request arg = if not (Common.Builder.equal builder Common.Builder.default) then warn_ignore_arguments lock_held_by; Scheduler.go_without_rpc_server ~common ~config - (wrap_build_outcome_exn ~print_on_success:true f args) + (wrap_build_outcome_exn ~print_on_success:true request arg) ;; diff --git a/bin/rpc/rpc_common.mli b/bin/rpc/rpc_common.mli index 201bbf0fe39..5373cde87a7 100644 --- a/bin/rpc/rpc_common.mli +++ b/bin/rpc/rpc_common.mli @@ -44,10 +44,10 @@ 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 - -> config:Dune_config_file.Dune_config.t + : Common.Builder.t -> Dune_util.Global_lock.Lock_held_by.t + -> Common.t + -> Dune_config_file.Dune_config.t -> ('a -> (Dune_rpc.Build_outcome_with_diagnostics.t, Dune_rpc.Response.Error.t) result Fiber.t) diff --git a/bin/runtest.ml b/bin/runtest.ml index e56c5a111c8..2edb938c9d1 100644 --- a/bin/runtest.ml +++ b/bin/runtest.ml @@ -49,13 +49,13 @@ let runtest_term = ~to_cwd:(Common.root common).to_cwd) | Error lock_held_by -> Rpc.Rpc_common.run_via_rpc - ~builder - ~common - ~config + builder lock_held_by + common + config (Rpc.Rpc_common.fire_request ~name:"runtest" - ~wait:true + ~wait:false Dune_rpc.Procedures.Public.runtest) dir_or_cram_test_paths ;; 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 1782847d673..a32b3be84da 100644 --- a/test/blackbox-tests/test-cases/cram/custom-build-dir.t +++ b/test/blackbox-tests/test-cases/cram/custom-build-dir.t @@ -10,8 +10,6 @@ path > $ dune runtest > EOF - $ dune rpc ping --wait - $ DUNE_BUILD_DIR=$PWD/tmp dune runtest --auto-promote File "foo.t", line 1, characters 0-0: Error: Files @@ -23,7 +21,11 @@ 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 + $ sed -E 's/[0-9]+\)/###)/g' foo.t $ echo " $ echo bar" >bar.t $ dune runtest - Error: A running dune (pid: ###) ... + Warning: + Your build request is being forwarded to a running Dune instance (pid: + ###). Note that certain command line arguments may be ignored. + 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 index 7ea39fc5dc2..70e8a934740 100644 --- 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 @@ -20,7 +20,7 @@ starts immediately. Test that we can run a test while another instance of dune is running in watch mode: - $ dune runtest 2>&1 | sed 's/pid: [0-9]*/pid: PID/g' + $ dune runtest 2>&1 Success Test that passing extra arguments to `dune runtest` prints a warning when From 27412bcf3d8bc6393ac89bded7b556bea53db8e3 Mon Sep 17 00:00:00 2001 From: Ambre Austen Suhamy Date: Thu, 2 Oct 2025 20:34:33 +0200 Subject: [PATCH 7/7] Big refactoring in Rpc_common to unify all RPC calls, and fix incorrect error messages Signed-off-by: Ambre Austen Suhamy --- bin/build.ml | 29 +++-- bin/build.mli | 10 -- bin/diagnostics.ml | 40 +++---- bin/exec.ml | 36 +++--- bin/fmt.ml | 31 +++-- bin/promotion.ml | 24 ++-- bin/rpc/rpc_build.ml | 29 ++--- bin/rpc/rpc_build.mli | 11 +- bin/rpc/rpc_common.ml | 109 +++++++++++------- bin/rpc/rpc_common.mli | 44 +++---- bin/rpc/rpc_ping.ml | 23 ++-- bin/runtest.ml | 23 ++-- bin/shutdown.ml | 31 ++--- bin/tools/tools_common.ml | 29 +++-- bin/tools/tools_common.mli | 1 + src/dune_util/global_lock.ml | 23 ++-- src/dune_util/global_lock.mli | 1 + .../test-cases/cram/custom-build-dir.t | 7 +- 18 files changed, 242 insertions(+), 259 deletions(-) diff --git a/bin/build.ml b/bin/build.ml index 45d78f3943d..ae4c872c77e 100644 --- a/bin/build.ml +++ b/bin/build.ml @@ -142,14 +142,6 @@ let run_build_command ~(common : Common.t) ~config ~request = ~request ;; -let build_via_rpc_server ~print_on_success ~targets = - Rpc.Rpc_common.wrap_build_outcome_exn - ~print_on_success - (Rpc.Group.Build.build ~wait:true) - targets - () -;; - let build = let doc = "Build the given targets, or the default ones if none are given." in let man = @@ -202,13 +194,20 @@ let build = an RPC server in the background to schedule the fiber which will perform the RPC call. *) - Rpc.Rpc_common.run_via_rpc - builder - lock_held_by - common - config - (Rpc.Group.Build.build ~wait:true) - targets + Scheduler.go_without_rpc_server ~common ~config (fun () -> + let open Fiber.O in + let targets = Rpc.Group.Build.prepare_targets targets in + let+ build_outcome = + Rpc.Rpc_common.fire_message + ~name:"build" + ~wait:false + ~lock_held_by + builder + (Rpc.Rpc_common.Request + (Dune_rpc.Decl.Request.witness Dune_rpc_impl.Decl.build)) + targets + in + Rpc.Rpc_common.wrap_build_outcome_exn ~print_on_success:true build_outcome) | Ok () -> let request setup = Target.interpret_targets (Common.root common) config setup targets diff --git a/bin/build.mli b/bin/build.mli index eadbc98076c..991de1711f3 100644 --- a/bin/build.mli +++ b/bin/build.mli @@ -1,15 +1,5 @@ open Import -(** Connect to an RPC server (waiting for the server to start if necessary) and - then send a request to the server to build the specified targets. If the - build fails then a diagnostic error message is printed. If - [print_on_success] is true then this function will also print a message - after the build succeeds. *) -val build_via_rpc_server - : print_on_success:bool - -> targets:Dune_lang.Dep_conf.t list - -> unit Fiber.t - val run_build_system : common:Common.t -> request:(Dune_rules.Main.build_system -> unit Action_builder.t) diff --git a/bin/diagnostics.ml b/bin/diagnostics.ml index 6ad4011d7bb..328270ebb1f 100644 --- a/bin/diagnostics.ml +++ b/bin/diagnostics.ml @@ -1,38 +1,24 @@ open Import -let exec () = - let open Fiber.O in - let where = Rpc.Rpc_common.active_server_exn () in - let module Client = Dune_rpc_client.Client in - let+ errors = - let* connect = Client.Connection.connect_exn where in - Dune_rpc_impl.Client.client - connect - (Dune_rpc_private.Initialize.Request.create - ~id:(Dune_rpc_private.Id.make (Sexp.Atom "diagnostics_cmd"))) - ~f:(fun cli -> - let* decl = - Client.Versioned.prepare_request cli Dune_rpc_private.Public.Request.diagnostics - in - match decl with - | Error e -> raise (Dune_rpc_private.Version_error.E e) - | Ok decl -> Client.request cli decl ()) - in - match errors with - | Ok errors -> - List.iter errors ~f:(fun err -> - Console.print_user_message (Dune_rpc.Diagnostic.to_user_message err)) - | Error e -> Rpc.Rpc_common.raise_rpc_error e -;; - let info = let doc = "Fetch and return errors from the current build." in Cmd.info "diagnostics" ~doc ;; let term = - let+ (builder : Common.Builder.t) = Common.Builder.term in - Rpc.Rpc_common.client_term builder exec + let+ builder = Common.Builder.term in + Rpc.Rpc_common.client_term builder (fun () -> + let open Fiber.O in + let+ errors = + Rpc.Rpc_common.fire_message + ~name:"diagnostics_cmd" + ~wait:false + builder + (Rpc.Rpc_common.Request Dune_rpc_private.Public.Request.diagnostics) + () + in + List.iter errors ~f:(fun err -> + Console.print_user_message (Dune_rpc.Diagnostic.to_user_message err))) ;; let command = Cmd.v info term diff --git a/bin/exec.ml b/bin/exec.ml index d768cf251ce..e702eaa94f9 100644 --- a/bin/exec.ml +++ b/bin/exec.ml @@ -187,12 +187,12 @@ 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 ~prog builder lock_held_by = match Filename.analyze_program_name prog with | In_path -> (* This case is reached if [dune exec] is passed the name of an executable (rather than a path to an executable). When dune is running - directly, dune will try to resolve the executbale name within the public + directly, dune will try to resolve the executable name within the public executables defined in the current project and its dependencies, and only if no executable with the given name is found will dune then resolve the name within the $PATH variable instead. Looking up an @@ -225,7 +225,18 @@ 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 ]) + let targets = Rpc.Group.Build.prepare_targets [ target ] in + let+ build_outcome = + Rpc.Rpc_common.fire_message + ~name:"build" + ~wait:true + ~lock_held_by + builder + (Rpc.Rpc_common.Request + (Dune_rpc.Decl.Request.witness Dune_rpc_impl.Decl.build)) + targets + in + Rpc.Rpc_common.wrap_build_outcome_exn ~print_on_success:false build_outcome) in Path.to_absolute_filename path | Absolute -> @@ -234,7 +245,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 +263,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 ~prog builder lock_held_by + in restore_cwd_and_execve (Common.root common) prog args Env.initial ;; @@ -311,18 +324,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 30b149932e8..37ba8cc92bc 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 @@ -45,22 +45,17 @@ let run_fmt_command ~common ~config ~preview = | Error lock_held_by -> (* The --preview flag is being ignored by the RPC server, warn the user. *) if preview then Rpc.Rpc_common.warn_ignore_arguments lock_held_by; - let response = - Scheduler.go_without_rpc_server ~common ~config (fun () -> - Rpc.Rpc_common.fire_request - ~name:"format" - ~wait:false - Dune_rpc.Procedures.Public.format - ()) - in - (match response with - | Ok () -> () - | Error error -> - User_error.raise - [ Pp.paragraphf - "Error: %s\n%!" - (Dyn.to_string (Dune_rpc.Response.Error.to_dyn error)) - ]) + Scheduler.go_without_rpc_server + ~common + ~config + (Rpc.Rpc_common.fire_message + ~name:"format" + ~wait:false + ~warn_forwarding:false + ~lock_held_by + builder + (Rpc.Rpc_common.Request + (Dune_rpc.Decl.Request.witness Dune_rpc.Procedures.Public.format))) ;; let command = @@ -81,7 +76,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 c1c5287f735..9dfa771ab18 100644 --- a/bin/promotion.ml +++ b/bin/promotion.ml @@ -62,16 +62,20 @@ module Apply = struct let+ () = Fiber.return () in Diff_promotion.promote_files_registered_in_last_run files_to_promote) | Error lock_held_by -> - Rpc.Rpc_common.run_via_rpc - builder - lock_held_by - common - config - (Rpc.Rpc_common.fire_request - ~name:"promote_many" - ~wait:false - Dune_rpc_private.Procedures.Public.promote_many) - files_to_promote + Scheduler.go_without_rpc_server ~common ~config (fun () -> + let open Fiber.O in + let+ build_outcome = + Rpc.Rpc_common.fire_message + ~name:"promote_many" + ~wait:false + ~lock_held_by + builder + (Rpc.Rpc_common.Request + (Dune_rpc.Decl.Request.witness + Dune_rpc_private.Procedures.Public.promote_many)) + files_to_promote + in + Rpc.Rpc_common.wrap_build_outcome_exn ~print_on_success:true build_outcome) ;; let command = Cmd.v info term diff --git a/bin/rpc/rpc_build.ml b/bin/rpc/rpc_build.ml index 81dd5d066e2..eb102c46d89 100644 --- a/bin/rpc/rpc_build.ml +++ b/bin/rpc/rpc_build.ml @@ -1,12 +1,9 @@ open Import -let build ~wait 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 +let prepare_targets targets = + List.map targets ~f:(fun target -> + let sexp = Dune_lang.Dep_conf.encode target in + Dune_lang.to_string sexp) ;; let term = @@ -17,14 +14,18 @@ let term = Rpc_common.client_term builder @@ fun () -> let open Fiber.O in - let+ response = - Rpc_common.fire_request ~name:"build" ~wait Dune_rpc_impl.Decl.build targets + let+ build_outcome = + Rpc_common.fire_message + ~name:"build" + ~wait + builder + (Rpc_common.Request (Dune_rpc.Decl.Request.witness Dune_rpc_impl.Decl.build)) + targets in - match response with - | Error (error : Dune_rpc.Response.Error.t) -> - Printf.eprintf "Error: %s\n%!" (Dyn.to_string (Dune_rpc.Response.Error.to_dyn error)) - | Ok Success -> print_endline "Success" - | Ok (Failure _) -> print_endline "Failure" + match build_outcome with + (* This is the only output that the client will see, details are in the server. *) + | Success -> print_endline "Success" + | Failure _ -> print_endline "Failure" ;; let info = diff --git a/bin/rpc/rpc_build.mli b/bin/rpc/rpc_build.mli index 73b1a078dd6..009512bc593 100644 --- a/bin/rpc/rpc_build.mli +++ b/bin/rpc/rpc_build.mli @@ -1,13 +1,8 @@ open! Import -(** Sends a command to an RPC server to build the specified targets and wait - for the build to complete or fail. If [wait] is true then wait until an RPC - server is running before making the request. Otherwise if no RPC server is - running then raise a [User_error]. *) -val build - : wait:bool - -> Dune_lang.Dep_conf.t list - -> (Dune_rpc.Build_outcome_with_diagnostics.t, Dune_rpc.Response.Error.t) result Fiber.t +(** Encode the targets as [Dune_lang.t], and then as strings suitable to + be sent via RPC. *) +val prepare_targets : Dune_lang.Dep_conf.t list -> string list (** dune rpc build command *) val cmd : unit Cmdliner.Cmd.t diff --git a/bin/rpc/rpc_common.ml b/bin/rpc/rpc_common.ml index 8a76c6ebe91..e8ba1ad4726 100644 --- a/bin/rpc/rpc_common.ml +++ b/bin/rpc/rpc_common.ml @@ -1,6 +1,7 @@ open Import module Client = Dune_rpc_client.Client module Rpc_error = Dune_rpc.Response.Error +open Fiber.O let active_server () = match Dune_rpc_impl.Where.get () with @@ -24,14 +25,34 @@ let raise_rpc_error (e : Rpc_error.t) = ] ;; +type (_, _) message_kind = + | Request : ('a, 'b) Dune_rpc.Decl.Request.witness -> ('a, 'b) message_kind + | Notification : 'a Dune_rpc.Decl.Notification.witness -> ('a, unit) message_kind + let request_exn client request n = - let open Fiber.O in - let* decl = - Client.Versioned.prepare_request client (Dune_rpc.Decl.Request.witness request) - in + let* decl = Client.Versioned.prepare_request client request in match decl with - | Error e -> raise (Dune_rpc.Version_error.E e) | Ok decl -> Client.request client decl n + | Error e -> raise (Dune_rpc.Version_error.E e) +;; + +let notify_exn client notification arg = + let* res = Client.Versioned.prepare_notification client notification in + match res with + | Ok decl -> Client.notification client decl arg + | Error e -> raise (Dune_rpc.Version_error.E e) +;; + +let prepare_message_and_send : type b. Client.t -> ('a, b) message_kind -> 'a -> b Fiber.t + = + fun client message arg -> + match message with + | Notification witness -> notify_exn client witness arg + | Request witness -> + let+ res = request_exn client witness arg in + (match res with + | Ok (result : b) -> result + | Error e -> raise_rpc_error e) ;; let client_term builder f = @@ -52,13 +73,7 @@ let establish_connection () = | Ok where -> Client.Connection.connect where ;; -let establish_connection_exn () = - let open Fiber.O in - establish_connection () >>| User_error.ok_exn -;; - let establish_connection_with_retry () = - let open Fiber.O in let pause_between_retries_s = 0.2 in let rec loop () = establish_connection () @@ -71,28 +86,54 @@ let establish_connection_with_retry () = loop () ;; -let establish_client_session ~wait = - if wait then establish_connection_with_retry () else establish_connection_exn () +let establish_connection_exn lock_held_by = + establish_connection () + >>| function + | Ok connection -> connection + | Error _ -> Dune_util.Global_lock.raise_other_dune_locked lock_held_by +;; + +let establish_client_session ~wait ~lock_held_by () = + if wait + then establish_connection_with_retry () + else establish_connection_exn lock_held_by ;; -let fire_request ~name ~wait request arg = - let open Fiber.O in - let* connection = establish_client_session ~wait in +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_message + ~name + ~wait + ?(warn_forwarding = true) + ?(lock_held_by = Dune_util.Global_lock.Lock_held_by.Unknown) + builder + message + arg + = + let* connection = establish_client_session ~wait ~lock_held_by () 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))) - ~f:(fun client -> request_exn client request arg) + ~f:(fun client -> prepare_message_and_send client message arg) ;; -let wrap_build_outcome_exn ~print_on_success f arg () = - let open Fiber.O in - let+ response = f arg in - match response with - | Error (error : Rpc_error.t) -> raise_rpc_error error - | Ok Dune_rpc.Build_outcome_with_diagnostics.Success -> +let wrap_build_outcome_exn ~print_on_success build_outcome = + match build_outcome with + | Dune_rpc.Build_outcome_with_diagnostics.Success -> if print_on_success then Console.print [ Pp.text "Success" |> Pp.tag User_message.Style.Success ] - | Ok (Failure errors) -> + | Failure errors -> let error_msg = match List.length errors with | 0 -> @@ -106,23 +147,3 @@ let wrap_build_outcome_exn ~print_on_success f arg () = Console.print_user_message main); 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 lock_held_by common config request arg = - if not (Common.Builder.equal builder Common.Builder.default) - then warn_ignore_arguments lock_held_by; - Scheduler.go_without_rpc_server - ~common - ~config - (wrap_build_outcome_exn ~print_on_success:true request arg) -;; diff --git a/bin/rpc/rpc_common.mli b/bin/rpc/rpc_common.mli index 5373cde87a7..25cf79ebe03 100644 --- a/bin/rpc/rpc_common.mli +++ b/bin/rpc/rpc_common.mli @@ -7,49 +7,35 @@ val active_server_exn : unit -> Dune_rpc.Where.t (** Raise an RPC response error. *) val raise_rpc_error : Dune_rpc.Response.Error.t -> 'a -(** Make a request and raise an exception if the preparation for the request - fails in any way. Returns an [Error] if the response errors. *) -val request_exn - : Dune_rpc_client.Client.t - -> ('a, 'b) Dune_rpc.Decl.request - -> 'a - -> ('b, Dune_rpc.Response.Error.t) result Fiber.t - (** Cmdliner term for a generic RPC client. *) val client_term : Common.Builder.t -> (unit -> 'a Fiber.t) -> 'a (** Cmdliner argument for a wait flag. *) val wait_term : bool Cmdliner.Term.t +type (_, _) message_kind = + | Request : ('a, 'b) Dune_rpc.Decl.Request.witness -> ('a, 'b) message_kind + | Notification : 'a Dune_rpc.Decl.Notification.witness -> ('a, unit) message_kind + (** 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. *) -val fire_request + 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] default to [Unknown], is only used to allow error messages to print the PID. *) +val fire_message : name:string -> wait:bool - -> ('a, 'b) Dune_rpc.Decl.request + -> ?warn_forwarding:bool + -> ?lock_held_by:Dune_util.Global_lock.Lock_held_by.t + -> Common.Builder.t + -> ('a, 'b) message_kind -> 'a - -> ('b, Dune_rpc.Response.Error.t) result Fiber.t + -> 'b Fiber.t val wrap_build_outcome_exn : print_on_success:bool - -> ('a - -> (Dune_rpc.Build_outcome_with_diagnostics.t, Dune_rpc.Response.Error.t) result - Fiber.t) - -> 'a + -> Dune_rpc.Build_outcome_with_diagnostics.t -> unit - -> unit Fiber.t (** Warn the user that since a RPC server is running, some arguments are ignored. *) 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 - : Common.Builder.t - -> Dune_util.Global_lock.Lock_held_by.t - -> Common.t - -> Dune_config_file.Dune_config.t - -> ('a - -> (Dune_rpc.Build_outcome_with_diagnostics.t, Dune_rpc.Response.Error.t) result - Fiber.t) - -> 'a - -> unit diff --git a/bin/rpc/rpc_ping.ml b/bin/rpc/rpc_ping.ml index 12fcda12eb1..9b2178d42d8 100644 --- a/bin/rpc/rpc_ping.ml +++ b/bin/rpc/rpc_ping.ml @@ -12,17 +12,18 @@ let info = let term = let+ (builder : Common.Builder.t) = Common.Builder.term and+ wait = Rpc_common.wait_term in - Rpc_common.client_term builder - @@ fun () -> - let open Fiber.O in - Rpc_common.fire_request - ~name:"ping_cmd" - ~wait - Dune_rpc_private.Procedures.Public.ping - () - >>| function - | Ok () -> Console.print [ Pp.text "Server appears to be responding normally" ] - | Error e -> Rpc_common.raise_rpc_error e + Rpc_common.client_term builder (fun () -> + let open Fiber.O in + let+ () = + Rpc_common.fire_message + ~name:"ping_cmd" + ~wait + builder + (Rpc_common.Request + (Dune_rpc.Decl.Request.witness Dune_rpc_private.Procedures.Public.ping)) + () + in + Console.print [ Pp.text "Server appears to be responding normally" ]) ;; let cmd = Cmd.v info term diff --git a/bin/runtest.ml b/bin/runtest.ml index 2edb938c9d1..40bc9e20b9b 100644 --- a/bin/runtest.ml +++ b/bin/runtest.ml @@ -48,16 +48,19 @@ let runtest_term = ~dir_or_cram_test_paths ~to_cwd:(Common.root common).to_cwd) | Error lock_held_by -> - Rpc.Rpc_common.run_via_rpc - builder - lock_held_by - common - config - (Rpc.Rpc_common.fire_request - ~name:"runtest" - ~wait:false - Dune_rpc.Procedures.Public.runtest) - dir_or_cram_test_paths + Scheduler.go_without_rpc_server ~common ~config (fun () -> + let open Fiber.O in + let+ build_outcome = + Rpc.Rpc_common.fire_message + ~name:"runtest" + ~wait:false + ~lock_held_by + builder + (Rpc.Rpc_common.Request + (Dune_rpc.Decl.Request.witness Dune_rpc.Procedures.Public.runtest)) + dir_or_cram_test_paths + in + Rpc.Rpc_common.wrap_build_outcome_exn ~print_on_success:true build_outcome) ;; let commands = diff --git a/bin/shutdown.ml b/bin/shutdown.ml index a72b5042940..b5c145c058a 100644 --- a/bin/shutdown.ml +++ b/bin/shutdown.ml @@ -1,29 +1,6 @@ open Import module Client = Dune_rpc_client.Client -let send_shutdown cli = - let open Fiber.O in - let* decl = - Client.Versioned.prepare_notification - cli - Dune_rpc_private.Public.Notification.shutdown - in - match decl with - | Ok decl -> Client.notification cli decl () - | Error e -> raise (Dune_rpc_private.Version_error.E e) -;; - -let exec () = - let open Fiber.O in - let where = Rpc.Rpc_common.active_server_exn () in - let* conn = Client.Connection.connect_exn where in - Dune_rpc_impl.Client.client - conn - ~f:send_shutdown - (Dune_rpc_private.Initialize.Request.create - ~id:(Dune_rpc_private.Id.make (Sexp.Atom "shutdown_cmd"))) -;; - let info = let doc = "Cancel and shutdown any builds in the current workspace." in Cmd.info "shutdown" ~doc @@ -31,7 +8,13 @@ let info = let term = let+ builder = Common.Builder.term in - Rpc.Rpc_common.client_term builder exec + Rpc.Rpc_common.client_term + builder + (Rpc.Rpc_common.fire_message + ~name:"shutdown_cmd" + ~wait:false + builder + (Rpc.Rpc_common.Notification Dune_rpc_private.Public.Notification.shutdown)) ;; let command = Cmd.v info term diff --git a/bin/tools/tools_common.ml b/bin/tools/tools_common.ml index 4ed3dd2c413..c65c5b212f4 100644 --- a/bin/tools/tools_common.ml +++ b/bin/tools/tools_common.ml @@ -31,18 +31,29 @@ let build_dev_tool_directly common dev_tool = | Ok () -> () ;; -let build_dev_tool_via_rpc dev_tool = +let build_dev_tool_via_rpc dev_tool builder lock_held_by = let target = dev_tool_build_target dev_tool in - Build.build_via_rpc_server ~print_on_success:false ~targets:[ target ] + let targets = Rpc.Group.Build.prepare_targets [ target ] in + let open Fiber.O in + let+ build_outcome = + Rpc.Rpc_common.fire_message + ~name:"build" + ~wait:true + ~lock_held_by + builder + (Rpc.Rpc_common.Request (Dune_rpc.Decl.Request.witness Dune_rpc_impl.Decl.build)) + targets + in + Rpc.Rpc_common.wrap_build_outcome_exn ~print_on_success:false build_outcome ;; -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 dev_tool builder lock_held_by) | Ok () -> Scheduler.go_with_rpc_server ~common ~config (fun () -> build_dev_tool_directly common dev_tool) @@ -60,8 +71,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 ;; @@ -104,7 +115,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 @@ -119,7 +130,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 bcdefc44f51..a894910a858 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/src/dune_util/global_lock.ml b/src/dune_util/global_lock.ml index ab34631affb..265719d7b35 100644 --- a/src/dune_util/global_lock.ml +++ b/src/dune_util/global_lock.ml @@ -119,19 +119,22 @@ let lock ~timeout = Error lock_held_by) ;; +let raise_other_dune_locked lock_held_by = + User_error.raise + [ Pp.textf + "A running dune%s instance has locked the build directory. If this is not the \ + case, please delete %S." + (match lock_held_by with + | Lock_held_by.Unknown -> "" + | Pid_from_lockfile pid -> sprintf " (pid: %d)" pid) + (Path.Build.to_string_maybe_quoted lock_file) + ] +;; + let lock_exn ~timeout = match lock ~timeout with | Ok () -> () - | Error lock_held_by -> - User_error.raise - [ Pp.textf - "A running dune%s instance has locked the build directory. If this is not the \ - case, please delete %S." - (match lock_held_by with - | Unknown -> "" - | Pid_from_lockfile pid -> sprintf " (pid: %d)" pid) - (Path.Build.to_string_maybe_quoted lock_file) - ] + | Error lock_held_by -> raise_other_dune_locked lock_held_by ;; let unlock () = diff --git a/src/dune_util/global_lock.mli b/src/dune_util/global_lock.mli index 1b5eef0209b..fdc9400e3f5 100644 --- a/src/dune_util/global_lock.mli +++ b/src/dune_util/global_lock.mli @@ -19,3 +19,4 @@ val lock_exn : timeout:float option -> unit val unlock : unit -> unit val write_pid : Unix.file_descr -> unit +val raise_other_dune_locked : Lock_held_by.t -> 'a 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 a32b3be84da..8479cc14881 100644 --- a/test/blackbox-tests/test-cases/cram/custom-build-dir.t +++ b/test/blackbox-tests/test-cases/cram/custom-build-dir.t @@ -24,8 +24,7 @@ path $ sed -E 's/[0-9]+\)/###)/g' foo.t $ echo " $ echo bar" >bar.t $ dune runtest - Warning: - Your build request is being forwarded to a running Dune instance (pid: - ###). Note that certain command line arguments may be ignored. - Error: RPC server not running. + Error: A running dune (pid: ###) instance has locked the build directory. + If this is not the case, please delete + "$TESTCASE_ROOT/tmp/.lock". [1]