Add Dune_cache and Dune_cache_storage libraries

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

bin/build_cmd.ml

@@ -45,8 +45,7 @@ let run_build_command ~(common : Common.t) ~config ~targets =
     run_build_command_poll
   else
     run_build_command_once)
-    ~setup ~common ~config ~targets;
-  Build_system.cache_teardown ()
+    ~setup ~common ~config ~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.(
@@ -142,7 +142,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,57 +32,12 @@ 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
 
-  let setup common config =
+  let setup common (config : Dune_config.t) =
     let open Fiber.O in
-    let* caching = make_cache config
-    and* conf = Memo.Build.run (Dune_rules.Dune_load.load ())
+    let* conf = Memo.Build.run (Dune_rules.Dune_load.load ())
     and* contexts = Memo.Build.run (Context.DB.all ()) in
     let stats = Common.stats common in
     List.iter contexts ~f:(fun (ctx : Context.t) ->
@@ -91,8 +46,25 @@ module Main = struct
           [ Pp.box ~indent:1
               (Pp.text "Dune context:" ++ Pp.cut ++ Dyn.pp (Context.to_dyn ctx))
           ]);
+    (* CR-soon amokhov: Right now, types [Dune_config.Caching.Duplication.t] and
+       [Dune_cache_storage.Mode.t] are the same. They will be unified after
+       removing the cache daemon and adapting the configuration format. *)
+    let cache_config =
+      match config.cache_mode with
+      | Disabled -> Dune_cache.Config.Disabled
+      | Enabled ->
+        Enabled
+          { storage_mode =
+              (match config.cache_duplication with
+              | None
+              | Some Hardlink ->
+                Dune_cache_storage.Mode.Hardlink
+              | Some Copy -> Copy)
+          ; check_probability = config.cache_check_probability
+          }
+    in
     init_build_system ~stats ~sandboxing_preference:config.sandboxing_preference
-      ~caching ~conf ~contexts
+      ~cache_config ~conf ~contexts
 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.mli

@@ -20,7 +20,7 @@ val destroy : what -> Path.t -> unit
     itself. *)
 val clear_dir : Path.t -> unit
 
-(** [temp_path ~dir ~prefix ~suffix] generate a temporary path in [dir]. The
+(** [temp_path ~dir ~prefix ~suffix] generates a temporary path in [dir]. The
     base name of the temporary file is formed by concatenating [prefix], then a
     suitably chosen integer number, then [suffix]. *)
 val temp_path : dir:Path.t -> prefix:string -> suffix:string -> Path.t

src/cache/dune

@@ -1,4 +1,4 @@
 (library
  (name cache)
  (synopsis "[Internal] Dune binary artifact cache protocol")
- (libraries stdune threads.posix xdg dune_lang dune_util csexp))
+ (libraries stdune threads.posix xdg dune_lang dune_util csexp dune_cache))

src/cache/local.ml

@@ -33,7 +33,7 @@ let default_root () =
 
 let file_store_root cache = Path.L.relative cache.root [ "files"; "v4" ]
 
-let metadata_store_root cache = Path.L.relative cache.root [ "meta"; "v4" ]
+let metadata_store_root cache = Path.L.relative cache.root [ "meta"; "v5" ]
 
 (* A file storage scheme. *)
 module type FSScheme = sig
@@ -62,7 +62,7 @@ module FirstTwoCharsSubdir : FSScheme = struct
     let first_two_chars = String.sub digest ~pos:0 ~len:2 in
     Path.L.relative root [ first_two_chars; digest ]
 
-  (* List all entries in a given cache root. Returns the empty list of the root
+  (* List all entries in a given cache root. Returns the empty list if the root
      doesn't exist. *)
   let list ~root =
     let open Result.O in
@@ -87,7 +87,7 @@ let metadata_path cache key =
 
 let file_path cache key = FSSchemeImpl.path ~root:(file_store_root cache) key
 
-(* Support for an older version of the cache. *)
+(* Support for older versions of the cache. *)
 module V3 = struct
   let file_store_root cache = Path.L.relative cache.root [ "files"; "v3" ]
 
@@ -96,6 +96,10 @@ module V3 = struct
   let file_path cache key = FSSchemeImpl.path ~root:(file_store_root cache) key
 end
 
+module V4 = struct
+  let metadata_store_root cache = Path.L.relative cache.root [ "meta"; "v4" ]
+end
+
 module Metadata_file = struct
   type t =
     { metadata : Sexp.t list
@@ -425,13 +429,14 @@ let trim_bad_metadata_files ~metadata_files ~trimmed_so_far ~file_path cache =
       | false -> trimmed_so_far)
 
 let garbage_collect_impl ~trimmed_so_far cache =
-  let metadata_files = FSSchemeImpl.list ~root:(V3.metadata_store_root cache) in
-  let trimmed_so_far =
-    trim_bad_metadata_files ~metadata_files ~trimmed_so_far
-      ~file_path:V3.file_path cache
-  in
-  let metadata_files = FSSchemeImpl.list ~root:(metadata_store_root cache) in
-  trim_bad_metadata_files ~metadata_files ~trimmed_so_far ~file_path cache
+  List.fold_left ~init:trimmed_so_far
+    ~f:(fun trimmed_so_far (root, file_path) ->
+      let metadata_files = FSSchemeImpl.list ~root in
+      trim_bad_metadata_files ~metadata_files ~trimmed_so_far ~file_path cache)
+    [ (V3.metadata_store_root cache, V3.file_path)
+    ; (V4.metadata_store_root cache, file_path)
+    ; (metadata_store_root cache, file_path)
+    ]
 
 let garbage_collect = garbage_collect_impl ~trimmed_so_far:Trimming_result.empty
 

src/dune_cache/config.ml

@@ -0,0 +1,9 @@
+(* CR-someday amokhov: We should probably switch from float [check_probability]
+   to integer [check_frequency], as in Jenga, to avoid generating random floats. *)
+
+type t =
+  | Disabled
+  | Enabled of
+      { storage_mode : Dune_cache_storage.Mode.t
+      ; check_probability : float
+      }

src/dune_cache/config.mli

@@ -0,0 +1,6 @@
+type t =
+  | Disabled
+  | Enabled of
+      { storage_mode : Dune_cache_storage.Mode.t
+      ; check_probability : float
+      }

src/dune_cache/dune

@@ -0,0 +1,4 @@
+(library
+ (name dune_cache)
+ (synopsis "[Internal] Dune's local and cloud build cache")
+ (libraries csexp dune_cache_storage fiber stdune))