Skip to content

Commit b60beb9

Browse files
ElectreAASElectreAAS
authored
[RPC] Allow promotion while watch server is running (#12010)
* Allow promotion while watch server is running * refactor: move as much as possible into rpc_common * Added clarifying comments * [RPC] Added a test showing the current promotion capabilities * Explain the difference between decl.promote and procedures.public.promote * Added changelog entry * Reintroduce the RPC server's implementation of the old promote, shouldn't have been deleted * Nit: simpler function name * Actually move everything needed for `promote_many` into dune_rpc_private * Demonstrate what moving everything into dune_rpc_private means * Previous commit was just copying, this is really moving things * Add alias for compound_user_error in the engine --------- Signed-off-by: Ambre Austen Suhamy <[email protected]>
1 parent 0150e32 commit b60beb9

39 files changed

+419
-328
lines changed

‎CHANGES.md‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -2,7 +2,7 @@ Unreleased
22
----------
33

44
If you're a contributor, please include your CHANGES entry in a file
5-
`doc/changes/$PR_NAME.md`. At release time, it will be incoporated into the
5+
`doc/changes/$PR_NUMBER.md`. At release time, it will be incoporated into the
66
changelog properly.
77

88
3.19.1 (2025-06-11)

‎bin/build.ml‎

Lines changed: 12 additions & 36 deletions
Original file line numberDiff line numberDiff line change
@@ -139,30 +139,11 @@ let run_build_command ~(common : Common.t) ~config ~request =
139139
;;
140140

141141
let build_via_rpc_server ~print_on_success ~targets =
142-
let open Fiber.O in
143-
let+ response = Rpc.Build.build ~wait:true targets in
144-
match response with
145-
| Error (error : Dune_rpc_private.Response.Error.t) ->
146-
Printf.eprintf
147-
"Error: %s\n%!"
148-
(Dyn.to_string (Dune_rpc_private.Response.Error.to_dyn error))
149-
| Ok Success ->
150-
if print_on_success
151-
then
152-
Console.print_user_message
153-
(User_message.make [ Pp.text "Success" |> Pp.tag User_message.Style.Success ])
154-
| Ok (Failure errors) ->
155-
List.iter errors ~f:(fun { Dune_engine.Compound_user_error.main; _ } ->
156-
Console.print_user_message main);
157-
User_error.raise
158-
[ (match List.length errors with
159-
| 0 ->
160-
Code_error.raise
161-
"Build via RPC failed, but the RPC server did not send an error message."
162-
[]
163-
| 1 -> Pp.textf "Build failed with 1 error."
164-
| n -> Pp.textf "Build failed with %d errors." n)
165-
]
142+
Rpc_common.wrap_build_outcome_exn
143+
~print_on_success
144+
(Rpc.Build.build ~wait:true)
145+
targets
146+
()
166147
;;
167148

168149
let build =
@@ -217,18 +198,13 @@ let build =
217198
an RPC server in the background to schedule the fiber which will
218199
perform the RPC call.
219200
*)
220-
Scheduler.go_without_rpc_server ~common ~config (fun () ->
221-
if not (Common.Builder.equal builder Common.Builder.default)
222-
then
223-
User_warning.emit
224-
[ Pp.textf
225-
"Your build request is being forwarded to a running Dune instance%s so \
226-
most command-line arguments will be ignored."
227-
(match lock_held_by with
228-
| Unknown -> ""
229-
| Pid_from_lockfile pid -> sprintf " (pid: %d)" pid)
230-
];
231-
build_via_rpc_server ~print_on_success:true ~targets)
201+
Rpc_common.run_via_rpc
202+
~builder
203+
~common
204+
~config
205+
lock_held_by
206+
(Rpc.Build.build ~wait:true)
207+
targets
232208
| Ok () ->
233209
let request setup =
234210
Target.interpret_targets (Common.root common) config setup targets

‎bin/diagnostics.ml‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -2,7 +2,7 @@ open Import
22

