Windows: make Sys.remove and Unix.unlink delete symlinks to directories

Changes

@@ -111,6 +111,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 and Xavier Leroy)
+
 - #10737: add new ephemeron API for forward compatibility with Multicore
   OCaml.
   (Damien Doligez, review by Stephen Dolan)

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

@@ -10,10 +10,17 @@
 
 let link1 = "link1"
 let link2 = "link2"
+let link3 = "link3"
+let link_dir = "link_directory"
+let dir = "directory"
+let did_raise = ref false
 
 let link_exists s =
   try (Unix.lstat s).Unix.st_kind = Unix.S_LNK with _ -> false
 
+let directory_exists s =
+  try (Unix.lstat s).Unix.st_kind = Unix.S_DIR with _ -> false
+
 let main () =
   close_out (open_out "test.txt");
   if link_exists link1 then Sys.remove link1;
@@ -23,7 +30,49 @@ let main () =
   print_endline "Unix.symlink works with backwards slashes";
   Unix.symlink ~to_dir:false "./test.txt" link2;
   assert ((Unix.stat link2).Unix.st_kind = Unix.S_REG);
-  print_endline "Unix.symlink works with forward slashes"
+  print_endline "Unix.symlink works with forward slashes";
+
+  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 *) | EACCES (* Windows *)), _, _) ->
+    did_raise := true end;
+  assert (!did_raise);
+  assert (directory_exists dir);
+  print_endline "Unix.unlink cannot delete directories";
+
+  did_raise := false;
+  if not (directory_exists dir) then
+    Unix.mkdir dir 0o644;
+  begin try Sys.remove dir with Sys_error _ -> did_raise := true end;
+  assert (!did_raise);
+  assert (directory_exists dir);
+  print_endline "Sys.remove cannot delete directories";
+
+  if not (directory_exists dir) then
+    Unix.mkdir dir 0o644;
+  if not (link_exists link_dir) then
+    Unix.symlink ~to_dir:true dir link_dir;
+  Unix.unlink link_dir;
+  print_endline "Unix.unlink can delete symlinks to directories";
+
+  if not (link_exists link3) then
+    Unix.symlink ~to_dir:false "test.txt" link3;
+  Unix.unlink link3;
+  print_endline "Unix.unlink can delete symlinks to files";
+
+  if not (directory_exists dir) then
+    Unix.mkdir dir 0o644;
+  if not (link_exists link_dir) then
+    Unix.symlink ~to_dir:true dir link_dir;
+  Sys.remove link_dir;
+  print_endline "Sys.remove can delete symlinks to directories";
+
+  if not (link_exists link3) then
+    Unix.symlink ~to_dir:false "test.txt" link3;
+  Sys.remove link3;
+  print_endline "Sys.remove can delete symlinks to files"
 
 let () =
   Unix.handle_unix_error main ()

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

@@ -1,2 +1,8 @@
 Unix.symlink works with backwards slashes
 Unix.symlink works with forward slashes
+Unix.unlink cannot delete directories
+Sys.remove cannot delete directories
+Unix.unlink can delete symlinks to directories
+Unix.unlink can delete symlinks to files
+Sys.remove can delete symlinks to directories
+Sys.remove can delete symlinks to files