Implicit relock if the dependencies have changed (#10546)

* Factor out validation function Signed-off-by: Marek Kubica <[email protected]> * Relock if the lock dir is out of date Signed-off-by: Marek Kubica <[email protected]> --------- Signed-off-by: Marek Kubica <[email protected]>
ocaml · May 20, 2024 · 98efedf · 98efedf
1 parent 8c62929
commit 98efedf
Show file tree

Hide file tree

Showing 6 changed files with 109 additions and 44 deletions.
diff --git a/bin/build_cmd.ml b/bin/build_cmd.ml
@@ -1,5 +1,13 @@
 open Import
 
+(** ad-hoc feature flag that automatically re-creates lock files if the
+    contents of the dependency list in the dune-project goes out of date
+
+    Supposed to be enabled in the developer preview and disabled in the
+    release, if you find yourself enabling this on release remove the
+    check altogether *)
+let use_autorelock = true
+
 let with_metrics ~common f =
   let start_time = Unix.gettimeofday () in
   Fiber.finalize f ~finally:(fun () ->
@@ -47,7 +55,48 @@ let run_build_system ~common ~request =
       Cached_digest.invalidate_cached_timestamps ();
       let* setup = Import.Main.setup () in
       let request =
-        Action_builder.bind (Action_builder.of_memo setup) ~f:(fun setup -> request setup)
+        let open Action_builder.O in
+        let autorelock =
+          match use_autorelock with
+          | false -> Memo.return ()
+          | true ->
+            Memo.of_thunk (fun () ->
+              let open Memo.O in
+              let lock_dir_path = Dune_pkg.Lock_dir.default_path in
+              let lock_dirs = Pkg_common.Lock_dirs_arg.of_path lock_dir_path in
+              let* per_contexts =
+                Workspace.workspace ()
+                >>| Pkg_common.Lock_dirs_arg.lock_dirs_of_workspace lock_dirs
+              in
+              let lock_dirs =
+                List.filter_map per_contexts ~f:(fun lock_dir_path ->
+                  match Path.exists (Path.source lock_dir_path) with
+                  | true -> Some (lock_dir_path, Dune_pkg.Lock_dir.read_disk lock_dir_path)
+                  | false -> None)
+              in
+              match lock_dirs with
+              | [] -> Memo.return ()
+              | lock_dirs ->
+                let* local_packages = Pkg_common.find_local_packages in
+                let locks =
+                  List.map lock_dirs ~f:(fun (lock_dir_path, lock_dir) ->
+                    match
+                      Dune_pkg.Package_universe.up_to_date local_packages lock_dir
+                    with
+                    | `Valid -> Memo.return ()
+                    | `Invalid _ ->
+                      let lock_dirs_arg =
+                        Pkg_common.Lock_dirs_arg.of_path lock_dir_path
+                      in
+                      Lock.lock ~version_preference:None ~lock_dirs_arg
+                      |> Memo.of_non_reproducible_fiber)
+                in
+                let+ (_ : unit list) = Memo.all_concurrently locks in
+                ())
+        in
+        let setup = Memo.both setup autorelock |> Memo.map ~f:fst in
+        let* setup = Action_builder.of_memo setup in
+        request setup
       in
       (* CR-someday cmoseley: Can we avoid creating a new lazy memo node every
          time the build system is rerun? *)

diff --git a/bin/pkg/lock.mli b/bin/pkg/lock.mli
@@ -1,4 +1,10 @@
 open Import
 
+(** creates a lock file at the specified location(s) *)
+val lock
+  :  version_preference:Dune_pkg.Version_preference.t option
+  -> lock_dirs_arg:Pkg_common.Lock_dirs_arg.t
+  -> unit Fiber.t
+
 (** Command to create lock directory *)
 val command : unit Cmd.t
diff --git a/bin/pkg/pkg_common.ml b/bin/pkg/pkg_common.ml
@@ -136,6 +136,8 @@ module Lock_dirs_arg = struct
        All)
   ;;
 
+  let of_path p = Selected [ p ]
+
   let lock_dirs_of_workspace t (workspace : Workspace.t) =
     let workspace_lock_dirs =
       Lock_dir.default_path

diff --git a/bin/pkg/pkg_common.mli b/bin/pkg/pkg_common.mli
@@ -62,6 +62,10 @@ module Lock_dirs_arg : sig
         of the workspace are considered. *)
   val term : t Term.t
 
+  (** [Lock_dirs_arg.of_path] creates a specific lock dir argument out of a
+      source path *)
+  val of_path : Path.Source.t -> t
+
   (** [Lock_dirs_arg.lock_dirs_of_workspace t workspace] returns the list of
       lock directories that should be considered for various operations.
 

diff --git a/src/dune_pkg/package_universe.ml b/src/dune_pkg/package_universe.ml
@@ -128,66 +128,65 @@ let check_for_unnecessary_packges_in_lock_dir
          ]))
 ;;
 
