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 : t -> path -> path -> unit
     val pp : t Fmt.t
     val native : t -> string -> string option
   end

lib_eio/path.ml

@@ -199,6 +199,16 @@ 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 ?(exists_ok=false) ~target name =
+  let (Resource.T (dir, ops), old_path) = target in
+  let module X = (val (Resource.get ops Fs.Pi.Dir)) in
+  try X.symlink dir old_path name
+  with 
+  | Exn.Io (Fs.E Already_exists _, _) when exists_ok -> ()
+  | Exn.Io _ as ex ->
+    let bt = Printexc.get_raw_backtrace () in
+    Exn.reraise_with_context ex bt "symlink to %a called %s" pp target name
+
 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,16 @@ 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 : ?exists_ok:bool -> target:_ t -> string -> unit
+(** [symlink ~target name] creates a link to [target] called [name]. 
+    
+    The following program creates a new file called [./hello.txt] and then creates
+    a symbolic link from [./world.txt] to [./hello.txt].
+    {[
+        Eio.Path.(save ~create:(`If_missing 0o644) (env#cwd / "hello.txt")) "Hello World!";
+        Eio.Path.(symlink ~target:(env#cwd / "hello.txt") "world.txt")
+    ]}
+
+    @param exist_ok If [false] (the default) then we raise {! Fs.Already_exists} if the symlink already exists with that target.
+*)

lib_eio_linux/eio_linux.ml

@@ -600,6 +600,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 t old_path new_path =
+    Low_level.symlink old_path t.fd new_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,26 @@ 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);
+  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();
+  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 old_path new_dir new_path =
+  with_parent_dir "renameat-new" new_dir new_path @@ fun new_parent new_leaf ->
+  try
+    eio_symlinkat old_path new_parent new_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 : string -> dir_fd -> string -> unit
+(** [rename old_path dir new_path] symlinks to [dir / old_path] as [dir / new_path]. *)
+
 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_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 t target_path new_name =
+    Err.run (Low_level.symlink target_path t.fd) new_name
+
   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

@@ -414,6 +414,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 old_path 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 old_path 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

@@ -77,6 +77,7 @@ val read_link : dir_fd -> string -> string
 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 : string -> dir_fd -> string -> unit
 
 val readdir : dir_fd -> string -> string array
 

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 t old_path new_path =
+    with_parent_dir t new_path @@ fun dirfd path ->
+    Err.run (Low_level.symlink dirfd old_path) 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_posix_symlinkat"
+
+let symlink old_path new_dir new_path =
+  with_dirfd "symlink-new" new_dir @@ fun new_dir ->
+  in_worker_thread @@ fun () ->
+  eio_symlinkat old_path new_dir new_path
+
 let lseek fd off cmd =
   Fd.use_exn "lseek" fd @@ fun fd ->
   let cmd =

lib_eio_windows/low_level.mli

@@ -47,6 +47,7 @@ val read_link : ?dirfd:fd -> string -> string
 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 : string -> fd option -> string -> unit
 
 val readdir : string -> string array
 

tests/fs.md

@@ -217,10 +217,10 @@ 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";
+  Path.symlink ~target:(Eio.Stdenv.fs env / "/") "to-root";
   let cwd = Eio.Stdenv.cwd env in
+  Path.symlink ~target:(cwd / "subdir") "to-subdir";
+  Path.symlink ~target:(cwd / "foo") "dangle";
   try_mkdir (cwd / "subdir");
   try_mkdir (cwd / "to-subdir/nested");
   try_mkdir (cwd / "to-root/tmp/foo");
@@ -384,10 +384,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";
-  Unix.symlink "../file2" "dir1/link2";
-  Unix.symlink "dir1" "linkdir";
-  Unix.symlink "/" "linkroot";
+  Path.symlink ~target:file1 "link1";
+  Path.symlink ~target:(cwd / "../file2") "dir1/link2";
+  Path.symlink ~target:(cwd / "dir1") "linkdir";
+  Path.symlink ~target:(fs / "/") "linkroot";
   try_read_file file1;
   try_read_file (cwd / "link1");
   try_read_file (cwd / "linkdir" / "file1");
@@ -540,10 +540,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 ~target:(cwd / "..") "foo/up";
   test (cwd / "foo/up/foo/bar");
   reject (cwd / "foo/up/../bar");
-  Unix.symlink "/" "foo/root";
+  Path.symlink ~target:(fs / "/") "foo/root";
   reject (cwd / "foo/root/..");
   reject (cwd / "missing");
 +open_dir <cwd:foo/bar> -> OK
@@ -604,7 +604,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 ~target:(cwd / "test-1") "readdir/link-1";
   try_read_dir (tmpdir / "link-1");
 +mkdir <cwd:readdir> -> ok
 +mkdir <readdir:test-1> -> ok
@@ -781,15 +781,15 @@ Unconfined:
   let cwd = Eio.Stdenv.cwd env in
   Switch.run @@ fun sw ->
   try_mkdir (cwd / "stat_subdir2");
-  Unix.symlink "stat_subdir2" "symlink";
-  Unix.symlink "missing" "broken-symlink";
+  Path.symlink ~target:(cwd / "stat_subdir2") "symlink";
+  Path.symlink ~target:(cwd / "missing") "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 ~target:(cwd / "..") "parent-symlink";
   try_stat (cwd / "parent-symlink");
   try_stat (cwd / "missing1" / "missing2");
 +mkdir <cwd:stat_subdir2> -> ok
@@ -811,7 +811,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 ~target:(cwd / "file") "symlink";
   try_read_link (cwd / "symlink");
   try_read_link (fs / "symlink");
   try_write_file (cwd / "file") "data" ~create:(`Exclusive 0o600);