33
let exec () =
44
let open Fiber.O in
5-
let where = Rpc_common.active_server () in
5+
let where = Rpc_common.active_server_exn () in
66
let module Client = Dune_rpc_client.Client in
77
let+ errors =
88
let* connect = Client.Connection.connect_exn where in

‎bin/fmt.ml‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -7,8 +7,8 @@ let man =
77
; `P
88
{|$(b,dune fmt) runs the formatter on the source code. The formatter is
99
automatically selected. ocamlformat is used to format OCaml source code
10-
(*.ml and *.mli files) and refmt is used to format Reason source code
11-
(*.re and *.rei files).|}
10+
( *.ml and *.mli files) and refmt is used to format Reason source code
11+
( *.re and *.rei files).|}
1212
; `Blocks Common.help_secs
1313
]
1414
;;

‎bin/promotion.ml‎

Lines changed: 19 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,7 @@
11
open Import
22
module Diff_promotion = Promote.Diff_promotion
33

4-
let files_to_promote ~common files : Diff_promotion.files_to_promote =
4+
let files_to_promote ~common files : Dune_rpc.Files_to_promote.t =
55
match files with
66
| [] -> All
77
| _ ->
@@ -53,9 +53,25 @@ module Apply = struct
5353
let term =
5454
let+ builder = Common.Builder.term
5555
and+ files = Arg.(value & pos_all Cmdliner.Arg.file [] & info [] ~docv:"FILE") in
56-
let common, _config = Common.init builder in
56+
let common, config = Common.init builder in
5757
let files_to_promote = files_to_promote ~common files in
58-
Diff_promotion.promote_files_registered_in_last_run files_to_promote
58+
match Dune_util.Global_lock.lock ~timeout:None with
59+
| Ok () ->
60+
Scheduler.go_with_rpc_server ~common ~config (fun () ->
61+
let open Fiber.O in
62+
let+ () = Fiber.return () in
63+
Diff_promotion.promote_files_registered_in_last_run files_to_promote)
64+
| Error lock_held_by ->
65+
Rpc_common.run_via_rpc
66+
~builder
67+
~common
68+
~config
69+
lock_held_by
70+
(Rpc_common.fire_request
71+
~name:"promote_many"
72+
~wait:true
73+
Dune_rpc_private.Procedures.Public.promote_many)
74+
files_to_promote
5975
;;
6076

6177
let command = Cmd.v info term

‎bin/rpc/rpc_build.ml‎

Lines changed: 7 additions & 69 deletions
Original file line numberDiff line numberDiff line change
@@ -1,74 +1,12 @@
11
open Import
2-
module Client = Dune_rpc_client.Client
3-
4-
let retry_loop once =
5-
let open Fiber.O in
6-
let rec loop () =
7-
let* res = once () in
8-
match res with
9-
| Some result -> Fiber.return result
10-
| None ->
11-
let* () = Scheduler.sleep ~seconds:0.2 in
12-
loop ()
13-
in
14-
loop ()
15-
;;
16-
17-
let establish_connection_or_raise ~wait once =
18-
let open Fiber.O in
19-
if wait
20-
then retry_loop once
21-
else
22-
let+ res = once () in
23-
match res with
24-
| Some conn -> conn
25-
| None ->
26-
let (_ : Dune_rpc_private.Where.t) = Rpc_common.active_server () in
27-
User_error.raise
28-
[ Pp.text "failed to establish connection even though server seems to be running"
29-
]
30-
;;
31-
32-
let establish_client_session ~wait =
33-
let open Fiber.O in
34-
let once () =
35-
let where = Dune_rpc_impl.Where.get () in
36-
match where with
37-
| None -> Fiber.return None
38-
| Some where ->
39-
let+ connection = Client.Connection.connect where in
40-
(match connection with
41-
| Ok conn -> Some conn
42-
| Error message ->
43-
if not wait then Console.print_user_message message;
44-
None)
45-
in
46-
establish_connection_or_raise ~wait once
47-
;;
48-
49-
(* Sends a request to build [targets] to the RPC server at [where]. The targets
50-
are specified as strings containing sexp-encoded targets that are passed to
51-
this command as arguments on the command line. *)
52-
let build_sexp_string_targets ~wait ~targets =
53-
let open Fiber.O in
54-
let* connection = establish_client_session ~wait in
55-
Dune_rpc_impl.Client.client
56-
connection
57-
(Dune_rpc.Initialize.Request.create ~id:(Dune_rpc.Id.make (Sexp.Atom "build")))
58-
~f:(fun session ->
59-
Rpc_common.request_exn
60-
session
61-
(Dune_rpc_private.Decl.Request.witness Dune_rpc_impl.Decl.build)
62-
targets)
63-
;;
642

