diff --git a/bin/build_cmd.ml b/bin/build_cmd.ml index 266c6e2f2b3..050c900bdc6 100644 --- 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 index 6223a7744d8..b09528a78da 100644 --- 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 index d5f04f5bc74..fd897dfc600 100644 --- 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 index 090129f422c..865ec87a992 100644 --- 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 index 64c331f9329..a5533a0e8ca 100644 --- a/src/dune_pkg/package_universe.ml +++ b/src/dune_pkg/package_universe.ml @@ -128,11 +128,26 @@ 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" @@ -140,54 +155,38 @@ let validate_dependency_hash { local_packages; lock_dir; _ } = ] ] 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 index 2b2273fc12d..e09ee66824d 100644 --- 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