Merge pull request #12653 from Alizter/push-skrkpmlkomsw

feat(pkg): autolocking

Author: Alizter

src/dune_pkg/opam_repo.ml

@@ -128,6 +128,13 @@ let revision t =
   | Directory _ -> Code_error.raise "not a git repo" []
 ;;
 
+let content_digest t =
+  match t.source with
+  | Repo repo ->
+    Rev_store.At_rev.rev repo |> Rev_store.Object.to_hex |> Dune_digest.string
+  | Directory path -> Path_digest.digest_with_lstat path
+;;
+
 let load_opam_package_from_dir ~(dir : Path.t) package =
   let opam_file_path = Paths.opam_file package in
   match Path.exists (Path.append_local dir opam_file_path) with

src/dune_pkg/opam_repo.mli

@@ -26,6 +26,15 @@ val of_git_repo : Loc.t -> OpamUrl.t -> t Fiber.t
 val revision : t -> Rev_store.At_rev.t
 val serializable : t -> Serializable.t option
 
+(** [content_digest t] digests the contents of an opam repository. For a Git
+    repository, this is a digest of the commit SHA. For a directory-based
+    repository, this is a digest of the directory's contents.
+
+    Raises [User_error] in the directory case if the path cannot be accessed or
+    digested due to permission errors, the directory being deleted or modified
+    between stat and digest, or other filesystem errors. *)
+val content_digest : t -> Dune_digest.t
+
 module Key : sig
   type t
 

src/dune_pkg/package_universe.ml

@@ -134,14 +134,16 @@ let check_for_unnecessary_packges_in_lock_dir
       ])
 ;;
 
-let up_to_date local_packages ~dependency_hash:saved_dependency_hash =
+let dependency_digest local_packages =
   let local_packages =
     Package_name.Map.values local_packages |> List.map ~f:Local_package.for_solver
   in
