WIP: eio_posix: use directory FDs instead of realpath

realpath was an old hack from the libuv days.

lib_eio_posix/fs.ml

@@ -16,20 +16,31 @@
 
 (* 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. *)
+   On FreeBSD we use O_RESOLVE_BENEATH and let the OS handle everything for us.
+   On other systems we resolve one path component at a time. *)
 
 open Eio.Std
 
 module Fd = Eio_unix.Fd
 
+type dir_fd =
+  | FD of Fd.t
+  | Cwd         (* Confined to "." *)
+  | Fs          (* Unconfined "."; also allows absolute paths *)
+
+let openat ~sw ~mode fd path flags =
+  try
+    match fd with
+    | Fs -> Low_level.openat ~sw ~mode path flags
+    | Cwd -> Low_level.open_beneath ~sw ~mode ?dirfd:None path flags
+    | FD dirfd -> Low_level.open_beneath ~sw ~mode ~dirfd path flags
+  with Unix.Unix_error (code, name, arg) ->
+    raise (Err.wrap code name arg)
+
 module rec Dir : sig
   include Eio.Fs.Pi.DIR
 
-  val v : label:string -> sandbox:bool -> string -> t
+  val v : label:string -> path:string -> dir_fd -> t
 
   val resolve : t -> string -> string
   (** [resolve t path] returns the real path that should be used to access [path].
@@ -44,8 +55,9 @@ module rec Dir : sig
       For sandboxes, it opens the parent of [path] as [dir_fd] and runs [fn (Some dir_fd) (basename path)]. *)
 end = struct
   type t = {
+    fd : dir_fd;
     dir_path : string;
-    sandbox : bool;
+    sandbox : bool;      (* XXX *)
     label : string;
     mutable closed : bool;
   }
@@ -76,13 +88,12 @@ end = struct
         if leaf = ".." then path, "."
         else dir, leaf
       in
-      let dir = resolve t dir in
       Switch.run ~name:"with_parent_dir" @@ fun sw ->
-      let dirfd = Low_level.openat ~sw ~mode:0 dir Low_level.Open_flags.(directory + rdonly + nofollow) in
+      let dirfd = openat ~sw ~mode:0 t.fd dir Low_level.Open_flags.(directory + rdonly + nofollow) in
       fn (Some dirfd) leaf
     ) else fn None path
 
-  let v ~label ~sandbox dir_path = { dir_path; sandbox; label; closed = false }
+  let v ~label ~path:dir_path fd = { fd; dir_path; sandbox = fd <> Fs; label; closed = false }
 
   (* Sandboxes use [O_NOFOLLOW] when opening files ([resolve] already removed any symlinks).
      This avoids a race where symlink might be added after [realpath] returns. *)
@@ -165,10 +176,14 @@ end = struct
   let close t = t.closed <- true
 
   let open_dir t ~sw path =
-    Switch.check sw;
+    let o_path = Option.value Low_level.Open_flags.path ~default:Low_level.Open_flags.empty in
+    let fd = openat ~sw t.fd (if path = "" then "." else path) ~mode:0 Low_level.Open_flags.(o_path + directory) in
     let label = Filename.basename path in
-    let d = v ~label (resolve t path) ~sandbox:true in
-    Switch.on_release sw (fun () -> close d);
+    let full_path =
+      if Filename.is_relative path then Filename.concat t.dir_path path else path
+    in
+    let d = v ~label ~path:full_path (FD fd) in
+    Switch.on_release sw (fun () -> close d);           (* XXX *)
     Eio.Resource.T (d, Handler.v)
 
   let pp f t = Fmt.string f (String.escaped t.label)
@@ -209,5 +224,5 @@ end = struct
 end
 
 (* Full access to the filesystem. *)
-let fs = Eio.Resource.T (Dir.v ~label:"fs" ~sandbox:false ".", Handler.v)
-let cwd = Eio.Resource.T (Dir.v ~label:"cwd" ~sandbox:true ".", Handler.v)
+let fs = Eio.Resource.T (Dir.v ~label:"fs" ~path:"." Fs, Handler.v)
+let cwd = Eio.Resource.T (Dir.v ~label:"cwd" ~path:"." Cwd, Handler.v)

lib_eio_posix/low_level.ml

@@ -201,12 +201,104 @@ let rec with_dirfd op dirfd fn =
 
 external eio_openat : Unix.file_descr -> string -> Open_flags.t -> int -> Unix.file_descr = "caml_eio_posix_openat"
 
-let openat ?dirfd ~sw ~mode path flags =
+let openat_raw ~sw ~mode dirfd path flags =
   with_dirfd "openat" dirfd @@ fun dirfd ->
