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

@@ -221,9 +221,8 @@ 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
-                 | Unknown -> ""
-                 | Pid_from_lockfile pid -> sprintf " (pid: %d)" pid)
+                (Dune_util.Global_lock.Lock_held_by.to_string_empty_if_unknown
+                   lock_held_by)
             ];
         build_via_rpc_server ~print_on_success:true ~targets)
     | Ok () ->

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,69 @@ 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 ->
+    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 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 +265,40 @@ 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."
+             (Dune_util.Global_lock.Lock_held_by.to_string_empty_if_unknown lock_held_by)
+         ]
+     | 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."
+               (Dune_util.Global_lock.Lock_held_by.to_string_empty_if_unknown
+                  lock_held_by)
+           ];
+       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)

src/dune_util/global_lock.ml

@@ -71,6 +71,11 @@ module Lock_held_by = struct
     | Pid_from_lockfile of int
     | Unknown
 
+  let to_string_empty_if_unknown = function
+    | Unknown -> ""
+    | Pid_from_lockfile pid -> sprintf " (pid: %d)" pid
+  ;;
+
   let read_lock_file () =
     match Io.read_file (Path.build lock_file) with
     | exception _ -> Unknown
@@ -127,9 +132,7 @@ let lock_exn ~timeout =
       [ Pp.textf
           "A running dune%s instance has locked the build directory. If this is not the \
            case, please delete %S."
-          (match lock_held_by with
-           | Unknown -> ""
-           | Pid_from_lockfile pid -> sprintf " (pid: %d)" pid)
+          (Lock_held_by.to_string_empty_if_unknown lock_held_by)
           (Path.Build.to_string_maybe_quoted lock_file)
       ]
 ;;

src/dune_util/global_lock.mli

@@ -3,9 +3,11 @@
     Before starting rpc, writing to the build dir, this lock should be locked. *)
 
 module Lock_held_by : sig
-  type t =
-    | Pid_from_lockfile of int
-    | Unknown
+  type t
+
+  (** returns "(pid: X)" where X is the PID if the PID is known, otherwise the
+      empty string *)
+  val to_string_empty_if_unknown : t -> string
 end
 
 (** Attempt to acquire a lock. once a lock is locked, subsequent locks always

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 "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 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) "Hello, World!"
+  Hello, World!
+
+  $ dune shutdown
+  $ wait