forked from
anil.recoil.org/monopam
Monorepo management for opam overlays
Smart local checkout push: force only when checkout is a subset
Local checkout push: try normal push first. If rejected, check if the
checkout's tip tree appears in the split chain (tree containment).
If yes, the split is a strict superset — safe to auto-force. If no,
the checkout has content not in the monorepo — refuse and suggest
pulling into the monorepo first.
This handles: split algorithm changes, filter-repo rewrites, and
concurrent monorepo instances without silently overwriting work.
+44
-8
+44
-8
lib/push.ml
+44
-8
lib/push.ml
···
18
18
| Ok (Git.Value.Commit c) -> Some (Git.Commit.tree c)
19
19
| _ -> None)
20
20
21
-
let split_and_push ~proc ~fs ~monorepo ~git_repo ~prefix ~checkout_url ~clean
22
-
~force:_ ~branch =
21
+
(** Check if [target_tree] appears in the commit ancestry of [head]. *)
22
+
let tree_in_history repo head target_tree =
23
+
let visited = Hashtbl.create 64 in
24
+
let queue = Queue.create () in
25
+
Queue.push head queue;
26
+
let found = ref false in
27
+
while (not (Queue.is_empty queue)) && not !found do
28
+
let h = Queue.pop queue in
29
+
if not (Hashtbl.mem visited h) then begin
30
+
Hashtbl.replace visited h ();
31
+
match Git.Repository.read repo h with
32
+
| Ok (Git.Value.Commit c) ->
33
+
if Git.Hash.equal (Git.Commit.tree c) target_tree then found := true
34
+
else List.iter (fun p -> Queue.push p queue) (Git.Commit.parents c)
35
+
| _ -> ()
36
+
end
37
+
done;
38
+
!found
39
+
40
+
let split_and_push ~proc ~fs ~monorepo ~git_repo ~prefix ~checkout_url
41
+
~checkout_tree ~clean ~force ~branch =
23
42
match Git.Repository.read_ref git_repo "HEAD" with
24
43
| None -> Error (Ctx.Git_error (Git_cli.Io_error "no HEAD ref found"))
25
44
| Some head -> (
···
39
58
split_hash)
40
59
else split_hash
41
60
in
42
-
(* Always force-push to local checkouts. They are derived caches,
43
-
not independent repos. The --force CLI flag controls upstream
44
-
remote pushes, not local checkout updates. *)
45
61
let refspec = Git.Hash.to_hex final_hash ^ ":refs/heads/" ^ branch in
46
62
match
47
63
Git_cli.push_refspec ~proc ~fs ~repo:monorepo ~url:checkout_url
48
-
~refspec ~force:true ()
64
+
~refspec ~force:false ()
49
65
with
50
66
| Ok () -> Ok ()
67
+
| Error (Git_cli.Command_failed _ as _e) when not force -> (
68
+
(* Push rejected. Check if the checkout's tree is in our split
69
+
chain — if so, we're a strict superset and can safely force.
70
+
If not, someone else pushed different content. *)
71
+
match checkout_tree with
72
+
| Some ct when tree_in_history git_repo final_hash ct ->
73
+
Log.debug (fun m ->
74
+
m "Checkout tree is in split chain, forcing local push");
75
+
Git_cli.push_refspec ~proc ~fs ~repo:monorepo
76
+
~url:checkout_url ~refspec ~force:true ()
77
+
|> Result.map_error (fun e -> Ctx.Git_error e)
78
+
| _ ->
79
+
Error
80
+
(Ctx.Git_error
81
+
(Git_cli.Io_error
82
+
(Fmt.str
83
+
"%s: checkout has content not in monorepo. Use \
84
+
--force to overwrite, or pull first."
85
+
prefix))))
51
86
| Error e -> Error (Ctx.Git_error e)))
52
87
53
88
(** Resolve the fetch URL for a package: sources.toml entry > dev-repo fallback.
···
132
167
Git_cli.clean_untracked ~proc ~fs:(fs :> _ Eio.Path.t) checkout_dir
133
168
in
134
169
split_and_push ~proc ~fs ~monorepo ~git_repo ~prefix ~checkout_url
135
-
~clean ~force ~branch
170
+
~checkout_tree ~clean ~force ~branch
136
171
|> Result.map (fun () -> Pushed)
137
172
end
138
173
end
···
338
373
| Error e ->
339
374
Log.warn (fun m -> m "Failed to configure %s: %a" name Git_cli.pp_error e));
340
375
let checkout_url = Fpath.to_string checkout_dir in
376
+
let checkout_tree = checkout_tree_hash ~fs:fs_t checkout_dir in
341
377
match
342
378
split_and_push ~proc ~fs:fs_t ~monorepo ~git_repo ~prefix ~checkout_url
343
-
~clean ~force ~branch
379
+
~checkout_tree ~clean ~force ~branch
344
380
with
345
381
| Ok () -> Log.info (fun m -> m "Pushed mono inner subtree %s" prefix)
346
382
| Error e ->