653
let build ~wait targets =
664
let targets =
675
List.map targets ~f:(fun target ->
686
let sexp = Dune_lang.Dep_conf.encode target in
697
Dune_lang.to_string sexp)
708
in
71-
build_sexp_string_targets ~wait ~targets
9+
Rpc_common.fire_request ~name:"build" ~wait Dune_rpc_impl.Decl.build targets
7210
;;
7311

7412
let term =
@@ -77,14 +15,14 @@ let term =
7715
and+ wait = Rpc_common.wait_term
7816
and+ targets = Arg.(value & pos_all string [] name_) in
7917
Rpc_common.client_term builder
80-
@@ fun _common ->
18+
@@ fun () ->
8119
let open Fiber.O in
82-
let+ response = build_sexp_string_targets ~wait ~targets in
20+
let+ response =
21+
Rpc_common.fire_request ~name:"build" ~wait Dune_rpc_impl.Decl.build targets
22+
in
8323
match response with
84-
| Error (error : Dune_rpc_private.Response.Error.t) ->
85-
Printf.eprintf
86-
"Error: %s\n%!"
87-
(Dyn.to_string (Dune_rpc_private.Response.Error.to_dyn error))
24+
| Error (error : Dune_rpc.Response.Error.t) ->
25+
Printf.eprintf "Error: %s\n%!" (Dyn.to_string (Dune_rpc.Response.Error.to_dyn error))
8826
| Ok Success -> print_endline "Success"
8927
| Ok (Failure _) -> print_endline "Failure"
9028
;;

‎bin/rpc/rpc_build.mli‎

Lines changed: 1 addition & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -7,10 +7,7 @@ open! Import
77
val build
88
: wait:bool
99
-> Dune_lang.Dep_conf.t list
10-
-> ( Dune_rpc_impl.Decl.Build_outcome_with_diagnostics.t
11-
, Dune_rpc.Response.Error.t )
12-
result
13-
Fiber.t
10+
-> (Dune_rpc.Build_outcome_with_diagnostics.t, Dune_rpc.Response.Error.t) result Fiber.t
1411

1512
(** dune rpc build command *)
1613
val cmd : unit Cmdliner.Cmd.t

‎bin/rpc/rpc_common.ml‎

Lines changed: 88 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -1,20 +1,23 @@
11
open Import
22
module Client = Dune_rpc_client.Client
3+
module Rpc_error = Dune_rpc.Response.Error
34

45
let active_server () =
56
match Dune_rpc_impl.Where.get () with
6-
| Some p -> p
7-
| None -> User_error.raise [ Pp.text "RPC server not running." ]
7+
| Some p -> Ok p
8+
| None -> Error (User_error.make [ Pp.text "RPC server not running." ])
89
;;
910

11+
let active_server_exn () = active_server () |> User_error.ok_exn
12+
1013
(* cwong: Should we put this into [dune-rpc]? *)
1114
let interpret_kind = function
12-
| Dune_rpc_private.Response.Error.Invalid_request -> "Invalid_request"
15+
| Rpc_error.Invalid_request -> "Invalid_request"
1316
| Code_error -> "Code_error"
1417
| Connection_dead -> "Connection_dead"
1518
;;
1619

