Merge pull request #715 from patricoferris/symlinks

Add symlink support

lib_eio/fs.ml

@@ -70,6 +70,7 @@ module Pi = struct
     val rmdir : t -> path -> unit
     val rename : t -> path -> _ dir -> path -> unit
     val read_link : t -> path -> string
+    val symlink : link_to:path -> t -> path -> unit
     val pp : t Fmt.t
     val native : t -> string -> string option
   end

lib_eio/path.ml

@@ -199,6 +199,14 @@ let rename t1 t2 =
     let bt = Printexc.get_raw_backtrace () in
     Exn.reraise_with_context ex bt "renaming %a to %a" pp t1 pp t2
 
+let symlink ~link_to source =
+  let (Resource.T (dir, ops), path) = source in
+  let module X = (val (Resource.get ops Fs.Pi.Dir)) in
+  try X.symlink dir path ~link_to
+  with Exn.Io _ as ex ->
+    let bt = Printexc.get_raw_backtrace () in
+    Exn.reraise_with_context ex bt "creating symlink %a -> %s" pp source link_to
+
 let rec mkdirs ?(exists_ok=false) ~perm t =
   (* Check parent exists first. *)
   split t |> Option.iter (fun (parent, _) ->

lib_eio/path.mli

@@ -207,3 +207,13 @@ val rename : _ t -> _ t -> unit
 (** [rename old_t new_t] atomically unlinks [old_t] and links it as [new_t].
 
     If [new_t] already exists, it is atomically replaced. *)
+
+val symlink : link_to:string -> _ t -> unit
+(** [symlink ~link_to t] creates a symbolic link [t] to [link_to].
+
+    [t] is the symlink that is created and [link_to] is the name used in the link.
+    For example, this creates a "current" symlink pointing at "version-1.0":
+
+    {[
+      Eio.Path.symlink (dir / "current") ~link_to:"version-1.0"
+    ]} *)

lib_eio_linux/eio_linux.ml

@@ -593,6 +593,9 @@ end = struct
     | Some fd2 -> Low_level.rename t.fd old_path fd2 new_path
     | None -> raise (Unix.Unix_error (Unix.EXDEV, "rename-dst", new_path))
 
+  let symlink ~link_to t path =
+    Low_level.symlink ~link_to t.fd path
+
   let pp f t = Fmt.string f (String.escaped t.label)
 
   let fd t = t.fd

lib_eio_linux/eio_stubs.c

@@ -97,6 +97,24 @@ CAMLprim value caml_eio_renameat(value v_old_fd, value v_old_path, value v_new_f
   CAMLreturn(Val_unit);
 }
 
+CAMLprim value caml_eio_symlinkat(value v_old_path, value v_new_fd, value v_new_path) {
+  CAMLparam2(v_old_path, v_new_path);
+  char *old_path;
+  char *new_path;
+  int ret;
+  caml_unix_check_path(v_old_path, "symlinkat-old");
+  caml_unix_check_path(v_new_path, "symlinkat-new");
+  old_path = caml_stat_strdup(String_val(v_old_path));
+  new_path = caml_stat_strdup(String_val(v_new_path));
+  caml_enter_blocking_section();
+  ret = symlinkat(old_path, Int_val(v_new_fd), new_path);
+  caml_leave_blocking_section();
+  caml_stat_free(old_path);
+  caml_stat_free(new_path);
+  if (ret == -1) uerror("symlinkat", v_old_path);
+  CAMLreturn(Val_unit);
+}
+
 CAMLprim value caml_eio_getrandom(value v_ba, value v_off, value v_len) {
   CAMLparam1(v_ba);
   ssize_t ret;

lib_eio_linux/low_level.ml

@@ -330,6 +330,8 @@ external eio_mkdirat : Unix.file_descr -> string -> Unix.file_perm -> unit = "ca
 
 external eio_renameat : Unix.file_descr -> string -> Unix.file_descr -> string -> unit = "caml_eio_renameat"
 
+external eio_symlinkat : string -> Unix.file_descr -> string -> unit = "caml_eio_symlinkat"
+
 external eio_getrandom : Cstruct.buffer -> int -> int -> int = "caml_eio_getrandom"
 
 external eio_getdents : Unix.file_descr -> string list = "caml_eio_getdents"
@@ -450,6 +452,12 @@ let rename old_dir old_path new_dir new_path =
       new_parent new_leaf
   with Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap_fs code name arg
 
+let symlink ~link_to dir path =
+  with_parent_dir "symlinkat-new" dir path @@ fun parent leaf ->
+  try
+    eio_symlinkat link_to parent leaf
+  with Unix.Unix_error (code, name, arg) -> raise @@ Err.wrap_fs code name arg
+
 let shutdown socket command =
   try
     Fd.use_exn "shutdown" socket @@ fun fd ->

lib_eio_linux/low_level.mli

@@ -150,6 +150,9 @@ val unlink : rmdir:bool -> dir_fd -> string -> unit
 val rename : dir_fd -> string -> dir_fd -> string -> unit
 (** [rename old_dir old_path new_dir new_path] renames [old_dir / old_path] as [new_dir / new_path]. *)
 
+val symlink : link_to:string -> dir_fd -> string -> unit
+(** [symlink ~link_to dir path] creates a new symlink at [dir / path] pointing to [link_to]. *)
+
 val pipe : sw:Switch.t -> fd * fd
 (** [pipe ~sw] returns a pair [r, w] with the readable and writeable ends of a new pipe. *)
 

lib_eio_linux/primitives.h

@@ -5,6 +5,7 @@
 CAMLprim value caml_eio_eventfd(value);
 CAMLprim value caml_eio_mkdirat(value, value, value);
 CAMLprim value caml_eio_renameat(value, value, value, value);
+CAMLprim value caml_eio_symlinkat(value, value, value);
 CAMLprim value caml_eio_getrandom(value, value, value);
 CAMLprim value caml_eio_getdents(value);
 CAMLprim value caml_eio_clone3(value, value);

lib_eio_posix/eio_posix_stubs.c

@@ -384,6 +384,27 @@ CAMLprim value caml_eio_posix_renameat(value v_old_fd, value v_old_path, value v
   CAMLreturn(Val_unit);
 }
 
+CAMLprim value caml_eio_posix_symlinkat(value v_old_path, value v_new_fd, value v_new_path) {
+  CAMLparam2(v_old_path, v_new_path);
+  size_t old_path_len = caml_string_length(v_old_path);
+  size_t new_path_len = caml_string_length(v_new_path);
+  char *old_path;
+  char *new_path;
+  int ret;
+  caml_unix_check_path(v_old_path, "symlinkat-old");
+  caml_unix_check_path(v_new_path, "symlinkat-new");
+  old_path = caml_stat_alloc(old_path_len + new_path_len + 2);
+  new_path = old_path + old_path_len + 1;
+  memcpy(old_path, String_val(v_old_path), old_path_len + 1);
+  memcpy(new_path, String_val(v_new_path), new_path_len + 1);
+  caml_enter_blocking_section();
+  ret = symlinkat(old_path, Int_val(v_new_fd), new_path);
+  caml_leave_blocking_section();
+  caml_stat_free_preserving_errno(old_path);
+  if (ret == -1) uerror("symlinkat", v_old_path);
+  CAMLreturn(Val_unit);
+}
+
 CAMLprim value caml_eio_posix_spawn(value v_errors, value v_actions) {
   CAMLparam1(v_actions);
   pid_t child_pid;

lib_eio_posix/fs.ml

@@ -94,6 +94,9 @@ end = struct
     | None -> invalid_arg "Target is not an eio_posix directory!"
     | Some new_dir -> Err.run (Low_level.rename t.fd old_path new_dir) new_path
 
+  let symlink ~link_to t path =
+    Err.run (Low_level.symlink ~link_to t.fd) path
+
   let open_dir t ~sw path =
     let flags = Low_level.Open_flags.(rdonly + directory +? path) in
     let fd = Err.run (Low_level.openat ~sw ~mode:0 t.fd path) flags in

lib_eio_posix/low_level.ml

@@ -415,6 +415,14 @@ let rename old_dir old_path new_dir new_path =
   let new_dir = Option.value new_dir ~default:at_fdcwd in
   eio_renameat old_dir old_path new_dir new_path
 
+external eio_symlinkat : string -> Unix.file_descr -> string -> unit = "caml_eio_posix_symlinkat"
+
+let symlink ~link_to new_dir new_path =
+  in_worker_thread "symlink" @@ fun () ->
+  Resolve.with_parent "symlink-new" new_dir new_path @@ fun new_dir new_path ->
+  let new_dir = Option.value new_dir ~default:at_fdcwd in
+  eio_symlinkat link_to new_dir new_path
+
 let read_link dirfd path =
   in_worker_thread "read_link" @@ fun () ->
   Resolve.with_parent "read_link" dirfd path @@ fun dirfd path ->

lib_eio_posix/low_level.mli

@@ -78,6 +78,10 @@ val mkdir : mode:int -> dir_fd -> string -> unit
 val unlink : dir:bool -> dir_fd -> string -> unit
 val rename : dir_fd -> string -> dir_fd -> string -> unit
 
+val symlink : link_to:string -> dir_fd -> string -> unit
+(** [symlink ~link_to dir path] will create a new symlink at [dir / path]
+    linking to [link_to]. *)
+
 val readdir : dir_fd -> string -> string array
 
 val readv : fd -> Cstruct.t array -> int

lib_eio_posix/primitives.h

@@ -14,6 +14,7 @@ CAMLprim value caml_eio_posix_fdopendir(value);
 CAMLprim value caml_eio_posix_mkdirat(value, value, value);
 CAMLprim value caml_eio_posix_unlinkat(value, value, value);
 CAMLprim value caml_eio_posix_renameat(value, value, value, value);
+CAMLprim value caml_eio_posix_symlinkat(value, value, value);
 CAMLprim value caml_eio_posix_make_stat(value);
 CAMLprim value caml_eio_posix_fstatat(value, value, value, value);
 CAMLprim value caml_eio_posix_fstat(value, value);

lib_eio_windows/eio_windows_stubs.c

@@ -252,6 +252,11 @@ CAMLprim value caml_eio_windows_renameat(value v_old_fd, value v_old_path, value
   uerror("renameat is not supported on windows yet", Nothing);
 }
 
+CAMLprim value caml_eio_windows_symlinkat(value v_old_path, value v_new_fd, value v_new_path)
+{
+  uerror("symlinkat is not supported on windows yet", Nothing);
+}
+
 CAMLprim value caml_eio_windows_spawn(value v_errors, value v_actions)
 {
   uerror("processes are not supported on windows yet", Nothing);

lib_eio_windows/fs.ml

@@ -172,6 +172,10 @@ end = struct
       with_parent_dir new_dir new_path @@ fun new_dir new_path ->
       Err.run (Low_level.rename ?old_dir old_path ?new_dir) new_path
 
+  let symlink ~link_to t path =
+    with_parent_dir t path @@ fun dirfd path ->
+    Err.run (Low_level.symlink ~link_to dirfd) path
+
   let close t = t.closed <- true
 
   let open_dir t ~sw path =

lib_eio_windows/low_level.ml

@@ -234,6 +234,14 @@ let rename ?old_dir old_path ?new_dir new_path =
   in_worker_thread @@ fun () ->
   eio_renameat old_dir old_path new_dir new_path
 
+
+external eio_symlinkat : string -> Unix.file_descr option -> string -> unit = "caml_eio_windows_symlinkat"
+
+let symlink ~link_to new_dir new_path =
+  with_dirfd "symlink-new" new_dir @@ fun new_dir ->
+  in_worker_thread @@ fun () ->
+  eio_symlinkat link_to new_dir new_path
+
 let lseek fd off cmd =
   Fd.use_exn "lseek" fd @@ fun fd ->
   let cmd =

lib_eio_windows/low_level.mli

@@ -48,6 +48,10 @@ 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
 
+val symlink : link_to:string -> fd option -> string -> unit
+(** [symlink ~link_to dir path] will create a new symlink at [dir / path]
+    linking to [link_to]. *)
+
 val readdir : string -> string array
 
 val readv : fd -> Cstruct.t array -> int

tests/fs.md

@@ -89,11 +89,17 @@ let try_stat path =
     traceln "%a -> %s" Eio.Path.pp path a
   else
     traceln "%a -> %s / %s" Eio.Path.pp path a b
+
+let try_symlink ~link_to path =
+  match Path.symlink ~link_to path with
+  | s -> traceln "symlink %a -> %S" Path.pp path link_to
+  | exception ex -> traceln "@[<h>%a@]" Eio.Exn.pp ex
 ```
 
 # Basic test cases
 
 Creating a file and reading it back:
+
 ```ocaml
 # run ~clear:["test-file"] @@ fun env ->
   let cwd = Eio.Stdenv.cwd env in
@@ -104,6 +110,7 @@ Creating a file and reading it back:
 ```
 
 Check the file got the correct permissions (subject to the umask set above):
+
 ```ocaml
 # Printf.printf "Perm = %o\n" ((Unix.stat "test-file").st_perm);;
 Perm = 644
@@ -113,6 +120,7 @@ Perm = 644
 # Sandboxing
 
 Trying to use cwd to access a file outside of that subtree fails:
+
 ```ocaml
 # run @@ fun env ->
   let cwd = Eio.Stdenv.cwd env in
@@ -123,6 +131,7 @@ Exception: Eio.Io Fs Permission_denied _,
 ```
 
 Trying to use cwd to access an absolute path fails:
+
 ```ocaml
 # run @@ fun env ->
   let cwd = Eio.Stdenv.cwd env in
@@ -135,6 +144,7 @@ Exception: Eio.Io Fs Permission_denied _,
 # Creation modes
 
 Exclusive create fails if already exists:
+
 ```ocaml
 # run @@ fun env ->
   let cwd = Eio.Stdenv.cwd env in
@@ -146,6 +156,7 @@ Exception: Eio.Io Fs Already_exists _,
 ```
 
 If-missing create succeeds if already exists:
+
 ```ocaml
 # run @@ fun env ->
   let cwd = Eio.Stdenv.cwd env in
@@ -158,6 +169,7 @@ If-missing create succeeds if already exists:
 ```
 
 Truncate create succeeds if already exists, and truncates:
+
 ```ocaml
 # run @@ fun env ->
   let cwd = Eio.Stdenv.cwd env in
@@ -172,6 +184,7 @@ Truncate create succeeds if already exists, and truncates:
 ```
 
 Error if no create and doesn't exist:
+
 ```ocaml
 # run @@ fun env ->
   let cwd = Eio.Stdenv.cwd env in
@@ -183,6 +196,7 @@ Exception: Eio.Io Fs Not_found _,
 ```
 
 Appending to an existing file:
+
 ```ocaml
 # run @@ fun env ->
   let cwd = Eio.Stdenv.cwd env in
@@ -215,12 +229,13 @@ Appending to an existing file:
 ```
 
 Creating directories with nesting, symlinks, etc:
+
 ```ocaml
 # run ~clear:["to-subdir"; "to-root"; "dangle"] @@ fun env ->
-  Unix.symlink "/" "to-root";
-  Unix.symlink "subdir" "to-subdir";
-  Unix.symlink "foo" "dangle";
   let cwd = Eio.Stdenv.cwd env in
+  Path.symlink ~link_to:"/" (cwd / "to-root");
+  Path.symlink ~link_to:"subdir" (cwd / "to-subdir");
+  Path.symlink ~link_to:"foo" (cwd / "dangle");
   try_mkdir (cwd / "subdir");
   try_mkdir (cwd / "to-subdir/nested");
   try_mkdir (cwd / "to-root/tmp/foo");
@@ -384,10 +399,10 @@ Reads and writes follow symlinks, but unlink operates on the symlink itself:
   let file2 = cwd / "file2" in
   try_write_file ~create:(`Exclusive 0o600) file1 "data1";
   try_write_file ~create:(`Exclusive 0o400) file2 "data2";
-  Unix.symlink "dir1/file1" "link1";
+  Path.symlink ~link_to:"dir1/file1" (cwd / "link1");
-  Unix.symlink "../file2" "dir1/link2";
+  Path.symlink ~link_to:"../file2" (cwd / "dir1/link2");
-  Unix.symlink "dir1" "linkdir";
+  Path.symlink ~link_to:"dir1" (cwd / "linkdir");
-  Unix.symlink "/" "linkroot";
+  Path.symlink ~link_to:"/" (cwd / "linkroot");
   try_read_file file1;
   try_read_file (cwd / "link1");
   try_read_file (cwd / "linkdir" / "file1");
@@ -504,6 +519,7 @@ Removing something that doesn't exist or is out of scope:
 # Limiting to a subdirectory
 
 Create a sandbox, write a file with it, then read it from outside:
+
 ```ocaml
 # run ~clear:["sandbox"] @@ fun env ->
   Switch.run @@ fun sw ->
@@ -540,10 +556,10 @@ Create a sandbox, write a file with it, then read it from outside:
   reject (cwd / "/");
   test (cwd / "foo/bar/..");
   test (fs / "foo/bar");
-  Unix.symlink ".." "foo/up";
+  Path.symlink ~link_to:".." (cwd / "foo/up");
   test (cwd / "foo/up/foo/bar");
   reject (cwd / "foo/up/../bar");
-  Unix.symlink "/" "foo/root";
+  Path.symlink ~link_to:"/" (cwd / "foo/root");
   reject (cwd / "foo/root/..");
   reject (cwd / "missing");
 +open_dir <cwd:foo/bar> -> OK
@@ -566,6 +582,7 @@ Create a sandbox, write a file with it, then read it from outside:
 
 We create a directory and chdir into it.
 Using `cwd` we can't access the parent, but using `fs` we can:
+
 ```ocaml
 # run ~clear:["fs-test"; "outside-cwd"] @@ fun env ->
   let cwd = Eio.Stdenv.cwd env in
@@ -604,7 +621,7 @@ Reading directory entries under `cwd` and outside of `cwd`.
   try_read_dir (tmpdir / ".");
   try_read_dir (tmpdir / "..");
   try_read_dir (tmpdir / "test-3");
-  Unix.symlink "test-1" "readdir/link-1";
+  Path.symlink ~link_to:"test-1" (cwd / "readdir/link-1");
   try_read_dir (tmpdir / "link-1");
 +mkdir <cwd:readdir> -> ok
 +mkdir <readdir:test-1> -> ok
@@ -650,6 +667,29 @@ Exception: Eio.Io Fs Permission_denied _,
   opening <cwd:/dev/null>
 ```
 
+Symlinking and sandboxing:
+
+```ocaml
+# run ~clear:["hello.txt"; "world.txt"] @@ fun env ->
+  let cwd = Eio.Stdenv.cwd env in
+  Path.save ~create:(`Exclusive 0o600) (cwd / "hello.txt") "Hello World!";
+  try_symlink ~link_to:"hello.txt" (cwd / "../world.txt");
+  try_symlink ~link_to:"hello.txt" (cwd / "/world.txt");
+  try_symlink ~link_to:"hello.txt" (cwd / "world.txt");
+  traceln "world.txt -> hello.txt: %s" (Path.load (cwd / "world.txt"));
+  try_symlink ~link_to:"hello.txt" (cwd / "world.txt");
+  try_symlink ~link_to:"/" (cwd / "root");
+  try_read_dir (cwd / "root");;
++Eio.Io Fs Permission_denied _, creating symlink <cwd:../world.txt> -> hello.txt
++Eio.Io Fs Permission_denied _, creating symlink <cwd:/world.txt> -> hello.txt
++symlink <cwd:world.txt> -> "hello.txt"
++world.txt -> hello.txt: Hello World!
++Eio.Io Fs Already_exists _, creating symlink <cwd:world.txt> -> hello.txt
++symlink <cwd:root> -> "/"
++Eio.Io Fs Permission_denied _, reading directory <cwd:root>
+- : unit = ()
+```
+
 ## Streamling lines
 
 ```ocaml
@@ -781,15 +821,15 @@ Unconfined:
   let cwd = Eio.Stdenv.cwd env in
   Switch.run @@ fun sw ->
   try_mkdir (cwd / "stat_subdir2");
-  Unix.symlink "stat_subdir2" "symlink";
+  Path.symlink ~link_to:"stat_subdir2" (cwd / "symlink");
-  Unix.symlink "missing" "broken-symlink";
+  Path.symlink ~link_to:"missing" (cwd / "broken-symlink");
   try_stat (cwd / "stat_subdir2");
   try_stat (cwd / "symlink");
   try_stat (cwd / "broken-symlink");
   try_stat cwd;
   try_stat (cwd / "..");
   try_stat (cwd / "stat_subdir2/..");
-  Unix.symlink ".." "parent-symlink";
+  Path.symlink ~link_to:".." (cwd / "parent-symlink");
   try_stat (cwd / "parent-symlink");
   try_stat (cwd / "missing1" / "missing2");
 +mkdir <cwd:stat_subdir2> -> ok
@@ -811,7 +851,7 @@ Unconfined:
   let fs = Eio.Stdenv.fs env in
   let cwd = Eio.Stdenv.cwd env in
   Switch.run @@ fun sw ->
-  Unix.symlink "file" "symlink";
+  Path.symlink ~link_to:"file" (cwd / "symlink");
   try_read_link (cwd / "symlink");
   try_read_link (fs / "symlink");
   try_write_file (cwd / "file") "data" ~create:(`Exclusive 0o600);