Add Dune_cache and Dune_cache_storage libraries

Signed-off-by: Andrey Mokhov <[email protected]>

Author: snowleopard

bin/build_cmd.ml

@@ -49,8 +49,7 @@ let run_build_command ~(common : Common.t) ~targets =
     run_build_command_poll
   else
     run_build_command_once)
-    ~setup ~common ~targets;
-  Build_system.cache_teardown ()
+    ~setup ~common ~targets
 
 let runtest =
   let doc = "Run tests." in

bin/caching.ml

@@ -60,8 +60,8 @@ let trim ~trimmed_size ~size =
   let open Result.O in
   match
     let* cache =
-      (* CR-someday amokhov: The [Hadrlink] duplication mode is chosen
-         artitrarily here, instead of respecting the corresponding configuration
+      (* CR-someday amokhov: The [Hardlink] duplication mode is chosen
+         arbitrarily here, instead of respecting the corresponding configuration
          setting, because the mode doesn't matter for the trimmer. It would be
          better to refactor the code to avoid such arbitrary choices. *)
       Cache.Local.make ~duplication_mode:Cache.Duplication_mode.Hardlink
@@ -123,7 +123,7 @@ let term =
      and+ root =
        Arg.(
          value
-         & opt path_conv (Cache.Local.default_root ())
+         & opt path_conv (Dune_cache_storage.Layout.default_root_path ())
          & info ~docv:"PATH" [ "root" ] ~doc:"Root of the dune cache")
      and+ trimmed_size =
        Arg.(
@@ -141,7 +141,13 @@ let term =
      | Some Start ->
        let config =
          { Cache_daemon.exit_no_client
-         ; duplication_mode = config.cache_duplication
+         ; duplication_mode =
+             (match
+                (config.cache_duplication : Dune_cache_storage.Mode.t option)
+              with
+             | None -> None
+             | Some Hardlink -> Some Hardlink
+             | Some Copy -> Some Copy)
          }
        in
        `Ok (start ~config ~foreground ~port_path ~root ~display)

bin/dune

@@ -8,6 +8,8 @@
   unix
   cache_daemon
   cache
+  dune_cache
+  dune_cache_storage
   dune_rules
   dune_engine
   dune_util

bin/import.ml

@@ -32,50 +32,6 @@ include Common.Let_syntax
 
 let in_group (t, info) = (Term.Group.Term t, info)
 
-let make_cache (config : Dune_config.t) =
-  let make_cache () =
-    let command_handler (Cache.Dedup file) =
-      match Build_system.get_cache () with
-      | None -> Code_error.raise "deduplication message and no caching" []
-      | Some caching ->
-        Scheduler.send_sync_task (fun () ->
-            let (module Caching : Cache.Caching) = caching.cache in
-            match Cached_digest.peek_file (Path.build file.path) with
-            | None -> ()
-            | Some d when not (Digest.equal d file.digest) -> ()
-            | _ -> Caching.Cache.deduplicate Caching.cache file)
-    in
-    match config.cache_transport with
-    | Dune_config.Caching.Transport.Direct ->
-      Log.info [ Pp.text "enable binary cache in direct access mode" ];
-      let cache =
-        Result.ok_exn
-          (Result.map_error
-             ~f:(fun s -> User_error.E (User_error.make [ Pp.text s ]))
-             (Cache.Local.make ?duplication_mode:config.cache_duplication
-                ~command_handler ()))
-      in
-      Cache.make_caching (module Cache.Local) cache
-    | Daemon ->
-      Log.info [ Pp.text "enable binary cache in daemon mode" ];
-      let cache =
-        Result.ok_exn
-          (Cache.Client.make ?duplication_mode:config.cache_duplication
-             ~command_handler ())
-      in
-      Cache.make_caching (module Cache.Client) cache
-  in
-  Fiber.return
-    (match config.cache_mode with
-    | Dune_config.Caching.Mode.Enabled ->
-      Some
-        { Build_system.cache = make_cache ()
-        ; check_probability = config.cache_check_probability
-        }
-    | Dune_config.Caching.Mode.Disabled ->
-      Log.info [ Pp.text "disable binary cache" ];
-      None)
-
 module Main = struct
   include Dune_rules.Main
 
@@ -93,7 +49,6 @@ module Main = struct
 
   let setup ?build_mutex common =
     let open Fiber.O in
-    let* caching = make_cache (Common.config common) in
     let* workspace = scan_workspace common in
     let* only_packages =
       match Common.only_packages common with
@@ -132,9 +87,22 @@ module Main = struct
         >>| Option.some
     in
     let stats = Common.stats common in
+    let cache_config =
+      match (Common.config common).cache_mode with
+      | Disabled -> Dune_cache.Config.Disabled
+      | Enabled ->
+        Enabled
+          { storage_mode =
+              (match (Common.config common).cache_duplication with
+              | None
+              | Some Hardlink ->
+                Dune_cache_storage.Mode.Hardlink
+              | Some Copy -> Copy)
+          }
+    in
     init_build_system workspace ?stats
       ~sandboxing_preference:(Common.config common).sandboxing_preference
-      ?caching ?build_mutex ?only_packages
+      ?build_mutex ?only_packages ~cache_config
 end
 
 module Scheduler = struct

boot/libs.ml

@@ -15,6 +15,8 @@ let local_libraries =
   ; ("src/memo", Some "Memo", false, None)
   ; ("src/dune_util", Some "Dune_util", false, None)
   ; ("src/xdg", Some "Xdg", false, None)
+  ; ("src/dune_cache_storage", Some "Dune_cache_storage", false, None)
+  ; ("src/dune_cache", Some "Dune_cache", false, None)
   ; ("src/cache", Some "Cache", false, None)
   ; ("src/cache_daemon", Some "Cache_daemon", false, None)
   ; ("vendor/re/src", Some "Dune_re", false, None)

otherlibs/stdune-unstable/digest.ml

@@ -35,21 +35,24 @@ let to_string_raw s = s
    or to different memory locations. *)
 let generic a = string (Marshal.to_string a [ No_sharing ])
 
-let file_with_stats p (stats : Unix.stats) =
+let file_with_executable_bit ~executable path =
+  (* We follow the digest scheme used by Jenga. *)
+  let string_and_bool ~digest_hex ~bool =
+    D.string
+      (digest_hex
+      ^
+      if bool then
+        "\001"
+      else
+        "\000")
+  in
+  let content_digest = file path in
+  string_and_bool ~digest_hex:content_digest ~bool:executable
+
+let file_with_stats path (stats : Unix.stats) =
   match stats.st_kind with
   | S_DIR ->
     generic (stats.st_size, stats.st_perm, stats.st_mtime, stats.st_ctime)
   | _ ->
-    (* We follow the digest scheme used by Jenga. *)
-    let string_and_bool ~digest_hex ~bool =
-      D.string
-        (digest_hex
-        ^
-        if bool then
-          "\001"
-        else
-          "\000")
-    in
-    let content_digest = file p in
     let executable = stats.st_perm land 0o100 <> 0 in
-    string_and_bool ~digest_hex:content_digest ~bool:executable
+    file_with_executable_bit ~executable path

otherlibs/stdune-unstable/digest.mli

@@ -26,5 +26,9 @@ val to_string_raw : t -> string
 
 val generic : 'a -> t
 
-(** Digest a file and its stats. Does something sensible for directories *)
+(** Digest a file and its stats. Does something sensible for directories. *)
 val file_with_stats : Path.t -> Unix.stats -> t
+
+(** Digest a file taking its executable bit into account. Should not be called
+    on a directory. *)
+val file_with_executable_bit : executable:bool -> Path.t -> t

otherlibs/stdune-unstable/path.ml

@@ -715,6 +715,10 @@ module Build = struct
 
   let chmod t ~mode = Unix.chmod (to_string t) mode
 
+  let lstat t = Unix.lstat (to_string t)
+
+  let unlink_no_err t = Fpath.unlink_no_err (to_string t)
+
   module Kind = Kind
 end
 

otherlibs/stdune-unstable/path.mli

@@ -186,6 +186,10 @@ module Build : sig
   (** Set permissions for a given path. You can use the [Permissions] module if
       you need to modify existing permissions in a non-trivial way. *)
   val chmod : t -> mode:int -> unit
+
+  val lstat : t -> Unix.stats
+
+  val unlink_no_err : t -> unit
 end
 
 type t = private
@@ -379,10 +383,9 @@ val set_of_build_paths_list : Build.t list -> Set.t
 
 val string_of_file_kind : Unix.file_kind -> string
 
-(** Rename a file. rename oldpath newpath renames the file called oldpath,
-    giving it newpath as its new name, moving it between directories if needed.
-    If newpath already exists, its contents will be replaced with those of
-    oldpath. *)
+(** Rename a file. [rename oldpath newpath] renames the file called [oldpath] to
+    [newpath], moving it between directories if needed. If [newpath] already
+    exists, its contents will be replaced with those of [oldpath]. *)
 val rename : t -> t -> unit
 
 (** Set permissions for a given path. You can use the [Permissions] module if

otherlibs/stdune-unstable/temp.ml

@@ -94,7 +94,8 @@ let clear_dir dir =
 
 let temp_path =
   try_paths 1000 ~f:(fun candidate ->
-      if Path.exists candidate then raise Exit;
+      if Path.exists candidate then
+        raise (Failure "the candidate temp path has already been taken");
       candidate)
 
 let temp_dir ~parent_dir ~prefix ~suffix =