Skip to content

Commit 8fa06b2

Browse files
committed
Initial filesystem implementation
1 parent 393ec68 commit 8fa06b2

File tree

7 files changed

+394
-44
lines changed

7 files changed

+394
-44
lines changed

lib_eio_windows/dune

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,7 @@
11
(library
22
(name eio_windows)
33
(public_name eio_windows)
4-
(library_flags :standard -ccopt -lbcrypt)
4+
(library_flags :standard -ccopt -lbcrypt -ccopt -lntdll)
55
(enabled_if (= %{os_type} "Win32"))
66
(foreign_stubs
77
(language c)

lib_eio_windows/eio_windows.ml

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -43,7 +43,7 @@ let run main =
4343
method mono_clock = Time.mono_clock
4444
method net = Net.v
4545
method domain_mgr = Domain_mgr.v
46-
method cwd = failwith "file-system operations not supported on Windows yet"
47-
method fs = failwith "file-system operations not supported on Windows yet"
46+
method cwd = ((Fs.cwd, "") :> Eio.Fs.dir Eio.Path.t)
47+
method fs = ((Fs.fs, "") :> Eio.Fs.dir Eio.Path.t)
4848
method secure_random = Flow.secure_random
4949
end

lib_eio_windows/eio_windows_stubs.c

Lines changed: 82 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -11,12 +11,29 @@
1111
#include <assert.h>
1212
#include <ntstatus.h>
1313
#include <bcrypt.h>
14+
#include <winternl.h>
15+
#include <ntdef.h>
16+
17+
typedef ULONG (__stdcall *pNtCreateFile)(
18+
PHANDLE FileHandle,
19+
ULONG DesiredAccess,
20+
PVOID ObjectAttributes,
21+
PVOID IoStatusBlock,
22+
PLARGE_INTEGER AllocationSize,
23+
ULONG FileAttributes,
24+
ULONG ShareAccess,
25+
ULONG CreateDisposition,
26+
ULONG CreateOptions,
27+
PVOID EaBuffer,
28+
ULONG EaLength
29+
);
1430

1531
#include <caml/mlvalues.h>
1632
#include <caml/memory.h>
1733
#include <caml/alloc.h>
1834
#include <caml/unixsupport.h>
1935
#include <caml/bigarray.h>
36+
#include <caml/osdeps.h>
2037

2138
#ifdef ARCH_SIXTYFOUR
2239
#define Int63_val(v) Long_val(v)
@@ -64,9 +81,72 @@ CAMLprim value caml_eio_windows_pwritev(value v_fd, value v_bufs, value v_offset
6481
uerror("pwritev is not supported on windows yet", Nothing);
6582
}
6683

67-
CAMLprim value caml_eio_windows_openat(value v_dirfd, value v_pathname, value v_flags, value v_mode)
84+
// File-system operations
85+
86+
// We recreate an openat like function using NtCreateFile
87+
CAMLprim value caml_eio_windows_openat(value v_dirfd, value v_pathname, value v_open_flags, value v_create_disposition, value v_create_options)
6888
{
69-
uerror("openat is not supported on windows yet", Nothing);
89+
CAMLparam2(v_dirfd, v_pathname);
90+
HANDLE h, dir;
91+
OBJECT_ATTRIBUTES obj_attr;
92+
IO_STATUS_BLOCK io_status;
93+
wchar_t *pathname;
94+
UNICODE_STRING relative;
95+
NTSTATUS r;
96+
97+
// Not sure what the overhead of this is, but it allows us to have low-level control
98+
// over file creation. In particular, we can specify the HANDLE to the parent directory
99+
// of a relative path a la openat.
100+
pNtCreateFile NtCreatefile = (pNtCreateFile)GetProcAddress(GetModuleHandle("ntdll.dll"), "NtCreateFile");
101+
caml_unix_check_path(v_pathname, "openat");
102+
pathname = caml_stat_strdup_to_utf16(String_val(v_pathname));
103+
RtlInitUnicodeString(&relative, pathname);
104+
105+
// If NULL the filepath has to be absolute
106+
if (Is_some(v_dirfd)) {
107+
dir = Handle_val(Field(v_dirfd, 0));
108+
} else {
109+
dir = NULL;
110+
}
111+
112+
// Initialise object attributes, passing in the root directory FD
113+
InitializeObjectAttributes(
114+
&obj_attr,
115+
&relative,
116+
OBJ_CASE_INSENSITIVE, // TODO: Double-check what flags need to be passed at this point.
117+
dir,
118+
NULL
119+
);
120+
121+
// Create the file
122+
r = NtCreatefile(
123+
&h,
124+
(GENERIC_READ | GENERIC_WRITE | SYNCHRONIZE),
125+
&obj_attr,
126+
&io_status,
127+
0, // Allocation size
128+
FILE_ATTRIBUTE_NORMAL, // TODO: Could check flags to see if we can do READONLY here a la OCaml
129+
(FILE_SHARE_READ | FILE_SHARE_WRITE),
130+
Int_val(v_create_disposition),
131+
(Int_val(v_create_options) | FILE_SYNCHRONOUS_IO_NONALERT),
132+
NULL, // Extended attribute buffer
133+
0 // Extended attribute buffer length
134+
);
135+
136+
// Free the allocated pathname
137+
caml_stat_free(pathname);
138+
139+
if (h == INVALID_HANDLE_VALUE) {
140+
caml_win32_maperr(GetLastError());
141+
uerror("openat", v_pathname);
142+
}
143+
144+
if (!NT_SUCCESS(r)) {
145+
caml_win32_maperr(GetLastError());
146+
uerror("openat", Nothing);
147+
}
148+
149+
CAMLreturn(caml_win32_alloc_handle(h));
70150
}
71151

72152
CAMLprim value caml_eio_windows_mkdirat(value v_fd, value v_path, value v_perm)

lib_eio_windows/fs.ml

Lines changed: 187 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,187 @@
1+
(*
2+
* Copyright (C) 2023 Thomas Leonard
3+
*
4+
* Permission to use, copy, modify, and distribute this software for any
5+
* purpose with or without fee is hereby granted, provided that the above
6+
* copyright notice and this permission notice appear in all copies.
7+
*
8+
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
9+
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
10+
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
11+
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
12+
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
13+
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
14+
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
15+
*)
16+
17+
(* This module provides (optional) sandboxing, allowing operations to be restricted to a subtree.
18+
19+
For now, sandboxed directories use realpath and [O_NOFOLLOW], which is probably quite slow,
20+
and requires duplicating a load of path lookup logic from the kernel.
21+
It might be better to hold a directory FD rather than a path.
22+
On FreeBSD we could use O_RESOLVE_BENEATH and let the OS handle everything for us.
23+
On other systems we would have to resolve one path component at a time. *)
24+
25+
open Eio.Std
26+
27+
module Fd = Eio_unix.Fd
28+
29+
class virtual posix_dir = object
30+
inherit Eio.Fs.dir
31+
32+
val virtual opt_nofollow : Low_level.Flags.Open.t
33+
(** Extra flags for open operations. Sandboxes will add [O_NOFOLLOW] here. *)
34+
35+
method virtual private resolve : string -> string
36+
(** [resolve path] returns the real path that should be used to access [path].
37+
For sandboxes, this is [realpath path] (and it checks that it is within the sandbox).
38+
For unrestricted access, this is the identity function. *)
39+
40+
method virtual with_parent_dir : 'a. (string -> (Fd.t option -> string -> 'a) -> 'a)
41+
(** [with_parent_dir path fn] runs [fn dir_fd rel_path],
42+
where [rel_path] accessed relative to [dir_fd] gives access to [path].
43+
For unrestricted access, this just runs [fn None path].
44+
For sandboxes, it opens the parent of [path] as [dir_fd] and runs [fn (Some dir_fd) (basename path)]. *)
45+
end
46+
47+
(* When renaming, we get a plain [Eio.Fs.dir]. We need extra access to check
48+
that the new location is within its sandbox. *)
49+
type _ Eio.Generic.ty += Posix_dir : posix_dir Eio.Generic.ty
50+
let as_posix_dir x = Eio.Generic.probe x Posix_dir
51+
52+
class virtual dir ~label = object (self)
53+
inherit posix_dir
54+
55+
val mutable closed = false
56+
57+
method! probe : type a. a Eio.Generic.ty -> a option = function
58+
| Posix_dir -> Some (self :> posix_dir)
59+
| _ -> None
60+
61+
method open_in ~sw path =
62+
let open Low_level in
63+
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
64+
(Flow.of_fd fd :> <Eio.File.ro; Eio.Flow.close>)
65+
66+
method open_out ~sw ~append ~create path =
67+
let open Low_level in
68+
let _mode, flags =
69+
match create with
70+
| `Never -> 0, Low_level.Flags.Open.empty
71+
| `If_missing perm -> perm, Low_level.Flags.Open.creat
72+
| `Or_truncate perm -> perm, Low_level.Flags.Open.(creat + trunc)
73+
| `Exclusive perm -> perm, Low_level.Flags.Open.(creat + excl)
74+
in
75+
let flags = if append then Low_level.Flags.Open.(flags + append) else flags in
76+
let flags = Low_level.Flags.Open.(flags + rdwr + opt_nofollow) in
77+
match
78+
self#with_parent_dir path @@ fun dirfd path ->
79+
Low_level.openat ?dirfd ~sw path flags Flags.Disposition.(open_if) Flags.Create.(non_directory)
80+
with
81+
| fd -> (Flow.of_fd fd :> <Eio.File.rw; Eio.Flow.close>)
82+
| exception Unix.Unix_error (ELOOP, _, _) ->
83+
(* The leaf was a symlink (or we're unconfined and the main path changed, but ignore that).
84+
A leaf symlink might be OK, but we need to check it's still in the sandbox.
85+
todo: possibly we should limit the number of redirections here, like the kernel does. *)
86+
let target = Unix.readlink path in
87+
let full_target =
88+
if Filename.is_relative target then
89+
Filename.concat (Filename.dirname path) target
90+
else target
91+
in
92+
self#open_out ~sw ~append ~create full_target
93+
| exception Unix.Unix_error (code, name, arg) ->
94+
raise (Err.wrap code name arg)
95+
96+
method mkdir ~perm path =
97+
self#with_parent_dir path @@ fun dirfd path ->
98+
Err.run (Low_level.mkdir ?dirfd ~mode:perm) path
99+
100+
method unlink path =
101+
self#with_parent_dir path @@ fun dirfd path ->
102+
Err.run (Low_level.unlink ?dirfd ~dir:false) path
103+
104+
method rmdir path =
105+
self#with_parent_dir path @@ fun dirfd path ->
106+
Err.run (Low_level.unlink ?dirfd ~dir:true) path
107+
108+
method read_dir path =
109+
(* todo: need fdopendir here to avoid races *)
110+
let path = self#resolve path in
111+
Err.run Low_level.readdir path
112+
|> Array.to_list
113+
114+
method rename old_path new_dir new_path =
115+
match as_posix_dir new_dir with
116+
| None -> invalid_arg "Target is not an eio_posix directory!"
117+
| Some new_dir ->
118+
self#with_parent_dir old_path @@ fun old_dir old_path ->
119+
new_dir#with_parent_dir new_path @@ fun new_dir new_path ->
120+
Err.run (Low_level.rename ?old_dir old_path ?new_dir) new_path
121+
122+
method open_dir ~sw path =
123+
Switch.check sw;
124+
let label = Filename.basename path in
125+
let d = new sandbox ~label (self#resolve path) in
126+
Switch.on_release sw (fun () -> d#close);
127+
(d :> Eio.Fs.dir_with_close)
128+
129+
method close = closed <- true
130+
131+
method pp f = Fmt.string f (String.escaped label)
132+
end
133+
134+
and sandbox ~label dir_path = object (self)
135+
inherit dir ~label
136+
137+
(* nofollow not on windows. *)
138+
val opt_nofollow = Low_level.Flags.Open.empty
139+
140+
(* Resolve a relative path to an absolute one, with no symlinks.
141+
@raise Eio.Fs.Permission_denied if it's outside of [dir_path]. *)
142+
method private resolve path =
143+
if closed then Fmt.invalid_arg "Attempt to use closed directory %S" dir_path;
144+
if Filename.is_relative path then (
145+
let dir_path = Err.run Low_level.realpath dir_path in
146+
let full = Err.run Low_level.realpath (Filename.concat dir_path path) in
147+
let prefix_len = String.length dir_path + 1 in
148+
(* \\??\\ Is necessary with NtCreateFile. *)
149+
if String.length full >= prefix_len && String.sub full 0 prefix_len = dir_path ^ Filename.dir_sep then
150+
"\\??\\" ^ full
151+
else if full = dir_path then
152+
"\\??\\" ^ full
153+
else
154+
raise @@ Eio.Fs.err (Permission_denied (Err.Outside_sandbox (full, dir_path)))
155+
) else (
156+
raise @@ Eio.Fs.err (Permission_denied Err.Absolute_path)
157+
)
158+
159+
method with_parent_dir path fn =
160+
if closed then Fmt.invalid_arg "Attempt to use closed directory %S" dir_path;
161+
let dir, leaf = Filename.dirname path, Filename.basename path in
162+
if leaf = ".." then (
163+
(* We could be smarter here and normalise the path first, but '..'
164+
doesn't make sense for any of the current uses of [with_parent_dir]
165+
anyway. *)
166+
raise (Eio.Fs.err (Permission_denied (Err.Invalid_leaf leaf)))
167+
) else (
168+
let dir = self#resolve dir in
169+
Switch.run @@ fun sw ->
170+
let open Low_level in
171+
let dirfd = Low_level.openat ~sw dir Flags.Open.(rdonly) Flags.Disposition.(open_if) Flags.Create.(directory) in
172+
fn (Some dirfd) leaf
173+
)
174+
end
175+
176+
(* Full access to the filesystem. *)
177+
let fs = object
178+
inherit dir ~label:"fs"
179+
180+
val opt_nofollow = Low_level.Flags.Open.empty
181+
182+
(* No checks *)
183+
method private resolve path = path
184+
method private with_parent_dir path fn = fn None path
185+
end
186+
187+
let cwd = new sandbox ~label:"cwd" "."

lib_eio_windows/include/discover.ml

Lines changed: 22 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -4,7 +4,7 @@ let () =
44
C.main ~name:"discover" (fun c ->
55
let defs =
66
C.C_define.import c ~c_flags:["-D_LARGEFILE64_SOURCE"]
7-
~includes:["sys/types.h"; "sys/stat.h"; "fcntl.h"]
7+
~includes:["sys/types.h"; "sys/stat.h"; "fcntl.h"; "ntdef.h"]
88
C.C_define.Type.[
99
"_O_RDONLY", Int;
1010
"_O_RDWR", Int;
@@ -14,11 +14,30 @@ let () =
1414
"_O_NOINHERIT", Int;
1515
"_O_TRUNC", Int;
1616
"_O_EXCL", Int;
17+
18+
(* Create Disposition *)
19+
"FILE_SUPERSEDE", Int;
20+
"FILE_CREATE", Int;
21+
"FILE_OPEN", Int;
22+
"FILE_OPEN_IF", Int;
23+
"FILE_OVERWRITE", Int;
24+
"FILE_OVERWRITE_IF", Int;
25+
26+
(* Create Options *)
27+
"FILE_DIRECTORY_FILE", Int;
28+
"FILE_NON_DIRECTORY_FILE", Int;
29+
"FILE_NO_INTERMEDIATE_BUFFERING", Int;
30+
"FILE_WRITE_THROUGH", Int;
31+
"FILE_SEQUENTIAL_ONLY", Int;
1732
]
1833
|> List.map (function
1934
| name, C.C_define.Value.Int v ->
20-
let name_length = String.length name in
21-
let name = String.sub name 1 (name_length - 1) in
35+
let name =
36+
if name.[0] = '_' then
37+
let name_length = String.length name in
38+
String.sub name 1 (name_length - 1)
39+
else name
40+
in
2241
Printf.sprintf "let %s = 0x%x" (String.lowercase_ascii name) v
2342
| _ -> assert false
2443
)

0 commit comments

Comments
 (0)