1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
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
|
