Allow dune exec while watch server is running (#11840)

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/build_cmd.ml

@@ -221,7 +221,7 @@ let build =
             [ Pp.textf
                 "Your build request is being forwarded to a running Dune instance%s so \
                  most command-line arguments will be ignored."
-                (match (lock_held_by : Dune_util.Global_lock.Lock_held_by.t) with
+                (match lock_held_by with
                  | Unknown -> ""
                  | Pid_from_lockfile pid -> sprintf " (pid: %d)" pid)
             ];

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,17 +168,83 @@ let step ~setup ~prog ~args ~common ~no_rebuild ~context ~on_exit () =
   | exit_code -> on_exit exit_code
 ;;
 
-let term : unit Term.t =
-  let+ builder = Common.Builder.term
-  and+ context = Common.context_arg ~doc:{|Run the command in this build context.|}
-  and+ prog = Arg.(required & pos 0 (some Cmd_arg.conv) None (Arg.info [] ~docv:"PROG"))
-  and+ no_rebuild =
-    Arg.(value & flag & info [ "no-build" ] ~doc:"don't rebuild target before executing")
-  and+ args = Arg.(value & pos_right 0 Cmd_arg.conv [] (Arg.info [] ~docv:"ARGS")) in
-  (* TODO we should make sure to finalize the current backend before exiting dune.
-     For watch mode, we should finalize the backend and then restart it in between
-     runs. *)
-  let common, config = Common.init builder in
+(* 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 ->
+    (* 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
+       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
+       executable's name within the current project requires running the
+       build system, but running the build system is not allowed while
+       another dune instance holds the global build directory lock. In this
+       case dune will only resolve the executable's name within $PATH.
+       Because this behaviour is different from the default, print a warning
+       so users are hopefully less surprised.
+    *)
+    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 v =
+    match (v : Cmd_arg.t) with
+    | Terminal s -> s
+    | Expandable (_, raw) ->
+      (* Variables cannot be expanded without running the build system. *)
+      User_error.raise
+        [ Pp.textf
+            "The term %S contains a variable but Dune is unable to expand 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 exec_building_directly ~common ~config ~context ~prog ~args ~no_rebuild =
   match Common.watch common with
   | Yes Passive ->
     User_error.raise [ Pp.textf "passive watch mode is unsupported by exec" ]
@@ -209,4 +279,43 @@ let term : unit Term.t =
       restore_cwd_and_execve (Common.root common) prog args env)
 ;;
 
+let term : unit Term.t =
+  let+ builder = Common.Builder.term
+  and+ context = Common.context_arg ~doc:{|Run the command in this build context.|}
+  and+ prog = Arg.(required & pos 0 (some Cmd_arg.conv) None (Arg.info [] ~docv:"PROG"))
+  and+ no_rebuild =
+    Arg.(value & flag & info [ "no-build" ] ~doc:"don't rebuild target before executing")
+  and+ args = Arg.(value & pos_right 0 Cmd_arg.conv [] (Arg.info [] ~docv:"ARGS")) in
+  (* TODO we should make sure to finalize the current backend before exiting dune.
+     For watch mode, we should finalize the backend and then restart it in between
+     runs. *)
+  let common, config = Common.init builder in
+  match Dune_util.Global_lock.lock ~timeout:None with
+  | Error lock_held_by ->
+    (match Common.watch common with
+     | Yes _ ->
+       User_error.raise
+         [ Pp.textf
+             "Another instance of dune%s has locked the _build directory. Refusing to \
+              start a new watch server until no other instances of dune are running."
+             (match lock_held_by with
+              | Unknown -> ""
+              | 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)
+  | Ok () -> exec_building_directly ~common ~config ~context ~prog ~args ~no_rebuild
+;;
+
 let command = Cmd.v info term

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,9 @@
  (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,50 @@
+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 "foo"' > 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
+  foo
+
+Demonstrate running an executable from PATH:
+  $ dune exec echo "bar"
+  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.
+  bar
+
+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.
+  foo
+
+Demonstrate trying to run exec in watch mode while another watch server is running:
+  $ dune exec ./foo.exe --watch 2>&1 | sed 's/pid: [0-9]*/pid: PID/g'
+  Error: Another instance of dune (pid: PID) has locked the _build
+  directory. Refusing to start a new watch server until no other instances of
+  dune are running.
+
+Demonstrate running an executable via an absolute path:
+  $ dune exec $(which echo) "baz"
+  baz
+
+  $ dune shutdown
+  $ wait