refactor: pull [Cached_digest] move (#10313)

It was moved to [Dune_digest]

Signed-off-by: Rudi Grinberg <[email protected]>

bin/common.ml

@@ -1258,9 +1258,9 @@ let init (builder : Builder.t) =
   Dune_engine.Clflags.debug_backtraces c.builder.debug_backtraces;
   Dune_rules.Clflags.debug_artifact_substitution := c.builder.debug_artifact_substitution;
   Dune_engine.Clflags.debug_load_dir := c.builder.debug_load_dir;
-  Dune_engine.Clflags.debug_digests := c.builder.debug_digests;
   Dune_engine.Clflags.debug_fs_cache := c.builder.cache_debug_flags.fs_cache;
-  Dune_engine.Clflags.wait_for_filesystem_clock := c.builder.wait_for_filesystem_clock;
+  Dune_digest.Clflags.debug_digests := c.builder.debug_digests;
+  Dune_digest.Clflags.wait_for_filesystem_clock := c.builder.wait_for_filesystem_clock;
   Dune_engine.Clflags.capture_outputs := c.builder.capture_outputs;
   Dune_engine.Clflags.diff_command := c.builder.diff_command;
   Dune_engine.Clflags.promote := c.builder.promote;

bin/import.ml

@@ -16,11 +16,11 @@ include struct
   module Dpath = Dpath
   module Findlib = Dune_rules.Findlib
   module Diff_promotion = Diff_promotion
-  module Cached_digest = Cached_digest
   module Targets = Targets
   module Context_name = Context_name
 end
 
+module Cached_digest = Dune_digest.Cached_digest
 module Execution_env = Dune_util.Execution_env
 
 include struct

src/dune_engine/cached_digest.ml → src/dune_digest/cached_digest.ml

@@ -92,7 +92,7 @@ let cache =
 let get_current_filesystem_time () =
   let special_path = Path.relative Path.build_dir ".filesystem-clock" in
   Io.write_file special_path "<dummy>";
-  (Path.Untracked.stat_exn special_path).st_mtime
+  (Path.stat_exn special_path).st_mtime
 ;;
 
 let wait_for_fs_clock_to_advance () =
@@ -176,7 +176,7 @@ let set_with_stat path digest stat =
 let set path digest =
   (* the caller of [set] ensures that the files exist *)
   let path = Path.build path in
-  let stat = Path.Untracked.stat_exn path in
+  let stat = Path.stat_exn path in
   set_with_stat path digest stat
 ;;
 
@@ -260,12 +260,12 @@ let catch_fs_errors f =
 (* Here we make only one [stat] call on the happy path. *)
 let refresh_without_removing_write_permissions ~allow_dirs path =
   catch_fs_errors (fun () ->
-    match Path.Untracked.stat_exn path with
+    match Path.stat_exn path with
     | stats -> refresh stats ~allow_dirs path
     | exception Unix.Unix_error (ELOOP, _, _) -> Error Cyclic_symlink
     | exception Unix.Unix_error (ENOENT, _, _) ->
       (* Test if this is a broken symlink for better error messages. *)
-      (match Path.Untracked.lstat_exn path with
+      (match Path.lstat_exn path with
        | exception Unix.Unix_error (ENOENT, _, _) -> Error No_such_file
        | _stats_so_must_be_a_symlink -> Error Broken_symlink))
 ;;
@@ -277,12 +277,12 @@ let refresh_without_removing_write_permissions ~allow_dirs path =
    here, e.g., by telling the subsequent [chmod] to not follow symlinks. *)
 let refresh_and_remove_write_permissions ~allow_dirs path =
   catch_fs_errors (fun () ->
-    match Path.Untracked.lstat_exn path with
+    match Path.lstat_exn path with
     | exception Unix.Unix_error (ENOENT, _, _) -> Error No_such_file
     | stats ->
       (match stats.st_kind with
        | S_LNK ->
-         (match Path.Untracked.stat_exn path with
+         (match Path.stat_exn path with
           | stats -> refresh stats ~allow_dirs:false path
           | exception Unix.Unix_error (ELOOP, _, _) -> Error Cyclic_symlink
           | exception Unix.Unix_error (ENOENT, _, _) -> Error Broken_symlink)
@@ -314,7 +314,7 @@ let peek_file ~allow_dirs path =
        then Ok x.digest
        else (
          (* The [stat_exn] below follows symlinks. *)
-         match Path.Untracked.stat_exn path with
+         match Path.stat_exn path with
          | exception Unix.Unix_error (ELOOP, _, _) ->
            Error Digest_result.Error.Cyclic_symlink
          | exception Unix.Unix_error (ENOENT, _, _) -> Error No_such_file
@@ -374,9 +374,12 @@ let remove path =
 ;;
 
 module Untracked = struct
-  let source_or_external_file = peek_or_refresh_file ~allow_dirs:false
+  let source_or_external_file path =
+    peek_or_refresh_file ~allow_dirs:false (Path.outside_build_dir path)
+  ;;
 
   let invalidate_cached_timestamp path =
+    let path = Path.outside_build_dir path in
     let cache = Lazy.force cache in
     match Path.Table.find cache.table path with
     | None -> ()

src/dune_engine/cached_digest.mli → src/dune_digest/cached_digest.mli

@@ -41,11 +41,11 @@ val refresh
 module Untracked : sig
   (** Digest the contents of a source or external file. This function doesn't
       track the source file. For a tracked version, see [fs_memo.mli]. *)
-  val source_or_external_file : Path.t -> Digest_result.t
+  val source_or_external_file : Path.Outside_build_dir.t -> Digest_result.t
 
   (** Invalidate the cached [stat] value. This causes the subsequent call to
       [source_or_external_file] to incur an additional [stat] call. *)
-  val invalidate_cached_timestamp : Path.t -> unit
+  val invalidate_cached_timestamp : Path.Outside_build_dir.t -> unit
 end
 
 (** {1 Managing the cache} *)

src/dune_digest/clflags.ml

@@ -0,0 +1,2 @@
+let wait_for_filesystem_clock = ref false
+let debug_digests = ref false

src/dune_digest/clflags.mli

@@ -0,0 +1,6 @@
+(** Wait for the filesystem clock to advance rather than dropping cached digest
+    entries *)
+val wait_for_filesystem_clock : bool ref
+
+(** Print debug info for cached digests *)
+val debug_digests : bool ref

src/dune_digest/digest.ml

@@ -0,0 +1,160 @@
+open Stdune
+
+type t = string
+
+external md5_fd : Unix.file_descr -> string = "dune_md5_fd"
+
+module D = Stdlib.Digest
+module Set = String.Set
+module Map = String.Map
+module Metrics = Dune_metrics
+
+module type Digest_impl = sig
+  val file : string -> t
+  val string : string -> t
+end
+
+module Direct_impl : Digest_impl = struct
+  let file file =
+    (* On Windows, if this function is invoked in a background thread,
+       if can happen that the file is not properly closed.
+       [O_SHARE_DELETE] ensures that the main thread can delete it even if it
+       is still open. See #8243. *)
+    let fd =
+      match Unix.openfile file [ Unix.O_RDONLY; O_SHARE_DELETE; O_CLOEXEC ] 0 with
+      | fd -> fd
+      | exception Unix.Unix_error (Unix.EACCES, _, _) ->
+        raise (Sys_error (sprintf "%s: Permission denied" file))
+      | exception exn -> reraise exn
+    in
+    Exn.protectx fd ~f:md5_fd ~finally:Unix.close
+  ;;
+
+  let string = D.string
+end
+
+module Mutable_impl = struct
+  let file_ref = ref Direct_impl.file
+  let string_ref = ref D.string
+  let file f = !file_ref f
+  let string s = !string_ref s
+end
+
+let override_impl ~file ~string =
+  Mutable_impl.file_ref := file;
+  Mutable_impl.string_ref := string
+;;
+
+module Impl : Digest_impl = Mutable_impl
+
+let hash = Poly.hash
+let equal = String.equal
+let file p = Impl.file (Path.to_string p)
+let compare x y = Ordering.of_int (D.compare x y)
+let to_string = D.to_hex
+let to_dyn s = Dyn.variant "digest" [ String (to_string s) ]
+
+let from_hex s =
+  match D.from_hex s with
+  | s -> Some s
+  | exception Invalid_argument _ -> None
+;;
+
+let string = Impl.string
+let to_string_raw s = s
+
+(* We use [No_sharing] to avoid generating different digests for inputs that
+   differ only in how they share internal values. Without [No_sharing], if a
+   command line contains duplicate flags, such as multiple occurrences of the
+   flag [-I], then [Marshal.to_string] will produce different digests depending
+   on whether the corresponding strings ["-I"] point to the same memory location
+   or to different memory locations. *)
+let generic a =
+  Metrics.Timer.record "generic_digest" ~f:(fun () ->
+    string (Marshal.to_string a [ No_sharing ]))
+;;
+
+let path_with_executable_bit =
+  (* We follow the digest scheme used by Jenga. *)
+  let string_and_bool ~digest_hex ~bool =
+    Impl.string (digest_hex ^ if bool then "\001" else "\000")
+  in
+  fun ~executable ~content_digest ->
+    string_and_bool ~digest_hex:content_digest ~bool:executable
+;;
+
+let file_with_executable_bit ~executable path =
+  let content_digest = file path in
+  path_with_executable_bit ~content_digest ~executable
+;;
+
+module Stats_for_digest = struct
+  type t =
+    { st_kind : Unix.file_kind
+    ; st_perm : Unix.file_perm
+    }
+
+  let of_unix_stats (stats : Unix.stats) =
+    { st_kind = stats.st_kind; st_perm = stats.st_perm }
+  ;;
+end
+
+module Path_digest_error = struct
+  type nonrec t =
+    | Unexpected_kind
+    | Unix_error of Dune_filesystem_stubs.Unix_error.Detailed.t
+end
+
+exception E of Path_digest_error.t
+
+let directory_digest_version = 2
+
+let path_with_stats ~allow_dirs path (stats : Stats_for_digest.t) =
+  let rec loop path (stats : Stats_for_digest.t) =
+    match stats.st_kind with
+    | S_LNK ->
+      let executable = Path.Permissions.test Path.Permissions.execute stats.st_perm in
+      Dune_filesystem_stubs.Unix_error.Detailed.catch
+        (fun path ->
+          let contents = Unix.readlink (Path.to_string path) in
+          path_with_executable_bit ~executable ~content_digest:contents)
+        path
+      |> Result.map_error ~f:(fun x -> Path_digest_error.Unix_error x)
+    | S_REG ->
+      let executable = Path.Permissions.test Path.Permissions.execute stats.st_perm in
+      Dune_filesystem_stubs.Unix_error.Detailed.catch
+        (file_with_executable_bit ~executable)
+        path
+      |> Result.map_error ~f:(fun x -> Path_digest_error.Unix_error x)
+    | S_DIR when allow_dirs ->
+      (* CR-someday amokhov: The current digesting scheme has collisions for files
+         and directories. It's unclear if this is actually a problem. If it turns
+         out to be a problem, we should include [st_kind] into both digests. *)
+      (match Path.readdir_unsorted path with
+       | Error e -> Error (Path_digest_error.Unix_error e)
+       | Ok listing ->
+         (match
+            List.rev_map listing ~f:(fun name ->
+              let path = Path.relative path name in
+              let stats =
+                match Path.lstat path with
+                | Error e -> raise_notrace (E (Unix_error e))
+                | Ok stat -> Stats_for_digest.of_unix_stats stat
+              in
+              let digest =
+                match loop path stats with
+                | Ok s -> s
+                | Error e -> raise_notrace (E e)
+              in
+              name, digest)
+            |> List.sort ~compare:(fun (x, _) (y, _) -> String.compare x y)
+          with
+          | exception E e -> Error e
+          | contents -> Ok (generic (directory_digest_version, contents, stats.st_perm))))
+    | S_DIR | S_BLK | S_CHR | S_FIFO | S_SOCK -> Error Unexpected_kind
+  in
+  match stats.st_kind with
+  | S_DIR when not allow_dirs -> Error Path_digest_error.Unexpected_kind
+  | S_BLK | S_CHR | S_LNK | S_FIFO | S_SOCK -> Error Unexpected_kind
+  | _ -> loop path stats
+;;

src/dune_digest/dune

@@ -1,6 +1,6 @@
 (library
  (name dune_digest)
- (libraries dune_metrics stdune unix)
+ (libraries dune_metrics dune_stats dune_console dune_util stdune unix)
  (foreign_stubs
   (names dune_digest_stubs)
   (language c))