diff --git a/CHANGES.md b/CHANGES.md index 85de011b64e..bf448ff980a 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -19,6 +19,9 @@ Unreleased - Do not re-run OCaml syntax files on every iteration of the watch mode. This is too memory consuming. (#7894, fix #6900, @rgrinberg) +- Add `--all` option to `dune rpc status` to show all Dune RPC servers running. + (#8011, fix #7902, @Alizter) + - Remove some compatibility code for old version of dune that generated `.merlin` files. Now dune will never remove `.merlin` files automatically (#7562) diff --git a/bin/rpc.ml b/bin/rpc.ml index 666231db87c..8c14f83c5c4 100644 --- a/bin/rpc.ml +++ b/bin/rpc.ml @@ -87,27 +87,110 @@ let report_error error = let witness = Dune_rpc_private.Decl.Request.witness module Status = struct - let term = - let+ (common : Common.t) = Common.term in - client_term common @@ fun _common -> - let where = active_server () in - Console.print - [ Pp.textf "Server is listening on %s" (Dune_rpc.Where.to_string where) - ; Pp.text "Connected clients (including this one):" - ]; + let ( let** ) x f = let open Fiber.O in - let* conn = Client.Connection.connect_exn where in + let* x = x in + match x with + | Ok s -> f s + | Error e -> Fiber.return (Error e) + + let ( let++ ) x f = + let open Fiber.O in + let+ x = x in + match x with + | Ok s -> Ok (f s) + | Error e -> Error e + + (** Get the status of a server at a given location and apply a function to the + list of clients *) + let server_response_map ~where ~f = + (* TODO: add timeout for status check *) + let open Fiber.O in + let** conn = + Client.Connection.connect where + >>| Result.map_error ~f:User_message.to_string + in Dune_rpc_impl.Client.client conn (Dune_rpc.Initialize.Request.create ~id:(Dune_rpc.Id.make (Sexp.Atom "status"))) ~f:(fun session -> let open Fiber.O in - let+ response = - request_exn session (witness Dune_rpc_impl.Decl.status) () + let++ response = + let** decl = + Client.Versioned.prepare_request session + (witness Dune_rpc_impl.Decl.status) + >>| Result.map_error ~f:Dune_rpc_private.Version_error.message + in + Client.request session decl () + >>| Result.map_error ~f:Dune_rpc.Response.Error.message in - match response with - | Error error -> report_error error - | Ok { clients } -> + f response.Dune_rpc_impl.Decl.Status.clients) + + (** Get a list of registered Dunes from the RPC registry *) + let registered_dunes () : Dune_rpc.Registry.Dune.t list Fiber.t = + let config = + Dune_rpc_private.Registry.Config.create (Lazy.force Dune_util.xdg) + in + let registry = Dune_rpc_private.Registry.create config in + let open Fiber.O in + let+ _result = Dune_rpc_impl.Poll_active.poll registry in + Dune_rpc_private.Registry.current registry + + (** The type of server statuses *) + type status = + { root : string + ; pid : Pid.t + ; result : (int, string) result + } + + (** Fetch the status of a single Dune instance *) + let get_status (dune : Dune_rpc.Registry.Dune.t) = + let root = Dune_rpc_private.Registry.Dune.root dune in + let pid = Dune_rpc_private.Registry.Dune.pid dune |> Pid.of_int in + let where = Dune_rpc_private.Registry.Dune.where dune in + let open Fiber.O in + let+ result = server_response_map ~where ~f:List.length in + { root; pid; result } + + (** Print a list of statuses to the console *) + let print_statuses statuses = + List.sort statuses ~compare:(fun x y -> String.compare x.root y.root) + |> Pp.concat_map ~sep:Pp.newline ~f:(fun { root; pid; result } -> + Pp.concat ~sep:Pp.newline + [ Pp.textf "root: %s" root + ; Pp.enumerate ~f:Fun.id + [ Pp.textf "pid: %d" (Pid.to_int pid) + ; Pp.textf "clients: %s" + (match result with + | Ok n -> string_of_int n + | Error e -> e) + ] + ]) + |> List.singleton |> Console.print + + let term = + let+ (common : Common.t) = Common.term + and+ all = + Arg.( + value & flag + & info [ "all" ] + ~doc: + "Show all running Dune instances together with their root, pids \ + and number of clients.") + in + client_term common @@ fun () -> + let open Fiber.O in + if all then + let* dunes = registered_dunes () in + let+ statuses = Fiber.parallel_map ~f:get_status dunes in + print_statuses statuses + else + let where = active_server () in + Console.print + [ Pp.textf "Server is listening on %s" (Dune_rpc.Where.to_string where) + ; Pp.text "Connected clients (including this one):" + ]; + server_response_map ~where ~f:(fun clients -> List.iter clients ~f:(fun (client, menu) -> let id = let sexp = Dune_rpc.Conv.to_sexp Dune_rpc.Id.sexp client in @@ -129,7 +212,10 @@ module Status = struct Pp.textf "%s: %d" method_ version))) ] in - User_message.print message)) + Console.print_user_message message)) + >>| function + | Ok () -> () + | Error e -> Printf.printf "Error: %s\n" e let info = let doc = "show active connections" in diff --git a/src/dune_rpc_impl/dune_rpc_impl.ml b/src/dune_rpc_impl/dune_rpc_impl.ml index 8fbc139a9e2..e9d8715691a 100644 --- a/src/dune_rpc_impl/dune_rpc_impl.ml +++ b/src/dune_rpc_impl/dune_rpc_impl.ml @@ -5,3 +5,27 @@ module For_handlers = For_handlers module Private = Dune_rpc_client.Private module Watch_mode_config = Watch_mode_config module Where = Dune_rpc_client.Where + +module Poll_active = + Dune_rpc_private.Registry.Poll + (Fiber) + (struct + let scandir dir = + Fiber.return + (match Dune_filesystem_stubs.read_directory dir with + | Ok s -> Ok s + | Error (e, _, _) -> + Error (Failure (dir ^ ": " ^ Unix.error_message e))) + + let stat s = + Fiber.return + (match Unix.stat s with + | exception exn -> Error exn + | s -> Ok (`Mtime s.st_mtime)) + + let read_file s = + Fiber.return + (match Stdune.Io.String_path.read_file s with + | s -> Ok s + | exception exn -> Error exn) + end) diff --git a/test/expect-tests/dune_rpc_e2e/dune b/test/expect-tests/dune_rpc_e2e/dune index eaf1e2d3131..686556062e5 100644 --- a/test/expect-tests/dune_rpc_e2e/dune +++ b/test/expect-tests/dune_rpc_e2e/dune @@ -55,6 +55,7 @@ dune_rpc_private dune_rpc_e2e dune_engine + dune_rpc_impl dune_filesystem_stubs spawn stdune diff --git a/test/expect-tests/dune_rpc_e2e/dune_rpc_registry_test.ml b/test/expect-tests/dune_rpc_e2e/dune_rpc_registry_test.ml index 20e5edf2b03..a720df8b4c6 100644 --- a/test/expect-tests/dune_rpc_e2e/dune_rpc_registry_test.ml +++ b/test/expect-tests/dune_rpc_e2e/dune_rpc_registry_test.ml @@ -3,32 +3,9 @@ open Fiber.O module Where = Dune_rpc_private.Where module Registry = Dune_rpc_private.Registry module Scheduler = Dune_engine.Scheduler +module Poll_active = Dune_rpc_impl.Poll_active open Dune_rpc_e2e -module Poll_active = - Dune_rpc_private.Registry.Poll - (Fiber) - (struct - let scandir dir = - Fiber.return - (match Dune_filesystem_stubs.read_directory dir with - | Ok s -> Ok s - | Error (e, _, _) -> - Error (Failure (dir ^ ": " ^ Unix.error_message e))) - - let stat s = - Fiber.return - (match Unix.stat s with - | exception exn -> Error exn - | s -> Ok (`Mtime s.st_mtime)) - - let read_file s = - Fiber.return - (match Io.String_path.read_file s with - | s -> Ok s - | exception exn -> Error exn) - end) - let try_ ~times ~delay ~f = let rec loop = function | 0 -> Fiber.return None