anil.recoil.org
My aggregated monorepo of OCaml code, automaintained
Merge commit 'd4a0dcdd73fdb305e519aaa33b39f21271164f24'
+16
-4
monopam/bin/main.ml
+16
-4
monopam/bin/main.ml
···
144
`P "For each unique repository:";
145
`I ("1.", "Splits the subtree commits from the monorepo");
146
`I ("2.", "Fast-forward merges the split commits into the checkout");
147
`P
148
-
"After running push, you can review the changes in each checkout and \
149
manually push them to the git remotes.";
150
`P "The operation will fail if any checkout has uncommitted changes.";
151
]
152
in
153
let info = Cmd.info "push" ~doc ~man in
154
-
let run config_file package () =
155
Eio_main.run @@ fun env ->
156
with_config env config_file @@ fun config ->
157
let fs = Eio.Stdenv.fs env in
158
let proc = Eio.Stdenv.process_mgr env in
159
-
match Monopam.push ~proc ~fs ~config ?package () with
160
| Ok () ->
161
Fmt.pr "Push completed.@.";
162
`Ok ()
···
165
`Error (false, "push failed")
166
in
167
Cmd.v info
168
-
Term.(ret (const run $ config_file_arg $ package_arg $ logging_term))
169
170
(* Add command *)
171
···
144
`P "For each unique repository:";
145
`I ("1.", "Splits the subtree commits from the monorepo");
146
`I ("2.", "Fast-forward merges the split commits into the checkout");
147
+
`I
148
+
( "3.",
149
+
"If --upstream is specified, pushes each checkout to its git remote"
150
+
);
151
`P
152
+
"Without --upstream, you can review the changes in each checkout and \
153
manually push them to the git remotes.";
154
`P "The operation will fail if any checkout has uncommitted changes.";
155
]
156
in
157
let info = Cmd.info "push" ~doc ~man in
158
+
let upstream_arg =
159
+
let doc =
160
+
"Also push each checkout to its upstream git remote after extracting \
161
+
changes."
162
+
in
163
+
Arg.(value & flag & info [ "upstream" ] ~doc)
164
+
in
165
+
let run config_file package upstream () =
166
Eio_main.run @@ fun env ->
167
with_config env config_file @@ fun config ->
168
let fs = Eio.Stdenv.fs env in
169
let proc = Eio.Stdenv.process_mgr env in
170
+
match Monopam.push ~proc ~fs ~config ?package ~upstream () with
171
| Ok () ->
172
Fmt.pr "Push completed.@.";
173
`Ok ()
···
176
`Error (false, "push failed")
177
in
178
Cmd.v info
179
+
Term.(
180
+
ret (const run $ config_file_arg $ package_arg $ upstream_arg $ logging_term))
181
182
(* Add command *)
183
+9
monopam/lib/git.ml
+9
monopam/lib/git.ml
···
181
let cwd = path_to_eio ~fs path in
182
run_git_ok ~proc ~cwd [ "commit"; "--allow-empty"; "-m"; message ]
183
|> Result.map ignore
184
+
185
+
let push_remote ~proc ~fs ?(remote = "origin") ?branch path =
186
+
let cwd = path_to_eio ~fs path in
187
+
let branch =
188
+
match branch with
189
+
| Some b -> b
190
+
| None -> Option.value ~default:"main" (current_branch ~proc ~fs path)
191
+
in
192
+
run_git_ok ~proc ~cwd [ "push"; remote; branch ] |> Result.map ignore
+13
monopam/lib/git.mli
+13
monopam/lib/git.mli
···
225
(unit, error) result
226
(** [commit_allow_empty ~proc ~fs ~message path] creates a commit, even if there
227
are no changes. Useful for initializing a repository. *)
228
+
229
+
val push_remote :
230
+
proc:_ Eio.Process.mgr ->
231
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
232
+
?remote:string ->
233
+
?branch:string ->
234
+
Fpath.t ->
235
+
(unit, error) result
236
+
(** [push_remote ~proc ~fs ?remote ?branch path] pushes the current branch to
237
+
the remote.
238
+
239
+
@param remote Remote name (default: "origin")
240
+
@param branch Branch to push (default: current branch) *)
+35
-5
monopam/lib/monopam.ml
+35
-5
monopam/lib/monopam.ml
···
710
Ok ()
711
end
712
713
-
let push ~proc ~fs ~config ?package () =
714
let fs_t = fs_typed fs in
715
(* Ensure checkouts directory exists before computing status *)
716
ensure_checkouts_dir ~fs:fs_t ~config;
···
737
let repos = unique_repos pkgs in
738
Log.info (fun m -> m "Pushing %d unique repos" (List.length repos));
739
let total = List.length repos in
740
-
let rec loop i = function
741
-
| [] -> Ok ()
742
| pkg :: rest -> (
743
Log.info (fun m ->
744
m "[%d/%d] Processing %s" i total
745
(Package.subtree_prefix pkg));
746
match push_one ~proc ~fs ~config pkg with
747
-
| Ok () -> loop (i + 1) rest
748
| Error e -> Error e)
749
in
750
-
loop 1 repos
751
end
752
end
753
···
710
Ok ()
711
end
712
713
+
let push ~proc ~fs ~config ?package ?(upstream = false) () =
714
let fs_t = fs_typed fs in
715
(* Ensure checkouts directory exists before computing status *)
716
ensure_checkouts_dir ~fs:fs_t ~config;
···
737
let repos = unique_repos pkgs in
738
Log.info (fun m -> m "Pushing %d unique repos" (List.length repos));
739
let total = List.length repos in
740
+
let rec loop i pushed_repos = function
741
+
| [] -> Ok (List.rev pushed_repos)
742
| pkg :: rest -> (
743
Log.info (fun m ->
744
m "[%d/%d] Processing %s" i total
745
(Package.subtree_prefix pkg));
746
match push_one ~proc ~fs ~config pkg with
747
+
| Ok () -> loop (i + 1) (pkg :: pushed_repos) rest
748
| Error e -> Error e)
749
in
750
+
match loop 1 [] repos with
751
+
| Error e -> Error e
752
+
| Ok pushed_repos ->
753
+
if upstream && pushed_repos <> [] then begin
754
+
Log.info (fun m ->
755
+
m "Pushing %d repos to upstream" (List.length pushed_repos));
756
+
let checkouts_root = Config.Paths.checkouts config in
757
+
let total = List.length pushed_repos in
758
+
let rec push_upstream i = function
759
+
| [] -> Ok ()
760
+
| pkg :: rest -> (
761
+
let checkout_dir =
762
+
Package.checkout_dir ~checkouts_root pkg
763
+
in
764
+
let branch = get_branch ~config pkg in
765
+
Log.info (fun m ->
766
+
m "[%d/%d] Pushing %s to origin" i total
767
+
(Package.repo_name pkg));
768
+
match
769
+
Git.push_remote ~proc ~fs:fs_t ~branch checkout_dir
770
+
with
771
+
| Ok () ->
772
+
Log.app (fun m ->
773
+
m " Pushed %s to origin/%s" (Package.repo_name pkg)
774
+
branch);
775
+
push_upstream (i + 1) rest
776
+
| Error e -> Error (Git_error e))
777
+
in
778
+
push_upstream 1 pushed_repos
779
+
end
780
+
else Ok ()
781
end
782
end
783
+9
-5
monopam/lib/monopam.mli
+9
-5
monopam/lib/monopam.mli
···
85
fs:Eio.Fs.dir_ty Eio.Path.t ->
86
config:Config.t ->
87
?package:string ->
88
unit ->
89
(unit, error) result
90
-
(** [push ~proc ~fs ~config ?package ()] pushes changes from monorepo to
91
-
checkouts.
92
93
For each package (or the specified package) with changes in the monorepo: 1.
94
-
Splits the subtree commits 2. Pushes to the individual checkout
95
96
-
The user must manually push from checkouts to remotes.
97
98
Aborts if any checkout has uncommitted changes.
99
100
@param proc Eio process manager
101
@param fs Eio filesystem
102
@param config Monopam configuration
103
-
@param package Optional specific package to push *)
104
105
(** {2 Package Management} *)
106
···
85
fs:Eio.Fs.dir_ty Eio.Path.t ->
86
config:Config.t ->
87
?package:string ->
88
+
?upstream:bool ->
89
unit ->
90
(unit, error) result
91
+
(** [push ~proc ~fs ~config ?package ?upstream ()] pushes changes from monorepo
92
+
to checkouts.
93
94
For each package (or the specified package) with changes in the monorepo: 1.
95
+
Splits the subtree commits 2. Pushes to the individual checkout 3. If
96
+
[~upstream:true], also pushes each checkout to its git remote
97
98
+
If [~upstream] is false (the default), the user must manually push from
99
+
checkouts to remotes.
100
101
Aborts if any checkout has uncommitted changes.
102
103
@param proc Eio process manager
104
@param fs Eio filesystem
105
@param config Monopam configuration
106
+
@param package Optional specific package to push
107
+
@param upstream If true, also push checkouts to their git remotes *)
108
109
(** {2 Package Management} *)
110