forked from
anil.recoil.org/monopam
Monorepo management for opam overlays
Merge 'monopam/' from /Users/samoht/git/blacksun/src/monopam git-subtree-mainline: a0bce624a0d032ee4ef35695bb4e7052d3bce1cc
+2380
-3937
+1
-2
bin/dune
+1
-2
bin/dune
+311
-529
bin/main.ml
+311
-529
bin/main.ml
···
87
87
let doc = "Show all repos including those not in your workspace." in
88
88
Arg.(value & flag & info [ "all"; "a" ] ~doc)
89
89
in
90
-
let forks_arg =
91
-
let doc = "Include fork analysis from verse members (slower)." in
92
-
Arg.(value & flag & info [ "forks"; "f" ] ~doc)
93
-
in
94
-
(* Helper: abbreviate handle to first part before dot, max 4 chars *)
95
-
let abbrev_handle h =
96
-
match String.split_on_char '.' h with
97
-
| first :: _ ->
98
-
if String.length first <= 4 then first else String.sub first 0 3
99
-
| [] -> h
100
-
in
101
-
(* Helper: load sources.toml *)
102
-
let load_sources ~fs ~config =
103
-
let sources_path =
104
-
Fpath.(Monopam.Config.Paths.monorepo config / "sources.toml")
105
-
in
106
-
match
107
-
Monopam.Sources_registry.load ~fs:(fs :> _ Eio.Path.t) sources_path
108
-
with
109
-
| Ok s -> Some s
110
-
| Error _ -> None
111
-
in
112
-
(* Helper: print unregistered opam files if any *)
113
-
let print_unregistered ~fs ~config pkgs =
114
-
let unregistered = Monopam.find_unregistered_opam_files ~fs ~config pkgs in
115
-
if unregistered <> [] then begin
116
-
let handle_abbrev =
117
-
match Monopam.Verse_config.load ~fs () with
118
-
| Ok vc -> abbrev_handle (Monopam.Verse_config.handle vc)
119
-
| Error _ -> "local"
120
-
in
121
-
Fmt.pr "%a %a\n"
122
-
Fmt.(styled `Bold string)
123
-
"Unregistered:"
124
-
Fmt.(styled `Faint int)
125
-
(List.length unregistered);
126
-
List.iter
127
-
(fun (_r, p) ->
128
-
Fmt.pr " %-22s %a\n" p
129
-
Fmt.(styled `Faint (fun ppf s -> pf ppf "%s~" s))
130
-
handle_abbrev)
131
-
unregistered
132
-
end
133
-
in
134
-
(* Helper: run fork analysis if requested *)
135
-
let print_forks ~proc ~fs ~config ~show_all =
136
-
match Monopam.Verse_config.load ~fs () with
137
-
| Error _ -> ()
138
-
| Ok verse_config ->
139
-
let forks =
140
-
Monopam.Forks.compute ~proc ~fs ~verse_config ~monopam_config:config
141
-
()
142
-
in
143
-
if forks.repos <> [] then
144
-
Fmt.pr "%a" (Monopam.Forks.pp_summary' ~show_all) forks
145
-
in
146
-
let run show_all show_forks () =
90
+
let run show_all () =
147
91
Eio_main.run @@ fun env ->
148
92
with_config env @@ fun config ->
149
93
let fs = Eio.Stdenv.fs env in
150
94
let proc = Eio.Stdenv.process_mgr env in
151
95
match Monopam.status ~proc ~fs ~config () with
152
96
| Ok statuses ->
153
-
let sources = load_sources ~fs ~config in
97
+
(* Load sources.toml for origin indicators *)
98
+
let sources =
99
+
let mono_path = Monopam.Config.Paths.monorepo config in
100
+
let sources_path = Fpath.(mono_path / "sources.toml") in
101
+
match Monopam.Sources_registry.load ~fs:(fs :> _ Eio.Path.t) sources_path with
102
+
| Ok s -> Some s
103
+
| Error _ -> None
104
+
in
154
105
Fmt.pr "%a" (Monopam.Status.pp_summary ?sources) statuses;
106
+
(* Check for unregistered opam files *)
155
107
(match Monopam.discover_packages ~fs ~config () with
156
-
| Ok pkgs -> print_unregistered ~fs ~config pkgs
108
+
| Ok pkgs ->
109
+
let unregistered =
110
+
Monopam.find_unregistered_opam_files ~fs ~config pkgs
111
+
in
112
+
if unregistered <> [] then begin
113
+
(* Get local handle abbreviation *)
114
+
let handle_abbrev =
115
+
match Monopam.Verse_config.load ~fs () with
116
+
| Ok vc -> (
117
+
let h = Monopam.Verse_config.handle vc in
118
+
match String.split_on_char '.' h with
119
+
| first :: _ ->
120
+
if String.length first <= 4 then first
121
+
else String.sub first 0 3
122
+
| [] -> h)
123
+
| Error _ -> "local"
124
+
in
125
+
Fmt.pr "%a %a\n"
126
+
Fmt.(styled `Bold string)
127
+
"Unregistered:"
128
+
Fmt.(styled `Faint int)
129
+
(List.length unregistered);
130
+
List.iter
131
+
(fun (_r, p) ->
132
+
Fmt.pr " %-22s %a\n" p
133
+
Fmt.(styled `Faint (fun ppf s -> pf ppf "%s~" s))
134
+
handle_abbrev)
135
+
unregistered
136
+
end
157
137
| Error _ -> ());
158
-
if show_forks then print_forks ~proc ~fs ~config ~show_all;
138
+
(* Fork analysis *)
139
+
(match Monopam.Verse_config.load ~fs () with
140
+
| Error _ -> ()
141
+
| Ok verse_config ->
142
+
let forks =
143
+
Monopam.Forks.compute ~proc ~fs ~verse_config
144
+
~monopam_config:config ()
145
+
in
146
+
if forks.repos <> [] then
147
+
Fmt.pr "%a" (Monopam.Forks.pp_summary' ~show_all) forks);
159
148
`Ok ()
160
149
| Error e ->
161
150
Fmt.epr "Error: %a@." Monopam.pp_error_with_hint e;
162
151
`Error (false, "status failed")
163
152
in
164
-
Cmd.v info Term.(ret (const run $ all_arg $ forks_arg $ logging_term))
153
+
Cmd.v info Term.(ret (const run $ all_arg $ logging_term))
165
154
166
155
(* Sync command *)
167
156
···
237
226
in
238
227
let run package remote skip_push skip_pull () =
239
228
Eio_main.run @@ fun env ->
240
-
Eio.Switch.run @@ fun sw ->
241
229
with_config env @@ fun config ->
242
230
let fs = Eio.Stdenv.fs env in
243
231
let proc = Eio.Stdenv.process_mgr env in
244
-
let xdg = Xdge.create fs "monopam" in
245
232
match
246
-
Monopam.sync ~sw ~env ~proc ~fs ~config ~xdg ?package ~remote ~skip_push
247
-
~skip_pull ()
233
+
Monopam.sync ~proc ~fs ~config ?package ~remote ~skip_push ~skip_pull ()
248
234
with
249
235
| Ok summary ->
250
236
if summary.errors = [] then `Ok ()
···
461
447
[
462
448
`S Manpage.s_description;
463
449
`P
464
-
"Creates a new monopam workspace for monorepo development. The \
465
-
workspace lets you manage your own monorepo and optionally browse and \
466
-
track other developers' monorepos.";
450
+
"Creates a new monopam workspace for monorepo development. The workspace \
451
+
lets you manage your own monorepo and optionally browse and track other \
452
+
developers' monorepos.";
467
453
`S "WORKSPACE STRUCTURE";
468
454
`P
469
455
"The init command creates the following directory structure at the \
···
490
476
handle = \"yourname.bsky.social\"";
491
477
`S "HANDLE VALIDATION";
492
478
`P
493
-
"The handle you provide identifies you in the community. It should be \
494
-
a valid domain name (e.g., yourname.bsky.social or your-domain.com).";
479
+
"The handle you provide identifies you in the community. \
480
+
It should be a valid domain name (e.g., yourname.bsky.social or \
481
+
your-domain.com).";
495
482
`S "REGISTRY";
496
483
`P
497
484
"The registry is a git repository containing an opamverse.toml file \
···
602
589
[
603
590
`S Manpage.s_description;
604
591
`P
605
-
"Fork a package from a verse member's opam repository into your \
606
-
workspace. This creates entries in your opam-repo with your fork URL \
607
-
as the dev-repo.";
592
+
"Fork a package from a verse member's opam repository into your workspace. \
593
+
This creates entries in your opam-repo with your fork URL as the dev-repo.";
608
594
`P
609
-
"The command finds all packages sharing the same git repository and \
610
-
forks them together. For example, if you fork 'cohttp', it will also \
611
-
fork cohttp-eio, cohttp-lwt, etc.";
595
+
"The command finds all packages sharing the same git repository and forks \
596
+
them together. For example, if you fork 'cohttp', it will also fork \
597
+
cohttp-eio, cohttp-lwt, etc.";
612
598
`S "WHAT IT DOES";
613
599
`P "For the specified package:";
614
-
`I
615
-
( "1.",
616
-
"Looks up the package in <handle>'s opam-repo (verse/<handle>-opam/)"
617
-
);
600
+
`I ("1.", "Looks up the package in <handle>'s opam-repo (verse/<handle>-opam/)");
618
601
`I ("2.", "Finds all packages from the same git repository");
619
602
`I ("3.", "Creates entries in your opam-repo with your fork URL");
620
603
`P "After forking:";
621
-
`I
622
-
( "1.",
623
-
"Commit the new opam files: $(b,cd opam-repo && git add -A && git \
624
-
commit)" );
604
+
`I ("1.", "Commit the new opam files: $(b,cd opam-repo && git add -A && git commit)");
625
605
`I ("2.", "Run $(b,monopam sync) to pull the fork into your monorepo");
626
606
`S "PREREQUISITES";
627
607
`P "Before forking:";
628
-
`I
629
-
( "-",
630
-
"Run $(b,monopam verse pull <handle>) to sync the member's opam-repo"
631
-
);
608
+
`I ("-", "Run $(b,monopam verse pull <handle>) to sync the member's opam-repo");
632
609
`I ("-", "Create a fork of the repository on GitHub/GitLab/etc.");
633
610
`S Manpage.s_examples;
634
611
`P "Fork a package from a verse member:";
635
-
`Pre
636
-
"monopam fork http2 --from sadiq.bsky.social --url \
637
-
git@github.com:me/http2.git";
612
+
`Pre "monopam fork http2 --from sadiq.bsky.social --url git@github.com:me/http2.git";
638
613
`P "Preview what would be forked (multi-package repos):";
639
-
`Pre
640
-
"monopam fork cohttp --from avsm.bsky.social --url \
641
-
git@github.com:me/cohttp.git --dry-run\n\
642
-
Would fork 5 packages from cohttp repository:\n\
643
-
\ cohttp\n\
644
-
\ cohttp-eio\n\
645
-
\ cohttp-lwt\n\
646
-
\ cohttp-async\n\
647
-
\ cohttp-mirage";
614
+
`Pre "monopam fork cohttp --from avsm.bsky.social --url git@github.com:me/cohttp.git --dry-run\n\
615
+
Would fork 5 packages from cohttp repository:\n\
616
+
\ cohttp\n\
617
+
\ cohttp-eio\n\
618
+
\ cohttp-lwt\n\
619
+
\ cohttp-async\n\
620
+
\ cohttp-mirage";
648
621
`P "After forking, commit and sync:";
649
-
`Pre
650
-
"cd opam-repo && git add -A && git commit -m \"Fork cohttp\"\n\
651
-
monopam sync";
622
+
`Pre "cd opam-repo && git add -A && git commit -m \"Fork cohttp\"\n\
623
+
monopam sync";
652
624
`S "ERRORS";
653
625
`P
654
-
"The command will fail if any package from the source repo already \
655
-
exists in your opam-repo. Remove conflicting packages first with:";
626
+
"The command will fail if any package from the source repo already exists \
627
+
in your opam-repo. Remove conflicting packages first with:";
656
628
`Pre "rm -rf opam-repo/packages/<package-name>";
657
629
]
658
630
in
···
663
635
in
664
636
let from_arg =
665
637
let doc = "Verse member handle to fork from (e.g., 'avsm.bsky.social')" in
666
-
Arg.(
667
-
required & opt (some string) None & info [ "from" ] ~docv:"HANDLE" ~doc)
638
+
Arg.(required & opt (some string) None & info [ "from" ] ~docv:"HANDLE" ~doc)
668
639
in
669
640
let url_arg =
670
641
let doc = "Git URL of your fork (e.g., 'git@github.com:you/repo.git')" in
···
679
650
with_verse_config env @@ fun config ->
680
651
let fs = Eio.Stdenv.fs env in
681
652
let proc = Eio.Stdenv.process_mgr env in
682
-
match
683
-
Monopam.Verse.fork ~proc ~fs ~config ~handle ~package ~fork_url ~dry_run
684
-
()
685
-
with
653
+
match Monopam.Verse.fork ~proc ~fs ~config ~handle ~package ~fork_url ~dry_run () with
686
654
| Ok result ->
687
655
if dry_run then begin
688
656
Fmt.pr "Would fork %d package(s) from %s:@."
689
-
(List.length result.packages_forked)
690
-
result.source_handle;
657
+
(List.length result.packages_forked) result.source_handle;
691
658
List.iter (fun p -> Fmt.pr " %s@." p) result.packages_forked
692
-
end
693
-
else begin
659
+
end else begin
694
660
(* Update sources.toml with fork information *)
695
661
let mono_path = Monopam.Verse_config.mono_path config in
696
662
let sources_path = Fpath.(mono_path / "sources.toml") in
697
663
let sources =
698
-
match
699
-
Monopam.Sources_registry.load
700
-
~fs:(fs :> _ Eio.Path.t)
701
-
sources_path
702
-
with
664
+
match Monopam.Sources_registry.load ~fs:(fs :> _ Eio.Path.t) sources_path with
703
665
| Ok s -> s
704
666
| Error _ -> Monopam.Sources_registry.empty
705
667
in
706
-
let entry =
707
-
Monopam.Sources_registry.
708
-
{
709
-
url = result.fork_url;
710
-
upstream = Some result.upstream_url;
711
-
branch = None;
712
-
reason = Some (Fmt.str "Forked from %s" result.source_handle);
713
-
origin = Some Join;
714
-
(* Forked from verse = joined *)
715
-
}
716
-
in
717
-
let sources =
718
-
Monopam.Sources_registry.add sources ~subtree:result.subtree_name
719
-
entry
720
-
in
721
-
(match
722
-
Monopam.Sources_registry.save
723
-
~fs:(fs :> _ Eio.Path.t)
724
-
sources_path sources
725
-
with
668
+
let entry = Monopam.Sources_registry.{
669
+
url = result.fork_url;
670
+
upstream = Some result.upstream_url;
671
+
branch = None;
672
+
reason = Some (Fmt.str "Forked from %s" result.source_handle);
673
+
origin = Some Join; (* Forked from verse = joined *)
674
+
} in
675
+
let sources = Monopam.Sources_registry.add sources ~subtree:result.subtree_name entry in
676
+
(match Monopam.Sources_registry.save ~fs:(fs :> _ Eio.Path.t) sources_path sources with
726
677
| Ok () ->
727
-
Fmt.pr "Updated sources.toml with fork entry for %s@."
728
-
result.subtree_name
678
+
Fmt.pr "Updated sources.toml with fork entry for %s@." result.subtree_name
729
679
| Error msg ->
730
680
Fmt.epr "Warning: Failed to update sources.toml: %s@." msg);
731
681
Fmt.pr "Forked %d package(s): %a@."
732
682
(List.length result.packages_forked)
733
-
Fmt.(list ~sep:(any ", ") string)
734
-
result.packages_forked;
683
+
Fmt.(list ~sep:(any ", ") string) result.packages_forked;
735
684
Fmt.pr "@.Next steps:@.";
736
-
Fmt.pr
737
-
" 1. cd opam-repo && git add -A && git commit -m \"Fork ...\"@.";
685
+
Fmt.pr " 1. cd opam-repo && git add -A && git commit -m \"Fork ...\"@.";
738
686
Fmt.pr " 2. monopam sync@."
739
687
end;
740
688
`Ok ()
···
742
690
Fmt.epr "Error: %a@." Monopam.Verse.pp_error_with_hint e;
743
691
`Error (false, "fork failed")
744
692
in
745
-
Cmd.v info
746
-
Term.(
747
-
ret
748
-
(const run $ package_arg $ from_arg $ url_arg $ dry_run_arg
749
-
$ logging_term))
693
+
Cmd.v info Term.(ret (const run $ package_arg $ from_arg $ url_arg $ dry_run_arg $ logging_term))
750
694
751
695
let verse_cmd =
752
696
let doc = "Verse member operations" in
···
755
699
`S Manpage.s_description;
756
700
`P
757
701
"Commands for working with verse community members. The verse system \
758
-
enables federated collaboration across multiple developers' \
759
-
monorepos.";
702
+
enables federated collaboration across multiple developers' monorepos.";
760
703
`P
761
704
"Members are identified by handles - typically domain names like \
762
705
'yourname.bsky.social' or 'your-domain.com'.";
763
706
`S "NOTE";
764
707
`P
765
-
"The $(b,monopam init) command creates your workspace and $(b,monopam \
766
-
sync) automatically syncs verse members. These commands are for \
767
-
additional verse-specific operations.";
708
+
"The $(b,monopam init) command creates your workspace and \
709
+
$(b,monopam sync) automatically syncs verse members. These commands \
710
+
are for additional verse-specific operations.";
768
711
`S "COMMANDS";
769
712
`I ("members", "List all members in the community registry");
770
-
`I
771
-
( "fork <pkg> --from <handle> --url <url>",
772
-
"Fork a package from a verse member" );
713
+
`I ("fork <pkg> --from <handle> --url <url>", "Fork a package from a verse member");
773
714
`S Manpage.s_examples;
774
715
`P "List all community members:";
775
716
`Pre "monopam verse members";
776
717
`P "Fork a package from another member:";
777
-
`Pre
778
-
"monopam verse fork cohttp --from avsm.bsky.social --url \
779
-
git@github.com:me/cohttp.git";
718
+
`Pre "monopam verse fork cohttp --from avsm.bsky.social --url git@github.com:me/cohttp.git";
780
719
]
781
720
in
782
721
let info = Cmd.info "verse" ~doc ~man in
783
-
Cmd.group info [ verse_members_cmd; verse_fork_cmd ]
722
+
Cmd.group info
723
+
[
724
+
verse_members_cmd;
725
+
verse_fork_cmd;
726
+
]
784
727
785
728
(* Diff command *)
786
729
···
790
733
[
791
734
`S Manpage.s_description;
792
735
`P
793
-
"Shows commit diffs from verse members for repositories where they \
794
-
have commits you don't have. This helps you see what changes are \
795
-
available from collaborators.";
736
+
"Shows commit diffs from verse members for repositories where they have \
737
+
commits you don't have. This helps you see what changes are available \
738
+
from collaborators.";
796
739
`S "OUTPUT";
797
-
`P
798
-
"First shows the verse status summary, then for each repository where \
799
-
a verse member is ahead:";
740
+
`P "First shows the verse status summary, then for each repository where \
741
+
a verse member is ahead:";
800
742
`I ("Repository name", "With the handle and relationship");
801
743
`I ("Commits", "List of commits they have that you don't (max 20)");
802
744
`S "RELATIONSHIPS";
803
745
`I ("+N", "They have N commits you don't have");
804
746
`I ("+N/-M", "Diverged: they have N new commits, you have M new commits");
805
747
`S "CACHING";
806
-
`P
807
-
"Remote fetches are cached for 1 hour to improve performance. Use \
808
-
$(b,--refresh) to force fresh fetches from all remotes.";
748
+
`P "Remote fetches are cached for 1 hour to improve performance. \
749
+
Use $(b,--refresh) to force fresh fetches from all remotes.";
809
750
`S Manpage.s_examples;
810
751
`P "Show diffs for all repos needing attention (uses cache):";
811
752
`Pre "monopam diff";
···
821
762
in
822
763
let info = Cmd.info "diff" ~doc ~man in
823
764
let arg =
824
-
let doc =
825
-
"Repository name or commit SHA. If a 7+ character hex string, shows the \
826
-
patch for that commit. Otherwise filters to that repository. If not \
827
-
specified, shows diffs for all repos needing attention."
828
-
in
765
+
let doc = "Repository name or commit SHA. If a 7+ character hex string, shows \
766
+
the patch for that commit. Otherwise filters to that repository. \
767
+
If not specified, shows diffs for all repos needing attention." in
829
768
Arg.(value & pos 0 (some string) None & info [] ~docv:"REPO|SHA" ~doc)
830
769
in
831
770
let refresh_arg =
832
-
let doc =
833
-
"Force fresh fetches from all remotes, ignoring the 1-hour cache."
834
-
in
771
+
let doc = "Force fresh fetches from all remotes, ignoring the 1-hour cache." in
835
772
Arg.(value & flag & info [ "refresh"; "r" ] ~doc)
836
773
in
837
774
let patch_arg =
···
846
783
let proc = Eio.Stdenv.process_mgr env in
847
784
(* Check if arg looks like a commit SHA *)
848
785
match arg with
849
-
| Some sha when Monopam.is_commit_sha sha -> (
786
+
| Some sha when Monopam.is_commit_sha sha ->
850
787
(* Show patch for specific commit *)
851
-
match
852
-
Monopam.diff_show_commit ~proc ~fs ~config ~verse_config ~sha ~refresh
853
-
()
854
-
with
788
+
(match Monopam.diff_show_commit ~proc ~fs ~config ~verse_config ~sha ~refresh () with
855
789
| Some info ->
856
-
let short_hash =
857
-
String.sub info.commit_hash 0
858
-
(min 7 (String.length info.commit_hash))
859
-
in
790
+
let short_hash = String.sub info.commit_hash 0 (min 7 (String.length info.commit_hash)) in
860
791
Fmt.pr "%a %s (%s/%s)@.@.%s@."
861
-
Fmt.(styled `Yellow string)
862
-
short_hash info.commit_subject info.commit_repo info.commit_handle
792
+
Fmt.(styled `Yellow string) short_hash
793
+
info.commit_subject
794
+
info.commit_repo info.commit_handle
863
795
info.commit_patch;
864
796
`Ok ()
865
797
| None ->
866
798
Fmt.epr "Commit %s not found in any verse diff@." sha;
867
799
`Error (false, "commit not found"))
868
800
| repo ->
869
-
let result =
870
-
Monopam.diff ~proc ~fs ~config ~verse_config ?repo ~refresh ~patch ()
871
-
in
801
+
let result = Monopam.diff ~proc ~fs ~config ~verse_config ?repo ~refresh ~patch () in
872
802
Fmt.pr "%a" (Monopam.pp_diff_result ~show_patch:patch) result;
873
803
`Ok ()
874
804
in
875
-
Cmd.v info
876
-
Term.(ret (const run $ arg $ refresh_arg $ patch_arg $ logging_term))
805
+
Cmd.v info Term.(ret (const run $ arg $ refresh_arg $ patch_arg $ logging_term))
877
806
878
807
(* Pull command - pull from verse members *)
879
808
···
893
822
`I ("3.", "$(b,monopam sync) - Sync changes into your monorepo");
894
823
`S "MERGING BEHAVIOR";
895
824
`P "When you're behind (they have commits you don't):";
896
-
`I
897
-
( "Fast-forward",
898
-
"If your branch has no new commits, a fast-forward merge is used." );
825
+
`I ("Fast-forward", "If your branch has no new commits, a fast-forward merge is used.");
899
826
`P "When branches have diverged (both have new commits):";
900
827
`I ("Merge commit", "A merge commit is created to combine the histories.");
901
828
`S Manpage.s_examples;
···
909
836
in
910
837
let info = Cmd.info "pull" ~doc ~man in
911
838
let handle_arg =
912
-
let doc =
913
-
"The verse member handle to pull from (e.g., avsm.bsky.social)."
914
-
in
839
+
let doc = "The verse member handle to pull from (e.g., avsm.bsky.social)." in
915
840
Arg.(required & pos 0 (some string) None & info [] ~docv:"HANDLE" ~doc)
916
841
in
917
842
let repo_arg =
918
-
let doc =
919
-
"Optional repository to pull from. If not specified, pulls from all \
920
-
repositories where the handle has commits you don't have."
921
-
in
843
+
let doc = "Optional repository to pull from. If not specified, pulls from all \
844
+
repositories where the handle has commits you don't have." in
922
845
Arg.(value & pos 1 (some string) None & info [] ~docv:"REPO" ~doc)
923
846
in
924
847
let refresh_arg =
925
-
let doc =
926
-
"Force fresh fetches from all remotes, ignoring the 1-hour cache."
927
-
in
848
+
let doc = "Force fresh fetches from all remotes, ignoring the 1-hour cache." in
928
849
Arg.(value & flag & info [ "refresh"; "r" ] ~doc)
929
850
in
930
851
let run handle repo refresh () =
···
933
854
with_verse_config env @@ fun verse_config ->
934
855
let fs = Eio.Stdenv.fs env in
935
856
let proc = Eio.Stdenv.process_mgr env in
936
-
match
937
-
Monopam.pull_from_handle ~proc ~fs ~config ~verse_config ~handle ?repo
938
-
~refresh ()
939
-
with
857
+
match Monopam.pull_from_handle ~proc ~fs ~config ~verse_config ~handle ?repo ~refresh () with
940
858
| Ok result ->
941
859
Fmt.pr "%a" Monopam.pp_handle_pull_result result;
942
860
if result.repos_failed <> [] then
···
946
864
`Ok ()
947
865
end
948
866
else begin
949
-
Fmt.pr
950
-
"@.Run $(b,monopam sync) to merge changes into your monorepo.@.";
867
+
Fmt.pr "@.Run $(b,monopam sync) to merge changes into your monorepo.@.";
951
868
`Ok ()
952
869
end
953
870
| Error e ->
954
871
Fmt.epr "Error: %a@." Monopam.pp_error_with_hint e;
955
872
`Error (false, "pull failed")
956
873
in
957
-
Cmd.v info
958
-
Term.(ret (const run $ handle_arg $ repo_arg $ refresh_arg $ logging_term))
874
+
Cmd.v info Term.(ret (const run $ handle_arg $ repo_arg $ refresh_arg $ logging_term))
959
875
960
876
(* Cherrypick command *)
961
877
···
965
881
[
966
882
`S Manpage.s_description;
967
883
`P
968
-
"Applies a specific commit from a verse member's fork to your local \
969
-
checkout. Use $(b,monopam diff) to see available commits and their \
970
-
hashes.";
884
+
"Applies a specific commit from a verse member's fork to your local checkout. \
885
+
Use $(b,monopam diff) to see available commits and their hashes.";
971
886
`S "WORKFLOW";
972
887
`P "The typical workflow for cherry-picking specific commits:";
973
888
`I ("1.", "$(b,monopam diff) - See available commits with their hashes");
···
984
899
in
985
900
let info = Cmd.info "cherrypick" ~doc ~man in
986
901
let sha_arg =
987
-
let doc =
988
-
"The commit SHA (or prefix) to cherry-pick. Must be at least 7 \
989
-
characters."
990
-
in
902
+
let doc = "The commit SHA (or prefix) to cherry-pick. Must be at least 7 characters." in
991
903
Arg.(required & pos 0 (some string) None & info [] ~docv:"SHA" ~doc)
992
904
in
993
905
let refresh_arg =
994
-
let doc =
995
-
"Force fresh fetches from all remotes, ignoring the 1-hour cache."
996
-
in
906
+
let doc = "Force fresh fetches from all remotes, ignoring the 1-hour cache." in
997
907
Arg.(value & flag & info [ "refresh"; "r" ] ~doc)
998
908
in
999
909
let run sha refresh () =
···
1002
912
with_verse_config env @@ fun verse_config ->
1003
913
let fs = Eio.Stdenv.fs env in
1004
914
let proc = Eio.Stdenv.process_mgr env in
1005
-
match
1006
-
Monopam.cherrypick ~proc ~fs ~config ~verse_config ~sha ~refresh ()
1007
-
with
915
+
match Monopam.cherrypick ~proc ~fs ~config ~verse_config ~sha ~refresh () with
1008
916
| Ok result ->
1009
917
Fmt.pr "%a" Monopam.pp_cherrypick_result result;
1010
918
Fmt.pr "Run $(b,monopam sync) to merge changes into your monorepo.@.";
···
1074
982
in
1075
983
let quiet_arg =
1076
984
let doc =
1077
-
"Quiet mode for cron jobs. Only output if issues are found. Exit code \
1078
-
reflects health status (0=healthy, 1=warning, 2=critical)."
985
+
"Quiet mode for cron jobs. Only output if issues are found. \
986
+
Exit code reflects health status (0=healthy, 1=warning, 2=critical)."
1079
987
in
1080
988
Arg.(value & flag & info [ "quiet"; "q" ] ~doc)
1081
989
in
1082
990
let run package json no_sync quiet () =
1083
991
Eio_main.run @@ fun env ->
1084
-
Eio.Switch.run @@ fun sw ->
1085
992
with_config env @@ fun config ->
1086
993
with_verse_config env @@ fun verse_config ->
1087
994
let fs = Eio.Stdenv.fs env in
1088
995
let proc = Eio.Stdenv.process_mgr env in
1089
996
let clock = Eio.Stdenv.clock env in
1090
-
let xdg = Xdge.create fs "monopam" in
1091
997
(* Run sync before analysis unless --no-sync is specified *)
1092
-
if (not no_sync) && not quiet then begin
998
+
if not no_sync && not quiet then begin
1093
999
Fmt.pr "Syncing workspace before analysis...@.";
1094
-
match Monopam.sync ~sw ~env ~proc ~fs ~config ~xdg ?package () with
1000
+
match Monopam.sync ~proc ~fs ~config ?package () with
1095
1001
| Ok _summary -> ()
1096
1002
| Error e ->
1097
1003
Fmt.pr "Warning: sync failed: %a@." Monopam.pp_error_with_hint e;
···
1099
1005
end
1100
1006
else if not no_sync then begin
1101
1007
(* Quiet mode but still sync - just don't print progress *)
1102
-
let _ = Monopam.sync ~sw ~env ~proc ~fs ~config ~xdg ?package () in
1103
-
()
1008
+
let _ = Monopam.sync ~proc ~fs ~config ?package () in ()
1104
1009
end;
1105
1010
let report =
1106
1011
Monopam.Doctor.analyze ~proc ~fs ~config ~verse_config ~clock ?package
···
1124
1029
end
1125
1030
in
1126
1031
Cmd.v info
1127
-
Term.(
1128
-
ret
1129
-
(const run $ package_arg $ json_arg $ no_sync_arg $ quiet_arg
1130
-
$ logging_term))
1032
+
Term.(ret (const run $ package_arg $ json_arg $ no_sync_arg $ quiet_arg $ logging_term))
1131
1033
1132
1034
(* Feature commands *)
1133
1035
···
1141
1043
[
1142
1044
`S Manpage.s_description;
1143
1045
`P
1144
-
"Creates a git worktree at $(b,root/work/<name>) with a new branch \
1145
-
named $(b,<name>). This allows parallel development on separate \
1146
-
branches, useful for having multiple Claude instances working on \
1147
-
different features.";
1046
+
"Creates a git worktree at $(b,root/work/<name>) with a new branch named \
1047
+
$(b,<name>). This allows parallel development on separate branches, \
1048
+
useful for having multiple Claude instances working on different features.";
1148
1049
`S "HOW IT WORKS";
1149
1050
`P "The command:";
1150
1051
`I ("1.", "Creates the $(b,work/) directory if it doesn't exist");
···
1152
1053
`I ("3.", "Checks out a new branch named $(b,<name>)");
1153
1054
`S Manpage.s_examples;
1154
1055
`P "Create a feature worktree:";
1155
-
`Pre
1156
-
"monopam feature add my-feature\n\
1157
-
cd work/my-feature\n\
1158
-
# Now you can work here independently";
1056
+
`Pre "monopam feature add my-feature\n\
1057
+
cd work/my-feature\n\
1058
+
# Now you can work here independently";
1159
1059
`P "Have multiple Claudes work in parallel:";
1160
-
`Pre
1161
-
"# Terminal 1\n\
1162
-
monopam feature add auth-system\n\
1163
-
cd work/auth-system && claude\n\n\
1164
-
# Terminal 2\n\
1165
-
monopam feature add api-refactor\n\
1166
-
cd work/api-refactor && claude";
1060
+
`Pre "# Terminal 1\n\
1061
+
monopam feature add auth-system\n\
1062
+
cd work/auth-system && claude\n\n\
1063
+
# Terminal 2\n\
1064
+
monopam feature add api-refactor\n\
1065
+
cd work/api-refactor && claude";
1167
1066
]
1168
1067
in
1169
1068
let info = Cmd.info "add" ~doc ~man in
···
1174
1073
let proc = Eio.Stdenv.process_mgr env in
1175
1074
match Monopam.Feature.add ~proc ~fs ~config:verse_config ~name () with
1176
1075
| Ok entry ->
1177
-
Fmt.pr "Created feature worktree '%s' at %a@." entry.name Fpath.pp
1178
-
entry.path;
1076
+
Fmt.pr "Created feature worktree '%s' at %a@." entry.name Fpath.pp entry.path;
1179
1077
Fmt.pr "@.To start working:@.";
1180
1078
Fmt.pr " cd %a@." Fpath.pp entry.path;
1181
1079
`Ok ()
···
1212
1110
with_verse_config env @@ fun verse_config ->
1213
1111
let fs = Eio.Stdenv.fs env in
1214
1112
let proc = Eio.Stdenv.process_mgr env in
1215
-
match
1216
-
Monopam.Feature.remove ~proc ~fs ~config:verse_config ~name ~force ()
1217
-
with
1113
+
match Monopam.Feature.remove ~proc ~fs ~config:verse_config ~name ~force () with
1218
1114
| Ok () ->
1219
1115
Fmt.pr "Removed feature worktree '%s'.@." name;
1220
1116
`Ok ()
···
1222
1118
Fmt.epr "Error: %a@." Monopam.Feature.pp_error_with_hint e;
1223
1119
`Error (false, "feature remove failed")
1224
1120
in
1225
-
Cmd.v info
1226
-
Term.(ret (const run $ feature_name_arg $ force_arg $ logging_term))
1121
+
Cmd.v info Term.(ret (const run $ feature_name_arg $ force_arg $ logging_term))
1227
1122
1228
1123
let feature_list_cmd =
1229
1124
let doc = "List all feature worktrees" in
···
1242
1137
let fs = Eio.Stdenv.fs env in
1243
1138
let proc = Eio.Stdenv.process_mgr env in
1244
1139
let entries = Monopam.Feature.list ~proc ~fs ~config:verse_config () in
1245
-
if entries = [] then Fmt.pr "No feature worktrees found.@."
1140
+
if entries = [] then
1141
+
Fmt.pr "No feature worktrees found.@."
1246
1142
else begin
1247
1143
Fmt.pr "Feature worktrees:@.";
1248
-
List.iter
1249
-
(fun entry ->
1250
-
Fmt.pr " %s -> %a (branch: %s)@." entry.Monopam.Feature.name Fpath.pp
1251
-
entry.Monopam.Feature.path entry.Monopam.Feature.branch)
1252
-
entries
1144
+
List.iter (fun entry ->
1145
+
Fmt.pr " %s -> %a (branch: %s)@."
1146
+
entry.Monopam.Feature.name
1147
+
Fpath.pp entry.Monopam.Feature.path
1148
+
entry.Monopam.Feature.branch
1149
+
) entries
1253
1150
end;
1254
1151
`Ok ()
1255
1152
in
···
1266
1163
working on different features simultaneously.";
1267
1164
`S "WORKSPACE STRUCTURE";
1268
1165
`P "Feature worktrees are created in the $(b,work/) directory:";
1269
-
`Pre
1270
-
"root/\n\
1271
-
├── mono/ # Main monorepo\n\
1272
-
├── work/\n\
1273
-
│ ├── feature-a/ # Worktree on branch 'feature-a'\n\
1274
-
│ └── feature-b/ # Worktree on branch 'feature-b'\n\
1275
-
└── ...";
1166
+
`Pre "root/\n\
1167
+
├── mono/ # Main monorepo\n\
1168
+
├── work/\n\
1169
+
│ ├── feature-a/ # Worktree on branch 'feature-a'\n\
1170
+
│ └── feature-b/ # Worktree on branch 'feature-b'\n\
1171
+
└── ...";
1276
1172
`S "COMMANDS";
1277
1173
`I ("add <name>", "Create a new feature worktree");
1278
1174
`I ("remove <name>", "Remove a feature worktree");
1279
1175
`I ("list", "List all feature worktrees");
1280
1176
`S "WORKFLOW";
1281
1177
`P "Typical workflow for parallel development:";
1282
-
`Pre
1283
-
"# Create feature worktrees\n\
1284
-
monopam feature add auth-system\n\
1285
-
monopam feature add api-cleanup\n\n\
1286
-
# Work in each worktree independently\n\
1287
-
cd work/auth-system && claude\n\
1288
-
cd work/api-cleanup && claude\n\n\
1289
-
# When done, merge branches back to main\n\
1290
-
cd mono\n\
1291
-
git merge auth-system\n\
1292
-
git merge api-cleanup\n\n\
1293
-
# Clean up worktrees\n\
1294
-
monopam feature remove auth-system\n\
1295
-
monopam feature remove api-cleanup";
1178
+
`Pre "# Create feature worktrees\n\
1179
+
monopam feature add auth-system\n\
1180
+
monopam feature add api-cleanup\n\n\
1181
+
# Work in each worktree independently\n\
1182
+
cd work/auth-system && claude\n\
1183
+
cd work/api-cleanup && claude\n\n\
1184
+
# When done, merge branches back to main\n\
1185
+
cd mono\n\
1186
+
git merge auth-system\n\
1187
+
git merge api-cleanup\n\n\
1188
+
# Clean up worktrees\n\
1189
+
monopam feature remove auth-system\n\
1190
+
monopam feature remove api-cleanup";
1296
1191
]
1297
1192
in
1298
1193
let info = Cmd.info "feature" ~doc ~man in
···
1314
1209
.devcontainer configuration, it will be created automatically.";
1315
1210
`P
1316
1211
"This is the recommended way to get started with monopam. The \
1317
-
devcontainer provides a consistent environment with OCaml, opam, and \
1318
-
all required tools pre-installed.";
1212
+
devcontainer provides a consistent environment with OCaml, opam, \
1213
+
and all required tools pre-installed.";
1319
1214
`S "WHAT IT DOES";
1320
1215
`P "For a new directory (no .devcontainer/):";
1321
1216
`I ("1.", "Creates the target directory if needed");
···
1327
1222
`I ("1.", "Starts the devcontainer if not running");
1328
1223
`I ("2.", "Opens an interactive shell inside the container");
1329
1224
`S Manpage.s_options;
1330
-
`P
1331
-
"Use $(b,--url) to specify a custom devcontainer.json URL if you want \
1332
-
to use a different base configuration.";
1225
+
`P "Use $(b,--url) to specify a custom devcontainer.json URL if you want \
1226
+
to use a different base configuration.";
1333
1227
`S Manpage.s_examples;
1334
1228
`P "Create a new devcontainer workspace:";
1335
1229
`Pre "monopam devcontainer ~/my-ocaml-project";
1336
1230
`P "Enter an existing devcontainer:";
1337
1231
`Pre "monopam devcontainer ~/my-ocaml-project";
1338
1232
`P "Use a custom devcontainer.json:";
1339
-
`Pre
1340
-
"monopam devcontainer --url https://example.com/devcontainer.json \
1341
-
~/project";
1233
+
`Pre "monopam devcontainer --url https://example.com/devcontainer.json ~/project";
1342
1234
]
1343
1235
in
1344
1236
let info = Cmd.info "devcontainer" ~doc ~man in
···
1347
1239
Arg.(required & pos 0 (some string) None & info [] ~docv:"PATH" ~doc)
1348
1240
in
1349
1241
let url_arg =
1350
-
let doc =
1351
-
"URL to fetch devcontainer.json from. Defaults to the \
1352
-
claude-ocaml-devcontainer template."
1353
-
in
1354
-
Arg.(
1355
-
value
1356
-
& opt string default_devcontainer_url
1357
-
& info [ "url" ] ~docv:"URL" ~doc)
1242
+
let doc = "URL to fetch devcontainer.json from. Defaults to the claude-ocaml-devcontainer template." in
1243
+
Arg.(value & opt string default_devcontainer_url & info ["url"] ~docv:"URL" ~doc)
1358
1244
in
1359
1245
let run path url () =
1360
1246
(* Resolve to absolute path *)
1361
1247
let abs_path =
1362
-
if Filename.is_relative path then Filename.concat (Sys.getcwd ()) path
1248
+
if Filename.is_relative path then
1249
+
Filename.concat (Sys.getcwd ()) path
1363
1250
else path
1364
1251
in
1365
1252
let devcontainer_dir = Filename.concat abs_path ".devcontainer" in
1366
-
let devcontainer_json =
1367
-
Filename.concat devcontainer_dir "devcontainer.json"
1368
-
in
1253
+
let devcontainer_json = Filename.concat devcontainer_dir "devcontainer.json" in
1369
1254
(* Check if .devcontainer exists *)
1370
-
let needs_init =
1371
-
not (Sys.file_exists devcontainer_dir && Sys.is_directory devcontainer_dir)
1372
-
in
1255
+
let needs_init = not (Sys.file_exists devcontainer_dir && Sys.is_directory devcontainer_dir) in
1373
1256
if needs_init then begin
1374
1257
Fmt.pr "Initializing devcontainer in %s...@." abs_path;
1375
1258
(* Create directories *)
1376
-
(try Unix.mkdir abs_path 0o755
1377
-
with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
1378
-
(try Unix.mkdir devcontainer_dir 0o755
1379
-
with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
1259
+
(try Unix.mkdir abs_path 0o755 with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
1260
+
(try Unix.mkdir devcontainer_dir 0o755 with Unix.Unix_error (Unix.EEXIST, _, _) -> ());
1380
1261
(* Fetch devcontainer.json using curl *)
1381
1262
Fmt.pr "Fetching devcontainer.json from %s...@." url;
1382
-
let curl_cmd =
1383
-
Printf.sprintf "curl -fsSL '%s' -o '%s'" url devcontainer_json
1384
-
in
1263
+
let curl_cmd = Printf.sprintf "curl -fsSL '%s' -o '%s'" url devcontainer_json in
1385
1264
let ret = Sys.command curl_cmd in
1386
1265
if ret <> 0 then begin
1387
-
Fmt.epr "Error: Failed to fetch devcontainer.json (curl exit code %d)@."
1388
-
ret;
1266
+
Fmt.epr "Error: Failed to fetch devcontainer.json (curl exit code %d)@." ret;
1389
1267
exit 1
1390
1268
end;
1391
1269
Fmt.pr "Created %s@." devcontainer_json;
1392
1270
(* Build and start the devcontainer *)
1393
1271
Fmt.pr "Building devcontainer (this may take a while on first run)...@.";
1394
-
let up_cmd =
1395
-
Printf.sprintf
1396
-
"npx @devcontainers/cli up --workspace-folder '%s' \
1397
-
--remove-existing-container"
1398
-
abs_path
1399
-
in
1272
+
let up_cmd = Printf.sprintf "npx @devcontainers/cli up --workspace-folder '%s' --remove-existing-container" abs_path in
1400
1273
let ret = Sys.command up_cmd in
1401
1274
if ret <> 0 then begin
1402
1275
Fmt.epr "Error: Failed to start devcontainer (exit code %d)@." ret;
···
1405
1278
end;
1406
1279
(* Exec into the devcontainer *)
1407
1280
Fmt.pr "Entering devcontainer...@.";
1408
-
let exec_cmd =
1409
-
Printf.sprintf
1410
-
"npx @devcontainers/cli exec --workspace-folder '%s' bash -l" abs_path
1411
-
in
1281
+
let exec_cmd = Printf.sprintf "npx @devcontainers/cli exec --workspace-folder '%s' bash -l" abs_path in
1412
1282
let ret = Sys.command exec_cmd in
1413
1283
if ret <> 0 then
1414
1284
`Error (false, Printf.sprintf "devcontainer exec failed with code %d" ret)
1415
-
else `Ok ()
1285
+
else
1286
+
`Ok ()
1416
1287
in
1417
1288
Cmd.v info Term.(ret (const run $ path_arg $ url_arg $ logging_term))
1418
1289
···
1445
1316
with the extracted history, then re-adds mono/<name>/ as a subtree.";
1446
1317
`S "FORK MODES";
1447
1318
`P "The fork command handles two scenarios:";
1448
-
`I
1449
-
( "Subtree with history",
1450
-
"For subtrees added via $(b,git subtree add) or $(b,monopam join), \
1451
-
the command uses $(b,git subtree split) to extract the full commit \
1452
-
history into the new repository." );
1453
-
`I
1454
-
( "Fresh package",
1455
-
"For packages created directly in mono/ without subtree history, the \
1456
-
command copies the files and creates an initial commit. This is \
1457
-
useful for new packages you've developed locally." );
1319
+
`I ("Subtree with history", "For subtrees added via $(b,git subtree add) or \
1320
+
$(b,monopam join), the command uses $(b,git subtree split) to extract \
1321
+
the full commit history into the new repository.");
1322
+
`I ("Fresh package", "For packages created directly in mono/ without subtree \
1323
+
history, the command copies the files and creates an initial commit. \
1324
+
This is useful for new packages you've developed locally.");
1458
1325
`S "WHAT IT DOES";
1459
1326
`P "The fork command performs a complete workflow in one step:";
1460
1327
`I ("1.", "Analyzes mono/<name>/ to detect fork mode");
1461
1328
`I ("2.", "Builds an action plan and shows discovery details");
1462
1329
`I ("3.", "Prompts for confirmation (use $(b,--yes) to skip)");
1463
1330
`I ("4.", "Creates a new git repo at src/<name>/");
1464
-
`I
1465
-
( "5.",
1466
-
"Extracts history (subtree split) or copies files (fresh package)" );
1331
+
`I ("5.", "Extracts history (subtree split) or copies files (fresh package)");
1467
1332
`I ("6.", "Removes mono/<name>/ from git and commits");
1468
1333
`I ("7.", "Re-adds mono/<name>/ as a proper subtree from src/<name>/");
1469
1334
`I ("8.", "Updates sources.toml with $(b,origin = \"fork\")");
···
1516
1381
let mono_path = Monopam.Config.mono_path config in
1517
1382
let subtree_path = Fpath.(mono_path / name) in
1518
1383
let knot = Monopam.Config.knot config in
1519
-
let suggested =
1520
-
Monopam.Fork_join.suggest_push_url ~fs ~knot subtree_path
1521
-
in
1522
-
if yes || dry_run then suggested
1523
-
(* Use suggested or None without prompting *)
1384
+
let suggested = Monopam.Fork_join.suggest_push_url ~fs ~knot subtree_path in
1385
+
if yes || dry_run then
1386
+
suggested (* Use suggested or None without prompting *)
1524
1387
else begin
1525
1388
match suggested with
1526
-
| Some default_url -> (
1389
+
| Some default_url ->
1527
1390
Fmt.pr "Remote push URL [%s]: %!" default_url;
1528
-
match prompt_string "" with
1529
-
| None -> Some default_url (* User pressed enter, use default *)
1530
-
| Some entered -> Some entered)
1391
+
(match prompt_string "" with
1392
+
| None -> Some default_url (* User pressed enter, use default *)
1393
+
| Some entered -> Some entered)
1531
1394
| None ->
1532
1395
Fmt.pr "Remote push URL (leave empty to skip): %!";
1533
1396
prompt_string ""
1534
1397
end
1535
1398
in
1536
1399
(* Build the plan *)
1537
-
match
1538
-
Monopam.Fork_join.plan_fork ~proc ~fs ~config ~name ?push_url:url ~dry_run
1539
-
()
1540
-
with
1400
+
match Monopam.Fork_join.plan_fork ~proc ~fs ~config ~name ?push_url:url ~dry_run () with
1541
1401
| Error e ->
1542
1402
Fmt.epr "Error: %a@." Monopam.Fork_join.pp_error_with_hint e;
1543
1403
`Error (false, "fork failed")
···
1545
1405
(* Print discovery and actions *)
1546
1406
Fmt.pr "Analyzing fork request for '%s'...@.@." name;
1547
1407
Fmt.pr "Discovery:@.%a@." Monopam.Fork_join.pp_discovery plan.discovery;
1548
-
(match url with Some u -> Fmt.pr " Remote URL: %s@." u | None -> ());
1408
+
(match url with
1409
+
| Some u -> Fmt.pr " Remote URL: %s@." u
1410
+
| None -> ());
1549
1411
Fmt.pr "@.Actions to perform:@.";
1550
-
List.iteri
1551
-
(fun i action ->
1552
-
Fmt.pr " %d. %a@." (i + 1) Monopam.Fork_join.pp_action action)
1553
-
plan.actions;
1412
+
List.iteri (fun i action ->
1413
+
Fmt.pr " %d. %a@." (i + 1) Monopam.Fork_join.pp_action action
1414
+
) plan.actions;
1554
1415
Fmt.pr "@.";
1555
1416
(* Prompt for confirmation unless --yes or --dry-run *)
1556
1417
let proceed =
1557
1418
if dry_run then begin
1558
1419
Fmt.pr "(dry-run mode - no changes will be made)@.";
1559
1420
true
1560
-
end
1561
-
else if yes then true
1562
-
else confirm "Proceed?"
1421
+
end else if yes then
1422
+
true
1423
+
else
1424
+
confirm "Proceed?"
1563
1425
in
1564
1426
if not proceed then begin
1565
1427
Fmt.pr "Cancelled.@.";
1566
1428
`Ok ()
1567
-
end
1568
-
else begin
1429
+
end else begin
1569
1430
(* Execute the plan *)
1570
1431
match Monopam.Fork_join.execute_fork_plan ~proc ~fs plan with
1571
1432
| Ok result ->
···
1574
1435
Fmt.pr "@.Next steps:@.";
1575
1436
Fmt.pr " 1. Review the new repo: cd src/%s@." result.name;
1576
1437
match url with
1577
-
| Some _ ->
1578
-
Fmt.pr " 2. Push to remote: git push -u origin main@."
1579
-
| None ->
1580
-
Fmt.pr " 2. Add a remote: git remote add origin <url>@."
1438
+
| Some _ -> Fmt.pr " 2. Push to remote: git push -u origin main@."
1439
+
| None -> Fmt.pr " 2. Add a remote: git remote add origin <url>@."
1581
1440
end;
1582
1441
`Ok ()
1583
1442
| Error e ->
···
1585
1444
`Error (false, "fork failed")
1586
1445
end
1587
1446
in
1588
-
Cmd.v info
1589
-
Term.(
1590
-
ret (const run $ name_arg $ url_arg $ dry_run_arg $ yes_arg $ logging_term))
1447
+
Cmd.v info Term.(ret (const run $ name_arg $ url_arg $ dry_run_arg $ yes_arg $ logging_term))
1591
1448
1592
1449
(* Join command *)
1593
1450
···
1602
1459
`S "JOIN MODES";
1603
1460
`P "The join command handles multiple scenarios:";
1604
1461
`I ("URL join", "Clone from a git URL and add as subtree (default).");
1605
-
`I
1606
-
( "Local directory join",
1607
-
"Import from a local filesystem path. If the path is a git repo, \
1608
-
uses it directly. If not, initializes a new repo." );
1609
-
`I
1610
-
( "Verse join",
1611
-
"Join from a verse member's repository using $(b,--from)." );
1462
+
`I ("Local directory join", "Import from a local filesystem path. If the \
1463
+
path is a git repo, uses it directly. If not, initializes a new repo.");
1464
+
`I ("Verse join", "Join from a verse member's repository using $(b,--from).");
1612
1465
`S "WHAT IT DOES";
1613
1466
`P "The join command:";
1614
1467
`I ("1.", "Analyzes the source (URL or local path)");
···
1619
1472
`I ("6.", "Updates sources.toml with $(b,origin = \"join\")");
1620
1473
`S "JOINING FROM VERSE";
1621
1474
`P "To join a package from a verse member, use $(b,--from):";
1622
-
`Pre
1623
-
"monopam join --from avsm.bsky.social --url \
1624
-
git@github.com:me/cohttp.git cohttp";
1475
+
`Pre "monopam join --from avsm.bsky.social --url git@github.com:me/cohttp.git cohttp";
1625
1476
`P "This will:";
1626
1477
`I ("-", "Look up the package in their opam-repo");
1627
1478
`I ("-", "Find all packages from the same git repository");
···
1642
1493
`P "Join with a custom name using --as:";
1643
1494
`Pre "monopam join https://github.com/someone/some-lib --as my-lib";
1644
1495
`P "Join with upstream tracking (for forks):";
1645
-
`Pre
1646
-
"monopam join https://github.com/me/cohttp --upstream \
1647
-
https://github.com/mirage/cohttp";
1496
+
`Pre "monopam join https://github.com/me/cohttp --upstream https://github.com/mirage/cohttp";
1648
1497
`P "Join from a verse member:";
1649
-
`Pre
1650
-
"monopam join cohttp --from avsm.bsky.social --url \
1651
-
git@github.com:me/cohttp.git";
1498
+
`Pre "monopam join cohttp --from avsm.bsky.social --url git@github.com:me/cohttp.git";
1652
1499
`P "Preview what would be done:";
1653
1500
`Pre "monopam join https://github.com/someone/lib --dry-run";
1654
1501
`P "Join without confirmation:";
···
1690
1537
let fs = Eio.Stdenv.fs env in
1691
1538
let proc = Eio.Stdenv.process_mgr env in
1692
1539
match from with
1693
-
| Some handle -> (
1540
+
| Some handle ->
1694
1541
(* Join from verse member - requires --url for your fork *)
1695
1542
(* Uses legacy API as it involves verse-specific operations *)
1696
-
match fork_url with
1697
-
| None ->
1698
-
Fmt.epr "Error: --url is required when using --from@.";
1699
-
`Error (false, "--url required")
1700
-
| Some fork_url -> (
1701
-
match
1702
-
Monopam.Fork_join.join_from_verse ~proc ~fs ~config
1703
-
~verse_config:config ~package:url_or_pkg ~handle ~fork_url
1704
-
~dry_run ()
1705
-
with
1706
-
| Ok result ->
1707
-
if dry_run then begin
1708
-
Fmt.pr "Would join '%s' from %s:@." result.name
1709
-
(Option.value ~default:"verse" result.from_handle);
1710
-
Fmt.pr " Source: %s@." result.source_url;
1711
-
Option.iter
1712
-
(fun u -> Fmt.pr " Upstream: %s@." u)
1713
-
result.upstream_url;
1714
-
Fmt.pr " Packages: %a@."
1715
-
Fmt.(list ~sep:(any ", ") string)
1716
-
result.packages_added
1717
-
end
1718
-
else begin
1719
-
Fmt.pr "%a@." Monopam.Fork_join.pp_join_result result;
1720
-
Fmt.pr "@.Next steps:@.";
1721
-
Fmt.pr
1722
-
" 1. Commit the opam changes: cd opam-repo && git add -A \
1723
-
&& git commit@.";
1724
-
Fmt.pr " 2. Run $(b,monopam sync) to synchronize@."
1725
-
end;
1726
-
`Ok ()
1727
-
| Error e ->
1728
-
Fmt.epr "Error: %a@." Monopam.Fork_join.pp_error_with_hint e;
1729
-
`Error (false, "join failed")))
1730
-
| None -> (
1543
+
(match fork_url with
1544
+
| None ->
1545
+
Fmt.epr "Error: --url is required when using --from@.";
1546
+
`Error (false, "--url required")
1547
+
| Some fork_url ->
1548
+
match Monopam.Fork_join.join_from_verse ~proc ~fs ~config ~verse_config:config
1549
+
~package:url_or_pkg ~handle ~fork_url ~dry_run () with
1550
+
| Ok result ->
1551
+
if dry_run then begin
1552
+
Fmt.pr "Would join '%s' from %s:@." result.name (Option.value ~default:"verse" result.from_handle);
1553
+
Fmt.pr " Source: %s@." result.source_url;
1554
+
Option.iter (fun u -> Fmt.pr " Upstream: %s@." u) result.upstream_url;
1555
+
Fmt.pr " Packages: %a@." Fmt.(list ~sep:(any ", ") string) result.packages_added
1556
+
end else begin
1557
+
Fmt.pr "%a@." Monopam.Fork_join.pp_join_result result;
1558
+
Fmt.pr "@.Next steps:@.";
1559
+
Fmt.pr " 1. Commit the opam changes: cd opam-repo && git add -A && git commit@.";
1560
+
Fmt.pr " 2. Run $(b,monopam sync) to synchronize@."
1561
+
end;
1562
+
`Ok ()
1563
+
| Error e ->
1564
+
Fmt.epr "Error: %a@." Monopam.Fork_join.pp_error_with_hint e;
1565
+
`Error (false, "join failed"))
1566
+
| None ->
1731
1567
(* Normal join from URL or local path - use plan-based workflow *)
1732
1568
let source = match fork_url with Some u -> u | None -> url_or_pkg in
1733
-
let name =
1734
-
match fork_url with Some _ -> Some url_or_pkg | None -> as_name
1735
-
in
1569
+
let name = match fork_url with Some _ -> Some url_or_pkg | None -> as_name in
1736
1570
(* Build the plan *)
1737
-
match
1738
-
Monopam.Fork_join.plan_join ~proc ~fs ~config ~source ?name ?upstream
1739
-
~dry_run ()
1740
-
with
1571
+
match Monopam.Fork_join.plan_join ~proc ~fs ~config ~source ?name ?upstream ~dry_run () with
1741
1572
| Error e ->
1742
1573
Fmt.epr "Error: %a@." Monopam.Fork_join.pp_error_with_hint e;
1743
1574
`Error (false, "join failed")
···
1750
1581
(if is_local then "local directory" else "remote URL");
1751
1582
Fmt.pr "%a" Monopam.Fork_join.pp_discovery plan.discovery;
1752
1583
Fmt.pr "@.Actions to perform:@.";
1753
-
List.iteri
1754
-
(fun i action ->
1755
-
Fmt.pr " %d. %a@." (i + 1) Monopam.Fork_join.pp_action action)
1756
-
plan.actions;
1584
+
List.iteri (fun i action ->
1585
+
Fmt.pr " %d. %a@." (i + 1) Monopam.Fork_join.pp_action action
1586
+
) plan.actions;
1757
1587
Fmt.pr "@.";
1758
1588
(* Prompt for confirmation unless --yes or --dry-run *)
1759
1589
let proceed =
1760
1590
if dry_run then begin
1761
1591
Fmt.pr "(dry-run mode - no changes will be made)@.";
1762
1592
true
1763
-
end
1764
-
else if yes then true
1765
-
else confirm "Proceed?"
1593
+
end else if yes then
1594
+
true
1595
+
else
1596
+
confirm "Proceed?"
1766
1597
in
1767
1598
if not proceed then begin
1768
1599
Fmt.pr "Cancelled.@.";
1769
1600
`Ok ()
1770
-
end
1771
-
else begin
1601
+
end else begin
1772
1602
(* Execute the plan *)
1773
1603
match Monopam.Fork_join.execute_join_plan ~proc ~fs plan with
1774
1604
| Ok result ->
···
1781
1611
| Error e ->
1782
1612
Fmt.epr "Error: %a@." Monopam.Fork_join.pp_error_with_hint e;
1783
1613
`Error (false, "join failed")
1784
-
end)
1614
+
end
1785
1615
in
1786
-
Cmd.v info
1787
-
Term.(
1788
-
ret
1789
-
(const run $ url_or_pkg_arg $ as_arg $ upstream_arg $ from_arg
1790
-
$ fork_url_arg $ dry_run_arg $ yes_arg $ logging_term))
1616
+
Cmd.v info Term.(ret (const run $ url_or_pkg_arg $ as_arg $ upstream_arg $ from_arg $ fork_url_arg $ dry_run_arg $ yes_arg $ logging_term))
1791
1617
1792
1618
(* Rejoin command *)
1793
1619
···
1815
1641
`I ("1.", "Verifies src/<name>/ exists and is a git repo");
1816
1642
`I ("2.", "Verifies mono/<name>/ does not exist");
1817
1643
`I ("3.", "Prompts for confirmation (use $(b,--yes) to skip)");
1818
-
`I
1819
-
( "4.",
1820
-
"Uses $(b,git subtree add) to bring src/<name>/ into mono/<name>/" );
1644
+
`I ("4.", "Uses $(b,git subtree add) to bring src/<name>/ into mono/<name>/");
1821
1645
`S Manpage.s_examples;
1822
1646
`P "Re-add a package from src/:";
1823
1647
`Pre "monopam rejoin my-lib";
···
1855
1679
Fmt.pr "Analyzing rejoin request for '%s'...@.@." name;
1856
1680
Fmt.pr "Discovery:@.%a@." Monopam.Fork_join.pp_discovery plan.discovery;
1857
1681
Fmt.pr "@.Actions to perform:@.";
1858
-
List.iteri
1859
-
(fun i action ->
1860
-
Fmt.pr " %d. %a@." (i + 1) Monopam.Fork_join.pp_action action)
1861
-
plan.actions;
1682
+
List.iteri (fun i action ->
1683
+
Fmt.pr " %d. %a@." (i + 1) Monopam.Fork_join.pp_action action
1684
+
) plan.actions;
1862
1685
Fmt.pr "@.";
1863
1686
(* Prompt for confirmation unless --yes or --dry-run *)
1864
1687
let proceed =
1865
1688
if dry_run then begin
1866
1689
Fmt.pr "(dry-run mode - no changes will be made)@.";
1867
1690
true
1868
-
end
1869
-
else if yes then true
1870
-
else confirm "Proceed?"
1691
+
end else if yes then
1692
+
true
1693
+
else
1694
+
confirm "Proceed?"
1871
1695
in
1872
1696
if not proceed then begin
1873
1697
Fmt.pr "Cancelled.@.";
1874
1698
`Ok ()
1875
-
end
1876
-
else begin
1699
+
end else begin
1877
1700
(* Execute the plan *)
1878
1701
match Monopam.Fork_join.execute_join_plan ~proc ~fs plan with
1879
1702
| Ok result ->
···
1889
1712
`Error (false, "rejoin failed")
1890
1713
end
1891
1714
in
1892
-
Cmd.v info
1893
-
Term.(ret (const run $ name_arg $ dry_run_arg $ yes_arg $ logging_term))
1715
+
Cmd.v info Term.(ret (const run $ name_arg $ dry_run_arg $ yes_arg $ logging_term))
1894
1716
1895
1717
(* Site command *)
1896
1718
···
1900
1722
[
1901
1723
`S Manpage.s_description;
1902
1724
`P
1903
-
"Generates a static index.html file that maps the monoverse, showing \
1904
-
all verse members, their packages, and the relationships between \
1905
-
them.";
1725
+
"Generates a static index.html file that maps the monoverse, showing all \
1726
+
verse members, their packages, and the relationships between them.";
1906
1727
`S "OUTPUT";
1907
1728
`P "The generated site includes:";
1908
-
`I
1909
-
( "Members",
1910
-
"All verse members with links to their monorepo and opam repos" );
1729
+
`I ("Members", "All verse members with links to their monorepo and opam repos");
1911
1730
`I ("Summary", "Overview of common libraries and member-specific packages");
1912
1731
`I ("Repository Details", "Each shared repo with packages and fork status");
1913
1732
`S "FORK STATUS";
···
1935
1754
let info = Cmd.info "site" ~doc ~man in
1936
1755
let output_arg =
1937
1756
let doc = "Output file path. Defaults to mono/index.html." in
1938
-
Arg.(
1939
-
value & opt (some string) None & info [ "o"; "output" ] ~docv:"FILE" ~doc)
1757
+
Arg.(value & opt (some string) None & info [ "o"; "output" ] ~docv:"FILE" ~doc)
1940
1758
in
1941
1759
let stdout_arg =
1942
1760
let doc = "Print HTML to stdout instead of writing to file." in
1943
1761
Arg.(value & flag & info [ "stdout" ] ~doc)
1944
1762
in
1945
1763
let status_arg =
1946
-
let doc =
1947
-
"Include fork status (ahead/behind) for each repository. This fetches \
1948
-
from remotes and may be slower."
1949
-
in
1764
+
let doc = "Include fork status (ahead/behind) for each repository. \
1765
+
This fetches from remotes and may be slower." in
1950
1766
Arg.(value & flag & info [ "status"; "s" ] ~doc)
1951
1767
in
1952
1768
let run output to_stdout with_status () =
···
1958
1774
(* Pull/clone registry to get latest metadata *)
1959
1775
Fmt.pr "Syncing registry...@.";
1960
1776
let registry =
1961
-
match
1962
-
Monopam.Verse_registry.clone_or_pull ~proc
1963
-
~fs:(fs :> _ Eio.Path.t)
1964
-
~config:verse_config ()
1965
-
with
1777
+
match Monopam.Verse_registry.clone_or_pull ~proc ~fs:(fs :> _ Eio.Path.t) ~config:verse_config () with
1966
1778
| Ok r -> r
1967
1779
| Error msg ->
1968
1780
Fmt.epr "Warning: Could not sync registry: %s@." msg;
1969
-
Monopam.Verse_registry.
1970
-
{ name = "opamverse"; description = None; members = [] }
1781
+
Monopam.Verse_registry.{ name = "opamverse"; description = None; members = [] }
1971
1782
in
1972
1783
(* Compute forks if --status is requested *)
1973
1784
let forks =
1974
1785
if with_status then begin
1975
1786
Fmt.pr "Computing fork status...@.";
1976
-
Some
1977
-
(Monopam.Forks.compute ~proc
1978
-
~fs:(fs :> _ Eio.Path.t)
1979
-
~verse_config ~monopam_config ())
1980
-
end
1981
-
else None
1787
+
Some (Monopam.Forks.compute ~proc ~fs:(fs :> _ Eio.Path.t)
1788
+
~verse_config ~monopam_config ())
1789
+
end else None
1982
1790
in
1983
1791
if to_stdout then begin
1984
-
let html =
1985
-
Monopam.Site.generate
1986
-
~fs:(fs :> _ Eio.Path.t)
1987
-
~config:verse_config ?forks ~registry ()
1988
-
in
1792
+
let html = Monopam.Site.generate ~fs:(fs :> _ Eio.Path.t) ~config:verse_config ?forks ~registry () in
1989
1793
print_string html;
1990
1794
`Ok ()
1991
-
end
1992
-
else begin
1795
+
end else begin
1993
1796
let output_path =
1994
1797
match output with
1995
1798
| Some p -> (
1996
1799
match Fpath.of_string p with
1997
1800
| Ok fp -> fp
1998
1801
| Error (`Msg _) -> Fpath.v p)
1999
-
| None ->
2000
-
Fpath.(Monopam.Verse_config.mono_path verse_config / "index.html")
1802
+
| None -> Fpath.(Monopam.Verse_config.mono_path verse_config / "index.html")
2001
1803
in
2002
-
match
2003
-
Monopam.Site.write
2004
-
~fs:(fs :> _ Eio.Path.t)
2005
-
~config:verse_config ?forks ~registry ~output_path ()
2006
-
with
1804
+
match Monopam.Site.write ~fs:(fs :> _ Eio.Path.t) ~config:verse_config ?forks ~registry ~output_path () with
2007
1805
| Ok () ->
2008
1806
Fmt.pr "Site generated: %a@." Fpath.pp output_path;
2009
1807
`Ok ()
···
2012
1810
`Error (false, "site generation failed")
2013
1811
end
2014
1812
in
2015
-
Cmd.v info
2016
-
Term.(ret (const run $ output_arg $ stdout_arg $ status_arg $ logging_term))
1813
+
Cmd.v info Term.(ret (const run $ output_arg $ stdout_arg $ status_arg $ logging_term))
2017
1814
2018
1815
(* Main command group *)
2019
1816
···
2031
1828
pre-installed.";
2032
1829
`S "QUICK START";
2033
1830
`P "Start by creating a devcontainer workspace:";
2034
-
`Pre "monopam devcontainer ~/tangled";
1831
+
`Pre
1832
+
"monopam devcontainer ~/tangled";
2035
1833
`P "Inside the devcontainer, initialize your workspace:";
2036
-
`Pre "cd ~/tangled\nmonopam init --handle yourname.bsky.social\ncd mono";
1834
+
`Pre
1835
+
"cd ~/tangled\n\
1836
+
monopam init --handle yourname.bsky.social\n\
1837
+
cd mono";
2037
1838
`P "Daily workflow:";
2038
1839
`Pre
2039
1840
"cd ~/tangled/mono\n\
···
2112
1913
in
2113
1914
let info = Cmd.info "monopam" ~version:"%%VERSION%%" ~doc ~man in
2114
1915
Cmd.group info
2115
-
[
2116
-
init_cmd;
2117
-
status_cmd;
2118
-
diff_cmd;
2119
-
pull_cmd;
2120
-
cherrypick_cmd;
2121
-
sync_cmd;
2122
-
changes_cmd;
2123
-
opam_cmd;
2124
-
doctor_cmd;
2125
-
verse_cmd;
2126
-
feature_cmd;
2127
-
fork_cmd;
2128
-
join_cmd;
2129
-
rejoin_cmd;
2130
-
devcontainer_cmd;
2131
-
site_cmd;
2132
-
]
1916
+
[ init_cmd; status_cmd; diff_cmd; pull_cmd; cherrypick_cmd; sync_cmd; changes_cmd; opam_cmd; doctor_cmd; verse_cmd; feature_cmd; fork_cmd; join_cmd; rejoin_cmd; devcontainer_cmd; site_cmd ]
2133
1917
2134
-
let () =
2135
-
Memtrace.trace_if_requested ~context:"monopam" ();
2136
-
exit (Cmd.eval main_cmd)
1918
+
let () = exit (Cmd.eval main_cmd)
+2
-2
lib/changes.ml
+2
-2
lib/changes.ml
···
464
464
week_start week_end);
465
465
Buffer.add_string buf "## Commits this week:\n\n";
466
466
List.iter
467
-
(fun (commit : Git_cli.log_entry) ->
467
+
(fun (commit : Git.log_entry) ->
468
468
Buffer.add_string buf
469
469
(Printf.sprintf "### %s by %s (%s)\n"
470
470
(String.sub commit.hash 0 (min 7 (String.length commit.hash)))
···
517
517
(Printf.sprintf "Generate a user-facing changelog entry for %s.\n\n" date);
518
518
Buffer.add_string buf "## Commits today:\n\n";
519
519
List.iter
520
-
(fun (commit : Git_cli.log_entry) ->
520
+
(fun (commit : Git.log_entry) ->
521
521
Buffer.add_string buf
522
522
(Printf.sprintf "### %s by %s (%s)\n"
523
523
(String.sub commit.hash 0 (min 7 (String.length commit.hash)))
+5
-5
lib/changes.mli
+5
-5
lib/changes.mli
···
165
165
repository:string ->
166
166
week_start:string ->
167
167
week_end:string ->
168
-
Git_cli.log_entry list ->
168
+
Git.log_entry list ->
169
169
string
170
170
(** [generate_prompt ~repository ~week_start ~week_end commits] creates the
171
171
prompt to send to Claude for weekly changelog generation. *)
···
174
174
repository:string ->
175
175
week_start:string ->
176
176
week_end:string ->
177
-
Git_cli.log_entry list ->
177
+
Git.log_entry list ->
178
178
string
179
179
(** [generate_weekly_prompt ~repository ~week_start ~week_end commits] creates
180
180
the prompt to send to Claude for weekly changelog generation. *)
181
181
182
182
val generate_daily_prompt :
183
-
repository:string -> date:string -> Git_cli.log_entry list -> string
183
+
repository:string -> date:string -> Git.log_entry list -> string
184
184
(** [generate_daily_prompt ~repository ~date commits] creates the prompt to send
185
185
to Claude for daily changelog generation. *)
186
186
···
197
197
repository:string ->
198
198
week_start:string ->
199
199
week_end:string ->
200
-
Git_cli.log_entry list ->
200
+
Git.log_entry list ->
201
201
(claude_response option, string) result
202
202
(** [analyze_commits ~sw ~process_mgr ~clock ~repository ~week_start ~week_end
203
203
commits] sends commits to Claude for weekly analysis and returns the parsed
···
209
209
clock:float Eio.Time.clock_ty Eio.Resource.t ->
210
210
repository:string ->
211
211
date:string ->
212
-
Git_cli.log_entry list ->
212
+
Git.log_entry list ->
213
213
(claude_response option, string) result
214
214
(** [analyze_commits_daily ~sw ~process_mgr ~clock ~repository ~date commits]
215
215
sends commits to Claude for daily analysis and returns the parsed response.
+22
-35
lib/config.ml
+22
-35
lib/config.ml
···
1
1
(** Unified configuration for monopam.
2
2
3
-
Configuration is stored in TOML format at ~/.config/monopam/opamverse.toml
4
-
*)
3
+
Configuration is stored in TOML format at ~/.config/monopam/opamverse.toml *)
5
4
6
5
let app_name = "monopam"
7
6
···
23
22
(** {1 Paths Configuration} *)
24
23
25
24
type paths = {
26
-
mono : string; (** Monorepo directory (default: "mono") *)
27
-
src : string; (** Source checkouts directory (default: "src") *)
25
+
mono : string; (** Monorepo directory (default: "mono") *)
26
+
src : string; (** Source checkouts directory (default: "src") *)
28
27
verse : string; (** Verse directory (default: "verse") *)
29
28
}
30
29
···
87
86
let xdg_cache_home () =
88
87
match Sys.getenv_opt "XDG_CACHE_HOME" with
89
88
| Some dir when dir <> "" -> Fpath.v dir
90
-
| _ -> (
89
+
| _ ->
91
90
match Sys.getenv_opt "HOME" with
92
91
| Some home -> Fpath.(v home / ".cache")
93
-
| None -> Fpath.v "/tmp")
92
+
| None -> Fpath.v "/tmp"
94
93
95
94
let config_dir () = Fpath.(xdg_config_home () / app_name)
96
95
let data_dir () = Fpath.(xdg_data_home () / app_name)
···
100
99
101
100
(** {1 Construction} *)
102
101
103
-
(** Derive knot (git push server) from handle. E.g., "anil.recoil.org" ->
104
-
"git.recoil.org" *)
102
+
(** Derive knot (git push server) from handle.
103
+
E.g., "anil.recoil.org" -> "git.recoil.org" *)
105
104
let default_knot_from_handle handle =
106
105
match String.index_opt handle '.' with
107
106
| None -> "git." ^ handle (* fallback *)
···
110
109
"git." ^ domain
111
110
112
111
let create ~root ~handle ?knot ?(packages = []) ?(paths = default_paths) () =
113
-
let knot =
114
-
match knot with Some k -> k | None -> default_knot_from_handle handle
115
-
in
112
+
let knot = match knot with Some k -> k | None -> default_knot_from_handle handle in
116
113
{ root; handle; knot; packages; paths }
117
114
118
115
let with_package_override t ~name ?branch:branch_opt () =
···
148
145
Tomlt.(
149
146
Table.(
150
147
obj (fun mono src verse ->
151
-
{
152
-
mono = Option.value ~default:default_paths.mono mono;
153
-
src = Option.value ~default:default_paths.src src;
154
-
verse = Option.value ~default:default_paths.verse verse;
155
-
})
148
+
{ mono = Option.value ~default:default_paths.mono mono;
149
+
src = Option.value ~default:default_paths.src src;
150
+
verse = Option.value ~default:default_paths.verse verse })
156
151
|> opt_mem "mono" string ~enc:(fun p -> Some p.mono)
157
152
|> opt_mem "src" string ~enc:(fun p -> Some p.src)
158
153
|> opt_mem "verse" string ~enc:(fun p -> Some p.verse)
···
199
194
Tomlt.(
200
195
Table.(
201
196
obj (fun pkgs -> pkgs)
202
-
|> keep_unknown ~enc:(fun pkgs -> pkgs) (Mems.assoc Package_config.codec)
197
+
|> keep_unknown ~enc:(fun pkgs -> pkgs)
198
+
(Mems.assoc Package_config.codec)
203
199
|> finish))
204
200
205
201
let codec : t Tomlt.t =
···
209
205
let packages = Option.value ~default:[] packages in
210
206
let paths = Option.value ~default:default_paths paths in
211
207
let knot = Option.value ~default:default_knot identity.i_knot in
212
-
{
213
-
root = workspace.w_root;
214
-
handle = identity.i_handle;
215
-
knot;
216
-
packages;
217
-
paths;
218
-
})
208
+
{ root = workspace.w_root; handle = identity.i_handle; knot; packages; paths })
219
209
|> mem "workspace" workspace_codec ~enc:(fun t -> { w_root = t.root })
220
-
|> mem "identity" identity_codec ~enc:(fun t ->
221
-
{ i_handle = t.handle; i_knot = Some t.knot })
222
-
|> opt_mem "packages" packages_table_codec ~enc:(fun t ->
223
-
if t.packages = [] then None else Some t.packages)
224
-
|> opt_mem "paths" paths_codec ~enc:(fun t ->
225
-
if t.paths = default_paths then None else Some t.paths)
210
+
|> mem "identity" identity_codec ~enc:(fun t -> { i_handle = t.handle; i_knot = Some t.knot })
211
+
|> opt_mem "packages" packages_table_codec
212
+
~enc:(fun t -> if t.packages = [] then None else Some t.packages)
213
+
|> opt_mem "paths" paths_codec
214
+
~enc:(fun t -> if t.paths = default_paths then None else Some t.paths)
226
215
|> finish))
227
216
228
217
(** {1 Validation} *)
···
261
250
| `Regular_file -> (
262
251
try Ok (Tomlt_eio.decode_path_exn codec ~fs path_str) with
263
252
| Failure msg -> Error (Printf.sprintf "Invalid config: %s" msg)
264
-
| exn ->
265
-
Error
266
-
(Printf.sprintf "Error loading config: %s" (Printexc.to_string exn))
267
-
)
253
+
| exn -> Error (Printf.sprintf "Error loading config: %s" (Printexc.to_string exn)))
268
254
| _ -> Error (Printf.sprintf "Config file not found: %s" path_str)
269
255
| exception _ -> Error (Printf.sprintf "Config file not found: %s" path_str)
270
256
···
287
273
@[<hov 2>identity:@ handle=%s@ knot=%s@]@,\
288
274
@[<hov 2>paths:@ mono=%s@ src=%s@ verse=%s@]@,\
289
275
packages=%d@]"
290
-
Fpath.pp t.root t.handle t.knot t.paths.mono t.paths.src t.paths.verse
276
+
Fpath.pp t.root t.handle t.knot
277
+
t.paths.mono t.paths.src t.paths.verse
291
278
(List.length t.packages)
+11
-13
lib/config.mli
+11
-13
lib/config.mli
···
1
1
(** Unified configuration for monopam.
2
2
3
-
Configuration is stored in TOML format at
4
-
[~/.config/monopam/opamverse.toml].
3
+
Configuration is stored in TOML format at [~/.config/monopam/opamverse.toml].
5
4
6
5
The config stores:
7
6
- Workspace root and custom paths
···
25
24
(** [branch t] returns the branch override for this package, if set. *)
26
25
end
27
26
28
-
type paths = {
29
-
mono : string; (** Monorepo directory (default: "mono") *)
30
-
src : string; (** Source checkouts directory (default: "src") *)
31
-
verse : string; (** Verse directory (default: "verse") *)
32
-
}
33
27
(** Configurable paths within the workspace.
34
28
35
29
By default, paths are:
···
38
32
- [verse = "verse"] - verse directory
39
33
40
34
Set [mono = "."] to have packages at the root level. *)
35
+
type paths = {
36
+
mono : string; (** Monorepo directory (default: "mono") *)
37
+
src : string; (** Source checkouts directory (default: "src") *)
38
+
verse : string; (** Verse directory (default: "verse") *)
39
+
}
41
40
42
41
val default_paths : paths
43
42
(** Default paths configuration. *)
···
54
53
(** [handle t] returns the user's handle. *)
55
54
56
55
val knot : t -> string
57
-
(** [knot t] returns the git push server hostname (e.g., "git.recoil.org"). Used
58
-
for converting tangled URLs to SSH push URLs. *)
56
+
(** [knot t] returns the git push server hostname (e.g., "git.recoil.org").
57
+
Used for converting tangled URLs to SSH push URLs. *)
59
58
60
59
val paths : t -> paths
61
60
(** [paths t] returns the paths configuration. *)
···
130
129
?paths:paths ->
131
130
unit ->
132
131
t
133
-
(** [create ~root ~handle ?knot ?packages ?paths ()] creates a new
134
-
configuration.
132
+
(** [create ~root ~handle ?knot ?packages ?paths ()] creates a new configuration.
135
133
136
134
@param root Workspace root directory (absolute path)
137
135
@param handle User's handle
···
140
138
@param paths Optional custom paths configuration *)
141
139
142
140
val with_package_override : t -> name:string -> ?branch:string -> unit -> t
143
-
(** [with_package_override t ~name ?branch ()] returns a new config with
144
-
overrides for the named package. *)
141
+
(** [with_package_override t ~name ?branch ()] returns a new config
142
+
with overrides for the named package. *)
145
143
146
144
(** {1 Validation} *)
147
145
+12
-13
lib/cross_status.ml
+12
-13
lib/cross_status.ml
···
141
141
(** Get subtree info for a given prefix in a monorepo. *)
142
142
let get_subtree_info ~proc ~fs ~monorepo_path ~prefix () : subtree_info =
143
143
let upstream_commit =
144
-
Git_cli.subtree_last_upstream_commit ~proc ~fs ~repo:monorepo_path ~prefix
145
-
()
144
+
Git.subtree_last_upstream_commit ~proc ~fs ~repo:monorepo_path ~prefix ()
146
145
in
147
146
{ monorepo_path; prefix; upstream_commit }
148
147
···
155
154
| Some my, Some their when my = their -> Same
156
155
| Some my, Some their ->
157
156
(* Try to compare using checkout if available *)
158
-
if not (Git_cli.is_repo ~proc ~fs checkout_path) then Unknown
157
+
if not (Git.is_repo ~proc ~fs checkout_path) then Unknown
159
158
else begin
160
159
(* Check if either is ancestor of the other *)
161
160
let my_is_ancestor =
162
-
Git_cli.is_ancestor ~proc ~fs ~repo:checkout_path ~commit1:my
161
+
Git.is_ancestor ~proc ~fs ~repo:checkout_path ~commit1:my
163
162
~commit2:their ()
164
163
in
165
164
let their_is_ancestor =
166
-
Git_cli.is_ancestor ~proc ~fs ~repo:checkout_path ~commit1:their
165
+
Git.is_ancestor ~proc ~fs ~repo:checkout_path ~commit1:their
167
166
~commit2:my ()
168
167
in
169
168
match (my_is_ancestor, their_is_ancestor) with
170
169
| true, false ->
171
170
(* My commit is ancestor of theirs -> I'm behind *)
172
171
let behind =
173
-
Git_cli.count_commits_between ~proc ~fs ~repo:checkout_path
174
-
~base:my ~head:their ()
172
+
Git.count_commits_between ~proc ~fs ~repo:checkout_path ~base:my
173
+
~head:their ()
175
174
in
176
175
I_am_behind behind
177
176
| false, true ->
178
177
(* Their commit is ancestor of mine -> I'm ahead *)
179
178
let ahead =
180
-
Git_cli.count_commits_between ~proc ~fs ~repo:checkout_path
179
+
Git.count_commits_between ~proc ~fs ~repo:checkout_path
181
180
~base:their ~head:my ()
182
181
in
183
182
I_am_ahead ahead
···
187
186
| false, false -> (
188
187
(* Neither is ancestor -> diverged *)
189
188
match
190
-
Git_cli.merge_base ~proc ~fs ~repo:checkout_path ~commit1:my
189
+
Git.merge_base ~proc ~fs ~repo:checkout_path ~commit1:my
191
190
~commit2:their ()
192
191
with
193
192
| Error _ -> Unknown
194
193
| Ok base ->
195
194
let my_ahead =
196
-
Git_cli.count_commits_between ~proc ~fs ~repo:checkout_path
197
-
~base ~head:my ()
195
+
Git.count_commits_between ~proc ~fs ~repo:checkout_path ~base
196
+
~head:my ()
198
197
in
199
198
let their_ahead =
200
-
Git_cli.count_commits_between ~proc ~fs ~repo:checkout_path
201
-
~base ~head:their ()
199
+
Git.count_commits_between ~proc ~fs ~repo:checkout_path ~base
200
+
~head:their ()
202
201
in
203
202
Diverged { my_ahead; their_ahead })
204
203
end
+14
-11
lib/doctor.ml
+14
-11
lib/doctor.ml
···
363
363
url : string;
364
364
ahead : int; [@warning "-69"] (** Commits we have that remote doesn't *)
365
365
behind : int; (** Commits remote has that we don't *)
366
-
incoming_commits : Git_cli.log_entry list;
366
+
incoming_commits : Git.log_entry list;
367
367
(** Commits from remote we don't have *)
368
368
}
369
369
(** Information about a single remote's status *)
···
371
371
(** Analyze a single remote for a checkout *)
372
372
let analyze_remote ~proc ~fs ~checkout_dir ~remote_name =
373
373
let url =
374
-
Git_cli.get_remote_url ~proc ~fs ~remote:remote_name checkout_dir
374
+
Git.get_remote_url ~proc ~fs ~remote:remote_name checkout_dir
375
375
|> Option.value ~default:"(unknown)"
376
376
in
377
377
(* Try to get ahead/behind for this remote *)
378
378
let ahead, behind =
379
-
match Git_cli.ahead_behind ~proc ~fs ~remote:remote_name checkout_dir with
379
+
match Git.ahead_behind ~proc ~fs ~remote:remote_name checkout_dir with
380
380
| Ok ab -> (ab.ahead, ab.behind)
381
381
| Error _ -> (0, 0)
382
382
in
···
385
385
if behind > 0 then
386
386
let tip = Printf.sprintf "%s/main" remote_name in
387
387
match
388
-
Git_cli.log_range ~proc ~fs ~base:"HEAD" ~tip ~max_count:20 checkout_dir
388
+
Git.log_range ~proc ~fs ~base:"HEAD" ~tip ~max_count:20 checkout_dir
389
389
with
390
390
| Ok commits -> commits
391
391
| Error _ -> (
392
392
(* Try with master branch *)
393
393
match
394
-
Git_cli.log_range ~proc ~fs ~base:"HEAD"
394
+
Git.log_range ~proc ~fs ~base:"HEAD"
395
395
~tip:(Printf.sprintf "%s/master" remote_name)
396
396
~max_count:20 checkout_dir
397
397
with
···
403
403
404
404
(** Analyze all remotes for a checkout *)
405
405
let analyze_checkout_remotes ~proc ~fs ~checkout_dir =
406
-
let remotes = Git_cli.list_remotes ~proc ~fs checkout_dir in
406
+
let remotes = Git.list_remotes ~proc ~fs checkout_dir in
407
407
List.map
408
408
(fun remote_name -> analyze_remote ~proc ~fs ~checkout_dir ~remote_name)
409
409
remotes
···
483
483
(Printf.sprintf "**%s** (%s) - %d commits behind:\n"
484
484
r.remote_name r.url r.behind);
485
485
List.iter
486
-
(fun (c : Git_cli.log_entry) ->
486
+
(fun (c : Git.log_entry) ->
487
487
let short_hash =
488
488
String.sub c.hash 0 (min 7 (String.length c.hash))
489
489
in
···
922
922
| Ok pkgs -> pkgs
923
923
| Error _ -> []
924
924
in
925
-
let statuses = Status.compute_all ~fs ~config packages in
925
+
let statuses = Status.compute_all ~proc ~fs ~config packages in
926
926
927
927
(* Filter by package if specified *)
928
928
let statuses =
···
939
939
940
940
(* Check opam-repo for dirty state *)
941
941
let opam_repo = Config.Paths.opam_repo config in
942
-
if Git_cli.is_dirty ~proc ~fs opam_repo then
942
+
if Git.is_dirty ~proc ~fs opam_repo then
943
943
warnings := "opam-repo has uncommitted changes" :: !warnings;
944
944
945
945
(* Check monorepo for dirty state *)
946
946
let monorepo = Config.Paths.monorepo config in
947
-
if Git_cli.is_dirty ~proc ~fs monorepo then
947
+
if Git.is_dirty ~proc ~fs monorepo then
948
948
warnings := "monorepo has uncommitted changes" :: !warnings;
949
949
950
950
(* Analyze all remotes for each checkout *)
···
1132
1132
(** Health status for cron-job style exit codes *)
1133
1133
type health = Healthy | Warning | Critical
1134
1134
1135
-
let health_to_exit_code = function Healthy -> 0 | Warning -> 1 | Critical -> 2
1135
+
let health_to_exit_code = function
1136
+
| Healthy -> 0
1137
+
| Warning -> 1
1138
+
| Critical -> 2
1136
1139
1137
1140
(** Compute overall health status from a report.
1138
1141
- Critical: has critical/high priority issues or warnings
+1
-2
lib/dune
+1
-2
lib/dune
+19
-14
lib/dune_project.ml
+19
-14
lib/dune_project.ml
···
3
3
type source_info =
4
4
| Github of { user : string; repo : string }
5
5
| Gitlab of { user : string; repo : string }
6
-
| Tangled of { host : string; repo : string }
7
-
(** tangled.org style sources *)
6
+
| Tangled of { host : string; repo : string } (** tangled.org style sources *)
8
7
| Uri of { url : string; branch : string option }
9
8
10
9
type t = {
···
17
16
module Sexp = Sexplib0.Sexp
18
17
19
18
(** Extract string from a Sexp.Atom, or None if it's a List *)
20
-
let atom_string = function Sexp.Atom s -> Some s | Sexp.List _ -> None
19
+
let atom_string = function
20
+
| Sexp.Atom s -> Some s
21
+
| Sexp.List _ -> None
21
22
22
23
(** Parse source stanza: (source (github user/repo)) or (source (uri "url")) *)
23
24
let parse_source_inner sexp =
···
35
36
match String.index_opt host_repo '/' with
36
37
| Some i ->
37
38
let host = String.sub host_repo 0 i in
38
-
let repo =
39
-
String.sub host_repo (i + 1) (String.length host_repo - i - 1)
40
-
in
39
+
let repo = String.sub host_repo (i + 1) (String.length host_repo - i - 1) in
41
40
Some (Tangled { host; repo })
42
41
| None -> None)
43
42
| Sexp.List [ Sexp.Atom "uri"; Sexp.Atom url ] ->
44
43
(* Check for branch in URI fragment *)
45
44
let uri = Uri.of_string url in
46
45
let branch = Uri.fragment uri in
47
-
let url_without_fragment = Uri.with_fragment uri None |> Uri.to_string in
46
+
let url_without_fragment =
47
+
Uri.with_fragment uri None |> Uri.to_string
48
+
in
48
49
Some (Uri { url = url_without_fragment; branch })
49
50
| Sexp.Atom url ->
50
51
(* Single atom URL (unlikely but handle it) *)
51
52
let uri = Uri.of_string url in
52
53
let branch = Uri.fragment uri in
53
-
let url_without_fragment = Uri.with_fragment uri None |> Uri.to_string in
54
+
let url_without_fragment =
55
+
Uri.with_fragment uri None |> Uri.to_string
56
+
in
54
57
Some (Uri { url = url_without_fragment; branch })
55
58
| _ -> None
56
59
···
87
90
let parse content =
88
91
match Parsexp.Many.parse_string content with
89
92
| Error err ->
90
-
Error
91
-
(Printf.sprintf "S-expression parse error: %s"
92
-
(Parsexp.Parse_error.message err))
93
+
Error (Printf.sprintf "S-expression parse error: %s"
94
+
(Parsexp.Parse_error.message err))
93
95
| Ok sexps -> (
94
96
match find_string_field "name" sexps with
95
97
| None -> Error "dune-project missing (name ...) stanza"
···
110
112
111
113
(** Ensure URL ends with .git *)
112
114
let ensure_git_suffix url =
113
-
if String.ends_with ~suffix:".git" url then url else url ^ ".git"
115
+
if String.ends_with ~suffix:".git" url then url
116
+
else url ^ ".git"
114
117
115
118
let dev_repo_url t =
116
119
match t.source with
···
121
124
| Some (Tangled { host; repo }) ->
122
125
(* Tangled sources: https://tangled.sh/@handle/repo *)
123
126
Ok (Printf.sprintf "git+https://tangled.sh/@%s/%s.git" host repo)
124
-
| Some (Uri { url; _ }) -> Ok (normalize_git_url (ensure_git_suffix url))
127
+
| Some (Uri { url; _ }) ->
128
+
Ok (normalize_git_url (ensure_git_suffix url))
125
129
| None -> (
126
130
match t.homepage with
127
-
| Some homepage -> Ok (normalize_git_url (ensure_git_suffix homepage))
131
+
| Some homepage ->
132
+
Ok (normalize_git_url (ensure_git_suffix homepage))
128
133
| None ->
129
134
Error
130
135
(Printf.sprintf
+6
-7
lib/dune_project.mli
+6
-7
lib/dune_project.mli
···
1
1
(** Dune project file parsing.
2
2
3
-
Parse dune-project s-expressions to extract package metadata needed for
4
-
generating opam-repo entries. *)
3
+
Parse dune-project s-expressions to extract package metadata needed
4
+
for generating opam-repo entries. *)
5
5
6
6
(** Source information from dune-project. *)
7
7
type source_info =
···
10
10
| Tangled of { host : string; repo : string } (** tangled.sh style sources *)
11
11
| Uri of { url : string; branch : string option }
12
12
13
+
(** Parsed dune-project file. *)
13
14
type t = {
14
15
name : string; (** Project name from (name ...) stanza *)
15
16
source : source_info option; (** Source from (source ...) stanza *)
16
17
homepage : string option; (** Homepage from (homepage ...) stanza *)
17
18
packages : string list; (** Package names from (package (name ...)) stanzas *)
18
19
}
19
-
(** Parsed dune-project file. *)
20
20
21
21
val parse : string -> (t, string) result
22
22
(** [parse content] parses a dune-project file content and extracts metadata.
···
24
24
25
25
val dev_repo_url : t -> (string, string) result
26
26
(** [dev_repo_url t] derives the dev-repo URL from the parsed dune-project.
27
-
Returns a URL suitable for the opam dev-repo field (e.g.,
28
-
"git+https://...").
27
+
Returns a URL suitable for the opam dev-repo field (e.g., "git+https://...").
29
28
30
29
URL derivation logic:
31
30
- [Github {user; repo}] -> "git+https://github.com/user/repo.git"
···
35
34
- Neither source nor homepage -> Error *)
36
35
37
36
val url_with_branch : t -> (string, string) result
38
-
(** [url_with_branch t] derives the URL with branch fragment for the opam url
39
-
section. Returns a URL with #branch suffix (e.g., "git+https://...#main").
37
+
(** [url_with_branch t] derives the URL with branch fragment for the opam url section.
38
+
Returns a URL with #branch suffix (e.g., "git+https://...#main").
40
39
41
40
Branch derivation:
42
41
- [Uri {url; branch = Some b}] -> url#b
+26
-34
lib/feature.ml
+26
-34
lib/feature.ml
···
1
1
type error =
2
-
| Git_error of Git_cli.error
2
+
| Git_error of Git.error
3
3
| Feature_exists of string
4
4
| Feature_not_found of string
5
5
| Config_error of string
6
6
7
7
let pp_error ppf = function
8
-
| Git_error e -> Fmt.pf ppf "Git error: %a" Git_cli.pp_error e
8
+
| Git_error e -> Fmt.pf ppf "Git error: %a" Git.pp_error e
9
9
| Feature_exists name -> Fmt.pf ppf "Feature '%s' already exists" name
10
10
| Feature_not_found name -> Fmt.pf ppf "Feature '%s' not found" name
11
11
| Config_error msg -> Fmt.pf ppf "Configuration error: %s" msg
···
13
13
let error_hint = function
14
14
| Git_error _ -> Some "Check that the monorepo is properly initialized"
15
15
| Feature_exists name ->
16
-
Some
17
-
(Printf.sprintf
18
-
"Run 'monopam feature remove %s' first if you want to recreate it"
19
-
name)
16
+
Some (Printf.sprintf "Run 'monopam feature remove %s' first if you want to recreate it" name)
20
17
| Feature_not_found name ->
21
-
Some
22
-
(Printf.sprintf
23
-
"Run 'monopam feature list' to see available features, or 'monopam \
24
-
feature add %s' to create it"
25
-
name)
26
-
| Config_error _ ->
27
-
Some "Run 'monopam init' to create a workspace configuration"
18
+
Some (Printf.sprintf "Run 'monopam feature list' to see available features, or 'monopam feature add %s' to create it" name)
19
+
| Config_error _ -> Some "Run 'monopam init' to create a workspace configuration"
28
20
29
21
let pp_error_with_hint ppf e =
30
22
pp_error ppf e;
···
32
24
| Some hint -> Fmt.pf ppf "@.Hint: %s" hint
33
25
| None -> ()
34
26
35
-
type entry = { name : string; path : Fpath.t; branch : string }
27
+
type entry = {
28
+
name : string;
29
+
path : Fpath.t;
30
+
branch : string;
31
+
}
36
32
37
33
let pp_entry ppf e =
38
34
Fmt.pf ppf "%s -> %a (branch: %s)" e.name Fpath.pp e.path e.branch
···
48
44
let work_dir = work_path config in
49
45
let wt_path = feature_path config name in
50
46
(* Check if feature already exists *)
51
-
if Git_cli.Worktree.exists ~proc ~fs ~repo:mono ~path:wt_path then
47
+
if Git.Worktree.exists ~proc ~fs ~repo:mono ~path:wt_path then
52
48
Error (Feature_exists name)
53
49
else begin
54
50
(* Ensure work directory exists *)
55
51
let work_eio = Eio.Path.(fs / Fpath.to_string work_dir) in
56
52
(try Eio.Path.mkdirs ~perm:0o755 work_eio with Eio.Io _ -> ());
57
53
(* Create the worktree with a new branch *)
58
-
match
59
-
Git_cli.Worktree.add ~proc ~fs ~repo:mono ~path:wt_path ~branch:name ()
60
-
with
54
+
match Git.Worktree.add ~proc ~fs ~repo:mono ~path:wt_path ~branch:name () with
61
55
| Error e -> Error (Git_error e)
62
56
| Ok () -> Ok { name; path = wt_path; branch = name }
63
57
end
···
66
60
let mono = Verse_config.mono_path config in
67
61
let wt_path = feature_path config name in
68
62
(* Check if feature exists *)
69
-
if not (Git_cli.Worktree.exists ~proc ~fs ~repo:mono ~path:wt_path) then
63
+
if not (Git.Worktree.exists ~proc ~fs ~repo:mono ~path:wt_path) then
70
64
Error (Feature_not_found name)
71
65
else
72
-
match
73
-
Git_cli.Worktree.remove ~proc ~fs ~repo:mono ~path:wt_path ~force ()
74
-
with
66
+
match Git.Worktree.remove ~proc ~fs ~repo:mono ~path:wt_path ~force () with
75
67
| Error e -> Error (Git_error e)
76
68
| Ok () -> Ok ()
77
69
78
70
let list ~proc ~fs ~config () =
79
71
let mono = Verse_config.mono_path config in
80
72
let work_dir = work_path config in
81
-
let all_worktrees = Git_cli.Worktree.list ~proc ~fs mono in
73
+
let all_worktrees = Git.Worktree.list ~proc ~fs mono in
82
74
(* Filter to only worktrees under work/ directory *)
83
-
List.filter_map
84
-
(fun (wt : Git_cli.Worktree.entry) ->
85
-
(* Check if this worktree is under the work directory *)
86
-
let wt_str = Fpath.to_string wt.path in
87
-
let work_str = Fpath.to_string work_dir in
88
-
if String.starts_with ~prefix:work_str wt_str then
89
-
let name = Fpath.basename wt.path in
90
-
let branch = Option.value ~default:name wt.branch in
91
-
Some { name; path = wt.path; branch }
92
-
else None)
93
-
all_worktrees
75
+
List.filter_map (fun (wt : Git.Worktree.entry) ->
76
+
(* Check if this worktree is under the work directory *)
77
+
let wt_str = Fpath.to_string wt.path in
78
+
let work_str = Fpath.to_string work_dir in
79
+
if String.starts_with ~prefix:work_str wt_str then
80
+
let name = Fpath.basename wt.path in
81
+
let branch = Option.value ~default:name wt.branch in
82
+
Some { name; path = wt.path; branch }
83
+
else
84
+
None
85
+
) all_worktrees
+2
-2
lib/feature.mli
+2
-2
lib/feature.mli
···
7
7
8
8
(** Errors from feature operations. *)
9
9
type error =
10
-
| Git_error of Git_cli.error (** Git operation error *)
10
+
| Git_error of Git.error (** Git operation error *)
11
11
| Feature_exists of string (** Feature worktree already exists *)
12
12
| Feature_not_found of string (** Feature worktree does not exist *)
13
13
| Config_error of string (** Configuration error *)
···
18
18
val pp_error_with_hint : error Fmt.t
19
19
(** [pp_error_with_hint] formats errors with a helpful hint. *)
20
20
21
+
(** A feature worktree entry. *)
21
22
type entry = {
22
23
name : string; (** Feature name *)
23
24
path : Fpath.t; (** Path to the worktree *)
24
25
branch : string; (** Branch name *)
25
26
}
26
-
(** A feature worktree entry. *)
27
27
28
28
val pp_entry : entry Fmt.t
29
29
(** [pp_entry] formats a feature entry. *)
+383
-643
lib/fork_join.ml
+383
-643
lib/fork_join.ml
···
2
2
3
3
type error =
4
4
| Config_error of string
5
-
| Git_error of Git_cli.error
5
+
| Git_error of Git.error
6
6
| Subtree_not_found of string
7
7
| Src_already_exists of string
8
8
| Src_not_found of string
···
18
18
| Check_remote_exists of string (** URL - informational check *)
19
19
| Create_directory of Fpath.t
20
20
| Git_init of Fpath.t
21
-
| Git_config of { repo : Fpath.t; key : string; value : string }
22
-
(** Set git config *)
23
-
| Git_clone of { url : string; dest : Fpath.t; branch : string }
24
-
| Git_subtree_split of { repo : Fpath.t; prefix : string }
25
-
| Git_subtree_add of {
26
-
repo : Fpath.t;
27
-
prefix : string;
28
-
url : Uri.t;
29
-
branch : string;
30
-
}
31
-
| Git_add_remote of { repo : Fpath.t; name : string; url : string }
32
-
| Git_push_ref of { repo : Fpath.t; target : string; ref_spec : string }
33
-
| Git_checkout of { repo : Fpath.t; branch : string }
34
-
| Git_branch_rename of { repo : Fpath.t; new_name : string }
35
-
(** Rename current branch *)
36
-
| Copy_directory of { src : Fpath.t; dest : Fpath.t }
21
+
| Git_config of { repo: Fpath.t; key: string; value: string } (** Set git config *)
22
+
| Git_clone of { url: string; dest: Fpath.t; branch: string }
23
+
| Git_subtree_split of { repo: Fpath.t; prefix: string }
24
+
| Git_subtree_add of { repo: Fpath.t; prefix: string; url: Uri.t; branch: string }
25
+
| Git_add_remote of { repo: Fpath.t; name: string; url: string }
26
+
| Git_push_ref of { repo: Fpath.t; target: string; ref_spec: string }
27
+
| Git_checkout of { repo: Fpath.t; branch: string }
28
+
| Git_branch_rename of { repo: Fpath.t; new_name: string } (** Rename current branch *)
29
+
| Copy_directory of { src: Fpath.t; dest: Fpath.t }
37
30
| Git_add_all of Fpath.t
38
-
| Git_commit of { repo : Fpath.t; message : string }
39
-
| Git_rm of { repo : Fpath.t; path : string; recursive : bool }
40
-
(** Remove file/dir from git *)
41
-
| Update_sources_toml of {
42
-
path : Fpath.t;
43
-
name : string;
44
-
entry : Sources_registry.entry;
45
-
}
31
+
| Git_commit of { repo: Fpath.t; message: string }
32
+
| Git_rm of { repo: Fpath.t; path: string; recursive: bool } (** Remove file/dir from git *)
33
+
| Update_sources_toml of { path: Fpath.t; name: string; entry: Sources_registry.entry }
46
34
35
+
(** Discovery information gathered during planning *)
47
36
type discovery = {
48
-
mono_exists : bool;
49
-
src_exists : bool;
50
-
has_subtree_history : bool; (** Can we git subtree split? *)
51
-
remote_accessible : bool option; (** None = not checked, Some = result *)
52
-
opam_files : string list;
53
-
local_path_is_repo : bool option; (** For join from local dir *)
37
+
mono_exists: bool;
38
+
src_exists: bool;
39
+
has_subtree_history: bool; (** Can we git subtree split? *)
40
+
remote_accessible: bool option; (** None = not checked, Some = result *)
41
+
opam_files: string list;
42
+
local_path_is_repo: bool option; (** For join from local dir *)
54
43
}
55
-
(** Discovery information gathered during planning *)
56
44
45
+
(** A complete action plan *)
57
46
type 'a action_plan = {
58
-
discovery : discovery;
59
-
actions : action list;
60
-
result : 'a; (** What we'll return on success *)
61
-
dry_run : bool;
47
+
discovery: discovery;
48
+
actions: action list;
49
+
result: 'a; (** What we'll return on success *)
50
+
dry_run: bool;
62
51
}
63
-
(** A complete action plan *)
64
52
65
53
let pp_error ppf = function
66
54
| Config_error msg -> Fmt.pf ppf "Configuration error: %s" msg
67
-
| Git_error e -> Fmt.pf ppf "Git error: %a" Git_cli.pp_error e
68
-
| Subtree_not_found name ->
69
-
Fmt.pf ppf "Subtree not found in monorepo: %s" name
70
-
| Src_already_exists name ->
71
-
Fmt.pf ppf "Source checkout already exists: src/%s" name
55
+
| Git_error e -> Fmt.pf ppf "Git error: %a" Git.pp_error e
56
+
| Subtree_not_found name -> Fmt.pf ppf "Subtree not found in monorepo: %s" name
57
+
| Src_already_exists name -> Fmt.pf ppf "Source checkout already exists: src/%s" name
72
58
| Src_not_found name -> Fmt.pf ppf "Source checkout not found: src/%s" name
73
-
| Subtree_already_exists name ->
74
-
Fmt.pf ppf "Subtree already exists in monorepo: mono/%s" name
59
+
| Subtree_already_exists name -> Fmt.pf ppf "Subtree already exists in monorepo: mono/%s" name
75
60
| No_opam_files name -> Fmt.pf ppf "No .opam files found in subtree: %s" name
76
61
| Verse_error e -> Fmt.pf ppf "Verse error: %a" Verse.pp_error e
77
62
| User_cancelled -> Fmt.pf ppf "Operation cancelled by user"
···
79
64
let error_hint = function
80
65
| Config_error _ ->
81
66
Some "Run 'monopam init --handle <your-handle>' to create a workspace."
82
-
| Git_error (Git_cli.Dirty_worktree _) ->
67
+
| Git_error (Git.Dirty_worktree _) ->
83
68
Some "Commit or stash your changes first: git status"
84
69
| Git_error _ -> None
85
70
| Subtree_not_found name ->
86
71
Some (Fmt.str "Check that mono/%s exists in your monorepo" name)
87
72
| Src_already_exists name ->
88
-
Some
89
-
(Fmt.str "Remove or rename src/%s first, or choose a different name"
90
-
name)
73
+
Some (Fmt.str "Remove or rename src/%s first, or choose a different name" name)
91
74
| Src_not_found name ->
92
75
Some (Fmt.str "Run 'monopam fork %s' first to create src/%s" name name)
93
76
| Subtree_already_exists name ->
94
-
Some
95
-
(Fmt.str "Remove mono/%s first, or use a different name with --as" name)
77
+
Some (Fmt.str "Remove mono/%s first, or use a different name with --as" name)
96
78
| No_opam_files name ->
97
79
Some (Fmt.str "Add a .opam file to mono/%s before forking" name)
98
80
| Verse_error e -> Verse.error_hint e
···
101
83
(** {1 Pretty Printers for Actions and Discovery} *)
102
84
103
85
let pp_action ppf = function
104
-
| Check_remote_exists url -> Fmt.pf ppf "Check remote accessible: %s" url
105
-
| Create_directory path -> Fmt.pf ppf "Create directory: %a" Fpath.pp path
106
-
| Git_init path -> Fmt.pf ppf "Initialize git repository: %a" Fpath.pp path
86
+
| Check_remote_exists url ->
87
+
Fmt.pf ppf "Check remote accessible: %s" url
88
+
| Create_directory path ->
89
+
Fmt.pf ppf "Create directory: %a" Fpath.pp path
90
+
| Git_init path ->
91
+
Fmt.pf ppf "Initialize git repository: %a" Fpath.pp path
107
92
| Git_config { repo = _; key; value } ->
108
93
Fmt.pf ppf "Set git config %s = %s" key value
109
94
| Git_clone { url; dest; branch } ->
···
111
96
| Git_subtree_split { repo = _; prefix } ->
112
97
Fmt.pf ppf "Split subtree history for '%s'" prefix
113
98
| Git_subtree_add { repo = _; prefix; url; branch } ->
114
-
Fmt.pf ppf "Add subtree '%s' from %s (branch: %s)" prefix
115
-
(Uri.to_string url) branch
99
+
Fmt.pf ppf "Add subtree '%s' from %s (branch: %s)" prefix (Uri.to_string url) branch
116
100
| Git_add_remote { repo = _; name; url } ->
117
101
Fmt.pf ppf "Add remote '%s' -> %s" name url
118
102
| Git_push_ref { repo = _; target; ref_spec } ->
···
123
107
Fmt.pf ppf "Rename current branch to '%s'" new_name
124
108
| Copy_directory { src; dest } ->
125
109
Fmt.pf ppf "Copy files from %a to %a" Fpath.pp src Fpath.pp dest
126
-
| Git_add_all path -> Fmt.pf ppf "Stage all changes in %a" Fpath.pp path
127
-
| Git_commit { repo = _; message } -> Fmt.pf ppf "Create commit: %s" message
110
+
| Git_add_all path ->
111
+
Fmt.pf ppf "Stage all changes in %a" Fpath.pp path
112
+
| Git_commit { repo = _; message } ->
113
+
Fmt.pf ppf "Create commit: %s" message
128
114
| Git_rm { repo = _; path; recursive = _ } ->
129
115
Fmt.pf ppf "Remove '%s' from git" path
130
116
| Update_sources_toml { path = _; name; entry = _ } ->
···
139
125
Fmt.pf ppf " Subtree history: %s@,"
140
126
(if d.has_subtree_history then "present" else "none (fresh package)");
141
127
(match d.remote_accessible with
142
-
| None -> ()
143
-
| Some true -> Fmt.pf ppf " Remote accessible: yes@,"
144
-
| Some false -> Fmt.pf ppf " Remote accessible: no@,");
128
+
| None -> ()
129
+
| Some true -> Fmt.pf ppf " Remote accessible: yes@,"
130
+
| Some false -> Fmt.pf ppf " Remote accessible: no@,");
145
131
(match d.local_path_is_repo with
146
-
| None -> ()
147
-
| Some true -> Fmt.pf ppf " Is git repo: yes@,"
148
-
| Some false -> Fmt.pf ppf " Is git repo: no@,");
132
+
| None -> ()
133
+
| Some true -> Fmt.pf ppf " Is git repo: yes@,"
134
+
| Some false -> Fmt.pf ppf " Is git repo: no@,");
149
135
if d.opam_files <> [] then
150
-
Fmt.pf ppf " Packages found: %a@,"
151
-
Fmt.(list ~sep:(any ", ") string)
152
-
d.opam_files;
136
+
Fmt.pf ppf " Packages found: %a@," Fmt.(list ~sep:(any ", ") string) d.opam_files;
153
137
Fmt.pf ppf "@]"
154
138
155
-
let pp_action_plan : type a. a Fmt.t -> a action_plan Fmt.t =
156
-
fun pp_result ppf plan ->
157
-
Fmt.pf ppf "@[<v>Discovery:@,%a@,@,Actions to perform:@," pp_discovery
158
-
plan.discovery;
159
-
List.iteri
160
-
(fun i action -> Fmt.pf ppf " %d. %a@," (i + 1) pp_action action)
161
-
plan.actions;
162
-
if plan.dry_run then Fmt.pf ppf "@,(dry-run mode - no changes will be made)@,";
139
+
let pp_action_plan : type a. a Fmt.t -> a action_plan Fmt.t = fun pp_result ppf plan ->
140
+
Fmt.pf ppf "@[<v>Discovery:@,%a@,@,Actions to perform:@," pp_discovery plan.discovery;
141
+
List.iteri (fun i action ->
142
+
Fmt.pf ppf " %d. %a@," (i + 1) pp_action action
143
+
) plan.actions;
144
+
if plan.dry_run then
145
+
Fmt.pf ppf "@,(dry-run mode - no changes will be made)@,";
163
146
Fmt.pf ppf "@,Expected result:@, %a@]" pp_result plan.result
164
147
165
148
let pp_error_with_hint ppf e =
···
187
170
let pp_fork_result ppf (r : fork_result) =
188
171
(* Only truncate if it looks like a git SHA (40 hex chars), otherwise show full string *)
189
172
let commit_display =
190
-
if
191
-
String.length r.split_commit = 40
192
-
&& String.for_all
193
-
(fun c -> (c >= '0' && c <= '9') || (c >= 'a' && c <= 'f'))
194
-
r.split_commit
173
+
if String.length r.split_commit = 40 &&
174
+
String.for_all (fun c -> (c >= '0' && c <= '9') || (c >= 'a' && c <= 'f')) r.split_commit
195
175
then String.sub r.split_commit 0 7
196
176
else r.split_commit
197
177
in
198
178
Fmt.pf ppf "@[<v>Forked subtree '%s':@, Split commit: %s@, Local repo: %a@,"
199
179
r.name commit_display Fpath.pp r.src_path;
200
180
(match r.push_url with
201
-
| Some url -> Fmt.pf ppf " Push URL: %s@," url
202
-
| None -> ());
181
+
| Some url -> Fmt.pf ppf " Push URL: %s@," url
182
+
| None -> ());
203
183
if r.packages_created <> [] then
204
-
Fmt.pf ppf " Packages: %a@]"
205
-
Fmt.(list ~sep:(any ", ") string)
206
-
r.packages_created
207
-
else Fmt.pf ppf "@]"
184
+
Fmt.pf ppf " Packages: %a@]" Fmt.(list ~sep:(any ", ") string) r.packages_created
185
+
else
186
+
Fmt.pf ppf "@]"
208
187
209
188
let pp_join_result ppf (r : join_result) =
210
-
Fmt.pf ppf "@[<v>Joined repository '%s':@, Source: %s@," r.name r.source_url;
189
+
Fmt.pf ppf "@[<v>Joined repository '%s':@, Source: %s@,"
190
+
r.name r.source_url;
211
191
(match r.upstream_url with
212
-
| Some url -> Fmt.pf ppf " Upstream: %s@," url
213
-
| None -> ());
192
+
| Some url -> Fmt.pf ppf " Upstream: %s@," url
193
+
| None -> ());
214
194
(match r.from_handle with
215
-
| Some h -> Fmt.pf ppf " From verse: %s@," h
216
-
| None -> ());
195
+
| Some h -> Fmt.pf ppf " From verse: %s@," h
196
+
| None -> ());
217
197
if r.packages_added <> [] then
218
-
Fmt.pf ppf " Packages: %a@]"
219
-
Fmt.(list ~sep:(any ", ") string)
220
-
r.packages_added
221
-
else Fmt.pf ppf "@]"
198
+
Fmt.pf ppf " Packages: %a@]" Fmt.(list ~sep:(any ", ") string) r.packages_added
199
+
else
200
+
Fmt.pf ppf "@]"
222
201
223
202
(** Helper to check if a path is a directory *)
224
203
let is_directory ~fs path =
···
257
236
| Some "tangled.org" | Some "tangled.sh" -> true
258
237
| _ -> false
259
238
260
-
(** Convert a dev-repo URL to a push URL (SSH format for github/gitlab/tangled)
261
-
*)
239
+
(** Convert a dev-repo URL to a push URL (SSH format for github/gitlab/tangled) *)
262
240
let url_to_push_url ?knot url =
263
241
(* Strip git+ prefix if present *)
264
242
let url =
···
324
302
(* For SSH URLs like git@github.com:user/repo.git *)
325
303
if String.starts_with ~prefix:"git@" url then
326
304
match String.index_opt url ':' with
327
-
| Some i -> (
305
+
| Some i ->
328
306
let path = String.sub url (i + 1) (String.length url - i - 1) in
329
307
(* path is like "user/repo.git" or "handle/repo" *)
330
-
match String.index_opt path '/' with
331
-
| Some j ->
332
-
let user = String.sub path 0 j in
333
-
(* Handle may be like "avsm" or "avsm.bsky.social" - compare first component *)
334
-
let handle_first =
335
-
match String.index_opt handle '.' with
336
-
| Some k -> String.sub handle 0 k
337
-
| None -> handle
338
-
in
339
-
String.equal user handle_first || String.equal user handle
340
-
| None -> false)
308
+
(match String.index_opt path '/' with
309
+
| Some j ->
310
+
let user = String.sub path 0 j in
311
+
(* Handle may be like "avsm" or "avsm.bsky.social" - compare first component *)
312
+
let handle_first =
313
+
match String.index_opt handle '.' with
314
+
| Some k -> String.sub handle 0 k
315
+
| None -> handle
316
+
in
317
+
String.equal user handle_first || String.equal user handle
318
+
| None -> false)
341
319
| None -> false
342
320
else
343
321
(* For HTTPS URLs like https://github.com/user/repo.git *)
···
373
351
let content = Eio.Path.load eio_path in
374
352
match Dune_project.parse content with
375
353
| Error _ -> None
376
-
| Ok dune_proj -> (
354
+
| Ok dune_proj ->
377
355
match Dune_project.dev_repo_url dune_proj with
378
356
| Error _ -> None
379
-
| Ok dev_repo -> Some (url_to_push_url ?knot dev_repo))
357
+
| Ok dev_repo -> Some (url_to_push_url ?knot dev_repo)
380
358
with Eio.Io _ -> None
381
359
382
360
(** Extract name from URL (last path component without .git suffix) *)
···
384
362
let uri = Uri.of_string url in
385
363
let path = Uri.path uri in
386
364
(* Remove leading slash and .git suffix *)
387
-
let path =
388
-
if String.length path > 0 && path.[0] = '/' then
389
-
String.sub path 1 (String.length path - 1)
390
-
else path
391
-
in
392
-
let path =
393
-
if String.ends_with ~suffix:".git" path then
394
-
String.sub path 0 (String.length path - 4)
395
-
else path
396
-
in
365
+
let path = if String.length path > 0 && path.[0] = '/' then
366
+
String.sub path 1 (String.length path - 1)
367
+
else path in
368
+
let path = if String.ends_with ~suffix:".git" path then
369
+
String.sub path 0 (String.length path - 4)
370
+
else path in
397
371
(* Get last component *)
398
372
match String.rindex_opt path '/' with
399
373
| Some i -> String.sub path (i + 1) (String.length path - i - 1)
···
404
378
(** Determine if input is a local path or URL *)
405
379
let is_local_path s =
406
380
(* It's a URL if it starts with a scheme or looks like SSH URL *)
407
-
not
408
-
(String.starts_with ~prefix:"http://" s
409
-
|| String.starts_with ~prefix:"https://" s
410
-
|| String.starts_with ~prefix:"git://" s
411
-
|| String.starts_with ~prefix:"git@" s
412
-
|| String.starts_with ~prefix:"ssh://" s
413
-
|| String.starts_with ~prefix:"git+" s)
381
+
not (String.starts_with ~prefix:"http://" s ||
382
+
String.starts_with ~prefix:"https://" s ||
383
+
String.starts_with ~prefix:"git://" s ||
384
+
String.starts_with ~prefix:"git@" s ||
385
+
String.starts_with ~prefix:"ssh://" s ||
386
+
String.starts_with ~prefix:"git+" s)
414
387
415
388
(** Copy a directory tree recursively *)
416
389
let copy_directory ~fs ~src ~dest =
···
420
393
match Eio.Path.kind ~follow:false src_path with
421
394
| `Directory ->
422
395
(try Eio.Path.mkdirs ~perm:0o755 dest_path with Eio.Io _ -> ());
423
-
List.iter
424
-
(fun name ->
425
-
(* Skip .git directory to avoid copying git internals *)
426
-
if name <> ".git" then begin
427
-
let src_child = Eio.Path.(src_path / name) in
428
-
let dest_child = Eio.Path.(dest_path / name) in
429
-
copy_rec src_child dest_child
430
-
end)
431
-
(Eio.Path.read_dir src_path)
396
+
List.iter (fun name ->
397
+
(* Skip .git directory to avoid copying git internals *)
398
+
if name <> ".git" then begin
399
+
let src_child = Eio.Path.(src_path / name) in
400
+
let dest_child = Eio.Path.(dest_path / name) in
401
+
copy_rec src_child dest_child
402
+
end
403
+
) (Eio.Path.read_dir src_path)
432
404
| `Regular_file ->
433
405
let content = Eio.Path.load src_path in
434
406
Eio.Path.save ~create:(`Or_truncate 0o644) dest_path content
435
-
| `Symbolic_link -> (
407
+
| `Symbolic_link ->
436
408
(* Read symlink target and recreate it *)
437
409
let target = Eio.Path.read_link src_path in
438
-
try Unix.symlink target (snd dest_path) with _ -> ())
439
-
| _ -> () (* Skip other file types *)
410
+
(try Unix.symlink target (snd dest_path) with _ -> ())
411
+
| _ -> () (* Skip other file types *)
440
412
| exception _ -> ()
441
413
in
442
414
copy_rec src_eio dest_eio
···
445
417
446
418
(** Build a fork plan - handles both subtree and fresh package scenarios.
447
419
448
-
The fork workflow: 1. Create src/<name>/ with the package content (split or
449
-
copy) 2. Remove mono/<name>/ from git 3. Re-add mono/<name>/ as a proper
450
-
subtree from src/<name>/
420
+
The fork workflow:
421
+
1. Create src/<name>/ with the package content (split or copy)
422
+
2. Remove mono/<name>/ from git
423
+
3. Re-add mono/<name>/ as a proper subtree from src/<name>/
451
424
452
425
This ensures the subtree relationship is properly established for sync. *)
453
426
let plan_fork ~proc ~fs ~config ~name ?push_url ?(dry_run = false) () =
···
459
432
let branch = Verse_config.default_branch in
460
433
461
434
(* Gather discovery information *)
462
-
let mono_exists = Git_cli.subtree_prefix_exists ~fs ~repo:monorepo ~prefix in
435
+
let mono_exists = Git.Subtree.exists ~fs ~repo:monorepo ~prefix in
463
436
let src_exists = is_directory ~fs src_path in
464
437
let has_subtree_hist =
465
-
if mono_exists then
466
-
Git_cli.has_subtree_history ~proc ~fs ~repo:monorepo ~prefix ()
438
+
if mono_exists then Git.has_subtree_history ~proc ~fs ~repo:monorepo ~prefix ()
467
439
else false
468
440
in
469
441
let opam_files =
470
-
if mono_exists then find_opam_files ~fs subtree_path else []
442
+
if mono_exists then find_opam_files ~fs subtree_path
443
+
else []
471
444
in
472
445
473
-
let discovery =
474
-
{
475
-
mono_exists;
476
-
src_exists;
477
-
has_subtree_history = has_subtree_hist;
478
-
remote_accessible = None;
479
-
(* Could check if push_url is accessible *)
480
-
opam_files;
481
-
local_path_is_repo = None;
482
-
}
483
-
in
446
+
let discovery = {
447
+
mono_exists;
448
+
src_exists;
449
+
has_subtree_history = has_subtree_hist;
450
+
remote_accessible = None; (* Could check if push_url is accessible *)
451
+
opam_files;
452
+
local_path_is_repo = None;
453
+
} in
484
454
485
455
(* Validation *)
486
-
if not mono_exists then Error (Subtree_not_found name)
487
-
else if src_exists then Error (Src_already_exists name)
488
-
else if opam_files = [] then Error (No_opam_files name)
456
+
if not mono_exists then
457
+
Error (Subtree_not_found name)
458
+
else if src_exists then
459
+
Error (Src_already_exists name)
460
+
else if opam_files = [] then
461
+
Error (No_opam_files name)
489
462
else begin
490
463
(* Build actions for complete fork workflow:
491
464
1. Create src/<name>/ with content
···
499
472
Git_subtree_split { repo = monorepo; prefix };
500
473
Git_init src_path;
501
474
(* Allow pushing to checked-out branch (for monopam sync) *)
502
-
Git_config
503
-
{
504
-
repo = src_path;
505
-
key = "receive.denyCurrentBranch";
506
-
value = "updateInstead";
507
-
};
508
-
Git_add_remote
509
-
{ repo = src_path; name = "mono"; url = Fpath.to_string monorepo };
510
-
Git_push_ref
511
-
{
512
-
repo = monorepo;
513
-
target = Fpath.to_string src_path;
514
-
ref_spec = "SPLIT_COMMIT:refs/heads/main";
515
-
};
475
+
Git_config { repo = src_path; key = "receive.denyCurrentBranch"; value = "updateInstead" };
476
+
Git_add_remote { repo = src_path; name = "mono"; url = Fpath.to_string monorepo };
477
+
Git_push_ref { repo = monorepo; target = Fpath.to_string src_path; ref_spec = "SPLIT_COMMIT:refs/heads/main" };
516
478
Git_checkout { repo = src_path; branch };
517
479
]
518
480
else
···
522
484
Create_directory src_path;
523
485
Git_init src_path;
524
486
(* Allow pushing to checked-out branch (for monopam sync) *)
525
-
Git_config
526
-
{
527
-
repo = src_path;
528
-
key = "receive.denyCurrentBranch";
529
-
value = "updateInstead";
530
-
};
487
+
Git_config { repo = src_path; key = "receive.denyCurrentBranch"; value = "updateInstead" };
531
488
Git_branch_rename { repo = src_path; new_name = branch };
532
489
Copy_directory { src = subtree_path; dest = src_path };
533
490
Git_add_all src_path;
534
-
Git_commit
535
-
{ repo = src_path; message = Fmt.str "Initial commit of %s" name };
491
+
Git_commit { repo = src_path; message = Fmt.str "Initial commit of %s" name };
536
492
]
537
493
in
538
494
539
495
(* Add remote if push_url provided *)
540
-
let remote_actions =
541
-
match push_url with
496
+
let remote_actions = match push_url with
542
497
| Some url -> [ Git_add_remote { repo = src_path; name = "origin"; url } ]
543
498
| None -> []
544
499
in
545
500
546
501
(* Remove from mono and re-add as subtree *)
547
-
let rejoin_actions =
548
-
[
549
-
Git_rm { repo = monorepo; path = prefix; recursive = true };
550
-
Git_commit
551
-
{ repo = monorepo; message = Fmt.str "Remove %s for fork" name };
552
-
Git_subtree_add
553
-
{
554
-
repo = monorepo;
555
-
prefix;
556
-
url = Uri.of_string (Fpath.to_string src_path);
557
-
branch;
558
-
};
559
-
]
560
-
in
502
+
let rejoin_actions = [
503
+
Git_rm { repo = monorepo; path = prefix; recursive = true };
504
+
Git_commit { repo = monorepo; message = Fmt.str "Remove %s for fork" name };
505
+
Git_subtree_add { repo = monorepo; prefix; url = Uri.of_string (Fpath.to_string src_path); branch };
506
+
] in
561
507
562
508
(* Update sources.toml only if push_url is a true fork (different namespace) *)
563
509
let handle = Verse_config.handle config in
564
-
let sources_actions =
565
-
match push_url with
566
-
| Some url when not (is_own_namespace ~handle url) ->
567
-
[
568
-
Update_sources_toml
569
-
{
570
-
path = Fpath.(monorepo / "sources.toml");
571
-
name;
572
-
entry =
573
-
Sources_registry.
574
-
{
575
-
url = normalize_git_url url;
576
-
upstream = None;
577
-
branch = Some branch;
578
-
reason = None;
579
-
origin = Some Fork;
580
-
};
581
-
};
582
-
]
583
-
| Some _ -> [] (* Own namespace - no sources.toml entry needed *)
510
+
let sources_actions = match push_url with
511
+
| Some url when not (is_own_namespace ~handle url) -> [
512
+
Update_sources_toml {
513
+
path = Fpath.(monorepo / "sources.toml");
514
+
name;
515
+
entry = Sources_registry.{
516
+
url = normalize_git_url url;
517
+
upstream = None;
518
+
branch = Some branch;
519
+
reason = None;
520
+
origin = Some Fork;
521
+
};
522
+
};
523
+
]
524
+
| Some _ -> [] (* Own namespace - no sources.toml entry needed *)
584
525
| None -> []
585
526
in
586
527
587
-
let actions =
588
-
create_src_actions @ remote_actions @ rejoin_actions @ sources_actions
589
-
in
528
+
let actions = create_src_actions @ remote_actions @ rejoin_actions @ sources_actions in
590
529
591
-
let result =
592
-
{
593
-
name;
594
-
split_commit =
595
-
(if has_subtree_hist then "(will be computed)" else "(fresh package)");
596
-
src_path;
597
-
push_url;
598
-
packages_created = opam_files;
599
-
}
600
-
in
530
+
let result = {
531
+
name;
532
+
split_commit = if has_subtree_hist then "(will be computed)" else "(fresh package)";
533
+
src_path;
534
+
push_url;
535
+
packages_created = opam_files;
536
+
} in
601
537
602
538
Ok { discovery; actions; result; dry_run }
603
539
end
···
612
548
let src_path = Fpath.(checkouts / name) in
613
549
614
550
(* Gather discovery information *)
615
-
let subtree_exists =
616
-
Git_cli.subtree_prefix_exists ~fs ~repo:monorepo ~prefix
617
-
in
551
+
let subtree_exists = Git.Subtree.exists ~fs ~repo:monorepo ~prefix in
618
552
let src_exists = is_directory ~fs src_path in
619
553
let local_is_repo =
620
554
if is_local then begin
621
555
match Fpath.of_string source with
622
-
| Ok path -> Some (Git_cli.is_repo ~proc ~fs path)
556
+
| Ok path -> Some (Git.is_repo ~proc ~fs path)
623
557
| Error _ -> Some false
624
-
end
625
-
else None
558
+
end else None
626
559
in
627
560
628
-
let discovery =
629
-
{
630
-
mono_exists = subtree_exists;
631
-
src_exists;
632
-
has_subtree_history = false;
633
-
remote_accessible = None;
634
-
opam_files = [];
635
-
(* Will be discovered after join *)
636
-
local_path_is_repo = local_is_repo;
637
-
}
638
-
in
561
+
let discovery = {
562
+
mono_exists = subtree_exists;
563
+
src_exists;
564
+
has_subtree_history = false;
565
+
remote_accessible = None;
566
+
opam_files = []; (* Will be discovered after join *)
567
+
local_path_is_repo = local_is_repo;
568
+
} in
639
569
640
570
(* Validation *)
641
-
if subtree_exists then Error (Subtree_already_exists name)
571
+
if subtree_exists then
572
+
Error (Subtree_already_exists name)
642
573
else begin
643
574
let branch = Verse_config.default_branch in
644
575
let actions =
···
653
584
[
654
585
Create_directory checkouts;
655
586
Copy_directory { src = local_path; dest = src_path };
656
-
Git_subtree_add
657
-
{
658
-
repo = monorepo;
659
-
prefix;
660
-
url = Uri.of_string (Fpath.to_string src_path);
661
-
branch;
662
-
};
587
+
Git_subtree_add { repo = monorepo; prefix; url = Uri.of_string (Fpath.to_string src_path); branch };
663
588
]
664
589
else
665
590
(* Local directory without git - init and commit first *)
···
669
594
Git_init src_path;
670
595
Copy_directory { src = local_path; dest = src_path };
671
596
Git_add_all src_path;
672
-
Git_commit
673
-
{
674
-
repo = src_path;
675
-
message = Fmt.str "Initial commit of %s" name;
676
-
};
677
-
Git_branch_rename { repo = src_path; new_name = branch };
678
-
(* Ensure branch is named correctly *)
679
-
Git_subtree_add
680
-
{
681
-
repo = monorepo;
682
-
prefix;
683
-
url = Uri.of_string (Fpath.to_string src_path);
684
-
branch;
685
-
};
597
+
Git_commit { repo = src_path; message = Fmt.str "Initial commit of %s" name };
598
+
Git_branch_rename { repo = src_path; new_name = branch }; (* Ensure branch is named correctly *)
599
+
Git_subtree_add { repo = monorepo; prefix; url = Uri.of_string (Fpath.to_string src_path); branch };
686
600
]
687
-
end
688
-
else begin
601
+
end else begin
689
602
(* Join from URL (existing behavior) *)
690
603
let url_uri = Uri.of_string source in
691
-
let base_actions =
692
-
[
693
-
Create_directory checkouts;
694
-
Git_clone { url = source; dest = src_path; branch };
695
-
Git_subtree_add { repo = monorepo; prefix; url = url_uri; branch };
696
-
]
697
-
in
698
-
let sources_actions =
699
-
match upstream with
604
+
let base_actions = [
605
+
Create_directory checkouts;
606
+
Git_clone { url = source; dest = src_path; branch };
607
+
Git_subtree_add { repo = monorepo; prefix; url = url_uri; branch };
608
+
] in
609
+
let sources_actions = match upstream with
700
610
| Some _ ->
701
-
[
702
-
Update_sources_toml
703
-
{
704
-
path = Fpath.(monorepo / "sources.toml");
705
-
name;
706
-
entry =
707
-
Sources_registry.
708
-
{
709
-
url = normalize_git_url source;
710
-
upstream = Option.map normalize_git_url upstream;
711
-
branch = Some branch;
712
-
reason = None;
713
-
origin = Some Join;
714
-
};
715
-
};
716
-
]
611
+
[Update_sources_toml {
612
+
path = Fpath.(monorepo / "sources.toml");
613
+
name;
614
+
entry = Sources_registry.{
615
+
url = normalize_git_url source;
616
+
upstream = Option.map normalize_git_url upstream;
617
+
branch = Some branch;
618
+
reason = None;
619
+
origin = Some Join;
620
+
};
621
+
}]
717
622
| None -> []
718
623
in
719
624
base_actions @ sources_actions
···
729
634
else []
730
635
in
731
636
732
-
let result =
733
-
{
734
-
name;
735
-
source_url = source;
736
-
upstream_url = upstream;
737
-
packages_added = opam_preview;
738
-
from_handle = None;
739
-
}
740
-
in
637
+
let result = {
638
+
name;
639
+
source_url = source;
640
+
upstream_url = upstream;
641
+
packages_added = opam_preview;
642
+
from_handle = None;
643
+
} in
741
644
742
-
Ok
743
-
{
744
-
discovery = { discovery with opam_files = opam_preview };
745
-
actions;
746
-
result;
747
-
dry_run;
748
-
}
645
+
Ok { discovery = { discovery with opam_files = opam_preview }; actions; result; dry_run }
749
646
end
750
647
751
648
(** Build a rejoin plan - add existing src/<name> back into mono/<name> *)
···
756
653
let src_path = Fpath.(checkouts / name) in
757
654
758
655
(* Gather discovery information *)
759
-
let subtree_exists =
760
-
Git_cli.subtree_prefix_exists ~fs ~repo:monorepo ~prefix
761
-
in
656
+
let subtree_exists = Git.Subtree.exists ~fs ~repo:monorepo ~prefix in
762
657
let src_exists = is_directory ~fs src_path in
763
-
let src_is_repo =
764
-
if src_exists then Git_cli.is_repo ~proc ~fs src_path else false
765
-
in
658
+
let src_is_repo = if src_exists then Git.is_repo ~proc ~fs src_path else false in
766
659
let opam_files = if src_exists then find_opam_files ~fs src_path else [] in
767
660
768
-
let discovery =
769
-
{
770
-
mono_exists = subtree_exists;
771
-
src_exists;
772
-
has_subtree_history = false;
773
-
remote_accessible = None;
774
-
opam_files;
775
-
local_path_is_repo = Some src_is_repo;
776
-
}
777
-
in
661
+
let discovery = {
662
+
mono_exists = subtree_exists;
663
+
src_exists;
664
+
has_subtree_history = false;
665
+
remote_accessible = None;
666
+
opam_files;
667
+
local_path_is_repo = Some src_is_repo;
668
+
} in
778
669
779
670
(* Validation *)
780
-
if subtree_exists then Error (Subtree_already_exists name)
781
-
else if not src_exists then Error (Src_not_found name)
671
+
if subtree_exists then
672
+
Error (Subtree_already_exists name)
673
+
else if not src_exists then
674
+
Error (Src_not_found name)
782
675
else if not src_is_repo then
783
-
Error
784
-
(Config_error (Fmt.str "src/%s exists but is not a git repository" name))
676
+
Error (Config_error (Fmt.str "src/%s exists but is not a git repository" name))
785
677
else begin
786
678
let branch = Verse_config.default_branch in
787
-
let actions =
788
-
[
789
-
Git_subtree_add
790
-
{
791
-
repo = monorepo;
792
-
prefix;
793
-
url = Uri.of_string (Fpath.to_string src_path);
794
-
branch;
795
-
};
796
-
]
797
-
in
679
+
let actions = [
680
+
Git_subtree_add { repo = monorepo; prefix; url = Uri.of_string (Fpath.to_string src_path); branch };
681
+
] in
798
682
799
-
let result =
800
-
{
801
-
name;
802
-
source_url = Fpath.to_string src_path;
803
-
upstream_url = None;
804
-
packages_added = opam_files;
805
-
from_handle = None;
806
-
}
807
-
in
683
+
let result = {
684
+
name;
685
+
source_url = Fpath.to_string src_path;
686
+
upstream_url = None;
687
+
packages_added = opam_files;
688
+
from_handle = None;
689
+
} in
808
690
809
691
Ok { discovery; actions; result; dry_run }
810
692
end
811
693
812
694
(** {1 Plan Execution} *)
813
695
814
-
type exec_state = { mutable split_commit : string option }
815
696
(** State tracked during plan execution *)
697
+
type exec_state = {
698
+
mutable split_commit: string option;
699
+
}
816
700
817
701
(** Execute a single action *)
818
702
let execute_action ~proc ~fs ~state action =
···
824
708
ensure_dir ~fs path;
825
709
Ok ()
826
710
| Git_init path ->
827
-
Git_cli.init ~proc ~fs path |> Result.map_error (fun e -> Git_error e)
711
+
Git.init ~proc ~fs path |> Result.map_error (fun e -> Git_error e)
828
712
| Git_config { repo; key; value } ->
829
-
Git_cli.config ~proc ~fs ~key ~value repo
830
-
|> Result.map_error (fun e -> Git_error e)
713
+
Git.config ~proc ~fs ~key ~value repo |> Result.map_error (fun e -> Git_error e)
831
714
| Git_clone { url; dest; branch } ->
832
-
Git_cli.clone ~proc ~fs ~url:(Uri.of_string url) ~branch dest
715
+
Git.clone ~proc ~fs ~url:(Uri.of_string url) ~branch dest
833
716
|> Result.map_error (fun e -> Git_error e)
834
-
| Git_subtree_split { repo; prefix } -> (
835
-
let repo_path = Fpath.to_string repo in
836
-
let git_repo = Git.Repository.open_repo ~fs repo_path in
837
-
match Git.Repository.read_ref git_repo "HEAD" with
838
-
| None -> Error (Git_error (Git_cli.Io_error "no HEAD ref found"))
839
-
| Some head -> (
840
-
match Git.Subtree.split git_repo ~prefix ~head () with
841
-
| Ok None -> Error (Git_error (Git_cli.Subtree_prefix_missing prefix))
842
-
| Error (`Msg msg) -> Error (Git_error (Git_cli.Io_error msg))
843
-
| Ok (Some split_hash) ->
844
-
state.split_commit <- Some (Git.Hash.to_hex split_hash);
845
-
Ok ()))
846
-
| Git_subtree_add { repo; prefix; url; branch } -> (
847
-
(* Fetch the branch first to get the commit *)
848
-
match Git_cli.fetch_url ~proc ~fs ~repo ~url ~branch () with
849
-
| Error e -> Error (Git_error e)
850
-
| Ok hash_hex -> (
851
-
let repo_path = Fpath.to_string repo in
852
-
let git_repo = Git.Repository.open_repo ~fs repo_path in
853
-
let commit = Git.Hash.of_hex hash_hex in
854
-
let user =
855
-
Git.User.make ~name:"monopam" ~email:"monopam@localhost"
856
-
~date:(Int64.of_float (Unix.time ()))
857
-
()
858
-
in
859
-
let message =
860
-
Fmt.str "Add '%s' from %s\n\ngit-subtree-dir: %s\n" prefix
861
-
(Uri.to_string url) prefix
862
-
in
863
-
match
864
-
Git.Subtree.add git_repo ~prefix ~commit ~author:user
865
-
~committer:user ~message ()
866
-
with
867
-
| Ok _ -> Ok ()
868
-
| Error (`Msg msg) -> Error (Git_error (Git_cli.Io_error msg))))
717
+
| Git_subtree_split { repo; prefix } ->
718
+
Git.Subtree.split ~proc ~fs ~repo ~prefix ()
719
+
|> Result.map (fun commit -> state.split_commit <- Some commit)
720
+
|> Result.map_error (fun e -> Git_error e)
721
+
| Git_subtree_add { repo; prefix; url; branch } ->
722
+
Git.Subtree.add ~proc ~fs ~repo ~prefix ~url ~branch ()
723
+
|> Result.map_error (fun e -> Git_error e)
869
724
| Git_add_remote { repo; name; url } ->
870
-
Git_cli.add_remote ~proc ~fs ~name ~url repo
725
+
Git.add_remote ~proc ~fs ~name ~url repo
871
726
|> Result.map_error (fun e -> Git_error e)
872
727
| Git_push_ref { repo; target; ref_spec } ->
873
728
(* Replace SPLIT_COMMIT placeholder with actual commit if available *)
874
729
let ref_spec =
875
730
match state.split_commit with
876
-
| Some commit ->
877
-
String.concat ""
878
-
(String.split_on_char 'S'
879
-
(String.concat commit (String.split_on_char 'S' ref_spec)))
880
-
|> fun s ->
881
-
if String.starts_with ~prefix:"PLIT_COMMIT" s then
882
-
Option.value ~default:ref_spec state.split_commit
883
-
^ String.sub s 11 (String.length s - 11)
884
-
else s
731
+
| Some commit -> String.concat "" (String.split_on_char 'S' (String.concat commit (String.split_on_char 'S' ref_spec)))
732
+
|> fun s -> if String.starts_with ~prefix:"PLIT_COMMIT" s then
733
+
Option.value ~default:ref_spec state.split_commit ^ String.sub s 11 (String.length s - 11)
734
+
else s
885
735
| None -> ref_spec
886
736
in
887
737
(* Better replacement: look for SPLIT_COMMIT literal *)
888
738
let ref_spec =
889
739
match state.split_commit with
890
740
| Some commit ->
891
-
if
892
-
String.length ref_spec >= 12
893
-
&& String.sub ref_spec 0 12 = "SPLIT_COMMIT"
894
-
then commit ^ String.sub ref_spec 12 (String.length ref_spec - 12)
741
+
if String.length ref_spec >= 12 && String.sub ref_spec 0 12 = "SPLIT_COMMIT" then
742
+
commit ^ String.sub ref_spec 12 (String.length ref_spec - 12)
895
743
else ref_spec
896
744
| None -> ref_spec
897
745
in
898
-
Git_cli.push_ref ~proc ~fs ~repo ~target ~ref_spec ()
746
+
Git.push_ref ~proc ~fs ~repo ~target ~ref_spec ()
899
747
|> Result.map_error (fun e -> Git_error e)
900
748
| Git_checkout { repo; branch } ->
901
-
Git_cli.checkout ~proc ~fs ~branch repo
749
+
Git.checkout ~proc ~fs ~branch repo
902
750
|> Result.map_error (fun e -> Git_error e)
903
751
| Git_branch_rename { repo; new_name } ->
904
-
Git_cli.branch_rename ~proc ~fs ~new_name repo
752
+
Git.branch_rename ~proc ~fs ~new_name repo
905
753
|> Result.map_error (fun e -> Git_error e)
906
754
| Copy_directory { src; dest } ->
907
755
copy_directory ~fs ~src ~dest;
908
756
Ok ()
909
757
| Git_add_all path ->
910
-
Git_cli.add_all ~proc ~fs path |> Result.map_error (fun e -> Git_error e)
758
+
Git.add_all ~proc ~fs path
759
+
|> Result.map_error (fun e -> Git_error e)
911
760
| Git_commit { repo; message } ->
912
-
Git_cli.commit ~proc ~fs ~message repo
761
+
Git.commit ~proc ~fs ~message repo
913
762
|> Result.map_error (fun e -> Git_error e)
914
763
| Git_rm { repo; path; recursive } ->
915
-
Git_cli.rm ~proc ~fs ~recursive repo path
764
+
Git.rm ~proc ~fs ~recursive repo path
916
765
|> Result.map_error (fun e -> Git_error e)
917
-
| Update_sources_toml { path; name; entry } -> (
766
+
| Update_sources_toml { path; name; entry } ->
918
767
let sources =
919
768
match Sources_registry.load ~fs:(fs :> _ Eio.Path.t) path with
920
769
| Ok s -> s
921
770
| Error _ -> Sources_registry.empty
922
771
in
923
772
let sources = Sources_registry.add sources ~subtree:name entry in
924
-
match Sources_registry.save ~fs:(fs :> _ Eio.Path.t) path sources with
925
-
| Ok () -> Ok ()
926
-
| Error msg ->
927
-
Error (Config_error (Fmt.str "Failed to update sources.toml: %s" msg))
928
-
)
773
+
(match Sources_registry.save ~fs:(fs :> _ Eio.Path.t) path sources with
774
+
| Ok () -> Ok ()
775
+
| Error msg -> Error (Config_error (Fmt.str "Failed to update sources.toml: %s" msg)))
929
776
930
777
(** Execute a complete fork action plan *)
931
778
let execute_fork_plan ~proc ~fs plan =
932
-
if plan.dry_run then Ok plan.result
779
+
if plan.dry_run then
780
+
Ok plan.result
933
781
else begin
934
782
let state = { split_commit = None } in
935
783
let rec run_actions = function
936
784
| [] -> Ok ()
937
-
| action :: rest -> (
785
+
| action :: rest ->
938
786
match execute_action ~proc ~fs ~state action with
939
787
| Error e -> Error e
940
-
| Ok () -> run_actions rest)
788
+
| Ok () -> run_actions rest
941
789
in
942
790
match run_actions plan.actions with
943
791
| Error e -> Error e
···
953
801
954
802
(** Execute a complete join action plan *)
955
803
let execute_join_plan ~proc ~fs plan =
956
-
if plan.dry_run then Ok plan.result
804
+
if plan.dry_run then
805
+
Ok plan.result
957
806
else begin
958
807
let state = { split_commit = None } in
959
808
let rec run_actions = function
960
809
| [] -> Ok ()
961
-
| action :: rest -> (
810
+
| action :: rest ->
962
811
match execute_action ~proc ~fs ~state action with
963
812
| Error e -> Error e
964
-
| Ok () -> run_actions rest)
813
+
| Ok () -> run_actions rest
965
814
in
966
815
match run_actions plan.actions with
967
816
| Error e -> Error e
···
977
826
let subtree_path = Fpath.(monorepo / prefix) in
978
827
let src_path = Fpath.(checkouts / name) in
979
828
(* Validate: mono/<name>/ must exist *)
980
-
if not (Git_cli.subtree_prefix_exists ~fs ~repo:monorepo ~prefix) then
981
-
Error (Subtree_not_found name) (* Validate: src/<name>/ must not exist *)
982
-
else if is_directory ~fs src_path then Error (Src_already_exists name)
829
+
if not (Git.Subtree.exists ~fs ~repo:monorepo ~prefix) then
830
+
Error (Subtree_not_found name)
831
+
(* Validate: src/<name>/ must not exist *)
832
+
else if is_directory ~fs src_path then
833
+
Error (Src_already_exists name)
983
834
else begin
984
835
(* Find .opam files in subtree *)
985
836
let packages = find_opam_files ~fs subtree_path in
986
-
if packages = [] then Error (No_opam_files name)
837
+
if packages = [] then
838
+
Error (No_opam_files name)
987
839
else if dry_run then
988
-
Ok
989
-
{
990
-
name;
991
-
split_commit = "(dry-run)";
992
-
src_path;
993
-
push_url;
994
-
packages_created = packages;
995
-
}
840
+
Ok { name; split_commit = "(dry-run)"; src_path; push_url; packages_created = packages }
996
841
else begin
997
842
(* Split the subtree to get history *)
998
-
let repo_path = Fpath.to_string monorepo in
999
-
let git_repo = Git.Repository.open_repo ~fs repo_path in
1000
-
match Git.Repository.read_ref git_repo "HEAD" with
1001
-
| None -> Error (Git_error (Git_cli.Io_error "no HEAD ref found"))
1002
-
| Some head -> (
1003
-
match Git.Subtree.split git_repo ~prefix ~head () with
1004
-
| Ok None -> Error (Git_error (Git_cli.Subtree_prefix_missing prefix))
1005
-
| Error (`Msg msg) -> Error (Git_error (Git_cli.Io_error msg))
1006
-
| Ok (Some split_hash) -> (
1007
-
let split_commit = Git.Hash.to_hex split_hash in
1008
-
(* Ensure src/ exists *)
1009
-
ensure_dir ~fs checkouts;
1010
-
(* Initialize new git repo at src/<name>/ *)
1011
-
match Git_cli.init ~proc ~fs src_path with
1012
-
| Error e -> Error (Git_error e)
1013
-
| Ok () -> (
1014
-
(* Add 'origin' remote pointing to monorepo path temporarily *)
1015
-
let mono_str = Fpath.to_string monorepo in
1016
-
match
1017
-
Git_cli.add_remote ~proc ~fs ~name:"mono" ~url:mono_str
1018
-
src_path
1019
-
with
1020
-
| Error e -> Error (Git_error e)
1021
-
| Ok () -> (
1022
-
(* Push split commit to local repo *)
1023
-
let ref_spec = split_commit ^ ":refs/heads/main" in
1024
-
match
1025
-
Git_cli.push_ref ~proc ~fs ~repo:monorepo
1026
-
~target:(Fpath.to_string src_path) ~ref_spec ()
1027
-
with
1028
-
| Error e -> Error (Git_error e)
1029
-
| Ok () -> (
1030
-
(* Checkout main branch *)
1031
-
match
1032
-
Git_cli.checkout ~proc ~fs ~branch:"main" src_path
1033
-
with
1034
-
| Error e -> Error (Git_error e)
1035
-
| Ok () -> (
1036
-
(* Set push URL if provided *)
1037
-
let push_result =
1038
-
match push_url with
1039
-
| Some url -> (
1040
-
match
1041
-
Git_cli.add_remote ~proc ~fs
1042
-
~name:"origin" ~url src_path
1043
-
with
1044
-
| Error e -> Error (Git_error e)
1045
-
| Ok () -> Ok ())
1046
-
| None -> Ok ()
1047
-
in
1048
-
match push_result with
1049
-
| Error _ as e -> e
1050
-
| Ok () ->
1051
-
(* Only update sources.toml if there's a push URL *)
1052
-
(match push_url with
1053
-
| Some url -> (
1054
-
let sources_path =
1055
-
Fpath.(monorepo / "sources.toml")
1056
-
in
1057
-
let sources =
1058
-
match
1059
-
Sources_registry.load
1060
-
~fs:(fs :> _ Eio.Path.t)
1061
-
sources_path
1062
-
with
1063
-
| Ok s -> s
1064
-
| Error _ -> Sources_registry.empty
1065
-
in
1066
-
let entry =
1067
-
Sources_registry.
1068
-
{
1069
-
url = normalize_git_url url;
1070
-
upstream = None;
1071
-
branch = Some "main";
1072
-
reason = None;
1073
-
origin = Some Fork;
1074
-
}
1075
-
in
1076
-
let sources =
1077
-
Sources_registry.add sources
1078
-
~subtree:name entry
1079
-
in
1080
-
match
1081
-
Sources_registry.save
1082
-
~fs:(fs :> _ Eio.Path.t)
1083
-
sources_path sources
1084
-
with
843
+
match Git.Subtree.split ~proc ~fs ~repo:monorepo ~prefix () with
844
+
| Error e -> Error (Git_error e)
845
+
| Ok split_commit ->
846
+
(* Ensure src/ exists *)
847
+
ensure_dir ~fs checkouts;
848
+
(* Initialize new git repo at src/<name>/ *)
849
+
match Git.init ~proc ~fs src_path with
850
+
| Error e -> Error (Git_error e)
851
+
| Ok () ->
852
+
(* Add 'origin' remote pointing to monorepo path temporarily *)
853
+
let mono_str = Fpath.to_string monorepo in
854
+
(match Git.add_remote ~proc ~fs ~name:"mono" ~url:mono_str src_path with
855
+
| Error e -> Error (Git_error e)
856
+
| Ok () ->
857
+
(* Push split commit to local repo *)
858
+
let ref_spec = split_commit ^ ":refs/heads/main" in
859
+
match Git.push_ref ~proc ~fs ~repo:monorepo ~target:(Fpath.to_string src_path) ~ref_spec () with
860
+
| Error e -> Error (Git_error e)
861
+
| Ok () ->
862
+
(* Checkout main branch *)
863
+
(match Git.checkout ~proc ~fs ~branch:"main" src_path with
864
+
| Error e -> Error (Git_error e)
865
+
| Ok () ->
866
+
(* Set push URL if provided *)
867
+
let push_result =
868
+
match push_url with
869
+
| Some url ->
870
+
(match Git.add_remote ~proc ~fs ~name:"origin" ~url src_path with
871
+
| Error e -> Error (Git_error e)
872
+
| Ok () -> Ok ())
873
+
| None -> Ok ()
874
+
in
875
+
match push_result with
876
+
| Error _ as e -> e
877
+
| Ok () ->
878
+
(* Only update sources.toml if there's a push URL *)
879
+
(match push_url with
880
+
| Some url ->
881
+
let sources_path = Fpath.(monorepo / "sources.toml") in
882
+
let sources =
883
+
match Sources_registry.load ~fs:(fs :> _ Eio.Path.t) sources_path with
884
+
| Ok s -> s
885
+
| Error _ -> Sources_registry.empty
886
+
in
887
+
let entry = Sources_registry.{
888
+
url = normalize_git_url url;
889
+
upstream = None;
890
+
branch = Some "main";
891
+
reason = None;
892
+
origin = Some Fork;
893
+
} in
894
+
let sources = Sources_registry.add sources ~subtree:name entry in
895
+
(match Sources_registry.save ~fs:(fs :> _ Eio.Path.t) sources_path sources with
1085
896
| Ok () -> ()
1086
-
| Error msg ->
1087
-
Logs.warn (fun m ->
1088
-
m
1089
-
"Failed to update \
1090
-
sources.toml: %s"
1091
-
msg))
1092
-
| None -> ());
1093
-
Ok
1094
-
{
1095
-
name;
1096
-
split_commit;
1097
-
src_path;
1098
-
push_url;
1099
-
packages_created = packages;
1100
-
}))))))
897
+
| Error msg -> Logs.warn (fun m -> m "Failed to update sources.toml: %s" msg))
898
+
| None -> ());
899
+
Ok { name; split_commit; src_path; push_url; packages_created = packages }))
1101
900
end
1102
901
end
1103
902
···
1109
908
let subtree_path = Fpath.(monorepo / prefix) in
1110
909
let src_path = Fpath.(checkouts / name) in
1111
910
(* Validate: mono/<name>/ must not exist *)
1112
-
if Git_cli.subtree_prefix_exists ~fs ~repo:monorepo ~prefix then
911
+
if Git.Subtree.exists ~fs ~repo:monorepo ~prefix then
1113
912
Error (Subtree_already_exists name)
1114
913
else if dry_run then
1115
-
Ok
1116
-
{
1117
-
name;
1118
-
source_url = url;
1119
-
upstream_url = upstream;
1120
-
packages_added = [];
1121
-
from_handle = None;
1122
-
}
914
+
Ok { name; source_url = url; upstream_url = upstream; packages_added = []; from_handle = None }
1123
915
else begin
1124
916
(* Ensure src/ exists *)
1125
917
ensure_dir ~fs checkouts;
1126
918
(* Clone to src/<name>/ *)
1127
919
let branch = Verse_config.default_branch in
1128
920
let uri = Uri.of_string url in
1129
-
match Git_cli.clone ~proc ~fs ~url:uri ~branch src_path with
921
+
match Git.clone ~proc ~fs ~url:uri ~branch src_path with
1130
922
| Error e -> Error (Git_error e)
1131
-
| Ok () -> (
1132
-
(* Add subtree to monorepo - first fetch to get the commit *)
1133
-
match
1134
-
Git_cli.fetch_url ~proc ~fs ~repo:monorepo ~url:uri ~branch ()
1135
-
with
923
+
| Ok () ->
924
+
(* Add subtree to monorepo *)
925
+
match Git.Subtree.add ~proc ~fs ~repo:monorepo ~prefix ~url:uri ~branch () with
1136
926
| Error e -> Error (Git_error e)
1137
-
| Ok hash_hex -> (
1138
-
let repo_path = Fpath.to_string monorepo in
1139
-
let git_repo = Git.Repository.open_repo ~fs repo_path in
1140
-
let commit = Git.Hash.of_hex hash_hex in
1141
-
let user =
1142
-
Git.User.make ~name:"monopam" ~email:"monopam@localhost"
1143
-
~date:(Int64.of_float (Unix.time ()))
1144
-
()
1145
-
in
1146
-
let message =
1147
-
Fmt.str "Add '%s' from %s\n\ngit-subtree-dir: %s\n" prefix url
1148
-
prefix
1149
-
in
1150
-
match
1151
-
Git.Subtree.add git_repo ~prefix ~commit ~author:user
1152
-
~committer:user ~message ()
1153
-
with
1154
-
| Error (`Msg msg) -> Error (Git_error (Git_cli.Io_error msg))
1155
-
| Ok _ ->
1156
-
(* Find .opam files in the new subtree *)
1157
-
let packages = find_opam_files ~fs subtree_path in
1158
-
(* Only update sources.toml if there's an upstream to track *)
1159
-
(match upstream with
1160
-
| Some _ -> (
1161
-
let sources_path = Fpath.(monorepo / "sources.toml") in
1162
-
let sources =
1163
-
match
1164
-
Sources_registry.load
1165
-
~fs:(fs :> _ Eio.Path.t)
1166
-
sources_path
1167
-
with
1168
-
| Ok s -> s
1169
-
| Error _ -> Sources_registry.empty
1170
-
in
1171
-
let entry =
1172
-
Sources_registry.
1173
-
{
1174
-
url = normalize_git_url url;
1175
-
upstream = Option.map normalize_git_url upstream;
1176
-
branch = Some branch;
1177
-
reason = None;
1178
-
origin = Some Join;
1179
-
}
1180
-
in
1181
-
let sources =
1182
-
Sources_registry.add sources ~subtree:name entry
1183
-
in
1184
-
match
1185
-
Sources_registry.save
1186
-
~fs:(fs :> _ Eio.Path.t)
1187
-
sources_path sources
1188
-
with
1189
-
| Ok () -> ()
1190
-
| Error msg ->
1191
-
Logs.warn (fun m ->
1192
-
m "Failed to update sources.toml: %s" msg))
1193
-
| None -> ());
1194
-
Ok
1195
-
{
1196
-
name;
1197
-
source_url = url;
1198
-
upstream_url = upstream;
1199
-
packages_added = packages;
1200
-
from_handle = None;
1201
-
}))
927
+
| Ok () ->
928
+
(* Find .opam files in the new subtree *)
929
+
let packages = find_opam_files ~fs subtree_path in
930
+
(* Only update sources.toml if there's an upstream to track *)
931
+
(match upstream with
932
+
| Some _ ->
933
+
let sources_path = Fpath.(monorepo / "sources.toml") in
934
+
let sources =
935
+
match Sources_registry.load ~fs:(fs :> _ Eio.Path.t) sources_path with
936
+
| Ok s -> s
937
+
| Error _ -> Sources_registry.empty
938
+
in
939
+
let entry = Sources_registry.{
940
+
url = normalize_git_url url;
941
+
upstream = Option.map normalize_git_url upstream;
942
+
branch = Some branch;
943
+
reason = None;
944
+
origin = Some Join;
945
+
} in
946
+
let sources = Sources_registry.add sources ~subtree:name entry in
947
+
(match Sources_registry.save ~fs:(fs :> _ Eio.Path.t) sources_path sources with
948
+
| Ok () -> ()
949
+
| Error msg -> Logs.warn (fun m -> m "Failed to update sources.toml: %s" msg))
950
+
| None -> ());
951
+
Ok { name; source_url = url; upstream_url = upstream; packages_added = packages; from_handle = None }
1202
952
end
1203
953
1204
-
let join_from_verse ~proc ~fs ~config ~verse_config ~package ~handle ~fork_url
1205
-
?(dry_run = false) () =
954
+
let join_from_verse ~proc ~fs ~config ~verse_config ~package ~handle ~fork_url ?(dry_run = false) () =
1206
955
(* First use verse fork to set up the opam entries *)
1207
-
match
1208
-
Verse.fork ~proc ~fs ~config:verse_config ~handle ~package ~fork_url
1209
-
~dry_run ()
1210
-
with
956
+
match Verse.fork ~proc ~fs ~config:verse_config ~handle ~package ~fork_url ~dry_run () with
1211
957
| Error e -> Error (Verse_error e)
1212
958
| Ok fork_result ->
1213
959
if dry_run then
1214
-
Ok
1215
-
{
1216
-
name = fork_result.subtree_name;
1217
-
source_url = fork_url;
1218
-
upstream_url = Some fork_result.upstream_url;
1219
-
packages_added = fork_result.packages_forked;
1220
-
from_handle = Some handle;
1221
-
}
960
+
Ok {
961
+
name = fork_result.subtree_name;
962
+
source_url = fork_url;
963
+
upstream_url = Some fork_result.upstream_url;
964
+
packages_added = fork_result.packages_forked;
965
+
from_handle = Some handle;
966
+
}
1222
967
else begin
1223
968
(* Now join the repository *)
1224
969
let name = fork_result.subtree_name in
1225
-
match
1226
-
join ~proc ~fs ~config ~url:fork_url ~name
1227
-
~upstream:fork_result.upstream_url ~dry_run ()
1228
-
with
970
+
match join ~proc ~fs ~config ~url:fork_url ~name ~upstream:fork_result.upstream_url ~dry_run () with
1229
971
| Error e -> Error e
1230
972
| Ok join_result ->
1231
-
Ok
1232
-
{
1233
-
join_result with
1234
-
packages_added = fork_result.packages_forked;
1235
-
from_handle = Some handle;
1236
-
}
973
+
Ok { join_result with
974
+
packages_added = fork_result.packages_forked;
975
+
from_handle = Some handle;
976
+
}
1237
977
end
+67
-78
lib/fork_join.mli
+67
-78
lib/fork_join.mli
···
6
6
7
7
Both operations update sources.toml to track the origin of each source.
8
8
9
-
The module supports an action-based workflow where commands: 1. Analyze
10
-
current state 2. Build a list of actions with reasoning 3. Display the plan
11
-
with discovery details 4. Prompt for confirmation (or skip with [--yes]) 5.
12
-
Execute actions sequentially *)
9
+
The module supports an action-based workflow where commands:
10
+
1. Analyze current state
11
+
2. Build a list of actions with reasoning
12
+
3. Display the plan with discovery details
13
+
4. Prompt for confirmation (or skip with [--yes])
14
+
5. Execute actions sequentially *)
13
15
14
16
(** {1 Error Types} *)
15
17
16
18
type error =
17
19
| Config_error of string (** Configuration error *)
18
-
| Git_error of Git_cli.error (** Git operation failed *)
20
+
| Git_error of Git.error (** Git operation failed *)
19
21
| Subtree_not_found of string (** Subtree not found in monorepo *)
20
22
| Src_already_exists of string (** Source checkout already exists *)
21
23
| Src_not_found of string (** Source checkout not found *)
···
40
42
| Check_remote_exists of string (** URL - informational check *)
41
43
| Create_directory of Fpath.t
42
44
| Git_init of Fpath.t
43
-
| Git_config of { repo : Fpath.t; key : string; value : string }
44
-
(** Set git config *)
45
-
| Git_clone of { url : string; dest : Fpath.t; branch : string }
46
-
| Git_subtree_split of { repo : Fpath.t; prefix : string }
47
-
| Git_subtree_add of {
48
-
repo : Fpath.t;
49
-
prefix : string;
50
-
url : Uri.t;
51
-
branch : string;
52
-
}
53
-
| Git_add_remote of { repo : Fpath.t; name : string; url : string }
54
-
| Git_push_ref of { repo : Fpath.t; target : string; ref_spec : string }
55
-
| Git_checkout of { repo : Fpath.t; branch : string }
56
-
| Git_branch_rename of { repo : Fpath.t; new_name : string }
57
-
(** Rename current branch *)
58
-
| Copy_directory of { src : Fpath.t; dest : Fpath.t }
45
+
| Git_config of { repo: Fpath.t; key: string; value: string } (** Set git config *)
46
+
| Git_clone of { url: string; dest: Fpath.t; branch: string }
47
+
| Git_subtree_split of { repo: Fpath.t; prefix: string }
48
+
| Git_subtree_add of { repo: Fpath.t; prefix: string; url: Uri.t; branch: string }
49
+
| Git_add_remote of { repo: Fpath.t; name: string; url: string }
50
+
| Git_push_ref of { repo: Fpath.t; target: string; ref_spec: string }
51
+
| Git_checkout of { repo: Fpath.t; branch: string }
52
+
| Git_branch_rename of { repo: Fpath.t; new_name: string } (** Rename current branch *)
53
+
| Copy_directory of { src: Fpath.t; dest: Fpath.t }
59
54
| Git_add_all of Fpath.t
60
-
| Git_commit of { repo : Fpath.t; message : string }
61
-
| Git_rm of { repo : Fpath.t; path : string; recursive : bool }
62
-
(** Remove from git *)
63
-
| Update_sources_toml of {
64
-
path : Fpath.t;
65
-
name : string;
66
-
entry : Sources_registry.entry;
67
-
}
55
+
| Git_commit of { repo: Fpath.t; message: string }
56
+
| Git_rm of { repo: Fpath.t; path: string; recursive: bool } (** Remove from git *)
57
+
| Update_sources_toml of { path: Fpath.t; name: string; entry: Sources_registry.entry }
68
58
59
+
(** Discovery information gathered during planning *)
69
60
type discovery = {
70
-
mono_exists : bool; (** Does mono/<name>/ exist? *)
71
-
src_exists : bool; (** Does src/<name>/ exist? *)
72
-
has_subtree_history : bool; (** Can we git subtree split? *)
73
-
remote_accessible : bool option; (** None = not checked, Some = result *)
74
-
opam_files : string list; (** Package names found from .opam files *)
75
-
local_path_is_repo : bool option; (** For join from local dir *)
61
+
mono_exists: bool; (** Does mono/<name>/ exist? *)
62
+
src_exists: bool; (** Does src/<name>/ exist? *)
63
+
has_subtree_history: bool; (** Can we git subtree split? *)
64
+
remote_accessible: bool option; (** None = not checked, Some = result *)
65
+
opam_files: string list; (** Package names found from .opam files *)
66
+
local_path_is_repo: bool option; (** For join from local dir *)
76
67
}
77
-
(** Discovery information gathered during planning *)
78
68
69
+
(** A complete action plan *)
79
70
type 'a action_plan = {
80
-
discovery : discovery;
81
-
actions : action list;
82
-
result : 'a; (** What we'll return on success *)
83
-
dry_run : bool;
71
+
discovery: discovery;
72
+
actions: action list;
73
+
result: 'a; (** What we'll return on success *)
74
+
dry_run: bool;
84
75
}
85
-
(** A complete action plan *)
86
76
87
77
val pp_action : action Fmt.t
88
78
(** [pp_action] formats a single action. *)
···
99
89
(** [is_local_path s] returns true if [s] looks like a local filesystem path
100
90
rather than a URL. *)
101
91
102
-
val suggest_push_url :
103
-
fs:Eio.Fs.dir_ty Eio.Path.t -> ?knot:string -> Fpath.t -> string option
104
-
(** [suggest_push_url ~fs ?knot subtree_path] tries to derive a push URL from
105
-
the dune-project file in the subtree. Returns [Some url] if a source URL can
92
+
val suggest_push_url : fs:Eio.Fs.dir_ty Eio.Path.t -> ?knot:string -> Fpath.t -> string option
93
+
(** [suggest_push_url ~fs ?knot subtree_path] tries to derive a push URL from the
94
+
dune-project file in the subtree. Returns [Some url] if a source URL can
106
95
be found and converted to SSH push format, [None] otherwise.
107
96
108
-
@param knot
109
-
Optional git push server for tangled URLs (default: git.recoil.org) *)
97
+
@param knot Optional git push server for tangled URLs (default: git.recoil.org) *)
110
98
111
99
(** {1 Result Types} *)
112
100
101
+
(** Result of a fork operation. *)
113
102
type fork_result = {
114
103
name : string; (** Subtree/repository name *)
115
104
split_commit : string; (** Git commit SHA from subtree split *)
···
117
106
push_url : string option; (** Remote push URL if provided *)
118
107
packages_created : string list; (** Package names from .opam files *)
119
108
}
120
-
(** Result of a fork operation. *)
121
109
122
110
val pp_fork_result : fork_result Fmt.t
123
111
(** [pp_fork_result] formats a fork result. *)
124
112
113
+
(** Result of a join operation. *)
125
114
type join_result = {
126
115
name : string; (** Subtree/repository name *)
127
116
source_url : string; (** URL the repository was cloned from *)
···
129
118
packages_added : string list; (** Package names from .opam files *)
130
119
from_handle : string option; (** Verse handle if joined from verse *)
131
120
}
132
-
(** Result of a join operation. *)
133
121
134
122
val pp_join_result : join_result Fmt.t
135
123
(** [pp_join_result] formats a join result. *)
···
145
133
?dry_run:bool ->
146
134
unit ->
147
135
(fork_result action_plan, error) result
148
-
(** [plan_fork ~proc ~fs ~config ~name ?push_url ?dry_run ()] builds a fork
149
-
plan.
136
+
(** [plan_fork ~proc ~fs ~config ~name ?push_url ?dry_run ()] builds a fork plan.
150
137
151
138
This analyzes the current state and builds a list of actions to:
152
139
- For subtrees with history: split subtree, create repo, push history
···
168
155
?dry_run:bool ->
169
156
unit ->
170
157
(join_result action_plan, error) result
171
-
(** [plan_join ~proc ~fs ~config ~source ?name ?upstream ?dry_run ()] builds a
172
-
join plan.
158
+
(** [plan_join ~proc ~fs ~config ~source ?name ?upstream ?dry_run ()] builds a join plan.
173
159
174
-
This analyzes the source (URL or local path) and builds a list of actions
175
-
to:
160
+
This analyzes the source (URL or local path) and builds a list of actions to:
176
161
- For URLs: clone repo, add subtree
177
162
- For local directories: copy/init repo, add subtree
178
163
179
164
The plan can be displayed to the user and executed with [execute_join_plan].
180
165
181
166
@param source Git URL or local filesystem path to join
182
-
@param name
183
-
Override the subtree directory name (default: derived from source)
167
+
@param name Override the subtree directory name (default: derived from source)
184
168
@param upstream Original upstream URL if this is your fork
185
169
@param dry_run If true, mark plan as dry-run (execute will skip actions) *)
186
170
···
194
178
(join_result action_plan, error) result
195
179
(** [plan_rejoin ~proc ~fs ~config ~name ?dry_run ()] builds a rejoin plan.
196
180
197
-
This is used to add an existing src/<name>/ repository back into
198
-
mono/<name>/ as a subtree. Useful after forking a package and removing it
199
-
from the monorepo.
181
+
This is used to add an existing src/<name>/ repository back into mono/<name>/
182
+
as a subtree. Useful after forking a package and removing it from the monorepo.
200
183
201
184
Requires:
202
185
- src/<name>/ must exist and be a git repository
···
216
199
(fork_result, error) result
217
200
(** [execute_fork_plan ~proc ~fs plan] executes a fork action plan.
218
201
219
-
Returns the fork result with the actual split commit (if applicable). If the
220
-
plan is marked as dry-run, returns the plan's result without executing any
221
-
actions. *)
202
+
Returns the fork result with the actual split commit (if applicable).
203
+
If the plan is marked as dry-run, returns the plan's result without
204
+
executing any actions. *)
222
205
223
206
val execute_join_plan :
224
207
proc:_ Eio.Process.mgr ->
···
244
227
(** [fork ~proc ~fs ~config ~name ?push_url ?dry_run ()] splits a monorepo
245
228
subtree into its own repository.
246
229
247
-
This operation: 1. Validates mono/<name>/ exists 2. Validates src/<name>/
248
-
does not exist 3. Uses [git subtree split] to extract history 4. Creates a
249
-
new git repo at src/<name>/ 5. Pushes the split commit to the new repo 6.
250
-
Updates sources.toml with [origin = "fork"] 7. Auto-discovers packages from
251
-
.opam files
230
+
This operation:
231
+
1. Validates mono/<name>/ exists
232
+
2. Validates src/<name>/ does not exist
233
+
3. Uses [git subtree split] to extract history
234
+
4. Creates a new git repo at src/<name>/
235
+
5. Pushes the split commit to the new repo
236
+
6. Updates sources.toml with [origin = "fork"]
237
+
7. Auto-discovers packages from .opam files
252
238
253
239
@param name Name of the subtree to fork (directory name under mono/)
254
240
@param push_url Optional remote URL to add as origin for pushing
···
269
255
(** [join ~proc ~fs ~config ~url ?name ?upstream ?dry_run ()] brings an external
270
256
repository into the monorepo.
271
257
272
-
This operation: 1. Derives name from URL if not provided 2. Validates
273
-
mono/<name>/ does not exist 3. Clones the repository to src/<name>/ 4. Uses
274
-
[git subtree add] to bring into monorepo 5. Updates sources.toml with
275
-
[origin = "join"] 6. Auto-discovers packages from .opam files
258
+
This operation:
259
+
1. Derives name from URL if not provided
260
+
2. Validates mono/<name>/ does not exist
261
+
3. Clones the repository to src/<name>/
262
+
4. Uses [git subtree add] to bring into monorepo
263
+
5. Updates sources.toml with [origin = "join"]
264
+
6. Auto-discovers packages from .opam files
276
265
277
266
@param url Git URL to clone from
278
267
@param name Override the subtree directory name (default: derived from URL)
279
-
@param upstream
280
-
Original upstream URL if this is your fork of another project
268
+
@param upstream Original upstream URL if this is your fork of another project
281
269
@param dry_run If true, validate and report what would be done *)
282
270
283
271
val join_from_verse :
···
294
282
(** [join_from_verse ~proc ~fs ~config ~verse_config ~package ~handle ~fork_url
295
283
?dry_run ()] joins a package from a verse member's repository.
296
284
297
-
This combines [Verse.fork] (to set up opam entries) with [join]: 1. Looks up
298
-
the package in verse/<handle>-opam/ 2. Finds all packages sharing the same
299
-
git repository 3. Creates opam entries pointing to your fork 4. Clones and
300
-
adds the subtree
285
+
This combines [Verse.fork] (to set up opam entries) with [join]:
286
+
1. Looks up the package in verse/<handle>-opam/
287
+
2. Finds all packages sharing the same git repository
288
+
3. Creates opam entries pointing to your fork
289
+
4. Clones and adds the subtree
301
290
302
291
@param verse_config Verse configuration (for accessing verse/ directory)
303
292
@param package Package name to look up
+53
-167
lib/forks.ml
+53
-167
lib/forks.ml
···
30
30
if String.length content > 2 then begin
31
31
let inner = String.sub content 1 (String.length content - 2) in
32
32
let pairs = String.split_on_char ',' inner in
33
-
List.iter
34
-
(fun pair ->
35
-
let pair = String.trim pair in
36
-
match String.split_on_char ':' pair with
37
-
| [ key; value ] -> (
38
-
let key = String.trim key in
39
-
let value = String.trim value in
40
-
(* Strip quotes from key *)
41
-
let key =
42
-
if String.length key > 2 && key.[0] = '"' then
43
-
String.sub key 1 (String.length key - 2)
44
-
else key
45
-
in
46
-
match float_of_string_opt value with
47
-
| Some ts -> Hashtbl.replace fetch_cache key ts
48
-
| None -> ())
49
-
| _ -> ())
33
+
List.iter (fun pair ->
34
+
let pair = String.trim pair in
35
+
match String.split_on_char ':' pair with
36
+
| [key; value] ->
37
+
let key = String.trim key in
38
+
let value = String.trim value in
39
+
(* Strip quotes from key *)
40
+
let key = if String.length key > 2 && key.[0] = '"' then
41
+
String.sub key 1 (String.length key - 2)
42
+
else key
43
+
in
44
+
(match float_of_string_opt value with
45
+
| Some ts -> Hashtbl.replace fetch_cache key ts
46
+
| None -> ())
47
+
| _ -> ())
50
48
pairs
51
49
end
52
50
with _ -> ()
···
62
60
ignore (Sys.command (Printf.sprintf "mkdir -p %s" (Filename.quote dir)));
63
61
(* Write cache as JSON *)
64
62
Out_channel.with_open_text path (fun oc ->
65
-
output_string oc "{\n";
66
-
let first = ref true in
67
-
Hashtbl.iter
68
-
(fun key ts ->
69
-
if not !first then output_string oc ",\n";
70
-
first := false;
71
-
Printf.fprintf oc " \"%s\": %.0f" key ts)
72
-
fetch_cache;
73
-
output_string oc "\n}\n")
63
+
output_string oc "{\n";
64
+
let first = ref true in
65
+
Hashtbl.iter (fun key ts ->
66
+
if not !first then output_string oc ",\n";
67
+
first := false;
68
+
Printf.fprintf oc " \"%s\": %.0f" key ts)
69
+
fetch_cache;
70
+
output_string oc "\n}\n")
74
71
with _ -> ()
75
72
76
73
(** Check if a fetch is needed for a cache key *)
···
92
89
Hashtbl.replace fetch_cache key now;
93
90
save_cache ()
94
91
95
-
(* ==================== Scan Cache ==================== *)
96
-
97
-
(** In-memory cache of scanned opam repo results: opam_path -> (pkg_name, url)
98
-
list *)
99
-
let scan_cache : (string, (string * Uri.t) list) Hashtbl.t = Hashtbl.create 64
100
-
101
-
(** Scan cache file path *)
102
-
let scan_cache_file_path () =
103
-
Fpath.(to_string (Verse_config.cache_dir () / "scan-cache.json"))
104
-
105
-
(** Load scan cache from disk. Uses simple line-based format:
106
-
path<TAB>pkg1<TAB>url1<TAB>pkg2<TAB>url2... *)
107
-
let load_scan_cache () =
108
-
let path = scan_cache_file_path () in
109
-
if Sys.file_exists path then begin
110
-
try
111
-
let lines =
112
-
In_channel.with_open_text path (fun ic ->
113
-
let rec read acc =
114
-
match In_channel.input_line ic with
115
-
| Some line -> read (line :: acc)
116
-
| None -> List.rev acc
117
-
in
118
-
read [])
119
-
in
120
-
List.iter
121
-
(fun line ->
122
-
match String.split_on_char '\t' line with
123
-
| key :: rest when List.length rest >= 2 ->
124
-
(* rest is alternating pkg, url, pkg, url, ... *)
125
-
let rec parse_pairs acc = function
126
-
| pkg :: url :: tail ->
127
-
parse_pairs ((pkg, Uri.of_string url) :: acc) tail
128
-
| _ -> List.rev acc
129
-
in
130
-
let pairs = parse_pairs [] rest in
131
-
if pairs <> [] then Hashtbl.replace scan_cache key pairs
132
-
| _ -> ())
133
-
lines;
134
-
Log.debug (fun m ->
135
-
m "Loaded scan cache with %d entries" (Hashtbl.length scan_cache))
136
-
with _ -> ()
137
-
end
138
-
139
-
(** Save scan cache to disk. Uses simple line-based format. *)
140
-
let save_scan_cache () =
141
-
let path = scan_cache_file_path () in
142
-
try
143
-
let dir = Filename.dirname path in
144
-
if not (Sys.file_exists dir) then
145
-
ignore (Sys.command (Printf.sprintf "mkdir -p %s" (Filename.quote dir)));
146
-
Out_channel.with_open_text path (fun oc ->
147
-
Hashtbl.iter
148
-
(fun key pairs ->
149
-
output_string oc key;
150
-
List.iter
151
-
(fun (pkg, url) ->
152
-
output_char oc '\t';
153
-
output_string oc pkg;
154
-
output_char oc '\t';
155
-
output_string oc (Uri.to_string url))
156
-
pairs;
157
-
output_char oc '\n')
158
-
scan_cache)
159
-
with _ -> ()
160
-
161
-
(** Get cached scan results for a path, or None if not cached *)
162
-
let get_cached_scan path =
163
-
if Hashtbl.length scan_cache = 0 then load_scan_cache ();
164
-
Hashtbl.find_opt scan_cache (Fpath.to_string path)
165
-
166
-
(** Store scan results in cache *)
167
-
let cache_scan path results =
168
-
Hashtbl.replace scan_cache (Fpath.to_string path) results;
169
-
save_scan_cache ()
170
-
171
92
type repo_source = {
172
93
handle : string; (** Member handle or "me" *)
173
94
url : Uri.t; (** Normalized git URL *)
···
405
326
(* Generic git.<domain>: pattern - convert git@git.<domain>:path to https://git.<domain>/path *)
406
327
match String.index_opt s ':' with
407
328
| Some colon_pos ->
408
-
let host = String.sub s 4 (colon_pos - 4) in
409
-
(* "git.<domain>" *)
410
-
let path =
411
-
String.sub s (colon_pos + 1) (String.length s - colon_pos - 1)
412
-
in
329
+
let host = String.sub s 4 (colon_pos - 4) in (* "git.<domain>" *)
330
+
let path = String.sub s (colon_pos + 1) (String.length s - colon_pos - 1) in
413
331
"https://" ^ host ^ "/" ^ path
414
332
| None -> s
415
333
else s
···
473
391
package_names
474
392
with _ -> []
475
393
476
-
(** Fetch a verse opam repo (with caching). Returns true if actually fetched. *)
394
+
(** Fetch a verse opam repo (with caching) *)
477
395
let fetch_verse_opam_repo ~proc ~fs ~refresh path =
478
396
let cache_key = "verse-opam/" ^ Fpath.to_string path in
479
397
if not (needs_fetch ~refresh ~timeout:default_cache_timeout cache_key) then begin
480
398
Log.debug (fun m -> m "Skipping fetch for %a (cached)" Fpath.pp path);
481
-
false (* Did not fetch *)
482
-
end
483
-
else begin
399
+
()
400
+
end else begin
484
401
let cwd = Eio.Path.(fs / Fpath.to_string path) in
485
-
let cmd = [ "git"; "fetch"; "--quiet" ] in
486
-
Log.debug (fun m ->
487
-
m "Running: %s (in %a)" (String.concat " " cmd) Fpath.pp path);
402
+
let cmd = ["git"; "fetch"; "--quiet"] in
403
+
Log.debug (fun m -> m "Running: %s (in %a)" (String.concat " " cmd) Fpath.pp path);
488
404
Eio.Switch.run @@ fun sw ->
489
-
let child =
490
-
Eio.Process.spawn proc ~sw ~cwd
405
+
let child = Eio.Process.spawn proc ~sw ~cwd
491
406
~stdout:(Eio.Flow.buffer_sink (Buffer.create 16))
492
407
~stderr:(Eio.Flow.buffer_sink (Buffer.create 16))
493
408
cmd
494
409
in
495
410
match Eio.Process.await child with
496
-
| `Exited 0 ->
497
-
record_fetch cache_key;
498
-
true (* Actually fetched *)
499
-
| _ ->
500
-
Log.debug (fun m -> m "Failed to fetch %a" Fpath.pp path);
501
-
false
411
+
| `Exited 0 -> record_fetch cache_key
412
+
| _ -> Log.debug (fun m -> m "Failed to fetch %a" Fpath.pp path)
502
413
end
503
414
504
-
(** Scan all verse opam repos and build a map: repo_basename ->
505
-
[(handle, url, [packages])] *)
415
+
(** Scan all verse opam repos and build a map: repo_basename -> [(handle, url, [packages])] *)
506
416
let scan_all_verse_opam_repos ~proc ~fs ~verse_path ~refresh () =
507
417
let eio_verse = Eio.Path.(fs / Fpath.to_string verse_path) in
508
418
let entries = try Eio.Path.read_dir eio_verse with _ -> [] in
509
419
(* Find opam repo directories (ending in -opam) *)
510
-
let opam_dirs =
511
-
List.filter (fun name -> String.ends_with ~suffix:"-opam" name) entries
512
-
in
420
+
let opam_dirs = List.filter (fun name -> String.ends_with ~suffix:"-opam" name) entries in
421
+
(* Fetch each opam repo first (respecting cache unless refresh) *)
513
422
Log.info (fun m -> m "Checking %d verse opam repos" (List.length opam_dirs));
423
+
List.iter (fun opam_dir ->
424
+
let opam_path = Fpath.(verse_path / opam_dir) in
425
+
fetch_verse_opam_repo ~proc ~fs ~refresh opam_path)
426
+
opam_dirs;
514
427
(* Build map: repo_basename -> [(handle, url, [packages])] *)
515
428
let repo_map = Hashtbl.create 64 in
516
429
List.iter
···
518
431
let handle = String.sub opam_dir 0 (String.length opam_dir - 5) in
519
432
(* strip -opam *)
520
433
let opam_path = Fpath.(verse_path / opam_dir) in
521
-
(* Fetch and decide whether to rescan *)
522
-
let did_fetch = fetch_verse_opam_repo ~proc ~fs ~refresh opam_path in
523
-
(* Use cached scan results unless we fetched or have no cache *)
524
-
let pkg_urls =
525
-
match (did_fetch, get_cached_scan opam_path) with
526
-
| false, Some cached ->
527
-
Log.debug (fun m -> m "Using cached scan for %a" Fpath.pp opam_path);
528
-
cached
529
-
| _ ->
530
-
(* Need to scan: either we fetched or no cache exists *)
531
-
Log.debug (fun m -> m "Scanning %a" Fpath.pp opam_path);
532
-
let results = scan_verse_opam_repo ~fs opam_path in
533
-
cache_scan opam_path results;
534
-
results
535
-
in
434
+
let pkg_urls = scan_verse_opam_repo ~fs opam_path in
536
435
(* Group by repo basename *)
537
436
let by_repo = Hashtbl.create 16 in
538
437
List.iter
···
611
510
612
511
(** Fetch a remote (with caching) *)
613
512
let fetch_remote ~proc ~fs ~repo ~remote ~refresh () =
614
-
let cache_key =
615
-
Printf.sprintf "checkout/%s/%s" (Fpath.to_string repo) remote
616
-
in
513
+
let cache_key = Printf.sprintf "checkout/%s/%s" (Fpath.to_string repo) remote in
617
514
if not (needs_fetch ~refresh ~timeout:default_cache_timeout cache_key) then begin
618
-
Log.debug (fun m ->
619
-
m "Skipping fetch for %s in %a (cached)" remote Fpath.pp repo);
620
-
Ok () (* Return Ok since we have cached data *)
621
-
end
622
-
else begin
515
+
Log.debug (fun m -> m "Skipping fetch for %s in %a (cached)" remote Fpath.pp repo);
516
+
Ok () (* Return Ok since we have cached data *)
517
+
end else begin
623
518
let cwd = Eio.Path.(fs / Fpath.to_string repo) in
624
-
let cmd = [ "git"; "fetch"; remote ] in
519
+
let cmd = ["git"; "fetch"; remote] in
625
520
Log.info (fun m -> m "Fetching %s in %a" remote Fpath.pp repo);
626
-
Log.debug (fun m ->
627
-
m "Running: %s (in %a)" (String.concat " " cmd) Fpath.pp repo);
521
+
Log.debug (fun m -> m "Running: %s (in %a)" (String.concat " " cmd) Fpath.pp repo);
628
522
Eio.Switch.run @@ fun sw ->
629
-
let child =
630
-
Eio.Process.spawn proc ~sw ~cwd
523
+
let child = Eio.Process.spawn proc ~sw ~cwd
631
524
~stdout:(Eio.Flow.buffer_sink (Buffer.create 256))
632
525
~stderr:(Eio.Flow.buffer_sink (Buffer.create 256))
633
526
cmd
634
527
in
635
528
match Eio.Process.await child with
636
-
| `Exited 0 ->
637
-
record_fetch cache_key;
638
-
Ok ()
529
+
| `Exited 0 -> record_fetch cache_key; Ok ()
639
530
| _ -> Error "Failed to fetch remote"
640
531
end
641
532
···
732
623
Diverged { common_ancestor = base; my_ahead; their_ahead }))
733
624
734
625
(** Compute fork analysis for all repos *)
735
-
let compute ~proc ~fs ~verse_config ~monopam_config ?(refresh = false) () =
626
+
let compute ~proc ~fs ~verse_config ~monopam_config ?(refresh=false) () =
736
627
let verse_path = Verse_config.verse_path verse_config in
737
628
let opam_repo_path = Config.Paths.opam_repo monopam_config in
738
629
let checkouts_path = Config.Paths.checkouts monopam_config in
···
743
634
744
635
(* Scan verse opam repos *)
745
636
Log.info (fun m -> m "Scanning verse opam repos");
746
-
let verse_repos =
747
-
scan_all_verse_opam_repos ~proc ~fs ~verse_path ~refresh ()
748
-
in
637
+
let verse_repos = scan_all_verse_opam_repos ~proc ~fs ~verse_path ~refresh () in
749
638
750
639
(* Build combined list of all repo names *)
751
640
let all_repos = Hashtbl.create 64 in
···
771
660
else begin
772
661
(* Check if we have a local checkout *)
773
662
let checkout_path = Fpath.(checkouts_path / repo_name) in
774
-
let have_checkout = Git_cli.is_repo ~proc ~fs checkout_path in
663
+
let have_checkout = Git.is_repo ~proc ~fs checkout_path in
775
664
776
665
(* Process each verse source *)
777
666
let verse_with_rel =
···
798
687
~name:remote_name ~url:src.url ())
799
688
end;
800
689
(* Fetch remote (respecting cache unless refresh) *)
801
-
match
802
-
fetch_remote ~proc ~fs ~repo:checkout_path
803
-
~remote:remote_name ~refresh ()
804
-
with
690
+
match fetch_remote ~proc ~fs ~repo:checkout_path ~remote:remote_name ~refresh () with
805
691
| Error _ -> Not_fetched
806
692
| Ok () ->
807
693
(* Compare refs *)
+8
-6
lib/forks.mli
+8
-6
lib/forks.mli
···
76
76
?refresh:bool ->
77
77
unit ->
78
78
t
79
-
(** [compute ~proc ~fs ~verse_config ~monopam_config ?refresh ()] performs full
80
-
fork analysis by: 1. Scanning my opam repo for dev-repo URLs 2. Scanning all
81
-
verse opam repos for dev-repo URLs 3. Adding git remotes to my checkouts for
82
-
each member's fork 4. Fetching remotes and comparing commit histories
79
+
(** [compute ~proc ~fs ~verse_config ~monopam_config ?refresh ()] performs full fork
80
+
analysis by:
81
+
1. Scanning my opam repo for dev-repo URLs
82
+
2. Scanning all verse opam repos for dev-repo URLs
83
+
3. Adding git remotes to my checkouts for each member's fork
84
+
4. Fetching remotes and comparing commit histories
83
85
84
-
Fetches are cached for 1 hour by default. Use [~refresh:true] to force fresh
85
-
fetches from all remotes. *)
86
+
Fetches are cached for 1 hour by default. Use [~refresh:true] to force
87
+
fresh fetches from all remotes. *)
+80
-110
lib/git_cli.ml
lib/git.ml
+80
-110
lib/git_cli.ml
lib/git.ml
···
68
68
let retryable_error_patterns =
69
69
[
70
70
(* HTTP 5xx errors *)
71
-
"500";
72
-
"502";
73
-
"503";
74
-
"504";
75
-
"HTTP 5";
76
-
"http 5";
77
-
"Internal Server Error";
78
-
"Bad Gateway";
79
-
"Service Unavailable";
80
-
"Gateway Timeout";
71
+
"500"; "502"; "503"; "504"; "HTTP 5"; "http 5";
72
+
"Internal Server Error"; "Bad Gateway"; "Service Unavailable"; "Gateway Timeout";
81
73
(* RPC failures (common git smart HTTP errors) *)
82
-
"RPC failed";
83
-
"curl";
84
-
"unexpected disconnect";
85
-
"the remote end hung up";
86
-
"early EOF";
74
+
"RPC failed"; "curl"; "unexpected disconnect";
75
+
"the remote end hung up"; "early EOF";
87
76
(* Connection errors *)
88
-
"Connection refused";
89
-
"Connection reset";
90
-
"Connection timed out";
91
-
"Could not resolve host";
92
-
"Failed to connect";
93
-
"Network is unreachable";
94
-
"Temporary failure";
77
+
"Connection refused"; "Connection reset"; "Connection timed out";
78
+
"Could not resolve host"; "Failed to connect";
79
+
"Network is unreachable"; "Temporary failure";
95
80
]
96
81
97
82
(** Check if an error is a retryable HTTP server error (5xx) or network error *)
98
83
let is_retryable_error result =
99
84
let stderr = result.stderr in
100
85
String.length stderr > 0
101
-
&& List.exists
102
-
(fun needle -> string_contains ~needle stderr)
103
-
retryable_error_patterns
86
+
&& List.exists (fun needle -> string_contains ~needle stderr) retryable_error_patterns
104
87
105
-
(** Run a git command with retry logic for network errors. Retries up to
106
-
[max_retries] times with exponential backoff starting at [initial_delay_ms].
107
-
*)
108
-
let run_git_ok_with_retry ~proc ~cwd ?(max_retries = 3)
109
-
?(initial_delay_ms = 2000) args =
88
+
(** Run a git command with retry logic for network errors.
89
+
Retries up to [max_retries] times with exponential backoff starting at [initial_delay_ms]. *)
90
+
let run_git_ok_with_retry ~proc ~cwd ?(max_retries = 3) ?(initial_delay_ms = 2000) args =
110
91
let rec attempt n delay_ms =
111
92
let result = run_git ~proc ~cwd args in
112
93
if result.exit_code = 0 then Ok result.stdout
113
94
else if n < max_retries && is_retryable_error result then begin
114
95
(* Log the retry *)
115
96
Logs.warn (fun m ->
116
-
m
117
-
"Git command failed with retryable error, retrying in %dms \
118
-
(%d/%d): %s"
97
+
m "Git command failed with retryable error, retrying in %dms (%d/%d): %s"
119
98
delay_ms (n + 1) max_retries result.stderr);
120
99
(* Sleep before retry - convert ms to seconds for Unix.sleepf *)
121
100
Unix.sleepf (float_of_int delay_ms /. 1000.0);
···
160
139
let cwd = Eio.Path.(fs / Fpath.to_string parent) in
161
140
let target_name = Fpath.basename target in
162
141
let url_str = Uri.to_string url in
163
-
run_git_ok_with_retry ~proc ~cwd
164
-
[ "clone"; "--branch"; branch; url_str; target_name ]
142
+
run_git_ok_with_retry ~proc ~cwd [ "clone"; "--branch"; branch; url_str; target_name ]
165
143
|> Result.map ignore
166
144
167
145
let fetch ~proc ~fs ?(remote = "origin") path =
···
224
202
Ok { ahead = int_of_string ahead; behind = int_of_string behind }
225
203
| _ -> Ok { ahead = 0; behind = 0 })
226
204
227
-
(* Fetch from URL and return the commit hash for the branch *)
228
-
let fetch_url ~proc ~fs ~repo ~url ~branch () =
229
-
let cwd = path_to_eio ~fs repo in
230
-
let url_str = Uri.to_string url in
231
-
(* Fetch into FETCH_HEAD *)
232
-
match run_git_ok_with_retry ~proc ~cwd [ "fetch"; url_str; branch ] with
233
-
| Error e -> Error e
234
-
| Ok _ -> (
235
-
(* Get the fetched commit hash *)
236
-
match run_git_ok ~proc ~cwd [ "rev-parse"; "FETCH_HEAD" ] with
237
-
| Error e -> Error e
238
-
| Ok hash -> Ok (String.trim hash))
205
+
module Subtree = struct
206
+
let exists ~fs ~repo ~prefix =
207
+
let path = Eio.Path.(fs / Fpath.to_string repo / prefix) in
208
+
match Eio.Path.kind ~follow:true path with
209
+
| `Directory -> true
210
+
| _ -> false
211
+
| exception _ -> false
239
212
240
-
let push_refspec ~proc ~fs ~repo ~url ~refspec () =
241
-
let cwd = path_to_eio ~fs repo in
242
-
let url_str = Uri.to_string url in
243
-
run_git_ok_with_retry ~proc ~cwd [ "push"; url_str; refspec ]
244
-
|> Result.map ignore
213
+
let add ~proc ~fs ~repo ~prefix ~url ~branch () =
214
+
if exists ~fs ~repo ~prefix then Error (Subtree_prefix_exists prefix)
215
+
else
216
+
let cwd = path_to_eio ~fs repo in
217
+
let url_str = Uri.to_string url in
218
+
run_git_ok_with_retry ~proc ~cwd
219
+
[ "subtree"; "add"; "--prefix"; prefix; url_str; branch; "--squash" ]
220
+
|> Result.map ignore
245
221
246
-
let subtree_prefix_exists ~fs ~repo ~prefix =
247
-
let path = Eio.Path.(fs / Fpath.to_string repo / prefix) in
248
-
match Eio.Path.kind ~follow:true path with
249
-
| `Directory -> true
250
-
| _ -> false
251
-
| exception _ -> false
222
+
let pull ~proc ~fs ~repo ~prefix ~url ~branch () =
223
+
if not (exists ~fs ~repo ~prefix) then Error (Subtree_prefix_missing prefix)
224
+
else
225
+
let cwd = path_to_eio ~fs repo in
226
+
let url_str = Uri.to_string url in
227
+
run_git_ok_with_retry ~proc ~cwd
228
+
[ "subtree"; "pull"; "--prefix"; prefix; url_str; branch; "--squash" ]
229
+
|> Result.map ignore
230
+
231
+
let push ~proc ~fs ~repo ~prefix ~url ~branch () =
232
+
if not (exists ~fs ~repo ~prefix) then Error (Subtree_prefix_missing prefix)
233
+
else
234
+
let cwd = path_to_eio ~fs repo in
235
+
let url_str = Uri.to_string url in
236
+
run_git_ok_with_retry ~proc ~cwd
237
+
[ "subtree"; "push"; "--prefix"; prefix; url_str; branch ]
238
+
|> Result.map ignore
239
+
240
+
let split ~proc ~fs ~repo ~prefix () =
241
+
if not (exists ~fs ~repo ~prefix) then Error (Subtree_prefix_missing prefix)
242
+
else
243
+
let cwd = path_to_eio ~fs repo in
244
+
run_git_ok ~proc ~cwd [ "subtree"; "split"; "--prefix"; prefix ]
245
+
end
252
246
253
247
let init ~proc ~fs path =
254
248
let cwd = path_to_eio ~fs (Fpath.parent path) in
···
267
261
| Some b -> b
268
262
| None -> Option.value ~default:"main" (current_branch ~proc ~fs path)
269
263
in
270
-
run_git_ok_with_retry ~proc ~cwd [ "push"; remote; branch ]
271
-
|> Result.map ignore
264
+
run_git_ok_with_retry ~proc ~cwd [ "push"; remote; branch ] |> Result.map ignore
272
265
273
266
let push_ref ~proc ~fs ~repo ~target ~ref_spec () =
274
267
let cwd = path_to_eio ~fs repo in
···
390
383
let cwd = path_to_eio ~fs repo_path in
391
384
run_git_ok ~proc ~cwd [ "show"; "--patch"; "--stat"; commit ]
392
385
393
-
(** Parse a subtree merge/squash commit message to extract the upstream commit
394
-
range. Messages look like: "Squashed 'prefix/' changes from abc123..def456"
395
-
or "Squashed 'prefix/' content from commit abc123" Returns the end commit
396
-
(most recent) if found. *)
386
+
(** Parse a subtree merge/squash commit message to extract the upstream commit range.
387
+
Messages look like: "Squashed 'prefix/' changes from abc123..def456"
388
+
or "Squashed 'prefix/' content from commit abc123"
389
+
Returns the end commit (most recent) if found. *)
397
390
let parse_subtree_message subject =
398
391
(* Helper to extract hex commit hash starting at position *)
399
392
let extract_hex s start =
···
478
471
(** {1 Worktree Operations} *)
479
472
480
473
module Worktree = struct
481
-
type entry = { path : Fpath.t; head : string; branch : string option }
474
+
type entry = {
475
+
path : Fpath.t;
476
+
head : string;
477
+
branch : string option;
478
+
}
482
479
483
480
let add ~proc ~fs ~repo ~path ~branch () =
484
481
let cwd = path_to_eio ~fs repo in
485
482
let path_str = Fpath.to_string path in
486
-
run_git_ok ~proc ~cwd [ "worktree"; "add"; "-b"; branch; path_str ]
483
+
run_git_ok ~proc ~cwd
484
+
[ "worktree"; "add"; "-b"; branch; path_str ]
487
485
|> Result.map ignore
488
486
489
487
let remove ~proc ~fs ~repo ~path ~force () =
···
508
506
HEAD abc123...
509
507
branch refs/heads/branchname (or detached) *)
510
508
let lines = String.split_on_char '\n' output in
511
-
let rec parse_entries acc current_path current_head current_branch =
512
-
function
513
-
| [] -> (
509
+
let rec parse_entries acc current_path current_head current_branch = function
510
+
| [] ->
514
511
(* Finalize last entry if we have one *)
515
-
match (current_path, current_head) with
512
+
(match current_path, current_head with
516
513
| Some p, Some h ->
517
-
let entry =
518
-
{ path = p; head = h; branch = current_branch }
519
-
in
514
+
let entry = { path = p; head = h; branch = current_branch } in
520
515
List.rev (entry :: acc)
521
516
| _ -> List.rev acc)
522
-
| "" :: rest -> (
517
+
| "" :: rest ->
523
518
(* End of entry block *)
524
-
match (current_path, current_head) with
519
+
(match current_path, current_head with
525
520
| Some p, Some h ->
526
-
let entry =
527
-
{ path = p; head = h; branch = current_branch }
528
-
in
521
+
let entry = { path = p; head = h; branch = current_branch } in
529
522
parse_entries (entry :: acc) None None None rest
530
523
| _ -> parse_entries acc None None None rest)
531
524
| line :: rest ->
532
525
if String.starts_with ~prefix:"worktree " line then
533
526
let path_str = String.sub line 9 (String.length line - 9) in
534
-
match Fpath.of_string path_str with
535
-
| Ok p ->
536
-
parse_entries acc (Some p) current_head current_branch
537
-
rest
538
-
| Error _ ->
539
-
parse_entries acc current_path current_head current_branch
540
-
rest
527
+
(match Fpath.of_string path_str with
528
+
| Ok p -> parse_entries acc (Some p) current_head current_branch rest
529
+
| Error _ -> parse_entries acc current_path current_head current_branch rest)
541
530
else if String.starts_with ~prefix:"HEAD " line then
542
531
let head = String.sub line 5 (String.length line - 5) in
543
532
parse_entries acc current_path (Some head) current_branch rest
···
546
535
(* Extract branch name from refs/heads/... *)
547
536
let branch =
548
537
if String.starts_with ~prefix:"refs/heads/" branch_ref then
549
-
Some
550
-
(String.sub branch_ref 11
551
-
(String.length branch_ref - 11))
552
-
else Some branch_ref
538
+
Some (String.sub branch_ref 11 (String.length branch_ref - 11))
539
+
else
540
+
Some branch_ref
553
541
in
554
542
parse_entries acc current_path current_head branch rest
555
543
else if line = "detached" then
556
544
parse_entries acc current_path current_head None rest
557
545
else
558
-
parse_entries acc current_path current_head current_branch
559
-
rest
546
+
parse_entries acc current_path current_head current_branch rest
560
547
in
561
548
parse_entries [] None None None lines
562
549
···
569
556
let cwd = path_to_eio ~fs path in
570
557
run_git_ok ~proc ~cwd [ "cherry-pick"; commit ] |> Result.map ignore
571
558
572
-
let merge ~proc ~fs ~ref_name ?(ff_only = false) path =
559
+
let merge ~proc ~fs ~ref_name ?(ff_only=false) path =
573
560
let cwd = path_to_eio ~fs path in
574
-
let args =
575
-
[ "merge" ] @ (if ff_only then [ "--ff-only" ] else []) @ [ ref_name ]
576
-
in
561
+
let args = ["merge"] @ (if ff_only then ["--ff-only"] else []) @ [ref_name] in
577
562
run_git_ok ~proc ~cwd args |> Result.map ignore
578
563
579
564
(** {1 Diff Operations} *)
···
667
652
let branch_rename ~proc ~fs ~new_name path =
668
653
let cwd = path_to_eio ~fs path in
669
654
run_git_ok ~proc ~cwd [ "branch"; "-M"; new_name ] |> Result.map ignore
670
-
671
-
let ls_remote_head ~proc ~fs ?(remote = "origin") ?(branch = "main") path =
672
-
let cwd = path_to_eio ~fs path in
673
-
match
674
-
run_git_ok ~proc ~cwd
675
-
[ "ls-remote"; "--heads"; remote; Printf.sprintf "refs/heads/%s" branch ]
676
-
with
677
-
| Error _ -> None
678
-
| Ok output -> (
679
-
if String.trim output = "" then None
680
-
else
681
-
(* Output format: "hash\trefs/heads/branch" *)
682
-
match String.split_on_char '\t' (String.trim output) with
683
-
| hash :: _ -> Some hash
684
-
| [] -> None)
+85
-67
lib/git_cli.mli
lib/git.mli
+85
-67
lib/git_cli.mli
lib/git.mli
···
128
128
branch:string ->
129
129
Fpath.t ->
130
130
(unit, error) result
131
-
(** [fetch_and_reset ~proc ~fs ?remote ~branch path] fetches from the remote and
132
-
resets the local branch to match the remote.
131
+
(** [fetch_and_reset ~proc ~fs ?remote ~branch path] fetches from the remote
132
+
and resets the local branch to match the remote.
133
133
134
134
This is useful for repositories that should not have local changes, as it
135
135
discards any local modifications and sets the working tree to exactly match
···
167
167
@param remote Remote name (default: "origin")
168
168
@param branch Branch to compare (default: current branch) *)
169
169
170
-
(** {1 Subtree Helper Operations} *)
170
+
(** {1 Subtree Operations} *)
171
171
172
-
val fetch_url :
173
-
proc:_ Eio.Process.mgr ->
174
-
fs:Eio.Fs.dir_ty Eio.Path.t ->
175
-
repo:Fpath.t ->
176
-
url:Uri.t ->
177
-
branch:string ->
178
-
unit ->
179
-
(string, error) result
180
-
(** [fetch_url ~proc ~fs ~repo ~url ~branch ()] fetches a branch from a URL and
181
-
returns the commit hash of FETCH_HEAD.
172
+
(** Operations for git subtree management in the monorepo. *)
173
+
module Subtree : sig
174
+
val add :
175
+
proc:_ Eio.Process.mgr ->
176
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
177
+
repo:Fpath.t ->
178
+
prefix:string ->
179
+
url:Uri.t ->
180
+
branch:string ->
181
+
unit ->
182
+
(unit, error) result
183
+
(** [add ~proc ~fs ~repo ~prefix ~url ~branch ()] adds a new subtree to the
184
+
repository.
182
185
183
-
@param repo Path to the local repository
184
-
@param url Git remote URL to fetch from
185
-
@param branch Branch to fetch *)
186
+
@param repo Path to the monorepo
187
+
@param prefix Subdirectory for the subtree
188
+
@param url Git remote URL for the subtree source
189
+
@param branch Branch to add *)
186
190
187
-
val push_refspec :
188
-
proc:_ Eio.Process.mgr ->
189
-
fs:Eio.Fs.dir_ty Eio.Path.t ->
190
-
repo:Fpath.t ->
191
-
url:Uri.t ->
192
-
refspec:string ->
193
-
unit ->
194
-
(unit, error) result
195
-
(** [push_refspec ~proc ~fs ~repo ~url ~refspec ()] pushes a refspec to a URL.
191
+
val pull :
192
+
proc:_ Eio.Process.mgr ->
193
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
194
+
repo:Fpath.t ->
195
+
prefix:string ->
196
+
url:Uri.t ->
197
+
branch:string ->
198
+
unit ->
199
+
(unit, error) result
200
+
(** [pull ~proc ~fs ~repo ~prefix ~url ~branch ()] pulls updates from the
201
+
remote into the subtree.
196
202
197
-
@param repo Path to the local repository
198
-
@param url Git remote URL to push to
199
-
@param refspec Git refspec (e.g. "hash:refs/heads/branch") *)
203
+
@param repo Path to the monorepo
204
+
@param prefix Subdirectory of the subtree
205
+
@param url Git remote URL
206
+
@param branch Branch to pull *)
200
207
201
-
val subtree_prefix_exists :
202
-
fs:Eio.Fs.dir_ty Eio.Path.t -> repo:Fpath.t -> prefix:string -> bool
203
-
(** [subtree_prefix_exists ~fs ~repo ~prefix] returns true if the subtree prefix
204
-
directory exists in the repository. *)
208
+
val push :
209
+
proc:_ Eio.Process.mgr ->
210
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
211
+
repo:Fpath.t ->
212
+
prefix:string ->
213
+
url:Uri.t ->
214
+
branch:string ->
215
+
unit ->
216
+
(unit, error) result
217
+
(** [push ~proc ~fs ~repo ~prefix ~url ~branch ()] pushes subtree changes to
218
+
the remote.
219
+
220
+
This extracts commits that affected the subtree and pushes them to the
221
+
specified remote/branch.
222
+
223
+
@param repo Path to the monorepo
224
+
@param prefix Subdirectory of the subtree
225
+
@param url Git remote URL
226
+
@param branch Branch to push to *)
227
+
228
+
val split :
229
+
proc:_ Eio.Process.mgr ->
230
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
231
+
repo:Fpath.t ->
232
+
prefix:string ->
233
+
unit ->
234
+
(string, error) result
235
+
(** [split ~proc ~fs ~repo ~prefix ()] extracts commits for a subtree into a
236
+
standalone branch.
237
+
238
+
Returns the commit hash of the split branch head. *)
239
+
240
+
val exists :
241
+
fs:Eio.Fs.dir_ty Eio.Path.t -> repo:Fpath.t -> prefix:string -> bool
242
+
(** [exists ~fs ~repo ~prefix] returns true if the subtree prefix directory
243
+
exists in the repository. *)
244
+
end
205
245
206
246
(** {1 Initialization} *)
207
247
···
450
490
451
491
(** Operations for git worktree management. *)
452
492
module Worktree : sig
493
+
(** A git worktree entry. *)
453
494
type entry = {
454
495
path : Fpath.t; (** Absolute path to the worktree *)
455
496
head : string; (** HEAD commit hash *)
456
497
branch : string option; (** Branch name if not detached *)
457
498
}
458
-
(** A git worktree entry. *)
459
499
460
500
val add :
461
501
proc:_ Eio.Process.mgr ->
···
499
539
repo:Fpath.t ->
500
540
path:Fpath.t ->
501
541
bool
502
-
(** [exists ~proc ~fs ~repo ~path] returns true if a worktree exists at
503
-
[path]. *)
542
+
(** [exists ~proc ~fs ~repo ~path] returns true if a worktree exists at [path]. *)
504
543
end
505
544
506
545
(** {1 Cherry-pick Operations} *)
···
511
550
commit:string ->
512
551
Fpath.t ->
513
552
(unit, error) result
514
-
(** [cherry_pick ~proc ~fs ~commit path] applies a single commit to the current
515
-
branch.
553
+
(** [cherry_pick ~proc ~fs ~commit path] applies a single commit to the current branch.
516
554
517
555
@param commit The commit hash to cherry-pick
518
556
@param path Path to the repository *)
···
524
562
?ff_only:bool ->
525
563
Fpath.t ->
526
564
(unit, error) result
527
-
(** [merge ~proc ~fs ~ref_name ?ff_only path] merges a ref into the current
528
-
branch.
565
+
(** [merge ~proc ~fs ~ref_name ?ff_only path] merges a ref into the current branch.
529
566
530
567
@param ref_name The ref to merge (e.g., "verse/handle/main")
531
568
@param ff_only If true, only allow fast-forward merges (default: false)
···
573
610
message:string ->
574
611
Fpath.t ->
575
612
(unit, error) result
576
-
(** [commit ~proc ~fs ~message path] creates a commit with the given message in
577
-
the repository at [path]. *)
613
+
(** [commit ~proc ~fs ~message path] creates a commit with the given message
614
+
in the repository at [path]. *)
578
615
579
616
val rm :
580
617
proc:_ Eio.Process.mgr ->
···
583
620
Fpath.t ->
584
621
string ->
585
622
(unit, error) result
586
-
(** [rm ~proc ~fs ~recursive path target] removes [target] from the git index in
587
-
the repository at [path]. If [recursive] is true, removes directories
623
+
(** [rm ~proc ~fs ~recursive path target] removes [target] from the git index
624
+
in the repository at [path]. If [recursive] is true, removes directories
588
625
recursively (git rm -r). *)
589
626
590
627
val config :
···
604
641
prefix:string ->
605
642
unit ->
606
643
bool
607
-
(** [has_subtree_history ~proc ~fs ~repo ~prefix ()] returns true if the prefix
608
-
has subtree commit history (i.e., was added via git subtree add). Returns
609
-
false for fresh local packages that were never part of a subtree. *)
644
+
(** [has_subtree_history ~proc ~fs ~repo ~prefix ()] returns true if the
645
+
prefix has subtree commit history (i.e., was added via git subtree add).
646
+
Returns false for fresh local packages that were never part of a subtree. *)
610
647
611
648
val branch_rename :
612
649
proc:_ Eio.Process.mgr ->
···
614
651
new_name:string ->
615
652
Fpath.t ->
616
653
(unit, error) result
617
-
(** [branch_rename ~proc ~fs ~new_name path] renames the current branch to
618
-
[new_name] in the repository at [path]. Uses [git branch -M]. *)
619
-
620
-
(** {1 Remote Queries} *)
621
-
622
-
val ls_remote_head :
623
-
proc:_ Eio.Process.mgr ->
624
-
fs:Eio.Fs.dir_ty Eio.Path.t ->
625
-
?remote:string ->
626
-
?branch:string ->
627
-
Fpath.t ->
628
-
string option
629
-
(** [ls_remote_head ~proc ~fs ?remote ?branch path] queries the remote for the
630
-
HEAD ref of a branch without fetching any objects.
631
-
632
-
This is much faster than [fetch] and can be used to check if there are any
633
-
new commits to fetch. Returns [None] if the branch doesn't exist or the
634
-
remote is unreachable.
635
-
636
-
@param remote Remote name (default: "origin")
637
-
@param branch Branch name (default: "main") *)
654
+
(** [branch_rename ~proc ~fs ~new_name path] renames the current branch
655
+
to [new_name] in the repository at [path]. Uses [git branch -M]. *)
+687
-1009
lib/monopam.ml
+687
-1009
lib/monopam.ml
···
1
1
module Config = Config
2
2
module Package = Package
3
3
module Opam_repo = Opam_repo
4
-
module Git_cli = Git_cli
4
+
module Git = Git
5
5
module Status = Status
6
6
module Changes = Changes
7
7
module Verse = Verse
···
16
16
module Sources_registry = Sources_registry
17
17
module Fork_join = Fork_join
18
18
module Site = Site
19
-
module Remote_cache = Remote_cache
20
19
21
20
let src = Logs.Src.create "monopam" ~doc:"Monopam operations"
22
21
23
22
module Log = (val Logs.src_log src : Logs.LOG)
24
23
25
-
(* Timing helper for benchmarking phases *)
26
-
let time_phase name f =
27
-
let t0 = Unix.gettimeofday () in
28
-
let result = f () in
29
-
let t1 = Unix.gettimeofday () in
30
-
Log.debug (fun m -> m "[TIMING] %s: %.3fs" name (t1 -. t0));
31
-
result
32
-
33
24
type error =
34
25
| Config_error of string
35
26
| Repo_error of Opam_repo.error
36
-
| Git_error of Git_cli.error
27
+
| Git_error of Git.error
37
28
| Dirty_state of Package.t list
38
29
| Monorepo_dirty
39
30
| Package_not_found of string
···
42
33
let pp_error ppf = function
43
34
| Config_error msg -> Fmt.pf ppf "Configuration error: %s" msg
44
35
| Repo_error e -> Fmt.pf ppf "Repository error: %a" Opam_repo.pp_error e
45
-
| Git_error e -> Fmt.pf ppf "Git error: %a" Git_cli.pp_error e
36
+
| Git_error e -> Fmt.pf ppf "Git error: %a" Git.pp_error e
46
37
| Dirty_state pkgs ->
47
38
Fmt.pf ppf "Dirty packages: %a"
48
39
Fmt.(list ~sep:comma (using Package.name string))
···
55
46
*)
56
47
let error_hint = function
57
48
| Config_error _ ->
58
-
Some "Run 'monopam init --handle <your-handle>' to create a workspace."
49
+
Some
50
+
"Run 'monopam init --handle <your-handle>' to create a workspace."
59
51
| Repo_error (Opam_repo.No_dev_repo _) ->
60
52
Some
61
53
"Add a 'dev-repo' field to the package's opam file pointing to a git \
···
63
55
| Repo_error (Opam_repo.Not_git_remote _) ->
64
56
Some "The dev-repo must be a git URL (git+https:// or git://)."
65
57
| Repo_error _ -> None
66
-
| Git_error (Git_cli.Dirty_worktree _) ->
58
+
| Git_error (Git.Dirty_worktree _) ->
67
59
Some "Commit or stash your changes first: cd <repo> && git status"
68
-
| Git_error (Git_cli.Not_a_repo _) ->
60
+
| Git_error (Git.Not_a_repo _) ->
69
61
Some "Run 'monopam sync' to clone missing repositories."
70
-
| Git_error (Git_cli.Subtree_prefix_missing _) ->
62
+
| Git_error (Git.Subtree_prefix_missing _) ->
71
63
Some "Run 'monopam sync' to set up the subtree."
72
-
| Git_error (Git_cli.Remote_not_found _) ->
64
+
| Git_error (Git.Remote_not_found _) ->
73
65
Some "Check that the remote is configured: git remote -v"
74
-
| Git_error (Git_cli.Branch_not_found _) ->
66
+
| Git_error (Git.Branch_not_found _) ->
75
67
Some "Check available branches: git branch -a"
76
-
| Git_error (Git_cli.Command_failed (cmd, _))
68
+
| Git_error (Git.Command_failed (cmd, _))
77
69
when String.starts_with ~prefix:"git push" cmd ->
78
70
Some "Check your network connection and git credentials."
79
-
| Git_error (Git_cli.Command_failed (cmd, _))
71
+
| Git_error (Git.Command_failed (cmd, _))
80
72
when String.starts_with ~prefix:"git subtree" cmd ->
81
73
Some "Run 'monopam status' to check repository state."
82
74
| Git_error _ -> None
···
85
77
"Commit changes in the monorepo first: cd mono && git add -A && git \
86
78
commit"
87
79
| Monorepo_dirty ->
88
-
Some
89
-
"Commit or stash your changes first: git status && git add -A && git \
90
-
commit"
80
+
Some "Commit or stash your changes first: git status && git add -A && git commit"
91
81
| Package_not_found _ ->
92
82
Some "Check available packages: ls opam-repo/packages/"
93
83
| Claude_error msg when String.starts_with ~prefix:"Failed to decode" msg ->
···
146
136
let fs = fs_typed fs in
147
137
ensure_checkouts_dir ~fs ~config;
148
138
discover_packages ~fs:(fs :> _ Eio.Path.t) ~config ()
149
-
|> Result.map (Status.compute_all ~fs ~config)
139
+
|> Result.map (Status.compute_all ~proc ~fs ~config)
150
140
151
141
(** Find opam files in monorepo subtrees that aren't registered in the overlay.
152
142
Returns a list of (subtree_name, unregistered_package_name) pairs. *)
···
197
187
with Eio.Io _ -> [])
198
188
repos
199
189
190
+
(** Information about a package discovered from the monorepo. *)
200
191
type monorepo_package = {
201
192
pkg_name : string;
202
193
subtree : string;
···
204
195
url_src : string;
205
196
opam_content : string;
206
197
}
207
-
(** Information about a package discovered from the monorepo. *)
208
198
209
-
(** Discover packages from monorepo subtrees by parsing dune-project files. If
210
-
[sources] is provided, it overrides the dev-repo URL for matching subtrees.
211
-
*)
212
-
let discover_packages_from_monorepo ~fs ~config
213
-
?(sources = Sources_registry.empty) () =
199
+
(** Discover packages from monorepo subtrees by parsing dune-project files.
200
+
If [sources] is provided, it overrides the dev-repo URL for matching subtrees. *)
201
+
let discover_packages_from_monorepo ~fs ~config ?(sources = Sources_registry.empty) () =
214
202
let fs = fs_typed fs in
215
203
let monorepo = Config.Paths.monorepo config in
216
204
let monorepo_eio = Eio.Path.(fs / Fpath.to_string monorepo) in
···
227
215
with Eio.Io _ -> []
228
216
in
229
217
230
-
Log.debug (fun m ->
231
-
m "Found %d subdirectories in monorepo" (List.length subdirs));
218
+
Log.debug (fun m -> m "Found %d subdirectories in monorepo" (List.length subdirs));
232
219
233
220
(* Process each subdirectory *)
234
221
let packages, errors =
···
242
229
| `Regular_file -> (
243
230
(* Parse dune-project *)
244
231
let content =
245
-
try Some (Eio.Path.load dune_project_path) with Eio.Io _ -> None
232
+
try Some (Eio.Path.load dune_project_path)
233
+
with Eio.Io _ -> None
246
234
in
247
235
match content with
248
236
| None -> (pkgs, errs)
···
266
254
1. Explicit sources.toml entry for this subtree
267
255
2. dune-project source/homepage
268
256
3. sources.toml default_url_base + subtree name *)
269
-
let sources_override =
270
-
Sources_registry.find sources ~subtree
271
-
in
257
+
let sources_override = Sources_registry.find sources ~subtree in
272
258
273
259
let derive_from_dune () =
274
260
match
···
284
270
match Sources_registry.derive_url sources ~subtree with
285
271
| Some dev_repo ->
286
272
Log.debug (fun m ->
287
-
m "Using default_url_base for %s: %s" subtree
288
-
dev_repo);
273
+
m "Using default_url_base for %s: %s" subtree dev_repo);
289
274
Some (dev_repo, dev_repo ^ "#main")
290
275
| None -> None
291
276
in
···
301
286
| None -> (
302
287
(* Try to get branch from dune-project, default to main *)
303
288
match dune_proj.source with
304
-
| Some (Dune_project.Uri { branch = Some b; _ })
305
-
->
306
-
b
289
+
| Some (Dune_project.Uri { branch = Some b; _ }) -> b
307
290
| _ -> "main")
308
291
in
309
292
Log.debug (fun m ->
310
-
m "Using sources.toml entry for %s: %s" subtree
311
-
dev_repo);
293
+
m "Using sources.toml entry for %s: %s" subtree dev_repo);
312
294
Some (dev_repo, dev_repo ^ "#" ^ branch)
313
295
| None -> (
314
296
match derive_from_dune () with
···
318
300
| Some result -> Some result
319
301
| None ->
320
302
Log.warn (fun m ->
321
-
m
322
-
"Cannot derive dev-repo for %s (no \
323
-
source in dune-project or \
324
-
sources.toml)"
325
-
subtree);
303
+
m "Cannot derive dev-repo for %s (no source in dune-project or sources.toml)" subtree);
326
304
None))
327
305
in
328
306
match dev_repo_and_url with
329
307
| None -> (pkgs, "Cannot derive dev-repo" :: errs)
330
308
| Some (dev_repo, url_src) ->
331
309
Log.debug (fun m ->
332
-
m "Found %d opam files in %s"
333
-
(List.length opam_files) subtree);
310
+
m "Found %d opam files in %s" (List.length opam_files)
311
+
subtree);
334
312
(* Transform each opam file *)
335
313
let new_pkgs =
336
314
List.filter_map
···
348
326
~dev_repo ~url_src
349
327
in
350
328
Some
351
-
{
352
-
pkg_name;
353
-
subtree;
354
-
dev_repo;
355
-
url_src;
356
-
opam_content;
357
-
}
329
+
{ pkg_name; subtree; dev_repo; url_src; opam_content }
358
330
with Eio.Io _ -> None)
359
331
opam_files
360
332
in
···
363
335
(* No dune-project, skip *)
364
336
Log.debug (fun m -> m "No dune-project in %s, skipping" subtree);
365
337
(pkgs, errs)
366
-
| exception Eio.Io _ -> (pkgs, errs))
338
+
| exception Eio.Io _ ->
339
+
(pkgs, errs))
367
340
([], []) subdirs
368
341
in
369
342
···
394
367
Log.info (fun m ->
395
368
m "Cloning %s from %a (branch: %s)" (Package.repo_name pkg) Uri.pp
396
369
(Package.dev_repo pkg) branch);
397
-
Git_cli.clone ~proc ~fs ~url:(Package.dev_repo pkg) ~branch checkout_dir
370
+
Git.clone ~proc ~fs ~url:(Package.dev_repo pkg) ~branch checkout_dir
398
371
in
399
372
let is_directory =
400
373
match Eio.Path.kind ~follow:true checkout_eio with
···
403
376
| exception Eio.Io _ -> false
404
377
in
405
378
if not is_directory then do_clone ()
406
-
else if not (Git_cli.is_repo ~proc ~fs checkout_dir) then do_clone ()
379
+
else if not (Git.is_repo ~proc ~fs checkout_dir) then do_clone ()
407
380
else begin
408
381
Log.info (fun m -> m "Fetching %s" (Package.repo_name pkg));
409
-
match Git_cli.fetch ~proc ~fs checkout_dir with
382
+
match Git.fetch ~proc ~fs checkout_dir with
410
383
| Error e -> Error e
411
384
| Ok () ->
412
385
Log.info (fun m -> m "Updating %s to %s" (Package.repo_name pkg) branch);
413
-
Git_cli.merge_ff ~proc ~fs ~branch checkout_dir
386
+
Git.merge_ff ~proc ~fs ~branch checkout_dir
414
387
end
415
388
416
389
(* Group packages by their repository *)
···
684
657
let monorepo_eio = Eio.Path.(fs / Fpath.to_string monorepo) in
685
658
let init_and_commit () =
686
659
Log.info (fun m -> m "Initializing monorepo at %a" Fpath.pp monorepo);
687
-
match Git_cli.init ~proc ~fs monorepo with
660
+
match Git.init ~proc ~fs monorepo with
688
661
| Error e -> Error (Git_error e)
689
662
| Ok () -> (
690
663
(* Create dune-project file so the monorepo builds *)
···
711
684
(* Commit *)
712
685
Log.debug (fun m -> m "Creating initial commit in monorepo");
713
686
match
714
-
Git_cli.commit_allow_empty ~proc ~fs
687
+
Git.commit_allow_empty ~proc ~fs
715
688
~message:
716
689
"Initial commit with dune-project, CLAUDE.md, and .gitignore"
717
690
monorepo
···
749
722
| _ -> false
750
723
| exception Eio.Io _ -> false
751
724
in
752
-
if is_directory && Git_cli.is_repo ~proc ~fs monorepo then begin
725
+
if is_directory && Git.is_repo ~proc ~fs monorepo then begin
753
726
Log.debug (fun m ->
754
727
m "Monorepo already initialized at %a" Fpath.pp monorepo);
755
728
ensure_file ~filename:"CLAUDE.md" ~content:claude_md_content;
···
832
805
833
806
(** Convert a clone URL to a push URL.
834
807
- GitHub HTTPS URLs are converted to SSH format
835
-
- Tangled URLs (tangled.org/tangled.sh) are converted to SSH format using
836
-
the knot server
808
+
- Tangled URLs (tangled.org/tangled.sh) are converted to SSH format using the knot server
837
809
- Other URLs are returned unchanged
838
-
839
-
@param knot
840
-
Git push server hostname. Defaults to git.recoil.org if not provided. *)
810
+
@param knot Git push server hostname. Defaults to git.recoil.org if not provided. *)
841
811
let url_to_push_url ?knot uri =
842
812
let scheme = Uri.scheme uri in
843
813
let host = Uri.host uri in
···
926
896
(* Pull from local checkout, not remote URL - ensures push/pull use same source *)
927
897
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
928
898
let url = Uri.of_string (Fpath.to_string checkout_dir) in
929
-
let subtree_exists =
930
-
Git_cli.subtree_prefix_exists ~fs ~repo:monorepo ~prefix
931
-
in
932
-
(* Fetch from checkout and get commit hash *)
933
-
match Git_cli.fetch_url ~proc ~fs ~repo:monorepo ~url ~branch () with
934
-
| Error e -> Error (Git_error e)
935
-
| Ok hash_hex ->
936
-
let repo_path = Fpath.to_string monorepo in
937
-
let git_repo = Git.Repository.open_repo ~fs repo_path in
938
-
let commit = Git.Hash.of_hex hash_hex in
939
-
let user =
940
-
Git.User.make ~name:"monopam" ~email:"monopam@localhost"
941
-
~date:(Int64.of_float (Unix.time ()))
942
-
()
943
-
in
944
-
if subtree_exists then begin
945
-
Log.info (fun m ->
946
-
m "Pulling subtree %s from %a" prefix Fpath.pp checkout_dir);
947
-
let message =
948
-
Fmt.str
949
-
"Merge '%s/' from %s\n\n\
950
-
git-subtree-dir: %s\n\
951
-
git-subtree-mainline: %s\n"
952
-
prefix (Uri.to_string url) prefix hash_hex
953
-
in
954
-
match
955
-
Git.Subtree.merge git_repo ~prefix ~commit ~author:user
956
-
~committer:user ~message ()
957
-
with
958
-
| Ok _ -> Ok false (* not newly added *)
959
-
| Error (`Msg msg) -> Error (Git_error (Git_cli.Io_error msg))
960
-
end
961
-
else begin
962
-
Log.info (fun m ->
963
-
m "Adding subtree %s from %a" prefix Fpath.pp checkout_dir);
964
-
let message =
965
-
Fmt.str
966
-
"Add '%s/' from %s\n\n\
967
-
git-subtree-dir: %s\n\
968
-
git-subtree-mainline: %s\n"
969
-
prefix (Uri.to_string url) prefix hash_hex
970
-
in
971
-
match
972
-
Git.Subtree.add git_repo ~prefix ~commit ~author:user ~committer:user
973
-
~message ()
974
-
with
975
-
| Ok _ -> Ok true (* newly added *)
976
-
| Error (`Msg msg) -> Error (Git_error (Git_cli.Io_error msg))
977
-
end
899
+
if Git.Subtree.exists ~fs ~repo:monorepo ~prefix then begin
900
+
Log.info (fun m -> m "Pulling subtree %s from %a" prefix Fpath.pp checkout_dir);
901
+
match Git.Subtree.pull ~proc ~fs ~repo:monorepo ~prefix ~url ~branch () with
902
+
| Ok () -> Ok false (* not newly added *)
903
+
| Error e -> Error (Git_error e)
904
+
end
905
+
else begin
906
+
Log.info (fun m -> m "Adding subtree %s from %a" prefix Fpath.pp checkout_dir);
907
+
match Git.Subtree.add ~proc ~fs ~repo:monorepo ~prefix ~url ~branch () with
908
+
| Ok () -> Ok true (* newly added *)
909
+
| Error e -> Error (Git_error e)
910
+
end
978
911
979
912
(* Check if checkout exists and is a repo *)
980
913
let checkout_exists ~proc ~fs ~config pkg =
···
982
915
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
983
916
let checkout_eio = Eio.Path.(fs / Fpath.to_string checkout_dir) in
984
917
match Eio.Path.kind ~follow:true checkout_eio with
985
-
| `Directory -> Git_cli.is_repo ~proc ~fs checkout_dir
918
+
| `Directory -> Git.is_repo ~proc ~fs checkout_dir
986
919
| _ -> false
987
920
| exception Eio.Io _ -> false
988
921
···
991
924
let checkouts_root = Config.Paths.checkouts config in
992
925
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
993
926
let branch = get_branch ~config pkg in
994
-
match Git_cli.ahead_behind ~proc ~fs ~branch checkout_dir with
927
+
match Git.ahead_behind ~proc ~fs ~branch checkout_dir with
995
928
| Ok ab -> ab.behind
996
929
| Error _ -> 0
997
930
···
999
932
let fs_t = fs_typed fs in
1000
933
(* Update the opam repo first - clone if needed *)
1001
934
let opam_repo = Config.Paths.opam_repo config in
1002
-
if Git_cli.is_repo ~proc ~fs:fs_t opam_repo then begin
935
+
if Git.is_repo ~proc ~fs:fs_t opam_repo then begin
1003
936
Log.info (fun m -> m "Updating opam repo at %a" Fpath.pp opam_repo);
1004
937
let result =
1005
938
let ( let* ) = Result.bind in
1006
-
let* () = Git_cli.fetch ~proc ~fs:fs_t opam_repo in
1007
-
Git_cli.merge_ff ~proc ~fs:fs_t opam_repo
939
+
let* () = Git.fetch ~proc ~fs:fs_t opam_repo in
940
+
Git.merge_ff ~proc ~fs:fs_t opam_repo
1008
941
in
1009
942
match result with
1010
943
| Ok () -> ()
1011
944
| Error e ->
1012
-
Log.warn (fun m ->
1013
-
m "Failed to update opam repo: %a" Git_cli.pp_error e)
945
+
Log.warn (fun m -> m "Failed to update opam repo: %a" Git.pp_error e)
1014
946
end
1015
947
else begin
1016
948
(* Opam repo doesn't exist - clone it if we have a URL *)
···
1020
952
m "Cloning opam repo from %s to %a" url Fpath.pp opam_repo);
1021
953
let url = Uri.of_string url in
1022
954
let branch = Config.default_branch in
1023
-
match Git_cli.clone ~proc ~fs:fs_t ~url ~branch opam_repo with
955
+
match Git.clone ~proc ~fs:fs_t ~url ~branch opam_repo with
1024
956
| Ok () -> Log.info (fun m -> m "Opam repo cloned successfully")
1025
957
| Error e ->
1026
-
Log.warn (fun m ->
1027
-
m "Failed to clone opam repo: %a" Git_cli.pp_error e))
958
+
Log.warn (fun m -> m "Failed to clone opam repo: %a" Git.pp_error e)
959
+
)
1028
960
| None ->
1029
961
Log.info (fun m ->
1030
962
m "Opam repo at %a does not exist and no URL provided" Fpath.pp
···
1048
980
else begin
1049
981
Log.info (fun m ->
1050
982
m "Checking status of %d packages" (List.length pkgs));
1051
-
let statuses = Status.compute_all ~fs:fs_t ~config pkgs in
983
+
let statuses = Status.compute_all ~proc ~fs:fs_t ~config pkgs in
1052
984
let dirty =
1053
985
List.filter Status.has_local_changes statuses
1054
986
|> List.map (fun s -> s.Status.package)
···
1180
1112
let checkouts_root = Config.Paths.checkouts config in
1181
1113
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
1182
1114
let branch = get_branch ~config pkg in
1183
-
if not (Git_cli.subtree_prefix_exists ~fs ~repo:monorepo ~prefix) then begin
1115
+
if not (Git.Subtree.exists ~fs ~repo:monorepo ~prefix) then begin
1184
1116
Log.debug (fun m -> m "Subtree %s not in monorepo, skipping" prefix);
1185
1117
Ok ()
1186
1118
end
···
1189
1121
let needs_clone =
1190
1122
match Eio.Path.kind ~follow:true checkout_eio with
1191
1123
| exception Eio.Io _ -> true
1192
-
| `Directory when Git_cli.is_repo ~proc ~fs checkout_dir -> false
1124
+
| `Directory when Git.is_repo ~proc ~fs checkout_dir -> false
1193
1125
| _ -> true
1194
1126
in
1195
1127
let* () =
···
1199
1131
end
1200
1132
else Ok ()
1201
1133
in
1202
-
(* Use native subtree split + push to export commits to the checkout.
1134
+
(* Use git subtree push to export commits to the checkout.
1203
1135
This preserves commit identity, ensuring round-trips converge. *)
1204
1136
let checkout_url = Uri.of_string (Fpath.to_string checkout_dir) in
1205
1137
Log.info (fun m -> m "Subtree push %s -> %a" prefix Fpath.pp checkout_dir);
1206
-
let repo_path = Fpath.to_string monorepo in
1207
-
let git_repo = Git.Repository.open_repo ~fs repo_path in
1208
-
match Git.Repository.read_ref git_repo "HEAD" with
1209
-
| None -> Error (Git_error (Git_cli.Io_error "no HEAD ref found"))
1210
-
| Some head -> (
1211
-
match Git.Subtree.split git_repo ~prefix ~head () with
1212
-
| Ok None -> Error (Git_error (Git_cli.Subtree_prefix_missing prefix))
1213
-
| Error (`Msg msg) -> Error (Git_error (Git_cli.Io_error msg))
1214
-
| Ok (Some split_hash) ->
1215
-
let refspec =
1216
-
Git.Hash.to_hex split_hash ^ ":refs/heads/" ^ branch
1217
-
in
1218
-
let* () =
1219
-
Git_cli.push_refspec ~proc ~fs ~repo:monorepo ~url:checkout_url
1220
-
~refspec ()
1221
-
in
1222
-
Ok ())
1138
+
let* () = Git.Subtree.push ~proc ~fs ~repo:monorepo ~prefix ~url:checkout_url ~branch () in
1139
+
Ok ()
1223
1140
end
1224
1141
1225
1142
let push ~proc ~fs ~config ?package ?(upstream = false) () =
···
1239
1156
else begin
1240
1157
Log.info (fun m ->
1241
1158
m "Checking status of %d packages" (List.length pkgs));
1242
-
let statuses = Status.compute_all ~fs:fs_t ~config pkgs in
1159
+
let statuses = Status.compute_all ~proc ~fs:fs_t ~config pkgs in
1243
1160
let dirty =
1244
1161
List.filter Status.has_local_changes statuses
1245
1162
|> List.map (fun s -> s.Status.package)
···
1280
1197
m "Pushing %s to %s" (Package.repo_name pkg) push_url);
1281
1198
(* Set the push URL for origin *)
1282
1199
(match
1283
-
Git_cli.set_push_url ~proc ~fs:fs_t ~url:push_url
1200
+
Git.set_push_url ~proc ~fs:fs_t ~url:push_url
1284
1201
checkout_dir
1285
1202
with
1286
1203
| Ok () -> ()
1287
1204
| Error e ->
1288
1205
Log.warn (fun m ->
1289
-
m "Failed to set push URL: %a" Git_cli.pp_error e));
1206
+
m "Failed to set push URL: %a" Git.pp_error e));
1290
1207
match
1291
-
Git_cli.push_remote ~proc ~fs:fs_t ~branch checkout_dir
1208
+
Git.push_remote ~proc ~fs:fs_t ~branch checkout_dir
1292
1209
with
1293
1210
| Ok () ->
1294
1211
Log.app (fun m ->
···
1313
1230
type sync_failure = {
1314
1231
repo_name : string;
1315
1232
phase : sync_phase;
1316
-
error : Git_cli.error;
1233
+
error : Git.error;
1317
1234
}
1318
1235
1319
1236
type sync_summary = {
···
1332
1249
| `Push_remote -> Fmt.string ppf "push-remote"
1333
1250
1334
1251
let pp_sync_failure ppf f =
1335
-
Fmt.pf ppf "%s (%a): %a" f.repo_name pp_sync_phase f.phase Git_cli.pp_error
1252
+
Fmt.pf ppf "%s (%a): %a" f.repo_name pp_sync_phase f.phase Git.pp_error
1336
1253
f.error
1337
1254
1338
1255
let pp_sync_summary ppf s =
···
1355
1272
| _ -> false
1356
1273
| exception Eio.Io _ -> false
1357
1274
in
1358
-
let was_cloned =
1359
-
not (is_directory && Git_cli.is_repo ~proc ~fs checkout_dir)
1360
-
in
1275
+
let was_cloned = not (is_directory && Git.is_repo ~proc ~fs checkout_dir) in
1361
1276
if was_cloned then begin
1362
1277
Log.info (fun m ->
1363
1278
m "Cloning %s from %a (branch: %s)" (Package.repo_name pkg) Uri.pp
1364
1279
(Package.dev_repo pkg) branch);
1365
1280
match
1366
-
Git_cli.clone ~proc ~fs ~url:(Package.dev_repo pkg) ~branch checkout_dir
1281
+
Git.clone ~proc ~fs ~url:(Package.dev_repo pkg) ~branch checkout_dir
1367
1282
with
1368
1283
| Ok () ->
1369
1284
(* Configure checkout to accept pushes to current branch.
···
1372
1287
Eio.Switch.run (fun sw ->
1373
1288
let child =
1374
1289
Eio.Process.spawn proc ~sw ~cwd
1375
-
[
1376
-
"git"; "config"; "receive.denyCurrentBranch"; "updateInstead";
1377
-
]
1290
+
[ "git"; "config"; "receive.denyCurrentBranch"; "updateInstead" ]
1378
1291
in
1379
1292
ignore (Eio.Process.await child));
1380
1293
Ok (true, 0)
···
1393
1306
end
1394
1307
1395
1308
(* Fetch a single checkout - safe for parallel execution *)
1396
-
1397
-
(** Wrapper around Remote_cache that adds disk persistence via XDG cache *)
1398
-
module Cached_remote_heads : sig
1399
-
type t
1400
-
1401
-
val create : xdg:Xdge.t -> now:(unit -> float) -> t
1402
-
val get : t -> url:Uri.t -> branch:string -> string option
1403
-
val set : t -> url:Uri.t -> branch:string -> hash:string -> unit
1404
-
end = struct
1405
-
type t = { cache : Remote_cache.t; cache_file : Eio.Fs.dir_ty Eio.Path.t }
1406
-
1407
-
let filename = "remote-heads"
1408
-
1409
-
let create ~xdg ~now =
1410
-
let cache_file = Eio.Path.(Xdge.cache_dir xdg / filename) in
1411
-
let content = try Eio.Path.load cache_file with _ -> "" in
1412
-
let cache = Remote_cache.create_from_string ~now content in
1413
-
{ cache; cache_file }
1414
-
1415
-
let get t = Remote_cache.get t.cache
1416
-
1417
-
let set t ~url ~branch ~hash =
1418
-
Remote_cache.set t.cache ~url ~branch ~hash;
1419
-
let content = Remote_cache.to_string t.cache in
1420
-
try Eio.Path.save ~create:(`Or_truncate 0o644) t.cache_file content
1421
-
with _ -> ()
1422
-
end
1423
-
1424
-
let fetch_checkout_safe ~sw ~env ~proc ~fs ~config ~cache ~get_session pkg =
1425
-
let repo = Package.repo_name pkg in
1309
+
let fetch_checkout_safe ~proc ~fs ~config pkg =
1426
1310
let checkouts_root = Config.Paths.checkouts config in
1427
1311
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
1428
1312
let branch = get_branch ~config pkg in
1429
-
let remote_url = Package.dev_repo pkg in
1430
-
let local_head =
1431
-
Git_cli.rev_parse ~proc ~fs ~rev:(Fmt.str "origin/%s" branch) checkout_dir
1432
-
|> Result.to_option
1313
+
(* Get commits behind before fetching *)
1314
+
let behind_before =
1315
+
match Git.ahead_behind ~proc ~fs ~branch checkout_dir with
1316
+
| Ok ab -> ab.behind
1317
+
| Error _ -> 0
1433
1318
in
1434
-
(* Check if we can skip fetch entirely *)
1435
-
let remote_matches_local hash =
1436
-
match local_head with Some h -> hash = h | None -> false
1437
-
in
1438
-
(* Step 1: Try cached remote HEAD - O(1) hashtbl lookup *)
1439
-
match Cached_remote_heads.get cache ~url:remote_url ~branch with
1440
-
| Some cached when remote_matches_local cached ->
1441
-
Log.debug (fun m -> m "Skipping fetch for %s (cached)" repo);
1442
-
Ok 0
1443
-
| _ -> (
1444
-
(* Step 2: Query remote HEAD via HTTP (lazily creates session) *)
1445
-
let remote =
1446
-
time_phase (Fmt.str "ls-remote:%s" repo) (fun () ->
1447
-
Git.Remote.get_remote_head ~session:(get_session ()) ~sw ~env
1448
-
remote_url ~branch)
1319
+
Log.info (fun m -> m "Fetching %s (all remotes)" (Package.repo_name pkg));
1320
+
match Git.fetch_all ~proc ~fs checkout_dir with
1321
+
| Error e -> Error e
1322
+
| Ok () ->
1323
+
(* Get commits behind after fetching *)
1324
+
let behind_after =
1325
+
match Git.ahead_behind ~proc ~fs ~branch checkout_dir with
1326
+
| Ok ab -> ab.behind
1327
+
| Error _ -> 0
1449
1328
in
1450
-
Option.iter
1451
-
(fun h ->
1452
-
Cached_remote_heads.set cache ~url:remote_url ~branch
1453
-
~hash:(Git.Hash.to_hex h))
1454
-
remote;
1455
-
match remote with
1456
-
| Some h when remote_matches_local (Git.Hash.to_hex h) ->
1457
-
Log.debug (fun m -> m "Skipping fetch for %s (remote unchanged)" repo);
1458
-
Ok 0
1459
-
| _ ->
1460
-
(* Step 3: Do full git fetch *)
1461
-
let get_behind () =
1462
-
Git_cli.ahead_behind ~proc ~fs ~branch checkout_dir
1463
-
|> Result.map (fun (ab : Git_cli.ahead_behind) -> ab.behind)
1464
-
|> Result.value ~default:0
1465
-
in
1466
-
let behind_before = get_behind () in
1467
-
Log.info (fun m -> m "Fetching %s (all remotes)" repo);
1468
-
Git_cli.fetch_all ~proc ~fs checkout_dir
1469
-
|> Result.map (fun () -> get_behind () - behind_before))
1329
+
Ok (behind_after - behind_before)
1470
1330
1471
1331
(* Merge checkout to latest - must be sequential *)
1472
1332
let merge_checkout_safe ~proc ~fs ~config pkg =
···
1474
1334
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
1475
1335
let branch = get_branch ~config pkg in
1476
1336
Log.info (fun m -> m "Merging %s to %s" (Package.repo_name pkg) branch);
1477
-
Git_cli.merge_ff ~proc ~fs ~branch checkout_dir
1337
+
Git.merge_ff ~proc ~fs ~branch checkout_dir
1478
1338
1479
1339
(* Push checkout to remote - safe for parallel execution *)
1480
1340
let push_remote_safe ~proc ~fs ~config pkg =
···
1484
1344
let push_url = url_to_push_url (Package.dev_repo pkg) in
1485
1345
Log.info (fun m -> m "Pushing %s to %s" (Package.repo_name pkg) push_url);
1486
1346
(* Set the push URL for origin *)
1487
-
(match Git_cli.set_push_url ~proc ~fs ~url:push_url checkout_dir with
1347
+
(match Git.set_push_url ~proc ~fs ~url:push_url checkout_dir with
1488
1348
| Ok () -> ()
1489
-
| Error e ->
1490
-
Log.warn (fun m -> m "Failed to set push URL: %a" Git_cli.pp_error e));
1491
-
Git_cli.push_remote ~proc ~fs ~branch checkout_dir
1349
+
| Error e -> Log.warn (fun m -> m "Failed to set push URL: %a" Git.pp_error e));
1350
+
Git.push_remote ~proc ~fs ~branch checkout_dir
1492
1351
1493
1352
(* Sanitize handle for use as git remote name *)
1494
1353
let sanitize_remote_name handle =
1495
1354
(* Replace @ and . with - for valid git remote names *)
1496
1355
String.map (function '@' | '.' -> '-' | c -> c) handle
1497
1356
1498
-
(* Ensure verse remotes for a single repo - fully native git *)
1499
-
let ensure_verse_remotes_for_repo ~fs ~config ~verse_subtrees pkg =
1357
+
(* Ensure verse remotes for a single repo *)
1358
+
let ensure_verse_remotes_for_repo ~proc ~fs ~config ~verse_subtrees pkg =
1500
1359
let checkouts_root = Config.Paths.checkouts config in
1501
1360
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
1502
-
let checkout_path = Fpath.to_string checkout_dir in
1503
1361
let repo_name = Package.repo_name pkg in
1504
1362
1505
-
(* Only process if checkout exists - use native git *)
1506
-
if not (Git.Repository.is_repo ~fs checkout_path) then ()
1363
+
(* Only process if checkout exists *)
1364
+
if not (Git.is_repo ~proc ~fs checkout_dir) then ()
1507
1365
else begin
1508
1366
(* Get all verse members who have this repo *)
1509
1367
let members_with_repo =
1510
1368
Hashtbl.find_opt verse_subtrees repo_name |> Option.value ~default:[]
1511
1369
in
1512
1370
1513
-
(* Get current remotes - use native git *)
1514
-
let repo = Git.Repository.open_repo ~fs checkout_path in
1515
-
let current_remotes = Git.Repository.list_remotes repo in
1371
+
(* Get current remotes *)
1372
+
let current_remotes = Git.list_remotes ~proc ~fs checkout_dir in
1516
1373
let verse_remotes =
1517
1374
List.filter
1518
1375
(fun r -> String.starts_with ~prefix:"verse-" r)
1519
1376
current_remotes
1520
1377
in
1521
1378
1522
-
(* Build set of expected verse remotes with their URLs *)
1379
+
(* Build set of expected verse remotes *)
1523
1380
let expected_remotes =
1524
-
List.filter_map
1525
-
(fun (handle, verse_mono_path) ->
1526
-
let remote_name = "verse-" ^ sanitize_remote_name handle in
1527
-
let verse_src = Fpath.(parent verse_mono_path / "src" / repo_name) in
1528
-
if Sys.file_exists (Fpath.to_string verse_src) then
1529
-
Some (remote_name, Fpath.to_string verse_src)
1530
-
else None)
1381
+
List.map
1382
+
(fun (handle, _) -> "verse-" ^ sanitize_remote_name handle)
1531
1383
members_with_repo
1532
1384
in
1533
-
let expected_names = List.map fst expected_remotes in
1534
1385
1535
-
(* Add/update remotes for verse members - native git *)
1386
+
(* Add/update remotes for verse members *)
1536
1387
List.iter
1537
-
(fun (remote_name, url) ->
1538
-
match Git.Repository.ensure_remote repo ~name:remote_name ~url with
1539
-
| Ok () ->
1540
-
Log.debug (fun m ->
1541
-
m "Ensured verse remote %s -> %s" remote_name url)
1542
-
| Error (`Msg msg) ->
1543
-
Log.warn (fun m ->
1544
-
m "Failed to add verse remote %s: %s" remote_name msg))
1545
-
expected_remotes;
1388
+
(fun (handle, verse_mono_path) ->
1389
+
let remote_name = "verse-" ^ sanitize_remote_name handle in
1390
+
(* Point to their src/ checkout for this repo *)
1391
+
let verse_src = Fpath.(parent verse_mono_path / "src" / repo_name) in
1392
+
if Sys.file_exists (Fpath.to_string verse_src) then begin
1393
+
let url = Fpath.to_string verse_src in
1394
+
match
1395
+
Git.ensure_remote ~proc ~fs ~name:remote_name ~url checkout_dir
1396
+
with
1397
+
| Ok () ->
1398
+
Log.debug (fun m ->
1399
+
m "Ensured verse remote %s -> %s" remote_name url)
1400
+
| Error e ->
1401
+
Log.warn (fun m ->
1402
+
m "Failed to add verse remote %s: %a" remote_name Git.pp_error
1403
+
e)
1404
+
end)
1405
+
members_with_repo;
1546
1406
1547
-
(* Remove outdated verse remotes - native git *)
1407
+
(* Remove outdated verse remotes *)
1548
1408
List.iter
1549
1409
(fun remote_name ->
1550
-
if not (List.mem remote_name expected_names) then begin
1410
+
if not (List.mem remote_name expected_remotes) then begin
1551
1411
Log.debug (fun m -> m "Removing outdated verse remote %s" remote_name);
1552
-
match Git.Repository.remove_remote repo remote_name with
1412
+
match Git.remove_remote ~proc ~fs ~name:remote_name checkout_dir with
1553
1413
| Ok () -> ()
1554
-
| Error (`Msg msg) ->
1414
+
| Error e ->
1555
1415
Log.warn (fun m ->
1556
-
m "Failed to remove verse remote %s: %s" remote_name msg)
1416
+
m "Failed to remove verse remote %s: %a" remote_name
1417
+
Git.pp_error e)
1557
1418
end)
1558
1419
verse_remotes
1559
1420
end
···
1565
1426
Verse.get_verse_subtrees ~proc ~fs ~config:verse_config ()
1566
1427
in
1567
1428
List.iter
1568
-
(fun pkg -> ensure_verse_remotes_for_repo ~fs ~config ~verse_subtrees pkg)
1429
+
(fun pkg ->
1430
+
ensure_verse_remotes_for_repo ~proc ~fs ~config ~verse_subtrees pkg)
1569
1431
repos
1570
1432
1571
-
(* Fetch from verse remotes for a repo - uses native git for list_remotes *)
1433
+
(* Fetch from verse remotes for a repo *)
1572
1434
let fetch_verse_remotes ~proc ~fs ~config pkg =
1573
1435
let checkouts_root = Config.Paths.checkouts config in
1574
1436
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
1575
-
let checkout_path = Fpath.to_string checkout_dir in
1576
-
let remotes =
1577
-
if Git.Repository.is_repo ~fs checkout_path then
1578
-
let repo = Git.Repository.open_repo ~fs checkout_path in
1579
-
Git.Repository.list_remotes repo
1580
-
else []
1581
-
in
1437
+
let remotes = Git.list_remotes ~proc ~fs checkout_dir in
1582
1438
let verse_remotes =
1583
1439
List.filter (fun r -> String.starts_with ~prefix:"verse-" r) remotes
1584
1440
in
1585
1441
List.iter
1586
1442
(fun remote ->
1587
1443
Log.debug (fun m -> m "Fetching from verse remote %s" remote);
1588
-
match Git_cli.fetch ~proc ~fs ~remote checkout_dir with
1444
+
match Git.fetch ~proc ~fs ~remote checkout_dir with
1589
1445
| Ok () -> ()
1590
1446
| Error e ->
1591
1447
Log.debug (fun m ->
1592
-
m "Failed to fetch from %s: %a" remote Git_cli.pp_error e))
1448
+
m "Failed to fetch from %s: %a" remote Git.pp_error e))
1593
1449
verse_remotes
1594
1450
1595
1451
(* Helper to read file contents, returning None if file doesn't exist *)
···
1613
1469
List.iter
1614
1470
(fun pkg ->
1615
1471
let pkg_dir =
1616
-
Fpath.(
1617
-
opam_repo / "packages" / pkg.pkg_name / (pkg.pkg_name ^ ".dev"))
1472
+
Fpath.(opam_repo / "packages" / pkg.pkg_name / (pkg.pkg_name ^ ".dev"))
1618
1473
in
1619
1474
let dst_path = Eio.Path.(fs / Fpath.to_string pkg_dir / "opam") in
1620
1475
let dst_content = read_file_opt dst_path in
···
1626
1481
end)
1627
1482
pkgs;
1628
1483
if !updated > 0 then
1629
-
Log.info (fun m ->
1630
-
m "Regenerated %d opam-repo entries from monorepo" !updated)
1484
+
Log.info (fun m -> m "Regenerated %d opam-repo entries from monorepo" !updated)
1631
1485
1632
-
(** Clone monorepo and opam-repo from verse registry if they don't exist
1633
-
locally. This enables `monopam sync` to work in a fresh devcontainer. *)
1486
+
(** Clone monorepo and opam-repo from verse registry if they don't exist locally.
1487
+
This enables `monopam sync` to work in a fresh devcontainer. *)
1634
1488
let clone_from_verse_if_needed ~proc ~fs ~config () =
1635
1489
let monorepo = Config.Paths.monorepo config in
1636
1490
let opam_repo = Config.Paths.opam_repo config in
1637
-
let monorepo_exists = Git_cli.is_repo ~proc ~fs monorepo in
1638
-
let opam_repo_exists = Git_cli.is_repo ~proc ~fs opam_repo in
1491
+
let monorepo_exists = Git.is_repo ~proc ~fs monorepo in
1492
+
let opam_repo_exists = Git.is_repo ~proc ~fs opam_repo in
1639
1493
1640
1494
(* If both exist, nothing to do *)
1641
1495
if monorepo_exists && opam_repo_exists then Ok ()
···
1644
1498
match Verse_config.load ~fs () with
1645
1499
| Error _ ->
1646
1500
(* No verse config - can't clone from registry *)
1647
-
Log.debug (fun m ->
1648
-
m "No verse config found, will initialize fresh repos");
1501
+
Log.debug (fun m -> m "No verse config found, will initialize fresh repos");
1649
1502
Ok ()
1650
-
| Ok verse_config -> (
1503
+
| Ok verse_config ->
1651
1504
let handle = Verse_config.handle verse_config in
1652
1505
Log.info (fun m -> m "Found verse config for handle: %s" handle);
1653
1506
(* Load registry to look up URLs *)
1654
-
match
1655
-
Verse_registry.clone_or_pull ~proc ~fs ~config:verse_config ()
1656
-
with
1507
+
match Verse_registry.clone_or_pull ~proc ~fs ~config:verse_config () with
1657
1508
| Error msg ->
1658
1509
Log.warn (fun m -> m "Could not load verse registry: %s" msg);
1659
-
Ok () (* Continue without cloning - will init fresh *)
1660
-
| Ok registry -> (
1510
+
Ok () (* Continue without cloning - will init fresh *)
1511
+
| Ok registry ->
1661
1512
match Verse_registry.find_member registry ~handle with
1662
1513
| None ->
1663
1514
Log.warn (fun m -> m "Handle %s not found in registry" handle);
1664
1515
Ok ()
1665
-
| Some member -> (
1516
+
| Some member ->
1666
1517
(* Clone monorepo if needed *)
1667
1518
let result =
1668
1519
if monorepo_exists then Ok ()
1669
1520
else begin
1670
-
Log.app (fun m ->
1671
-
m "Cloning monorepo from %s..." member.monorepo);
1521
+
Log.app (fun m -> m "Cloning monorepo from %s..." member.monorepo);
1672
1522
let url = Uri.of_string member.monorepo in
1673
-
let branch =
1674
-
Option.value ~default:"main" member.monorepo_branch
1675
-
in
1676
-
match Git_cli.clone ~proc ~fs ~url ~branch monorepo with
1523
+
let branch = Option.value ~default:"main" member.monorepo_branch in
1524
+
match Git.clone ~proc ~fs ~url ~branch monorepo with
1677
1525
| Ok () ->
1678
1526
Log.app (fun m -> m "Monorepo cloned successfully");
1679
1527
Ok ()
1680
1528
| Error e ->
1681
-
Log.err (fun m ->
1682
-
m "Failed to clone monorepo: %a" Git_cli.pp_error e);
1529
+
Log.err (fun m -> m "Failed to clone monorepo: %a" Git.pp_error e);
1683
1530
Error (Git_error e)
1684
1531
end
1685
1532
in
···
1689
1536
(* Clone opam-repo if needed *)
1690
1537
if opam_repo_exists then Ok ()
1691
1538
else begin
1692
-
Log.app (fun m ->
1693
-
m "Cloning opam-repo from %s..." member.opamrepo);
1539
+
Log.app (fun m -> m "Cloning opam-repo from %s..." member.opamrepo);
1694
1540
let url = Uri.of_string member.opamrepo in
1695
-
let branch =
1696
-
Option.value ~default:"main" member.opamrepo_branch
1697
-
in
1698
-
match Git_cli.clone ~proc ~fs ~url ~branch opam_repo with
1541
+
let branch = Option.value ~default:"main" member.opamrepo_branch in
1542
+
match Git.clone ~proc ~fs ~url ~branch opam_repo with
1699
1543
| Ok () ->
1700
1544
Log.app (fun m -> m "Opam-repo cloned successfully");
1701
1545
Ok ()
1702
1546
| Error e ->
1703
-
Log.err (fun m ->
1704
-
m "Failed to clone opam-repo: %a" Git_cli.pp_error
1705
-
e);
1547
+
Log.err (fun m -> m "Failed to clone opam-repo: %a" Git.pp_error e);
1706
1548
Error (Git_error e)
1707
-
end)))
1549
+
end
1708
1550
1709
-
let sync ~sw ~env ~proc ~fs ~config ~xdg ?package ?(remote = false)
1710
-
?(skip_push = false) ?(skip_pull = false) ?(skip_verse = false) () =
1551
+
let sync ~proc ~fs ~config ?package ?(remote = false) ?(skip_push = false)
1552
+
?(skip_pull = false) () =
1711
1553
let fs_t = fs_typed fs in
1712
-
(* Create remote HEAD cache with O(1) lookup - loaded once, persisted on updates *)
1713
-
let cache =
1714
-
Cached_remote_heads.create ~xdg ~now:(fun () -> Eio.Time.now env#clock)
1715
-
in
1716
-
(* Domain-safe lazy HTTP session to avoid TLS cert loading if cache hits *)
1717
-
let session_atom : Requests.t option Atomic.t = Atomic.make None in
1718
-
let get_session () =
1719
-
match Atomic.get session_atom with
1720
-
| Some s -> s
1721
-
| None ->
1722
-
let s = Requests.create ~sw env in
1723
-
(* CAS to avoid races - if another domain created one, use theirs *)
1724
-
if Atomic.compare_and_set session_atom None (Some s) then s
1725
-
else Option.get (Atomic.get session_atom)
1726
-
in
1727
1554
1728
-
(* Step 0: Sync verse members if verse config exists and not skipping
1729
-
Skip verse sync when syncing a specific package for faster operations *)
1730
-
let should_skip_verse = skip_pull || skip_verse || Option.is_some package in
1731
-
(if not should_skip_verse then
1732
-
match Verse_config.load ~fs:fs_t () with
1733
-
| Error _ -> () (* No verse config = skip *)
1734
-
| Ok verse_config ->
1735
-
Log.app (fun m -> m "Syncing verse members...");
1736
-
time_phase "verse-sync" (fun () ->
1737
-
match Verse.pull ~proc ~fs:fs_t ~config:verse_config () with
1738
-
| Ok () -> ()
1739
-
| Error e ->
1740
-
Log.warn (fun m -> m "Verse sync: %a" Verse.pp_error e)));
1555
+
(* Step 0: Sync verse members if verse config exists and not skipping pull *)
1556
+
(if not skip_pull then
1557
+
match Verse_config.load ~fs:fs_t () with
1558
+
| Error _ -> () (* No verse config = skip *)
1559
+
| Ok verse_config ->
1560
+
Log.app (fun m -> m "Syncing verse members...");
1561
+
match Verse.pull ~proc ~fs:fs_t ~config:verse_config () with
1562
+
| Ok () -> ()
1563
+
| Error e -> Log.warn (fun m -> m "Verse sync: %a" Verse.pp_error e));
1741
1564
1742
1565
(* Clone from verse registry if repos don't exist *)
1743
1566
match clone_from_verse_if_needed ~proc ~fs:fs_t ~config () with
1744
1567
| Error e -> Error e
1568
+
| Ok () ->
1569
+
1570
+
(* Update the opam repo first - clone if needed *)
1571
+
let opam_repo = Config.Paths.opam_repo config in
1572
+
if (not skip_pull) && Git.is_repo ~proc ~fs:fs_t opam_repo then begin
1573
+
Log.info (fun m -> m "Updating opam repo at %a" Fpath.pp opam_repo);
1574
+
let result =
1575
+
let ( let* ) = Result.bind in
1576
+
let* () = Git.fetch ~proc ~fs:fs_t opam_repo in
1577
+
Git.merge_ff ~proc ~fs:fs_t opam_repo
1578
+
in
1579
+
match result with
1580
+
| Ok () -> ()
1581
+
| Error e ->
1582
+
Log.warn (fun m -> m "Failed to update opam repo: %a" Git.pp_error e)
1583
+
end;
1584
+
(* Ensure directories exist *)
1585
+
ensure_checkouts_dir ~fs:fs_t ~config;
1586
+
match ensure_monorepo_initialized ~proc ~fs:fs_t ~config with
1587
+
| Error e -> Error e
1745
1588
| Ok () -> (
1746
-
(* Update the opam repo first - clone if needed
1747
-
Skip when syncing a single package for faster operations *)
1748
-
let opam_repo = Config.Paths.opam_repo config in
1749
-
let skip_opam_repo = Option.is_some package in
1750
-
if
1751
-
(not skip_pull) && (not skip_opam_repo)
1752
-
&& Git_cli.is_repo ~proc ~fs:fs_t opam_repo
1753
-
then begin
1754
-
Log.info (fun m -> m "Updating opam repo at %a" Fpath.pp opam_repo);
1755
-
time_phase "opam-repo-fetch" (fun () ->
1756
-
let result =
1757
-
let ( let* ) = Result.bind in
1758
-
let* () = Git_cli.fetch ~proc ~fs:fs_t opam_repo in
1759
-
Git_cli.merge_ff ~proc ~fs:fs_t opam_repo
1760
-
in
1761
-
match result with
1762
-
| Ok () -> ()
1763
-
| Error e ->
1764
-
Log.warn (fun m ->
1765
-
m "Failed to update opam repo: %a" Git_cli.pp_error e))
1766
-
end;
1767
-
(* Ensure directories exist *)
1768
-
ensure_checkouts_dir ~fs:fs_t ~config;
1769
-
match ensure_monorepo_initialized ~proc ~fs:fs_t ~config with
1589
+
(* Check for uncommitted changes in monorepo *)
1590
+
let monorepo = Config.Paths.monorepo config in
1591
+
if Git.is_dirty ~proc ~fs:fs_t monorepo then begin
1592
+
Log.err (fun m -> m "Monorepo has uncommitted changes");
1593
+
Error Monorepo_dirty
1594
+
end
1595
+
else begin
1596
+
(* Regenerate opam-repo from monorepo to ensure URLs are up to date *)
1597
+
regenerate_opam_repo ~fs:(fs_t :> _ Eio.Path.t) ~config ();
1598
+
match discover_packages ~fs:(fs_t :> _ Eio.Path.t) ~config () with
1770
1599
| Error e -> Error e
1771
-
| Ok () -> (
1772
-
(* Regenerate opam-repo from monorepo to ensure URLs are up to date *)
1773
-
(* Skip when syncing a single package for faster operations *)
1774
-
if Option.is_none package then
1775
-
time_phase "regenerate-opam-repo" (fun () ->
1776
-
regenerate_opam_repo ~fs:(fs_t :> _ Eio.Path.t) ~config ());
1777
-
match
1778
-
time_phase "discover-packages" (fun () ->
1779
-
discover_packages ~fs:(fs_t :> _ Eio.Path.t) ~config ())
1780
-
with
1781
-
| Error e -> Error e
1782
-
| Ok all_pkgs ->
1783
-
let pkgs =
1784
-
match package with
1785
-
| None -> all_pkgs
1786
-
| Some name ->
1787
-
List.filter (fun p -> Package.name p = name) all_pkgs
1600
+
| Ok all_pkgs ->
1601
+
let pkgs =
1602
+
match package with
1603
+
| None -> all_pkgs
1604
+
| Some name -> List.filter (fun p -> Package.name p = name) all_pkgs
1605
+
in
1606
+
if pkgs = [] && package <> None then
1607
+
Error (Package_not_found (Option.get package))
1608
+
else begin
1609
+
(* Step 1: Validate - check for dirty state *)
1610
+
Log.info (fun m ->
1611
+
m "Checking status of %d packages" (List.length pkgs));
1612
+
let statuses = Status.compute_all ~proc ~fs:fs_t ~config pkgs in
1613
+
let dirty =
1614
+
List.filter Status.has_local_changes statuses
1615
+
|> List.map (fun s -> s.Status.package)
1616
+
in
1617
+
if dirty <> [] then Error (Dirty_state dirty)
1618
+
else begin
1619
+
let repos = unique_repos pkgs in
1620
+
let total = List.length repos in
1621
+
Log.app (fun m -> m "Syncing %d repositories..." total);
1622
+
1623
+
(* Build status lookup for optimization *)
1624
+
let status_by_name =
1625
+
List.map (fun s -> (Package.name s.Status.package, s)) statuses
1626
+
in
1627
+
let sync_needs_push = function
1628
+
| Status.Subtree_ahead _ | Status.Trees_differ -> true
1629
+
| Status.In_sync | Status.Subtree_behind _ | Status.Unknown ->
1630
+
false
1788
1631
in
1789
-
if pkgs = [] && package <> None then
1790
-
Error (Package_not_found (Option.get package))
1791
-
else begin
1792
-
(* Step 1: Validate - check for dirty state in packages being synced *)
1793
-
Log.info (fun m ->
1794
-
m "Checking status of %d packages" (List.length pkgs));
1795
-
let statuses =
1796
-
time_phase "compute-status" (fun () ->
1797
-
Status.compute_all ~fs:fs_t ~config pkgs)
1798
-
in
1799
-
let dirty =
1800
-
List.filter Status.has_local_changes statuses
1801
-
|> List.map (fun s -> s.Status.package)
1802
-
in
1803
-
if dirty <> [] then Error (Dirty_state dirty)
1804
-
else begin
1805
-
let repos = unique_repos pkgs in
1806
-
let total = List.length repos in
1807
-
Log.app (fun m -> m "Syncing %d repositories..." total);
1632
+
let needs_push pkg =
1633
+
List.assoc_opt (Package.name pkg) status_by_name
1634
+
|> Option.fold ~none:true ~some:(fun s ->
1635
+
sync_needs_push s.Status.subtree_sync)
1636
+
in
1637
+
let sync_needs_pull = function
1638
+
| Status.Subtree_behind _ | Status.Trees_differ -> true
1639
+
| Status.In_sync | Status.Subtree_ahead _ | Status.Unknown ->
1640
+
false
1641
+
in
1642
+
let needs_pull pkg =
1643
+
List.assoc_opt (Package.name pkg) status_by_name
1644
+
|> Option.fold ~none:true ~some:(fun s ->
1645
+
sync_needs_pull s.Status.subtree_sync)
1646
+
in
1808
1647
1809
-
(* Build status lookup for optimization *)
1810
-
let status_by_name =
1811
-
List.map
1812
-
(fun s -> (Package.name s.Status.package, s))
1813
-
statuses
1648
+
(* Step 2: Push phase - export monorepo changes to checkouts (PARALLEL) *)
1649
+
(* git subtree push is read-only on the monorepo, so safe to parallelize *)
1650
+
(* OPTIMIZATION: skip packages already in sync *)
1651
+
let push_results =
1652
+
if skip_push then begin
1653
+
Log.app (fun m ->
1654
+
m " Skipping push to checkouts (--skip-push)");
1655
+
List.map (fun pkg -> Ok (Package.repo_name pkg)) repos
1656
+
end
1657
+
else begin
1658
+
let to_push, to_skip = List.partition needs_push repos in
1659
+
Log.app (fun m ->
1660
+
m " Pushing monorepo changes to checkouts (parallel)...");
1661
+
if to_skip <> [] then
1662
+
Log.app (fun m ->
1663
+
m " Skipping %d already-synced packages"
1664
+
(List.length to_skip));
1665
+
(* Local git subtree push - no parallelism limit needed *)
1666
+
let pushed =
1667
+
Eio.Fiber.List.map
1668
+
(fun pkg ->
1669
+
let repo_name = Package.repo_name pkg in
1670
+
Log.info (fun m -> m "Push to checkout: %s" repo_name);
1671
+
match push_one ~proc ~fs ~config pkg with
1672
+
| Ok () -> Ok repo_name
1673
+
| Error (Git_error e) ->
1674
+
Error
1675
+
{ repo_name; phase = `Push_checkout; error = e }
1676
+
| Error _ -> Ok repo_name)
1677
+
to_push
1814
1678
in
1815
-
let sync_needs_push = function
1816
-
| Status.Subtree_ahead _ | Status.Trees_differ -> true
1817
-
| Status.In_sync | Status.Subtree_behind _ | Status.Unknown
1818
-
->
1819
-
false
1679
+
let skipped_ok =
1680
+
List.map (fun pkg -> Ok (Package.repo_name pkg)) to_skip
1820
1681
in
1821
-
let needs_push pkg =
1822
-
List.assoc_opt (Package.name pkg) status_by_name
1823
-
|> Option.fold ~none:true ~some:(fun s ->
1824
-
sync_needs_push s.Status.subtree_sync)
1682
+
pushed @ skipped_ok
1683
+
end
1684
+
in
1685
+
let push_errors =
1686
+
List.filter_map
1687
+
(function Error e -> Some e | Ok _ -> None)
1688
+
push_results
1689
+
in
1690
+
1691
+
(* Steps 3-5: Pull phases (fetch, merge, subtree) - skip if --skip-pull *)
1692
+
let ( fetch_errors,
1693
+
unchanged_count,
1694
+
total_commits_pulled,
1695
+
merge_errors,
1696
+
subtree_errors,
1697
+
successfully_fetched_repos ) =
1698
+
if skip_pull then begin
1699
+
Log.app (fun m ->
1700
+
m " Skipping pull from remotes (--skip-pull)");
1701
+
([], List.length repos, 0, ref [], ref [], repos)
1702
+
end
1703
+
else begin
1704
+
(* Step 3: Fetch phase - clone/fetch from remotes (PARALLEL) *)
1705
+
Log.app (fun m -> m " Fetching from remotes (parallel)...");
1706
+
let fetch_results =
1707
+
Eio.Fiber.List.map ~max_fibers:4
1708
+
(fun pkg ->
1709
+
let repo_name = Package.repo_name pkg in
1710
+
(* First ensure checkout exists *)
1711
+
match
1712
+
ensure_checkout_safe ~proc ~fs:fs_t ~config pkg
1713
+
with
1714
+
| Error e ->
1715
+
Error { repo_name; phase = `Fetch; error = e }
1716
+
| Ok (was_cloned, _) -> (
1717
+
if was_cloned then Ok (repo_name, true, 0)
1718
+
else
1719
+
match
1720
+
fetch_checkout_safe ~proc ~fs:fs_t ~config pkg
1721
+
with
1722
+
| Error e ->
1723
+
Error { repo_name; phase = `Fetch; error = e }
1724
+
| Ok commits -> Ok (repo_name, false, commits)))
1725
+
repos
1825
1726
in
1826
-
let sync_needs_pull = function
1827
-
| Status.Subtree_behind _ | Status.Trees_differ -> true
1828
-
| Status.In_sync | Status.Subtree_ahead _ | Status.Unknown
1829
-
->
1830
-
false
1727
+
let fetch_errs, fetch_successes =
1728
+
List.partition_map
1729
+
(function Error e -> Left e | Ok r -> Right r)
1730
+
fetch_results
1831
1731
in
1832
-
let needs_pull pkg =
1833
-
List.assoc_opt (Package.name pkg) status_by_name
1834
-
|> Option.fold ~none:true ~some:(fun s ->
1835
-
sync_needs_pull s.Status.subtree_sync)
1732
+
let cloned =
1733
+
List.filter (fun (_, c, _) -> c) fetch_successes
1836
1734
in
1837
-
1838
-
(* Step 2: Push phase - export monorepo changes to checkouts (PARALLEL) *)
1839
-
(* git subtree push is read-only on the monorepo, so safe to parallelize *)
1840
-
(* OPTIMIZATION: skip packages already in sync *)
1841
-
let push_results =
1842
-
if skip_push then begin
1843
-
Log.app (fun m ->
1844
-
m " Skipping push to checkouts (--skip-push)");
1845
-
List.map (fun pkg -> Ok (Package.repo_name pkg)) repos
1846
-
end
1847
-
else begin
1848
-
let to_push, to_skip = List.partition needs_push repos in
1849
-
Log.app (fun m ->
1850
-
m
1851
-
" Pushing monorepo changes to checkouts \
1852
-
(parallel)...");
1853
-
if to_skip <> [] then
1854
-
Log.app (fun m ->
1855
-
m " Skipping %d already-synced packages"
1856
-
(List.length to_skip));
1857
-
(* Local git subtree push - no parallelism limit needed *)
1858
-
let pushed =
1859
-
Eio.Fiber.List.map
1860
-
(fun pkg ->
1861
-
let repo_name = Package.repo_name pkg in
1862
-
Log.info (fun m ->
1863
-
m "Push to checkout: %s" repo_name);
1864
-
match push_one ~proc ~fs ~config pkg with
1865
-
| Ok () -> Ok repo_name
1866
-
| Error (Git_error e) ->
1867
-
Error
1868
-
{
1869
-
repo_name;
1870
-
phase = `Push_checkout;
1871
-
error = e;
1872
-
}
1873
-
| Error _ -> Ok repo_name)
1874
-
to_push
1875
-
in
1876
-
let skipped_ok =
1877
-
List.map (fun pkg -> Ok (Package.repo_name pkg)) to_skip
1878
-
in
1879
-
pushed @ skipped_ok
1880
-
end
1735
+
let updated =
1736
+
List.filter
1737
+
(fun (_, c, commits) -> (not c) && commits > 0)
1738
+
fetch_successes
1881
1739
in
1882
-
let push_errors =
1883
-
List.filter_map
1884
-
(function Error e -> Some e | Ok _ -> None)
1885
-
push_results
1740
+
let unchanged =
1741
+
List.length fetch_successes
1742
+
- List.length cloned - List.length updated
1886
1743
in
1887
-
1888
-
(* Steps 3-5: Pull phases (fetch, merge, subtree) - skip if --skip-pull *)
1889
-
let ( fetch_errors,
1890
-
unchanged_count,
1891
-
total_commits_pulled,
1892
-
merge_errors,
1893
-
subtree_errors,
1894
-
successfully_fetched_repos ) =
1895
-
if skip_pull then begin
1896
-
Log.app (fun m ->
1897
-
m " Skipping pull from remotes (--skip-pull)");
1898
-
([], List.length repos, 0, ref [], ref [], repos)
1899
-
end
1900
-
else begin
1901
-
(* Step 3: Fetch phase - clone/fetch from remotes (PARALLEL) *)
1902
-
Log.app (fun m ->
1903
-
m " Fetching from remotes (parallel)...");
1904
-
let fetch_results =
1905
-
time_phase "fetch-phase" (fun () ->
1906
-
Eio.Fiber.List.map ~max_fibers:8
1907
-
(fun pkg ->
1908
-
let repo_name = Package.repo_name pkg in
1909
-
(* First ensure checkout exists *)
1910
-
match
1911
-
time_phase
1912
-
(Printf.sprintf "ensure-checkout:%s"
1913
-
repo_name) (fun () ->
1914
-
ensure_checkout_safe ~proc ~fs:fs_t
1915
-
~config pkg)
1916
-
with
1917
-
| Error e ->
1918
-
Error
1919
-
{ repo_name; phase = `Fetch; error = e }
1920
-
| Ok (was_cloned, _) -> (
1921
-
if was_cloned then Ok (repo_name, true, 0)
1922
-
else
1923
-
match
1924
-
time_phase
1925
-
(Printf.sprintf "fetch:%s" repo_name)
1926
-
(fun () ->
1927
-
fetch_checkout_safe ~sw ~env ~proc
1928
-
~fs:fs_t ~config ~cache
1929
-
~get_session pkg)
1930
-
with
1931
-
| Error e ->
1932
-
Error
1933
-
{
1934
-
repo_name;
1935
-
phase = `Fetch;
1936
-
error = e;
1937
-
}
1938
-
| Ok commits ->
1939
-
Ok (repo_name, false, commits)))
1940
-
repos)
1941
-
in
1942
-
let fetch_errs, fetch_successes =
1943
-
List.partition_map
1944
-
(function Error e -> Left e | Ok r -> Right r)
1945
-
fetch_results
1946
-
in
1947
-
let cloned =
1948
-
List.filter (fun (_, c, _) -> c) fetch_successes
1949
-
in
1950
-
let updated =
1951
-
List.filter
1952
-
(fun (_, c, commits) -> (not c) && commits > 0)
1953
-
fetch_successes
1954
-
in
1955
-
let unchanged =
1956
-
List.length fetch_successes
1957
-
- List.length cloned - List.length updated
1958
-
in
1959
-
let commits_pulled =
1960
-
List.fold_left
1961
-
(fun acc (_, _, c) -> acc + c)
1962
-
0 fetch_successes
1963
-
in
1964
-
Log.app (fun m ->
1965
-
m " Pulled: %d cloned, %d updated, %d unchanged"
1966
-
(List.length cloned) (List.length updated) unchanged);
1967
-
1968
-
(* Filter repos to only those that were successfully fetched *)
1969
-
let success_names =
1970
-
List.map (fun (name, _, _) -> name) fetch_successes
1971
-
in
1972
-
let successfully_fetched =
1973
-
List.filter
1974
-
(fun pkg ->
1975
-
List.mem (Package.repo_name pkg) success_names)
1976
-
repos
1977
-
in
1978
-
1979
-
(* Step 4: Merge phase - fast-forward merge checkouts (SEQUENTIAL) *)
1980
-
Log.app (fun m -> m " Merging checkouts...");
1981
-
let merge_errs = ref [] in
1982
-
time_phase "merge-phase" (fun () ->
1983
-
List.iter
1984
-
(fun pkg ->
1985
-
match
1986
-
time_phase
1987
-
(Printf.sprintf "merge:%s"
1988
-
(Package.repo_name pkg))
1989
-
(fun () ->
1990
-
merge_checkout_safe ~proc ~fs:fs_t ~config
1991
-
pkg)
1992
-
with
1993
-
| Ok () -> ()
1994
-
| Error e ->
1995
-
merge_errs :=
1996
-
{
1997
-
repo_name = Package.repo_name pkg;
1998
-
phase = `Merge;
1999
-
error = e;
2000
-
}
2001
-
:: !merge_errs)
2002
-
successfully_fetched);
1744
+
let commits_pulled =
1745
+
List.fold_left
1746
+
(fun acc (_, _, c) -> acc + c)
1747
+
0 fetch_successes
1748
+
in
1749
+
Log.app (fun m ->
1750
+
m " Pulled: %d cloned, %d updated, %d unchanged"
1751
+
(List.length cloned) (List.length updated) unchanged);
2003
1752
2004
-
(* Step 5: Subtree phase - pull subtrees into monorepo (SEQUENTIAL) *)
2005
-
(* Check if monorepo has local modifications first *)
2006
-
let monorepo = Config.Paths.monorepo config in
2007
-
let monorepo_dirty =
2008
-
Git_cli.is_dirty ~proc ~fs:fs_t monorepo
2009
-
in
2010
-
let subtree_errs = ref [] in
2011
-
if monorepo_dirty then begin
2012
-
Log.warn (fun m ->
2013
-
m
2014
-
"Monorepo has uncommitted changes, skipping \
2015
-
subtree pulls");
2016
-
Log.app (fun m ->
2017
-
m
2018
-
" Skipping subtree updates (local \
2019
-
modifications)...")
2020
-
end
2021
-
else begin
2022
-
(* OPTIMIZATION: skip packages already in sync *)
2023
-
(* But always pull repos that received commits from fetch *)
2024
-
let repos_updated_by_fetch =
2025
-
List.filter_map
2026
-
(fun (name, was_cloned, commits) ->
2027
-
if was_cloned || commits > 0 then Some name
2028
-
else None)
2029
-
fetch_successes
2030
-
in
2031
-
let needs_pull_after_fetch pkg =
2032
-
needs_pull pkg
2033
-
|| List.mem (Package.repo_name pkg)
2034
-
repos_updated_by_fetch
2035
-
in
2036
-
let to_pull, to_skip =
2037
-
List.partition needs_pull_after_fetch
2038
-
successfully_fetched
2039
-
in
2040
-
Log.app (fun m -> m " Updating subtrees...");
2041
-
if to_skip <> [] then
2042
-
Log.app (fun m ->
2043
-
m " Skipping %d already-synced subtrees"
2044
-
(List.length to_skip));
2045
-
let pull_count = List.length to_pull in
2046
-
List.iteri
2047
-
(fun i pkg ->
2048
-
Log.info (fun m ->
2049
-
m "[%d/%d] Subtree %s" (i + 1) pull_count
2050
-
(Package.subtree_prefix pkg));
2051
-
match pull_subtree ~proc ~fs ~config pkg with
2052
-
| Ok _ -> ()
2053
-
| Error (Git_error e) ->
2054
-
subtree_errs :=
2055
-
{
2056
-
repo_name = Package.repo_name pkg;
2057
-
phase = `Subtree;
2058
-
error = e;
2059
-
}
2060
-
:: !subtree_errs
2061
-
| Error _ -> ())
2062
-
to_pull
2063
-
end;
2064
-
( fetch_errs,
2065
-
unchanged,
2066
-
commits_pulled,
2067
-
merge_errs,
2068
-
subtree_errs,
2069
-
successfully_fetched )
2070
-
end
1753
+
(* Filter repos to only those that were successfully fetched *)
1754
+
let success_names =
1755
+
List.map (fun (name, _, _) -> name) fetch_successes
1756
+
in
1757
+
let successfully_fetched =
1758
+
List.filter
1759
+
(fun pkg -> List.mem (Package.repo_name pkg) success_names)
1760
+
repos
2071
1761
in
2072
1762
2073
-
(* Step 5.5: Verse remotes - update and fetch from verse members *)
2074
-
(* Skip when syncing a single package for faster operations *)
2075
-
(* Only operate on successfully fetched repos to avoid missing directory errors *)
2076
-
(if Option.is_some package then
2077
-
Log.debug (fun m ->
2078
-
m "Skipping verse remotes (single package sync)")
2079
-
else
2080
-
match Verse_config.load ~fs:(fs_t :> _ Eio.Path.t) () with
2081
-
| Error _ -> () (* No verse config, skip verse remotes *)
2082
-
| Ok verse_config ->
2083
-
time_phase "sync-verse-remotes" (fun () ->
2084
-
sync_verse_remotes ~proc ~fs:fs_t ~config
2085
-
~verse_config successfully_fetched_repos);
2086
-
(* Fetch from verse remotes in parallel *)
2087
-
Log.app (fun m -> m " Fetching from verse remotes...");
2088
-
time_phase "fetch-verse-remotes" (fun () ->
2089
-
Eio.Fiber.List.iter ~max_fibers:8
2090
-
(fun pkg ->
2091
-
fetch_verse_remotes ~proc ~fs:fs_t ~config pkg)
2092
-
successfully_fetched_repos));
1763
+
(* Step 4: Merge phase - fast-forward merge checkouts (SEQUENTIAL) *)
1764
+
Log.app (fun m -> m " Merging checkouts...");
1765
+
let merge_errs = ref [] in
1766
+
List.iter
1767
+
(fun pkg ->
1768
+
match merge_checkout_safe ~proc ~fs:fs_t ~config pkg with
1769
+
| Ok () -> ()
1770
+
| Error e ->
1771
+
merge_errs :=
1772
+
{
1773
+
repo_name = Package.repo_name pkg;
1774
+
phase = `Merge;
1775
+
error = e;
1776
+
}
1777
+
:: !merge_errs)
1778
+
successfully_fetched;
2093
1779
2094
-
(* Step 6: Finalize - write README.md, CLAUDE.md, and dune-project (SEQUENTIAL) *)
2095
-
(* Skip when syncing a single package for faster operations *)
2096
-
if Option.is_some package then
2097
-
Log.debug (fun m ->
2098
-
m "Skipping finalize (single package sync)")
2099
-
else begin
1780
+
(* Step 5: Subtree phase - pull subtrees into monorepo (SEQUENTIAL) *)
1781
+
(* Check if monorepo has local modifications first *)
1782
+
let monorepo = Config.Paths.monorepo config in
1783
+
let monorepo_dirty = Git.is_dirty ~proc ~fs:fs_t monorepo in
1784
+
let subtree_errs = ref [] in
1785
+
if monorepo_dirty then begin
1786
+
Log.warn (fun m ->
1787
+
m
1788
+
"Monorepo has uncommitted changes, skipping subtree \
1789
+
pulls");
2100
1790
Log.app (fun m ->
2101
-
m " Writing README.md, CLAUDE.md, and dune-project...");
2102
-
time_phase "write-readme" (fun () ->
2103
-
write_readme ~proc ~fs:fs_t ~config all_pkgs);
2104
-
time_phase "write-claude-md" (fun () ->
2105
-
write_claude_md ~proc ~fs:fs_t ~config);
2106
-
time_phase "write-dune-project" (fun () ->
2107
-
write_dune_project ~proc ~fs:fs_t ~config all_pkgs)
1791
+
m " Skipping subtree updates (local modifications)...")
1792
+
end
1793
+
else begin
1794
+
(* OPTIMIZATION: skip packages already in sync *)
1795
+
(* But always pull repos that received commits from fetch *)
1796
+
let repos_updated_by_fetch =
1797
+
List.filter_map
1798
+
(fun (name, was_cloned, commits) ->
1799
+
if was_cloned || commits > 0 then Some name else None)
1800
+
fetch_successes
1801
+
in
1802
+
let needs_pull_after_fetch pkg =
1803
+
needs_pull pkg
1804
+
|| List.mem (Package.repo_name pkg) repos_updated_by_fetch
1805
+
in
1806
+
let to_pull, to_skip =
1807
+
List.partition needs_pull_after_fetch successfully_fetched
1808
+
in
1809
+
Log.app (fun m -> m " Updating subtrees...");
1810
+
if to_skip <> [] then
1811
+
Log.app (fun m ->
1812
+
m " Skipping %d already-synced subtrees"
1813
+
(List.length to_skip));
1814
+
let pull_count = List.length to_pull in
1815
+
List.iteri
1816
+
(fun i pkg ->
1817
+
Log.info (fun m ->
1818
+
m "[%d/%d] Subtree %s" (i + 1) pull_count
1819
+
(Package.subtree_prefix pkg));
1820
+
match pull_subtree ~proc ~fs ~config pkg with
1821
+
| Ok _ -> ()
1822
+
| Error (Git_error e) ->
1823
+
subtree_errs :=
1824
+
{
1825
+
repo_name = Package.repo_name pkg;
1826
+
phase = `Subtree;
1827
+
error = e;
1828
+
}
1829
+
:: !subtree_errs
1830
+
| Error _ -> ())
1831
+
to_pull
2108
1832
end;
1833
+
( fetch_errs,
1834
+
unchanged,
1835
+
commits_pulled,
1836
+
merge_errs,
1837
+
subtree_errs,
1838
+
successfully_fetched )
1839
+
end
1840
+
in
2109
1841
2110
-
(* Step 7: Remote phase - push to upstream remotes if --remote (LIMITED PARALLEL) *)
2111
-
(* Only push repos that were successfully fetched *)
2112
-
let remote_errors =
2113
-
if remote then begin
2114
-
Log.app (fun m -> m " Pushing to upstream remotes...");
2115
-
(* Limit to 2 concurrent pushes to avoid overwhelming remotes *)
2116
-
let push_results =
2117
-
Eio.Fiber.List.map ~max_fibers:2
2118
-
(fun pkg ->
2119
-
let repo_name = Package.repo_name pkg in
2120
-
match
2121
-
push_remote_safe ~proc ~fs:fs_t ~config pkg
2122
-
with
2123
-
| Error e ->
2124
-
Error
2125
-
{ repo_name; phase = `Push_remote; error = e }
2126
-
| Ok () ->
2127
-
Log.app (fun m -> m " Pushed %s" repo_name);
2128
-
Ok repo_name)
2129
-
successfully_fetched_repos
2130
-
in
2131
-
let errors, successes =
2132
-
List.partition_map
2133
-
(function Error e -> Left e | Ok r -> Right r)
2134
-
push_results
2135
-
in
2136
-
Log.app (fun m ->
2137
-
m " Pushed: %d repos to upstream"
2138
-
(List.length successes));
2139
-
errors
2140
-
end
2141
-
else []
2142
-
in
1842
+
(* Step 5.5: Verse remotes - update and fetch from verse members *)
1843
+
(* Only operate on successfully fetched repos to avoid missing directory errors *)
1844
+
(match Verse_config.load ~fs:(fs_t :> _ Eio.Path.t) () with
1845
+
| Error _ -> () (* No verse config, skip verse remotes *)
1846
+
| Ok verse_config ->
1847
+
sync_verse_remotes ~proc ~fs:fs_t ~config ~verse_config successfully_fetched_repos;
1848
+
(* Fetch from verse remotes in parallel *)
1849
+
Log.app (fun m -> m " Fetching from verse remotes...");
1850
+
Eio.Fiber.List.iter ~max_fibers:4
1851
+
(fun pkg -> fetch_verse_remotes ~proc ~fs:fs_t ~config pkg)
1852
+
successfully_fetched_repos);
2143
1853
2144
-
(* Collect all errors *)
2145
-
let all_errors =
2146
-
push_errors @ fetch_errors @ !merge_errors @ !subtree_errors
2147
-
@ remote_errors
1854
+
(* Step 6: Finalize - write README.md, CLAUDE.md, and dune-project (SEQUENTIAL) *)
1855
+
Log.app (fun m ->
1856
+
m " Writing README.md, CLAUDE.md, and dune-project...");
1857
+
write_readme ~proc ~fs:fs_t ~config all_pkgs;
1858
+
write_claude_md ~proc ~fs:fs_t ~config;
1859
+
write_dune_project ~proc ~fs:fs_t ~config all_pkgs;
1860
+
1861
+
(* Step 7: Remote phase - push to upstream remotes if --remote (LIMITED PARALLEL) *)
1862
+
(* Only push repos that were successfully fetched *)
1863
+
let remote_errors =
1864
+
if remote then begin
1865
+
Log.app (fun m -> m " Pushing to upstream remotes...");
1866
+
(* Limit to 2 concurrent pushes to avoid overwhelming remotes *)
1867
+
let push_results =
1868
+
Eio.Fiber.List.map ~max_fibers:2
1869
+
(fun pkg ->
1870
+
let repo_name = Package.repo_name pkg in
1871
+
match push_remote_safe ~proc ~fs:fs_t ~config pkg with
1872
+
| Error e ->
1873
+
Error { repo_name; phase = `Push_remote; error = e }
1874
+
| Ok () ->
1875
+
Log.app (fun m -> m " Pushed %s" repo_name);
1876
+
Ok repo_name)
1877
+
successfully_fetched_repos
2148
1878
in
2149
-
let summary =
2150
-
{
2151
-
repos_synced = List.length repos - List.length all_errors;
2152
-
repos_unchanged = unchanged_count;
2153
-
commits_pulled = total_commits_pulled;
2154
-
commits_pushed = 0;
2155
-
(* TODO: track this *)
2156
-
errors = all_errors;
2157
-
}
1879
+
let errors, successes =
1880
+
List.partition_map
1881
+
(function Error e -> Left e | Ok r -> Right r)
1882
+
push_results
2158
1883
in
2159
-
2160
-
(* Print summary *)
2161
1884
Log.app (fun m ->
2162
-
m "@.Summary: %d synced, %d errors" summary.repos_synced
2163
-
(List.length summary.errors));
2164
-
if summary.errors <> [] then
2165
-
List.iter
2166
-
(fun e -> Log.warn (fun m -> m " %a" pp_sync_failure e))
2167
-
summary.errors;
2168
-
2169
-
Ok summary
1885
+
m " Pushed: %d repos to upstream" (List.length successes));
1886
+
errors
2170
1887
end
2171
-
end))
1888
+
else []
1889
+
in
1890
+
1891
+
(* Collect all errors *)
1892
+
let all_errors =
1893
+
push_errors @ fetch_errors @ !merge_errors @ !subtree_errors
1894
+
@ remote_errors
1895
+
in
1896
+
let summary =
1897
+
{
1898
+
repos_synced = List.length repos - List.length all_errors;
1899
+
repos_unchanged = unchanged_count;
1900
+
commits_pulled = total_commits_pulled;
1901
+
commits_pushed = 0;
1902
+
(* TODO: track this *)
1903
+
errors = all_errors;
1904
+
}
1905
+
in
1906
+
1907
+
(* Print summary *)
1908
+
Log.app (fun m ->
1909
+
m "@.Summary: %d synced, %d errors" summary.repos_synced
1910
+
(List.length summary.errors));
1911
+
if summary.errors <> [] then
1912
+
List.iter
1913
+
(fun e -> Log.warn (fun m -> m " %a" pp_sync_failure e))
1914
+
summary.errors;
1915
+
1916
+
Ok summary
1917
+
end
1918
+
end
1919
+
end)
2172
1920
2173
1921
(* Opam metadata sync: copy .opam files from monorepo subtrees to opam-repo *)
2174
1922
···
2231
1979
| Ok s ->
2232
1980
let count = List.length (Sources_registry.to_list s) in
2233
1981
if count > 0 then
2234
-
Log.info (fun m ->
2235
-
m "Loaded %d source overrides from sources.toml" count);
1982
+
Log.info (fun m -> m "Loaded %d source overrides from sources.toml" count);
2236
1983
s
2237
1984
| Error msg ->
2238
1985
Log.warn (fun m -> m "Failed to load sources.toml: %s" msg);
···
2240
1987
in
2241
1988
2242
1989
(* Discover packages from monorepo *)
2243
-
match
2244
-
discover_packages_from_monorepo ~fs:(fs :> _ Eio.Path.t) ~config ~sources ()
2245
-
with
1990
+
match discover_packages_from_monorepo ~fs:(fs :> _ Eio.Path.t) ~config ~sources () with
2246
1991
| Error e -> Error e
2247
1992
| Ok all_pkgs ->
2248
1993
(* Filter to specific package/subtree if requested *)
···
2267
2012
(fun pkg ->
2268
2013
(* Destination: opam-repo/packages/<name>/<name>.dev/opam *)
2269
2014
let pkg_dir =
2270
-
Fpath.(
2271
-
opam_repo / "packages" / pkg.pkg_name / (pkg.pkg_name ^ ".dev"))
2015
+
Fpath.(opam_repo / "packages" / pkg.pkg_name / (pkg.pkg_name ^ ".dev"))
2272
2016
in
2273
2017
let dst_path = Eio.Path.(fs / Fpath.to_string pkg_dir / "opam") in
2274
2018
···
2299
2043
2300
2044
(* Find and delete orphaned packages *)
2301
2045
let generated_names =
2302
-
List.map (fun p -> p.pkg_name) pkgs |> List.sort_uniq String.compare
2046
+
List.map (fun p -> p.pkg_name) pkgs
2047
+
|> List.sort_uniq String.compare
2303
2048
in
2304
2049
let existing_packages = list_opam_repo_packages ~fs ~config in
2305
2050
let orphaned =
···
2325
2070
{
2326
2071
synced = List.rev !synced;
2327
2072
unchanged = List.rev !unchanged;
2328
-
missing = [];
2329
-
(* No longer used in generation-based approach *)
2073
+
missing = []; (* No longer used in generation-based approach *)
2330
2074
orphaned = deleted;
2331
2075
}
2332
2076
in
···
2380
2124
let fs = fs_typed fs in
2381
2125
let monorepo = Config.Paths.monorepo config in
2382
2126
let prefix = package in
2383
-
if not (Git_cli.subtree_prefix_exists ~fs ~repo:monorepo ~prefix) then Ok ()
2127
+
if not (Git.Subtree.exists ~fs ~repo:monorepo ~prefix) then Ok ()
2384
2128
else
2385
2129
let subtree_path = Eio.Path.(fs / Fpath.to_string monorepo / prefix) in
2386
2130
try
2387
2131
Eio.Path.rmtree subtree_path;
2388
2132
Ok ()
2389
2133
with Eio.Io _ as e ->
2390
-
Error (Git_error (Git_cli.Io_error (Printexc.to_string e)))
2134
+
Error (Git_error (Git.Io_error (Printexc.to_string e)))
2391
2135
2392
2136
(* Changes command - generate weekly changelogs using Claude *)
2393
2137
···
2459
2203
let since = week_start ^ " 00:00:00" in
2460
2204
let until = week_end ^ " 23:59:59" in
2461
2205
match
2462
-
Git_cli.log ~proc ~fs:fs_t ~since ~until
2463
-
~path:repo_name monorepo
2206
+
Git.log ~proc ~fs:fs_t ~since ~until ~path:repo_name
2207
+
monorepo
2464
2208
with
2465
2209
| Error e -> Error (Git_error e)
2466
2210
| Ok commits ->
···
2502
2246
repo_name week_start);
2503
2247
(* Create new entry *)
2504
2248
let first_hash =
2505
-
(List.hd commits).Git_cli.hash
2249
+
(List.hd commits).Git.hash
2506
2250
in
2507
2251
let last_hash =
2508
-
(List.hd (List.rev commits)).Git_cli.hash
2252
+
(List.hd (List.rev commits)).Git.hash
2509
2253
in
2510
2254
let entry : Changes.weekly_entry =
2511
2255
{
···
2668
2412
let since = date ^ " 00:00:00" in
2669
2413
let until = date ^ " 23:59:59" in
2670
2414
match
2671
-
Git_cli.log ~proc ~fs:fs_t ~since ~until
2672
-
~path:repo_name monorepo
2415
+
Git.log ~proc ~fs:fs_t ~since ~until ~path:repo_name
2416
+
monorepo
2673
2417
with
2674
2418
| Error e -> Error (Git_error e)
2675
2419
| Ok commits ->
···
2712
2456
(* Extract unique contributors from commits *)
2713
2457
let contributors =
2714
2458
commits
2715
-
|> List.map
2716
-
(fun (c : Git_cli.log_entry) ->
2717
-
c.author)
2459
+
|> List.map (fun (c : Git.log_entry) ->
2460
+
c.author)
2718
2461
|> List.sort_uniq String.compare
2719
2462
in
2720
2463
(* Get repo URL from package dev_repo *)
···
2731
2474
in
2732
2475
(* Create new entry with hour and timestamp *)
2733
2476
let first_hash =
2734
-
(List.hd commits).Git_cli.hash
2477
+
(List.hd commits).Git.hash
2735
2478
in
2736
2479
let last_hash =
2737
-
(List.hd (List.rev commits)).Git_cli.hash
2480
+
(List.hd (List.rev commits)).Git.hash
2738
2481
in
2739
2482
let _, ((hour, _, _), _) =
2740
2483
Ptime.to_date_time now_ptime
···
2831
2574
if (not dry_run) && aggregate then begin
2832
2575
let today = Changes.date_of_ptime now_ptime in
2833
2576
let git_head =
2834
-
match Git_cli.rev_parse ~proc ~fs:fs_t ~rev:"HEAD" monorepo with
2577
+
match Git.rev_parse ~proc ~fs:fs_t ~rev:"HEAD" monorepo with
2835
2578
| Ok hash -> String.sub hash 0 (min 7 (String.length hash))
2836
2579
| Error _ -> "unknown"
2837
2580
in
···
2856
2599
repo_name : string;
2857
2600
handle : string;
2858
2601
relationship : Forks.relationship;
2859
-
commits : Git_cli.log_entry list;
2860
-
patches : (string * string) list; (* hash -> patch content *)
2602
+
commits : Git.log_entry list;
2603
+
patches : (string * string) list; (* hash -> patch content *)
2861
2604
}
2862
2605
2863
-
type diff_result = { entries : diff_entry list; forks : Forks.t }
2606
+
type diff_result = {
2607
+
entries : diff_entry list;
2608
+
forks : Forks.t;
2609
+
}
2864
2610
2865
2611
let pp_diff_entry ~show_patch ppf entry =
2866
2612
let n_commits = List.length entry.commits in
2867
2613
Fmt.pf ppf "@[<v 2>%a %s (%a, %d commit%s):@,"
2868
-
Fmt.(styled `Bold string)
2869
-
entry.repo_name entry.handle Forks.pp_relationship entry.relationship
2870
-
n_commits
2871
-
(if n_commits = 1 then "" else "s");
2872
-
List.iter
2873
-
(fun (c : Git_cli.log_entry) ->
2874
-
let short_hash = String.sub c.hash 0 (min 7 (String.length c.hash)) in
2875
-
Fmt.pf ppf " %a %s %a@,"
2876
-
Fmt.(styled `Yellow string)
2877
-
short_hash c.subject
2878
-
Fmt.(styled `Faint string)
2879
-
c.author;
2880
-
if show_patch then
2881
-
match List.assoc_opt c.hash entry.patches with
2882
-
| Some patch -> Fmt.pf ppf "@,%s@," patch
2883
-
| None -> ())
2614
+
Fmt.(styled `Bold string) entry.repo_name
2615
+
entry.handle
2616
+
Forks.pp_relationship entry.relationship
2617
+
n_commits (if n_commits = 1 then "" else "s");
2618
+
List.iter (fun (c : Git.log_entry) ->
2619
+
let short_hash = String.sub c.hash 0 (min 7 (String.length c.hash)) in
2620
+
Fmt.pf ppf " %a %s %a@,"
2621
+
Fmt.(styled `Yellow string) short_hash
2622
+
c.subject
2623
+
Fmt.(styled `Faint string) c.author;
2624
+
if show_patch then
2625
+
match List.assoc_opt c.hash entry.patches with
2626
+
| Some patch -> Fmt.pf ppf "@,%s@," patch
2627
+
| None -> ())
2884
2628
entry.commits;
2885
2629
Fmt.pf ppf "@]"
2886
2630
···
2890
2634
(* Then show diffs for each entry *)
2891
2635
if result.entries <> [] then begin
2892
2636
Fmt.pf ppf "@[<v>%a@]@."
2893
-
Fmt.(list ~sep:(any "@,@,") (pp_diff_entry ~show_patch))
2894
-
result.entries
2637
+
Fmt.(list ~sep:(any "@,@,") (pp_diff_entry ~show_patch)) result.entries
2895
2638
end
2896
2639
2897
2640
(** Check if a string looks like a git commit hash (7+ hex chars) *)
2898
2641
let is_commit_sha s =
2899
-
String.length s >= 7
2900
-
&& String.for_all
2901
-
(function '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true | _ -> false)
2902
-
s
2642
+
String.length s >= 7 &&
2643
+
String.for_all (function '0'..'9' | 'a'..'f' | 'A'..'F' -> true | _ -> false) s
2903
2644
2904
-
let diff ~proc ~fs ~config ~verse_config ?repo ?(refresh = false)
2905
-
?(patch = false) () =
2645
+
let diff ~proc ~fs ~config ~verse_config ?repo ?(refresh=false) ?(patch=false) () =
2906
2646
let checkouts_path = Config.Paths.checkouts config in
2907
2647
2908
2648
(* Compute fork analysis *)
2909
-
let forks =
2910
-
Forks.compute ~proc ~fs ~verse_config ~monopam_config:config ~refresh ()
2911
-
in
2649
+
let forks = Forks.compute ~proc ~fs ~verse_config ~monopam_config:config ~refresh () in
2912
2650
2913
2651
(* Filter repos if specific one requested *)
2914
-
let repos_to_check =
2915
-
match repo with
2652
+
let repos_to_check = match repo with
2916
2653
| None -> forks.repos
2917
2654
| Some name -> List.filter (fun r -> r.Forks.repo_name = name) forks.repos
2918
2655
in
2919
2656
2920
2657
(* For each repo with actionable status, get commits *)
2921
2658
let entries =
2922
-
List.filter_map
2923
-
(fun (r : Forks.repo_analysis) ->
2924
-
(* Find actionable verse sources *)
2925
-
let actionable =
2926
-
List.filter
2927
-
(fun (_, _, rel) ->
2928
-
match rel with
2929
-
| Forks.I_am_behind _ -> true
2930
-
| Forks.Diverged _ -> true
2931
-
| _ -> false)
2932
-
r.verse_sources
2933
-
in
2934
-
match actionable with
2935
-
| [] -> None
2936
-
| sources -> (
2937
-
(* Get commits for each actionable source *)
2938
-
let entries =
2939
-
List.filter_map
2940
-
(fun (handle, _src, rel) ->
2941
-
let checkout_path = Fpath.(checkouts_path / r.repo_name) in
2942
-
if not (Git_cli.is_repo ~proc ~fs checkout_path) then None
2943
-
else begin
2944
-
let remote_name = "verse/" ^ handle in
2945
-
let my_ref = "origin/main" in
2946
-
let their_ref = remote_name ^ "/main" in
2947
-
(* Get commits they have that I don't *)
2948
-
match
2949
-
Git_cli.log_range ~proc ~fs ~base:my_ref ~tip:their_ref
2950
-
~max_count:20 checkout_path
2951
-
with
2952
-
| Error _ -> None
2953
-
| Ok commits when commits = [] -> None
2954
-
| Ok commits ->
2955
-
(* Fetch patches if requested *)
2956
-
let patches =
2957
-
if patch then
2958
-
List.filter_map
2959
-
(fun (c : Git_cli.log_entry) ->
2960
-
match
2961
-
Git_cli.show_patch ~proc ~fs ~commit:c.hash
2962
-
checkout_path
2963
-
with
2964
-
| Ok p -> Some (c.hash, p)
2965
-
| Error _ -> None)
2966
-
commits
2967
-
else []
2968
-
in
2969
-
Some
2970
-
{
2971
-
repo_name = r.repo_name;
2972
-
handle;
2973
-
relationship = rel;
2974
-
commits;
2975
-
patches;
2976
-
}
2977
-
end)
2978
-
sources
2979
-
in
2980
-
match entries with [] -> None | _ -> Some entries))
2659
+
List.filter_map (fun (r : Forks.repo_analysis) ->
2660
+
(* Find actionable verse sources *)
2661
+
let actionable = List.filter (fun (_, _, rel) ->
2662
+
match rel with
2663
+
| Forks.I_am_behind _ -> true
2664
+
| Forks.Diverged _ -> true
2665
+
| _ -> false)
2666
+
r.verse_sources
2667
+
in
2668
+
match actionable with
2669
+
| [] -> None
2670
+
| sources ->
2671
+
(* Get commits for each actionable source *)
2672
+
let entries = List.filter_map (fun (handle, _src, rel) ->
2673
+
let checkout_path = Fpath.(checkouts_path / r.repo_name) in
2674
+
if not (Git.is_repo ~proc ~fs checkout_path) then None
2675
+
else begin
2676
+
let remote_name = "verse/" ^ handle in
2677
+
let my_ref = "origin/main" in
2678
+
let their_ref = remote_name ^ "/main" in
2679
+
(* Get commits they have that I don't *)
2680
+
match Git.log_range ~proc ~fs ~base:my_ref ~tip:their_ref ~max_count:20 checkout_path with
2681
+
| Error _ -> None
2682
+
| Ok commits when commits = [] -> None
2683
+
| Ok commits ->
2684
+
(* Fetch patches if requested *)
2685
+
let patches =
2686
+
if patch then
2687
+
List.filter_map (fun (c : Git.log_entry) ->
2688
+
match Git.show_patch ~proc ~fs ~commit:c.hash checkout_path with
2689
+
| Ok p -> Some (c.hash, p)
2690
+
| Error _ -> None)
2691
+
commits
2692
+
else []
2693
+
in
2694
+
Some { repo_name = r.repo_name; handle; relationship = rel; commits; patches }
2695
+
end)
2696
+
sources
2697
+
in
2698
+
match entries with
2699
+
| [] -> None
2700
+
| _ -> Some entries)
2981
2701
repos_to_check
2982
2702
|> List.flatten
2983
2703
in
2984
2704
{ entries; forks }
2985
2705
2706
+
(** Result of looking up a specific commit *)
2986
2707
type commit_info = {
2987
2708
commit_repo : string;
2988
2709
commit_handle : string;
···
2991
2712
commit_author : string;
2992
2713
commit_patch : string;
2993
2714
}
2994
-
(** Result of looking up a specific commit *)
2995
2715
2996
2716
(** Show patch for a specific commit SHA from diff output *)
2997
-
let diff_show_commit ~proc ~fs ~config ~verse_config ~sha ?(refresh = false) ()
2998
-
=
2717
+
let diff_show_commit ~proc ~fs ~config ~verse_config ~sha ?(refresh=false) () =
2999
2718
let checkouts_path = Config.Paths.checkouts config in
3000
2719
3001
2720
(* Compute fork analysis to find which repo has this commit *)
3002
-
let forks =
3003
-
Forks.compute ~proc ~fs ~verse_config ~monopam_config:config ~refresh ()
3004
-
in
2721
+
let forks = Forks.compute ~proc ~fs ~verse_config ~monopam_config:config ~refresh () in
3005
2722
3006
2723
(* Search through repos for this commit *)
3007
-
let result =
3008
-
List.find_map
3009
-
(fun (r : Forks.repo_analysis) ->
3010
-
let checkout_path = Fpath.(checkouts_path / r.repo_name) in
3011
-
if not (Git_cli.is_repo ~proc ~fs checkout_path) then None
3012
-
else
3013
-
(* Check each verse source *)
3014
-
List.find_map
3015
-
(fun (handle, _src, rel) ->
3016
-
match rel with
3017
-
| Forks.I_am_behind _ | Forks.Diverged _ -> (
3018
-
let remote_name = "verse/" ^ handle in
3019
-
let my_ref = "origin/main" in
3020
-
let their_ref = remote_name ^ "/main" in
3021
-
(* Get commits they have that I don't *)
3022
-
match
3023
-
Git_cli.log_range ~proc ~fs ~base:my_ref ~tip:their_ref
3024
-
~max_count:50 checkout_path
3025
-
with
3026
-
| Error _ -> None
3027
-
| Ok commits -> (
3028
-
(* Check if our sha matches any commit *)
3029
-
let matching =
3030
-
List.find_opt
3031
-
(fun (c : Git_cli.log_entry) ->
3032
-
String.starts_with ~prefix:sha c.hash
3033
-
|| String.starts_with
3034
-
~prefix:(String.lowercase_ascii sha)
3035
-
(String.lowercase_ascii c.hash))
3036
-
commits
3037
-
in
3038
-
match matching with
3039
-
| None -> None
3040
-
| Some c -> (
3041
-
match
3042
-
Git_cli.show_patch ~proc ~fs ~commit:c.hash
3043
-
checkout_path
3044
-
with
3045
-
| Ok patch ->
3046
-
Some
3047
-
{
3048
-
commit_repo = r.repo_name;
3049
-
commit_handle = handle;
3050
-
commit_hash = c.hash;
3051
-
commit_subject = c.subject;
3052
-
commit_author = c.author;
3053
-
commit_patch = patch;
3054
-
}
3055
-
| Error _ -> None)))
3056
-
| _ -> None)
3057
-
r.verse_sources)
3058
-
forks.repos
2724
+
let result = List.find_map (fun (r : Forks.repo_analysis) ->
2725
+
let checkout_path = Fpath.(checkouts_path / r.repo_name) in
2726
+
if not (Git.is_repo ~proc ~fs checkout_path) then None
2727
+
else
2728
+
(* Check each verse source *)
2729
+
List.find_map (fun (handle, _src, rel) ->
2730
+
match rel with
2731
+
| Forks.I_am_behind _ | Forks.Diverged _ ->
2732
+
let remote_name = "verse/" ^ handle in
2733
+
let my_ref = "origin/main" in
2734
+
let their_ref = remote_name ^ "/main" in
2735
+
(* Get commits they have that I don't *)
2736
+
(match Git.log_range ~proc ~fs ~base:my_ref ~tip:their_ref ~max_count:50 checkout_path with
2737
+
| Error _ -> None
2738
+
| Ok commits ->
2739
+
(* Check if our sha matches any commit *)
2740
+
let matching = List.find_opt (fun (c : Git.log_entry) ->
2741
+
String.starts_with ~prefix:sha c.hash ||
2742
+
String.starts_with ~prefix:(String.lowercase_ascii sha) (String.lowercase_ascii c.hash))
2743
+
commits
2744
+
in
2745
+
match matching with
2746
+
| None -> None
2747
+
| Some c ->
2748
+
match Git.show_patch ~proc ~fs ~commit:c.hash checkout_path with
2749
+
| Ok patch -> Some {
2750
+
commit_repo = r.repo_name;
2751
+
commit_handle = handle;
2752
+
commit_hash = c.hash;
2753
+
commit_subject = c.subject;
2754
+
commit_author = c.author;
2755
+
commit_patch = patch;
2756
+
}
2757
+
| Error _ -> None)
2758
+
| _ -> None)
2759
+
r.verse_sources)
2760
+
forks.repos
3059
2761
in
3060
2762
result
3061
2763
···
3070
2772
let pp_handle_pull_result ppf result =
3071
2773
if result.repos_pulled <> [] then begin
3072
2774
Fmt.pf ppf "@[<v>%a@," Fmt.(styled `Bold string) "Pulled:";
3073
-
List.iter
3074
-
(fun (repo, count) -> Fmt.pf ppf " %s: %d commits@," repo count)
2775
+
List.iter (fun (repo, count) ->
2776
+
Fmt.pf ppf " %s: %d commits@," repo count)
3075
2777
result.repos_pulled;
3076
2778
Fmt.pf ppf "@]"
3077
2779
end;
3078
2780
if result.repos_skipped <> [] then
3079
2781
Fmt.pf ppf "%a %s@,"
3080
-
Fmt.(styled `Faint string)
3081
-
"Skipped:"
2782
+
Fmt.(styled `Faint string) "Skipped:"
3082
2783
(String.concat ", " result.repos_skipped);
3083
2784
if result.repos_failed <> [] then begin
3084
2785
Fmt.pf ppf "@[<v>%a@," Fmt.(styled `Red string) "Failed:";
3085
-
List.iter
3086
-
(fun (repo, err) -> Fmt.pf ppf " %s: %s@," repo err)
2786
+
List.iter (fun (repo, err) ->
2787
+
Fmt.pf ppf " %s: %s@," repo err)
3087
2788
result.repos_failed;
3088
2789
Fmt.pf ppf "@]"
3089
2790
end
3090
2791
3091
-
let pull_from_handle ~proc ~fs ~config ~verse_config ~handle ?repo
3092
-
?(refresh = false) () =
2792
+
let pull_from_handle ~proc ~fs ~config ~verse_config ~handle ?repo ?(refresh=false) () =
3093
2793
let checkouts_path = Config.Paths.checkouts config in
3094
2794
3095
2795
(* Compute fork analysis *)
3096
-
let forks =
3097
-
Forks.compute ~proc ~fs ~verse_config ~monopam_config:config ~refresh ()
3098
-
in
2796
+
let forks = Forks.compute ~proc ~fs ~verse_config ~monopam_config:config ~refresh () in
3099
2797
3100
2798
(* Filter repos if specific one requested *)
3101
-
let repos_to_check =
3102
-
match repo with
2799
+
let repos_to_check = match repo with
3103
2800
| None -> forks.repos
3104
2801
| Some name -> List.filter (fun r -> r.Forks.repo_name = name) forks.repos
3105
2802
in
···
3109
2806
let repos_skipped = ref [] in
3110
2807
let repos_failed = ref [] in
3111
2808
3112
-
List.iter
3113
-
(fun (r : Forks.repo_analysis) ->
3114
-
(* Check if this handle has commits for this repo *)
3115
-
let handle_source =
3116
-
List.find_opt (fun (h, _, _) -> h = handle) r.verse_sources
3117
-
in
3118
-
match handle_source with
3119
-
| None ->
3120
-
(* Handle doesn't have this repo *)
3121
-
()
3122
-
| Some (_, _, rel) ->
3123
-
let checkout_path = Fpath.(checkouts_path / r.repo_name) in
3124
-
if not (Git_cli.is_repo ~proc ~fs checkout_path) then
3125
-
repos_skipped := r.repo_name :: !repos_skipped
3126
-
else begin
3127
-
match rel with
3128
-
| Forks.Same_url | Forks.Same_commit | Forks.I_am_ahead _ ->
3129
-
repos_skipped := r.repo_name :: !repos_skipped
3130
-
| Forks.Not_fetched | Forks.Unrelated ->
3131
-
repos_skipped := r.repo_name :: !repos_skipped
3132
-
| Forks.I_am_behind count -> (
3133
-
(* Merge their changes *)
3134
-
let remote_ref = "verse/" ^ handle ^ "/main" in
3135
-
match
3136
-
Git_cli.merge ~proc ~fs ~ref_name:remote_ref ~ff_only:true
3137
-
checkout_path
3138
-
with
3139
-
| Ok () -> repos_pulled := (r.repo_name, count) :: !repos_pulled
3140
-
| Error e ->
3141
-
repos_failed :=
3142
-
(r.repo_name, Fmt.str "%a" Git_cli.pp_error e)
3143
-
:: !repos_failed)
3144
-
| Forks.Diverged { their_ahead; _ } -> (
3145
-
(* Merge their changes (may create a merge commit) *)
3146
-
let remote_ref = "verse/" ^ handle ^ "/main" in
3147
-
match
3148
-
Git_cli.merge ~proc ~fs ~ref_name:remote_ref checkout_path
3149
-
with
3150
-
| Ok () ->
3151
-
repos_pulled := (r.repo_name, their_ahead) :: !repos_pulled
3152
-
| Error e ->
3153
-
repos_failed :=
3154
-
(r.repo_name, Fmt.str "%a" Git_cli.pp_error e)
3155
-
:: !repos_failed)
3156
-
end)
2809
+
List.iter (fun (r : Forks.repo_analysis) ->
2810
+
(* Check if this handle has commits for this repo *)
2811
+
let handle_source = List.find_opt (fun (h, _, _) -> h = handle) r.verse_sources in
2812
+
match handle_source with
2813
+
| None ->
2814
+
(* Handle doesn't have this repo *)
2815
+
()
2816
+
| Some (_, _, rel) ->
2817
+
let checkout_path = Fpath.(checkouts_path / r.repo_name) in
2818
+
if not (Git.is_repo ~proc ~fs checkout_path) then
2819
+
repos_skipped := r.repo_name :: !repos_skipped
2820
+
else begin
2821
+
match rel with
2822
+
| Forks.Same_url | Forks.Same_commit | Forks.I_am_ahead _ ->
2823
+
repos_skipped := r.repo_name :: !repos_skipped
2824
+
| Forks.Not_fetched | Forks.Unrelated ->
2825
+
repos_skipped := r.repo_name :: !repos_skipped
2826
+
| Forks.I_am_behind count ->
2827
+
(* Merge their changes *)
2828
+
let remote_ref = "verse/" ^ handle ^ "/main" in
2829
+
(match Git.merge ~proc ~fs ~ref_name:remote_ref ~ff_only:true checkout_path with
2830
+
| Ok () ->
2831
+
repos_pulled := (r.repo_name, count) :: !repos_pulled
2832
+
| Error e ->
2833
+
repos_failed := (r.repo_name, Fmt.str "%a" Git.pp_error e) :: !repos_failed)
2834
+
| Forks.Diverged { their_ahead; _ } ->
2835
+
(* Merge their changes (may create a merge commit) *)
2836
+
let remote_ref = "verse/" ^ handle ^ "/main" in
2837
+
(match Git.merge ~proc ~fs ~ref_name:remote_ref checkout_path with
2838
+
| Ok () ->
2839
+
repos_pulled := (r.repo_name, their_ahead) :: !repos_pulled
2840
+
| Error e ->
2841
+
repos_failed := (r.repo_name, Fmt.str "%a" Git.pp_error e) :: !repos_failed)
2842
+
end)
3157
2843
repos_to_check;
3158
2844
3159
-
Ok
3160
-
{
3161
-
repos_pulled = List.rev !repos_pulled;
3162
-
repos_skipped = List.rev !repos_skipped;
3163
-
repos_failed = List.rev !repos_failed;
3164
-
}
2845
+
Ok {
2846
+
repos_pulled = List.rev !repos_pulled;
2847
+
repos_skipped = List.rev !repos_skipped;
2848
+
repos_failed = List.rev !repos_failed;
2849
+
}
3165
2850
3166
2851
(* ==================== Cherry-pick ==================== *)
3167
2852
···
3172
2857
}
3173
2858
3174
2859
let pp_cherrypick_result ppf result =
3175
-
let short_hash =
3176
-
String.sub result.commit_hash 0 (min 7 (String.length result.commit_hash))
3177
-
in
2860
+
let short_hash = String.sub result.commit_hash 0 (min 7 (String.length result.commit_hash)) in
3178
2861
Fmt.pf ppf "Cherry-picked %a %s into %s@."
3179
-
Fmt.(styled `Yellow string)
3180
-
short_hash result.commit_subject result.repo_name
2862
+
Fmt.(styled `Yellow string) short_hash
2863
+
result.commit_subject
2864
+
result.repo_name
3181
2865
3182
-
let cherrypick ~proc ~fs ~config ~verse_config ~sha ?(refresh = false) () =
2866
+
let cherrypick ~proc ~fs ~config ~verse_config ~sha ?(refresh=false) () =
3183
2867
let checkouts_path = Config.Paths.checkouts config in
3184
2868
3185
2869
(* First, find the commit *)
3186
2870
match diff_show_commit ~proc ~fs ~config ~verse_config ~sha ~refresh () with
3187
2871
| None ->
3188
-
Error
3189
-
(Config_error
3190
-
(Printf.sprintf "Commit %s not found in any verse diff" sha))
2872
+
Error (Config_error (Printf.sprintf "Commit %s not found in any verse diff" sha))
3191
2873
| Some info ->
3192
2874
let checkout_path = Fpath.(checkouts_path / info.commit_repo) in
3193
-
if not (Git_cli.is_repo ~proc ~fs checkout_path) then
3194
-
Error
3195
-
(Config_error
3196
-
(Printf.sprintf "No checkout for repository %s" info.commit_repo))
2875
+
if not (Git.is_repo ~proc ~fs checkout_path) then
2876
+
Error (Config_error (Printf.sprintf "No checkout for repository %s" info.commit_repo))
3197
2877
else begin
3198
-
match
3199
-
Git_cli.cherry_pick ~proc ~fs ~commit:info.commit_hash checkout_path
3200
-
with
2878
+
match Git.cherry_pick ~proc ~fs ~commit:info.commit_hash checkout_path with
3201
2879
| Ok () ->
3202
-
Ok
3203
-
{
3204
-
repo_name = info.commit_repo;
3205
-
commit_hash = info.commit_hash;
3206
-
commit_subject = info.commit_subject;
3207
-
}
3208
-
| Error e -> Error (Git_error e)
2880
+
Ok {
2881
+
repo_name = info.commit_repo;
2882
+
commit_hash = info.commit_hash;
2883
+
commit_subject = info.commit_subject;
2884
+
}
2885
+
| Error e ->
2886
+
Error (Git_error e)
3209
2887
end
+52
-65
lib/monopam.mli
+52
-65
lib/monopam.mli
···
17
17
- {!Config} - Configuration management
18
18
- {!Package} - Package metadata
19
19
- {!Opam_repo} - Opam repository scanning
20
-
- {!Git_cli} - Git operations (CLI-based)
20
+
- {!Git} - Git operations
21
21
- {!Status} - Status computation *)
22
22
23
23
(** Re-export modules for convenience. *)
···
25
25
module Config = Config
26
26
module Package = Package
27
27
module Opam_repo = Opam_repo
28
-
module Git_cli = Git_cli
28
+
module Git = Git
29
29
module Status = Status
30
30
module Changes = Changes
31
31
module Verse = Verse
···
40
40
module Sources_registry = Sources_registry
41
41
module Fork_join = Fork_join
42
42
module Site = Site
43
-
module Remote_cache = Remote_cache
44
43
45
44
(** {1 High-Level Operations} *)
46
45
···
48
47
type error =
49
48
| Config_error of string (** Configuration error *)
50
49
| Repo_error of Opam_repo.error (** Opam repository error *)
51
-
| Git_error of Git_cli.error (** Git operation error *)
50
+
| Git_error of Git.error (** Git operation error *)
52
51
| Dirty_state of Package.t list
53
52
(** Operation blocked due to dirty packages *)
54
53
| Monorepo_dirty (** Monorepo has uncommitted changes *)
···
144
143
type sync_failure = {
145
144
repo_name : string;
146
145
phase : sync_phase;
147
-
error : Git_cli.error;
146
+
error : Git.error;
148
147
}
149
148
(** A failure during sync for a specific repository. *)
150
149
···
167
166
(** [pp_sync_summary] formats a sync summary. *)
168
167
169
168
val sync :
170
-
sw:Eio.Switch.t ->
171
-
env:
172
-
< clock : _ Eio.Time.clock
173
-
; net : _ Eio.Net.t
174
-
; fs : Eio.Fs.dir_ty Eio.Path.t
175
-
; .. > ->
176
169
proc:_ Eio.Process.mgr ->
177
170
fs:Eio.Fs.dir_ty Eio.Path.t ->
178
171
config:Config.t ->
179
-
xdg:Xdge.t ->
180
172
?package:string ->
181
173
?remote:bool ->
182
174
?skip_push:bool ->
183
175
?skip_pull:bool ->
184
-
?skip_verse:bool ->
185
176
unit ->
186
177
(sync_summary, error) result
187
-
(** [sync ~sw ~env ~proc ~fs ~config ~xdg ?package ?remote ?skip_push ?skip_pull
188
-
?skip_verse ()] synchronizes the monorepo with upstream repositories.
178
+
(** [sync ~proc ~fs ~config ?package ?remote ?skip_push ?skip_pull ()]
179
+
synchronizes the monorepo with upstream repositories.
189
180
190
181
This is the primary command for all sync operations. It performs both push
191
182
and pull operations in the correct order: 1. Validate: check for dirty state
···
230
221
(** [sync_opam_files ~proc ~fs ~config ?package ()] generates opam-repo entries
231
222
from monorepo dune-project files.
232
223
233
-
For each subtree directory in the monorepo: 1. Parses the dune-project to
234
-
extract source/homepage URL 2. For each .opam file in the subtree:
235
-
- Transforms it by removing dune-generated comment
236
-
- Adds dev-repo and url fields derived from dune-project
237
-
- Writes to opam-repo/packages/<name>/<name>.dev/opam 3. Deletes any
238
-
orphaned packages in opam-repo not found in monorepo 4. Stages and commits
239
-
changes in opam-repo
224
+
For each subtree directory in the monorepo:
225
+
1. Parses the dune-project to extract source/homepage URL
226
+
2. For each .opam file in the subtree:
227
+
- Transforms it by removing dune-generated comment
228
+
- Adds dev-repo and url fields derived from dune-project
229
+
- Writes to opam-repo/packages/<name>/<name>.dev/opam
230
+
3. Deletes any orphaned packages in opam-repo not found in monorepo
231
+
4. Stages and commits changes in opam-repo
240
232
241
233
This is a generation-based approach - opam-repo is derived entirely from
242
234
monorepo dune-project and .opam files.
···
320
312
@param config Monopam configuration
321
313
@param pkgs List of packages discovered from the opam overlay *)
322
314
315
+
(** Information about a package discovered from the monorepo. *)
323
316
type monorepo_package = {
324
317
pkg_name : string; (** Package name (from .opam filename) *)
325
318
subtree : string; (** Subtree directory name *)
···
327
320
url_src : string; (** url src with branch (e.g., "git+https://...#main") *)
328
321
opam_content : string; (** Transformed opam file content ready to write *)
329
322
}
330
-
(** Information about a package discovered from the monorepo. *)
331
323
332
324
val discover_packages_from_monorepo :
333
325
fs:Eio.Fs.dir_ty Eio.Path.t ->
···
338
330
(** [discover_packages_from_monorepo ~fs ~config ?sources ()] scans monorepo
339
331
subtrees and discovers packages from dune-project files.
340
332
341
-
For each subdirectory of the monorepo with a dune-project file: 1. Checks
342
-
sources.toml for URL override 2. Falls back to dune-project source/homepage
343
-
URL 3. For each .opam file in that directory, transforms it with dev-repo
344
-
and url
333
+
For each subdirectory of the monorepo with a dune-project file:
334
+
1. Checks sources.toml for URL override
335
+
2. Falls back to dune-project source/homepage URL
336
+
3. For each .opam file in that directory, transforms it with dev-repo and url
345
337
346
338
@param fs Eio filesystem
347
339
@param config Monopam configuration
···
419
411
420
412
(** {1 Diff} *)
421
413
414
+
(** A diff entry for a single repository showing commits from a verse member. *)
422
415
type diff_entry = {
423
416
repo_name : string;
424
417
handle : string;
425
418
relationship : Forks.relationship;
426
-
commits : Git_cli.log_entry list;
419
+
commits : Git.log_entry list;
427
420
patches : (string * string) list; (** hash -> patch content *)
428
421
}
429
-
(** A diff entry for a single repository showing commits from a verse member. *)
430
422
431
-
type diff_result = { entries : diff_entry list; forks : Forks.t }
432
423
(** Result of computing diffs for repos needing attention. *)
424
+
type diff_result = {
425
+
entries : diff_entry list;
426
+
forks : Forks.t;
427
+
}
433
428
434
429
val pp_diff_entry : show_patch:bool -> diff_entry Fmt.t
435
-
(** [pp_diff_entry ~show_patch] formats a single diff entry. If [show_patch] is
436
-
true, includes the patch content for each commit. *)
430
+
(** [pp_diff_entry ~show_patch] formats a single diff entry.
431
+
If [show_patch] is true, includes the patch content for each commit. *)
437
432
438
433
val pp_diff_result : show_patch:bool -> diff_result Fmt.t
439
434
(** [pp_diff_result ~show_patch] formats the full diff result. *)
440
435
441
436
val is_commit_sha : string -> bool
442
-
(** [is_commit_sha s] returns true if [s] looks like a git commit hash (7+
443
-
hexadecimal characters). *)
437
+
(** [is_commit_sha s] returns true if [s] looks like a git commit hash
438
+
(7+ hexadecimal characters). *)
444
439
445
440
val diff :
446
441
proc:_ Eio.Process.mgr ->
···
452
447
?patch:bool ->
453
448
unit ->
454
449
diff_result
455
-
(** [diff ~proc ~fs ~config ~verse_config ?repo ?refresh ?patch ()] computes and
456
-
displays diffs for repositories that need attention from verse members.
450
+
(** [diff ~proc ~fs ~config ~verse_config ?repo ?refresh ?patch ()] computes and displays diffs
451
+
for repositories that need attention from verse members.
457
452
458
453
For each repository where a verse member is ahead (I_am_behind or Diverged),
459
454
retrieves the commit log showing what commits they have that you don't.
···
467
462
@param verse_config Verse configuration
468
463
@param repo Optional specific repository to show diff for
469
464
@param refresh If true, force fresh fetches ignoring cache (default: false)
470
-
@param patch
471
-
If true, fetch and include patch content for each commit (default: false)
472
-
*)
465
+
@param patch If true, fetch and include patch content for each commit (default: false) *)
473
466
467
+
(** Result of looking up a specific commit *)
474
468
type commit_info = {
475
469
commit_repo : string;
476
470
commit_handle : string;
···
479
473
commit_author : string;
480
474
commit_patch : string;
481
475
}
482
-
(** Result of looking up a specific commit *)
483
476
484
477
val diff_show_commit :
485
478
proc:_ Eio.Process.mgr ->
···
490
483
?refresh:bool ->
491
484
unit ->
492
485
commit_info option
493
-
(** [diff_show_commit ~proc ~fs ~config ~verse_config ~sha ?refresh ()] finds
494
-
and shows the patch for a specific commit SHA from the diff output.
486
+
(** [diff_show_commit ~proc ~fs ~config ~verse_config ~sha ?refresh ()] finds and shows
487
+
the patch for a specific commit SHA from the diff output.
495
488
496
489
Searches through all repos with actionable verse sources to find a commit
497
-
matching the given SHA prefix. Returns [Some commit_info] if found, [None]
498
-
otherwise.
490
+
matching the given SHA prefix. Returns [Some commit_info] if found, [None] otherwise.
499
491
500
492
@param sha Commit SHA prefix (7+ characters) to look up *)
501
493
502
494
(** {1 Pull from Verse Members} *)
503
495
496
+
(** Result of pulling from a handle. *)
504
497
type handle_pull_result = {
505
-
repos_pulled : (string * int) list;
506
-
(** (repo_name, commit_count) for each repo pulled *)
507
-
repos_skipped : string list;
508
-
(** Repos skipped (already in sync or no checkout) *)
509
-
repos_failed : (string * string) list;
510
-
(** (repo_name, error_message) for failures *)
498
+
repos_pulled : (string * int) list; (** (repo_name, commit_count) for each repo pulled *)
499
+
repos_skipped : string list; (** Repos skipped (already in sync or no checkout) *)
500
+
repos_failed : (string * string) list; (** (repo_name, error_message) for failures *)
511
501
}
512
-
(** Result of pulling from a handle. *)
513
502
514
503
val pp_handle_pull_result : handle_pull_result Fmt.t
515
504
(** [pp_handle_pull_result] formats a pull result. *)
···
527
516
(** [pull_from_handle ~proc ~fs ~config ~verse_config ~handle ?repo ?refresh ()]
528
517
pulls commits from a verse member's forks into your local checkouts.
529
518
530
-
For each repository where the handle has commits you don't have: 1. Merges
531
-
their commits into your checkout's main branch 2. The changes are then ready
532
-
to be synced to the monorepo via [sync]
519
+
For each repository where the handle has commits you don't have:
520
+
1. Merges their commits into your checkout's main branch
521
+
2. The changes are then ready to be synced to the monorepo via [sync]
533
522
534
-
If [repo] is specified, only pulls from that repository. Otherwise, pulls
535
-
from all repositories where the handle is ahead.
523
+
If [repo] is specified, only pulls from that repository.
524
+
Otherwise, pulls from all repositories where the handle is ahead.
536
525
537
526
@param handle The verse member handle (e.g., "avsm.bsky.social")
538
527
@param repo Optional specific repository to pull from
539
-
@param refresh If true, force fresh fetches ignoring cache (default: false)
540
-
*)
528
+
@param refresh If true, force fresh fetches ignoring cache (default: false) *)
541
529
542
530
(** {1 Cherry-pick} *)
543
531
532
+
(** Result of cherry-picking a commit. *)
544
533
type cherrypick_result = {
545
534
repo_name : string;
546
535
commit_hash : string;
547
536
commit_subject : string;
548
537
}
549
-
(** Result of cherry-picking a commit. *)
550
538
551
539
val pp_cherrypick_result : cherrypick_result Fmt.t
552
540
(** [pp_cherrypick_result] formats a cherry-pick result. *)
···
560
548
?refresh:bool ->
561
549
unit ->
562
550
(cherrypick_result, error) result
563
-
(** [cherrypick ~proc ~fs ~config ~verse_config ~sha ?refresh ()] applies a
564
-
specific commit from a verse member's fork to your local checkout.
551
+
(** [cherrypick ~proc ~fs ~config ~verse_config ~sha ?refresh ()]
552
+
applies a specific commit from a verse member's fork to your local checkout.
565
553
566
554
Finds the commit in the verse diff output and cherry-picks it into the
567
-
appropriate local checkout. The changes are then ready to be synced to the
568
-
monorepo via [sync].
555
+
appropriate local checkout. The changes are then ready to be synced to
556
+
the monorepo via [sync].
569
557
570
558
@param sha Commit SHA prefix (7+ characters) to cherry-pick
571
-
@param refresh If true, force fresh fetches ignoring cache (default: false)
572
-
*)
559
+
@param refresh If true, force fresh fetches ignoring cache (default: false) *)
+9
-16
lib/opam_repo.ml
+9
-16
lib/opam_repo.ml
···
188
188
(** Read the raw content of an opam file. *)
189
189
let read_opam_file ~fs opam_file_path =
190
190
let eio_path = Eio.Path.(fs / Fpath.to_string opam_file_path) in
191
-
try Ok (Eio.Path.load eio_path)
192
-
with Eio.Io _ as e -> Error (Io_error (Printexc.to_string e))
191
+
try Ok (Eio.Path.load eio_path) with Eio.Io _ as e -> Error (Io_error (Printexc.to_string e))
193
192
194
-
(** Replace dev-repo line in content. Looks for 'dev-repo: "..."' and replaces
195
-
the URL. *)
193
+
(** Replace dev-repo line in content. Looks for 'dev-repo: "..."' and replaces the URL. *)
196
194
let replace_dev_repo_line content ~new_url =
197
195
let lines = String.split_on_char '\n' content in
198
196
let dev_repo_url =
···
217
215
let url_src =
218
216
let base =
219
217
if String.starts_with ~prefix:"git@" new_url then "git+" ^ new_url
220
-
else if String.starts_with ~prefix:"https://" new_url then
221
-
"git+" ^ new_url
218
+
else if String.starts_with ~prefix:"https://" new_url then "git+" ^ new_url
222
219
else if String.starts_with ~prefix:"git+" new_url then new_url
223
220
else "git+" ^ new_url
224
221
in
···
242
239
else
243
240
(* Skip this line, it's part of the old url block *)
244
241
process rest true acc
245
-
else if trimmed = "url {" || String.starts_with ~prefix:"url {" trimmed
246
-
then
242
+
else if trimmed = "url {" || String.starts_with ~prefix:"url {" trimmed then
247
243
(* Start of url block *)
248
244
if String.ends_with ~suffix:"}" trimmed then
249
245
(* Single-line url block *)
···
256
252
in
257
253
String.concat "\n" (process lines false [])
258
254
259
-
(** Replace the dev-repo and url fields in an opam file content with a new git
260
-
URL. The new URL should be a plain git URL (e.g.,
261
-
"git@github.com:user/repo.git"). *)
255
+
(** Replace the dev-repo and url fields in an opam file content with a new git URL.
256
+
The new URL should be a plain git URL (e.g., "git@github.com:user/repo.git"). *)
262
257
let replace_dev_repo_url content ~new_url =
263
258
let content = replace_dev_repo_line content ~new_url in
264
259
let content = replace_url_section content ~new_url in
265
260
content
266
261
267
-
(** Write an opam package to the opam-repo overlay. Creates the directory
268
-
structure: packages/<name>/<name.version>/opam *)
262
+
(** Write an opam package to the opam-repo overlay.
263
+
Creates the directory structure: packages/<name>/<name.version>/opam *)
269
264
let write_package ~fs ~repo_path ~name ~version ~content =
270
-
let pkg_dir =
271
-
Fpath.(repo_path / "packages" / name / (name ^ "." ^ version))
272
-
in
265
+
let pkg_dir = Fpath.(repo_path / "packages" / name / (name ^ "." ^ version)) in
273
266
let opam_path = Fpath.(pkg_dir / "opam") in
274
267
let eio_pkg_dir = Eio.Path.(fs / Fpath.to_string pkg_dir) in
275
268
let eio_opam_path = Eio.Path.(fs / Fpath.to_string opam_path) in
+5
-8
lib/opam_repo.mli
+5
-8
lib/opam_repo.mli
···
90
90
(** {1 Low-level Opam File Parsing} *)
91
91
92
92
val find_dev_repo : OpamParserTypes.FullPos.opamfile_item list -> string option
93
-
(** [find_dev_repo items] extracts the dev-repo field from parsed opam file
94
-
items. *)
93
+
(** [find_dev_repo items] extracts the dev-repo field from parsed opam file items. *)
95
94
96
95
(** {1 Writing Packages} *)
97
96
···
101
100
val replace_dev_repo_url : string -> new_url:string -> string
102
101
(** [replace_dev_repo_url content ~new_url] replaces the dev-repo and url fields
103
102
in an opam file content with a new git URL. The new URL should be a plain
104
-
git URL (e.g., "git@github.com:user/repo.git" or
105
-
"https://github.com/user/repo.git"). *)
103
+
git URL (e.g., "git@github.com:user/repo.git" or "https://github.com/user/repo.git"). *)
106
104
107
105
val write_package :
108
106
fs:_ Eio.Path.t ->
···
111
109
version:string ->
112
110
content:string ->
113
111
(unit, error) result
114
-
(** [write_package ~fs ~repo_path ~name ~version ~content] writes an opam
115
-
package to the opam-repo overlay.
112
+
(** [write_package ~fs ~repo_path ~name ~version ~content] writes an opam package
113
+
to the opam-repo overlay.
116
114
117
115
Creates the directory structure: [packages/<name>/<name.version>/opam] *)
118
116
119
117
val package_exists : fs:_ Eio.Path.t -> repo_path:Fpath.t -> name:string -> bool
120
-
(** [package_exists ~fs ~repo_path ~name] checks if a package exists in the
121
-
opam-repo. *)
118
+
(** [package_exists ~fs ~repo_path ~name] checks if a package exists in the opam-repo. *)
+5
-2
lib/opam_transform.ml
+5
-2
lib/opam_transform.ml
···
32
32
let trimmed = String.trim line in
33
33
if in_url_block then
34
34
(* Inside url { ... }, skip until we see } *)
35
-
if String.starts_with ~prefix:"}" trimmed then process rest false acc
35
+
if String.starts_with ~prefix:"}" trimmed then
36
+
process rest false acc
36
37
else process rest true acc
37
38
else if trimmed = "url {" || String.starts_with ~prefix:"url {" trimmed
38
39
then
···
71
72
72
73
(* Step 4: Append dev-repo and url section *)
73
74
let dev_repo_line = Printf.sprintf {|dev-repo: "%s"|} dev_repo in
74
-
let url_section = Printf.sprintf "url {\n src: \"%s\"\n}" url_src in
75
+
let url_section =
76
+
Printf.sprintf "url {\n src: \"%s\"\n}" url_src
77
+
in
75
78
content ^ "\n" ^ dev_repo_line ^ "\n" ^ url_section ^ "\n"
+2
-4
lib/opam_transform.mli
+2
-4
lib/opam_transform.mli
···
7
7
- Add url section with source URL and branch *)
8
8
9
9
val transform : content:string -> dev_repo:string -> url_src:string -> string
10
-
(** [transform ~content ~dev_repo ~url_src] transforms a dune-generated opam
11
-
file.
10
+
(** [transform ~content ~dev_repo ~url_src] transforms a dune-generated opam file.
12
11
13
12
- Removes the "# This file is generated by dune" comment if present
14
13
- Adds or replaces the [dev-repo] field with [dev_repo]
15
14
- Adds or replaces the [url { src: "..." }] section with [url_src]
16
15
17
16
@param content The original opam file content
18
-
@param dev_repo
19
-
The dev-repo URL (e.g., "git+https://github.com/user/repo.git")
17
+
@param dev_repo The dev-repo URL (e.g., "git+https://github.com/user/repo.git")
20
18
@param url_src The url src URL with branch (e.g., "git+https://...#main") *)
-91
lib/remote_cache.ml
-91
lib/remote_cache.ml
···
1
-
(* Copyright (c) 2024-2026 Thomas Gazagnaire <thomas@gazagnaire.org>
2
-
3
-
Permission to use, copy, modify, and distribute this software for any
4
-
purpose with or without fee is hereby granted, provided that the above
5
-
copyright notice and this permission notice appear in all copies.
6
-
7
-
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
8
-
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
9
-
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10
-
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11
-
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12
-
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13
-
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *)
14
-
15
-
(** Remote HEAD cache with O(1) in-memory lookup and optional disk persistence.
16
-
17
-
Uses a Hashtbl for O(1) amortized lookup by key (url:branch). Entries expire
18
-
after a configurable TTL (default 5 minutes).
19
-
20
-
File format: one entry per line "url:branch hash timestamp" *)
21
-
22
-
let src = Logs.Src.create "monopam.remote_cache" ~doc:"Remote HEAD cache"
23
-
24
-
module Log = (val Logs.src_log src : Logs.LOG)
25
-
26
-
type entry = { hash : string; expires : float }
27
-
type t = { tbl : (string, entry) Hashtbl.t; ttl : float; now : unit -> float }
28
-
29
-
let default_ttl = 300.0 (* 5 minutes *)
30
-
let make_key url branch = Fmt.str "%s:%s" (Uri.to_string url) branch
31
-
32
-
let parse_line ~ttl line =
33
-
match String.split_on_char ' ' line with
34
-
| [ key; hash; ts ] ->
35
-
let ts = float_of_string ts in
36
-
Some (key, { hash; expires = ts +. ttl })
37
-
| _ -> None
38
-
39
-
let load_from_string ~ttl content =
40
-
let tbl = Hashtbl.create 32 in
41
-
String.split_on_char '\n' content
42
-
|> List.iter (fun line ->
43
-
match parse_line ~ttl line with
44
-
| Some (key, entry) -> Hashtbl.replace tbl key entry
45
-
| None -> ());
46
-
tbl
47
-
48
-
let to_string t =
49
-
let now = t.now () in
50
-
let lines =
51
-
Hashtbl.fold
52
-
(fun key entry acc ->
53
-
if entry.expires > now then
54
-
let ts = entry.expires -. t.ttl in
55
-
Fmt.str "%s %s %.0f" key entry.hash ts :: acc
56
-
else acc)
57
-
t.tbl []
58
-
in
59
-
String.concat "\n" lines ^ "\n"
60
-
61
-
let create ?(ttl = default_ttl) ~now () =
62
-
let tbl = Hashtbl.create 32 in
63
-
{ tbl; ttl; now }
64
-
65
-
let create_from_string ?(ttl = default_ttl) ~now content =
66
-
let tbl = load_from_string ~ttl content in
67
-
{ tbl; ttl; now }
68
-
69
-
let get t ~url ~branch =
70
-
let key = make_key url branch in
71
-
let now = t.now () in
72
-
match Hashtbl.find_opt t.tbl key with
73
-
| Some entry when entry.expires > now ->
74
-
Log.debug (fun m ->
75
-
m "Cache hit for %s (expires in %.0fs)" key (entry.expires -. now));
76
-
Some entry.hash
77
-
| Some entry ->
78
-
Log.debug (fun m ->
79
-
m "Cache expired for %s (%.0fs ago)" key (now -. entry.expires));
80
-
None
81
-
| None ->
82
-
Log.debug (fun m -> m "Cache miss for %s (not found)" key);
83
-
None
84
-
85
-
let set t ~url ~branch ~hash =
86
-
let key = make_key url branch in
87
-
let expires = t.now () +. t.ttl in
88
-
Hashtbl.replace t.tbl key { hash; expires }
89
-
90
-
let size t = Hashtbl.length t.tbl
91
-
let clear t = Hashtbl.clear t.tbl
-76
lib/remote_cache.mli
-76
lib/remote_cache.mli
···
1
-
(* Copyright (c) 2024-2026 Thomas Gazagnaire <thomas@gazagnaire.org>
2
-
3
-
Permission to use, copy, modify, and distribute this software for any
4
-
purpose with or without fee is hereby granted, provided that the above
5
-
copyright notice and this permission notice appear in all copies.
6
-
7
-
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
8
-
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
9
-
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
10
-
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
11
-
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
12
-
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
13
-
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *)
14
-
15
-
(** Remote HEAD cache with O(1) in-memory lookup.
16
-
17
-
This module provides an in-memory cache for remote git HEAD refs with
18
-
time-based expiration. Uses a Hashtbl for O(1) amortized lookup.
19
-
20
-
{2 Example with mock time}
21
-
22
-
{[
23
-
let time = ref 0.0 in
24
-
let now () = !time in
25
-
let cache = Remote_cache.create ~ttl:60.0 ~now () in
26
-
27
-
(* Set a value *)
28
-
let url = Uri.of_string "https://github.com/ocaml/ocaml.git" in
29
-
Remote_cache.set cache ~url ~branch:"trunk" ~hash:"abc123";
30
-
31
-
(* Get it back immediately *)
32
-
assert (Remote_cache.get cache ~url ~branch:"trunk" = Some "abc123");
33
-
34
-
(* Advance time past TTL *)
35
-
time := 61.0;
36
-
assert (Remote_cache.get cache ~url ~branch:"trunk" = None)
37
-
]} *)
38
-
39
-
type t
40
-
(** The cache type. *)
41
-
42
-
val default_ttl : float
43
-
(** Default TTL in seconds (300.0 = 5 minutes). *)
44
-
45
-
val create : ?ttl:float -> now:(unit -> float) -> unit -> t
46
-
(** [create ~ttl ~now ()] creates a new empty cache.
47
-
48
-
@param ttl Time-to-live in seconds (default {!default_ttl})
49
-
@param now Function to get current time in seconds *)
50
-
51
-
val create_from_string : ?ttl:float -> now:(unit -> float) -> string -> t
52
-
(** [create_from_string ~ttl ~now content] creates a cache populated from
53
-
serialized content.
54
-
55
-
@param ttl Time-to-live in seconds (default {!default_ttl})
56
-
@param now Function to get current time in seconds
57
-
@param content Serialized cache content from {!to_string} *)
58
-
59
-
val get : t -> url:Uri.t -> branch:string -> string option
60
-
(** [get t ~url ~branch] returns the cached hash if present and not expired.
61
-
O(1) amortized time complexity. *)
62
-
63
-
val set : t -> url:Uri.t -> branch:string -> hash:string -> unit
64
-
(** [set t ~url ~branch ~hash] adds or updates a cache entry. O(1) amortized
65
-
time complexity. *)
66
-
67
-
val to_string : t -> string
68
-
(** [to_string t] serializes the cache to a string for disk persistence. Format:
69
-
one entry per line "url:branch hash timestamp". Expired entries are not
70
-
included. *)
71
-
72
-
val size : t -> int
73
-
(** [size t] returns the number of entries in the cache. *)
74
-
75
-
val clear : t -> unit
76
-
(** [clear t] removes all entries from the cache. *)
+240
-361
lib/site.ml
+240
-361
lib/site.ml
···
1
1
(** Generate a static HTML site representing the monoverse map. *)
2
2
3
+
(** Information about a package in the verse *)
3
4
type pkg_info = {
4
5
name : string;
5
6
synopsis : string option;
···
8
9
owners : string list; (** List of handles that have this package *)
9
10
depends : string list; (** Package dependencies *)
10
11
}
11
-
(** Information about a package in the verse *)
12
12
13
+
(** Information about a repository (group of packages) *)
13
14
type repo_info = {
14
15
ri_name : string;
15
16
ri_dev_repo : string;
16
17
ri_packages : pkg_info list;
17
-
ri_owners : string list;
18
-
(** All handles that have any package from this repo *)
19
-
ri_fork_status : (string * Forks.relationship) list;
20
-
(** (handle, relationship) *)
18
+
ri_owners : string list; (** All handles that have any package from this repo *)
19
+
ri_fork_status : (string * Forks.relationship) list; (** (handle, relationship) *)
21
20
ri_dep_count : int; (** Number of dependencies (for sorting) *)
22
21
}
23
-
(** Information about a repository (group of packages) *)
24
22
23
+
(** Information about a verse member *)
25
24
type member_info = {
26
25
handle : string;
27
26
display_name : string; (** Name to display (from registry or handle) *)
···
30
29
package_count : int;
31
30
unique_packages : string list; (** Packages unique to this member *)
32
31
}
33
-
(** Information about a verse member *)
34
32
33
+
(** Aggregated site data *)
35
34
type site_data = {
36
35
local_handle : string;
37
36
registry_name : string;
···
41
40
unique_repos : repo_info list; (** Repos unique to one member *)
42
41
all_packages : pkg_info list; (** All packages *)
43
42
}
44
-
(** Aggregated site data *)
45
43
46
44
(** Scan a member's opam repo and return package info *)
47
45
let scan_member_packages ~fs opam_repo_path =
48
46
let pkgs, _errors = Opam_repo.scan_all ~fs opam_repo_path in
49
-
List.map
50
-
(fun pkg ->
51
-
{
52
-
name = Package.name pkg;
53
-
synopsis = Package.synopsis pkg;
54
-
repo_name = Package.repo_name pkg;
55
-
dev_repo = Uri.to_string (Package.dev_repo pkg);
56
-
owners = [];
57
-
depends = Package.depends pkg;
58
-
})
59
-
pkgs
47
+
List.map (fun pkg ->
48
+
{
49
+
name = Package.name pkg;
50
+
synopsis = Package.synopsis pkg;
51
+
repo_name = Package.repo_name pkg;
52
+
dev_repo = Uri.to_string (Package.dev_repo pkg);
53
+
owners = [];
54
+
depends = Package.depends pkg;
55
+
}
56
+
) pkgs
60
57
61
58
(** Check if a directory exists *)
62
59
let dir_exists ~fs path =
···
80
77
in
81
78
82
79
(* Build a map: package name -> list of (handle, pkg_info) *)
83
-
let pkg_map : (string, (string * pkg_info) list) Hashtbl.t =
84
-
Hashtbl.create 256
85
-
in
80
+
let pkg_map : (string, (string * pkg_info) list) Hashtbl.t = Hashtbl.create 256 in
86
81
87
82
(* Add local packages *)
88
-
List.iter
89
-
(fun pkg ->
90
-
let existing = try Hashtbl.find pkg_map pkg.name with Not_found -> [] in
91
-
Hashtbl.replace pkg_map pkg.name ((local_handle, pkg) :: existing))
92
-
local_pkgs;
83
+
List.iter (fun pkg ->
84
+
let existing = try Hashtbl.find pkg_map pkg.name with Not_found -> [] in
85
+
Hashtbl.replace pkg_map pkg.name ((local_handle, pkg) :: existing)
86
+
) local_pkgs;
93
87
94
88
let registry_name = registry.Verse_registry.name in
95
89
let registry_description = registry.Verse_registry.description in
96
90
97
91
(* Build handle -> display name lookup *)
98
92
let handle_to_name = Hashtbl.create 16 in
99
-
List.iter
100
-
(fun (m : Verse_registry.member) ->
101
-
let display = match m.name with Some n -> n | None -> m.handle in
102
-
Hashtbl.replace handle_to_name m.handle display)
103
-
registry.Verse_registry.members;
93
+
List.iter (fun (m : Verse_registry.member) ->
94
+
let display = match m.name with Some n -> n | None -> m.handle in
95
+
Hashtbl.replace handle_to_name m.handle display
96
+
) registry.Verse_registry.members;
104
97
105
98
(* Get tracked handles from verse directory, excluding local handle *)
106
99
let tracked_handles =
···
109
102
try
110
103
Eio.Path.read_dir eio_path
111
104
|> List.filter (fun name ->
112
-
(not (String.ends_with ~suffix:"-opam" name))
113
-
&& name <> local_handle
114
-
&& dir_exists ~fs Fpath.(verse_path / name))
105
+
not (String.ends_with ~suffix:"-opam" name) &&
106
+
name <> local_handle &&
107
+
dir_exists ~fs Fpath.(verse_path / name))
115
108
with Eio.Io _ -> []
116
109
else []
117
110
in
118
111
119
112
(* Scan each tracked member's opam repo *)
120
113
let member_infos =
121
-
List.filter_map
122
-
(fun handle ->
123
-
let opam_path = Fpath.(verse_path / (handle ^ "-opam")) in
124
-
if dir_exists ~fs opam_path then begin
125
-
let pkgs = scan_member_packages ~fs opam_path in
126
-
(* Add to package map *)
127
-
List.iter
128
-
(fun pkg ->
129
-
let existing =
130
-
try Hashtbl.find pkg_map pkg.name with Not_found -> []
131
-
in
132
-
Hashtbl.replace pkg_map pkg.name ((handle, pkg) :: existing))
133
-
pkgs;
134
-
(* Look up member in registry for URLs *)
135
-
let member = Verse_registry.find_member registry ~handle in
136
-
let display_name =
137
-
try Hashtbl.find handle_to_name handle with Not_found -> handle
138
-
in
139
-
Some
140
-
{
141
-
handle;
142
-
display_name;
143
-
monorepo_url =
144
-
(match member with Some m -> m.monorepo | None -> "");
145
-
opam_url = (match member with Some m -> m.opamrepo | None -> "");
146
-
package_count = List.length pkgs;
147
-
unique_packages = [];
148
-
(* Will be filled in later *)
149
-
}
150
-
end
151
-
else None)
152
-
tracked_handles
114
+
List.filter_map (fun handle ->
115
+
let opam_path = Fpath.(verse_path / (handle ^ "-opam")) in
116
+
if dir_exists ~fs opam_path then begin
117
+
let pkgs = scan_member_packages ~fs opam_path in
118
+
(* Add to package map *)
119
+
List.iter (fun pkg ->
120
+
let existing = try Hashtbl.find pkg_map pkg.name with Not_found -> [] in
121
+
Hashtbl.replace pkg_map pkg.name ((handle, pkg) :: existing)
122
+
) pkgs;
123
+
(* Look up member in registry for URLs *)
124
+
let member = Verse_registry.find_member registry ~handle in
125
+
let display_name =
126
+
try Hashtbl.find handle_to_name handle
127
+
with Not_found -> handle
128
+
in
129
+
Some {
130
+
handle;
131
+
display_name;
132
+
monorepo_url = (match member with Some m -> m.monorepo | None -> "");
133
+
opam_url = (match member with Some m -> m.opamrepo | None -> "");
134
+
package_count = List.length pkgs;
135
+
unique_packages = []; (* Will be filled in later *)
136
+
}
137
+
end else None
138
+
) tracked_handles
153
139
in
154
140
155
141
(* Add local member info *)
···
171
157
172
158
(* Build final package list with owners *)
173
159
let all_packages =
174
-
Hashtbl.fold
175
-
(fun _name entries acc ->
176
-
match entries with
177
-
| [] -> acc
178
-
| (_, pkg) :: _ as all ->
179
-
let owners = List.map fst all in
180
-
(* Pick the best synopsis (first non-None) *)
181
-
let synopsis = List.find_map (fun (_, p) -> p.synopsis) all in
182
-
(* Merge depends from all sources *)
183
-
let depends =
184
-
List.concat_map (fun (_, p) -> p.depends) all
185
-
|> List.sort_uniq String.compare
186
-
in
187
-
{ pkg with owners; synopsis; depends } :: acc)
188
-
pkg_map []
160
+
Hashtbl.fold (fun _name entries acc ->
161
+
match entries with
162
+
| [] -> acc
163
+
| (_, pkg) :: _ as all ->
164
+
let owners = List.map fst all in
165
+
(* Pick the best synopsis (first non-None) *)
166
+
let synopsis =
167
+
List.find_map (fun (_, p) -> p.synopsis) all
168
+
in
169
+
(* Merge depends from all sources *)
170
+
let depends =
171
+
List.concat_map (fun (_, p) -> p.depends) all
172
+
|> List.sort_uniq String.compare
173
+
in
174
+
{ pkg with owners; synopsis; depends } :: acc
175
+
) pkg_map []
189
176
|> List.sort (fun a b -> String.compare a.name b.name)
190
177
in
191
178
192
179
(* Build set of all package names for dependency counting *)
193
180
let all_pkg_names =
194
-
List.fold_left
195
-
(fun s p ->
196
-
Hashtbl.replace s p.name ();
197
-
s)
181
+
List.fold_left (fun s p -> Hashtbl.replace s p.name (); s)
198
182
(Hashtbl.create 256) all_packages
199
183
in
200
184
201
185
(* Group packages by repo *)
202
186
let repos_map : (string, pkg_info list) Hashtbl.t = Hashtbl.create 64 in
203
-
List.iter
204
-
(fun (pkg : pkg_info) ->
205
-
let existing =
206
-
try Hashtbl.find repos_map pkg.repo_name with Not_found -> []
207
-
in
208
-
Hashtbl.replace repos_map pkg.repo_name (pkg :: existing))
209
-
all_packages;
187
+
List.iter (fun (pkg : pkg_info) ->
188
+
let existing = try Hashtbl.find repos_map pkg.repo_name with Not_found -> [] in
189
+
Hashtbl.replace repos_map pkg.repo_name (pkg :: existing)
190
+
) all_packages;
210
191
211
192
(* Build forks status lookup from forks data if provided *)
212
-
let forks_by_repo : (string, (string * Forks.relationship) list) Hashtbl.t =
213
-
Hashtbl.create 64
214
-
in
193
+
let forks_by_repo : (string, (string * Forks.relationship) list) Hashtbl.t = Hashtbl.create 64 in
215
194
(match forks with
216
-
| Some f ->
217
-
List.iter
218
-
(fun (ra : Forks.repo_analysis) ->
219
-
let statuses =
220
-
List.map (fun (h, _src, rel) -> (h, rel)) ra.verse_sources
221
-
in
222
-
Hashtbl.replace forks_by_repo ra.repo_name statuses)
223
-
f.Forks.repos
224
-
| None -> ());
195
+
| Some f ->
196
+
List.iter (fun (ra : Forks.repo_analysis) ->
197
+
let statuses = List.map (fun (h, _src, rel) -> (h, rel)) ra.verse_sources in
198
+
Hashtbl.replace forks_by_repo ra.repo_name statuses
199
+
) f.Forks.repos
200
+
| None -> ());
225
201
226
202
(* Build repo_info list with dependency counts *)
227
203
let all_repos =
228
-
Hashtbl.fold
229
-
(fun repo_name pkgs acc ->
230
-
let dev_repo = (List.hd pkgs).dev_repo in
231
-
let owners =
232
-
List.sort_uniq String.compare
233
-
(List.concat_map (fun (p : pkg_info) -> p.owners) pkgs)
234
-
in
235
-
let fork_status =
236
-
try Hashtbl.find forks_by_repo repo_name with Not_found -> []
237
-
in
238
-
(* Count dependencies that are in our package set *)
239
-
let dep_count =
240
-
List.concat_map (fun (p : pkg_info) -> p.depends) pkgs
241
-
|> List.filter (fun d -> Hashtbl.mem all_pkg_names d)
242
-
|> List.sort_uniq String.compare
243
-
|> List.length
244
-
in
245
-
{
246
-
ri_name = repo_name;
247
-
ri_dev_repo = dev_repo;
248
-
ri_packages = List.sort (fun a b -> String.compare a.name b.name) pkgs;
249
-
ri_owners = owners;
250
-
ri_fork_status = fork_status;
251
-
ri_dep_count = dep_count;
252
-
}
253
-
:: acc)
254
-
repos_map []
204
+
Hashtbl.fold (fun repo_name pkgs acc ->
205
+
let dev_repo = (List.hd pkgs).dev_repo in
206
+
let owners =
207
+
List.sort_uniq String.compare (List.concat_map (fun (p : pkg_info) -> p.owners) pkgs)
208
+
in
209
+
let fork_status =
210
+
try Hashtbl.find forks_by_repo repo_name with Not_found -> []
211
+
in
212
+
(* Count dependencies that are in our package set *)
213
+
let dep_count =
214
+
List.concat_map (fun (p : pkg_info) -> p.depends) pkgs
215
+
|> List.filter (fun d -> Hashtbl.mem all_pkg_names d)
216
+
|> List.sort_uniq String.compare
217
+
|> List.length
218
+
in
219
+
{ ri_name = repo_name;
220
+
ri_dev_repo = dev_repo;
221
+
ri_packages = List.sort (fun a b -> String.compare a.name b.name) pkgs;
222
+
ri_owners = owners;
223
+
ri_fork_status = fork_status;
224
+
ri_dep_count = dep_count } :: acc
225
+
) repos_map []
255
226
(* Sort by dependency count descending (apps with most deps first), then by name *)
256
227
|> List.sort (fun a b ->
257
228
let cmp = compare b.ri_dep_count a.ri_dep_count in
···
259
230
in
260
231
261
232
(* Separate common and unique repos *)
262
-
let common_repos =
263
-
List.filter (fun r -> List.length r.ri_owners > 1) all_repos
264
-
in
265
-
let unique_repos =
266
-
List.filter (fun r -> List.length r.ri_owners = 1) all_repos
267
-
in
233
+
let common_repos = List.filter (fun r -> List.length r.ri_owners > 1) all_repos in
234
+
let unique_repos = List.filter (fun r -> List.length r.ri_owners = 1) all_repos in
268
235
269
236
(* Compute unique packages per member *)
270
237
let unique_by_handle = Hashtbl.create 32 in
271
-
List.iter
272
-
(fun (pkg : pkg_info) ->
273
-
if List.length pkg.owners = 1 then begin
274
-
let handle = List.hd pkg.owners in
275
-
let existing =
276
-
try Hashtbl.find unique_by_handle handle with Not_found -> []
277
-
in
278
-
Hashtbl.replace unique_by_handle handle (pkg.name :: existing)
279
-
end)
280
-
all_packages;
238
+
List.iter (fun (pkg : pkg_info) ->
239
+
if List.length pkg.owners = 1 then begin
240
+
let handle = List.hd pkg.owners in
241
+
let existing = try Hashtbl.find unique_by_handle handle with Not_found -> [] in
242
+
Hashtbl.replace unique_by_handle handle (pkg.name :: existing)
243
+
end
244
+
) all_packages;
281
245
282
246
(* Update member infos with unique packages *)
283
247
let update_member m =
284
-
let unique =
285
-
try Hashtbl.find unique_by_handle m.handle with Not_found -> []
286
-
in
248
+
let unique = try Hashtbl.find unique_by_handle m.handle with Not_found -> [] in
287
249
{ m with unique_packages = List.sort String.compare unique }
288
250
in
289
251
290
252
let all_members = local_member :: member_infos in
291
253
let members = List.map update_member all_members in
292
254
293
-
{
294
-
local_handle;
295
-
registry_name;
296
-
registry_description;
297
-
members;
298
-
common_repos;
299
-
unique_repos;
300
-
all_packages;
301
-
}
255
+
{ local_handle; registry_name; registry_description; members; common_repos; unique_repos; all_packages }
302
256
303
257
(** Escape HTML special characters *)
304
258
let html_escape s =
305
259
let buf = Buffer.create (String.length s) in
306
-
String.iter
307
-
(function
308
-
| '<' -> Buffer.add_string buf "<"
309
-
| '>' -> Buffer.add_string buf ">"
310
-
| '&' -> Buffer.add_string buf "&"
311
-
| '"' -> Buffer.add_string buf """
312
-
| c -> Buffer.add_char buf c)
313
-
s;
260
+
String.iter (function
261
+
| '<' -> Buffer.add_string buf "<"
262
+
| '>' -> Buffer.add_string buf ">"
263
+
| '&' -> Buffer.add_string buf "&"
264
+
| '"' -> Buffer.add_string buf """
265
+
| c -> Buffer.add_char buf c
266
+
) s;
314
267
Buffer.contents buf
315
268
316
269
(** External link SVG icon *)
···
323
276
| Forks.Same_commit -> "sync"
324
277
| Forks.I_am_ahead n -> Printf.sprintf "+%d" n
325
278
| Forks.I_am_behind n -> Printf.sprintf "-%d" n
326
-
| Forks.Diverged { my_ahead; their_ahead; _ } ->
327
-
Printf.sprintf "+%d/-%d" my_ahead their_ahead
279
+
| Forks.Diverged { my_ahead; their_ahead; _ } -> Printf.sprintf "+%d/-%d" my_ahead their_ahead
328
280
| Forks.Unrelated -> "unrel"
329
281
| Forks.Not_fetched -> "?"
330
282
···
336
288
(* Build member lookups *)
337
289
let member_urls = Hashtbl.create 16 in
338
290
let member_names = Hashtbl.create 16 in
339
-
List.iter
340
-
(fun m ->
341
-
Hashtbl.replace member_urls m.handle (m.monorepo_url, m.opam_url);
342
-
Hashtbl.replace member_names m.handle m.display_name)
343
-
data.members;
291
+
List.iter (fun m ->
292
+
Hashtbl.replace member_urls m.handle (m.monorepo_url, m.opam_url);
293
+
Hashtbl.replace member_names m.handle m.display_name
294
+
) data.members;
344
295
345
296
(* Helper to get display name for handle *)
346
297
let get_name handle =
347
298
try Hashtbl.find member_names handle with Not_found -> handle
348
299
in
349
300
350
-
add
351
-
{|<!DOCTYPE html>
301
+
add {|<!DOCTYPE html>
352
302
<html lang="en">
353
303
<head>
354
304
<meta charset="UTF-8">
355
305
<meta name="viewport" content="width=device-width, initial-scale=1.0">
356
306
<title>|};
357
307
add (html_escape data.registry_name);
358
-
add
359
-
{|</title>
308
+
add {|</title>
360
309
<style>
361
310
* { margin: 0; padding: 0; box-sizing: border-box; }
362
311
body { font: 10pt/1.4 -apple-system, BlinkMacSystemFont, "Segoe UI", Roboto, sans-serif; color: #333; max-width: 900px; margin: 0 auto; padding: 12px; }
···
416
365
(* Title and description *)
417
366
add (Printf.sprintf "<h1>%s</h1>\n" (html_escape data.registry_name));
418
367
(match data.registry_description with
419
-
| Some desc ->
420
-
add
421
-
(Printf.sprintf "<div class=\"subtitle\">%s</div>\n" (html_escape desc))
422
-
| None -> add "<div class=\"subtitle\"></div>\n");
368
+
| Some desc -> add (Printf.sprintf "<div class=\"subtitle\">%s</div>\n" (html_escape desc))
369
+
| None -> add "<div class=\"subtitle\"></div>\n");
423
370
424
371
(* Intro section *)
425
-
add
426
-
{|<div class="intro">
372
+
add {|<div class="intro">
427
373
This is an experiment in large-scale agentic coding using OCaml and OxCaml, where we're building environments to exchange vibe code at scale.
428
-
Managed by <a class="ext" href="https://tangled.org/anil.recoil.org/monopam">monopam|};
429
-
add external_link_icon;
430
-
add
431
-
{|</a>,
432
-
with the central registry at <a class="ext" href="https://tangled.org/eeg.cl.cam.ac.uk/opamverse">opamverse|};
433
-
add external_link_icon;
434
-
add {|</a>.
374
+
Managed by <a class="ext" href="https://tangled.org/anil.recoil.org/monopam">monopam|}; add external_link_icon; add {|</a>,
375
+
with the central registry at <a class="ext" href="https://tangled.org/eeg.cl.cam.ac.uk/opamverse">opamverse|}; add external_link_icon; add {|</a>.
435
376
</div>
436
377
|};
437
378
438
379
(* Members section *)
439
380
add "<div class=\"section\">\n<h2>Members</h2>\n<div class=\"members\">\n";
440
-
List.iter
441
-
(fun m ->
442
-
add "<div class=\"member\">\n";
443
-
add
444
-
(Printf.sprintf
445
-
"<div class=\"member-name\"><a href=\"https://%s\">%s</a></div>\n"
446
-
(html_escape m.handle)
447
-
(html_escape m.display_name));
448
-
if m.display_name <> m.handle then
449
-
add
450
-
(Printf.sprintf "<div class=\"member-handle\">%s</div>\n"
451
-
(html_escape m.handle));
452
-
add
453
-
(Printf.sprintf "<div class=\"member-stats\">%d packages"
454
-
m.package_count);
455
-
if m.unique_packages <> [] then
456
-
add (Printf.sprintf ", %d unique" (List.length m.unique_packages));
457
-
add "</div>\n";
458
-
if m.monorepo_url <> "" || m.opam_url <> "" then begin
459
-
add "<div class=\"member-links\">";
460
-
if m.monorepo_url <> "" then
461
-
add
462
-
(Printf.sprintf "<a class=\"ext\" href=\"%s\">mono%s</a>"
463
-
(html_escape m.monorepo_url)
464
-
external_link_icon);
465
-
if m.opam_url <> "" then
466
-
add
467
-
(Printf.sprintf "<a class=\"ext\" href=\"%s\">opam%s</a>"
468
-
(html_escape m.opam_url) external_link_icon);
469
-
add "</div>\n"
470
-
end;
471
-
add "</div>\n")
472
-
data.members;
381
+
List.iter (fun m ->
382
+
add "<div class=\"member\">\n";
383
+
add (Printf.sprintf "<div class=\"member-name\"><a href=\"https://%s\">%s</a></div>\n"
384
+
(html_escape m.handle) (html_escape m.display_name));
385
+
if m.display_name <> m.handle then
386
+
add (Printf.sprintf "<div class=\"member-handle\">%s</div>\n" (html_escape m.handle));
387
+
add (Printf.sprintf "<div class=\"member-stats\">%d packages" m.package_count);
388
+
if m.unique_packages <> [] then
389
+
add (Printf.sprintf ", %d unique" (List.length m.unique_packages));
390
+
add "</div>\n";
391
+
if m.monorepo_url <> "" || m.opam_url <> "" then begin
392
+
add "<div class=\"member-links\">";
393
+
if m.monorepo_url <> "" then
394
+
add (Printf.sprintf "<a class=\"ext\" href=\"%s\">mono%s</a>" (html_escape m.monorepo_url) external_link_icon);
395
+
if m.opam_url <> "" then
396
+
add (Printf.sprintf "<a class=\"ext\" href=\"%s\">opam%s</a>" (html_escape m.opam_url) external_link_icon);
397
+
add "</div>\n"
398
+
end;
399
+
add "</div>\n"
400
+
) data.members;
473
401
add "</div>\n</div>\n";
474
402
475
403
(* Summary section *)
476
404
add "<div class=\"section\">\n";
477
405
add "<div class=\"summary\">\n";
478
-
add
479
-
(Printf.sprintf
480
-
"<div class=\"summary-title\">Common Libraries (%d repos, %d \
481
-
packages)</div>\n"
482
-
(List.length data.common_repos)
483
-
(List.fold_left
484
-
(fun acc r -> acc + List.length r.ri_packages)
485
-
0 data.common_repos));
406
+
add (Printf.sprintf "<div class=\"summary-title\">Common Libraries (%d repos, %d packages)</div>\n"
407
+
(List.length data.common_repos)
408
+
(List.fold_left (fun acc r -> acc + List.length r.ri_packages) 0 data.common_repos));
486
409
add "<div class=\"summary-list\">\n";
487
-
List.iter
488
-
(fun r ->
489
-
add
490
-
(Printf.sprintf
491
-
"<span class=\"summary-item\"><a href=\"#%s\">%s</a> <span \
492
-
style=\"color:#888\">(%d)</span></span>\n"
493
-
(html_escape r.ri_name) (html_escape r.ri_name)
494
-
(List.length r.ri_packages)))
495
-
data.common_repos;
410
+
List.iter (fun r ->
411
+
add (Printf.sprintf "<span class=\"summary-item\"><a href=\"#%s\">%s</a> <span style=\"color:#888\">(%d)</span></span>\n"
412
+
(html_escape r.ri_name) (html_escape r.ri_name) (List.length r.ri_packages))
413
+
) data.common_repos;
496
414
add "</div>\n</div>\n";
497
415
498
416
(* Member-specific summary *)
499
-
let members_with_unique =
500
-
List.filter (fun m -> m.unique_packages <> []) data.members
501
-
in
417
+
let members_with_unique = List.filter (fun m -> m.unique_packages <> []) data.members in
502
418
if members_with_unique <> [] then begin
503
419
add "<div class=\"summary\">\n";
504
420
add "<div class=\"summary-title\">Member-Specific Packages</div>\n";
505
421
add "<div class=\"unique-section\">\n";
506
-
List.iter
507
-
(fun m ->
508
-
add "<div class=\"unique-member\">\n";
509
-
add
510
-
(Printf.sprintf
511
-
"<span class=\"unique-member-name\"><a \
512
-
href=\"https://%s\">%s</a>:</span> "
513
-
(html_escape m.handle)
514
-
(html_escape m.display_name));
515
-
add "<span class=\"unique-list\">";
516
-
add (String.concat ", " (List.map html_escape m.unique_packages));
517
-
add "</span>\n";
518
-
add "</div>\n")
519
-
members_with_unique;
422
+
List.iter (fun m ->
423
+
add "<div class=\"unique-member\">\n";
424
+
add (Printf.sprintf "<span class=\"unique-member-name\"><a href=\"https://%s\">%s</a>:</span> "
425
+
(html_escape m.handle) (html_escape m.display_name));
426
+
add "<span class=\"unique-list\">";
427
+
add (String.concat ", " (List.map html_escape m.unique_packages));
428
+
add "</span>\n";
429
+
add "</div>\n"
430
+
) members_with_unique;
520
431
add "</div>\n</div>\n"
521
432
end;
522
433
add "</div>\n";
···
525
436
if data.common_repos <> [] then begin
526
437
add "<div class=\"section\">\n<h2>Repository Details</h2>\n";
527
438
528
-
List.iter
529
-
(fun r ->
530
-
add
531
-
(Printf.sprintf "<div class=\"repo\" id=\"%s\">\n"
532
-
(html_escape r.ri_name));
533
-
add "<div class=\"repo-header\">";
534
-
add
535
-
(Printf.sprintf
536
-
"<span class=\"repo-name\"><a class=\"ext\" \
537
-
href=\"%s\">%s%s</a></span>"
538
-
(html_escape r.ri_dev_repo)
539
-
(html_escape r.ri_name) external_link_icon);
540
-
add "</div>\n";
439
+
List.iter (fun r ->
440
+
add (Printf.sprintf "<div class=\"repo\" id=\"%s\">\n" (html_escape r.ri_name));
441
+
add "<div class=\"repo-header\">";
442
+
add (Printf.sprintf "<span class=\"repo-name\"><a class=\"ext\" href=\"%s\">%s%s</a></span>"
443
+
(html_escape r.ri_dev_repo) (html_escape r.ri_name) external_link_icon);
444
+
add "</div>\n";
541
445
542
-
(* Packages list - compact with names *)
543
-
add "<div class=\"repo-packages\">";
544
-
let pkg_names = List.map (fun (p : pkg_info) -> p.name) r.ri_packages in
545
-
add (String.concat ", " (List.map html_escape pkg_names));
546
-
add "</div>\n";
446
+
(* Packages list - compact with names *)
447
+
add "<div class=\"repo-packages\">";
448
+
let pkg_names = List.map (fun (p : pkg_info) -> p.name) r.ri_packages in
449
+
add (String.concat ", " (List.map html_escape pkg_names));
450
+
add "</div>\n";
547
451
548
-
(* Package descriptions as bullet list *)
549
-
let pkg_descs =
550
-
List.filter_map
551
-
(fun (p : pkg_info) ->
552
-
match p.synopsis with Some s -> Some (p.name, s) | None -> None)
553
-
r.ri_packages
554
-
in
555
-
if pkg_descs <> [] then begin
556
-
add "<ul class=\"pkg-list\">\n";
557
-
List.iter
558
-
(fun (name, desc) ->
559
-
add
560
-
(Printf.sprintf "<li><b>%s</b>: %s</li>\n" (html_escape name)
561
-
(html_escape desc)))
562
-
pkg_descs;
563
-
add "</ul>\n"
564
-
end;
452
+
(* Package descriptions as bullet list *)
453
+
let pkg_descs = List.filter_map (fun (p : pkg_info) ->
454
+
match p.synopsis with
455
+
| Some s -> Some (p.name, s)
456
+
| None -> None
457
+
) r.ri_packages in
458
+
if pkg_descs <> [] then begin
459
+
add "<ul class=\"pkg-list\">\n";
460
+
List.iter (fun (name, desc) ->
461
+
add (Printf.sprintf "<li><b>%s</b>: %s</li>\n" (html_escape name) (html_escape desc))
462
+
) pkg_descs;
463
+
add "</ul>\n"
464
+
end;
565
465
566
-
(* Forks - at repo level with names *)
567
-
if List.length r.ri_owners > 1 then begin
568
-
let owner_links =
569
-
List.map
570
-
(fun h ->
571
-
Printf.sprintf "<a href=\"https://%s\">%s</a>" (html_escape h)
572
-
(html_escape (get_name h)))
573
-
(List.sort String.compare r.ri_owners)
466
+
(* Forks - at repo level with names *)
467
+
if List.length r.ri_owners > 1 then begin
468
+
let owner_links = List.map (fun h ->
469
+
Printf.sprintf "<a href=\"https://%s\">%s</a>" (html_escape h) (html_escape (get_name h))
470
+
) (List.sort String.compare r.ri_owners) in
471
+
add "<details class=\"repo-forks\">\n";
472
+
add (Printf.sprintf "<summary>%d members (%s)</summary>\n"
473
+
(List.length r.ri_owners)
474
+
(String.concat ", " owner_links));
475
+
add "<div class=\"fork-list\">\n";
476
+
List.iter (fun handle ->
477
+
let mono_url, _opam_url =
478
+
try Hashtbl.find member_urls handle
479
+
with Not_found -> ("", "")
574
480
in
575
-
add "<details class=\"repo-forks\">\n";
576
-
add
577
-
(Printf.sprintf "<summary>%d members (%s)</summary>\n"
578
-
(List.length r.ri_owners)
579
-
(String.concat ", " owner_links));
580
-
add "<div class=\"fork-list\">\n";
581
-
List.iter
582
-
(fun handle ->
583
-
let mono_url, _opam_url =
584
-
try Hashtbl.find member_urls handle with Not_found -> ("", "")
585
-
in
586
-
add "<span class=\"fork-item\">";
587
-
add
588
-
(Printf.sprintf "<a href=\"https://%s\">%s</a>"
589
-
(html_escape handle)
590
-
(html_escape (get_name handle)));
591
-
(* Add status if available *)
592
-
(match List.assoc_opt handle r.ri_fork_status with
593
-
| Some rel ->
594
-
let status_str = format_relationship rel in
595
-
let status_class =
596
-
match rel with
597
-
| Forks.Same_url | Forks.Same_commit -> "sync"
598
-
| Forks.I_am_ahead _ -> "ahead"
599
-
| Forks.I_am_behind _ -> "behind"
600
-
| Forks.Diverged _ -> "diverged"
601
-
| _ -> ""
602
-
in
603
-
if status_class <> "" then
604
-
add
605
-
(Printf.sprintf "<span class=\"fork-status %s\">%s</span>"
606
-
status_class status_str)
607
-
else
608
-
add
609
-
(Printf.sprintf "<span class=\"fork-status\">%s</span>"
610
-
status_str)
611
-
| None -> ());
612
-
if mono_url <> "" then
613
-
add
614
-
(Printf.sprintf "<a class=\"ext\" href=\"%s/%s\">mono%s</a>"
615
-
(html_escape mono_url) (html_escape r.ri_name)
616
-
external_link_icon);
617
-
add "</span>\n")
618
-
(List.sort String.compare r.ri_owners);
619
-
add "</div>\n</details>\n"
620
-
end;
481
+
add "<span class=\"fork-item\">";
482
+
add (Printf.sprintf "<a href=\"https://%s\">%s</a>" (html_escape handle) (html_escape (get_name handle)));
483
+
(* Add status if available *)
484
+
(match List.assoc_opt handle r.ri_fork_status with
485
+
| Some rel ->
486
+
let status_str = format_relationship rel in
487
+
let status_class =
488
+
match rel with
489
+
| Forks.Same_url | Forks.Same_commit -> "sync"
490
+
| Forks.I_am_ahead _ -> "ahead"
491
+
| Forks.I_am_behind _ -> "behind"
492
+
| Forks.Diverged _ -> "diverged"
493
+
| _ -> ""
494
+
in
495
+
if status_class <> "" then
496
+
add (Printf.sprintf "<span class=\"fork-status %s\">%s</span>" status_class status_str)
497
+
else
498
+
add (Printf.sprintf "<span class=\"fork-status\">%s</span>" status_str)
499
+
| None -> ());
500
+
if mono_url <> "" then
501
+
add (Printf.sprintf "<a class=\"ext\" href=\"%s/%s\">mono%s</a>"
502
+
(html_escape mono_url) (html_escape r.ri_name) external_link_icon);
503
+
add "</span>\n"
504
+
) (List.sort String.compare r.ri_owners);
505
+
add "</div>\n</details>\n"
506
+
end;
621
507
622
-
add "</div>\n")
623
-
data.common_repos;
508
+
add "</div>\n"
509
+
) data.common_repos;
624
510
625
511
add "</div>\n"
626
512
end;
···
628
514
(* Footer with generation date *)
629
515
let now = Unix.gettimeofday () in
630
516
let tm = Unix.gmtime now in
631
-
let date_str =
632
-
Printf.sprintf "%04d-%02d-%02d" (tm.Unix.tm_year + 1900)
633
-
(tm.Unix.tm_mon + 1) tm.Unix.tm_mday
634
-
in
635
-
add
636
-
(Printf.sprintf
637
-
"<footer>Generated by monopam on %s | %d members | %d repos | %d \
638
-
packages</footer>\n"
639
-
date_str (List.length data.members)
640
-
(List.length data.common_repos + List.length data.unique_repos)
641
-
(List.length data.all_packages));
517
+
let date_str = Printf.sprintf "%04d-%02d-%02d"
518
+
(tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday in
519
+
add (Printf.sprintf "<footer>Generated by monopam on %s | %d members | %d repos | %d packages</footer>\n"
520
+
date_str (List.length data.members) (List.length data.common_repos + List.length data.unique_repos) (List.length data.all_packages));
642
521
643
522
add "</body>\n</html>\n";
644
523
Buffer.contents buf
+11
-14
lib/site.mli
+11
-14
lib/site.mli
···
7
7
8
8
(** {1 Types} *)
9
9
10
+
(** Information about a package in the verse *)
10
11
type pkg_info = {
11
12
name : string;
12
13
synopsis : string option;
···
15
16
owners : string list; (** List of handles that have this package *)
16
17
depends : string list; (** Package dependencies *)
17
18
}
18
-
(** Information about a package in the verse *)
19
19
20
+
(** Information about a repository (group of packages) *)
20
21
type repo_info = {
21
22
ri_name : string;
22
23
ri_dev_repo : string;
23
24
ri_packages : pkg_info list;
24
-
ri_owners : string list;
25
-
(** All handles that have any package from this repo *)
26
-
ri_fork_status : (string * Forks.relationship) list;
27
-
(** (handle, relationship) *)
25
+
ri_owners : string list; (** All handles that have any package from this repo *)
26
+
ri_fork_status : (string * Forks.relationship) list; (** (handle, relationship) *)
28
27
ri_dep_count : int; (** Number of dependencies (for sorting) *)
29
28
}
30
-
(** Information about a repository (group of packages) *)
31
29
30
+
(** Information about a verse member *)
32
31
type member_info = {
33
32
handle : string;
34
33
display_name : string; (** Name to display (from registry or handle) *)
···
37
36
package_count : int;
38
37
unique_packages : string list; (** Packages unique to this member *)
39
38
}
40
-
(** Information about a verse member *)
41
39
40
+
(** Aggregated site data *)
42
41
type site_data = {
43
42
local_handle : string;
44
43
registry_name : string;
···
48
47
unique_repos : repo_info list; (** Repos unique to one member *)
49
48
all_packages : pkg_info list; (** All packages *)
50
49
}
51
-
(** Aggregated site data *)
52
50
53
51
(** {1 Generation} *)
54
52
···
59
57
registry:Verse_registry.t ->
60
58
unit ->
61
59
site_data
62
-
(** [collect_data ~fs ~config ?forks ~registry ()] scans the workspace and verse
63
-
members to collect package information for the site. If [forks] is provided,
60
+
(** [collect_data ~fs ~config ?forks ~registry ()] scans the workspace and verse members
61
+
to collect package information for the site. If [forks] is provided,
64
62
includes fork status information for each repository. *)
65
63
66
64
val generate :
···
70
68
registry:Verse_registry.t ->
71
69
unit ->
72
70
string
73
-
(** [generate ~fs ~config ?forks ~registry ()] generates the HTML content for
74
-
the site. *)
71
+
(** [generate ~fs ~config ?forks ~registry ()] generates the HTML content for the site. *)
75
72
76
73
val write :
77
74
fs:Eio.Fs.dir_ty Eio.Path.t ->
···
81
78
output_path:Fpath.t ->
82
79
unit ->
83
80
(unit, string) result
84
-
(** [write ~fs ~config ?forks ~registry ~output_path ()] generates and writes
85
-
the site to the specified output path. *)
81
+
(** [write ~fs ~config ?forks ~registry ~output_path ()] generates and writes the site
82
+
to the specified output path. *)
+27
-23
lib/sources_registry.ml
+27
-23
lib/sources_registry.ml
···
10
10
origin : origin option;
11
11
}
12
12
13
-
type t = { default_url_base : string option; entries : (string * entry) list }
13
+
type t = {
14
+
default_url_base : string option;
15
+
entries : (string * entry) list;
16
+
}
14
17
15
18
let empty = { default_url_base = None; entries = [] }
19
+
16
20
let default_url_base t = t.default_url_base
17
-
let with_default_url_base t base = { t with default_url_base = Some base }
21
+
22
+
let with_default_url_base t base =
23
+
{ t with default_url_base = Some base }
24
+
18
25
let find t ~subtree = List.assoc_opt subtree t.entries
19
26
20
27
let derive_url t ~subtree =
···
22
29
| Some entry -> Some entry.url
23
30
| None ->
24
31
(* Use default_url_base to construct URL from subtree name *)
25
-
Option.map
26
-
(fun base ->
27
-
let base =
28
-
if String.ends_with ~suffix:"/" base then
29
-
String.sub base 0 (String.length base - 1)
30
-
else base
31
-
in
32
-
base ^ "/" ^ subtree)
33
-
t.default_url_base
32
+
Option.map (fun base ->
33
+
let base =
34
+
if String.ends_with ~suffix:"/" base then
35
+
String.sub base 0 (String.length base - 1)
36
+
else base
37
+
in
38
+
base ^ "/" ^ subtree
39
+
) t.default_url_base
34
40
35
41
let add t ~subtree entry =
36
42
{ t with entries = (subtree, entry) :: List.remove_assoc subtree t.entries }
37
43
38
-
let remove t ~subtree = { t with entries = List.remove_assoc subtree t.entries }
44
+
let remove t ~subtree =
45
+
{ t with entries = List.remove_assoc subtree t.entries }
46
+
39
47
let to_list t = t.entries
48
+
40
49
let of_list entries = { default_url_base = None; entries }
41
50
42
51
(* TOML structure:
···
57
66
~dec:(function
58
67
| "fork" -> Fork
59
68
| "join" -> Join
60
-
| s ->
61
-
failwith
62
-
(Printf.sprintf "Invalid origin: %s (expected 'fork' or 'join')" s))
69
+
| s -> failwith (Printf.sprintf "Invalid origin: %s (expected 'fork' or 'join')" s))
63
70
~enc:(function Fork -> "fork" | Join -> "join")
64
71
Tomlt.string
65
72
66
73
let entry_codec : entry Tomlt.t =
67
74
Tomlt.(
68
75
Table.(
69
-
obj (fun url upstream branch reason origin ->
70
-
{ url; upstream; branch; reason; origin })
76
+
obj (fun url upstream branch reason origin -> { url; upstream; branch; reason; origin })
71
77
|> mem "url" string ~enc:(fun e -> e.url)
72
78
|> opt_mem "upstream" string ~enc:(fun e -> e.upstream)
73
79
|> opt_mem "branch" string ~enc:(fun e -> e.branch)
···
78
84
let codec : t Tomlt.t =
79
85
Tomlt.(
80
86
Table.(
81
-
obj (fun default_url_base entries -> { default_url_base; entries })
87
+
obj (fun default_url_base entries ->
88
+
{ default_url_base; entries })
82
89
|> opt_mem "default_url_base" string ~enc:(fun t -> t.default_url_base)
83
90
|> keep_unknown ~enc:(fun t -> t.entries) (Mems.assoc entry_codec)
84
91
|> finish))
···
91
98
| `Regular_file -> (
92
99
try Ok (Tomlt_eio.decode_path_exn codec ~fs path_str) with
93
100
| Failure msg -> Error (Printf.sprintf "Invalid sources.toml: %s" msg)
94
-
| exn ->
95
-
Error
96
-
(Printf.sprintf "Error loading sources.toml: %s"
97
-
(Printexc.to_string exn)))
98
-
| _ -> Ok empty (* File doesn't exist, return empty registry *)
101
+
| exn -> Error (Printf.sprintf "Error loading sources.toml: %s" (Printexc.to_string exn)))
102
+
| _ -> Ok empty (* File doesn't exist, return empty registry *)
99
103
| exception _ -> Ok empty
100
104
101
105
let save ~fs path t =
+13
-15
lib/sources_registry.mli
+13
-15
lib/sources_registry.mli
···
1
1
(** Sources registry for tracking forked/vendored package URLs.
2
2
3
-
The sources.toml file in the monorepo root tracks packages where the
4
-
dev-repo URL differs from what's declared in dune-project. This is typically
5
-
used for:
3
+
The sources.toml file in the monorepo root tracks packages where
4
+
the dev-repo URL differs from what's declared in dune-project.
5
+
This is typically used for:
6
6
- Forked packages (our fork URL vs upstream)
7
7
- Vendored packages (local copy, custom URL)
8
8
- Packages without source in dune-project
9
9
10
-
The registry also supports a [default_url_base] field that is used to derive
11
-
URLs for subtrees without explicit entries:
10
+
The registry also supports a [default_url_base] field that is used
11
+
to derive URLs for subtrees without explicit entries:
12
12
{v
13
13
default_url_base = "git+https://tangled.org/anil.recoil.org"
14
14
v}
···
18
18
(** How a source entry was created. *)
19
19
type origin =
20
20
| Fork (** Created via [monopam fork] - subtree split from monorepo *)
21
-
| Join
22
-
(** Created via [monopam join] - external repo brought into monorepo *)
21
+
| Join (** Created via [monopam join] - external repo brought into monorepo *)
23
22
23
+
(** A source entry for a subtree. *)
24
24
type entry = {
25
-
url : string;
26
-
(** Our dev-repo URL (e.g., "git+https://github.com/avsm/braid") *)
25
+
url : string; (** Our dev-repo URL (e.g., "git+https://github.com/avsm/braid") *)
27
26
upstream : string option; (** Original upstream URL if this is a fork *)
28
27
branch : string option; (** Override branch (default: main) *)
29
28
reason : string option; (** Why we have a custom source *)
30
29
origin : origin option; (** How this entry was created *)
31
30
}
32
-
(** A source entry for a subtree. *)
33
31
32
+
(** The sources registry - maps subtree names to source entries. *)
34
33
type t
35
-
(** The sources registry - maps subtree names to source entries. *)
36
34
37
35
val empty : t
38
36
(** Empty registry. *)
···
47
45
(** [find t ~subtree] looks up the source entry for a subtree. *)
48
46
49
47
val derive_url : t -> subtree:string -> string option
50
-
(** [derive_url t ~subtree] derives a URL for a subtree. First checks for an
51
-
explicit entry, then uses default_url_base if set. *)
48
+
(** [derive_url t ~subtree] derives a URL for a subtree.
49
+
First checks for an explicit entry, then uses default_url_base if set. *)
52
50
53
51
val add : t -> subtree:string -> entry -> t
54
52
(** [add t ~subtree entry] adds or replaces an entry. *)
···
63
61
(** [of_list entries] creates a registry from an association list. *)
64
62
65
63
val load : fs:_ Eio.Path.t -> Fpath.t -> (t, string) result
66
-
(** [load ~fs path] loads a sources.toml file. Returns empty registry if file
67
-
doesn't exist. *)
64
+
(** [load ~fs path] loads a sources.toml file. Returns empty registry
65
+
if file doesn't exist. *)
68
66
69
67
val save : fs:_ Eio.Path.t -> Fpath.t -> t -> (unit, string) result
70
68
(** [save ~fs path t] writes the registry to a TOML file. *)
+96
-111
lib/status.ml
+96
-111
lib/status.ml
···
1
-
type ahead_behind = { ahead : int; behind : int }
2
-
type checkout_status = Missing | Not_a_repo | Dirty | Clean of ahead_behind
1
+
type checkout_status =
2
+
| Missing
3
+
| Not_a_repo
4
+
| Dirty
5
+
| Clean of Git.ahead_behind
6
+
3
7
type subtree_status = Not_added | Present
4
8
5
9
(** Sync state between monorepo subtree and local checkout *)
···
23
27
let dir, _ = fs in
24
28
(dir, "")
25
29
26
-
(** Check if a directory exists *)
27
-
let dir_exists fs path =
28
-
let eio_path = Eio.Path.(fs / Fpath.to_string path) in
29
-
match Eio.Path.kind ~follow:true eio_path with
30
-
| `Directory -> true
31
-
| _ -> false
32
-
| exception Eio.Io _ -> false
33
-
34
-
let to_ahead_behind (ab : Git.Repository.ahead_behind) =
35
-
{ ahead = ab.ahead; behind = ab.behind }
36
-
37
-
(** Pre-compute all subtree hashes from mono repo's HEAD *)
38
-
let get_subtree_hashes ~fs ~monorepo =
39
-
let mono_repo = Git.Repository.open_repo ~fs (Fpath.to_string monorepo) in
40
-
match Git.Repository.read_ref mono_repo "HEAD" with
41
-
| None -> Hashtbl.create 0
42
-
| Some commit_hash -> (
43
-
match Git.Repository.read mono_repo commit_hash with
44
-
| Error _ -> Hashtbl.create 0
45
-
| Ok (Git.Value.Commit c) ->
46
-
let root_tree_hash = Git.Commit.tree c in
47
-
let tbl = Hashtbl.create 128 in
48
-
(* Read root tree and cache all subtree hashes *)
49
-
(match Git.Repository.read mono_repo root_tree_hash with
50
-
| Ok (Git.Value.Tree tree) ->
51
-
List.iter
52
-
(fun (e : Git.Tree.entry) ->
53
-
if e.perm = `Dir then Hashtbl.add tbl e.name e.hash)
54
-
(Git.Tree.to_list tree)
55
-
| _ -> ());
56
-
tbl
57
-
| Ok _ -> Hashtbl.create 0)
58
-
59
-
(** Internal: compute status for a single package with pre-computed subtree
60
-
hashes *)
61
-
let compute_one ~fs ~checkouts_root ~monorepo ~subtree_hashes pkg =
30
+
let compute ~proc ~fs ~config pkg =
31
+
let checkouts_root = Config.Paths.checkouts config in
62
32
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
33
+
let monorepo = Config.Paths.monorepo config in
63
34
let prefix = Package.subtree_prefix pkg in
64
-
let checkout_path = Fpath.to_string checkout_dir in
35
+
let fs_t = fs_typed fs in
36
+
let fs_dir =
37
+
let dir, _ = fs in
38
+
(dir, Fpath.to_string checkout_dir)
39
+
in
65
40
let checkout =
66
-
if not (dir_exists fs checkout_dir) then Missing
67
-
else if not (Git.Repository.is_repo ~fs checkout_path) then Not_a_repo
68
-
else
69
-
let repo = Git.Repository.open_repo ~fs checkout_path in
70
-
if Git.Repository.is_dirty repo then Dirty
71
-
else
72
-
let branch =
73
-
match Git.Repository.current_branch repo with
74
-
| Some b -> b
75
-
| None -> "main"
76
-
in
77
-
match Git.Repository.ahead_behind repo ~branch () with
78
-
| Some ab -> Clean (to_ahead_behind ab)
79
-
| None -> Clean { ahead = 0; behind = 0 }
41
+
match Eio.Path.kind ~follow:true fs_dir with
42
+
| exception Eio.Io _ -> Missing
43
+
| `Directory -> (
44
+
if not (Git.is_repo ~proc ~fs:fs_t checkout_dir) then Not_a_repo
45
+
else if Git.is_dirty ~proc ~fs:fs_t checkout_dir then Dirty
46
+
else
47
+
match Git.ahead_behind ~proc ~fs:fs_t checkout_dir with
48
+
| Ok ab -> Clean ab
49
+
| Error _ -> Clean { ahead = 0; behind = 0 })
50
+
| _ -> Missing
80
51
in
81
-
let subtree_dir = Fpath.(monorepo / prefix) in
82
-
let subtree = if dir_exists fs subtree_dir then Present else Not_added in
52
+
let subtree =
53
+
if Git.Subtree.exists ~fs:fs_t ~repo:monorepo ~prefix then Present
54
+
else Not_added
55
+
in
56
+
(* Compute subtree sync state: compare tree content between monorepo subtree and checkout.
57
+
This is more accurate than commit ancestry because it handles both push and pull directions.
58
+
If the trees match, the content is in sync regardless of how it got there. *)
83
59
let subtree_sync =
84
60
match (checkout, subtree) with
85
61
| (Missing | Not_a_repo | Dirty), _ -> Unknown
86
62
| _, Not_added -> Unknown
87
63
| Clean _, Present -> (
88
-
let checkout_repo = Git.Repository.open_repo ~fs checkout_path in
89
-
let subtree_tree = Hashtbl.find_opt subtree_hashes prefix in
64
+
(* Get tree hash of subtree directory in monorepo *)
65
+
let subtree_tree =
66
+
Git.rev_parse ~proc ~fs:fs_t ~rev:("HEAD:" ^ prefix) monorepo
67
+
in
68
+
(* Get tree hash of checkout root *)
90
69
let checkout_tree =
91
-
Git.Repository.tree_hash_at_path checkout_repo ~rev:"HEAD" ~path:""
70
+
Git.rev_parse ~proc ~fs:fs_t ~rev:"HEAD^{tree}" checkout_dir
92
71
in
93
72
match (subtree_tree, checkout_tree) with
94
-
| Some st, Some ct when Git.Hash.equal st ct -> In_sync
95
-
| Some _, Some _ -> Trees_differ
73
+
| Ok st, Ok ct when st = ct -> In_sync
74
+
| Ok _, Ok _ -> (
75
+
(* Trees differ - check commit ancestry to determine direction *)
76
+
let subtree_commit =
77
+
Git.subtree_last_upstream_commit ~proc ~fs:fs_t ~repo:monorepo
78
+
~prefix ()
79
+
in
80
+
let checkout_head = Git.head_commit ~proc ~fs:fs_t checkout_dir in
81
+
match (subtree_commit, checkout_head) with
82
+
| Some subtree_sha, Ok checkout_sha ->
83
+
if
84
+
Git.is_ancestor ~proc ~fs:fs_t ~repo:checkout_dir
85
+
~commit1:subtree_sha ~commit2:checkout_sha ()
86
+
then
87
+
(* Checkout has commits not in subtree - need subtree pull *)
88
+
let count =
89
+
Git.count_commits_between ~proc ~fs:fs_t ~repo:checkout_dir
90
+
~base:subtree_sha ~head:checkout_sha ()
91
+
in
92
+
if count > 0 then Subtree_behind count else Trees_differ
93
+
(* Same commit but trees differ - monorepo has changes *)
94
+
else if
95
+
Git.is_ancestor ~proc ~fs:fs_t ~repo:checkout_dir
96
+
~commit1:checkout_sha ~commit2:subtree_sha ()
97
+
then
98
+
(* Subtree has content not in checkout - need push *)
99
+
let count =
100
+
Git.count_commits_between ~proc ~fs:fs_t ~repo:checkout_dir
101
+
~base:checkout_sha ~head:subtree_sha ()
102
+
in
103
+
if count > 0 then Subtree_ahead count else Trees_differ
104
+
else Trees_differ (* Diverged *)
105
+
| _ -> Trees_differ
106
+
(* Trees differ but can't determine ancestry *))
96
107
| _ -> Unknown)
97
108
in
98
109
{ package = pkg; checkout; subtree; subtree_sync }
99
110
100
-
let compute ~fs ~config pkg =
101
-
let fs_t = fs_typed fs in
102
-
let checkouts_root = Config.Paths.checkouts config in
103
-
let monorepo = Config.Paths.monorepo config in
104
-
let subtree_hashes = get_subtree_hashes ~fs:fs_t ~monorepo in
105
-
compute_one ~fs:fs_t ~checkouts_root ~monorepo ~subtree_hashes pkg
106
-
107
-
let compute_all ~fs ~config packages =
108
-
let fs_t = fs_typed fs in
109
-
let checkouts_root = Config.Paths.checkouts config in
110
-
let monorepo = Config.Paths.monorepo config in
111
-
(* Pre-compute all subtree hashes once *)
112
-
let subtree_hashes = get_subtree_hashes ~fs:fs_t ~monorepo in
113
-
Eio.Fiber.List.map ~max_fibers:8
114
-
(compute_one ~fs:fs_t ~checkouts_root ~monorepo ~subtree_hashes)
115
-
packages
111
+
let compute_all ~proc ~fs ~config packages =
112
+
List.map (compute ~proc ~fs ~config) packages
116
113
117
114
let is_checkout_clean t = match t.checkout with Clean _ -> true | _ -> false
118
115
let has_local_changes t = match t.checkout with Dirty -> true | _ -> false
···
163
160
Fmt.pf ppf "@[<h>%-20s checkout: %a subtree: %a@]" (Package.name t.package)
164
161
pp_checkout_status t.checkout pp_subtree_status t.subtree
165
162
166
-
(** Extract handle from a tangled.org URL like
167
-
"git+https://tangled.org/handle/repo" *)
163
+
(** Extract handle from a tangled.org URL like "git+https://tangled.org/handle/repo" *)
168
164
let extract_handle_from_url url =
169
-
let url =
170
-
if String.starts_with ~prefix:"git+" url then
171
-
String.sub url 4 (String.length url - 4)
172
-
else url
173
-
in
165
+
let url = if String.starts_with ~prefix:"git+" url then
166
+
String.sub url 4 (String.length url - 4)
167
+
else url in
174
168
let uri = Uri.of_string url in
175
169
match Uri.host uri with
176
-
| Some "tangled.org" -> (
170
+
| Some "tangled.org" ->
177
171
let path = Uri.path uri in
178
172
(* Path is like "/handle/repo" - extract first component *)
179
-
let path =
180
-
if String.length path > 0 && path.[0] = '/' then
181
-
String.sub path 1 (String.length path - 1)
182
-
else path
183
-
in
184
-
match String.index_opt path '/' with
185
-
| Some i -> Some (String.sub path 0 i)
186
-
| None -> Some path)
173
+
let path = if String.length path > 0 && path.[0] = '/' then
174
+
String.sub path 1 (String.length path - 1)
175
+
else path in
176
+
(match String.index_opt path '/' with
177
+
| Some i -> Some (String.sub path 0 i)
178
+
| None -> Some path)
187
179
| _ -> None
188
180
189
181
(** Format origin indicator from sources registry entry *)
···
192
184
| None -> ()
193
185
| Some Sources_registry.{ origin = Some Sources_registry.Fork; _ } ->
194
186
Fmt.pf ppf " %a" Fmt.(styled `Magenta string) "^"
195
-
| Some
196
-
Sources_registry.
197
-
{ origin = Some Sources_registry.Join; upstream = Some url; _ } -> (
198
-
match extract_handle_from_url url with
199
-
| Some handle ->
200
-
(* Abbreviate handle - take first part before dot, max 8 chars *)
201
-
let abbrev =
202
-
match String.index_opt handle '.' with
203
-
| Some i -> String.sub handle 0 i
204
-
| None -> handle
205
-
in
206
-
let abbrev =
207
-
if String.length abbrev > 8 then String.sub abbrev 0 8 else abbrev
208
-
in
209
-
Fmt.pf ppf " %a"
210
-
Fmt.(styled `Cyan (fun ppf s -> pf ppf "v:%s" s))
211
-
abbrev
212
-
| None -> Fmt.pf ppf " %a" Fmt.(styled `Cyan string) "v:")
187
+
| Some Sources_registry.{ origin = Some Sources_registry.Join; upstream = Some url; _ } ->
188
+
(match extract_handle_from_url url with
189
+
| Some handle ->
190
+
(* Abbreviate handle - take first part before dot, max 8 chars *)
191
+
let abbrev = match String.index_opt handle '.' with
192
+
| Some i -> String.sub handle 0 i
193
+
| None -> handle
194
+
in
195
+
let abbrev = if String.length abbrev > 8 then String.sub abbrev 0 8 else abbrev in
196
+
Fmt.pf ppf " %a" Fmt.(styled `Cyan (fun ppf s -> pf ppf "v:%s" s)) abbrev
197
+
| None -> Fmt.pf ppf " %a" Fmt.(styled `Cyan string) "v:")
213
198
| Some Sources_registry.{ origin = Some Sources_registry.Join; _ } ->
214
199
Fmt.pf ppf " %a" Fmt.(styled `Cyan string) "v:"
215
200
| Some _ -> ()
···
221
206
let entry = Option.bind sources (fun s -> Sources_registry.find s ~subtree) in
222
207
(* Helper to print remote sync info *)
223
208
let pp_remote ab =
224
-
if ab.ahead > 0 && ab.behind > 0 then
209
+
if ab.Git.ahead > 0 && ab.behind > 0 then
225
210
Fmt.pf ppf " %a"
226
211
Fmt.(styled `Yellow (fun ppf (a, b) -> pf ppf "remote:+%d/-%d" a b))
227
212
(ab.ahead, ab.behind)
+30
-15
lib/status.mli
+30
-15
lib/status.mli
···
1
1
(** Status computation and display.
2
2
3
3
This module computes the synchronization status of packages across the three
4
-
locations: git remote, individual checkout, and monorepo subtree. Uses
5
-
native OCaml git library for fast in-process operations. *)
4
+
locations: git remote, individual checkout, and monorepo subtree. *)
6
5
7
6
(** {1 Types} *)
8
7
9
-
type ahead_behind = { ahead : int; behind : int }
10
-
(** Commits ahead/behind relative to upstream. *)
11
-
12
8
(** Status of an individual checkout relative to its remote. *)
13
9
type checkout_status =
14
10
| Missing (** Checkout directory does not exist *)
15
11
| Not_a_repo (** Directory exists but is not a git repository *)
16
12
| Dirty (** Has uncommitted changes *)
17
-
| Clean of ahead_behind
13
+
| Clean of Git.ahead_behind
18
14
(** Clean with ahead/behind info relative to remote *)
19
15
20
16
(** Status of a subtree in the monorepo. *)
···
44
40
45
41
(** {1 Status Computation} *)
46
42
47
-
val compute : fs:Eio.Fs.dir_ty Eio.Path.t -> config:Config.t -> Package.t -> t
48
-
(** [compute ~fs ~config pkg] computes the status of a single package. *)
43
+
val compute :
44
+
proc:_ Eio.Process.mgr ->
45
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
46
+
config:Config.t ->
47
+
Package.t ->
48
+
t
49
+
(** [compute ~proc ~fs ~config pkg] computes the status of a single package.
50
+
51
+
@param proc Eio process manager
52
+
@param fs Eio filesystem
53
+
@param config Monopam configuration
54
+
@param pkg Package to check *)
49
55
50
56
val compute_all :
51
-
fs:Eio.Fs.dir_ty Eio.Path.t -> config:Config.t -> Package.t list -> t list
52
-
(** [compute_all ~fs ~config packages] computes status for all packages. *)
57
+
proc:_ Eio.Process.mgr ->
58
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
59
+
config:Config.t ->
60
+
Package.t list ->
61
+
t list
62
+
(** [compute_all ~proc ~fs ~config packages] computes status for all packages in
63
+
parallel.
64
+
65
+
@param proc Eio process manager
66
+
@param fs Eio filesystem
67
+
@param config Monopam configuration
68
+
@param packages List of packages to check *)
53
69
54
70
(** {1 Predicates} *)
55
71
···
97
113
(** [pp] formats a single package status. *)
98
114
99
115
val pp_compact : ?sources:Sources_registry.t -> t Fmt.t
100
-
(** [pp_compact ?sources] formats a single package status in compact form with
101
-
colors. If [sources] is provided, displays origin indicators (^ for fork,
102
-
v:handle for join). *)
116
+
(** [pp_compact ?sources] formats a single package status in compact form with colors.
117
+
If [sources] is provided, displays origin indicators (^ for fork, v:handle for join). *)
103
118
104
119
val pp_summary : ?sources:Sources_registry.t -> t list Fmt.t
105
-
(** [pp_summary ?sources] formats a summary of all package statuses. If
106
-
[sources] is provided, displays origin indicators for each package. *)
120
+
(** [pp_summary ?sources] formats a summary of all package statuses.
121
+
If [sources] is provided, displays origin indicators for each package. *)
+64
-119
lib/verse.ml
+64
-119
lib/verse.ml
···
1
1
type error =
2
2
| Config_error of string
3
-
| Git_error of Git_cli.error
3
+
| Git_error of Git.error
4
4
| Registry_error of string
5
5
| Member_not_found of string
6
6
| Workspace_exists of Fpath.t
7
7
| Not_a_workspace of Fpath.t
8
8
| Package_not_found of string * string (** (package, handle) *)
9
-
| Package_already_exists of string list
10
-
(** List of conflicting package names *)
9
+
| Package_already_exists of string list (** List of conflicting package names *)
11
10
| Opam_repo_error of Opam_repo.error
12
11
13
12
let pp_error ppf = function
14
13
| Config_error msg -> Fmt.pf ppf "Configuration error: %s" msg
15
-
| Git_error e -> Fmt.pf ppf "Git error: %a" Git_cli.pp_error e
14
+
| Git_error e -> Fmt.pf ppf "Git error: %a" Git.pp_error e
16
15
| Registry_error msg -> Fmt.pf ppf "Registry error: %s" msg
17
16
| Member_not_found h -> Fmt.pf ppf "Member not in registry: %s" h
18
17
| Workspace_exists p -> Fmt.pf ppf "Workspace already exists: %a" Fpath.pp p
···
21
20
Fmt.pf ppf "Package %s not found in %s's opam repo" pkg handle
22
21
| Package_already_exists pkgs ->
23
22
Fmt.pf ppf "Packages already exist in your opam repo: %a"
24
-
Fmt.(list ~sep:comma string)
25
-
pkgs
23
+
Fmt.(list ~sep:comma string) pkgs
26
24
| Opam_repo_error e -> Fmt.pf ppf "Opam repo error: %a" Opam_repo.pp_error e
27
25
28
26
let error_hint = function
29
27
| Config_error _ ->
30
-
Some "Run 'monopam init --handle <your-handle>' to create a workspace."
31
-
| Git_error (Git_cli.Dirty_worktree _) ->
28
+
Some
29
+
"Run 'monopam init --handle <your-handle>' to create a workspace."
30
+
| Git_error (Git.Dirty_worktree _) ->
32
31
Some "Commit or stash your changes first: git status"
33
-
| Git_error (Git_cli.Command_failed (cmd, _))
32
+
| Git_error (Git.Command_failed (cmd, _))
34
33
when String.starts_with ~prefix:"git clone" cmd ->
35
34
Some "Check the URL is correct and you have network access."
36
-
| Git_error (Git_cli.Command_failed (cmd, _))
35
+
| Git_error (Git.Command_failed (cmd, _))
37
36
when String.starts_with ~prefix:"git pull" cmd ->
38
37
Some "Check your network connection. Try: git fetch origin"
39
38
| Git_error _ -> None
···
46
45
| Workspace_exists _ ->
47
46
Some "Use a different directory, or remove the existing workspace."
48
47
| Not_a_workspace _ ->
49
-
Some
50
-
"Run 'monopam init --handle <your-handle>' to create a workspace here."
48
+
Some "Run 'monopam init --handle <your-handle>' to create a workspace here."
51
49
| Package_not_found (pkg, handle) ->
52
-
Some
53
-
(Fmt.str
54
-
"Run 'monopam verse pull %s' to sync their opam repo, then check \
55
-
package name: %s"
56
-
handle pkg)
50
+
Some (Fmt.str "Run 'monopam verse pull %s' to sync their opam repo, then check package name: %s" handle pkg)
57
51
| Package_already_exists pkgs ->
58
-
Some
59
-
(Fmt.str "Remove conflicting packages first:\n %s"
60
-
(String.concat "\n "
61
-
(List.map (fun p -> "rm -rf opam-repo/packages/" ^ p) pkgs)))
52
+
Some (Fmt.str "Remove conflicting packages first:\n %s"
53
+
(String.concat "\n " (List.map (fun p -> "rm -rf opam-repo/packages/" ^ p) pkgs)))
62
54
| Opam_repo_error _ -> None
63
55
64
56
let pp_error_with_hint ppf e =
···
73
65
local_path : Fpath.t;
74
66
cloned : bool;
75
67
clean : bool option;
76
-
ahead_behind : Git_cli.ahead_behind option;
68
+
ahead_behind : Git.ahead_behind option;
77
69
}
78
70
79
71
type status = {
···
188
180
Logs.info (fun m -> m "Cloning monorepo to %a" Fpath.pp mono_path);
189
181
let mono_url = Uri.of_string member.monorepo in
190
182
match
191
-
Git_cli.clone ~proc ~fs ~url:mono_url
183
+
Git.clone ~proc ~fs ~url:mono_url
192
184
~branch:Verse_config.default_branch mono_path
193
185
with
194
186
| Error e ->
195
-
Logs.err (fun m ->
196
-
m "Monorepo clone failed: %a" Git_cli.pp_error e);
187
+
Logs.err (fun m -> m "Monorepo clone failed: %a" Git.pp_error e);
197
188
Error (Git_error e)
198
189
| Ok () -> (
199
190
Logs.info (fun m -> m "Monorepo cloned");
···
203
194
m "Cloning opam repo to %a" Fpath.pp opam_path);
204
195
let opam_url = Uri.of_string member.opamrepo in
205
196
match
206
-
Git_cli.clone ~proc ~fs ~url:opam_url
197
+
Git.clone ~proc ~fs ~url:opam_url
207
198
~branch:Verse_config.default_branch opam_path
208
199
with
209
200
| Error e ->
210
201
Logs.err (fun m ->
211
-
m "Opam repo clone failed: %a" Git_cli.pp_error e);
202
+
m "Opam repo clone failed: %a" Git.pp_error e);
212
203
Error (Git_error e)
213
204
| Ok () -> (
214
205
Logs.info (fun m -> m "Opam repo cloned");
···
256
247
let local_path =
257
248
Fpath.(Verse_config.verse_path config / handle)
258
249
in
259
-
let cloned = Git_cli.is_repo ~proc ~fs local_path in
250
+
let cloned = Git.is_repo ~proc ~fs local_path in
260
251
let clean =
261
-
if cloned then
262
-
Some (not (Git_cli.is_dirty ~proc ~fs local_path))
252
+
if cloned then Some (not (Git.is_dirty ~proc ~fs local_path))
263
253
else None
264
254
in
265
255
let ahead_behind =
266
256
if cloned then
267
-
match Git_cli.ahead_behind ~proc ~fs local_path with
257
+
match Git.ahead_behind ~proc ~fs local_path with
268
258
| Ok ab -> Some ab
269
259
| Error _ -> None
270
260
else None
···
287
277
| Error msg -> Error (Registry_error msg)
288
278
| Ok registry -> Ok registry.members
289
279
290
-
(** Clone or fetch+reset a single git repo. Returns Ok true if cloned, Ok false
291
-
if reset. Uses fetch+reset instead of pull since verse repos should not have
292
-
local changes. *)
280
+
(** Clone or fetch+reset a single git repo. Returns Ok true if cloned, Ok false if reset.
281
+
Uses fetch+reset instead of pull since verse repos should not have local changes. *)
293
282
let clone_or_reset_repo ~proc ~fs ~url ~branch path =
294
-
if Git_cli.is_repo ~proc ~fs path then begin
295
-
match Git_cli.fetch_and_reset ~proc ~fs ~branch path with
283
+
if Git.is_repo ~proc ~fs path then begin
284
+
match Git.fetch_and_reset ~proc ~fs ~branch path with
296
285
| Error e -> Error e
297
286
| Ok () -> Ok false
298
287
end
299
288
else begin
300
289
let url = Uri.of_string url in
301
-
match Git_cli.clone ~proc ~fs ~url ~branch path with
290
+
match Git.clone ~proc ~fs ~url ~branch path with
302
291
| Error e -> Error e
303
292
| Ok () -> Ok true
304
293
end
···
322
311
let verse_dir = Verse_config.verse_path config in
323
312
ensure_dir ~fs verse_dir;
324
313
Logs.info (fun m -> m "Syncing %d members" (List.length members));
325
-
(* Sync all members in parallel *)
326
314
let errors =
327
-
Eio.Fiber.List.filter_map ~max_fibers:4
315
+
List.filter_map
328
316
(fun (member : Verse_registry.member) ->
329
317
let h = member.handle in
330
318
let mono_path = Fpath.(verse_dir / h) in
···
332
320
(* Clone or fetch+reset monorepo *)
333
321
Logs.info (fun m -> m "Syncing %s monorepo" h);
334
322
let mono_branch =
335
-
Option.value ~default:Verse_config.default_branch
336
-
member.monorepo_branch
323
+
Option.value ~default:Verse_config.default_branch member.monorepo_branch
337
324
in
338
325
let mono_result =
339
326
clone_or_reset_repo ~proc ~fs ~url:member.monorepo
···
349
336
None
350
337
| Error e ->
351
338
Logs.warn (fun m ->
352
-
m " Failed %s monorepo: %a" h Git_cli.pp_error e);
353
-
Some (Fmt.str "%s monorepo: %a" h Git_cli.pp_error e)
339
+
m " Failed %s monorepo: %a" h Git.pp_error e);
340
+
Some (Fmt.str "%s monorepo: %a" h Git.pp_error e)
354
341
in
355
342
(* Clone or fetch+reset opam repo *)
356
343
Logs.info (fun m -> m "Syncing %s opam repo" h);
357
344
let opam_branch =
358
-
Option.value ~default:Verse_config.default_branch
359
-
member.opamrepo_branch
345
+
Option.value ~default:Verse_config.default_branch member.opamrepo_branch
360
346
in
361
347
let opam_result =
362
348
clone_or_reset_repo ~proc ~fs ~url:member.opamrepo
···
372
358
None
373
359
| Error e ->
374
360
Logs.warn (fun m ->
375
-
m " Failed %s opam repo: %a" h Git_cli.pp_error e);
376
-
Some (Fmt.str "%s opam: %a" h Git_cli.pp_error e)
361
+
m " Failed %s opam repo: %a" h Git.pp_error e);
362
+
Some (Fmt.str "%s opam: %a" h Git.pp_error e)
377
363
in
378
364
match (mono_err, opam_err) with
379
365
| None, None -> None
···
382
368
members
383
369
in
384
370
if errors = [] then Ok ()
385
-
else Error (Git_error (Git_cli.Io_error (String.concat "; " errors)))
371
+
else Error (Git_error (Git.Io_error (String.concat "; " errors)))
386
372
end
387
373
388
374
let sync ~proc ~fs ~config () =
···
392
378
(** Scan a monorepo for subtree directories. Returns a list of directory names
393
379
that look like subtrees (have commits). *)
394
380
let scan_subtrees ~proc ~fs monorepo_path =
395
-
if not (Git_cli.is_repo ~proc ~fs monorepo_path) then []
381
+
if not (Git.is_repo ~proc ~fs monorepo_path) then []
396
382
else
397
383
let eio_path = Eio.Path.(fs / Fpath.to_string monorepo_path) in
398
384
try
···
414
400
List.iter
415
401
(fun handle ->
416
402
let member_mono = Fpath.(verse_path / handle) in
417
-
if Git_cli.is_repo ~proc ~fs member_mono then begin
403
+
if Git.is_repo ~proc ~fs member_mono then begin
418
404
let subtrees = scan_subtrees ~proc ~fs member_mono in
419
405
List.iter
420
406
(fun subtree ->
···
428
414
tracked_handles;
429
415
subtree_map
430
416
417
+
(** Result of a fork operation. *)
431
418
type fork_result = {
432
419
packages_forked : string list; (** Package names that were forked *)
433
420
source_handle : string; (** Handle of the verse member we forked from *)
434
421
fork_url : string; (** URL of the fork *)
435
422
upstream_url : string; (** Original dev-repo URL (upstream) *)
436
-
subtree_name : string;
437
-
(** Name for the subtree directory (derived from fork URL) *)
423
+
subtree_name : string; (** Name for the subtree directory (derived from fork URL) *)
438
424
}
439
-
(** Result of a fork operation. *)
440
425
441
426
(** Extract subtree name from a URL (last path component without .git suffix) *)
442
427
let subtree_name_from_url url =
443
428
let uri = Uri.of_string url in
444
429
let path = Uri.path uri in
445
430
(* Remove leading slash and .git suffix *)
446
-
let path =
447
-
if String.length path > 0 && path.[0] = '/' then
448
-
String.sub path 1 (String.length path - 1)
449
-
else path
450
-
in
451
-
let path =
452
-
if String.ends_with ~suffix:".git" path then
453
-
String.sub path 0 (String.length path - 4)
454
-
else path
455
-
in
431
+
let path = if String.length path > 0 && path.[0] = '/' then
432
+
String.sub path 1 (String.length path - 1)
433
+
else path in
434
+
let path = if String.ends_with ~suffix:".git" path then
435
+
String.sub path 0 (String.length path - 4)
436
+
else path in
456
437
(* Get last component *)
457
438
match String.rindex_opt path '/' with
458
439
| Some i -> String.sub path (i + 1) (String.length path - i - 1)
459
440
| None -> path
460
441
461
442
let pp_fork_result ppf r =
462
-
Fmt.pf ppf
463
-
"@[<v>Forked %d package(s) from %s:@,\
464
-
\ @[<v>%a@]@,\
465
-
Fork URL: %s@,\
466
-
Upstream: %s@,\
467
-
Subtree: %s@]"
443
+
Fmt.pf ppf "@[<v>Forked %d package(s) from %s:@, @[<v>%a@]@,Fork URL: %s@,Upstream: %s@,Subtree: %s@]"
468
444
(List.length r.packages_forked)
469
445
r.source_handle
470
-
Fmt.(list ~sep:cut string)
471
-
r.packages_forked r.fork_url r.upstream_url r.subtree_name
446
+
Fmt.(list ~sep:cut string) r.packages_forked
447
+
r.fork_url
448
+
r.upstream_url
449
+
r.subtree_name
472
450
473
451
(** Fork a package from a verse member's opam repo into your workspace.
474
452
···
487
465
(* Ensure the member exists and their opam-repo is synced *)
488
466
match Verse_registry.clone_or_pull ~proc ~fs ~config () with
489
467
| Error msg -> Error (Registry_error msg)
490
-
| Ok registry -> (
468
+
| Ok registry ->
491
469
match Verse_registry.find_member registry ~handle with
492
470
| None -> Error (Member_not_found handle)
493
-
| Some _member -> (
471
+
| Some _member ->
494
472
let verse_path = Verse_config.verse_path config in
495
473
let member_opam_repo = Fpath.(verse_path / (handle ^ "-opam")) in
496
474
(* Check if their opam repo exists locally *)
497
475
if not (is_directory ~fs member_opam_repo) then
498
-
Error
499
-
(Config_error
500
-
(Fmt.str
501
-
"Member's opam repo not synced. Run: monopam verse pull %s"
502
-
handle))
476
+
Error (Config_error (Fmt.str "Member's opam repo not synced. Run: monopam verse pull %s" handle))
503
477
else
504
478
(* Scan their opam repo to find the package *)
505
479
let pkgs, _errors = Opam_repo.scan_all ~fs member_opam_repo in
···
519
493
let user_opam_repo = Verse_config.opam_repo_path config in
520
494
let conflicts =
521
495
List.filter
522
-
(fun name ->
523
-
Opam_repo.package_exists ~fs ~repo_path:user_opam_repo
524
-
~name)
496
+
(fun name -> Opam_repo.package_exists ~fs ~repo_path:user_opam_repo ~name)
525
497
pkg_names
526
498
in
527
-
if conflicts <> [] then Error (Package_already_exists conflicts)
499
+
if conflicts <> [] then
500
+
Error (Package_already_exists conflicts)
528
501
else if dry_run then
529
502
(* Dry run - just report what would be done *)
530
-
Ok
531
-
{
532
-
packages_forked = pkg_names;
533
-
source_handle = handle;
534
-
fork_url;
535
-
upstream_url;
536
-
subtree_name;
537
-
}
503
+
Ok { packages_forked = pkg_names; source_handle = handle; fork_url; upstream_url; subtree_name }
538
504
else begin
539
505
(* Fork each package *)
540
506
let results =
···
543
509
let name = Package.name p in
544
510
let version = Package.version p in
545
511
let opam_path =
546
-
Fpath.(
547
-
member_opam_repo / "packages" / name
548
-
/ (name ^ "." ^ version)
549
-
/ "opam")
512
+
Fpath.(member_opam_repo / "packages" / name / (name ^ "." ^ version) / "opam")
550
513
in
551
514
match Opam_repo.read_opam_file ~fs opam_path with
552
515
| Error e -> Error (Opam_repo_error e)
553
-
| Ok content -> (
516
+
| Ok content ->
554
517
(* Replace dev-repo and url with fork URL *)
555
-
let new_content =
556
-
Opam_repo.replace_dev_repo_url content
557
-
~new_url:fork_url
558
-
in
518
+
let new_content = Opam_repo.replace_dev_repo_url content ~new_url:fork_url in
559
519
(* Write to user's opam-repo *)
560
-
match
561
-
Opam_repo.write_package ~fs
562
-
~repo_path:user_opam_repo ~name ~version
563
-
~content:new_content
564
-
with
520
+
match Opam_repo.write_package ~fs ~repo_path:user_opam_repo ~name ~version ~content:new_content with
565
521
| Error e -> Error (Opam_repo_error e)
566
-
| Ok () -> Ok name))
522
+
| Ok () -> Ok name)
567
523
related_pkgs
568
524
in
569
525
(* Check for errors *)
570
526
match List.find_opt Result.is_error results with
571
527
| Some (Error e) -> Error e
572
528
| _ ->
573
-
let forked_names =
574
-
List.filter_map
575
-
(function Ok n -> Some n | Error _ -> None)
576
-
results
577
-
in
578
-
Ok
579
-
{
580
-
packages_forked = forked_names;
581
-
source_handle = handle;
582
-
fork_url;
583
-
upstream_url;
584
-
subtree_name;
585
-
}
586
-
end))
529
+
let forked_names = List.filter_map (function Ok n -> Some n | Error _ -> None) results in
530
+
Ok { packages_forked = forked_names; source_handle = handle; fork_url; upstream_url; subtree_name }
531
+
end
+6
-9
lib/verse.mli
+6
-9
lib/verse.mli
···
7
7
8
8
type error =
9
9
| Config_error of string (** Configuration loading/saving error *)
10
-
| Git_error of Git_cli.error (** Git operation failed *)
10
+
| Git_error of Git.error (** Git operation failed *)
11
11
| Registry_error of string (** Registry clone/pull/parse error *)
12
12
| Member_not_found of string (** Handle not in registry *)
13
13
| Workspace_exists of Fpath.t (** Workspace already initialized *)
14
14
| Not_a_workspace of Fpath.t (** Not a opamverse workspace *)
15
-
| Package_not_found of string * string
16
-
(** Package not found in member's repo: (package, handle) *)
17
-
| Package_already_exists of string list
18
-
(** Packages already exist in user's opam repo *)
15
+
| Package_not_found of string * string (** Package not found in member's repo: (package, handle) *)
16
+
| Package_already_exists of string list (** Packages already exist in user's opam repo *)
19
17
| Opam_repo_error of Opam_repo.error (** Error reading/writing opam files *)
20
18
21
19
val pp_error : error Fmt.t
···
36
34
local_path : Fpath.t; (** Local path under verse/ *)
37
35
cloned : bool; (** Whether the monorepo is cloned locally *)
38
36
clean : bool option; (** Whether the clone is clean (None if not cloned) *)
39
-
ahead_behind : Git_cli.ahead_behind option;
37
+
ahead_behind : Git.ahead_behind option;
40
38
(** Ahead/behind status (None if not cloned) *)
41
39
}
42
40
(** Status of a member's monorepo in the workspace. *)
···
151
149
152
150
(** {1 Forking} *)
153
151
152
+
(** Result of a fork operation. *)
154
153
type fork_result = {
155
154
packages_forked : string list; (** Package names that were forked *)
156
155
source_handle : string; (** Handle of the verse member we forked from *)
157
156
fork_url : string; (** URL of the fork *)
158
157
upstream_url : string; (** Original dev-repo URL (upstream) *)
159
-
subtree_name : string;
160
-
(** Name for the subtree directory (derived from fork URL) *)
158
+
subtree_name : string; (** Name for the subtree directory (derived from fork URL) *)
161
159
}
162
-
(** Result of a fork operation. *)
163
160
164
161
val pp_fork_result : fork_result Fmt.t
165
162
(** [pp_fork_result] formats a fork result. *)
+3
-3
lib/verse_config.ml
+3
-3
lib/verse_config.ml
···
1
1
(** Verse_config is now an alias for Config.
2
2
3
-
This module is kept for backwards compatibility. All functionality has been
4
-
unified into Config. *)
3
+
This module is kept for backwards compatibility.
4
+
All functionality has been unified into Config. *)
5
5
6
6
include Config
7
7
8
-
type package_override = Config.Package_config.t
9
8
(** Legacy type alias for package overrides *)
9
+
type package_override = Config.Package_config.t
+3
-3
lib/verse_config.mli
+3
-3
lib/verse_config.mli
···
1
1
(** Verse_config is now an alias for Config.
2
2
3
-
This module is kept for backwards compatibility. All functionality has been
4
-
unified into Config.
3
+
This module is kept for backwards compatibility.
4
+
All functionality has been unified into Config.
5
5
6
6
@deprecated Use {!Config} directly. *)
7
7
8
8
include module type of Config
9
9
10
-
type package_override = Config.Package_config.t
11
10
(** Legacy type alias for package overrides.
12
11
@deprecated Use {!Config.Package_config.t} instead. *)
12
+
type package_override = Config.Package_config.t
+15
-23
lib/verse_registry.ml
+15
-23
lib/verse_registry.ml
···
6
6
opamrepo : string;
7
7
opamrepo_branch : string option;
8
8
}
9
-
10
9
type t = { name : string; description : string option; members : member list }
11
10
12
11
let default_url = "https://tangled.org/eeg.cl.cam.ac.uk/opamverse"
···
22
21
23
22
(** Encode a URL with optional branch suffix. *)
24
23
let encode_url_with_branch url branch =
25
-
match branch with None -> url | Some b -> url ^ "#" ^ b
24
+
match branch with
25
+
| None -> url
26
+
| Some b -> url ^ "#" ^ b
26
27
27
28
let pp_member ppf m =
28
29
let mono_str = encode_url_with_branch m.monorepo m.monorepo_branch in
29
30
let opam_str = encode_url_with_branch m.opamrepo m.opamrepo_branch in
30
31
let name_str = match m.name with Some n -> n | None -> m.handle in
31
-
Fmt.pf ppf "@[<hov 2>%s (%s) ->@ mono:%s@ opam:%s@]" name_str m.handle
32
-
mono_str opam_str
32
+
Fmt.pf ppf "@[<hov 2>%s (%s) ->@ mono:%s@ opam:%s@]" name_str m.handle mono_str opam_str
33
33
34
34
let pp ppf t =
35
35
Fmt.pf ppf "@[<v>registry: %s%a@,members:@, @[<v>%a@]@]" t.name
36
-
Fmt.(option (fun ppf s -> pf ppf "@,description: %s" s))
37
-
t.description
36
+
Fmt.(option (fun ppf s -> pf ppf "@,description: %s" s)) t.description
38
37
Fmt.(list ~sep:cut pp_member)
39
38
t.members
40
39
···
57
56
{ handle; name; monorepo; monorepo_branch; opamrepo; opamrepo_branch })
58
57
|> mem "handle" string ~enc:(fun (m : member) -> m.handle)
59
58
|> opt_mem "name" string ~enc:(fun (m : member) -> m.name)
60
-
|> mem "monorepo" string ~enc:(fun (m : member) ->
61
-
encode_url_with_branch m.monorepo m.monorepo_branch)
62
-
|> mem "opamrepo" string ~enc:(fun (m : member) ->
63
-
encode_url_with_branch m.opamrepo m.opamrepo_branch)
59
+
|> mem "monorepo" string ~enc:(fun (m : member) -> encode_url_with_branch m.monorepo m.monorepo_branch)
60
+
|> mem "opamrepo" string ~enc:(fun (m : member) -> encode_url_with_branch m.opamrepo m.opamrepo_branch)
64
61
|> finish))
65
62
66
63
type registry_info = { r_name : string; r_description : string option }
···
77
74
Tomlt.(
78
75
Table.(
79
76
obj (fun registry members ->
80
-
{
81
-
name = registry.r_name;
82
-
description = registry.r_description;
83
-
members = Option.value ~default:[] members;
84
-
})
85
-
|> mem "registry" registry_info_codec ~enc:(fun t ->
86
-
{ r_name = t.name; r_description = t.description })
77
+
{ name = registry.r_name; description = registry.r_description; members = Option.value ~default:[] members })
78
+
|> mem "registry" registry_info_codec ~enc:(fun t -> { r_name = t.name; r_description = t.description })
87
79
|> opt_mem "members" (list member_codec) ~enc:(fun t ->
88
80
match t.members with [] -> None | ms -> Some ms)
89
81
|> finish))
···
125
117
let exists =
126
118
let path = Eio.Path.(fs / Fpath.to_string registry_path) in
127
119
match Eio.Path.kind ~follow:true path with
128
-
| `Directory -> Git_cli.is_repo ~proc ~fs registry_path
120
+
| `Directory -> Git.is_repo ~proc ~fs registry_path
129
121
| _ -> false
130
122
| exception _ -> false
131
123
in
132
124
if exists then begin
133
125
Logs.info (fun m -> m "Registry exists, pulling updates...");
134
126
(* Pull updates, but don't fail if pull fails *)
135
-
(match Git_cli.pull ~proc ~fs registry_path with
127
+
(match Git.pull ~proc ~fs registry_path with
136
128
| Ok () -> Logs.info (fun m -> m "Registry pull succeeded")
137
129
| Error e ->
138
130
Logs.warn (fun m ->
139
-
m "Registry pull failed: %a (using cached)" Git_cli.pp_error e));
131
+
m "Registry pull failed: %a (using cached)" Git.pp_error e));
140
132
Logs.info (fun m -> m "Loading registry from %a" Fpath.pp registry_toml);
141
133
load ~fs registry_toml
142
134
end
···
149
141
(* Try to clone the registry *)
150
142
let url = Uri.of_string default_url in
151
143
let branch = "main" in
152
-
match Git_cli.clone ~proc ~fs ~url ~branch registry_path with
144
+
match Git.clone ~proc ~fs ~url ~branch registry_path with
153
145
| Ok () ->
154
146
Logs.info (fun m -> m "Registry cloned successfully");
155
147
load ~fs registry_toml
156
148
| Error e ->
157
-
Logs.warn (fun m -> m "Registry clone failed: %a" Git_cli.pp_error e);
149
+
Logs.warn (fun m -> m "Registry clone failed: %a" Git.pp_error e);
158
150
Logs.info (fun m -> m "Creating empty local registry...");
159
151
(* Clone failed - create local registry directory with empty registry *)
160
152
let registry_eio = Eio.Path.(fs / Fpath.to_string registry_path) in
161
153
(try Eio.Path.mkdirs ~perm:0o755 registry_eio with Eio.Io _ -> ());
162
154
(* Initialize as git repo *)
163
-
(match Git_cli.init ~proc ~fs registry_path with
155
+
(match Git.init ~proc ~fs registry_path with
164
156
| Ok () -> ()
165
157
| Error _ -> ());
166
158
(* Create empty registry file *)
+4
-6
lib/verse_registry.mli
+4
-6
lib/verse_registry.mli
···
9
9
handle : string; (** Tangled handle (e.g., "alice.bsky.social") *)
10
10
name : string option; (** Display name (e.g., "Alice Smith") *)
11
11
monorepo : string; (** Git URL of the member's monorepo *)
12
-
monorepo_branch : string option;
13
-
(** Optional branch for monorepo (from URL#branch) *)
12
+
monorepo_branch : string option; (** Optional branch for monorepo (from URL#branch) *)
14
13
opamrepo : string; (** Git URL of the member's opam overlay repository *)
15
-
opamrepo_branch : string option;
16
-
(** Optional branch for opam repo (from URL#branch) *)
14
+
opamrepo_branch : string option; (** Optional branch for opam repo (from URL#branch) *)
17
15
}
18
16
(** A registry member entry.
19
17
20
-
URLs may include a [#branch] suffix to specify a non-default branch. For
21
-
example, ["https://github.com/user/repo#develop"]. *)
18
+
URLs may include a [#branch] suffix to specify a non-default branch.
19
+
For example, ["https://github.com/user/repo#develop"]. *)
22
20
23
21
type t = {
24
22
name : string; (** Registry name *)
-221
test/test_remote_cache.ml
-221
test/test_remote_cache.ml
···
1
-
(* Tests for Remote_cache module *)
2
-
3
-
module Remote_cache = Monopam.Remote_cache
4
-
5
-
let test_url = Uri.of_string "https://github.com/ocaml/ocaml.git"
6
-
let test_url2 = Uri.of_string "https://github.com/mirage/mirage.git"
7
-
8
-
(* Mock clock for deterministic testing *)
9
-
let make_mock_clock () =
10
-
let time = ref 0.0 in
11
-
let now () = !time in
12
-
let advance dt = time := !time +. dt in
13
-
let set t = time := t in
14
-
(now, advance, set)
15
-
16
-
let test_empty_cache () =
17
-
let now, _, _ = make_mock_clock () in
18
-
let cache = Remote_cache.create ~now () in
19
-
Alcotest.(check int) "empty cache" 0 (Remote_cache.size cache);
20
-
Alcotest.(check (option string))
21
-
"get from empty" None
22
-
(Remote_cache.get cache ~url:test_url ~branch:"main")
23
-
24
-
let test_set_get () =
25
-
let now, _, _ = make_mock_clock () in
26
-
let cache = Remote_cache.create ~now () in
27
-
Remote_cache.set cache ~url:test_url ~branch:"main" ~hash:"abc123";
28
-
Alcotest.(check int) "size after set" 1 (Remote_cache.size cache);
29
-
Alcotest.(check (option string))
30
-
"get after set" (Some "abc123")
31
-
(Remote_cache.get cache ~url:test_url ~branch:"main")
32
-
33
-
let test_different_branches () =
34
-
let now, _, _ = make_mock_clock () in
35
-
let cache = Remote_cache.create ~now () in
36
-
Remote_cache.set cache ~url:test_url ~branch:"main" ~hash:"main123";
37
-
Remote_cache.set cache ~url:test_url ~branch:"develop" ~hash:"dev456";
38
-
Alcotest.(check int) "size with two branches" 2 (Remote_cache.size cache);
39
-
Alcotest.(check (option string))
40
-
"get main" (Some "main123")
41
-
(Remote_cache.get cache ~url:test_url ~branch:"main");
42
-
Alcotest.(check (option string))
43
-
"get develop" (Some "dev456")
44
-
(Remote_cache.get cache ~url:test_url ~branch:"develop")
45
-
46
-
let test_different_urls () =
47
-
let now, _, _ = make_mock_clock () in
48
-
let cache = Remote_cache.create ~now () in
49
-
Remote_cache.set cache ~url:test_url ~branch:"main" ~hash:"ocaml123";
50
-
Remote_cache.set cache ~url:test_url2 ~branch:"main" ~hash:"mirage456";
51
-
Alcotest.(check int) "size with two urls" 2 (Remote_cache.size cache);
52
-
Alcotest.(check (option string))
53
-
"get ocaml" (Some "ocaml123")
54
-
(Remote_cache.get cache ~url:test_url ~branch:"main");
55
-
Alcotest.(check (option string))
56
-
"get mirage" (Some "mirage456")
57
-
(Remote_cache.get cache ~url:test_url2 ~branch:"main")
58
-
59
-
let test_update_existing () =
60
-
let now, _, _ = make_mock_clock () in
61
-
let cache = Remote_cache.create ~now () in
62
-
Remote_cache.set cache ~url:test_url ~branch:"main" ~hash:"old123";
63
-
Remote_cache.set cache ~url:test_url ~branch:"main" ~hash:"new456";
64
-
Alcotest.(check int) "size after update" 1 (Remote_cache.size cache);
65
-
Alcotest.(check (option string))
66
-
"get updated value" (Some "new456")
67
-
(Remote_cache.get cache ~url:test_url ~branch:"main")
68
-
69
-
let test_expiration () =
70
-
let now, advance, _ = make_mock_clock () in
71
-
let ttl = 60.0 in
72
-
let cache = Remote_cache.create ~ttl ~now () in
73
-
Remote_cache.set cache ~url:test_url ~branch:"main" ~hash:"abc123";
74
-
(* Still valid *)
75
-
Alcotest.(check (option string))
76
-
"before expiry" (Some "abc123")
77
-
(Remote_cache.get cache ~url:test_url ~branch:"main");
78
-
(* Advance time but still within TTL *)
79
-
advance 30.0;
80
-
Alcotest.(check (option string))
81
-
"half way" (Some "abc123")
82
-
(Remote_cache.get cache ~url:test_url ~branch:"main");
83
-
(* Advance past TTL *)
84
-
advance 31.0;
85
-
Alcotest.(check (option string))
86
-
"after expiry" None
87
-
(Remote_cache.get cache ~url:test_url ~branch:"main")
88
-
89
-
let test_expiration_boundary () =
90
-
let now, advance, _ = make_mock_clock () in
91
-
let ttl = 60.0 in
92
-
let cache = Remote_cache.create ~ttl ~now () in
93
-
Remote_cache.set cache ~url:test_url ~branch:"main" ~hash:"abc123";
94
-
(* Just before TTL - still valid *)
95
-
advance 59.999;
96
-
Alcotest.(check (option string))
97
-
"just before expiry" (Some "abc123")
98
-
(Remote_cache.get cache ~url:test_url ~branch:"main");
99
-
(* Exactly at TTL boundary - expired (uses strict > comparison) *)
100
-
advance 0.001;
101
-
Alcotest.(check (option string))
102
-
"at boundary" None
103
-
(Remote_cache.get cache ~url:test_url ~branch:"main")
104
-
105
-
let test_refresh_extends_ttl () =
106
-
let now, advance, _ = make_mock_clock () in
107
-
let ttl = 60.0 in
108
-
let cache = Remote_cache.create ~ttl ~now () in
109
-
Remote_cache.set cache ~url:test_url ~branch:"main" ~hash:"abc123";
110
-
(* Advance 50 seconds *)
111
-
advance 50.0;
112
-
Alcotest.(check (option string))
113
-
"still valid" (Some "abc123")
114
-
(Remote_cache.get cache ~url:test_url ~branch:"main");
115
-
(* Refresh the entry *)
116
-
Remote_cache.set cache ~url:test_url ~branch:"main" ~hash:"abc123";
117
-
(* Advance another 50 seconds (would be expired without refresh) *)
118
-
advance 50.0;
119
-
Alcotest.(check (option string))
120
-
"valid after refresh" (Some "abc123")
121
-
(Remote_cache.get cache ~url:test_url ~branch:"main")
122
-
123
-
let test_clear () =
124
-
let now, _, _ = make_mock_clock () in
125
-
let cache = Remote_cache.create ~now () in
126
-
Remote_cache.set cache ~url:test_url ~branch:"main" ~hash:"abc123";
127
-
Remote_cache.set cache ~url:test_url2 ~branch:"main" ~hash:"def456";
128
-
Alcotest.(check int) "before clear" 2 (Remote_cache.size cache);
129
-
Remote_cache.clear cache;
130
-
Alcotest.(check int) "after clear" 0 (Remote_cache.size cache);
131
-
Alcotest.(check (option string))
132
-
"get after clear" None
133
-
(Remote_cache.get cache ~url:test_url ~branch:"main")
134
-
135
-
let test_serialization () =
136
-
let now, _, _ = make_mock_clock () in
137
-
let cache = Remote_cache.create ~now () in
138
-
Remote_cache.set cache ~url:test_url ~branch:"main" ~hash:"abc123";
139
-
Remote_cache.set cache ~url:test_url ~branch:"develop" ~hash:"def456";
140
-
let serialized = Remote_cache.to_string cache in
141
-
(* Reload from serialized *)
142
-
let cache2 = Remote_cache.create_from_string ~now serialized in
143
-
Alcotest.(check int) "size after reload" 2 (Remote_cache.size cache2);
144
-
Alcotest.(check (option string))
145
-
"main after reload" (Some "abc123")
146
-
(Remote_cache.get cache2 ~url:test_url ~branch:"main");
147
-
Alcotest.(check (option string))
148
-
"develop after reload" (Some "def456")
149
-
(Remote_cache.get cache2 ~url:test_url ~branch:"develop")
150
-
151
-
let test_serialization_excludes_expired () =
152
-
let now, advance, set = make_mock_clock () in
153
-
let ttl = 60.0 in
154
-
let cache = Remote_cache.create ~ttl ~now () in
155
-
Remote_cache.set cache ~url:test_url ~branch:"main" ~hash:"fresh";
156
-
advance 30.0;
157
-
Remote_cache.set cache ~url:test_url ~branch:"develop" ~hash:"newer";
158
-
(* Advance so first entry is expired *)
159
-
advance 40.0;
160
-
let serialized = Remote_cache.to_string cache in
161
-
(* Reset time and reload *)
162
-
set 70.0;
163
-
let cache2 = Remote_cache.create_from_string ~ttl ~now serialized in
164
-
(* Only the newer entry should survive *)
165
-
Alcotest.(check int) "only fresh entry" 1 (Remote_cache.size cache2);
166
-
Alcotest.(check (option string))
167
-
"expired not saved" None
168
-
(Remote_cache.get cache2 ~url:test_url ~branch:"main");
169
-
Alcotest.(check (option string))
170
-
"fresh saved" (Some "newer")
171
-
(Remote_cache.get cache2 ~url:test_url ~branch:"develop")
172
-
173
-
let test_many_entries () =
174
-
let now, _, _ = make_mock_clock () in
175
-
let cache = Remote_cache.create ~now () in
176
-
for i = 0 to 999 do
177
-
let url =
178
-
Uri.of_string (Printf.sprintf "https://example.com/repo%d.git" i)
179
-
in
180
-
Remote_cache.set cache ~url ~branch:"main" ~hash:(Printf.sprintf "hash%d" i)
181
-
done;
182
-
Alcotest.(check int) "1000 entries" 1000 (Remote_cache.size cache);
183
-
(* Verify random access is O(1) - just check some entries *)
184
-
let url = Uri.of_string "https://example.com/repo500.git" in
185
-
Alcotest.(check (option string))
186
-
"get entry 500" (Some "hash500")
187
-
(Remote_cache.get cache ~url ~branch:"main")
188
-
189
-
let test_default_ttl () =
190
-
Alcotest.(check (float 0.1))
191
-
"default ttl is 5 minutes" 300.0 Remote_cache.default_ttl
192
-
193
-
let () =
194
-
Alcotest.run "Remote_cache"
195
-
[
196
-
( "basic",
197
-
[
198
-
Alcotest.test_case "empty cache" `Quick test_empty_cache;
199
-
Alcotest.test_case "set and get" `Quick test_set_get;
200
-
Alcotest.test_case "different branches" `Quick test_different_branches;
201
-
Alcotest.test_case "different urls" `Quick test_different_urls;
202
-
Alcotest.test_case "update existing" `Quick test_update_existing;
203
-
Alcotest.test_case "clear" `Quick test_clear;
204
-
] );
205
-
( "expiration",
206
-
[
207
-
Alcotest.test_case "basic expiration" `Quick test_expiration;
208
-
Alcotest.test_case "boundary" `Quick test_expiration_boundary;
209
-
Alcotest.test_case "refresh extends ttl" `Quick
210
-
test_refresh_extends_ttl;
211
-
Alcotest.test_case "default ttl" `Quick test_default_ttl;
212
-
] );
213
-
( "serialization",
214
-
[
215
-
Alcotest.test_case "roundtrip" `Quick test_serialization;
216
-
Alcotest.test_case "excludes expired" `Quick
217
-
test_serialization_excludes_expired;
218
-
] );
219
-
( "performance",
220
-
[ Alcotest.test_case "1000 entries" `Quick test_many_entries ] );
221
-
]