rpc: dune rpc status --all

We add an --all flag for printing the statuses of all running dune
processes.

Signed-off-by: Ali Caglayan <alizter@gmail.com>

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)

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

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)