Implement flock on Windows with LockFileEx + 'dune clean' fix on Wind…

…ows (#6523)

Signed-off-by: Nicolás Ojeda Bär <[email protected]>

CHANGES.md

@@ -15,6 +15,10 @@ Unreleased
 
 - Fix build with MSVC compiler (#6517, @nojb)
 
+- `dune clean` should no longer fail under Windows due to the inability to
+  remove the `.lock` file. Also, bring the implementation of the global lock
+  under Windows closer to that of Unix. (#6523, @nojb)
+
 3.6.0 (2022-11-14)
 ------------------
 

src/dune_util/dune_flock.c

@@ -3,18 +3,52 @@
 #include <caml/threads.h>
 #include <caml/unixsupport.h>
 
-#ifndef _WIN32
+#ifdef _WIN32
+
+#define FD_val(value) Handle_val(value)
+
+CAMLprim value dune_flock_lock(value v_fd, value v_block, value v_exclusive) {
+  CAMLparam3(v_fd, v_block, v_exclusive);
+  OVERLAPPED overlapped = { 0 };
+  DWORD ok, dwFlags = 0;
+  if (Bool_val(v_exclusive)) {
+    dwFlags |= LOCKFILE_EXCLUSIVE_LOCK;
+  }
+  if (!Bool_val(v_block)) {
+    dwFlags |= LOCKFILE_FAIL_IMMEDIATELY;
+  }
+  caml_release_runtime_system();
+  ok = LockFileEx(FD_val(v_fd), dwFlags, 0, MAXDWORD, MAXDWORD, &overlapped);
+  caml_acquire_runtime_system();
+  if (!ok) {
+    win32_maperr(GetLastError());
+    uerror("LockFileEx", Nothing);
+  }
+  CAMLreturn(Val_unit);
+}
+
+CAMLprim value dune_flock_unlock(value v_fd) {
+  CAMLparam1(v_fd);
+  OVERLAPPED overlapped = { 0 };
+  DWORD ok;
+  caml_release_runtime_system();
+  ok = UnlockFileEx(FD_val(v_fd), 0, MAXDWORD, MAXDWORD, &overlapped);
+  caml_acquire_runtime_system();
+  if (!ok) {
+    win32_maperr(GetLastError());
+    uerror("UnlockFileEx", Nothing);
+  }
+  CAMLreturn(Val_unit);
+}
+
+#else /* _WIN32 */
+
 #include <sys/file.h>
-#endif
 
 #define FD_val(value) Int_val(value)
 
 CAMLprim value dune_flock_lock(value v_fd, value v_block, value v_exclusive) {
-#ifdef _WIN32
-  caml_failwith("no flock on win32");
-  return Val_unit;
-#else
-  CAMLparam2(v_fd, v_block);
+  CAMLparam3(v_fd, v_block, v_exclusive);
   int flags = 0;
   if (Bool_val(v_exclusive)) {
     flags |= LOCK_EX;
@@ -30,14 +64,9 @@ CAMLprim value dune_flock_lock(value v_fd, value v_block, value v_exclusive) {
   } else {
     uerror("flock", Nothing);
   }
-#endif
 }
 
 CAMLprim value dune_flock_unlock(value v_fd) {
-#ifdef _WIN32
-  caml_failwith("no flock on win32");
-  return Val_unit;
-#else
   CAMLparam1(v_fd);
   caml_release_runtime_system();
   int ret = flock(FD_val(v_fd), LOCK_UN);
@@ -47,5 +76,6 @@ CAMLprim value dune_flock_unlock(value v_fd) {
   } else {
     uerror("flock", Nothing);
   }
-#endif
 }
+
+#endif /* _WIN32 */

src/dune_util/flock.ml

@@ -21,7 +21,8 @@ let lock_block t lock =
 let lock_non_block t lock =
   match gen_lock t ~block:false ~exclusive:(is_exclusive lock) with
   | () -> Ok `Success
-  | exception Unix.Unix_error ((EWOULDBLOCK | EAGAIN), _, _) -> Ok `Failure
+  | exception Unix.Unix_error ((EWOULDBLOCK | EAGAIN | EACCES), _, _) ->
+    Ok `Failure
   | exception Unix.Unix_error (err, _, _) -> Error err
 
 external unlock : t -> unit = "dune_flock_unlock"

src/dune_util/global_lock.ml

@@ -14,76 +14,32 @@ let with_timeout ~timeout f =
   in
   loop ()
 
-module type S = sig
-  val lock : unit -> [ `Success | `Failure ]
-
-  val unlock : unit -> unit
-end
-
 let write_pid fd =
   let pid = Int.to_string (Unix.getpid ()) in
   let len = String.length pid in
   let res = Unix.write fd (Bytes.of_string pid) 0 len in
   assert (res = len)
 
-module Win () : S = struct
-  let t = ref None
-
-  let create () =
-    Path.ensure_build_dir_exists ();
-    match
-      Unix.openfile
-        (Path.Build.to_string lock_file)
-        [ O_CREAT; O_EXCL; O_WRONLY ]
-        0o600
-    with
-    | exception _ -> None
-    | fd ->
-      Unix.set_close_on_exec fd;
-      write_pid fd;
-      Some fd
-
-  let () =
-    at_exit (fun () ->
-        match !t with
-        | None -> ()
-        | Some fd ->
-          Unix.close fd;
-          Path.rm_rf (Path.build lock_file))
-
-  let lock () =
-    match !t with
-    | Some _ -> `Success
-    | None -> (
-      match create () with
-      | None -> `Failure
-      | Some fd ->
-        t := Some fd;
-        `Success)
-
-  let unlock () =
-    match !t with
-    | None -> ()
-    | Some fd ->
-      Unix.close fd;
-      Path.rm_rf (Path.build lock_file)
-end
-
-module Unix () : S = struct
+module Lock = struct
   let t =
     lazy
       (Path.ensure_build_dir_exists ();
        let fd =
          Unix.openfile
            (Path.Build.to_string lock_file)
-           [ Unix.O_CREAT; O_WRONLY ] 0o600
+           [ Unix.O_CREAT; O_WRONLY; O_SHARE_DELETE ]
+           0o600
        in
        Unix.set_close_on_exec fd;
        Flock.create fd)
 
   let or_raise_unix ~name = function
     | Ok s -> s
-    | Error _unix -> Code_error.raise "lock" [ ("name", Dyn.string name) ]
+    | Error error ->
+      Code_error.raise "lock"
+        [ ("name", Dyn.string name)
+        ; ("error", Dyn.string (Unix.error_message error))
+        ]
 
   let lock () =
     let t = Lazy.force t in
@@ -98,8 +54,6 @@ module Unix () : S = struct
   let unlock () = Lazy.force t |> Flock.unlock |> or_raise_unix ~name:"unlock"
 end
 
-module Lock = (val if Sys.win32 then (module Win ()) else (module Unix ()) : S)
-
 let locked = ref false
 
 let lock_exn ~timeout =