Big refactoring in Rpc_common to unify all RPC calls, and fix incorrect error messages

Signed-off-by: Ambre Austen Suhamy <[email protected]>

Author: ElectreAAS

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

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)

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

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
 ;;
 

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
 ;;

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

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 =

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