unikernel/duniverse/dune_/bin/pkg/validate_lock_dir.ml

@@ -0,0 +1,88 @@
+open! Import
+open Pkg_common
+module Package_universe = Dune_pkg.Package_universe
+module Lock_dir = Dune_pkg.Lock_dir
+module Opam_repo = Dune_pkg.Opam_repo
+module Package_version = Dune_pkg.Package_version
+module Opam_solver = Dune_pkg.Opam_solver
+
+let info =
+  let doc = "Validate that a lockdir contains a solution for local packages" in
+  let man = [ `S "DESCRIPTION"; `P doc ] in
+  Cmd.info "validate-lockdir" ~doc ~man
+;;
+
+(* CR-someday alizter: The logic here is a little more complicated than it needs
+   to be and can be simplified. *)
+
+let enumerate_lock_dirs_by_path ~lock_dirs () =
+  let open Memo.O in
+  let+ per_contexts =
+    Workspace.workspace () >>| Pkg_common.Lock_dirs_arg.lock_dirs_of_workspace lock_dirs
+  in
+  List.filter_map per_contexts ~f:(fun lock_dir_path ->
+    if Path.exists (Path.source lock_dir_path)
+    then (
+      try Some (Ok (lock_dir_path, Lock_dir.read_disk_exn lock_dir_path)) with
+      | User_error.E e -> Some (Error (lock_dir_path, `Parse_error e)))
+    else None)
+;;
+
+let validate_lock_dirs ~lock_dirs () =
+  let open Fiber.O in
+  let* lock_dirs_by_path, local_packages =
+    Memo.both (enumerate_lock_dirs_by_path ~lock_dirs ()) Pkg_common.find_local_packages
+    |> Memo.run
+  in
+  if List.is_empty lock_dirs_by_path
+  then
+    let+ () = Fiber.return () in
+    Console.print [ Pp.text "No lockdirs to validate." ]
+  else
+    let+ universes =
+      Fiber.parallel_map lock_dirs_by_path ~f:(function
+        | Error e -> Fiber.return (Some e)
+        | Ok (lock_dir_path, lock_dir) ->
+          let+ platform = solver_env_from_system_and_context ~lock_dir_path in
+          (match Package_universe.create ~platform local_packages lock_dir with
+           | Ok _ -> None
+           | Error e -> Some (lock_dir_path, `Lock_dir_out_of_sync e)))
+      >>| List.filter_opt
+    in
+    match universes with
+    | [] -> ()
+    | errors_by_path ->
+      List.iter errors_by_path ~f:(fun (path, error) ->
+        match error with
+        | `Parse_error error ->
+          User_message.prerr
+            (User_message.make
+               [ Pp.textf
+                   "Failed to parse lockdir %s:"
+                   (Path.Source.to_string_maybe_quoted path)
+               ; User_message.pp error
+               ])
+        | `Lock_dir_out_of_sync error ->
+          User_message.prerr
+            (User_message.make
+               [ Pp.textf
+                   "Lockdir %s does not contain a solution for local packages:"
+                   (Path.Source.to_string path)
+               ]);
+          User_message.prerr error);
+      User_error.raise
+        [ Pp.text "Some lockdirs do not contain solutions for local packages:"
+        ; Pp.enumerate errors_by_path ~f:(fun (path, _) ->
+            Pp.text (Path.Source.to_string path))
+        ]
+;;
+
+let term =
+  let+ builder = Common.Builder.term
+  and+ lock_dirs = Pkg_common.Lock_dirs_arg.term in
+  let builder = Common.Builder.forbid_builds builder in
+  let common, config = Common.init builder in
+  Scheduler.go_with_rpc_server ~common ~config @@ validate_lock_dirs ~lock_dirs
+;;
+
+let command = Cmd.v info term