Use dev/inode to detect loops

src/file_tree.ml

@@ -155,33 +155,46 @@ let ignore_file fn ~is_directory =
   (is_directory && (fn.[0] = '.' || fn.[0] = '_')) ||
   (fn.[0] = '.' && fn.[1] = '#')
 
+module File = struct
+  type t =
+    { ino : int
+    ; dev : int
+    }
+
+  let compare a b =
+    match Int.compare a.ino b.ino with
+    | Eq -> Int.compare a.dev b.dev
+    | ne -> ne
+
+  let dummy = { ino = 0; dev = 0 }
+
+  let of_stats (st : Unix.stats) =
+    { ino = st.st_ino
+    ; dev = st.st_dev
+    }
+end
+
+module File_map = Map.Make(File)
+
 let load ?(extra_ignored_subtrees=Path.Set.empty) path =
-  let rec walk seen_real_paths path ~project ~ignored : Dir.t =
-    let realpath =
-      Path.follow_symlink path
-      |> Result.map_error ~f:(function
-        | `Maximum_depth_exceeded ->
-          die "maximum symlink depth exceeded while scanning %s"
-            (Path.to_string_maybe_quoted path)
-        | `Cycle_detected ->
-          die "cycle detected while scanning %s"
-            (Path.to_string_maybe_quoted path))
-      |> Result.ok_exn in
-    if List.mem realpath ~set:seen_real_paths then
-      die "Path %s has already been scanned. \
-           Cannot scan it again through symlink %s"
-        (Path.to_string_maybe_quoted realpath)
-        (Path.to_string_maybe_quoted path);
+  let rec walk path ~dirs_visited ~project ~ignored : Dir.t =
     let contents = lazy (
       let files, sub_dirs =
         Path.readdir path
         |> List.filter_partition_map ~f:(fun fn ->
           let path = Path.relative path fn in
-          let is_directory = Path.is_directory path in
+          let is_directory, file =
+            match Unix.stat (Path.to_string path) with
+            | exception _ -> (false, File.dummy)
+            | { st_kind = S_DIR; _ } as st ->
+              (true, File.of_stats st)
+            | _ ->
+              (false, File.dummy)
+          in
           if ignore_file fn ~is_directory then
             Skip
           else if is_directory then
-            Right (fn, path)
+            Right (fn, path, file)
           else
             Left fn)
       in
@@ -218,14 +231,27 @@ let load ?(extra_ignored_subtrees=Path.Set.empty) path =
           (dune_file, ignored_subdirs)
       in
       let sub_dirs =
-        List.fold_left sub_dirs ~init:String.Map.empty ~f:(fun acc (fn, path) ->
-          let ignored =
-            ignored
-            || String.Set.mem ignored_subdirs fn
-            || Path.Set.mem extra_ignored_subtrees path
-          in
-          String.Map.add acc fn
-            (walk (realpath :: seen_real_paths) path ~project ~ignored))
+        List.fold_left sub_dirs ~init:String.Map.empty
+          ~f:(fun acc (fn, path, file) ->
+            let dirs_visited =
+              if Sys.win32 then
+                dirs_visited
+              else
+                match File_map.find dirs_visited file with
+                | None -> File_map.add dirs_visited file path
+                | Some first_path ->
+                  die "Path %s has already been scanned. \
+                       Cannot scan it again through symlink %s"
+                    (Path.to_string_maybe_quoted first_path)
+                    (Path.to_string_maybe_quoted path)
+            in
+            let ignored =
+              ignored
+              || String.Set.mem ignored_subdirs fn
+              || Path.Set.mem extra_ignored_subtrees path
+            in
+            String.Map.add acc fn
+              (walk path ~dirs_visited ~project ~ignored))
       in
       { Dir. files; sub_dirs; dune_file; project })
     in
@@ -234,7 +260,14 @@ let load ?(extra_ignored_subtrees=Path.Set.empty) path =
     ; ignored
     }
   in
-  let root = walk [] path ~ignored:false ~project:None in
+  let root =
+    walk path
+      ~dirs_visited:(File_map.singleton
+                       (File.of_stats (Unix.stat (Path.to_string path)))
+                       path)
+      ~ignored:false
+      ~project:None
+  in
   let dirs = Hashtbl.create 1024      in
   Hashtbl.add dirs Path.root root;
   { root; dirs }

src/stdune/path.ml

@@ -520,36 +520,3 @@ let change_extension ~ext t =
 let extension = Filename.extension
 
 let pp ppf t = Format.pp_print_string ppf (to_string t)
-
-let follow_symlink p =
-  let readlink fn =
-    match Unix.readlink fn with
-    | exception Unix.Unix_error ((EINVAL | ENOENT), "readlink", _) -> None
-    | p -> Some p in
-  match readlink p with
-  | None -> Result.Ok p
-  | Some p ->
-    let rec follow n fn =
-      if n = 0 then
-        Result.Error `Maximum_depth_exceeded
-      else
-        match readlink fn with
-        | None -> Result.Ok fn
-        | Some p ->
-          if p = fn then
-            Result.Error `Cycle_detected
-          else
-            follow (pred n) p
-    in
-    let open Result.O in
-    follow 256 (to_string p) >>| fun 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 ]
-

src/stdune/path.mli

@@ -143,7 +143,3 @@ val pp : Format.formatter -> t -> unit
 val build_dir_exists : unit -> bool
 
 val ensure_build_dir_exists : unit -> unit
-
-val follow_symlink
-  :  t
-  -> (t, [ `Cycle_detected | `Maximum_depth_exceeded ]) Result.t

test/blackbox-tests/test-cases/github764/run.t

@@ -24,12 +24,12 @@
   $ cd symlink-outside-root2 && ln -s ../a other/b/x
   $ cd symlink-outside-root2 && ln -s ../other root/src
   $ cd symlink-outside-root2/root && dune build
-  Path b has already been scanned. Cannot scan it again through symlink src/a/x/x/x
+  Path src/a has already been scanned. Cannot scan it again through symlink src/a/x/x
   [1]
 
   $ mkdir -p symlink-outside-root3/{root,other}
   $ cd symlink-outside-root3 && ln -s ../other root/src
   $ cd symlink-outside-root3 && ln -s ../other other/foo
   $ cd symlink-outside-root3/root && dune build
-  Path other has already been scanned. Cannot scan it again through symlink src/foo
+  Path src has already been scanned. Cannot scan it again through symlink src/foo
   [1]