diff --git a/lib_eio/utils/nt_path.ml b/lib_eio/utils/nt_path.ml index 554da6abd..4c7856b46 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 = @@ -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)) + ) diff --git a/lib_eio/utils/nt_path.mli b/lib_eio/utils/nt_path.mli index cb1b9cb64..719e356ee 100644 --- a/lib_eio/utils/nt_path.mli +++ b/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. *) diff --git a/lib_eio_windows/eio_windows_stubs.c b/lib_eio_windows/eio_windows_stubs.c index 4e26e21c5..1f45acbbc 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); } @@ -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,10 +147,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) + | (follow != 0 ? FILE_OPEN_REPARSE_POINT : 0)), NULL, // Extended attribute buffer 0 // Extended attribute buffer length ); @@ -154,23 +159,18 @@ 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 // 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)); } @@ -178,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); @@ -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); } diff --git a/lib_eio_windows/fs.ml b/lib_eio_windows/fs.ml index 433e2dc7e..1c7f5531f 100755 --- a/lib_eio_windows/fs.ml +++ b/lib_eio_windows/fs.ml @@ -25,9 +25,7 @@ open Eio.Std module Fd = Eio_unix.Fd - -(* NT object-manager namespace prefix, required by NtCreateFile. *) -let nt_prefix = "\\??\\" +module Nt_path = Eio_utils.Nt_path module rec Dir : sig include Eio.Fs.Pi.DIR @@ -56,14 +54,12 @@ 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 - nt_prefix ^ full - end else if full = dir_path then - nt_prefix ^ full + 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))) ) else ( @@ -71,16 +67,10 @@ 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; - 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] @@ -90,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 ~follow:Nofollow dir Flags.Open.(generic_read + synchronise) Flags.Disposition.(open_)) Flags.Create.(directory) in fn (Some dirfd) leaf ) ) else fn None path @@ -100,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_if) 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 = @@ -122,21 +112,16 @@ 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,...)] *) - | 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 full_target = - if Filename.is_relative target then - Filename.concat (Filename.dirname path) target - else target - 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) -> raise (Err.v code name arg) @@ -157,9 +142,17 @@ 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 create = Flags.Create.non_directory in - let fd = Err.run (openat ~sw ~nofollow:(not follow) (resolve t path) flags dis) create in + let dis = Flags.Disposition.open_ in + let create = Flags.Create.empty 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 = @@ -172,7 +165,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) ) @@ -203,7 +196,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) @@ -215,10 +208,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 (strip_nt_prefix t.dir_path) path + else Nt_path.join 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..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 () -> @@ -208,6 +214,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 @@ -223,23 +230,32 @@ 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 -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 nt_path dirfd path = + match dirfd with + | Some _ -> path + | None -> Eio_utils.Nt_path.to_nt ~cwd:(Sys.getcwd ()) path + +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; - in_worker_thread ~label:"openat" (fun () -> eio_openat dirfd nofollow path Flags.Open.(flags + cloexec (* + nonblock *)) dis create) + let path = nt_path dirfd path in + 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" 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..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,8 +48,9 @@ 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 val symlink : link_to:string -> fd option -> string -> unit @@ -114,6 +117,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. *) @@ -130,5 +136,8 @@ 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 -(** Note: the returned FD is always non-blocking and close-on-exec. *) +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. + + 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 90465e404..5bfa159f4 100755 --- a/lib_eio_windows/test/test_fs.ml +++ b/lib_eio_windows/test/test_fs.ml @@ -51,6 +51,45 @@ 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 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 = + 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 @@ -103,7 +142,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 -> @@ -204,9 +243,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 +350,159 @@ 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 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 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 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; @@ -329,5 +519,20 @@ 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; + "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; + "stat-directory", `Quick, test_stat_directory env; + "stat-regular-file", `Quick, test_stat_regular_file env; + "stat-symlink", `Quick, test_stat_symlink env; ] 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`.