-  let dependency_hash =
-    Local_package.For_solver.non_local_dependencies local_packages
-    |> Local_package.Dependency_hash.of_dependency_formula
-  in
+  Local_package.For_solver.non_local_dependencies local_packages
+  |> Local_package.Dependency_hash.of_dependency_formula
+;;
+
+let up_to_date local_packages ~dependency_hash:saved_dependency_hash =
+  let dependency_hash = dependency_digest local_packages in
   match saved_dependency_hash, dependency_hash with
   | None, None -> `Valid
   | Some lock_dir_dependency_hash, Some non_local_dependencies_hash

src/dune_pkg/package_universe.mli

@@ -14,6 +14,10 @@ val create
   -> Lock_dir.t
   -> (t, User_message.t) result
 
+val dependency_digest
+  :  Local_package.t Package_name.Map.t
+  -> Local_package.Dependency_hash.t option
+
 (** Verifies if the dependencies described in the project file are still
     synchronized with the dependencies selected in the lock directroy. If it is
     not the case, it returns the hash of the new dependency set. *)

src/dune_pkg/path_digest.ml

@@ -0,0 +1,25 @@
+open Import
+
+let digest_with_lstat path =
+  match Path.lstat path with
+  | Error e ->
+    User_error.raise
+      [ Pp.textf "Can't stat path %S:" (Path.to_string path); Unix_error.Detailed.pp e ]
+  | Ok stats ->
+    let stats_for_digest = Dune_digest.Stats_for_digest.of_unix_stats stats in
+    (match Dune_digest.path_with_stats ~allow_dirs:true path stats_for_digest with
+     | Ok digest -> digest
+     | Error (Unix_error e) ->
+       User_error.raise
+         [ Pp.textf "Can't digest path %S:" (Path.to_string path)
+         ; Unix_error.Detailed.pp e
+         ]
+     | Error Unexpected_kind ->
+       User_error.raise
+         [ Pp.textf
+             "Can't digest path %S: Unexpected file kind %S (%s)"
+             (Path.to_string path)
+             (File_kind.to_string stats_for_digest.st_kind)
+             (File_kind.to_string_hum stats_for_digest.st_kind)
+         ])
+;;

src/dune_pkg/path_digest.mli

@@ -0,0 +1,10 @@
+open Import
+
+(** [digest_with_lstat path] stats the [path] using [lstat] (without following
+    symlinks) and computes a digest of its contents. Directories are allowed
+    and will be digested recursively.
+
+    Raises [User_error] if the path cannot be stat'd (e.g., does not exist or
+    permission denied), cannot be digested (e.g., I/O error during reading), or
+    has an unexpected file kind (e.g., socket, FIFO). *)
+val digest_with_lstat : Path.t -> Dune_digest.t

src/dune_pkg/resolved_package.ml

@@ -38,6 +38,11 @@ let opam_file = function
   | Rest t -> t.opam_file
 ;;
 
+let extra_files = function
+  | Dune -> None
+  | Rest t -> Some t.extra_files
+;;
+
 let add_opam_package_to_opam_file package opam_file =
   opam_file
   |> OpamFile.OPAM.with_version (OpamPackage.version package)
@@ -188,3 +193,50 @@ let get_opam_package_files resolved_packages =
     | Some _ -> Some (Option.value files ~default:[]))
   |> Int.Map.values
 ;;
+
+let digest_extra_files : extra_files -> Dune_digest.t = function
+  | Inside_files_dir path_opt ->
+    (match path_opt with
+     | None ->
+       Sexp.List [ Atom "inside_files_dir"; Atom "none" ]
+       |> Sexp.to_string
+       |> Dune_digest.string
+     | Some path -> Path_digest.digest_with_lstat path)
+  | Git_files (path_opt, rev) ->
+    let path_str =
+      match path_opt with
+      | None -> "None"
+      | Some p -> sprintf "Some %s" (Path.Local.to_string p)
+    in
+    Sexp.List
+      [ Atom "git_files"
+      ; Atom path_str
+      ; Atom (Rev_store.At_rev.rev rev |> Rev_store.Object.to_hex)
+      ]
+    |> Sexp.to_string
+    |> Dune_digest.string
+;;
+
+let digest res_pkg =
+  (* We are explicitly ignoring [loc] here because we don't need to take into
+     account the location of the opam file. *)
+  Sexp.record
+    [ "opam_file", Atom (OpamFile.OPAM.write_to_string (opam_file res_pkg))
+    ; ( "package"
+      , let opam_pkg = package res_pkg in
+        Sexp.record
+          [ "name", Atom (OpamPackage.name opam_pkg |> OpamPackage.Name.to_string)
+          ; "version", Atom (OpamPackage.version opam_pkg |> OpamPackage.Version.to_string)
+          ] )
+    ; "dune_build", Atom (dune_build res_pkg |> Bool.to_string)
+    ; ( "extra_files"
+      , Atom
+          (extra_files res_pkg
+           |> Option.map ~f:digest_extra_files
+           |> Dune_digest.Feed.compute_digest
+                (Dune_digest.Feed.option Dune_digest.Feed.digest)
+           |> Dune_digest.to_string) )
+    ]
+  |> Sexp.to_string
+  |> Dune_digest.string
+;;

src/dune_pkg/resolved_package.mli

@@ -35,3 +35,12 @@ val local_package
 val get_opam_package_files
   :  t list
   -> (File_entry.t list list, User_message.t) result Fiber.t
+
+(** [digest t] computes a digest of the resolved package contents, excluding the
+    source location. For directory-based extra files, the digest of the
+    directory contents is included. For git-based extra files, the commit SHA is
+    included.
+
+    Raises [User_error] if extra files in a directory cannot be accessed or
+    digested due to permission errors, filesystem errors. *)
+val digest : t -> Dune_digest.t

src/dune_rules/lock_action.ml

@@ -0,0 +1,198 @@
+open Import
+
+include struct
+  open Dune_pkg
+  module Solver_env = Solver_env
+  module Opam_repo = Opam_repo
+  module Local_package = Local_package
+  module Resolved_package = Resolved_package
+  module Version_preference = Version_preference
+  module Package_universe = Package_universe
+  module Package_dependency = Package_dependency
+  module Opam_solver = Opam_solver
+  module Sys_poll = Sys_poll
+end
+
+module Spec = struct
+  type ('path, 'target) t =
+    { target : 'target
+    ; lock_dir : 'path
+    ; packages : Local_package.t Package.Name.Map.t
+    ; repos : Opam_repo.t list
+    ; solver_env_from_context : Solver_env.t
+    ; unset_solver_vars : Package_variable_name.Set.t
+    ; constraints : Package_dependency.t list
+    ; selected_depopts : Package.Name.t list
+    ; pins : Resolved_package.t Package.Name.Map.t
+    ; version_preference : Version_preference.t
+    }
+
+  let name = "lock"
+  let version = 1
+  let bimap t f g = { t with lock_dir = f t.lock_dir; target = g t.target }
+  let is_useful_to ~memoize = memoize
+
+  let encode
+        { target
+        ; lock_dir
+        ; packages
+        ; repos
+        ; solver_env_from_context
+        ; unset_solver_vars
+        ; constraints
+        ; selected_depopts
+        ; pins
+        ; version_preference
+        }
+        encode_path
+        encode_target
+    =
+    Sexp.record
+      [ "target", encode_target target
+      ; "lock_dir", encode_path lock_dir
+      ; ( "packages"
+        , match Package_universe.dependency_digest packages with
+          | None -> Atom "no packages"
+          | Some hash ->
+            List [ Atom "hash"; Atom (Local_package.Dependency_hash.to_string hash) ] )
+      ; ( "repos"
+        , List
+            (List.map repos ~f:(fun repo ->
+               Sexp.Atom (Opam_repo.content_digest repo |> Dune_digest.to_string))) )
+      ; ( "solver_env_from_context"
+        , Atom
+            (Dune_digest.Feed.compute_digest
+               Solver_env.digest_feed
+               solver_env_from_context
+             |> Dune_digest.to_string) )
+      ; ( "unset_solver_vars"
+        , List
+            (Package_variable_name.Set.to_list unset_solver_vars
+             |> List.sort ~compare:Package_variable_name.compare
+             |> List.map ~f:(fun var -> Sexp.Atom (Package_variable_name.to_string var)))
+        )
+      ; ( "constraints"
+        , List
+            (List.sort constraints ~compare:(fun a b ->
+               Dune_lang.Package_name.compare
+                 a.Package_dependency.name
+                 b.Package_dependency.name)
+             |> List.map ~f:(fun { Package_dependency.name; constraint_ } ->
+               let name = Dune_lang.Package_name.to_string name in
+               let constraint_ =
+                 match constraint_ with
+                 | None -> "no constraints"
+                 | Some c -> Package_dependency.Constraint.to_dyn c |> Dyn.to_string
+               in
+               Sexp.List [ Sexp.Atom name; Sexp.Atom constraint_ ])) )
+      ; ( "selected_depopts"
+        , List
+            (List.sort selected_depopts ~compare:Dune_lang.Package_name.compare
+             |> List.map ~f:(fun pkg_name ->
+               Sexp.Atom (Dune_lang.Package_name.to_string pkg_name))) )
+      ; ( "pins"
+        , List
+            (Dune_lang.Package_name.Map.to_list pins
+             |> List.sort ~compare:(fun (a, _) (b, _) ->
+               Dune_lang.Package_name.compare a b)
+             |> List.map ~f:(fun (pkg_name, resolved_pkg) ->
+               let name = Dune_lang.Package_name.to_string pkg_name in
+               let digest =
+                 Resolved_package.digest resolved_pkg |> Dune_digest.to_string
+               in
+               Sexp.List [ Sexp.Atom name; Sexp.Atom digest ])) )
+      ; ( "version_preference"
+        , Atom
+            (match version_preference with
+             | Oldest -> "oldest"
+             | Newest -> "newest") )
+      ]
+  ;;
+
+  let action
+        { target
+        ; lock_dir = _
+        ; packages
+        ; repos
+        ; solver_env_from_context
+        ; unset_solver_vars
+        ; constraints
+        ; selected_depopts
+        ; pins
+        ; version_preference
+        }
+        ~ectx:_
+        ~eenv:{ Action.Ext.Exec.env; _ }
+    =
+    let open Fiber.O in
+    let* () = Fiber.return () in
+    let local_packages = Package.Name.Map.map packages ~f:Local_package.for_solver in
+    (* Whether or not the lock directory we are creating is portable or not
+       doesn't concern us. We therefore set it as non-portable. *)
+    let portable_lock_dir = false in
+    let* solver_env =
+      let open Fiber.O in
+      let+ solver_env_from_current_system =
+        Sys_poll.make ~path:(Env_path.path env) |> Sys_poll.solver_env_from_current_system
+      in
+      let solver_env =
+        [ solver_env_from_current_system; solver_env_from_context ]
+        |> List.fold_left ~init:Solver_env.with_defaults ~f:Solver_env.extend
+      in
+      Solver_env.unset_multi solver_env unset_solver_vars
+    in
+    let* solver_result =
+      Opam_solver.solve_lock_dir
+        solver_env
+        version_preference
+        repos
+        ~pins
+        ~local_packages
+        ~constraints
+        ~selected_depopts
+        ~portable_lock_dir
+    in
+    match solver_result with
+    | Error (`Manifest_error diagnostic) -> raise (User_error.E diagnostic)
+    | Error (`Solve_error diagnostic) -> User_error.raise [ diagnostic ]
+    | Ok { pinned_packages; files; lock_dir; _ } ->
+      let lock_dir_path = Path.build target in
+      let+ lock_dir =
+        Dune_pkg.Lock_dir.compute_missing_checksums ~pinned_packages lock_dir
+      in
+      Dune_pkg.Lock_dir.Write_disk.prepare
+        ~portable_lock_dir
+        ~lock_dir_path
+        ~files
+        lock_dir
+      |> Dune_pkg.Lock_dir.Write_disk.commit
+  ;;
+end
+
+module A = Action_ext.Make (Spec)
+
+let action
+      ~target
+      ~lock_dir
+      ~packages
+      ~repos
+      ~solver_env_from_context
+      ~unset_solver_vars
+      ~constraints
+      ~selected_depopts
+      ~pins
+      ~version_preference
+  =
+  A.action
+    { Spec.target
+    ; lock_dir
+    ; packages
+    ; repos
+    ; solver_env_from_context
+    ; unset_solver_vars
+    ; constraints
+    ; selected_depopts
+    ; pins
+    ; version_preference
+    }
+;;

src/dune_rules/lock_action.mli

@@ -0,0 +1,14 @@
+open Import
+
+val action
+  :  target:Path.Build.t
+  -> lock_dir:Path.t
+  -> packages:Dune_pkg.Local_package.t Package.Name.Map.t
+  -> repos:Dune_pkg.Opam_repo.t list
+  -> solver_env_from_context:Dune_pkg.Solver_env.t
+  -> unset_solver_vars:Package_variable_name.Set.t
+  -> constraints:Dune_pkg.Package_dependency.t list
+  -> selected_depopts:Dune_pkg.Package_name.t list
+  -> pins:Dune_pkg.Resolved_package.t Dune_lang.Package_name.Map.t
+  -> version_preference:Dune_pkg.Version_preference.t
+  -> Action.t