-  Switch.check sw;
-  in_worker_thread "openat" (fun () -> eio_openat dirfd path Open_flags.(flags + cloexec + nonblock) mode)
+  eio_openat dirfd path Open_flags.(flags + cloexec + nonblock) mode
   |> Fd.of_unix ~sw ~blocking:false ~close_unix:true
 
+let openat ?dirfd ~sw ~mode path flags =
+  Switch.check sw;
+  in_worker_thread "openat" (fun () -> openat_raw ~sw dirfd path flags ~mode)
+
+module Resolve = struct
+  type dir_stack =
+    | Base of Fd.t option         (* None if cwd *)
+    | Tmp of Fd.t * dir_stack
+
+  type resolve_state = {
+    sw : Switch.t;                            (* Temporary switch for [dir_stack] *)
+    mutable path : Path.Rel.t;                (* Components still to process *)
+    mutable dir_stack : dir_stack;            (* Directories already opened, for ".." *)
+    mutable max_follows : int;
+  }
+
+  let current_base state =
+    match state.dir_stack with
+    | Base b -> b
+    | Tmp (x, _) -> Some x
+
+  let parse_rel s =
+    match Path.parse s with
+    | Relative r -> r
+    | Absolute _ -> raise @@ Eio.Fs.err (Eio.Fs.Permission_denied (Err.Absolute_path))
+
+  (* Fallback for systems without O_RESOLVE_BENEATH: *)
+  let rec resolve state =
+    let path = state.path in
+    (* traceln "Consider %a" Path.Rel.dump path; *)
+    match path with
+    | Leaf { basename; trailing_slash } -> if trailing_slash then basename ^ "/" else basename
+    | Self -> "."
+    | Parent xs ->
+      begin match state.dir_stack with
+        | Base _ -> raise @@ Eio.Fs.err (Permission_denied (Err.Outside_sandbox ("XXX", "XXX")))
+        | Tmp (p, ps) ->
+          Fd.close p;
+          state.dir_stack <- ps;
+          state.path <- xs;
+          resolve state
+      end
+    | Child (x, xs) ->
+      state.path <- xs;
+      let base = current_base state in
+      match openat_raw ~sw:state.sw base x ~mode:0 Open_flags.(nofollow + directory) with
+      | new_base ->
+        state.dir_stack <- Tmp (new_base, state.dir_stack);
+        resolve state
+      | exception (Unix.Unix_error (Unix.ENOTDIR, _, _) as e) when state.max_follows > 0 ->
+        state.max_follows <- state.max_follows - 1;
+        match Eio_unix.Private.read_link base x with
+        | target ->
+          state.path <- Path.Rel.concat (parse_rel target) state.path;
+          resolve state
+        | exception Unix.Unix_error _ -> raise e
+
+  let close_tmp state =
+    let rec aux = function
+      | Base _ -> ()
+      | Tmp (x, xs) -> Fd.close x; aux xs
+    in
+    aux state.dir_stack
+
+  let open_beneath_fallback ?dirfd:base ~sw:final_sw ~mode path flags =
+    (* Match the kernel's behaviour of rejecting empty paths *)
+    if path = "" then raise (Unix.Unix_error (Unix.ENOENT, "open_beneath", path));
+    Switch.run @@ fun sw ->
+    let path = parse_rel path in
+    let state = { sw; path; dir_stack = Base base; max_follows = 8 } in
+    Switch.on_release sw (fun () -> close_tmp state);
+    let rec aux leaf =
+      let base = current_base state in
+      match openat_raw ~sw:final_sw base leaf ~mode Open_flags.(flags + nofollow) with
+      | fd -> fd
+      | exception (Unix.Unix_error (Unix.ELOOP, _, _) as e) when state.max_follows > 0 ->
+        state.max_follows <- state.max_follows - 1;
+        match Eio_unix.Private.read_link base leaf with
+        | target ->
+          state.path <- parse_rel target;
+          aux (resolve state)
+        | exception Unix.Unix_error _ -> raise e
+    in
+    aux (resolve state)
+end
+
+let open_beneath =
+  match Open_flags.resolve_beneath with
+  | None -> Resolve.open_beneath_fallback
+  | Some o_resolve_beneath ->
+    fun ?dirfd ~sw ~mode path flags ->
+      openat ?dirfd ~sw ~mode path Open_flags.(flags + o_resolve_beneath)
+
 external eio_mkdirat : Unix.file_descr -> string -> Unix.file_perm -> unit = "caml_eio_posix_mkdirat"
 
 let mkdir ?dirfd ~mode path =
@@ -330,14 +422,14 @@ module Process = struct
   (* Wait for [pid] to exit and then resolve [exit_status] to its status. *)
   let reap t exit_status =
     Eio.Condition.loop_no_mutex Eio_unix.Process.sigchld (fun () ->
-         Mutex.lock t.lock;
-         match Unix.waitpid [WNOHANG] t.pid with
-         | 0, _ -> Mutex.unlock t.lock; None                (* Not ready; wait for next SIGCHLD *)
-         | p, status ->
-           assert (p = t.pid);
-           Promise.resolve exit_status status;
-           Mutex.unlock t.lock;
-           Some ()
+        Mutex.lock t.lock;
+        match Unix.waitpid [WNOHANG] t.pid with
+        | 0, _ -> Mutex.unlock t.lock; None                (* Not ready; wait for next SIGCHLD *)
+        | p, status ->
+          assert (p = t.pid);
+          Promise.resolve exit_status status;
+          Mutex.unlock t.lock;
+          Some ()
       )
 
   let spawn ~sw actions =

lib_eio_posix/low_level.mli

@@ -108,6 +108,11 @@ end
 val openat : ?dirfd:fd -> sw:Switch.t -> mode:int -> string -> Open_flags.t -> fd
 (** Note: the returned FD is always non-blocking and close-on-exec. *)
 
+val open_beneath : ?dirfd:fd -> sw:Switch.t -> mode:int -> string -> Open_flags.t -> fd
+(** Like [openat], but with {!Open_flags.resolve_beneath}.
+
+    If the platform doesn't support this, the behaviour is emulated. *)
+
 module Process : sig
   type t
   (** A child process. *)

lib_eio_posix/path.ml

@@ -0,0 +1,67 @@
+type token =
+  | Empty
+  | DotDot
+  | String of string
+
+let rec tokenise = function
+  | [] -> []
+  | ["."] -> [Empty]                  (* "path/." is the same as "path/" *)
+  | "." :: xs -> tokenise xs          (* Skip dot if not at end *)
+  | "" :: xs -> Empty :: tokenise xs
+  | ".." :: xs -> DotDot :: tokenise xs
+  | x :: xs -> String x :: tokenise xs
+
+module Rel = struct
+  type t =
+    | Leaf of { basename : string; trailing_slash : bool }
+    | Self    (* A final "." *)
+    | Child of string * t
+    | Parent of t
+
+  let rec parse = function
+    | [] -> Self
+    | [String basename; Empty] -> Leaf { basename; trailing_slash = true }
+    | [String basename] -> Leaf { basename; trailing_slash = false }
+    | [DotDot] -> Parent Self
+    | DotDot :: xs -> Parent (parse xs)
+    | String s :: xs -> Child (s, parse xs)
+    | Empty :: [] -> Self
+    | Empty :: xs -> parse xs
+
+  let parse s = parse (tokenise s)
+
+  let rec concat a b =
+    match a with
+    | Leaf { basename; trailing_slash = _ } -> Child (basename, b)
+    | Child (name, xs) -> Child (name, concat xs b)
+    | Parent xs -> Parent (concat xs b)
+    | Self -> b
+
+  let rec dump f = function
+    | Child (x, xs) -> Fmt.pf f "%S / %a" x dump xs
+    | Parent xs -> Fmt.pf f ".. / %a" dump xs
+    | Self -> Fmt.pf f "."
+    | Leaf { basename; trailing_slash } ->
+      Fmt.pf f "%S" basename;
+      if trailing_slash then Fmt.pf f " /"
+end
+
+type t =
+  | Relative of Rel.t
+  | Absolute of Rel.t
+
+let rec parse_abs = function
+  | "" :: [] -> Absolute Self
+  | "" :: xs -> parse_abs xs
+  | xs -> Absolute (Rel.parse xs)
+
+let parse = function
+  | "" -> Relative Self
+  | s ->
+    match String.split_on_char '/' s with
+    | "" :: path -> parse_abs path
+    | path -> Relative (Rel.parse path)
+
+let dump f = function
+  | Relative r -> Rel.dump f r
+  | Absolute r -> Fmt.pf f "/ %a" Rel.dump r

lib_eio_posix/path.mli

@@ -0,0 +1,22 @@
+module Rel : sig
+  type t =
+    | Leaf of { basename : string; trailing_slash : bool }
+    | Self    (* A final "." *)
+    | Child of string * t
+    | Parent of t
+
+  val concat : t -> t -> t
+
+  val dump : t Fmt.t
+end
+
+type t =
+  | Relative of Rel.t
+  | Absolute of Rel.t
+
+val parse : string -> t
+(** Note:
+    [parse "" = Relative Self]
+    [parse ".." = Relative (Parent Self)] *)
+
+val dump : t Fmt.t

lib_eio_posix/test/dune

@@ -2,3 +2,8 @@
   (package eio_posix)
   (enabled_if (= %{os_type} "Unix"))
   (deps (package eio_posix)))
+
+(test
+  (name open_beneath)
+  (package eio_posix)
+  (libraries eio_posix))