From 540a22315b554de512bcb916442f0e8f65ada5dc Mon Sep 17 00:00:00 2001
From: Rudi Grinberg <rudi.grinberg@gmail.com>
Date: Tue, 15 May 2018 13:11:41 +0700
Subject: [PATCH] Refactor symlink following

Correctly resolve relative symlinks and add better error handling. Also move the
logic to the path module.
---
 src/file_tree.ml    |  5 +----
 src/stdune/path.ml  | 18 ++++++++++++++++++
 src/stdune/path.mli |  2 ++
 3 files changed, 21 insertions(+), 4 deletions(-)

diff --git a/src/file_tree.ml b/src/file_tree.ml
index eb3c8ae0..cc993f00 100644
--- a/src/file_tree.ml
+++ b/src/file_tree.ml
@@ -157,10 +157,7 @@ let ignore_file fn ~is_directory =
 
 let load ?(extra_ignored_subtrees=Path.Set.empty) path =
   let rec walk seen_real_paths path ~project ~ignored : Dir.t =
-    let realpath =
-      try Path.of_string (Unix.readlink (Path.to_string path))
-      with Unix.Unix_error (_, _, _) -> path
-    in
+    let realpath = Path.follow_symlink path in
     if List.mem realpath ~set:seen_real_paths then
       die "Path %s has already been scanned. \
            Cannot scan it again through symlink %s"
diff --git a/src/stdune/path.ml b/src/stdune/path.ml
index ec8fd4ad..6794bb5f 100644
--- a/src/stdune/path.ml
+++ b/src/stdune/path.ml
@@ -521,3 +521,21 @@ let extension = Filename.extension
 
 let pp ppf t = Format.pp_print_string ppf (to_string t)
 
+let follow_symlink p =
+  match (
+    match Unix.readlink (to_string p) with
+    | p -> Some p
+    | exception Unix.Unix_error (Unix.EINVAL, "readlink", _) -> None
+  ) with
+  | None -> p
+  | Some realpath ->
+    if not (is_local realpath) then
+      of_string realpath
+    else
+      match parent p with
+      | Some p -> relative p realpath
+      | None ->
+        Exn.code_error "follow_symlink: p cannot be a symlink to root"
+          [ "p", sexp_of_t p
+          ; "realpath", sexp_of_t realpath ]
+
diff --git a/src/stdune/path.mli b/src/stdune/path.mli
index 44663266..53e34816 100644
--- a/src/stdune/path.mli
+++ b/src/stdune/path.mli
@@ -143,3 +143,5 @@ val pp : Format.formatter -> t -> unit
 val build_dir_exists : unit -> bool
 
 val ensure_build_dir_exists : unit -> unit
+
+val follow_symlink : t -> t