From 84453e6016c43a97c650e624e04475760b75f012 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Antonin=20D=C3=A9cimo?= <antonin.decimo@gmail.com>
Date: Mon, 3 May 2021 10:04:07 +0200
Subject: [PATCH] Try removing the RO bit when unlinking files on Windows
 (#849)

* Try removing the RO bit when unlinking files on Windows

On Windows, some programs may set the read-only bit on files. For
instance, git marks its index files as read-only. Calling
`Unix.unlink` on such a file will result in an
`Unix.Unix_error(Unix.EACCES, "unlink", _)` exception.

`Lwt_io.with_temp_dir` creates a temporary directory in which it is
possible that a read-only file is created. In such case, the
`delete_recursively` function will not be able to clean the temporary
directory and will also raise an exception.

This patch allows by setting the file writable (removing the RO bit)
to delete the file.

This code was copied from Dune:
https://github.com/ocaml/dune/blob/ed361ebc4f37a81d3e6ffc905b0d45f61bc17e9c/otherlibs/stdune-unstable/fpath.ml#L74-L88

* Use Lwt.catch instead of try-with and restore perms if unlink fails
---
 CHANGES            |  2 ++
 src/unix/lwt_io.ml | 24 +++++++++++++++++++++++-
 2 files changed, 25 insertions(+), 1 deletion(-)

diff --git a/CHANGES b/CHANGES
index 311a74a2cb..94994bece5 100644
--- a/CHANGES
+++ b/CHANGES
@@ -4,6 +4,8 @@
 
   * Fix Lwt_fmt.stderr to actually point to stderr (#852, #850, Volker Diels-Grabsch).
 
+  * Make temporary files created by Lwt_io.with_temp_dir deletable on Windows by removing the RO bit (#849, Antonin Décimo)
+
 
 
 ===== 5.4.0 (2020-12-16) =====
diff --git a/src/unix/lwt_io.ml b/src/unix/lwt_io.ml
index e788d3c87d..01988ed59a 100644
--- a/src/unix/lwt_io.ml
+++ b/src/unix/lwt_io.ml
@@ -1470,6 +1470,28 @@ let create_temp_dir
   in
   attempt 0
 
+let win32_unlink fn =
+  Lwt.catch
+    (fun () -> Lwt_unix.unlink fn)
+    (function
+     | Unix.Unix_error (Unix.EACCES, _, _) as exn ->
+       Lwt_unix.lstat fn >>= fun {st_perm; _} ->
+       (* Try removing the read-only attribute *)
+       Lwt_unix.chmod fn 0o666 >>= fun () ->
+       Lwt.catch
+         (fun () -> Lwt_unix.unlink fn)
+         (function _ ->
+            (* Restore original permissions *)
+            Lwt_unix.chmod fn st_perm >>= fun () ->
+            Lwt.fail exn)
+     | exn -> Lwt.fail exn)
+
+let unlink =
+  if Sys.win32 then
+    win32_unlink
+  else
+    Lwt_unix.unlink
+
 (* This is likely VERY slow for directories with many files. That is probably
    best addressed by switching to blocking calls run inside a worker thread,
    i.e. with Lwt_preemptive. *)
@@ -1485,7 +1507,7 @@ let rec delete_recursively directory =
       if stat.Lwt_unix.st_kind = Lwt_unix.S_DIR then
         delete_recursively path
       else
-        Lwt_unix.unlink path
+        unlink path
   end >>= fun () ->
   Lwt_unix.rmdir directory