-let validate_dependency_hash { local_packages; lock_dir; _ } =
+let up_to_date local_packages (lock_dir : Lock_dir.t) =
   let local_packages =
     Package_name.Map.values local_packages |> List.map ~f:Local_package.for_solver
   in
-  let regenerate_lock_dir_hints =
+  let non_local_dependencies =
+    Local_package.For_solver.list_non_local_dependency_set local_packages
+  in
+  let dependency_hash = Local_package.Dependency_set.hash non_local_dependencies in
+  match lock_dir.dependency_hash, dependency_hash with
+  | None, None -> `Valid
+  | Some (_, lock_dir_dependency_hash), Some non_local_dependency_hash
+    when Local_package.Dependency_hash.equal
+           lock_dir_dependency_hash
+           non_local_dependency_hash -> `Valid
+  | _, Some non_local_dependency_hash -> `Invalid (Some non_local_dependency_hash)
+  | _, None -> `Invalid None
+;;
+
+let validate_dependency_hash { local_packages; lock_dir; _ } =
+  let hints =
     [ Pp.concat
         ~sep:Pp.space
         [ Pp.text "Regenerate the lockdir by running"
         ; User_message.command "dune pkg lock"
         ]
     ]
   in
-  let non_local_dependencies =
-    Local_package.For_solver.list_non_local_dependency_set local_packages
-  in
-  let dependency_hash = Local_package.Dependency_set.hash non_local_dependencies in
-  match lock_dir.dependency_hash, dependency_hash with
-  | None, None -> Ok ()
-  | Some (loc, lock_dir_dependency_hash), None ->
+  let res = up_to_date local_packages lock_dir in
+  match res, lock_dir.dependency_hash with
+  | `Valid, _ -> Ok ()
+  | `Invalid (Some _), None ->
     Error
       (User_error.make
-         ~loc
-         ~hints:regenerate_lock_dir_hints
-         [ Pp.textf
-             "This project has no non-local dependencies yet the lockfile contains a \
-              dependency hash: %s"
-             (Local_package.Dependency_hash.to_string lock_dir_dependency_hash)
+         ~hints
+         [ Pp.text
+             "This project has specified dependencies but the lockdir doesn't contain a \
+              dependency hash."
          ])
-  | None, Some _ ->
-    let any_non_local_dependency : Package_dependency.t =
-      List.hd (Local_package.Dependency_set.package_dependencies non_local_dependencies)
-    in
+  | `Invalid None, _ ->
     Error
       (User_error.make
-         ~hints:regenerate_lock_dir_hints
+         ~hints
+         [ Pp.text
+             "This project does not have dependencies but the lockdir specifies \
+              dependencies"
+         ])
+  | `Invalid (Some non_local_dependency_hash), Some (loc, lock_dir_dependency_hash) ->
+    Error
+      (User_error.make
+         ~loc
+         ~hints
          [ Pp.text
-             "This project has at least one non-local dependency but the lockdir doesn't \
-              contain a dependency hash."
-         ; Pp.textf
-             "An example of a non-local dependency of this project is: %s"
-             (Package_name.to_string any_non_local_dependency.name)
+             "Dependency hash in lockdir does not match the hash of non-local \
+              dependencies of this project. The lockdir expects the the non-local \
+              dependencies to hash to:"
+         ; Pp.text (Local_package.Dependency_hash.to_string lock_dir_dependency_hash)
+         ; Pp.text "...but the non-local dependencies of this project hash to:"
+         ; Pp.text (Local_package.Dependency_hash.to_string non_local_dependency_hash)
          ])
-  | Some (loc, lock_dir_dependency_hash), Some non_local_dependency_hash ->
-    if Local_package.Dependency_hash.equal
-         lock_dir_dependency_hash
-         non_local_dependency_hash
-    then Ok ()
-    else
-      Error
-        (User_error.make
-           ~loc
-           ~hints:regenerate_lock_dir_hints
-           [ Pp.text
-               "Dependency hash in lockdir does not match the hash of non-local \
-                dependencies of this project. The lockdir expects the the non-local \
-                dependencies to hash to:"
-           ; Pp.text (Local_package.Dependency_hash.to_string lock_dir_dependency_hash)
-           ; Pp.text "...but the non-local dependencies of this project hash to:"
-           ; Pp.text (Local_package.Dependency_hash.to_string non_local_dependency_hash)
-           ])
 ;;
 
 let validate t =

diff --git a/src/dune_pkg/package_universe.mli b/src/dune_pkg/package_universe.mli
@@ -5,6 +5,11 @@ open! Import
     solution for the local packages. *)
 type t
 
+val up_to_date
+  :  Local_package.t Package_name.Map.t
+  -> Lock_dir.t
+  -> [ `Valid | `Invalid of Local_package.Dependency_hash.t option ]
+
 val create
   :  Local_package.t Package_name.Map.t
   -> Lock_dir.t