Allow dune exec while watch server is running

This change allows a limited version of `dune exec` to run at the same
time as dune is running in watch mode. This allows users to run example
programs without needing to stop their watch server. This works by
sending messages to the RPC server to build the executable if necessary.

Signed-off-by: Stephen Sherratt <[email protected]>

Author: gridbugs

bin/exec.ml

@@ -64,7 +64,16 @@ module Cmd_arg = struct
   let conv = Arg.conv ((fun s -> Ok (parse s)), pp)
 end
 
-let not_found ~dir ~prog =
+let not_found ~hints ~prog =
+  User_error.raise
+    ~hints
+    [ Pp.concat
+        ~sep:Pp.space
+        [ Pp.text "Program"; User_message.command prog; Pp.text "not found!" ]
+    ]
+;;
+
+let not_found_with_suggestions ~dir ~prog =
   let open Memo.O in
   let+ hints =
     (* Good candidates for the "./x.exe" instead of "x.exe" error are
@@ -81,30 +90,25 @@ let not_found ~dir ~prog =
     in
     User_message.did_you_mean prog ~candidates
   in
+  not_found ~hints ~prog
+;;
+
+let program_not_built_yet prog =
   User_error.raise
-    ~hints
     [ Pp.concat
         ~sep:Pp.space
-        [ Pp.text "Program"; User_message.command prog; Pp.text "not found!" ]
+        [ Pp.text "Program"
+        ; User_message.command prog
+        ; Pp.text "isn't built yet. You need to build it first or remove the"
+        ; User_message.command "--no-build"
+        ; Pp.text "option."
+        ]
     ]
 ;;
 
 let build_prog ~no_rebuild ~prog p =
   if no_rebuild
-  then
-    if Path.exists p
-    then Memo.return p
-    else
-      User_error.raise
-        [ Pp.concat
-            ~sep:Pp.space
-            [ Pp.text "Program"
-            ; User_message.command prog
-            ; Pp.text "isn't built yet. You need to build it first or remove the"
-            ; User_message.command "--no-build"
-            ; Pp.text "option."
-            ]
-        ]
+  then if Path.exists p then Memo.return p else program_not_built_yet prog
   else
     let open Memo.O in
     let+ () = Build_system.build_file p in
@@ -117,14 +121,14 @@ let get_path_and_build_if_necessary sctx ~no_rebuild ~dir ~prog =
   | In_path ->
     Super_context.resolve_program_memo sctx ~dir ~loc:None prog
     >>= (function
-     | Error (_ : Action.Prog.Not_found.t) -> not_found ~dir ~prog
+     | Error (_ : Action.Prog.Not_found.t) -> not_found_with_suggestions ~dir ~prog
      | Ok p -> build_prog ~no_rebuild ~prog p)
   | Relative_to_current_dir ->
     let path = Path.relative_to_source_in_build_or_external ~dir prog in
     Build_system.file_exists path
     >>= (function
      | true -> build_prog ~no_rebuild ~prog path
-     | false -> not_found ~dir ~prog)
+     | false -> not_found_with_suggestions ~dir ~prog)
   | Absolute ->
     (match
        let prog = Path.of_string prog in
@@ -137,7 +141,7 @@ let get_path_and_build_if_necessary sctx ~no_rebuild ~dir ~prog =
          Option.some_if (Path.exists prog) prog)
      with
      | Some prog -> Memo.return prog
-     | None -> not_found ~dir ~prog)
+     | None -> not_found_with_suggestions ~dir ~prog)
 ;;
 
 let step ~setup ~prog ~args ~common ~no_rebuild ~context ~on_exit () =
@@ -164,6 +168,68 @@ let step ~setup ~prog ~args ~common ~no_rebuild ~context ~on_exit () =
   | exit_code -> on_exit exit_code
 ;;
 
+(* Similar to [get_path_and_build_if_necessary] but doesn't require the build
+   system (ie. it sequences with [Fiber] rather than with [Memo]) and builds
+   targets via an RPC server. Some functionality is not available but it can be
+   run concurrently while a second Dune process holds the global build
+   directory lock.
+
+   Returns the absolute path to the executable. *)
+let build_prog_via_rpc_if_necessary ~dir ~no_rebuild prog =
+  match Filename.analyze_program_name prog with
+  | In_path ->
+    User_warning.emit
+      [ Pp.textf
+          "As this is not the main instance of Dune it is unable to locate the \
+           executable %S within this project. Dune will attempt to resolve the \
+           executable's name within your PATH only."
+          prog
+      ];
+    let path = Env_path.path Env.initial in
+    (match Bin.which ~path prog with
+     | None -> not_found ~hints:[] ~prog
+     | Some prog_path -> Fiber.return (Path.to_absolute_filename prog_path))
+  | Relative_to_current_dir ->
+    let open Fiber.O in
+    let path = Path.relative_to_source_in_build_or_external ~dir prog in
+    let+ () =
+      if no_rebuild
+      then if Path.exists path then Fiber.return () else program_not_built_yet prog
+      else (
+        let target =
+          Dune_lang.Dep_conf.File
+            (Dune_lang.String_with_vars.make_text Loc.none (Path.to_string path))
+        in
+        Build_cmd.build_via_rpc_server ~print_on_success:false ~targets:[ target ])
+    in
+    Path.to_absolute_filename path
+  | Absolute ->
+    if Path.exists (Path.of_string prog)
+    then Fiber.return prog
+    else not_found ~hints:[] ~prog
+;;
+
+let exec_building_via_rpc_server ~common ~prog ~args ~no_rebuild =
+  let open Fiber.O in
+  let ensure_terminal = function
+    | Cmd_arg.Terminal s -> s
+    | Expandable (_, raw) ->
+      (* Pforms cannot be expanded without running the build system. *)
+      User_error.raise
+        [ Pp.textf
+            "The term %S contains a pform variable but Dune is unable to expand pform \
+             variables when building via RPC."
+            raw
+        ]
+  in
+  let context = Common.x common |> Option.value ~default:Context_name.default in
+  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
+  restore_cwd_and_execve (Common.root common) prog args Env.initial
+;;
+
 let term : unit Term.t =
   let+ builder = Common.Builder.term
   and+ context = Common.context_arg ~doc:{|Run the command in this build context.|}
