From 3c2a48e66969d16567477bac21976f85e193fd5b Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Sat, 5 Sep 2026 17:22:34 +0100 Subject: [PATCH 01/14] Fix error reporting in the eio_windows openat and unlinkat stubs The stubs checked an uninitialized handle before the NtCreateFile status --- lib_eio_windows/eio_windows_stubs.c | 27 +++++++++------------------ 1 file changed, 9 insertions(+), 18 deletions(-) diff --git a/lib_eio_windows/eio_windows_stubs.c b/lib_eio_windows/eio_windows_stubs.c index 4e26e21c5..3cb83332e 100755 --- a/lib_eio_windows/eio_windows_stubs.c +++ b/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); } @@ -154,14 +156,9 @@ CAMLprim value caml_eio_windows_openat(value v_dirfd, value v_nofollow, value v_ // 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 @@ -192,7 +189,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 +227,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); } From 0410489befb7681d65040580f77a2869f0b298c0 Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Mon, 7 Sep 2026 09:36:51 +0100 Subject: [PATCH 02/14] Add tests for Win32 paths given to the unsandboxed fs Absolute and relative paths given to fs are passed to NtCreateFile unqualified and fail with ENOENT, unless already in NT form (#931). --- lib_eio_windows/test/test_fs.ml | 98 +++++++++++++++++++++++++++++++-- 1 file changed, 94 insertions(+), 4 deletions(-) diff --git a/lib_eio_windows/test/test_fs.ml b/lib_eio_windows/test/test_fs.ml index 90465e404..2e63e8c7c 100755 --- a/lib_eio_windows/test/test_fs.ml +++ b/lib_eio_windows/test/test_fs.ml @@ -51,6 +51,28 @@ let try_rmdir path = let with_temp_file path fn = Fun.protect (fun () -> fn path) ~finally:(fun () -> Eio.Path.unlink path) +(* Remove [paths] after [fn], ignoring any that have gone already. List a + directory after its contents. *) +let with_cleanup paths fn = + let rm path = + try Unix.unlink path + with Unix.Unix_error _ -> (try Unix.rmdir path with Unix.Unix_error _ -> ()) + in + Fun.protect fn ~finally:(fun () -> List.iter rm paths) + +(* A temporary file made by the stdlib, so that [fs] is given an absolute path. *) +let with_stdlib_temp_file prefix fn = + let path = Filename.temp_file prefix "" in + with_cleanup [path] (fun () -> fn path) + +(* Making a symlink needs a privilege that older Windows withholds. *) +let with_symlinks fn = + if Unix.has_symlink () then fn () else Alcotest.skip () + +(* Read and write without Eio, to see what really landed on disk. *) +let write_file path data = Out_channel.with_open_bin path (fun oc -> Out_channel.output_string oc data) +let read_file path = In_channel.with_open_bin path In_channel.input_all + let chdir path = traceln "chdir %S" path; Unix.chdir path @@ -204,9 +226,7 @@ let test_symlink env () = Unix.mkdir "another" 0o700; print_endline @@ Unix.realpath "to-subdir" |} *) - if not (Unix.has_symlink ()) then - Printf.printf "Skipping test_symlink on systems that don't support symlinks.\n" - else + with_symlinks @@ fun () -> let cwd = Eio.Stdenv.cwd env in try_mkdir (cwd / "sandbox"); Unix.symlink ~to_dir:true ".." "sandbox\\to-root"; @@ -313,6 +333,69 @@ let test_remove_dir env () = in () +(* Absolute Win32 paths via the unsandboxed [fs] (#931) *) +let test_fs_absolute_read env () = + let fs = Eio.Stdenv.fs env in + with_stdlib_temp_file "eio-abs" @@ fun path -> + let data = "abs-read-data" in + write_file path data; + Alcotest.(check string) "same data" data (Path.load (fs / path)); + let dir = Filename.dirname path in + let unnormalised = String.concat "/" [dir; ".."; Filename.basename dir; Filename.basename path] in + Alcotest.(check string) "with .. and /" data (Path.load (fs / unnormalised)) + +let test_fs_absolute_write env () = + let fs = Eio.Stdenv.fs env in + let path = Filename.temp_file "eio-abs-write" "" in + Unix.unlink path; + with_cleanup [path] @@ fun () -> + let data = "abs-write-data" in + Path.save ~create:(`Exclusive 0o600) (fs / path) data; + Alcotest.(check string) "same data" data (read_file path) + +let test_fs_absolute_unlink env () = + let fs = Eio.Stdenv.fs env in + with_stdlib_temp_file "eio-abs-unlink" @@ fun path -> + Path.unlink (fs / path); + Alcotest.(check bool) "file gone" false (Sys.file_exists path) + +let test_fs_absolute_mkdir_rmdir env () = + let fs = Eio.Stdenv.fs env in + let path = Filename.temp_file "eio-abs-dir" "" in + Unix.unlink path; + with_cleanup [path] @@ fun () -> + Path.mkdir ~perm:0o700 (fs / path); + Alcotest.(check bool) "is dir" true (Sys.is_directory path); + Path.rmdir (fs / path); + Alcotest.(check bool) "dir gone" false (Sys.file_exists path) + +let test_fs_relative_read env () = + let fs = Eio.Stdenv.fs env in + let name = "fs-rel-test-file" in + let data = "rel-read-data" in + with_cleanup [name] @@ fun () -> + write_file name data; + Alcotest.(check string) "same data" data (Path.load (fs / name)) + +let test_fs_nt_prefixed_read env () = + let fs = Eio.Stdenv.fs env in + with_stdlib_temp_file "eio-nt" @@ fun path -> + let data = "nt-prefixed-data" in + write_file path data; + Alcotest.(check string) "same data" data (Path.load (fs / ("\\??\\" ^ path))) + +let test_fs_symlink_follow_read env () = + with_symlinks @@ fun () -> + let fs = Eio.Stdenv.fs env in + let data = "symlink-follow-data" in + let target = "slt-target" and link = "slt-link" in + with_cleanup [link; target] @@ fun () -> + write_file target data; + Unix.symlink target link; + Alcotest.(check string) "relative link" data (Path.load (fs / link)); + let abs_link = Filename.concat (Sys.getcwd ()) link in + Alcotest.(check string) "absolute link" data (Path.load (fs / abs_link)) + let tests env = [ "create-write-read", `Quick, test_create_and_read env; "absolute-join", `Quick, test_absolute_join env; @@ -329,5 +412,12 @@ let tests env = [ "unlink", `Quick, test_unlink env; "failing-unlink", `Quick, try_failing_unlink env; "rmdir", `Quick, test_remove_dir env; - "mkdirs", `Quick, test_mkdirs env; + "mkdirs", `Quick, test_mkdirs env; + "fs-absolute-read", `Quick, test_fs_absolute_read env; + "fs-absolute-write", `Quick, test_fs_absolute_write env; + "fs-absolute-unlink", `Quick, test_fs_absolute_unlink env; + "fs-absolute-mkdir-rmdir", `Quick, test_fs_absolute_mkdir_rmdir env; + "fs-relative-read", `Quick, test_fs_relative_read env; + "fs-nt-prefixed-read", `Quick, test_fs_nt_prefixed_read env; + "fs-symlink-follow-read", `Quick, test_fs_symlink_follow_read env; ] From 12e585db78e60419ef5589ec8ac0be571c191a5d Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Sun, 6 Sep 2026 20:33:02 +0100 Subject: [PATCH 03/14] Qualify Win32 paths as NT paths when openat has no directory handle Unqualified paths (like `C:\foo`) raised ENOENT. We now convert such paths before passing them through to Win32. Fixes #931. --- lib_eio/utils/nt_path.ml | 55 ++++++++++++++++++++++++---- lib_eio/utils/nt_path.mli | 7 ++++ lib_eio_windows/fs.ml | 15 ++------ lib_eio_windows/low_level.ml | 7 ++++ lib_eio_windows/low_level.mli | 6 +++- lib_eio_windows/test/test_fs.ml | 2 +- tests/fs.md | 64 +++++++++++++++++++++++++++++++++ 7 files changed, 136 insertions(+), 20 deletions(-) diff --git a/lib_eio/utils/nt_path.ml b/lib_eio/utils/nt_path.ml index 554da6abd..1df3d34df 100644 --- a/lib_eio/utils/nt_path.ml +++ b/lib_eio/utils/nt_path.ml @@ -53,20 +53,28 @@ 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 @@ -74,7 +82,7 @@ let split p = 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 = @@ -97,3 +105,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)) + ) diff --git a/lib_eio/utils/nt_path.mli b/lib_eio/utils/nt_path.mli index cb1b9cb64..22a2e6c35 100644 --- a/lib_eio/utils/nt_path.mli +++ b/lib_eio/utils/nt_path.mli @@ -7,3 +7,10 @@ - [split]: Volume prefixes ([C:], [\\server\share], [\\?\...], [\??\...]) are never split. *) include Eio.Fs.Pi.PATH + +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. *) diff --git a/lib_eio_windows/fs.ml b/lib_eio_windows/fs.ml index 433e2dc7e..b9253c55b 100755 --- a/lib_eio_windows/fs.ml +++ b/lib_eio_windows/fs.ml @@ -26,9 +26,6 @@ open Eio.Std module Fd = Eio_unix.Fd -(* NT object-manager namespace prefix, required by NtCreateFile. *) -let nt_prefix = "\\??\\" - module rec Dir : sig include Eio.Fs.Pi.DIR @@ -61,9 +58,9 @@ end = struct let full = Err.run Low_level.realpath (Filename.concat dir_path path) in let prefix_len = String.length dir_path + 1 in if String.length full >= prefix_len && String.sub full 0 prefix_len = dir_path ^ Filename.dir_sep then begin - nt_prefix ^ full + full end else if full = dir_path then - nt_prefix ^ full + full else raise @@ Eio.Fs.err (Permission_denied (Err.Outside_sandbox (full, dir_path))) ) else ( @@ -71,12 +68,6 @@ end = struct ) ) else path - let strip_nt_prefix p = - let n = String.length nt_prefix in - if String.starts_with ~prefix:nt_prefix p - then String.sub p n (String.length p - n) - else p - let with_parent_dir t path fn = if t.sandbox then ( if t.closed then Fmt.invalid_arg "Attempt to use closed directory %S" t.dir_path; @@ -218,7 +209,7 @@ end = struct if Filename.is_relative path then ( let p = if t.dir_path = "." then path - else Filename.concat (strip_nt_prefix t.dir_path) path + else Filename.concat t.dir_path path in if p = "" then "." else if p = "." then p diff --git a/lib_eio_windows/low_level.ml b/lib_eio_windows/low_level.ml index dc43bcc00..ed9522956 100755 --- a/lib_eio_windows/low_level.ml +++ b/lib_eio_windows/low_level.ml @@ -223,11 +223,17 @@ let rec with_dirfd op dirfd fn = | Some dirfd -> Fd.use_exn op dirfd (fun fd -> fn (Some fd)) | exception Unix.Unix_error(Unix.EINTR, _, "") -> with_dirfd op dirfd fn +let nt_path dirfd path = + match dirfd with + | Some _ -> path + | None -> Eio_utils.Nt_path.to_nt ~cwd:(Sys.getcwd ()) path + external eio_openat : Unix.file_descr option -> bool -> string -> Flags.Open.t -> Flags.Disposition.t -> Flags.Create.t -> Unix.file_descr = "caml_eio_windows_openat_bytes" "caml_eio_windows_openat" let openat ?dirfd ?(nofollow=false) ~sw path flags dis create = with_dirfd "openat" dirfd @@ fun dirfd -> Switch.check sw; + let path = nt_path dirfd path in in_worker_thread ~label:"openat" (fun () -> eio_openat dirfd nofollow path Flags.Open.(flags + cloexec (* + nonblock *)) dis create) |> Fd.of_unix ~sw ~blocking:false ~close_unix:true @@ -240,6 +246,7 @@ external eio_unlinkat : Unix.file_descr option -> string -> bool -> unit = "caml let unlink ?dirfd ~dir path = with_dirfd "unlink" dirfd @@ fun dirfd -> + let path = nt_path dirfd path in in_worker_thread ~label:"unlink" @@ fun () -> eio_unlinkat dirfd path dir diff --git a/lib_eio_windows/low_level.mli b/lib_eio_windows/low_level.mli index 14d65afd7..8fa9187fb 100755 --- a/lib_eio_windows/low_level.mli +++ b/lib_eio_windows/low_level.mli @@ -48,6 +48,7 @@ val chown : ?dirfd:fd -> follow:bool -> ?uid:int64 -> ?gid:int64 -> string -> un val mkdir : ?dirfd:fd -> ?nofollow:bool -> mode:int -> string -> unit val unlink : ?dirfd:fd -> dir:bool -> string -> unit + val rename : ?old_dir:fd -> string -> ?new_dir:fd -> string -> unit val symlink : link_to:string -> fd option -> string -> unit @@ -131,4 +132,7 @@ module Flags : sig end val openat : ?dirfd:fd -> ?nofollow:bool-> sw:Switch.t -> string -> Flags.Open.t -> Flags.Disposition.t -> Flags.Create.t -> fd -(** Note: the returned FD is always non-blocking and close-on-exec. *) +(** [openat ?dirfd ~sw path ...] opens [path], relative to [dirfd] if given + and otherwise a Win32 path, relative to the current directory. + + Note: the returned FD is always non-blocking and close-on-exec. *) diff --git a/lib_eio_windows/test/test_fs.ml b/lib_eio_windows/test/test_fs.ml index 2e63e8c7c..f00fc9f86 100755 --- a/lib_eio_windows/test/test_fs.ml +++ b/lib_eio_windows/test/test_fs.ml @@ -125,7 +125,7 @@ let test_native env () = Alcotest.(check string) "empty" "." (Path.native_exn cwd); Alcotest.(check string) "fs relative" ".\\foo" (Path.native_exn (Eio.Stdenv.fs env / "foo")); Alcotest.(check string) "absolute" "C:\\foo" (Path.native_exn (Eio.Stdenv.fs env / "C:\\foo")); - (* A subtree records its directory in NT form; native must yield the Win32 form. *) + (* A subtree records its directory as an absolute Win32 path. *) Path.mkdir (cwd / "native-sub") ~perm:0o700; Fun.protect ~finally:(fun () -> Path.rmdir (cwd / "native-sub")) @@ fun () -> Path.with_open_dir (cwd / "native-sub") @@ fun sub -> diff --git a/tests/fs.md b/tests/fs.md index 4729c6093..315ff440f 100644 --- a/tests/fs.md +++ b/tests/fs.md @@ -532,6 +532,70 @@ Components separated by "/" can come back separated by "\". - : string option = Some "a\\b" ``` +# Win32 to NT paths + +`NtCreateFile` takes an NT object-manager path, so `to_nt` qualifies a Win32 +path, resolving a relative one against the current directory: + +```ocaml +let to_nt = Eio_utils.Nt_path.to_nt ~cwd:"C:\\cwd\\dir" +``` + +```ocaml +# to_nt "C:\\a\\b";; +- : string = "\\??\\C:\\a\\b" + +# to_nt "a\\b";; +- : string = "\\??\\C:\\cwd\\dir\\a\\b" + +# to_nt ".";; +- : string = "\\??\\C:\\cwd\\dir" + +# to_nt "..";; +- : string = "\\??\\C:\\cwd" + +# to_nt "\\x";; +- : string = "\\??\\C:\\x" + +# to_nt "c:x";; +- : string = "\\??\\C:\\cwd\\dir\\x" + +# to_nt "D:x";; +- : string = "\\??\\D:\\x" + +# to_nt "\\\\srv\\share\\x";; +- : string = "\\??\\UNC\\srv\\share\\x" + +# to_nt "\\\\.\\pipe\\x";; +- : string = "\\??\\pipe\\x" +``` + +The NT namespace does no normalisation, so Win32's is applied first: + +```ocaml +# to_nt "C:/a/./b//c/";; +- : string = "\\??\\C:\\a\\b\\c" + +# to_nt "C:\\a\\..\\..\\b";; +- : string = "\\??\\C:\\b" + +# to_nt "a\\..\\..\\b";; +- : string = "\\??\\C:\\cwd\\b" +``` + +Verbatim and NT paths only have their prefix changed: + +```ocaml +# to_nt "\\\\?\\C:\\a\\..\\b";; +- : string = "\\??\\C:\\a\\..\\b" + +# to_nt "\\\\?\\UNC\\srv\\share\\x";; +- : string = "\\??\\UNC\\srv\\share\\x" + +# to_nt "\\??\\C:\\a/b";; +- : string = "\\??\\C:\\a/b" +``` + # Mkdirs Recursively creating directories with `mkdirs`. From 075953e7f3c53c3a1dbab25ef37f3cd060922b88 Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Mon, 7 Sep 2026 09:38:53 +0100 Subject: [PATCH 04/14] Use Nt_path rather than Filename for paths in eio_windows Filename doesn know about volume prefixes, so it splits a UNC root or a bare drive as if it were an ordinary path. --- lib_eio/utils/nt_path.ml | 9 +++++++++ lib_eio/utils/nt_path.mli | 14 ++++++++++++++ lib_eio_windows/fs.ml | 27 +++++++++++---------------- 3 files changed, 34 insertions(+), 16 deletions(-) diff --git a/lib_eio/utils/nt_path.ml b/lib_eio/utils/nt_path.ml index 1df3d34df..4c7856b46 100644 --- a/lib_eio/utils/nt_path.ml +++ b/lib_eio/utils/nt_path.ml @@ -91,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 diff --git a/lib_eio/utils/nt_path.mli b/lib_eio/utils/nt_path.mli index 22a2e6c35..719e356ee 100644 --- a/lib_eio/utils/nt_path.mli +++ b/lib_eio/utils/nt_path.mli @@ -8,6 +8,20 @@ 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]. diff --git a/lib_eio_windows/fs.ml b/lib_eio_windows/fs.ml index b9253c55b..1292c579a 100755 --- a/lib_eio_windows/fs.ml +++ b/lib_eio_windows/fs.ml @@ -25,6 +25,7 @@ open Eio.Std module Fd = Eio_unix.Fd +module Nt_path = Eio_utils.Nt_path module rec Dir : sig include Eio.Fs.Pi.DIR @@ -53,13 +54,11 @@ end = struct let resolve t path = if t.sandbox then ( if t.closed then Fmt.invalid_arg "Attempt to use closed directory %S" t.dir_path; - if Filename.is_relative path then ( + if Nt_path.is_relative path then ( let dir_path = Err.run Low_level.realpath t.dir_path in - let full = Err.run Low_level.realpath (Filename.concat dir_path path) in - let prefix_len = String.length dir_path + 1 in - if String.length full >= prefix_len && String.sub full 0 prefix_len = dir_path ^ Filename.dir_sep then begin - full - end else if full = dir_path then + let full = Err.run Low_level.realpath (Nt_path.join dir_path path) in + let prefix = Nt_path.join dir_path "" in (* [dir_path] and a trailing separator *) + if String.starts_with ~prefix full || full = dir_path then full else raise @@ Eio.Fs.err (Permission_denied (Err.Outside_sandbox (full, dir_path))) @@ -71,7 +70,7 @@ end = struct let with_parent_dir t path fn = if t.sandbox then ( if t.closed then Fmt.invalid_arg "Attempt to use closed directory %S" t.dir_path; - let dir, leaf = Filename.dirname path, Filename.basename path in + let dir, leaf = Nt_path.dirname path, Nt_path.basename path in if leaf = ".." then ( (* We could be smarter here and normalise the path first, but '..' doesn't make sense for any of the current uses of [with_parent_dir] @@ -123,11 +122,7 @@ end = struct A leaf symlink might be OK, but we need to check it's still in the sandbox. todo: possibly we should limit the number of redirections here, like the kernel does. *) let target = Unix.readlink path in - let full_target = - if Filename.is_relative target then - Filename.concat (Filename.dirname path) target - else target - in + let full_target = Nt_path.join (Nt_path.dirname path) target in open_out t ~sw ~append ~create full_target | exception Unix.Unix_error (code, name, arg) -> raise (Err.v code name arg) @@ -163,7 +158,7 @@ end = struct let entries = read_dir t path |> List.map (fun name -> - match stat ~follow:false t (Filename.concat path name) with + match stat ~follow:false t (Nt_path.join path name) with | info -> (info.kind, name) | exception Eio.Exn.Io _ -> (`Unknown, name) ) @@ -194,7 +189,7 @@ end = struct let open_subtree t ~sw path = Switch.check sw; - let label = Filename.basename path in + let label = Nt_path.basename path in let d = v ~label (resolve t path) ~sandbox:true in Switch.on_release sw (fun () -> close d); Eio.Resource.T (d, Handler.v) @@ -206,10 +201,10 @@ end = struct let pp f t = Fmt.string f (String.escaped t.label) let native_internal t path = - if Filename.is_relative path then ( + if Nt_path.is_relative path then ( let p = if t.dir_path = "." then path - else Filename.concat t.dir_path path + else Nt_path.join t.dir_path path in if p = "" then "." else if p = "." then p From e02eb617d47d859b6393bc8a15d2559e3ae2f5ff Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Sat, 5 Sep 2026 17:23:14 +0100 Subject: [PATCH 05/14] Keep the create options when opening with nofollow nofollow formerly replaced the NT create options with a Win32 flag, dropping the directory/non-directory constraints. --- lib_eio_windows/eio_windows_stubs.c | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lib_eio_windows/eio_windows_stubs.c b/lib_eio_windows/eio_windows_stubs.c index 3cb83332e..0d746caa5 100755 --- a/lib_eio_windows/eio_windows_stubs.c +++ b/lib_eio_windows/eio_windows_stubs.c @@ -145,10 +145,11 @@ 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) + | (Bool_val(v_nofollow) ? FILE_OPEN_REPARSE_POINT : 0)), NULL, // Extended attribute buffer 0 // Extended attribute buffer length ); From b3d2ad8a0d04da023f3d8c9012f444e9e32769e4 Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Mon, 7 Sep 2026 09:41:09 +0100 Subject: [PATCH 06/14] Add tests for writing through a symlink leaf in a sandbox --- lib_eio_windows/test/test_fs.ml | 43 +++++++++++++++++++++++++++++++++ 1 file changed, 43 insertions(+) diff --git a/lib_eio_windows/test/test_fs.ml b/lib_eio_windows/test/test_fs.ml index f00fc9f86..8a2f1e5b1 100755 --- a/lib_eio_windows/test/test_fs.ml +++ b/lib_eio_windows/test/test_fs.ml @@ -396,6 +396,46 @@ let test_fs_symlink_follow_read env () = let abs_link = Filename.concat (Sys.getcwd ()) link in Alcotest.(check string) "absolute link" data (Path.load (fs / abs_link)) +let test_sandbox_write_through_symlink_leaf env () = + with_symlinks @@ fun () -> + let cwd = Eio.Stdenv.cwd env in + let target = "slt2-target" and link = "slt2-link" in + with_cleanup [link; target] @@ fun () -> + write_file target "old"; + Unix.symlink target link; + Path.save ~create:`Never (cwd / link) "new"; + Alcotest.(check string) "wrote through symlink" "new" (read_file target) + +(* As above, but in a subtree, whose [dir_path] is absolute, and with a relative link target *) +let test_subtree_write_through_symlink_leaf env () = + with_symlinks @@ fun () -> + let cwd = Eio.Stdenv.cwd env in + let dir = "slt3-dir" in + let target = dir ^ "\\target" and link = dir ^ "\\link" in + with_cleanup [link; target; dir] @@ fun () -> + try_mkdir (cwd / dir); + write_file target "old"; + Unix.symlink "target" link; + Eio.Path.with_subtree (cwd / dir) @@ fun sub -> + Path.save ~create:`Never (sub / "link") "new"; + Alcotest.(check string) "wrote through subtree symlink" "new" (read_file target) + +let test_sandbox_symlink_escape_write env () = + with_symlinks @@ fun () -> + let cwd = Eio.Stdenv.cwd env in + let dir = "slt4-dir" and outside = "slt4-outside" in + let escape = dir ^ "\\escape" in + with_cleanup [escape; dir; outside] @@ fun () -> + try_mkdir (cwd / dir); + write_file outside "unchanged"; + Unix.symlink ("..\\" ^ outside) escape; + (try + Eio.Path.with_subtree (cwd / dir) @@ fun sub -> + Path.save ~create:`Never (sub / "escape") "x"; + failwith "Expected permission denied" + with Eio.Io (Eio.Fs.E (Permission_denied _), _) -> ()); + Alcotest.(check string) "outside file unchanged" "unchanged" (read_file outside) + let tests env = [ "create-write-read", `Quick, test_create_and_read env; "absolute-join", `Quick, test_absolute_join env; @@ -420,4 +460,7 @@ let tests env = [ "fs-relative-read", `Quick, test_fs_relative_read env; "fs-nt-prefixed-read", `Quick, test_fs_nt_prefixed_read env; "fs-symlink-follow-read", `Quick, test_fs_symlink_follow_read env; + "sandbox-write-through-symlink-leaf", `Quick, test_sandbox_write_through_symlink_leaf env; + "subtree-write-through-symlink-leaf", `Quick, test_subtree_write_through_symlink_leaf env; + "sandbox-symlink-escape-write", `Quick, test_sandbox_symlink_escape_write env; ] From 5cf43c94a5c9503e1833dc4f3cab0cb0ba5dcda7 Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Sat, 5 Sep 2026 17:23:21 +0100 Subject: [PATCH 07/14] Fix the symlink recovery path in open_out The ELOOP handler ran readlink relative to the process directory instead of the sandbox root. --- lib_eio_windows/fs.ml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/lib_eio_windows/fs.ml b/lib_eio_windows/fs.ml index 1292c579a..97cc7e1a9 100755 --- a/lib_eio_windows/fs.ml +++ b/lib_eio_windows/fs.ml @@ -116,12 +116,11 @@ end = struct with | fd -> (Flow.of_fd fd :> Eio.File.rw_ty r) (* This is the result of raising [caml_unix_error(ELOOP,...)] *) - | exception Unix.Unix_error (EUNKNOWNERR 114, _, _) -> - print_endline "UNKNOWN"; + | exception Unix.Unix_error ((ELOOP | EUNKNOWNERR 114), _, _) -> (* The leaf was a symlink (or we're unconfined and the main path changed, but ignore that). A leaf symlink might be OK, but we need to check it's still in the sandbox. todo: possibly we should limit the number of redirections here, like the kernel does. *) - let target = Unix.readlink path in + let target = Unix.readlink (Nt_path.join t.dir_path path) in let full_target = Nt_path.join (Nt_path.dirname path) target in open_out t ~sw ~append ~create full_target | exception Unix.Unix_error (code, name, arg) -> From 817486c1ef922a9fda88994e2a1804976e7e7fb2 Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Mon, 7 Sep 2026 09:41:58 +0100 Subject: [PATCH 08/14] Add tests for reading and statting a missing path through fs --- lib_eio_windows/test/test_fs.ml | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/lib_eio_windows/test/test_fs.ml b/lib_eio_windows/test/test_fs.ml index 8a2f1e5b1..090d9b382 100755 --- a/lib_eio_windows/test/test_fs.ml +++ b/lib_eio_windows/test/test_fs.ml @@ -73,6 +73,17 @@ let with_symlinks fn = let write_file path data = Out_channel.with_open_bin path (fun oc -> Out_channel.output_string oc data) let read_file path = In_channel.with_open_bin path In_channel.input_all +(* Check that [fn] reports a missing path as [Not_found] without creating it. + [fn] describes what it got instead, for the failure message. *) +let check_missing name fn = + let path = Filename.temp_file name "" in + Unix.unlink path; + with_cleanup [path] @@ fun () -> + (match fn path with + | got -> Alcotest.failf "Expected Not_found, got %s" got + | exception Eio.Io (Eio.Fs.E (Not_found _), _) -> ()); + Alcotest.(check bool) "file not created" false (Sys.file_exists path) + let chdir path = traceln "chdir %S" path; Unix.chdir path @@ -436,6 +447,16 @@ let test_sandbox_symlink_escape_write env () = with Eio.Io (Eio.Fs.E (Permission_denied _), _) -> ()); Alcotest.(check string) "outside file unchanged" "unchanged" (read_file outside) +let test_fs_missing_read_no_create env () = + let fs = Eio.Stdenv.fs env in + check_missing "eio-missing-read" @@ fun path -> + Fmt.str "%S" (Path.load (fs / path)) + +let test_fs_missing_stat_no_create env () = + let fs = Eio.Stdenv.fs env in + check_missing "eio-missing-stat" @@ fun path -> + Fmt.str "kind %a" Eio.File.Stat.pp_kind (Eio.Path.stat ~follow:true (fs / path)).kind + let tests env = [ "create-write-read", `Quick, test_create_and_read env; "absolute-join", `Quick, test_absolute_join env; @@ -463,4 +484,6 @@ let tests env = [ "sandbox-write-through-symlink-leaf", `Quick, test_sandbox_write_through_symlink_leaf env; "subtree-write-through-symlink-leaf", `Quick, test_subtree_write_through_symlink_leaf env; "sandbox-symlink-escape-write", `Quick, test_sandbox_symlink_escape_write env; + "fs-missing-read-no-create", `Quick, test_fs_missing_read_no_create env; + "fs-missing-stat-no-create", `Quick, test_fs_missing_stat_no_create env; ] From 5857522a8c65bbc4b4cb0f0edf09a8af83eb2e0c Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Sat, 5 Sep 2026 19:06:21 +0100 Subject: [PATCH 09/14] Do not create missing files when opening for reading or stat --- lib_eio_windows/fs.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lib_eio_windows/fs.ml b/lib_eio_windows/fs.ml index 97cc7e1a9..1924b0c7d 100755 --- a/lib_eio_windows/fs.ml +++ b/lib_eio_windows/fs.ml @@ -80,7 +80,7 @@ end = struct let dir = resolve t dir in Switch.run @@ fun sw -> let open Low_level in - let dirfd = Err.run (Low_level.openat ~sw ~nofollow:true dir Flags.Open.(generic_read + synchronise) Flags.Disposition.(open_if)) Flags.Create.(directory) in + let dirfd = Err.run (Low_level.openat ~sw ~nofollow:true dir Flags.Open.(generic_read + synchronise) Flags.Disposition.(open_)) Flags.Create.(directory) in fn (Some dirfd) leaf ) ) else fn None path @@ -94,7 +94,7 @@ end = struct let open_in t ~sw path = let open Low_level in - let fd = Err.run (Low_level.openat ~sw ~nofollow:(opt_nofollow t) (resolve t path)) Low_level.Flags.Open.(generic_read + synchronise) Flags.Disposition.(open_if) Flags.Create.(non_directory) in + let fd = Err.run (Low_level.openat ~sw ~nofollow:(opt_nofollow t) (resolve t path)) Low_level.Flags.Open.(generic_read + synchronise) Flags.Disposition.(open_) Flags.Create.(non_directory) in (Flow.of_fd fd :> Eio.File.ro_ty Eio.Resource.t) let rec open_out t ~sw ~append ~create path = @@ -142,7 +142,7 @@ end = struct Switch.run @@ fun sw -> let open Low_level in let flags = Low_level.Flags.Open.(generic_read + synchronise) in - let dis = Flags.Disposition.open_if in + let dis = Flags.Disposition.open_ in let create = Flags.Create.non_directory in let fd = Err.run (openat ~sw ~nofollow:(not follow) (resolve t path) flags dis) create in Flow.Impl.stat fd From ce7174313fcf7d0ee13b46788f016621878ce28a Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Sat, 5 Sep 2026 19:08:02 +0100 Subject: [PATCH 10/14] Map Unix errors raised by open_in to Eio errors The openat call was only partially applied inside Err.run, so the syscall ran outside it and Unix errors escaped. --- lib_eio_windows/fs.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib_eio_windows/fs.ml b/lib_eio_windows/fs.ml index 1924b0c7d..71881a359 100755 --- a/lib_eio_windows/fs.ml +++ b/lib_eio_windows/fs.ml @@ -94,7 +94,7 @@ end = struct let open_in t ~sw path = let open Low_level in - let fd = Err.run (Low_level.openat ~sw ~nofollow:(opt_nofollow t) (resolve t path)) Low_level.Flags.Open.(generic_read + synchronise) Flags.Disposition.(open_) Flags.Create.(non_directory) in + let fd = Err.run (Low_level.openat ~sw ~nofollow:(opt_nofollow t) (resolve t path) Low_level.Flags.Open.(generic_read + synchronise) Flags.Disposition.(open_)) Flags.Create.(non_directory) in (Flow.of_fd fd :> Eio.File.ro_ty Eio.Resource.t) let rec open_out t ~sw ~append ~create path = From 68b60c37eb3709d91d5f1e0c3be408209cb2d684 Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Mon, 7 Sep 2026 09:43:21 +0100 Subject: [PATCH 11/14] Add tests for stat on directories, files and symlinks --- lib_eio_windows/test/test_fs.ml | 49 +++++++++++++++++++++++++++++++++ 1 file changed, 49 insertions(+) diff --git a/lib_eio_windows/test/test_fs.ml b/lib_eio_windows/test/test_fs.ml index 090d9b382..5bfa159f4 100755 --- a/lib_eio_windows/test/test_fs.ml +++ b/lib_eio_windows/test/test_fs.ml @@ -73,6 +73,12 @@ let with_symlinks fn = let write_file path data = Out_channel.with_open_bin path (fun oc -> Out_channel.output_string oc data) let read_file path = In_channel.with_open_bin path In_channel.input_all +let stat_kind = Alcotest.testable Eio.File.Stat.pp_kind ( = ) + +let check_kind ~follow path expected = + Alcotest.check stat_kind (Fmt.str "%a ~follow:%b" Path.pp path follow) expected + (Eio.Path.stat ~follow path).kind + (* Check that [fn] reports a missing path as [Not_found] without creating it. [fn] describes what it got instead, for the failure message. *) let check_missing name fn = @@ -457,6 +463,46 @@ let test_fs_missing_stat_no_create env () = check_missing "eio-missing-stat" @@ fun path -> Fmt.str "kind %a" Eio.File.Stat.pp_kind (Eio.Path.stat ~follow:true (fs / path)).kind +let test_stat_directory env () = + let cwd = Eio.Stdenv.cwd env in + with_cleanup ["stat-dir"] @@ fun () -> + try_mkdir (cwd / "stat-dir"); + check_kind ~follow:true (cwd / "stat-dir") `Directory; + check_kind ~follow:false (cwd / "stat-dir") `Directory + +let test_stat_regular_file env () = + let cwd = Eio.Stdenv.cwd env in + let fs = Eio.Stdenv.fs env in + with_cleanup ["stat-file"] @@ fun () -> + Path.save ~create:(`Exclusive 0o600) (cwd / "stat-file") "data"; + let abs = Filename.concat (Sys.getcwd ()) "stat-file" in + check_kind ~follow:true (cwd / "stat-file") `Regular_file; + check_kind ~follow:false (cwd / "stat-file") `Regular_file; + check_kind ~follow:true (fs / abs) `Regular_file; + check_kind ~follow:false (fs / abs) `Regular_file + +let test_stat_symlink env () = + with_symlinks @@ fun () -> + let cwd = Eio.Stdenv.cwd env in + let fs = Eio.Stdenv.fs env in + let target = "statl-target" and link = "statl-link" and dangling = "statl-dangling" in + with_cleanup [link; dangling; target] @@ fun () -> + write_file target "data"; + Unix.symlink target link; + Unix.symlink "statl-missing" dangling; + let abs_link = Filename.concat (Sys.getcwd ()) link in + check_kind ~follow:false (cwd / link) `Symbolic_link; + check_kind ~follow:true (cwd / link) `Regular_file; + check_kind ~follow:false (fs / abs_link) `Symbolic_link; + check_kind ~follow:true (fs / abs_link) `Regular_file; + check_kind ~follow:false (cwd / dangling) `Symbolic_link; + (match Eio.Path.stat ~follow:true (cwd / dangling) with + | st -> Alcotest.failf "Expected Not_found, got %a" Eio.File.Stat.pp_kind st.kind + | exception Eio.Io (Eio.Fs.E (Not_found _), _) -> ()); + let size = (Eio.Path.stat ~follow:false (cwd / link)).size in + (* Windows stores the target path in UTF-16 *) + Alcotest.(check int) "size is that of the target path" (2 * String.length target) (Optint.Int63.to_int size) + let tests env = [ "create-write-read", `Quick, test_create_and_read env; "absolute-join", `Quick, test_absolute_join env; @@ -486,4 +532,7 @@ let tests env = [ "sandbox-symlink-escape-write", `Quick, test_sandbox_symlink_escape_write env; "fs-missing-read-no-create", `Quick, test_fs_missing_read_no_create env; "fs-missing-stat-no-create", `Quick, test_fs_missing_stat_no_create env; + "stat-directory", `Quick, test_stat_directory env; + "stat-regular-file", `Quick, test_stat_regular_file env; + "stat-symlink", `Quick, test_stat_symlink env; ] From af42ff8610d53d9b1f82d40dd947fc30d2245159 Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Sat, 5 Sep 2026 19:06:34 +0100 Subject: [PATCH 12/14] Allow stat on directories stat always passed FILE_NON_DIRECTORY_FILE, so statting a directory failed. --- lib_eio_windows/fs.ml | 2 +- lib_eio_windows/low_level.ml | 1 + lib_eio_windows/low_level.mli | 3 +++ 3 files changed, 5 insertions(+), 1 deletion(-) diff --git a/lib_eio_windows/fs.ml b/lib_eio_windows/fs.ml index 71881a359..208140cf7 100755 --- a/lib_eio_windows/fs.ml +++ b/lib_eio_windows/fs.ml @@ -143,7 +143,7 @@ end = struct let open Low_level in let flags = Low_level.Flags.Open.(generic_read + synchronise) in let dis = Flags.Disposition.open_ in - let create = Flags.Create.non_directory in + let create = Flags.Create.empty in let fd = Err.run (openat ~sw ~nofollow:(not follow) (resolve t path) flags dis) create in Flow.Impl.stat fd diff --git a/lib_eio_windows/low_level.ml b/lib_eio_windows/low_level.ml index ed9522956..8e7861a27 100755 --- a/lib_eio_windows/low_level.ml +++ b/lib_eio_windows/low_level.ml @@ -208,6 +208,7 @@ module Flags = struct module Create = struct type t = int + let empty = 0 let directory = Config.file_directory_file let non_directory = Config.file_non_directory_file let no_intermediate_buffering = Config.file_no_intermediate_buffering diff --git a/lib_eio_windows/low_level.mli b/lib_eio_windows/low_level.mli index 8fa9187fb..e35f56214 100755 --- a/lib_eio_windows/low_level.mli +++ b/lib_eio_windows/low_level.mli @@ -115,6 +115,9 @@ module Flags : sig module Create : sig type t + val empty : t + (** No create options: allow both directories and non-directories. *) + val directory : t (** Create a directory. *) From 1b098d1b74f8ccdbda83df381d9652684a3bab40 Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Mon, 7 Sep 2026 09:44:16 +0100 Subject: [PATCH 13/14] Add an openat mode that opens a symlink directly stat needs a third mode that opens the link rather than its target, to match the posix backend. fstat now reports the length of the target as the size, as lstat does (the odd looking division by 2 in the stub is because Windows comes back with a 2-byte WCHAR array). --- lib_eio_windows/eio_windows_stubs.c | 38 +++++++++++++++++++++++++---- lib_eio_windows/fs.ml | 10 ++++---- lib_eio_windows/low_level.ml | 20 ++++++++++----- lib_eio_windows/low_level.mli | 6 +++-- 4 files changed, 56 insertions(+), 18 deletions(-) diff --git a/lib_eio_windows/eio_windows_stubs.c b/lib_eio_windows/eio_windows_stubs.c index 0d746caa5..1f45acbbc 100755 --- a/lib_eio_windows/eio_windows_stubs.c +++ b/lib_eio_windows/eio_windows_stubs.c @@ -100,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; @@ -110,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 @@ -149,7 +151,7 @@ CAMLprim value caml_eio_windows_openat(value v_dirfd, value v_nofollow, value v_ FILE_SYNCHRONOUS_IO_NONALERT | FILE_OPEN_FOR_BACKUP_INTENT | Int_val(v_create_options) - | (Bool_val(v_nofollow) ? FILE_OPEN_REPARSE_POINT : 0)), + | (follow != 0 ? FILE_OPEN_REPARSE_POINT : 0)), NULL, // Extended attribute buffer 0 // Extended attribute buffer length ); @@ -165,10 +167,10 @@ CAMLprim value caml_eio_windows_openat(value v_dirfd, value v_nofollow, value v_ // 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)); } @@ -176,6 +178,32 @@ 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); diff --git a/lib_eio_windows/fs.ml b/lib_eio_windows/fs.ml index 208140cf7..12285011e 100755 --- a/lib_eio_windows/fs.ml +++ b/lib_eio_windows/fs.ml @@ -80,7 +80,7 @@ end = struct let dir = resolve t dir in Switch.run @@ fun sw -> let open Low_level in - let dirfd = Err.run (Low_level.openat ~sw ~nofollow:true dir Flags.Open.(generic_read + synchronise) Flags.Disposition.(open_)) Flags.Create.(directory) in + let dirfd = Err.run (Low_level.openat ~sw ~follow:Nofollow dir Flags.Open.(generic_read + synchronise) Flags.Disposition.(open_)) Flags.Create.(directory) in fn (Some dirfd) leaf ) ) else fn None path @@ -90,11 +90,11 @@ end = struct (* Sandboxes use [O_NOFOLLOW] when opening files ([resolve] already removed any symlinks). This avoids a race where symlink might be added after [realpath] returns. TODO: Emulate [O_NOFOLLOW] here. *) - let opt_nofollow t = t.sandbox + let opt_follow t = if t.sandbox then Low_level.Nofollow else Low_level.Follow let open_in t ~sw path = let open Low_level in - let fd = Err.run (Low_level.openat ~sw ~nofollow:(opt_nofollow t) (resolve t path) Low_level.Flags.Open.(generic_read + synchronise) Flags.Disposition.(open_)) Flags.Create.(non_directory) in + let fd = Err.run (Low_level.openat ~sw ~follow:(opt_follow t) (resolve t path) Low_level.Flags.Open.(generic_read + synchronise) Flags.Disposition.(open_)) Flags.Create.(non_directory) in (Flow.of_fd fd :> Eio.File.ro_ty Eio.Resource.t) let rec open_out t ~sw ~append ~create path = @@ -112,7 +112,7 @@ end = struct in match with_parent_dir t path @@ fun dirfd path -> - Low_level.openat ?dirfd ~nofollow:(opt_nofollow t) ~sw path flags disp Flags.Create.(non_directory) + Low_level.openat ?dirfd ~follow:(opt_follow t) ~sw path flags disp Flags.Create.(non_directory) with | fd -> (Flow.of_fd fd :> Eio.File.rw_ty r) (* This is the result of raising [caml_unix_error(ELOOP,...)] *) @@ -144,7 +144,7 @@ end = struct let flags = Low_level.Flags.Open.(generic_read + synchronise) in let dis = Flags.Disposition.open_ in let create = Flags.Create.empty in - let fd = Err.run (openat ~sw ~nofollow:(not follow) (resolve t path) flags dis) create in + let fd = Err.run (openat ~sw ~follow:(if follow then Follow else Nofollow) (resolve t path) flags dis) create in Flow.Impl.stat fd let read_dir t path = diff --git a/lib_eio_windows/low_level.ml b/lib_eio_windows/low_level.ml index 8e7861a27..3d087c311 100755 --- a/lib_eio_windows/low_level.ml +++ b/lib_eio_windows/low_level.ml @@ -113,8 +113,14 @@ let getrandom { Cstruct.buffer; off; len } = in_worker_thread @@ fun () -> loop 0 +external eio_symlink_size : Unix.file_descr -> int option = "caml_eio_windows_symlink_size" + let fstat fd = - Fd.use_exn "fstat" fd Unix.LargeFile.fstat + Fd.use_exn "fstat" fd @@ fun fd -> + let st = Unix.LargeFile.fstat fd in + match eio_symlink_size fd with + | None -> st + | Some size -> { st with st_kind = S_LNK; st_size = Int64.of_int size } let lstat path = in_worker_thread @@ fun () -> @@ -229,18 +235,20 @@ let nt_path dirfd path = | Some _ -> path | None -> Eio_utils.Nt_path.to_nt ~cwd:(Sys.getcwd ()) path -external eio_openat : Unix.file_descr option -> bool -> string -> Flags.Open.t -> Flags.Disposition.t -> Flags.Create.t -> Unix.file_descr = "caml_eio_windows_openat_bytes" "caml_eio_windows_openat" +type follow = Follow | Nofollow | Open_link + +external eio_openat : Unix.file_descr option -> follow -> string -> Flags.Open.t -> Flags.Disposition.t -> Flags.Create.t -> Unix.file_descr = "caml_eio_windows_openat_bytes" "caml_eio_windows_openat" -let openat ?dirfd ?(nofollow=false) ~sw path flags dis create = +let openat ?dirfd ?(follow=Follow) ~sw path flags dis create = with_dirfd "openat" dirfd @@ fun dirfd -> Switch.check sw; let path = nt_path dirfd path in - in_worker_thread ~label:"openat" (fun () -> eio_openat dirfd nofollow path Flags.Open.(flags + cloexec (* + nonblock *)) dis create) + in_worker_thread ~label:"openat" (fun () -> eio_openat dirfd follow path Flags.Open.(flags + cloexec (* + nonblock *)) dis create) |> Fd.of_unix ~sw ~blocking:false ~close_unix:true -let mkdir ?dirfd ?(nofollow=false) ~mode:_ path = +let mkdir ?dirfd ?(follow=Follow) ~mode:_ path = Switch.run @@ fun sw -> - let _ : Fd.t = openat ?dirfd ~nofollow ~sw path Flags.Open.(generic_write + synchronise) Flags.Disposition.(create) Flags.Create.(directory) in + let _ : Fd.t = openat ?dirfd ~follow ~sw path Flags.Open.(generic_write + synchronise) Flags.Disposition.(create) Flags.Create.(directory) in () external eio_unlinkat : Unix.file_descr option -> string -> bool -> unit = "caml_eio_windows_unlinkat" diff --git a/lib_eio_windows/low_level.mli b/lib_eio_windows/low_level.mli index e35f56214..429c75563 100755 --- a/lib_eio_windows/low_level.mli +++ b/lib_eio_windows/low_level.mli @@ -39,6 +39,8 @@ val lseek : fd -> Optint.Int63.t -> [`Set | `Cur | `End] -> Optint.Int63.t val fsync : fd -> unit val ftruncate : fd -> Optint.Int63.t -> unit +type follow = Follow | Nofollow | Open_link + val fstat : fd -> Unix.LargeFile.stats val lstat : string -> Unix.LargeFile.stats @@ -46,7 +48,7 @@ val realpath : string -> string val read_link : ?dirfd:fd -> string -> string val chown : ?dirfd:fd -> follow:bool -> ?uid:int64 -> ?gid:int64 -> string -> unit -val mkdir : ?dirfd:fd -> ?nofollow:bool -> mode:int -> string -> unit +val mkdir : ?dirfd:fd -> ?follow:follow -> mode:int -> string -> unit val unlink : ?dirfd:fd -> dir:bool -> string -> unit val rename : ?old_dir:fd -> string -> ?new_dir:fd -> string -> unit @@ -134,7 +136,7 @@ module Flags : sig end end -val openat : ?dirfd:fd -> ?nofollow:bool-> sw:Switch.t -> string -> Flags.Open.t -> Flags.Disposition.t -> Flags.Create.t -> fd +val openat : ?dirfd:fd -> ?follow:follow -> sw:Switch.t -> string -> Flags.Open.t -> Flags.Disposition.t -> Flags.Create.t -> fd (** [openat ?dirfd ~sw path ...] opens [path], relative to [dirfd] if given and otherwise a Win32 path, relative to the current directory. From eea7d54e972883c2594c688f7f50337af5d6a6e7 Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Mon, 7 Sep 2026 09:45:14 +0100 Subject: [PATCH 14/14] Return the symlink from stat with follow disabled --- lib_eio_windows/fs.ml | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/lib_eio_windows/fs.ml b/lib_eio_windows/fs.ml index 12285011e..1c7f5531f 100755 --- a/lib_eio_windows/fs.ml +++ b/lib_eio_windows/fs.ml @@ -144,7 +144,15 @@ end = struct let flags = Low_level.Flags.Open.(generic_read + synchronise) in let dis = Flags.Disposition.open_ in let create = Flags.Create.empty in - let fd = Err.run (openat ~sw ~follow:(if follow then Follow else Nofollow) (resolve t path) flags dis) create in + let leaf = Nt_path.basename path in + let fd = + (* "." and ".." are never symlinks, and [with_parent_dir] rejects ".." *) + if follow || leaf = "." || leaf = ".." then + Err.run (openat ~sw (resolve t path) flags dis) create + else + with_parent_dir t path @@ fun dirfd path -> + Err.run (openat ?dirfd ~follow:Open_link ~sw path flags dis) create + in Flow.Impl.stat fd let read_dir t path =