Windows: Sys.remove, Unix.unlink now remove symlinks to directories

On Windows, calling `_wunlink` on a path may fail with `EACCES` if [1]:
1. the path specifies a read-only file;
2. the path specifies a directory.

On Windows, a symbolic link to a directory is actually a directory
with an associated reparse point. The consequence is that `_wunlink`
will fail on them. However, POSIX `unlink(2)` specifies [2] that it
will gladly unlink symlinks to directories. POSIX `unlink(2)` also
forbids deletion of directories.

To emulate that behaviour, we wrap the `_wunlink` call. If it fails
with `EACCES`, we have to check whether the path is a directory with
an associated reparse point, and that the type of the reparse point is
a symbolic link. If so, we call `_wrmdir` on the path.

[1]: https://docs.microsoft.com/en-us/cpp/c-runtime-library/reference/unlink-wunlink?view=msvc-160
[2]: https://pubs.opengroup.org/onlinepubs/9699919799/functions/unlink.html

We cannot define `unlink_os` to `caml_win32_unlink` as ocamlyacc
includes `caml/misc.h`. It would need the definition from `win32.c`,
which isn't linked in ocamlyacc.

Introduce the `caml/winsupport.h` header to hold common code between
the runtime, lib-sys, and win32unix. This is also mandated by the name
conflict between `ATOM` from `<windef.h>` and `caml/instruct.h`.

Changes

@@ -86,6 +86,12 @@ Working version
   (Sébastien Hinderer, review by Damien Doligez, Gabriel Scherer, David
   Allsopp, Nicolás Ojeda Bär, Vincent Laviron)
 
+- #10642: On Windows, Sys.remove and Unix.unlink now remove symlinks
+  to directories instead of raising EACCES. Introduce
+  caml/winsupport.h to hold more common code between the runtime,
+  lib-sys, and win32unix. (Antonin Décimo, review by David Allsopp,
+  Xavier Leroy)
+
 ### Other libraries:
 
 - #10192: Add support for Unix domain sockets on Windows and use them

otherlibs/unix/unlink.c

@@ -29,7 +29,7 @@ CAMLprim value unix_unlink(value path)
   caml_unix_check_path(path, "unlink");
   p = caml_stat_strdup_to_os(String_val(path));
   caml_enter_blocking_section();
-  ret = unlink_os(p);
+  ret = caml_unlink(p);
   caml_leave_blocking_section();
   caml_stat_free(p);
   if (ret == -1) uerror("unlink", path);

otherlibs/win32unix/readlink.c

@@ -23,6 +23,7 @@
 #include "unixsupport.h"
 #include <errno.h>
 #include <winioctl.h>
