Add tests and fix creation modes

Author: patricoferris

lib_eio_windows/eio_windows_stubs.c

@@ -84,7 +84,7 @@ CAMLprim value caml_eio_windows_pwritev(value v_fd, value v_bufs, value v_offset
 // File-system operations
 
 // We recreate an openat like function using NtCreateFile
-CAMLprim value caml_eio_windows_openat(value v_dirfd, value v_pathname, value v_open_flags, value v_create_disposition, value v_create_options)
+CAMLprim value caml_eio_windows_openat(value v_dirfd, value v_pathname, value v_desired_access, value v_create_disposition, value v_create_options)
 {
   CAMLparam2(v_dirfd, v_pathname);
   HANDLE h, dir;
@@ -121,7 +121,7 @@ CAMLprim value caml_eio_windows_openat(value v_dirfd, value v_pathname, value v_
   // Create the file
   r = NtCreatefile(
     &h,
-    (GENERIC_READ | GENERIC_WRITE | SYNCHRONIZE),
+    Int_val(v_desired_access),
     &obj_attr,
     &io_status,
     0, // Allocation size
@@ -135,14 +135,14 @@ CAMLprim value caml_eio_windows_openat(value v_dirfd, value v_pathname, value v_
 
   // Free the allocated pathname
   caml_stat_free(pathname);
-  
+
   if (h == INVALID_HANDLE_VALUE) {
-    caml_win32_maperr(GetLastError());
+    caml_win32_maperr(RtlNtStatusToDosError(r));
     uerror("openat", v_pathname);
   }
 
   if (!NT_SUCCESS(r)) {
-    caml_win32_maperr(GetLastError());
+    caml_win32_maperr(RtlNtStatusToDosError(r));
     uerror("openat", Nothing);
   }
 
@@ -154,9 +154,73 @@ CAMLprim value caml_eio_windows_mkdirat(value v_fd, value v_path, value v_perm)
   uerror("mkdirat is not supported on windows yet", Nothing);
 }
 
-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)

lib_eio_windows/fs.ml

@@ -60,23 +60,22 @@ class virtual dir ~label = object (self)
 
   method open_in ~sw path =
     let open Low_level in
-    let fd = Err.run (Low_level.openat ~sw (self#resolve path)) Low_level.Flags.Open.(rdonly) Flags.Disposition.(open_if) Flags.Create.(non_directory) in
+    let fd = Err.run (Low_level.openat ~sw (self#resolve path)) Low_level.Flags.Open.(generic_read + synchronise) Flags.Disposition.(open_if) Flags.Create.(non_directory) in
     (Flow.of_fd fd :> <Eio.File.ro; Eio.Flow.close>)
 
   method open_out ~sw ~append ~create path =
     let open Low_level in
-    let _mode, flags =
+    let _mode, disp =
       match create with
-      | `Never            -> 0,    Low_level.Flags.Open.empty
-      | `If_missing  perm -> perm, Low_level.Flags.Open.creat
-      | `Or_truncate perm -> perm, Low_level.Flags.Open.(creat + trunc)
-      | `Exclusive   perm -> perm, Low_level.Flags.Open.(creat + excl)
+      | `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.(flags + append) else flags in
-    let flags = Low_level.Flags.Open.(flags + rdwr + opt_nofollow) 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 ~sw path flags Flags.Disposition.(open_if) Flags.Create.(non_directory)
+      Low_level.openat ?dirfd ~sw path flags disp Flags.Create.(non_directory)
     with
     | fd -> (Flow.of_fd fd :> <Eio.File.rw; Eio.Flow.close>)
     | exception Unix.Unix_error (ELOOP, _, _) ->
@@ -168,7 +167,7 @@ and sandbox ~label dir_path = object (self)
       let dir = self#resolve dir in
       Switch.run @@ fun sw ->
       let open Low_level in
-      let dirfd = Low_level.openat ~sw dir Flags.Open.(rdonly) Flags.Disposition.(open_if) Flags.Create.(directory) in
+      let dirfd = Low_level.openat ~sw dir Flags.Open.(generic_read + synchronise) Flags.Disposition.(open_if) Flags.Create.(directory) in
       fn (Some dirfd) leaf
     )
 end

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"; "ntdef.h"]
+          ~includes:["sys/types.h"; "sys/stat.h"; "fcntl.h"; "winternl.h"; "ntdef.h"]
           C.C_define.Type.[
             "_O_RDONLY", Int;
             "_O_RDWR", Int;
@@ -15,6 +15,12 @@ let () =
             "_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;

lib_eio_windows/low_level.ml

@@ -158,12 +158,16 @@ module Flags = struct
     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 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

lib_eio_windows/low_level.mli

@@ -60,11 +60,15 @@ module Flags : sig
     val rdonly : t
     val rdwr : t
     val wronly : t
-    val append : t
     val creat : t
     val excl : t
     val trunc : t
 
+    val generic_read : t
+    val generic_write : t
+    val synchronise : t
+    val append : t
+
     val empty : t
     val ( + ) : t -> t -> t
   end

lib_eio_windows/test/test.ml

@@ -53,6 +53,7 @@ let () =
   Eio_windows.run @@ fun env ->
   Alcotest.run "eio_windows" [
     "net", Test_net.tests env;
+    "fs", Test_fs.tests env;
     "timeout", Timeout.tests env;
     "random", Random.tests env;
     "dla", Dla.tests

lib_eio_windows/test/test_fs.ml

@@ -0,0 +1,121 @@
+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 -> traceln "@[<h>%a@]" Eio.Exn.pp 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 -> traceln "@[<h>%a@]" Eio.Exn.pp ex
+
+let try_mkdir path =
+  match Path.mkdir path ~perm:0o700 with
+  | () -> traceln "mkdir %a -> ok" Path.pp path
+  | exception ex -> traceln "@[<h>%a@]" Eio.Exn.pp 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 -> traceln "@[<h>%a@]" Eio.Exn.pp 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 -> traceln "@[<h>%a@]" Eio.Exn.pp ex
+
+let try_unlink path =
+  match Path.unlink path with
+  | () -> traceln "unlink %a -> ok" Path.pp path
+  | exception ex -> traceln "@[<h>%a@]" Eio.Exn.pp ex
+
+let try_rmdir path =
+  match Path.rmdir path with
+  | () -> traceln "rmdir %a -> ok" Path.pp path
+  | exception ex -> traceln "@[<h>%a@]" Eio.Exn.pp 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 ->
+  Path.save ~create:(`Exclusive 0o666) path "first-write";
+  try 
+    Path.save ~create:(`Exclusive 0o666) path "first-write";
+    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 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;
+]