ocamlmerlin.c: chdir to root also on Windows to continue working if cwd is deleted

CHANGES.md

@@ -15,6 +15,8 @@ unreleased
     - Correctly traverse patterns when looking for docs in the typedtree (#1572)
     - Get documentation when the declaration or definition is selected (#1542,
       fixes #1540)
+    - On Windows, change to a harmless directory when launching server to avoid
+      locking down current directory. (#1569, fixes #1474)
   + test suite
     - Add multiple tests for locate over ill-typed expressions (#1546)
 

src/frontend/ocamlmerlin/new/new_merlin.ml

@@ -147,21 +147,30 @@ let run = function
         prerr_endline ("Exception: " ^ Printexc.to_string exn);
         1
 
+let with_wd ~wd ~old_wd f args =
+  match Sys.chdir wd with
+  | () ->
+    log ~title:"run" "changed directory to %S (old wd: %S)" wd old_wd;
+    Fun.protect ~finally:(fun () -> Sys.chdir old_wd) (fun () -> f args)
+  | exception Sys_error _ ->
+    log ~title:"run" "cannot change working directory to %S (old wd: %S)"
+      wd old_wd;
+    f args
+
 let run ~new_env wd args =
   begin match new_env with
   | Some env ->
     Os_ipc.merlin_set_environ env;
     Unix.putenv "__MERLIN_MASTER_PID" (string_of_int (Unix.getpid ()))
   | None -> () end;
-  let wd_msg = match wd with
-    | None -> "No working directory specified"
-    | Some wd ->
-      try Sys.chdir wd; Printf.sprintf "changed directory to %S" wd
-      with _ -> Printf.sprintf "cannot change working directory to %S" wd
+  let old_wd = Sys.getcwd () in
+  let run args () = match wd with
+    | Some wd -> with_wd ~wd ~old_wd run args
+    | None ->
+      log ~title:"run" "No working directory specified (old wd: %S)" old_wd;
+      run args
   in
   let `Log_file_path log_file, `Log_sections sections =
     Log_info.get ()
   in
-  Logger.with_log_file log_file ~sections @@ fun () ->
-  log ~title:"run" "%s" wd_msg;
-  run args
+  Logger.with_log_file log_file ~sections @@ run args

src/frontend/ocamlmerlin/ocamlmerlin.c

@@ -279,7 +279,7 @@ static int connect_socket(const char *socketname, int fail)
 #ifdef _WIN32
 static void start_server(const char *socketname, const char* eventname, const char *exec_path)
 {
-  char buf[PATHSZ];
+  char buf[PATHSZ], lpSystemDir[PATHSZ];
   PROCESS_INFORMATION pi;
   STARTUPINFO si;
   HANDLE hEvent = CreateEvent(NULL, FALSE, FALSE, eventname);
@@ -288,9 +288,12 @@ static void start_server(const char *socketname, const char* eventname, const ch
   ZeroMemory(&si, sizeof(si));
   si.cb = sizeof(si);
   ZeroMemory(&pi, sizeof(pi));
+  /* Change to a harmless directory, so that process still works if the current
+     directory is deleted. */
+  GetSystemDirectory(lpSystemDir, PATHSZ);
   /* Note that DETACHED_PROCESS means that the process does not appear in Task Manager
      but the server can still be stopped with ocamlmerlin server stop-server */
-  if (!CreateProcess(exec_path, buf, NULL, NULL, FALSE, DETACHED_PROCESS, NULL, NULL, &si, &pi))
+  if (!CreateProcess(exec_path, buf, NULL, NULL, FALSE, DETACHED_PROCESS, NULL, lpSystemDir, &si, &pi))
     failwith_perror("fork");
   CloseHandle(pi.hProcess);
   CloseHandle(pi.hThread);

tests/test-dirs/server-tests/chdir_to_root.t

@@ -0,0 +1,13 @@
+In case server is running, stop it.
+
+  $ $MERLIN server stop-server
+
+Check that the working directory of the server process is correctly restored.
+
+  $ touch test.ml
+  $ export MERLIN_LOG=-
+  $ $MERLIN server errors -filename test.ml < test.ml 2>&1 | grep 'old wd'
+  changed directory to "$TESTCASE_ROOT" (old wd: "/")
+  $ $MERLIN server errors -filename test.ml < test.ml 2>&1 | grep 'old wd'
+  changed directory to "$TESTCASE_ROOT" (old wd: "/")
+  $ $MERLIN server stop-server

tests/test-dirs/server-tests/dune

@@ -3,3 +3,8 @@
  (applies_to :whole_subtree)
  (alias all-server-tests)
  (locks merlin_server))
+
+(cram
+ (applies_to chdir_to_root)
+ (enabled_if
+  (<> %{os_type} Win32)))