Fix NT path handling and stat in eio_windows

lib_eio/utils/nt_path.ml

@@ -53,28 +53,36 @@ let volume_prefix =
   <|> (sep *> sep *> component *> next)                  (* \\server\share, \\?\C: or \\.\device *)
   <|> (bslash *> qmark *> qmark *> component *> next)    (* \??\C: - the NT object-manager form (backslash only) *)
 
-let volume_end s = Option.value (volume_prefix s 0) ~default:0
-let volume s = String.sub s 0 (volume_end s)
-
 (* Win32 does no normalization in the verbatim and NT namespaces. *)
 let verbatim_prefix = bslash *> (bslash <|> qmark) *> qmark
 let verbatim s = Option.is_some (verbatim_prefix s 0)
 
+(* [\??\], [\\?\] and [\\.\] all name the NT object-manager namespace. *)
+let nt_prefix = (verbatim_prefix <|> (bslash *> bslash *> chr '.')) *> bslash
+
 (* [is_relative p] is [true] unless [p] begins with a volume or a separator. *)
 let is_relative s = Option.is_none ((volume_prefix <|> sep) s 0)
 
+let volume_end s = Option.value (volume_prefix s 0) ~default:0
+let drop n s = String.sub s n (String.length s - n)
+
+(* A path's volume prefix, and the rest of the path. *)
+let split_volume p =
+  let n = volume_end p in
+  String.sub p 0 n, drop n p
+
 let split p =
   let vend = volume_end p in
-  let sep_at = if verbatim p then Char.equal '\\' else is_sep in
-  let sep_at i = sep_at p.[i] in
+  let sep_char = if verbatim p then Char.equal '\\' else is_sep in
+  let sep_at i = sep_char p.[i] in
   (* Trailing separators are ignored; one is kept for a bare root. *)
   let rec trim i = if i > vend + 1 && sep_at (i - 1) then trim (i - 1) else i in
   let stop = trim (String.length p) in
   if stop <= vend || (stop = vend + 1 && sep_at vend) then None
   else
     let rec rsep i = if i < vend then None else if sep_at i then Some i else rsep (i - 1) in
     match rsep (stop - 1) with
-    | None -> Some (volume p, String.sub p vend (stop - vend))
+    | None -> Some (String.sub p 0 vend, String.sub p vend (stop - vend))
     | Some idx ->
       let basename = String.sub p (idx + 1) (stop - idx - 1) in
       let dirname =
@@ -83,6 +91,15 @@ let split p =
       in
       Some (dirname, basename)
 
+let parent_and_leaf p =
+  match split p with
+  | Some ("", leaf) -> ".", leaf
+  | Some parts -> parts
+  | None -> ".", (if p = "" then "." else p)
+
+let dirname p = fst (parent_and_leaf p)
+let basename p = snd (parent_and_leaf p)
+
 let concat a b =
   let l = String.length a in
   if l = 0 then b
@@ -97,3 +114,38 @@ let join p1 p2 =
   | _, p2 when not (is_relative p2) -> p2
   | ".", p2 -> p2
   | p1, p2 -> concat p1 p2
+
+let normalise rest =
+  let rec go acc = function
+    | [] -> List.rev acc
+    | ("" | ".") :: xs -> go acc xs
+    | ".." :: xs -> go (match acc with [] -> [] | _ :: acc -> acc) xs
+    | x :: xs -> go (x :: acc) xs
+  in
+  "\\" ^ String.concat "\\" (go [] (String.split_on_char '\\' rest))
+
+(* [qualify p] is the absolute Win32 path [p] named in the NT namespace. *)
+let qualify p =
+  let after r = Option.map (fun i -> drop i p) (r p 0) in
+  "\\??\\" ^
+  match after nt_prefix, after (bslash *> bslash) with
+  | Some rest, _ -> rest                     (* \??\, \\?\ or \\.\ *)
+  | None, Some share -> "UNC\\" ^ share      (* \\server\share *)
+  | None, None -> p                          (* C:\... *)
+
+let to_nt ~cwd p =
+  if verbatim p then qualify p
+  else (
+    let backslashes = String.map (fun c -> if c = '/' then '\\' else c) in
+    let vol, rest = split_volume (backslashes p) in
+    let cwd_vol, cwd_rest = split_volume (backslashes cwd) in
+    let rooted = rest <> "" && rest.[0] = '\\' in
+    let vol, base =
+      match vol with
+      | "" -> cwd_vol, (if rooted then "" else cwd_rest)
+      | v when rooted || v.[0] = '\\' -> v, ""
+      | v when String.uppercase_ascii v = String.uppercase_ascii cwd_vol -> cwd_vol, cwd_rest
+      | v -> v, ""    (* Win32 keeps a current directory per drive; but we sadly can't see it *)
+    in
+    qualify (vol ^ normalise (base ^ "\\" ^ rest))
+  )

lib_eio/utils/nt_path.mli

@@ -7,3 +7,24 @@
     - [split]: Volume prefixes ([C:], [\\server\share], [\\?\...], [\??\...]) are never split. *)
 
 include Eio.Fs.Pi.PATH
+
+val is_relative : string -> bool
+(** [is_relative p] is [true] unless [p] begins with a volume or a separator.
+    A drive-relative path such as [C:x] is not relative, since it is resolved
+    against that drive's own current directory rather than ours. *)
+
+val dirname : string -> string
+(** [dirname p] is the directory part of [p]. It is ["."] when [p] names
+    something in the current directory, and also when [p] has no parent to
+    name (e.g. the empty path, a bare volume ([C:]) and a root ([\\server\share])). *)
+
+val basename : string -> string
+(** [basename p] is the final component of [p]. It is [p] itself when [p] has
+    no directory part, and ["."] when [p] is empty. *)
+
+val to_nt : cwd:string -> string -> string
+(** [to_nt ~cwd path] is the NT object-manager form of the Win32 path [path].
+
+    A relative [path] is resolved against [cwd] and, as in Win32, ["/"] is a
+    separator and ["."] and [".."] components are removed. Verbatim ([\\?\])
+    and NT ([\??\]) paths are passed through unchanged. *)

lib_eio_windows/eio_windows_stubs.c

@@ -88,7 +88,9 @@ void no_follow(HANDLE h) {
   BY_HANDLE_FILE_INFORMATION b;
 
   if (!GetFileInformationByHandle(h, &b)) {
-    caml_win32_maperr(GetLastError());
+    DWORD err = GetLastError();
+    CloseHandle(h);
+    caml_win32_maperr(err);
     uerror("nofollow", Nothing);
   }
 
@@ -98,8 +100,9 @@ void no_follow(HANDLE h) {
   }
 }
 
-// We recreate an openat like function using NtCreateFile
-CAMLprim value caml_eio_windows_openat(value v_dirfd, value v_nofollow, value v_pathname, value v_desired_access, value v_create_disposition, value v_create_options)
+// We recreate an openat like function using NtCreateFile.
+// [v_follow] is a [Low_level.follow]: 0 opens a symlink's target, 1 raises ELOOP on one and 2 opens the symlink itself.
+CAMLprim value caml_eio_windows_openat(value v_dirfd, value v_follow, value v_pathname, value v_desired_access, value v_create_disposition, value v_create_options)
 {
   CAMLparam2(v_dirfd, v_pathname);
   HANDLE h, dir;
@@ -108,6 +111,7 @@ CAMLprim value caml_eio_windows_openat(value v_dirfd, value v_nofollow, value v_
   wchar_t *pathname;
   UNICODE_STRING relative;
   NTSTATUS r;
+  int follow = Int_val(v_follow);
 
   // Not sure what the overhead of this is, but it allows us to have low-level control
   // over file creation. In particular, we can specify the HANDLE to the parent directory
@@ -143,41 +147,63 @@ CAMLprim value caml_eio_windows_openat(value v_dirfd, value v_nofollow, value v_
     FILE_ATTRIBUTE_NORMAL, // TODO: Could check flags to see if we can do READONLY here a la OCaml
     (FILE_SHARE_READ | FILE_SHARE_WRITE),
     Int_val(v_create_disposition),
-    ( 
+    (
        FILE_SYNCHRONOUS_IO_NONALERT
       | FILE_OPEN_FOR_BACKUP_INTENT
-      | (Bool_val(v_nofollow) ? FILE_FLAG_OPEN_REPARSE_POINT : Int_val(v_create_options))),
+      | Int_val(v_create_options)
+      | (follow != 0 ? FILE_OPEN_REPARSE_POINT : 0)),
     NULL, // Extended attribute buffer
     0     // Extended attribute buffer length
   );
 
   // Free the allocated pathname
   caml_stat_free(pathname);
 
-  if (h == INVALID_HANDLE_VALUE) {
-    caml_win32_maperr(RtlNtStatusToDosError(r));
-    uerror("openat handle", v_pathname);
-  }
-
-   if (!NT_SUCCESS(r)) {
+  if (!NT_SUCCESS(r)) {
     caml_win32_maperr(RtlNtStatusToDosError(r));
-    uerror("openat", Nothing);
+    uerror("openat", v_pathname);
   }
 
   // No follow check -- Windows doesn't actually have that ability
   // so we have to do it after the fact. This will raise if a symbolic
   // link is encountered and will close the handle.
-  if (Bool_val(v_nofollow)) {
+  if (follow == 1) {
     no_follow(h);
   }
-  
+
   CAMLreturn(caml_win32_alloc_handle(h));
 }
 
 value caml_eio_windows_openat_bytes(value* values, int argc) {
     return caml_eio_windows_openat(values[0], values[1], values[2], values[3], values[4], values[5]);
 }
 
+// The size in bytes of the target path of the symlink open on [v_fd], or None if it is not a symlink
+CAMLprim value caml_eio_windows_symlink_size(value v_fd)
+{
+  CAMLparam1(v_fd);
+  HANDLE h = Handle_val(v_fd);
+  BY_HANDLE_FILE_INFORMATION info;
+  union {
+    REPARSE_DATA_BUFFER point;
+    char raw[MAXIMUM_REPARSE_DATA_BUFFER_SIZE];
+  } buffer;
+  DWORD len;
+
+  if (!GetFileInformationByHandle(h, &info) || !(info.dwFileAttributes & FILE_ATTRIBUTE_REPARSE_POINT))
+    CAMLreturn(Val_none);
+
+  if (!DeviceIoControl(h, FSCTL_GET_REPARSE_POINT, NULL, 0, &buffer, sizeof(buffer), &len, NULL)) {
+    caml_win32_maperr(GetLastError());
+    uerror("fstat", Nothing);
+  }
+
+  if (buffer.point.ReparseTag != IO_REPARSE_TAG_SYMLINK)
+    CAMLreturn(Val_none);
+
+  CAMLreturn(caml_alloc_some(Val_int(buffer.point.SymbolicLinkReparseBuffer.SubstituteNameLength)));
+}
+
 CAMLprim value caml_eio_windows_unlinkat(value v_dirfd, value v_pathname, value v_dir)
 {
   CAMLparam2(v_dirfd, v_pathname);
@@ -192,7 +218,7 @@ CAMLprim value caml_eio_windows_unlinkat(value v_dirfd, value v_pathname, value
   // over file creation. In particular, we can specify the HANDLE to the parent directory
   // of a relative path a la openat.
   pNtCreateFile NtCreatefile = (pNtCreateFile)GetProcAddress(GetModuleHandle("ntdll.dll"), "NtCreateFile");
-  caml_unix_check_path(v_pathname, "openat");
+  caml_unix_check_path(v_pathname, "unlinkat");
   pathname = caml_stat_strdup_to_utf16(String_val(v_pathname));
   RtlInitUnicodeString(&relative, pathname);
 
@@ -230,20 +256,14 @@ CAMLprim value caml_eio_windows_unlinkat(value v_dirfd, value v_pathname, value
   // Free the allocated pathname
   caml_stat_free(pathname);
 
-  if (h == INVALID_HANDLE_VALUE) {
-    caml_win32_maperr(RtlNtStatusToDosError(r));
-    uerror("openat", v_pathname);
-  }
-
   if (!NT_SUCCESS(r)) {
     caml_win32_maperr(RtlNtStatusToDosError(r));
-    uerror("openat", v_pathname);
+    uerror("unlinkat", v_pathname);
   }
 
   // Now close the file to delete it
-  BOOL closed;
-  closed = CloseHandle(h);
-
+  CloseHandle(h);
+
   CAMLreturn(Val_unit);
 }