From 9cf5f35063db7308681eababe7f42a8f1a0c9f34 Mon Sep 17 00:00:00 2001 From: Patrick Ferris Date: Sun, 7 May 2023 12:34:45 +0100 Subject: [PATCH] eio_windows: initial filesystem implementation --- lib_eio_windows/dune | 2 +- lib_eio_windows/eio_windows.ml | 4 +- lib_eio_windows/eio_windows_stubs.c | 182 ++++++++++++++++++- lib_eio_windows/fs.ml | 187 ++++++++++++++++++++ lib_eio_windows/include/discover.ml | 31 +++- lib_eio_windows/low_level.ml | 77 +++++--- lib_eio_windows/low_level.mli | 73 ++++++-- lib_eio_windows/test/test.ml | 3 +- lib_eio_windows/test/test_fs.ml | 262 ++++++++++++++++++++++++++++ 9 files changed, 767 insertions(+), 54 deletions(-) create mode 100755 lib_eio_windows/fs.ml create mode 100755 lib_eio_windows/test/test_fs.ml diff --git a/lib_eio_windows/dune b/lib_eio_windows/dune index 3a0fc6ea0..cb4d98b69 100644 --- a/lib_eio_windows/dune +++ b/lib_eio_windows/dune @@ -1,7 +1,7 @@ (library (name eio_windows) (public_name eio_windows) - (library_flags :standard -ccopt -lbcrypt) + (library_flags :standard -ccopt -lbcrypt -ccopt -lntdll) (enabled_if (= %{os_type} "Win32")) (foreign_stubs (language c) diff --git a/lib_eio_windows/eio_windows.ml b/lib_eio_windows/eio_windows.ml index ca6a9a2f1..e55f88d9b 100755 --- a/lib_eio_windows/eio_windows.ml +++ b/lib_eio_windows/eio_windows.ml @@ -31,8 +31,8 @@ let run main = method mono_clock = Time.mono_clock method net = Net.v method domain_mgr = Domain_mgr.v - method cwd = failwith "file-system operations not supported on Windows yet" - method fs = failwith "file-system operations not supported on Windows yet" + method cwd = ((Fs.cwd, "") :> Eio.Fs.dir Eio.Path.t) + method fs = ((Fs.fs, "") :> Eio.Fs.dir Eio.Path.t) method process_mgr = failwith "process operations not supported on Windows yet" method secure_random = Flow.secure_random end diff --git a/lib_eio_windows/eio_windows_stubs.c b/lib_eio_windows/eio_windows_stubs.c index 6120788b9..a8797617e 100755 --- a/lib_eio_windows/eio_windows_stubs.c +++ b/lib_eio_windows/eio_windows_stubs.c @@ -11,12 +11,29 @@ #include #include #include +#include +#include + +typedef ULONG (__stdcall *pNtCreateFile)( + PHANDLE FileHandle, + ULONG DesiredAccess, + PVOID ObjectAttributes, + PVOID IoStatusBlock, + PLARGE_INTEGER AllocationSize, + ULONG FileAttributes, + ULONG ShareAccess, + ULONG CreateDisposition, + ULONG CreateOptions, + PVOID EaBuffer, + ULONG EaLength + ); #include #include #include #include #include +#include #ifdef ARCH_SIXTYFOUR #define Int63_val(v) Long_val(v) @@ -64,19 +81,170 @@ CAMLprim value caml_eio_windows_pwritev(value v_fd, value v_bufs, value v_offset uerror("pwritev is not supported on windows yet", Nothing); } -CAMLprim value caml_eio_windows_openat(value v_dirfd, value v_pathname, value v_flags, value v_mode) -{ - uerror("openat is not supported on windows yet", Nothing); +// File-system operations + +// No follow +void no_follow(HANDLE h) { + BY_HANDLE_FILE_INFORMATION b; + + if (!GetFileInformationByHandle(h, &b)) { + caml_win32_maperr(GetLastError()); + uerror("nofollow", Nothing); + } + + if (b.dwFileAttributes & FILE_ATTRIBUTE_REPARSE_POINT) { + CloseHandle(h); + caml_unix_error(ELOOP, "nofollow", Nothing); + } } -CAMLprim value caml_eio_windows_mkdirat(value v_fd, value v_path, value v_perm) +// 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) { - uerror("mkdirat is not supported on windows yet", Nothing); + CAMLparam2(v_dirfd, v_pathname); + HANDLE h, dir; + OBJECT_ATTRIBUTES obj_attr; + IO_STATUS_BLOCK io_status; + wchar_t *pathname; + UNICODE_STRING relative; + NTSTATUS r; + + // 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 + // of a relative path a la openat. + pNtCreateFile NtCreatefile = (pNtCreateFile)GetProcAddress(GetModuleHandle("ntdll.dll"), "NtCreateFile"); + caml_unix_check_path(v_pathname, "openat"); + pathname = caml_stat_strdup_to_utf16(String_val(v_pathname)); + RtlInitUnicodeString(&relative, pathname); + + // If NULL the filepath has to be absolute + if (Is_some(v_dirfd)) { + dir = Handle_val(Field(v_dirfd, 0)); + } else { + dir = NULL; + } + + // Initialise object attributes, passing in the root directory FD + InitializeObjectAttributes( + &obj_attr, + &relative, + OBJ_CASE_INSENSITIVE, // TODO: Double-check what flags need to be passed at this point. + dir, + NULL + ); + + // Create the file + r = NtCreatefile( + &h, + Int_val(v_desired_access) | FILE_READ_ATTRIBUTES, + &obj_attr, + &io_status, + 0, // Allocation size + 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))), + 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)) { + caml_win32_maperr(RtlNtStatusToDosError(r)); + uerror("openat", Nothing); + } + + // 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)) { + 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]); } -CAMLprim value caml_eio_windows_unlinkat(value v_fd, value v_path, value v_dir) +CAMLprim value caml_eio_windows_unlinkat(value v_dirfd, value v_pathname, value v_dir) { - uerror("unlinkat is not supported on windows yet", Nothing); + CAMLparam2(v_dirfd, v_pathname); + HANDLE h, dir; + OBJECT_ATTRIBUTES obj_attr; + IO_STATUS_BLOCK io_status; + wchar_t *pathname; + UNICODE_STRING relative; + NTSTATUS r; + + // 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 + // of a relative path a la openat. + pNtCreateFile NtCreatefile = (pNtCreateFile)GetProcAddress(GetModuleHandle("ntdll.dll"), "NtCreateFile"); + caml_unix_check_path(v_pathname, "openat"); + pathname = caml_stat_strdup_to_utf16(String_val(v_pathname)); + RtlInitUnicodeString(&relative, pathname); + + // If NULL the filepath has to be absolute + if (Is_some(v_dirfd)) { + dir = Handle_val(Field(v_dirfd, 0)); + } else { + dir = NULL; + } + + // Initialise object attributes, passing in the root directory FD + InitializeObjectAttributes( + &obj_attr, + &relative, + OBJ_CASE_INSENSITIVE, // TODO: Double-check what flags need to be passed at this point. + dir, + NULL + ); + + // Create the file + r = NtCreatefile( + &h, + (SYNCHRONIZE | DELETE), + &obj_attr, + &io_status, + 0, // Allocation size + FILE_ATTRIBUTE_NORMAL, // TODO: Could check flags to see if we can do READONLY here a la OCaml + (FILE_SHARE_DELETE), + FILE_OPEN, + ((Bool_val(v_dir) ? FILE_DIRECTORY_FILE : FILE_NON_DIRECTORY_FILE) | FILE_SYNCHRONOUS_IO_NONALERT | FILE_DELETE_ON_CLOSE), + 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", v_pathname); + } + + if (!NT_SUCCESS(r)) { + caml_win32_maperr(RtlNtStatusToDosError(r)); + uerror("openat", Nothing); + } + + // Now close the file to delete it + BOOL closed; + closed = CloseHandle(h); + + CAMLreturn(Val_unit); } CAMLprim value caml_eio_windows_renameat(value v_old_fd, value v_old_path, value v_new_fd, value v_new_path) diff --git a/lib_eio_windows/fs.ml b/lib_eio_windows/fs.ml new file mode 100755 index 000000000..475c01f2c --- /dev/null +++ b/lib_eio_windows/fs.ml @@ -0,0 +1,187 @@ +(* + * Copyright (C) 2023 Thomas Leonard + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(* This module provides (optional) sandboxing, allowing operations to be restricted to a subtree. + + For now, sandboxed directories use realpath and [O_NOFOLLOW], which is probably quite slow, + and requires duplicating a load of path lookup logic from the kernel. + It might be better to hold a directory FD rather than a path. + On FreeBSD we could use O_RESOLVE_BENEATH and let the OS handle everything for us. + On other systems we would have to resolve one path component at a time. *) + +open Eio.Std + +module Fd = Eio_unix.Fd + +class virtual posix_dir = object + inherit Eio.Fs.dir + + val virtual opt_nofollow : bool + (** Emulate [O_NOFOLLOW] here. *) + + method virtual private resolve : string -> string + (** [resolve path] returns the real path that should be used to access [path]. + For sandboxes, this is [realpath path] (and it checks that it is within the sandbox). + For unrestricted access, this is the identity function. *) + + method virtual with_parent_dir : 'a. (string -> (Fd.t option -> string -> 'a) -> 'a) + (** [with_parent_dir path fn] runs [fn dir_fd rel_path], + where [rel_path] accessed relative to [dir_fd] gives access to [path]. + For unrestricted access, this just runs [fn None path]. + For sandboxes, it opens the parent of [path] as [dir_fd] and runs [fn (Some dir_fd) (basename path)]. *) +end + +(* When renaming, we get a plain [Eio.Fs.dir]. We need extra access to check + that the new location is within its sandbox. *) +type _ Eio.Generic.ty += Posix_dir : posix_dir Eio.Generic.ty +let as_posix_dir x = Eio.Generic.probe x Posix_dir + +class virtual dir ~label = object (self) + inherit posix_dir + + val mutable closed = false + + method! probe : type a. a Eio.Generic.ty -> a option = function + | Posix_dir -> Some (self :> posix_dir) + | _ -> None + + method open_in ~sw path = + let open Low_level in + let fd = Err.run (Low_level.openat ~sw ~nofollow:opt_nofollow (self#resolve path)) Low_level.Flags.Open.(generic_read + synchronise) Flags.Disposition.(open_if) Flags.Create.(non_directory) in + (Flow.of_fd fd :> ) + + method open_out ~sw ~append ~create path = + let open Low_level in + let _mode, disp = + match create with + | `Never -> 0, Low_level.Flags.Disposition.open_ + | `If_missing perm -> perm, Low_level.Flags.Disposition.open_if + | `Or_truncate perm -> perm, Low_level.Flags.Disposition.overwrite_if + | `Exclusive perm -> perm, Low_level.Flags.Disposition.create + in + let flags = if append then Low_level.Flags.Open.(synchronise + append) else Low_level.Flags.Open.(generic_write + synchronise) in + match + self#with_parent_dir path @@ fun dirfd path -> + Low_level.openat ?dirfd ~nofollow:opt_nofollow ~sw path flags disp Flags.Create.(non_directory) + with + | fd -> (Flow.of_fd fd :> ) + (* This is the result of raising [caml_unix_error(ELOOP,...)] *) + | exception Unix.Unix_error (EUNKNOWNERR 114, _, _) -> + print_endline "UNKNOWN"; + (* 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 + self#open_out ~sw ~append ~create full_target + | exception Unix.Unix_error (code, name, arg) -> + raise (Err.wrap code name arg) + + method mkdir ~perm path = + self#with_parent_dir path @@ fun dirfd path -> + Err.run (Low_level.mkdir ?dirfd ~mode:perm) path + + method unlink path = + self#with_parent_dir path @@ fun dirfd path -> + Err.run (Low_level.unlink ?dirfd ~dir:false) path + + method rmdir path = + self#with_parent_dir path @@ fun dirfd path -> + Err.run (Low_level.unlink ?dirfd ~dir:true) path + + method read_dir path = + (* todo: need fdopendir here to avoid races *) + let path = self#resolve path in + Err.run Low_level.readdir path + |> Array.to_list + + method rename old_path new_dir new_path = + match as_posix_dir new_dir with + | None -> invalid_arg "Target is not an eio_posix directory!" + | Some new_dir -> + self#with_parent_dir old_path @@ fun old_dir old_path -> + new_dir#with_parent_dir new_path @@ fun new_dir new_path -> + Err.run (Low_level.rename ?old_dir old_path ?new_dir) new_path + + method open_dir ~sw path = + Switch.check sw; + let label = Filename.basename path in + let d = new sandbox ~label (self#resolve path) in + Switch.on_release sw (fun () -> d#close); + (d :> Eio.Fs.dir_with_close) + + method close = closed <- true + + method pp f = Fmt.string f (String.escaped label) +end + +and sandbox ~label dir_path = object (self) + inherit dir ~label + + val opt_nofollow = true + + (* Resolve a relative path to an absolute one, with no symlinks. + @raise Eio.Fs.Permission_denied if it's outside of [dir_path]. *) + method private resolve path = + if closed then Fmt.invalid_arg "Attempt to use closed directory %S" dir_path; + if Filename.is_relative path then ( + let dir_path = Err.run Low_level.realpath 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 + (* \\??\\ Is necessary with NtCreateFile. *) + 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 + "\\??\\" ^ full + else + raise @@ Eio.Fs.err (Permission_denied (Err.Outside_sandbox (full, dir_path))) + ) else ( + raise @@ Eio.Fs.err (Permission_denied Err.Absolute_path) + ) + + method with_parent_dir path fn = + if closed then Fmt.invalid_arg "Attempt to use closed directory %S" dir_path; + let dir, leaf = Filename.dirname path, Filename.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] + anyway. *) + raise (Eio.Fs.err (Permission_denied (Err.Invalid_leaf leaf))) + ) else ( + let dir = self#resolve dir in + Switch.run @@ fun sw -> + let open Low_level in + let dirfd = Low_level.openat ~sw ~nofollow:true dir Flags.Open.(generic_read + synchronise) Flags.Disposition.(open_if) Flags.Create.(directory) in + fn (Some dirfd) leaf + ) +end + +(* Full access to the filesystem. *) +let fs = object + inherit dir ~label:"fs" + + val opt_nofollow = false + + (* No checks *) + method private resolve path = path + method private with_parent_dir path fn = fn None path +end + +let cwd = new sandbox ~label:"cwd" "." diff --git a/lib_eio_windows/include/discover.ml b/lib_eio_windows/include/discover.ml index 136d1200a..b38c130a6 100755 --- a/lib_eio_windows/include/discover.ml +++ b/lib_eio_windows/include/discover.ml @@ -4,7 +4,7 @@ let () = C.main ~name:"discover" (fun c -> let defs = C.C_define.import c ~c_flags:["-D_LARGEFILE64_SOURCE"] - ~includes:["sys/types.h"; "sys/stat.h"; "fcntl.h"] + ~includes:["sys/types.h"; "sys/stat.h"; "fcntl.h"; "winternl.h"; "ntdef.h"] C.C_define.Type.[ "_O_RDONLY", Int; "_O_RDWR", Int; @@ -14,11 +14,36 @@ let () = "_O_NOINHERIT", Int; "_O_TRUNC", Int; "_O_EXCL", Int; + + (* Desired Access *) + "GENERIC_READ", Int; + "GENERIC_WRITE", Int; + "SYNCHRONIZE", Int; + "FILE_APPEND_DATA", Int; + + (* Create Disposition *) + "FILE_SUPERSEDE", Int; + "FILE_CREATE", Int; + "FILE_OPEN", Int; + "FILE_OPEN_IF", Int; + "FILE_OVERWRITE", Int; + "FILE_OVERWRITE_IF", Int; + + (* Create Options *) + "FILE_DIRECTORY_FILE", Int; + "FILE_NON_DIRECTORY_FILE", Int; + "FILE_NO_INTERMEDIATE_BUFFERING", Int; + "FILE_WRITE_THROUGH", Int; + "FILE_SEQUENTIAL_ONLY", Int; ] |> List.map (function | name, C.C_define.Value.Int v -> - let name_length = String.length name in - let name = String.sub name 1 (name_length - 1) in + let name = + if name.[0] = '_' then + let name_length = String.length name in + String.sub name 1 (name_length - 1) + else name + in Printf.sprintf "let %s = 0x%x" (String.lowercase_ascii name) v | _ -> assert false ) diff --git a/lib_eio_windows/low_level.ml b/lib_eio_windows/low_level.ml index 2fd750d28..d9fd69ffa 100755 --- a/lib_eio_windows/low_level.ml +++ b/lib_eio_windows/low_level.ml @@ -156,51 +156,74 @@ let pwritev ~file_offset fd bufs = Fd.use_exn "pwritev" fd @@ fun fd -> do_nonblocking Write (fun fd -> eio_pwritev fd bufs file_offset) fd -module Open_flags = struct - type t = int - - let rdonly = Config.o_rdonly - let rdwr = Config.o_rdwr - let wronly = Config.o_wronly - let append = Config.o_append - let cloexec = Config.o_noinherit - let creat = Config.o_creat - let excl = Config.o_excl - let trunc = Config.o_trunc - - let empty = 0 - let ( + ) = ( lor ) +module Flags = struct + module Open = struct + type t = int + let rdonly = Config.o_rdonly + let rdwr = Config.o_rdwr + let wronly = Config.o_wronly + let cloexec = Config.o_noinherit + let creat = Config.o_creat + let excl = Config.o_excl + let trunc = Config.o_trunc + + let generic_read = Config.generic_read + let generic_write = Config.generic_write + let synchronise = Config.synchronize + let append = Config.file_append_data + + let empty = 0 + let ( + ) = ( lor ) + end + + module Disposition = struct + type t = int + let supersede = Config.file_supersede + let create = Config.file_create + let open_ = Config.file_open + let open_if = Config.file_open_if + let overwrite = Config.file_overwrite + let overwrite_if = Config.file_overwrite_if + end + + module Create = struct + type t = int + let directory = Config.file_directory_file + let non_directory = Config.file_non_directory_file + let no_intermediate_buffering = Config.file_no_intermediate_buffering + let write_through = Config.file_write_through + let sequential_only = Config.file_sequential_only + let ( + ) = ( lor ) + end end let rec with_dirfd op dirfd fn = match dirfd with - | None -> fn (Obj.magic (failwith "TODO AT_FDCWD") : Unix.file_descr) - | Some dirfd -> Fd.use_exn op dirfd fn + | None -> fn None + | 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 -> string -> Open_flags.t -> int -> Unix.file_descr = "caml_eio_windows_openat" +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 ~sw ~mode path flags = +let openat ?dirfd ?(nofollow=false) ~sw path flags dis create = with_dirfd "openat" dirfd @@ fun dirfd -> Switch.check sw; - in_worker_thread (fun () -> eio_openat dirfd path Open_flags.(flags + cloexec (* + nonblock *)) mode) + in_worker_thread (fun () -> eio_openat dirfd nofollow path Flags.Open.(flags + cloexec (* + nonblock *)) dis create) |> Fd.of_unix ~sw ~blocking:false ~close_unix:true -external eio_mkdirat : Unix.file_descr -> string -> Unix.file_perm -> unit = "caml_eio_windows_mkdirat" +let mkdir ?dirfd ?(nofollow=false) ~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 mkdir ?dirfd ~mode path = - with_dirfd "mkdirat" dirfd @@ fun dirfd -> - in_worker_thread @@ fun () -> - eio_mkdirat dirfd path mode - -external eio_unlinkat : Unix.file_descr -> string -> bool -> unit = "caml_eio_windows_unlinkat" +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 -> in_worker_thread @@ fun () -> eio_unlinkat dirfd path dir -external eio_renameat : Unix.file_descr -> string -> Unix.file_descr -> string -> unit = "caml_eio_windows_renameat" +external eio_renameat : Unix.file_descr option -> string -> Unix.file_descr option -> string -> unit = "caml_eio_windows_renameat" let rename ?old_dir old_path ?new_dir new_path = with_dirfd "rename-old" old_dir @@ fun old_dir -> diff --git a/lib_eio_windows/low_level.mli b/lib_eio_windows/low_level.mli index ca2a70776..189aed7bf 100755 --- a/lib_eio_windows/low_level.mli +++ b/lib_eio_windows/low_level.mli @@ -39,7 +39,7 @@ val lstat : string -> Unix.LargeFile.stats val realpath : string -> string -val mkdir : ?dirfd:fd -> mode:int -> string -> unit +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 @@ -53,20 +53,67 @@ val pwritev : file_offset:Optint.Int63.t -> fd -> Cstruct.t array -> int val pipe : sw:Switch.t -> fd * fd -module Open_flags : sig - type t +module Flags : sig + module Open : sig + type t - val rdonly : t - val rdwr : t - val wronly : t - val append : t - val creat : t - val excl : t - val trunc : t + val rdonly : t + val rdwr : t + val wronly : t + val creat : t + val excl : t + val trunc : t - val empty : t - val ( + ) : t -> t -> t + val generic_read : t + val generic_write : t + val synchronise : t + val append : t + + val empty : t + val ( + ) : t -> t -> t + end + + module Disposition : sig + type t + + val supersede : t + (** If the file already exists, replace it with the given file. + If it does not, create the given file. *) + + val create : t + (** Create the file, if it already exists fail. *) + + val open_ : t + (** If the file already exists, open it otherwise fail. *) + + val open_if : t + (** If the file already exists, open it otherwise create it. *) + + val overwrite : t + (** If the file already exists, open it and overwrite it otherwise fail. *) + + val overwrite_if : t + (** If the file already exists, open it and overwrite it otherwise create it. *) + end + + module Create : sig + type t + + val directory : t + (** Create a directory. *) + + val non_directory : t + (** Create something that is not a directory. *) + + val no_intermediate_buffering : t + + val write_through : t + + val sequential_only : t + + val ( + ) : t -> t -> t + end end -val openat : ?dirfd:fd -> sw:Switch.t -> mode:int -> string -> Open_flags.t -> fd +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. *) diff --git a/lib_eio_windows/test/test.ml b/lib_eio_windows/test/test.ml index 510c40964..9d865beb2 100755 --- a/lib_eio_windows/test/test.ml +++ b/lib_eio_windows/test/test.ml @@ -51,8 +51,9 @@ end let () = Eio_windows.run @@ fun env -> - Alcotest.run "eio_windows" [ + Alcotest.run ~bail:true "eio_windows" [ "net", Test_net.tests env; + "fs", Test_fs.tests env; "timeout", Timeout.tests env; "random", Random.tests env; "dla", Dla.tests diff --git a/lib_eio_windows/test/test_fs.ml b/lib_eio_windows/test/test_fs.ml new file mode 100755 index 000000000..553a55b7f --- /dev/null +++ b/lib_eio_windows/test/test_fs.ml @@ -0,0 +1,262 @@ +module Int63 = Optint.Int63 +module Path = Eio.Path + +let () = Eio.Exn.Backend.show := false + +open Eio.Std + +let ( / ) = Path.( / ) + +let try_read_file path = + match Path.load path with + | s -> traceln "read %a -> %S" Path.pp path s + | exception ex -> raise ex + +let try_write_file ~create ?append path content = + match Path.save ~create ?append path content with + | () -> traceln "write %a -> ok" Path.pp path + | exception ex -> raise ex + +let try_mkdir path = + traceln "mkdir %a -> ?" Path.pp path; + match Path.mkdir path ~perm:0o700 with + | () -> traceln "mkdir %a -> ok" Path.pp path + | exception ex -> raise ex + +let try_rename p1 p2 = + match Path.rename p1 p2 with + | () -> traceln "rename %a to %a -> ok" Path.pp p1 Path.pp p2 + | exception ex -> raise ex + +let try_read_dir path = + match Path.read_dir path with + | names -> traceln "read_dir %a -> %a" Path.pp path Fmt.Dump.(list string) names + | exception ex -> raise ex + +let try_unlink path = + match Path.unlink path with + | () -> traceln "unlink %a -> ok" Path.pp path + | exception ex -> raise ex + +let try_rmdir path = + match Path.rmdir path with + | () -> traceln "rmdir %a -> ok" Path.pp path + | exception ex -> raise ex + +let with_temp_file path fn = + Fun.protect (fun () -> fn path) ~finally:(fun () -> Eio.Path.unlink path) + +let chdir path = + traceln "chdir %S" path; + Unix.chdir path + +let assert_kind path kind = + Path.with_open_in path @@ fun file -> + assert ((Eio.File.stat file).kind = kind) + +let test_create_and_read env () = + let cwd = Eio.Stdenv.cwd env in + let data = "my-data" in + with_temp_file (cwd / "test-file") @@ fun path -> + Path.save ~create:(`Exclusive 0o666) path data; + Alcotest.(check string) "same data" data (Path.load path) + +let test_cwd_no_access_abs env () = + let cwd = Eio.Stdenv.cwd env in + let temp = Filename.temp_file "eio" "win" in + try + Path.save ~create:(`Exclusive 0o666) (cwd / temp) "my-data"; + failwith "Should have failed" + with Eio.Io (Eio.Fs.E (Permission_denied _), _) -> () + +let test_exclusive env () = + let cwd = Eio.Stdenv.cwd env in + with_temp_file (cwd / "test-file") @@ fun path -> + Eio.traceln "fiest"; + Path.save ~create:(`Exclusive 0o666) path "first-write"; + Eio.traceln "next"; + try + Path.save ~create:(`Exclusive 0o666) path "first-write"; + Eio.traceln "nope"; + failwith "Should have failed" + with Eio.Io (Eio.Fs.E (Already_exists _), _) -> () + +let test_if_missing env () = + let cwd = Eio.Stdenv.cwd env in + let test_file = (cwd / "test-file") in + with_temp_file test_file @@ fun test_file -> + Path.save ~create:(`If_missing 0o666) test_file "1st-write-original"; + Path.save ~create:(`If_missing 0o666) test_file "2nd-write"; + Alcotest.(check string) "same contents" "2nd-write-original" (Path.load test_file) + +let test_trunc env () = + let cwd = Eio.Stdenv.cwd env in + let test_file = (cwd / "test-file") in + with_temp_file test_file @@ fun test_file -> + Path.save ~create:(`Or_truncate 0o666) test_file "1st-write-original"; + Path.save ~create:(`Or_truncate 0o666) test_file "2nd-write"; + Alcotest.(check string) "same contents" "2nd-write" (Path.load test_file) + +let test_empty env () = + let cwd = Eio.Stdenv.cwd env in + let test_file = (cwd / "test-file") in + try + Path.save ~create:`Never test_file "1st-write-original"; + traceln "Got %S" @@ Path.load test_file; + failwith "Should have failed" + with Eio.Io (Eio.Fs.E (Not_found _), _) -> () + +let test_append env () = + let cwd = Eio.Stdenv.cwd env in + let test_file = (cwd / "test-file") in + with_temp_file test_file @@ fun test_file -> + Path.save ~create:(`Or_truncate 0o666) test_file "1st-write-original"; + Path.save ~create:`Never ~append:true test_file "2nd-write"; + Alcotest.(check string) "append" "1st-write-original2nd-write" (Path.load test_file) + +let test_mkdir env () = + let cwd = Eio.Stdenv.cwd env in + try_mkdir (cwd / "subdir"); + try_mkdir (cwd / "subdir\\nested"); + let test_file = cwd / "subdir\\nested\\test-file" in + Path.save ~create:(`Exclusive 0o600) test_file "data"; + Alcotest.(check string) "mkdir" "data" (Path.load test_file); + Unix.unlink "subdir\\nested\\test-file"; + Unix.rmdir "subdir\\nested"; + Unix.rmdir "subdir" + +let test_symlink env () = + (* + Important note: assuming that neither "another" nor + "to-subdir" exist, the following program will behave + differently if you don't have the ~to_dir flag. + + With [to_dir] set to [true] we get the desired UNIX behaviour, + without it [Unix.realpath] will actually show the parent directory + of "another". Presumably this is because Windows distinguishes + between file symlinks and directory symlinks. Fun. + + {[ Unix.symlink ~to_dir:true "another" "to-subdir"; + Unix.mkdir "another" 0o700; + print_endline @@ Unix.realpath "to-subdir" |} + *) + let cwd = Eio.Stdenv.cwd env in + try_mkdir (cwd / "sandbox"); + Unix.symlink ~to_dir:true ".." "sandbox\\to-root"; + Unix.symlink ~to_dir:true "subdir" "sandbox\\to-subdir"; + Unix.symlink ~to_dir:true "foo" "sandbox\\dangle"; + try_mkdir (cwd / "tmp"); + Eio.Path.with_open_dir (cwd / "sandbox") @@ fun sandbox -> + try_mkdir (sandbox / "subdir"); + try_mkdir (sandbox / "to-subdir\\nested"); + let () = + try + try_mkdir (sandbox / "to-root\\tmp\\foo"); + failwith "Expected permission denied to-root" + with Eio.Io (Eio.Fs.E (Permission_denied _), _) -> () + in + assert (not (Sys.file_exists ".\\tmp\\foo")); + let () = + try + try_mkdir (sandbox / "..\\foo"); + failwith "Expected permission denied parent foo" + with Eio.Io (Eio.Fs.E (Permission_denied _), _) -> () + in + let () = + try + try_mkdir (sandbox / "to-subdir"); + failwith "Expected already exists" + with Eio.Io (Eio.Fs.E (Already_exists _), _) -> () + in + let () = + try + try_mkdir (sandbox / "dangle\\foo"); + failwith "Expected permission denied dangle foo" + with Eio.Io (Eio.Fs.E (Not_found _), _) -> () + in + () + +let test_unlink env () = + let cwd = Eio.Stdenv.cwd env in + Path.save ~create:(`Exclusive 0o600) (cwd / "file") "data"; + try_mkdir (cwd / "subdir"); + Path.save ~create:(`Exclusive 0o600) (cwd / "subdir\\file2") "data2"; + try_read_file (cwd / "file"); + try_read_file (cwd / "subdir\\file2"); + try_unlink (cwd / "file"); + try_unlink (cwd / "subdir\\file2"); + let () = + try + try_read_file (cwd / "file"); + failwith "file should not exist" + with Eio.Io (Eio.Fs.E (Not_found _), _) -> () + in + let () = + try + try_read_file (cwd / "subdir\\file2"); + failwith "file should not exist" + with Eio.Io (Eio.Fs.E (Not_found _), _) -> () + in + try_write_file ~create:(`Exclusive 0o600) (cwd / "subdir\\file2") "data2"; + (* Supposed to use symlinks here. *) + try_unlink (cwd / "subdir\\file2"); + let () = + try + try_read_file (cwd / "subdir\\file2"); + failwith "file should not exist" + with Eio.Io (Eio.Fs.E (Not_found _), _) -> () + in + () + +let try_failing_unlink env () = + let cwd = Eio.Stdenv.cwd env in + let () = + try + try_unlink (cwd / "missing"); + failwith "Expected not found!" + with Eio.Io (Eio.Fs.E (Not_found _), _) -> () + in + let () = + try + try_unlink (cwd / "..\\foo"); + failwith "Expected permission denied!" + with Eio.Io (Eio.Fs.E (Permission_denied _), _) -> () + in + () + +let test_remove_dir env () = + let cwd = Eio.Stdenv.cwd env in + try_mkdir (cwd / "d1"); + try_mkdir (cwd / "subdir\\d2"); + try_read_dir (cwd / "d1"); + try_read_dir (cwd / "subdir\\d2"); + try_rmdir (cwd / "d1"); + try_rmdir (cwd / "subdir\\d2"); + let () = + try + try_read_dir (cwd / "d1"); + failwith "Expected not found" + with Eio.Io (Eio.Fs.E (Not_found _), _) -> () + in + let () = + try + try_read_dir (cwd / "subdir\\d2"); + failwith "Expected not found" + with Eio.Io (Eio.Fs.E (Not_found _), _) -> () + in + () + +let tests env = [ + "create-write-read", `Quick, test_create_and_read env; + "cwd-abs-path", `Quick, test_cwd_no_access_abs env; + "create-exclusive", `Quick, test_exclusive env; + "create-if_missing", `Quick, test_if_missing env; + "create-trunc", `Quick, test_trunc env; + "create-empty", `Quick, test_empty env; + "append", `Quick, test_append env; + "mkdir", `Quick, test_mkdir env; + "symlinks", `Quick, test_symlink env; + "unlink", `Quick, test_unlink env; + "failing-unlink", `Quick, try_failing_unlink env; + "rmdir", `Quick, test_remove_dir env; +] \ No newline at end of file