@@ -189,11 +255,26 @@ let term : unit Term.t =
     let* () = Fiber.return @@ Scheduler.maybe_clear_screen ~details_hum:[] config in
     build @@ step ~setup ~prog ~args ~common ~no_rebuild ~context ~on_exit
   | No ->
-    Scheduler.go_with_rpc_server ~common ~config
-    @@ fun () ->
-    let open Fiber.O in
-    let* setup = Import.Main.setup () in
-    build_exn @@ step ~setup ~prog ~args ~common ~no_rebuild ~context ~on_exit:exit
+    (match Dune_util.Global_lock.lock ~timeout:None with
+     | Error lock_held_by ->
+       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
+                | Dune_util.Global_lock.Lock_held_by.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
+     | Ok () ->
+       Scheduler.go_with_rpc_server ~common ~config
+       @@ fun () ->
+       let open Fiber.O in
+       let* setup = Import.Main.setup () in
+       build_exn @@ step ~setup ~prog ~args ~common ~no_rebuild ~context ~on_exit:exit)
 ;;
 
 let command = Cmd.v info term

bin/tools/tools_common.ml

@@ -29,7 +29,7 @@ let build_dev_tool_via_rpc dev_tool =
 let lock_and_build_dev_tool ~common ~config dev_tool =
   let open Fiber.O in
   match Dune_util.Global_lock.lock ~timeout:None with
-  | Error () ->
+  | Error _lock_held_by ->
     Scheduler.go_without_rpc_server ~common ~config (fun () ->
       let* () = Lock_dev_tool.lock_dev_tool dev_tool |> Memo.run in
       build_dev_tool_via_rpc dev_tool)

doc/changes/11840.md

@@ -0,0 +1,2 @@
+- Allow `dune exec` to run concurrently with another instance of dune in watch
+  mode (#11840, @gridbugs)

test/blackbox-tests/test-cases/watching/dune

@@ -17,8 +17,10 @@
  (applies_to what-dune-watches)
  (deps %{bin:strace}))
 
-;; this test sometimes gets stuck and times out
+;; These tests sometimes get stuck and time out:
 
 (cram
- (applies_to watching-eager-concurrent-build-command)
+ (applies_to
+  watching-eager-concurrent-build-command
+  watching-eager-concurrent-exec-command)
  (enabled_if false))

test/blackbox-tests/test-cases/watching/watching-eager-concurrent-exec-command.t

@@ -0,0 +1,44 @@
+Demonstrate running "dune exec" concurrently with an eager rpc server.
+
+  $ echo '(lang dune 3.18)' > dune-project
+  $ echo '(executable (name foo))' > dune
+  $ echo 'let () = print_endline "Hello, World!"' > foo.ml
+  $ touch README.md
+
+Just watch the readme file so we don't accidentally build foo.exe before
+testing the --no-build option:
+  $ dune build README.md --watch &
+  Success, waiting for filesystem changes...
+  Success, waiting for filesystem changes...
+  Success, waiting for filesystem changes...
+
+Demonstrate handling the --no-build option:
+  $ dune exec --no-build ./foo.exe
+  Error: Program './foo.exe' isn't built yet. You need to build it first or
+  remove the '--no-build' option.
+  [1]
+
+Demonstrate running an executable from the current project:
+  $ dune exec ./foo.exe
+  Hello, World!
+
+Demonstrate running an executable from PATH:
+  $ dune exec echo "Hello, World!"
+  Warning: As this is not the main instance of Dune it is unable to locate the
+  executable "echo" within this project. Dune will attempt to resolve the
+  executable's name within your PATH only.
+  Hello, World!
+
+Demonstrate printing a warning if arguments are passed that would be ignored
+due to how Dune builds via RPC:
+  $ dune exec --force ./foo.exe 2>&1 | sed 's/pid: [0-9]*/pid: PID/g'
+  Warning: Your build request is being forwarded to a running Dune instance
+  (pid: PID). Note that certain command line arguments may be ignored.
+  Hello, World!
+
+Demonstrate running an executable via an absolute path:
+  $ dune exec $(which echo) "Hello, World!"
+  Hello, World!
+
+  $ dune shutdown
+  $ wait