17-
let raise_rpc_error (e : Dune_rpc_private.Response.Error.t) =
20+
let raise_rpc_error (e : Rpc_error.t) =
1821
User_error.raise
1922
[ Pp.text "Server returned error: "
2023
; Pp.textf "%s (error kind: %s)" e.message (interpret_kind e.kind)
@@ -25,7 +28,7 @@ let request_exn client witness n =
2528
let open Fiber.O in
2629
let* decl = Client.Versioned.prepare_request client witness in
2730
match decl with
28-
| Error e -> raise (Dune_rpc_private.Version_error.E e)
31+
| Error e -> raise (Dune_rpc.Version_error.E e)
2932
| Ok decl -> Client.request client decl n
3033
;;
3134

@@ -40,3 +43,83 @@ let wait_term =
4043
let doc = "poll until server starts listening and then establish connection." in
4144
Arg.(value & flag & info [ "wait" ] ~doc)
4245
;;
46+
47+
let establish_connection () =
48+
match active_server () with
49+
| Error e -> Fiber.return (Error e)
50+
| Ok where -> Client.Connection.connect where
51+
;;
52+
53+
let establish_connection_exn () =
54+
let open Fiber.O in
55+
establish_connection () >>| User_error.ok_exn
56+
;;
57+
58+
let establish_connection_with_retry () =
59+
let open Fiber.O in
60+
let pause_between_retries_s = 0.2 in
61+
let rec loop () =
62+
establish_connection ()
63+
>>= function
64+
| Ok x -> Fiber.return x
65+
| Error _ ->
66+
let* () = Scheduler.sleep ~seconds:pause_between_retries_s in
67+
loop ()
68+
in
69+
loop ()
70+
;;
71+
72+
let establish_client_session ~wait =
73+
if wait then establish_connection_with_retry () else establish_connection_exn ()
74+
;;
75+
76+
let fire_request ~name ~wait request arg =
77+
let open Fiber.O in
78+
let* connection = establish_client_session ~wait in
79+
Dune_rpc_impl.Client.client
80+
connection
81+
(Dune_rpc.Initialize.Request.create ~id:(Dune_rpc.Id.make (Sexp.Atom name)))
82+
~f:(fun client -> request_exn client (Dune_rpc.Decl.Request.witness request) arg)
83+
;;
84+
85+
let wrap_build_outcome_exn ~print_on_success f args () =
86+
let open Fiber.O in
87+
let+ response = f args in
88+
match response with
89+
| Error (error : Rpc_error.t) ->
90+
Printf.eprintf "Error: %s\n%!" (Dyn.to_string (Rpc_error.to_dyn error))
91+
| Ok Dune_rpc.Build_outcome_with_diagnostics.Success ->
92+
if print_on_success
93+
then
94+
Console.print_user_message
95+
(User_message.make [ Pp.text "Success" |> Pp.tag User_message.Style.Success ])
96+
| Ok (Failure errors) ->
97+
List.iter errors ~f:(fun { Dune_rpc.Compound_user_error.main; _ } ->
98+
Console.print_user_message main);
99+
User_error.raise
100+
[ (match List.length errors with
101+
| 0 ->
102+
Code_error.raise
103+
"Build via RPC failed, but the RPC server did not send an error message."
104+
[]
105+
| 1 -> Pp.textf "Build failed with 1 error."
106+
| n -> Pp.textf "Build failed with %d errors." n)
107+
]
108+
;;
109+
110+
let run_via_rpc ~builder ~common ~config lock_held_by f args =
111+
if not (Common.Builder.equal builder Common.Builder.default)
112+
then
113+
User_warning.emit
114+
[ Pp.textf
115+
"Your build request is being forwarded to a running Dune instance%s. Note that \
116+
certain command line arguments may be ignored."
117+
(match lock_held_by with
118+
| Dune_util.Global_lock.Lock_held_by.Unknown -> ""
119+
| Pid_from_lockfile pid -> sprintf " (pid: %d)" pid)
120+
];
121+
Scheduler.go_without_rpc_server
122+
~common
123+
~config
124+
(wrap_build_outcome_exn ~print_on_success:true f args)
125+
;;

0 commit comments

Comments
 (0)