diff --git a/lib_eio/fs.ml b/lib_eio/fs.ml index 11d018ec9..95d55a290 100644 --- a/lib_eio/fs.ml +++ b/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 diff --git a/lib_eio/path.ml b/lib_eio/path.ml index fdfccf44e..74bf6cc8f 100644 --- a/lib_eio/path.ml +++ b/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, _) -> diff --git a/lib_eio/path.mli b/lib_eio/path.mli index 2fca64193..1ee10f091 100644 --- a/lib_eio/path.mli +++ b/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. +*) diff --git a/lib_eio_linux/eio_linux.ml b/lib_eio_linux/eio_linux.ml index 75aacd6d5..0fc4e9e65 100644 --- a/lib_eio_linux/eio_linux.ml +++ b/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 diff --git a/lib_eio_linux/eio_stubs.c b/lib_eio_linux/eio_stubs.c index 80e23317b..b917fc5a0 100644 --- a/lib_eio_linux/eio_stubs.c +++ b/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; diff --git a/lib_eio_linux/low_level.ml b/lib_eio_linux/low_level.ml index 16b36dad6..688ba49f8 100644 --- a/lib_eio_linux/low_level.ml +++ b/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 -> diff --git a/lib_eio_linux/low_level.mli b/lib_eio_linux/low_level.mli index eeaec8386..60b42273b 100644 --- a/lib_eio_linux/low_level.mli +++ b/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. *) diff --git a/lib_eio_posix/eio_posix_stubs.c b/lib_eio_posix/eio_posix_stubs.c index 199b714c3..a3895f48c 100644 --- a/lib_eio_posix/eio_posix_stubs.c +++ b/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; diff --git a/lib_eio_posix/fs.ml b/lib_eio_posix/fs.ml index a5723ed50..2d4954789 100644 --- a/lib_eio_posix/fs.ml +++ b/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 diff --git a/lib_eio_posix/low_level.ml b/lib_eio_posix/low_level.ml index 00b8d0367..38e0c0915 100644 --- a/lib_eio_posix/low_level.ml +++ b/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 -> diff --git a/lib_eio_posix/low_level.mli b/lib_eio_posix/low_level.mli index a829ca705..090ef6fc5 100644 --- a/lib_eio_posix/low_level.mli +++ b/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 diff --git a/lib_eio_windows/eio_windows_stubs.c b/lib_eio_windows/eio_windows_stubs.c index a8797617e..d3b5be2af 100755 --- a/lib_eio_windows/eio_windows_stubs.c +++ b/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); diff --git a/lib_eio_windows/fs.ml b/lib_eio_windows/fs.ml index 69d0aa344..dc7466302 100755 --- a/lib_eio_windows/fs.ml +++ b/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 = diff --git a/lib_eio_windows/low_level.ml b/lib_eio_windows/low_level.ml index f18896a21..24be68df9 100755 --- a/lib_eio_windows/low_level.ml +++ b/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 = diff --git a/lib_eio_windows/low_level.mli b/lib_eio_windows/low_level.mli index 1edcc8a4d..a59ce7650 100755 --- a/lib_eio_windows/low_level.mli +++ b/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 diff --git a/tests/fs.md b/tests/fs.md index e7401d10b..917cc42a0 100644 --- a/tests/fs.md +++ b/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 -> 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 -> ok +mkdir -> 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 -> 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);