Show RPC connection status in forwarded builds (#14424)

Add a composable status-line section for RPC-connected clients.

Signed-off-by: Rudi Grinberg <me@rgrinberg.com>

Author: rgrinberg

bin/rpc/rpc_common.ml

@@ -122,11 +122,21 @@ let should_warn ~warn_forwarding builder =
   && not (Common.Builder.equal builder Common.Builder.default)
 ;;
 
+let with_rpc_connected_status_line f =
+  let section =
+    Console.Status_line.add_section
+      (Live (fun () -> Pp.verbatim "Connected to RPC server"))
+  in
+  Fiber.finalize f ~finally:(fun () ->
+    Console.Status_line.remove_section section;
+    Fiber.return ())
+;;
+
 let send_request ~f connection name =
   Dune_rpc_impl.Client.client
     connection
     (Dune_rpc.Initialize.Request.create ~id:(Dune_rpc.Id.make (Sexp.Atom name)))
-    ~f
+    ~f:(fun client -> with_rpc_connected_status_line (fun () -> f client))
 ;;
 
 let fire_request

doc/changes/added/14424.md

@@ -0,0 +1 @@
+- Add a status message for RPC clients that manage to connect (#14424, @rgrinberg)

otherlibs/stdune/src/console.ml

@@ -143,16 +143,32 @@ module Status_line = struct
 
   let toplevel = Id.gen ()
   let stack = ref []
+  let sections = ref []
+
+  let pp_if_not_nop t =
+    let pp =
+      match t with
+      | Live f -> f ()
+      | Constant x -> x
+    in
+    match Pp.to_ast pp with
+    | Nop -> []
+    | _ -> [ pp ]
+  ;;
 
   let refresh () =
-    match !stack with
-    | [] -> set_status_line None
-    | (_id, t) :: _ ->
-      let pp =
-        match t with
-        | Live f -> f ()
-        | Constant x -> x
+    let pps =
+      let section_pps =
+        List.rev !sections |> List.concat_map ~f:(fun (_id, t) -> pp_if_not_nop t)
       in
+      match !stack with
+      | [] -> section_pps
+      | (_id, t) :: _ -> pp_if_not_nop t @ section_pps
+    in
+    match pps with
+    | [] -> set_status_line None
+    | _ :: _ ->
+      let pp = Pp.concat pps ~sep:(Pp.verbatim " | ") in
       (* Always put the status line inside a horizontal box to force the
          [Format] module to prefer a single line. In particular, it seems that
          [Format.pp_print_text] split the line before the last word, unless it
@@ -194,6 +210,20 @@ module Status_line = struct
     let id = add_overlay t in
     Exn.protect ~f ~finally:(fun () -> remove_overlay id)
   ;;
+
+  type section = Id.t
+
+  let add_section t =
+    let id = Id.gen () in
+    sections := (id, t) :: !sections;
+    refresh ();
+    id
+  ;;
+
+  let remove_section id =
+    sections := List.filter !sections ~f:(fun (id', _) -> not (Id.equal id id'));
+    refresh ()
+  ;;
 end
 
 let () = User_warning.set_reporter print_user_message

otherlibs/stdune/src/console.mli

@@ -130,5 +130,15 @@ module Status_line : sig
       ]} *)
   val with_overlay : t -> f:(unit -> 'a) -> 'a
 
+  type section
+
+  (** Add a section to the current status line. Sections are rendered after the
+      current status line, separated by [" | "], and stay active across [set]
+      and [clear] until removed. *)
+  val add_section : t -> section
+
+  (** Remove a section if it is still active. Do nothing otherwise. *)
+  val remove_section : section -> unit
+
   val refresh : unit -> unit
 end

test/blackbox-tests/test-cases/watching/rpc-build-status-line.t

@@ -0,0 +1,21 @@
+Forwarded builds display a rich status line once connected over RPC.
+
+  $ export XDG_RUNTIME_DIR="$PWD/.xdg-runtime"
+  $ mkdir -p "$XDG_RUNTIME_DIR"
+  $ chmod 700 "$XDG_RUNTIME_DIR"
+
+  $ echo "(lang dune 3.23)" > dune-project
+
+  $ cat > dune <<EOF
+  > (rule
+  >  (target x)
+  >  (action (write-file %{target} ok)))
+  > EOF
+
+  $ start_dune
+  $ INSIDE_EMACS=1 DUNE_CONFIG__THREADED_CONSOLE=disabled \
+  >   with_timeout dune build --display progress x > output 2>&1
+  $ tr '\r' '\n' < output | grep -m 1 "Connected to RPC server"
+  Connected to RPC server
+
+  $ stop_dune_quiet

test/expect-tests/dune_console/dune_console_tests.ml

@@ -65,6 +65,17 @@ let test_status_line_overwrite (module Console : New_console) =
   Status_line.clear ()
 ;;
 
+let test_status_line_section (module Console : New_console) =
+  let open Console in
+  Status_line.set (Status_line.Live (fun () -> Pp.text "Done: 50%"));
+  let section =
+    Status_line.add_section
+      (Status_line.Live (fun () -> Pp.text "Connected to RPC server"))
+  in
+  Status_line.remove_section section;
+  Status_line.clear ()
+;;
+
 (* Dumb backend *)
 
 let%expect_test "basic usage" =
@@ -193,3 +204,12 @@ let%expect_test "Status line overwriting." =
 Here is a status line\r                     \rHere is another status line\r                           \r
   |}]
 ;;
+
+let%expect_test "Status line sections." =
+  let module Console = New () in
+  Console.Backend.set Console.Backend.progress;
+  test_status_line_section (module Console);
+  escape [%expect.output];
+  [%expect
+    {| Done: 50%\r         \rDone: 50% | Connected to RPC server\r                                   \rDone: 50%\r         \r |}]
+;;