From c0796a6ba81bb97655f343aaddc304acd7d46d9c Mon Sep 17 00:00:00 2001
From: Stephen Sherratt <stephen@sherra.tt>
Date: Tue, 1 Oct 2024 17:49:15 +1000
Subject: [PATCH] Fix exec -w for relative paths with --root argument

Passing --root to `dune build` and `dune exec` causes relative paths
to files to be resolved relative to the workspace root rather than the
working directory (in addition to its main function of explicitly
setting the workspace root directory). This was not implemented
correctly for exec watch mode, where relative paths would be resolved
relative to the working directory instead.

There was already a test for this which was failing, however the test
is disabled in CI as it is known to be flaky.

Signed-off-by: Stephen Sherratt <stephen@sherra.tt>
---
 bin/exec.ml                                   | 26 +++++++++++--------
 bin/import.ml                                 | 18 +++++++------
 .../exec-watch-multi-levels.t/run.t           |  4 ++-
 3 files changed, 28 insertions(+), 20 deletions(-)

diff --git a/bin/exec.ml b/bin/exec.ml
index b4a0ec6e9ef0..2118a1a2b987 100644
--- a/bin/exec.ml
+++ b/bin/exec.ml
@@ -77,22 +77,26 @@ module Command_to_exec = struct
 
   (* Helper function to spawn a new process running a command in an
      environment, returning the new process' pid *)
-  let spawn_process path ~args ~env =
+  let spawn_process (common : Common.t) path ~args ~env =
     let pid =
-      let path = Path.to_string path in
+      let prog = string_path_relative_to_specified_root common (Path.to_string path) in
       let env = Env.to_unix env |> Spawn.Env.of_list in
-      let argv = path :: args in
+      let argv = prog :: args in
       let cwd = Spawn.Working_dir.Path Fpath.initial_cwd in
-      Spawn.spawn ~prog:path ~env ~cwd ~argv ()
+      Spawn.spawn ~prog ~env ~cwd ~argv ()
     in
     Pid.of_int pid
   ;;
 
   (* Run the command, first (re)building the program which the command is
      invoking *)
-  let build_and_run_in_child_process { get_path_and_build_if_necessary; prog; args; env } =
+  let build_and_run_in_child_process
+    common
+    { get_path_and_build_if_necessary; prog; args; env }
+    =
     get_path_and_build_if_necessary prog
-    |> Fiber.map ~f:(Result.map ~f:(spawn_process ~args ~env))
+    |> Fiber.map
+         ~f:(Result.map ~f:(fun exe_path -> spawn_process common ~args ~env exe_path))
   ;;
 end
 
@@ -139,18 +143,18 @@ module Watch = struct
 
   (* Kills the currently running process, then runs the given command after
      (re)building the program which it will invoke *)
-  let run state ~command_to_exec =
+  let run common state ~command_to_exec =
     let open Fiber.O in
     let* () = Fiber.return () in
     let* () = kill_currently_running_process state in
     let* command_to_exec = command_to_exec () in
-    Command_to_exec.build_and_run_in_child_process command_to_exec
+    Command_to_exec.build_and_run_in_child_process common command_to_exec
     >>| Result.map ~f:(fun pid -> state.currently_running_pid := Some pid)
   ;;
 
-  let loop ~command_to_exec =
+  let loop common ~command_to_exec =
     let state = init_state () in
-    Scheduler.Run.poll (run state ~command_to_exec)
+    Scheduler.Run.poll (run common state ~command_to_exec)
   ;;
 end
 
@@ -322,7 +326,7 @@ module Exec_context = struct
       ; env
       }
     in
-    Watch.loop ~command_to_exec
+    Watch.loop common ~command_to_exec
   ;;
 end
 
diff --git a/bin/import.ml b/bin/import.ml
index 86679de74341..f795d2ea540a 100644
--- a/bin/import.ml
+++ b/bin/import.ml
@@ -237,14 +237,16 @@ module Scheduler = struct
   ;;
 end
 
-let restore_cwd_and_execve (common : Common.t) prog argv env =
-  let prog =
-    if Filename.is_relative prog
-    then (
-      let root = Common.root common in
-      Filename.concat root.dir prog)
-    else prog
-  in
+let string_path_relative_to_specified_root (common : Common.t) path =
+  if Filename.is_relative path
+  then (
+    let root = Common.root common in
+    Filename.concat root.dir path)
+  else path
+;;
+
+let restore_cwd_and_execve common prog argv env =
+  let prog = string_path_relative_to_specified_root common prog in
   Proc.restore_cwd_and_execve prog argv ~env
 ;;
 
diff --git a/test/blackbox-tests/test-cases/exec-watch/exec-watch-multi-levels.t/run.t b/test/blackbox-tests/test-cases/exec-watch/exec-watch-multi-levels.t/run.t
index b3617bc1d1fd..b51a63d9913e 100644
--- a/test/blackbox-tests/test-cases/exec-watch/exec-watch-multi-levels.t/run.t
+++ b/test/blackbox-tests/test-cases/exec-watch/exec-watch-multi-levels.t/run.t
@@ -22,8 +22,10 @@ Perform the same test above but first enter the "bin" directory.
   Success, waiting for filesystem changes...
   foo
   Leaving directory '..'
+  $ PID=$!
   $ cd ..
-  $ wait
+  $ ../wait-for-file.sh $DONE_FLAG
+  $ kill $PID
 
 Test that the behaviour is the same when not running with "--watch"
   $ cd bin && dune exec --root .. ./bin/main.exe