+#include <caml/winsupport.h>
 
 CAMLprim value unix_readlink(value opath)
 {

otherlibs/win32unix/stat.c

@@ -34,6 +34,7 @@
 #include <sys/stat.h>
 #include <time.h>
 #include <winioctl.h>
+#include "caml/winsupport.h"
 
 #ifndef S_IFLNK
 /*

otherlibs/win32unix/unixsupport.h

@@ -92,45 +92,6 @@ extern int win_set_inherit(HANDLE fd, BOOL inherit);
 }
 #endif
 
-/*
- * This structure is defined inconsistently. mingw64 has it in ntdef.h (which
- * doesn't look like a primary header) and technically it's part of ntifs.h in
- * the WDK. Requiring the WDK is a bit extreme, so the definition is taken from
- * ntdef.h. Both ntdef.h and ntifs.h define REPARSE_DATA_BUFFER_HEADER_SIZE
- */
-#ifndef REPARSE_DATA_BUFFER_HEADER_SIZE
-typedef struct _REPARSE_DATA_BUFFER
-{
-  ULONG  ReparseTag;
-  USHORT ReparseDataLength;
-  USHORT Reserved;
-  union
-  {
-    struct
-    {
-      USHORT SubstituteNameOffset;
-      USHORT SubstituteNameLength;
-      USHORT PrintNameOffset;
-      USHORT PrintNameLength;
-      ULONG  Flags;
-      WCHAR  PathBuffer[1];
-    } SymbolicLinkReparseBuffer;
-    struct
-    {
-      USHORT SubstituteNameOffset;
-      USHORT SubstituteNameLength;
-      USHORT PrintNameOffset;
-      USHORT PrintNameLength;
-      WCHAR  PathBuffer[1];
-    } MountPointReparseBuffer;
-    struct
-    {
-      UCHAR  DataBuffer[1];
-    } GenericReparseBuffer;
-  };
-} REPARSE_DATA_BUFFER, *PREPARSE_DATA_BUFFER;
-#endif
-
 #define EXECV_CAST (const char_os * const *)
 
 #endif /* CAML_UNIXSUPPORT_H */

runtime/caml/misc.h

@@ -382,6 +382,13 @@ extern double caml_log1p(double);
 
 #endif /* _WIN32 */
 
+/* Wrapper for Windows unlink */
+#ifdef _WIN32
+#define caml_unlink caml_win32_unlink
+#else
+#define caml_unlink unlink_os
+#endif
+
 
 /* Data structures */
 

runtime/caml/osdeps.h

@@ -111,6 +111,7 @@ extern int caml_num_rows_fd(int fd);
 #ifdef _WIN32
 
 extern int caml_win32_rename(const wchar_t *, const wchar_t *);
+CAMLextern int caml_win32_unlink(const wchar_t *);
 
 extern void caml_probe_win32_version(void);
 extern void caml_setup_win32_terminal(void);

runtime/caml/winsupport.h

@@ -0,0 +1,65 @@
+/**************************************************************************/
+/*                                                                        */
+/*                                 OCaml                                  */
+/*                                                                        */
+/*                David Allsopp, MetaStack Solutions Ltd.                 */
+/*                                                                        */
+/*   Copyright 2015 MetaStack Solutions Ltd.                              */
+/*                                                                        */
+/*   All rights reserved.  This file is distributed under the terms of    */
+/*   the GNU Lesser General Public License version 2.1, with the          */
+/*   special exception on linking described in the file LICENSE.          */
+/*                                                                        */
+/**************************************************************************/
+
+/* Operating system - Windows specific stuff */
+
+#ifndef CAML_WINSUPPORT_H
+#define CAML_WINSUPPORT_H
+
+#if defined(_WIN32) && defined(CAML_INTERNALS)
+
+#include <windef.h>
+
+/*
+ * This structure is defined inconsistently. mingw64 has it in ntdef.h (which
+ * doesn't look like a primary header) and technically it's part of ntifs.h in
+ * the WDK. Requiring the WDK is a bit extreme, so the definition is taken from
+ * ntdef.h. Both ntdef.h and ntifs.h define REPARSE_DATA_BUFFER_HEADER_SIZE
+ */
+#ifndef REPARSE_DATA_BUFFER_HEADER_SIZE
+typedef struct _REPARSE_DATA_BUFFER
+{
+  ULONG  ReparseTag;
+  USHORT ReparseDataLength;
+  USHORT Reserved;
+  union
+  {
+    struct
+    {
+      USHORT SubstituteNameOffset;
+      USHORT SubstituteNameLength;
+      USHORT PrintNameOffset;
+      USHORT PrintNameLength;
+      ULONG  Flags;
+      WCHAR  PathBuffer[1];
+    } SymbolicLinkReparseBuffer;
+    struct
+    {
+      USHORT SubstituteNameOffset;
+      USHORT SubstituteNameLength;
+      USHORT PrintNameOffset;
+      USHORT PrintNameLength;
+      WCHAR  PathBuffer[1];
+    } MountPointReparseBuffer;
+    struct
+    {
+      UCHAR  DataBuffer[1];
+    } GenericReparseBuffer;
+  };
+} REPARSE_DATA_BUFFER, *PREPARSE_DATA_BUFFER;
+#endif
+
+#endif
+
+#endif /* CAML_WINSUPPORT_H */

runtime/sys.c

@@ -289,7 +289,7 @@ CAMLprim value caml_sys_remove(value name)
   caml_sys_check_path(name);
   p = caml_stat_strdup_to_os(String_val(name));
   caml_enter_blocking_section();
-  ret = unlink_os(p);
+  ret = caml_unlink(p);
   caml_leave_blocking_section();
   caml_stat_free(p);
   if (ret != 0) caml_sys_error(name);

runtime/win32.c

@@ -26,6 +26,8 @@
 #include <wtypes.h>
 #include <winbase.h>
 #include <winsock2.h>
+#include <winioctl.h>
+#include <direct.h>
 #include <stdlib.h>
 #include <stdio.h>
 #include <stdarg.h>
@@ -46,6 +48,7 @@
 #include "caml/osdeps.h"
 #include "caml/signals.h"
 #include "caml/sys.h"
+#include "caml/winsupport.h"
 
 #include "caml/config.h"
 
@@ -797,6 +800,48 @@ int caml_win32_rename(const wchar_t * oldpath, const wchar_t * newpath)
   return -1;
 }
 
+int caml_win32_unlink(const wchar_t * path) {
+  int ret;
+
+  ret = _wunlink(path);
+  /* On Windows, trying to unlink a symlink to a directory will return
+   * EACCES, but the symlink can be deleted with rmdir. */
+  if (ret == -1 && errno == EACCES) {
+    HANDLE h;
+    DWORD attrs, dummy;
+    union {
+      char raw[16384];
+      REPARSE_DATA_BUFFER point;
+    } buffer;
+
+    attrs = GetFileAttributes(path);
+    if (attrs == INVALID_FILE_ATTRIBUTES ||
+        !(attrs & (FILE_ATTRIBUTE_DIRECTORY | FILE_ATTRIBUTE_REPARSE_POINT)))
+      return -1;
+
+    h = CreateFile(path,
+                   FILE_READ_ATTRIBUTES,
+                   FILE_SHARE_DELETE | FILE_SHARE_READ | FILE_SHARE_WRITE,
+                   NULL,
+                   OPEN_EXISTING,
+                   FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT,
+                   NULL);
+    if (h == INVALID_HANDLE_VALUE)
+      return -1;
+
+    ret = DeviceIoControl(h, FSCTL_GET_REPARSE_POINT, NULL, 0, &buffer.point,
+                          sizeof(buffer.raw), &dummy, NULL);
+    CloseHandle(h);
+    if (!ret || buffer.point.ReparseTag != IO_REPARSE_TAG_SYMLINK)
+      return -1;
+
+    ret = _wrmdir(path);
+    if (ret == -1)
+      errno = EACCES;
+  }
+  return ret;
+}
+
 /* Windows Unicode support */
 static uintnat windows_unicode_enabled = WINDOWS_UNICODE;
 

testsuite/tests/lib-unix/win-symlink/test.ml

@@ -35,7 +35,9 @@ let main () =
   did_raise := false;
   if not (directory_exists dir) then
     Unix.mkdir dir 0o644;
-  begin try Unix.unlink dir with Unix.Unix_error((EISDIR (* Linux *) | EPERM (* POSIX *)), _, _) -> did_raise := true end;
+  begin try Unix.unlink dir with
+  | Unix.Unix_error((EISDIR (* Linux *) | EPERM (* POSIX *) | EACCES (* Windows *)), _, _) ->
+    did_raise := true end;
   assert (!did_raise);
   assert (directory_exists dir);
   print_endline "Unix.unlink cannot delete directories";